From 5b7eafd0f00a16d78f99a27f5c7d5a0de77dc7e6 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Wed, 21 Jul 2010 09:46:51 +0200 Subject: Imported Upstream snapshot 8.3~beta0+13298 --- theories/Arith/Arith.v | 2 +- theories/Arith/Arith_base.v | 2 +- theories/Arith/Between.v | 8 +- theories/Arith/Bool_nat.v | 2 +- theories/Arith/Compare.v | 4 +- theories/Arith/Compare_dec.v | 230 ++- theories/Arith/Div2.v | 6 +- theories/Arith/EqNat.v | 21 +- theories/Arith/Euclid.v | 2 +- theories/Arith/Even.v | 22 +- theories/Arith/Factorial.v | 2 +- theories/Arith/Gt.v | 10 +- theories/Arith/Le.v | 20 +- theories/Arith/Lt.v | 29 +- theories/Arith/Max.v | 112 +- theories/Arith/Min.v | 116 +- theories/Arith/MinMax.v | 113 ++ theories/Arith/Minus.v | 8 +- theories/Arith/Mult.v | 107 +- theories/Arith/NatOrderedType.v | 64 + theories/Arith/Peano_dec.v | 2 +- theories/Arith/Plus.v | 16 +- theories/Arith/Wf_nat.v | 16 +- theories/Arith/vo.itarget | 23 + theories/Bool/Bool.v | 362 ++-- theories/Bool/BoolEq.v | 2 +- theories/Bool/Bvector.v | 90 +- theories/Bool/DecBool.v | 2 +- theories/Bool/IfProp.v | 2 +- theories/Bool/Sumbool.v | 10 +- theories/Bool/Zerob.v | 2 +- theories/Bool/vo.itarget | 7 + theories/Classes/EquivDec.v | 80 +- theories/Classes/Equivalence.v | 32 +- theories/Classes/Functions.v | 41 - theories/Classes/Init.v | 16 +- theories/Classes/Morphisms.v | 391 ++-- theories/Classes/Morphisms_Prop.v | 72 +- theories/Classes/Morphisms_Relations.v | 28 +- theories/Classes/RelationClasses.v | 193 +- theories/Classes/RelationPairs.v | 153 ++ theories/Classes/SetoidAxioms.v | 34 - theories/Classes/SetoidClass.v | 43 +- theories/Classes/SetoidDec.v | 43 +- theories/Classes/SetoidTactics.v | 108 +- theories/Classes/vo.itarget | 11 + theories/FSets/FMapAVL.v | 681 ++++--- theories/FSets/FMapFacts.v | 447 ++--- theories/FSets/FMapFullAVL.v | 275 +-- theories/FSets/FMapInterface.v | 162 +- theories/FSets/FMapList.v | 466 +++-- theories/FSets/FMapPositive.v | 267 +-- theories/FSets/FMapWeakList.v | 332 ++-- theories/FSets/FMaps.v | 2 +- theories/FSets/FSetAVL.v | 2033 +------------------- theories/FSets/FSetBridge.v | 316 +-- theories/FSets/FSetCompat.v | 410 ++++ theories/FSets/FSetDecide.v | 50 +- theories/FSets/FSetEqProperties.v | 327 ++-- theories/FSets/FSetFacts.v | 100 +- theories/FSets/FSetFullAVL.v | 1133 ----------- theories/FSets/FSetInterface.v | 108 +- theories/FSets/FSetList.v | 1263 +----------- theories/FSets/FSetPositive.v | 1173 +++++++++++ theories/FSets/FSetProperties.v | 224 ++- theories/FSets/FSetToFiniteSet.v | 27 +- theories/FSets/FSetWeakList.v | 945 +-------- theories/FSets/FSets.v | 3 +- theories/FSets/OrderedType.v | 587 ------ theories/FSets/OrderedTypeAlt.v | 128 -- theories/FSets/OrderedTypeEx.v | 269 --- theories/FSets/vo.itarget | 21 + theories/Init/Datatypes.v | 101 +- theories/Init/Logic.v | 63 +- theories/Init/Logic_Type.v | 25 +- theories/Init/Notations.v | 2 +- theories/Init/Peano.v | 11 +- theories/Init/Prelude.v | 11 +- theories/Init/Specif.v | 59 +- theories/Init/Tactics.v | 85 +- theories/Init/Wf.v | 17 +- theories/Init/vo.itarget | 9 + theories/Lists/List.v | 1202 ++++++------ theories/Lists/ListSet.v | 53 +- theories/Lists/ListTactics.v | 48 +- theories/Lists/MonoList.v | 269 --- theories/Lists/SetoidList.v | 929 ++++----- theories/Lists/StreamMemo.v | 48 +- theories/Lists/Streams.v | 8 +- theories/Lists/TheoryList.v | 50 +- theories/Lists/intro.tex | 3 - theories/Lists/vo.itarget | 7 + theories/Logic/Berardi.v | 8 +- theories/Logic/ChoiceFacts.v | 170 +- theories/Logic/Classical.v | 2 +- theories/Logic/ClassicalChoice.v | 2 +- theories/Logic/ClassicalDescription.v | 10 +- theories/Logic/ClassicalEpsilon.v | 21 +- theories/Logic/ClassicalFacts.v | 70 +- theories/Logic/ClassicalUniqueChoice.v | 24 +- theories/Logic/Classical_Pred_Set.v | 2 +- theories/Logic/Classical_Pred_Type.v | 4 +- theories/Logic/Classical_Prop.v | 10 +- theories/Logic/Classical_Type.v | 2 +- theories/Logic/ConstructiveEpsilon.v | 3 +- theories/Logic/Decidable.v | 26 +- theories/Logic/DecidableType.v | 173 -- theories/Logic/DecidableTypeEx.v | 109 -- theories/Logic/Description.v | 4 +- theories/Logic/Diaconescu.v | 38 +- theories/Logic/Epsilon.v | 12 +- theories/Logic/Eqdep.v | 3 +- theories/Logic/EqdepFacts.v | 55 +- theories/Logic/Eqdep_dec.v | 32 +- theories/Logic/FunctionalExtensionality.v | 18 +- theories/Logic/Hurkens.v | 2 +- theories/Logic/IndefiniteDescription.v | 6 +- theories/Logic/JMeq.v | 75 +- theories/Logic/ProofIrrelevanceFacts.v | 4 +- theories/Logic/RelationalChoice.v | 4 +- theories/Logic/vo.itarget | 28 + theories/MSets/MSetAVL.v | 1842 ++++++++++++++++++ theories/MSets/MSetDecide.v | 880 +++++++++ theories/MSets/MSetEqProperties.v | 936 +++++++++ theories/MSets/MSetFacts.v | 528 +++++ theories/MSets/MSetInterface.v | 732 +++++++ theories/MSets/MSetList.v | 899 +++++++++ theories/MSets/MSetPositive.v | 1149 +++++++++++ theories/MSets/MSetProperties.v | 1176 +++++++++++ theories/MSets/MSetToFiniteSet.v | 158 ++ theories/MSets/MSetWeakList.v | 533 +++++ theories/MSets/MSets.v | 23 + theories/MSets/vo.itarget | 11 + theories/NArith/BinNat.v | 76 +- theories/NArith/BinPos.v | 162 +- theories/NArith/NArith.v | 2 +- theories/NArith/NOrderedType.v | 60 + theories/NArith/Ndec.v | 110 +- theories/NArith/Ndigits.v | 108 +- theories/NArith/Ndist.v | 20 +- theories/NArith/Nminmax.v | 126 ++ theories/NArith/Nnat.v | 74 +- theories/NArith/POrderedType.v | 60 + theories/NArith/Pminmax.v | 126 ++ theories/NArith/Pnat.v | 193 +- theories/NArith/vo.itarget | 12 + theories/Numbers/BigNumPrelude.v | 96 +- theories/Numbers/Cyclic/Abstract/CyclicAxioms.v | 159 +- theories/Numbers/Cyclic/Abstract/NZCyclic.v | 173 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v | 74 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v | 94 +- .../Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v | 168 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v | 324 ++-- theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v | 144 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v | 66 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v | 114 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v | 94 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v | 76 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v | 18 +- theories/Numbers/Cyclic/Int31/Cyclic31.v | 464 ++--- theories/Numbers/Cyclic/Int31/Int31.v | 141 +- theories/Numbers/Cyclic/Int31/Ring31.v | 103 + theories/Numbers/Cyclic/ZModulo/ZModulo.v | 227 ++- theories/Numbers/Integer/Abstract/ZAdd.v | 318 ++- theories/Numbers/Integer/Abstract/ZAddOrder.v | 337 ++-- theories/Numbers/Integer/Abstract/ZAxioms.v | 61 +- theories/Numbers/Integer/Abstract/ZBase.v | 69 +- theories/Numbers/Integer/Abstract/ZDivEucl.v | 605 ++++++ theories/Numbers/Integer/Abstract/ZDivFloor.v | 632 ++++++ theories/Numbers/Integer/Abstract/ZDivTrunc.v | 532 +++++ theories/Numbers/Integer/Abstract/ZDomain.v | 69 - theories/Numbers/Integer/Abstract/ZLt.v | 402 +--- theories/Numbers/Integer/Abstract/ZMul.v | 105 +- theories/Numbers/Integer/Abstract/ZMulOrder.v | 356 ++-- theories/Numbers/Integer/Abstract/ZProperties.v | 24 + theories/Numbers/Integer/Abstract/ZSgnAbs.v | 348 ++++ theories/Numbers/Integer/BigZ/BigZ.v | 173 +- theories/Numbers/Integer/BigZ/ZMake.v | 379 ++-- theories/Numbers/Integer/Binary/ZBinary.v | 277 +-- theories/Numbers/Integer/NatPairs/ZNatPairs.v | 506 ++--- theories/Numbers/Integer/SpecViaZ/ZSig.v | 116 +- theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v | 267 ++- theories/Numbers/NaryFunctions.v | 70 +- theories/Numbers/NatInt/NZAdd.v | 87 +- theories/Numbers/NatInt/NZAddOrder.v | 141 +- theories/Numbers/NatInt/NZAxioms.v | 202 +- theories/Numbers/NatInt/NZBase.v | 69 +- theories/Numbers/NatInt/NZDiv.v | 542 ++++++ theories/Numbers/NatInt/NZDomain.v | 417 ++++ theories/Numbers/NatInt/NZMul.v | 74 +- theories/Numbers/NatInt/NZMulOrder.v | 325 ++-- theories/Numbers/NatInt/NZOrder.v | 708 ++++--- theories/Numbers/NatInt/NZProperties.v | 20 + theories/Numbers/Natural/Abstract/NAdd.v | 109 +- theories/Numbers/Natural/Abstract/NAddOrder.v | 88 +- theories/Numbers/Natural/Abstract/NAxioms.v | 58 +- theories/Numbers/Natural/Abstract/NBase.v | 180 +- theories/Numbers/Natural/Abstract/NDefOps.v | 477 +++-- theories/Numbers/Natural/Abstract/NDiv.v | 239 +++ theories/Numbers/Natural/Abstract/NIso.v | 84 +- theories/Numbers/Natural/Abstract/NMul.v | 87 - theories/Numbers/Natural/Abstract/NMulOrder.v | 101 +- theories/Numbers/Natural/Abstract/NOrder.v | 390 +--- theories/Numbers/Natural/Abstract/NProperties.v | 22 + theories/Numbers/Natural/Abstract/NStrongRec.v | 231 ++- theories/Numbers/Natural/Abstract/NSub.v | 196 +- theories/Numbers/Natural/BigN/BigN.v | 192 +- theories/Numbers/Natural/BigN/NMake.v | 524 +++++ theories/Numbers/Natural/BigN/NMake_gen.ml | 929 +++------ theories/Numbers/Natural/BigN/Nbasic.v | 64 +- theories/Numbers/Natural/Binary/NBinDefs.v | 267 --- theories/Numbers/Natural/Binary/NBinary.v | 173 +- theories/Numbers/Natural/Peano/NPeano.v | 249 +-- theories/Numbers/Natural/SpecViaZ/NSig.v | 119 +- theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v | 292 +-- theories/Numbers/NumPrelude.v | 152 +- theories/Numbers/Rational/BigQ/BigQ.v | 207 +- theories/Numbers/Rational/BigQ/QMake.v | 721 ++++--- theories/Numbers/Rational/SpecViaQ/QSig.v | 202 +- theories/Numbers/vo.itarget | 70 + theories/Program/Basics.v | 16 +- theories/Program/Combinators.v | 11 +- theories/Program/Equality.v | 397 ++-- theories/Program/Program.v | 2 +- theories/Program/Subset.v | 30 +- theories/Program/Syntax.v | 19 +- theories/Program/Tactics.v | 106 +- theories/Program/Utils.v | 2 +- theories/Program/Wf.v | 305 +-- theories/Program/vo.itarget | 9 + theories/QArith/QArith.v | 2 +- theories/QArith/QArith_base.v | 178 +- theories/QArith/QOrderedType.v | 58 + theories/QArith/Qcanon.v | 52 +- theories/QArith/Qfield.v | 12 +- theories/QArith/Qminmax.v | 67 + theories/QArith/Qpower.v | 8 +- theories/QArith/Qreals.v | 8 +- theories/QArith/Qreduction.v | 20 +- theories/QArith/Qring.v | 2 +- theories/QArith/Qround.v | 4 +- theories/QArith/vo.itarget | 12 + theories/Reals/Alembert.v | 26 +- theories/Reals/AltSeries.v | 16 +- theories/Reals/ArithProp.v | 12 +- theories/Reals/Binomial.v | 4 +- theories/Reals/Cauchy_prod.v | 6 +- theories/Reals/Cos_plus.v | 96 +- theories/Reals/Cos_rel.v | 252 +-- theories/Reals/DiscrR.v | 17 +- theories/Reals/Exp_prop.v | 8 +- theories/Reals/Integration.v | 4 +- theories/Reals/LegacyRfield.v | 2 +- theories/Reals/MVT.v | 26 +- theories/Reals/NewtonInt.v | 16 +- theories/Reals/PSeries_reg.v | 16 +- theories/Reals/PartSum.v | 18 +- theories/Reals/RIneq.v | 113 +- theories/Reals/RList.v | 48 +- theories/Reals/ROrderedType.v | 95 + theories/Reals/R_Ifp.v | 126 +- theories/Reals/R_sqr.v | 30 +- theories/Reals/R_sqrt.v | 214 ++- theories/Reals/Ranalysis.v | 26 +- theories/Reals/Ranalysis1.v | 56 +- theories/Reals/Ranalysis2.v | 37 +- theories/Reals/Ranalysis3.v | 26 +- theories/Reals/Ranalysis4.v | 28 +- theories/Reals/Raxioms.v | 14 +- theories/Reals/Rbase.v | 2 +- theories/Reals/Rbasic_fun.v | 272 ++- theories/Reals/Rcomplete.v | 2 +- theories/Reals/Rdefinitions.v | 7 +- theories/Reals/Rderiv.v | 110 +- theories/Reals/Reals.v | 4 +- theories/Reals/Rfunctions.v | 36 +- theories/Reals/Rgeom.v | 8 +- theories/Reals/RiemannInt.v | 217 +-- theories/Reals/RiemannInt_SF.v | 278 +-- theories/Reals/Rlimit.v | 62 +- theories/Reals/Rlogic.v | 10 +- theories/Reals/Rminmax.v | 123 ++ theories/Reals/Rpow_def.v | 4 +- theories/Reals/Rpower.v | 34 +- theories/Reals/Rprod.v | 26 +- theories/Reals/Rseries.v | 34 +- theories/Reals/Rsigma.v | 2 +- theories/Reals/Rsqrt_def.v | 12 +- theories/Reals/Rtopology.v | 202 +- theories/Reals/Rtrigo.v | 134 +- theories/Reals/Rtrigo_alt.v | 30 +- theories/Reals/Rtrigo_calc.v | 16 +- theories/Reals/Rtrigo_def.v | 14 +- theories/Reals/Rtrigo_fun.v | 18 +- theories/Reals/Rtrigo_reg.v | 12 +- theories/Reals/SeqProp.v | 2 +- theories/Reals/SeqSeries.v | 12 +- theories/Reals/SplitAbsolu.v | 2 +- theories/Reals/SplitRmult.v | 2 +- theories/Reals/Sqrt_reg.v | 18 +- theories/Reals/vo.itarget | 58 + theories/Relations/Newman.v | 121 -- theories/Relations/Operators_Properties.v | 234 ++- theories/Relations/Relation_Definitions.v | 28 +- theories/Relations/Relation_Operators.v | 36 +- theories/Relations/Relations.v | 2 +- theories/Relations/Rstar.v | 94 - theories/Relations/vo.itarget | 4 + theories/Setoids/Setoid.v | 28 +- theories/Setoids/vo.itarget | 1 + theories/Sets/Classical_sets.v | 6 +- theories/Sets/Constructive_sets.v | 14 +- theories/Sets/Cpo.v | 12 +- theories/Sets/Ensembles.v | 38 +- theories/Sets/Finite_sets.v | 4 +- theories/Sets/Finite_sets_facts.v | 10 +- theories/Sets/Image.v | 26 +- theories/Sets/Infinite_sets.v | 14 +- theories/Sets/Integers.v | 24 +- theories/Sets/Multiset.v | 40 +- theories/Sets/Partial_Order.v | 14 +- theories/Sets/Permut.v | 12 +- theories/Sets/Powerset.v | 2 +- theories/Sets/Powerset_Classical_facts.v | 32 +- theories/Sets/Powerset_facts.v | 42 +- theories/Sets/Relations_1.v | 26 +- theories/Sets/Relations_1_facts.v | 2 +- theories/Sets/Relations_2.v | 2 +- theories/Sets/Relations_2_facts.v | 4 +- theories/Sets/Relations_3.v | 18 +- theories/Sets/Relations_3_facts.v | 2 +- theories/Sets/Uniset.v | 12 +- theories/Sets/vo.itarget | 22 + theories/Sorting/Heap.v | 89 +- theories/Sorting/Mergesort.v | 271 +++ theories/Sorting/PermutEq.v | 74 +- theories/Sorting/PermutSetoid.v | 492 ++++- theories/Sorting/Permutation.v | 554 ++++-- theories/Sorting/Sorted.v | 154 ++ theories/Sorting/Sorting.v | 124 +- theories/Sorting/vo.itarget | 7 + theories/Strings/Ascii.v | 143 +- theories/Strings/String.v | 52 +- theories/Strings/vo.itarget | 2 + theories/Structures/DecidableType.v | 156 ++ theories/Structures/DecidableTypeEx.v | 96 + theories/Structures/Equalities.v | 218 +++ theories/Structures/EqualitiesFacts.v | 185 ++ theories/Structures/GenericMinMax.v | 656 +++++++ theories/Structures/OrderedType.v | 485 +++++ theories/Structures/OrderedTypeAlt.v | 122 ++ theories/Structures/OrderedTypeEx.v | 333 ++++ theories/Structures/Orders.v | 333 ++++ theories/Structures/OrdersAlt.v | 242 +++ theories/Structures/OrdersEx.v | 88 + theories/Structures/OrdersFacts.v | 234 +++ theories/Structures/OrdersLists.v | 256 +++ theories/Structures/OrdersTac.v | 293 +++ theories/Structures/vo.itarget | 14 + theories/Unicode/Utf8.v | 8 +- theories/Unicode/vo.itarget | 1 + theories/Wellfounded/Disjoint_Union.v | 10 +- theories/Wellfounded/Inclusion.v | 4 +- theories/Wellfounded/Inverse_Image.v | 6 +- .../Wellfounded/Lexicographic_Exponentiation.v | 80 +- theories/Wellfounded/Lexicographic_Product.v | 28 +- theories/Wellfounded/Transitive_Closure.v | 8 +- theories/Wellfounded/Union.v | 12 +- theories/Wellfounded/Well_Ordering.v | 8 +- theories/Wellfounded/Wellfounded.v | 2 +- theories/Wellfounded/vo.itarget | 9 + theories/ZArith/BinInt.v | 62 +- theories/ZArith/Int.v | 204 +- theories/ZArith/Wf_Z.v | 10 +- theories/ZArith/ZArith.v | 2 +- theories/ZArith/ZArith_base.v | 6 +- theories/ZArith/ZArith_dec.v | 45 +- theories/ZArith/ZOdiv.v | 222 ++- theories/ZArith/ZOdiv_def.v | 34 +- theories/ZArith/ZOrderedType.v | 60 + theories/ZArith/Zabs.v | 23 +- theories/ZArith/Zbinary.v | 352 ---- theories/ZArith/Zbool.v | 7 +- theories/ZArith/Zcompare.v | 78 +- theories/ZArith/Zcomplements.v | 36 +- theories/ZArith/Zdigits.v | 347 ++++ theories/ZArith/Zdiv.v | 173 +- theories/ZArith/Zeven.v | 38 +- theories/ZArith/Zgcd_alt.v | 70 +- theories/ZArith/Zhints.v | 136 +- theories/ZArith/Zlogarithm.v | 37 +- theories/ZArith/Zmax.v | 178 +- theories/ZArith/Zmin.v | 146 +- theories/ZArith/Zminmax.v | 206 +- theories/ZArith/Zmisc.v | 25 +- theories/ZArith/Znat.v | 37 +- theories/ZArith/Znumtheory.v | 272 +-- theories/ZArith/Zorder.v | 66 +- theories/ZArith/Zpow_def.v | 8 +- theories/ZArith/Zpow_facts.v | 66 +- theories/ZArith/Zpower.v | 30 +- theories/ZArith/Zsqrt.v | 6 +- theories/ZArith/Zwf.v | 4 +- theories/ZArith/auxiliary.v | 9 +- theories/ZArith/vo.itarget | 32 + theories/theories.itarget | 22 + 406 files changed, 36012 insertions(+), 23737 deletions(-) create mode 100644 theories/Arith/MinMax.v create mode 100644 theories/Arith/NatOrderedType.v create mode 100644 theories/Arith/vo.itarget create mode 100644 theories/Bool/vo.itarget delete mode 100644 theories/Classes/Functions.v create mode 100644 theories/Classes/RelationPairs.v delete mode 100644 theories/Classes/SetoidAxioms.v create mode 100644 theories/Classes/vo.itarget create mode 100644 theories/FSets/FSetCompat.v delete mode 100644 theories/FSets/FSetFullAVL.v create mode 100644 theories/FSets/FSetPositive.v delete mode 100644 theories/FSets/OrderedType.v delete mode 100644 theories/FSets/OrderedTypeAlt.v delete mode 100644 theories/FSets/OrderedTypeEx.v create mode 100644 theories/FSets/vo.itarget create mode 100644 theories/Init/vo.itarget delete mode 100644 theories/Lists/MonoList.v create mode 100644 theories/Lists/vo.itarget delete mode 100644 theories/Logic/DecidableType.v delete mode 100644 theories/Logic/DecidableTypeEx.v create mode 100644 theories/Logic/vo.itarget create mode 100644 theories/MSets/MSetAVL.v create mode 100644 theories/MSets/MSetDecide.v create mode 100644 theories/MSets/MSetEqProperties.v create mode 100644 theories/MSets/MSetFacts.v create mode 100644 theories/MSets/MSetInterface.v create mode 100644 theories/MSets/MSetList.v create mode 100644 theories/MSets/MSetPositive.v create mode 100644 theories/MSets/MSetProperties.v create mode 100644 theories/MSets/MSetToFiniteSet.v create mode 100644 theories/MSets/MSetWeakList.v create mode 100644 theories/MSets/MSets.v create mode 100644 theories/MSets/vo.itarget create mode 100644 theories/NArith/NOrderedType.v create mode 100644 theories/NArith/Nminmax.v create mode 100644 theories/NArith/POrderedType.v create mode 100644 theories/NArith/Pminmax.v create mode 100644 theories/NArith/vo.itarget create mode 100644 theories/Numbers/Cyclic/Int31/Ring31.v create mode 100644 theories/Numbers/Integer/Abstract/ZDivEucl.v create mode 100644 theories/Numbers/Integer/Abstract/ZDivFloor.v create mode 100644 theories/Numbers/Integer/Abstract/ZDivTrunc.v delete mode 100644 theories/Numbers/Integer/Abstract/ZDomain.v create mode 100644 theories/Numbers/Integer/Abstract/ZProperties.v create mode 100644 theories/Numbers/Integer/Abstract/ZSgnAbs.v create mode 100644 theories/Numbers/NatInt/NZDiv.v create mode 100644 theories/Numbers/NatInt/NZDomain.v create mode 100644 theories/Numbers/NatInt/NZProperties.v create mode 100644 theories/Numbers/Natural/Abstract/NDiv.v delete mode 100644 theories/Numbers/Natural/Abstract/NMul.v create mode 100644 theories/Numbers/Natural/Abstract/NProperties.v create mode 100644 theories/Numbers/Natural/BigN/NMake.v delete mode 100644 theories/Numbers/Natural/Binary/NBinDefs.v create mode 100644 theories/Numbers/vo.itarget create mode 100644 theories/Program/vo.itarget create mode 100644 theories/QArith/QOrderedType.v create mode 100644 theories/QArith/Qminmax.v create mode 100644 theories/QArith/vo.itarget create mode 100644 theories/Reals/ROrderedType.v create mode 100644 theories/Reals/Rminmax.v create mode 100644 theories/Reals/vo.itarget delete mode 100644 theories/Relations/Newman.v delete mode 100644 theories/Relations/Rstar.v create mode 100644 theories/Relations/vo.itarget create mode 100644 theories/Setoids/vo.itarget create mode 100644 theories/Sets/vo.itarget create mode 100644 theories/Sorting/Mergesort.v create mode 100644 theories/Sorting/Sorted.v create mode 100644 theories/Sorting/vo.itarget create mode 100644 theories/Strings/vo.itarget create mode 100644 theories/Structures/DecidableType.v create mode 100644 theories/Structures/DecidableTypeEx.v create mode 100644 theories/Structures/Equalities.v create mode 100644 theories/Structures/EqualitiesFacts.v create mode 100644 theories/Structures/GenericMinMax.v create mode 100644 theories/Structures/OrderedType.v create mode 100644 theories/Structures/OrderedTypeAlt.v create mode 100644 theories/Structures/OrderedTypeEx.v create mode 100644 theories/Structures/Orders.v create mode 100644 theories/Structures/OrdersAlt.v create mode 100644 theories/Structures/OrdersEx.v create mode 100644 theories/Structures/OrdersFacts.v create mode 100644 theories/Structures/OrdersLists.v create mode 100644 theories/Structures/OrdersTac.v create mode 100644 theories/Structures/vo.itarget create mode 100644 theories/Unicode/vo.itarget create mode 100644 theories/Wellfounded/vo.itarget create mode 100644 theories/ZArith/ZOrderedType.v delete mode 100644 theories/ZArith/Zbinary.v create mode 100644 theories/ZArith/Zdigits.v create mode 100644 theories/ZArith/vo.itarget create mode 100644 theories/theories.itarget (limited to 'theories') diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v index be065f1d..18dbd27f 100644 --- a/theories/Arith/Arith.v +++ b/theories/Arith/Arith.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Arith.v 9302 2006-10-27 21:21:17Z barras $ i*) +(*i $Id$ i*) Require Export Arith_base. Require Export ArithRing. diff --git a/theories/Arith/Arith_base.v b/theories/Arith/Arith_base.v index fbdf2a41..2d54f0e8 100644 --- a/theories/Arith/Arith_base.v +++ b/theories/Arith/Arith_base.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Arith_base.v 11072 2008-06-08 16:13:37Z herbelin $ i*) +(*i $Id$ i*) Require Export Le. Require Export Lt. diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index 2e9472c4..208c2578 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Between.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Import Le. Require Import Lt. @@ -17,11 +17,11 @@ Implicit Types k l p q r : nat. Section Between. Variables P Q : nat -> Prop. - + Inductive between k : nat -> Prop := | bet_emp : between k k | bet_S : forall l, between k l -> P l -> between k (S l). - + Hint Constructors between: arith v62. Lemma bet_eq : forall k l, l = k -> between k l. @@ -185,5 +185,5 @@ Section Between. End Between. Hint Resolve nth_O bet_S bet_emp bet_eq between_Sk_l exists_S exists_le - in_int_S in_int_intro: arith v62. + in_int_S in_int_intro: arith v62. Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith v62. diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v index fed650ab..9fd59e10 100644 --- a/theories/Arith/Bool_nat.v +++ b/theories/Arith/Bool_nat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Bool_nat.v 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id$ *) Require Export Compare_dec. Require Export Peano_dec. diff --git a/theories/Arith/Compare.v b/theories/Arith/Compare.v index 06898658..0f2595b2 100644 --- a/theories/Arith/Compare.v +++ b/theories/Arith/Compare.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Compare.v 9302 2006-10-27 21:21:17Z barras $ i*) +(*i $Id$ i*) (** Equality is decidable on [nat] *) @@ -52,4 +52,4 @@ Qed. Require Export Wf_nat. -Require Export Min. +Require Export Min Max. \ No newline at end of file diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index e6cb5be4..8fc92579 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Compare_dec.v 10295 2007-11-06 22:46:21Z letouzey $ i*) +(*i $Id$ i*) Require Import Le. Require Import Lt. @@ -18,20 +18,24 @@ Open Local Scope nat_scope. Implicit Types m n x y : nat. Definition zerop n : {n = 0} + {0 < n}. +Proof. destruct n; auto with arith. Defined. -Definition lt_eq_lt_dec n m : {n < m} + {n = m} + {m < n}. - induction n; simple destruct m; auto with arith. - intros m0; elim (IHn m0); auto with arith. - induction 1; auto with arith. +Definition lt_eq_lt_dec : forall n m, {n < m} + {n = m} + {m < n}. +Proof. + induction n; destruct m; auto with arith. + destruct (IHn m) as [H|H]; auto with arith. + destruct H; auto with arith. Defined. -Definition gt_eq_gt_dec n m : {m > n} + {n = m} + {n > m}. - exact lt_eq_lt_dec. +Definition gt_eq_gt_dec : forall n m, {m > n} + {n = m} + {n > m}. +Proof. + intros; apply lt_eq_lt_dec; assumption. Defined. -Definition le_lt_dec n m : {n <= m} + {m < n}. +Definition le_lt_dec : forall n m, {n <= m} + {m < n}. +Proof. induction n. auto with arith. destruct m. @@ -40,43 +44,68 @@ Definition le_lt_dec n m : {n <= m} + {m < n}. Defined. Definition le_le_S_dec n m : {n <= m} + {S m <= n}. - exact le_lt_dec. +Proof. + intros; 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. Defined. Definition le_gt_dec n m : {n <= m} + {n > m}. - exact le_lt_dec. +Proof. + intros; exact (le_lt_dec n m). Defined. Definition le_lt_eq_dec n m : n <= m -> {n < m} + {n = m}. - intros; elim (lt_eq_lt_dec n m); auto with arith. +Proof. + intros; destruct (lt_eq_lt_dec n m); auto with arith. intros; absurd (m < n); auto with arith. Defined. +Theorem le_dec : forall 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. +Defined. + +Theorem lt_dec : forall n m, {n < m} + {~ n < m}. +Proof. + intros; apply le_dec. +Defined. + +Theorem gt_dec : forall n m, {n > m} + {~ n > m}. +Proof. + intros; apply lt_dec. +Defined. + +Theorem ge_dec : forall n m, {n >= m} + {~ n >= m}. +Proof. + intros; apply le_dec. +Defined. + (** Proofs of decidability *) Theorem dec_le : forall n m, decidable (n <= m). Proof. - intros x y; unfold decidable in |- *; elim (le_gt_dec x y); - [ auto with arith | intro; right; apply gt_not_le; assumption ]. + intros n m; destruct (le_dec n m); unfold decidable; auto. Qed. Theorem dec_lt : forall n m, decidable (n < m). Proof. - intros x y; unfold lt in |- *; apply dec_le. + intros; apply dec_le. Qed. Theorem dec_gt : forall n m, decidable (n > m). Proof. - intros x y; unfold gt in |- *; apply dec_lt. + intros; apply dec_lt. Qed. Theorem dec_ge : forall n m, decidable (n >= m). Proof. - intros x y; unfold ge in |- *; apply dec_le. + intros; apply dec_le. Qed. Theorem not_eq : forall n m, n <> m -> n < m \/ m < n. @@ -107,86 +136,111 @@ Qed. Theorem not_lt : forall n m, ~ n < m -> n >= m. Proof. - intros x y H; exact (not_gt y x H). + intros x y H; exact (not_gt y x H). Qed. (** A ternary comparison function in the spirit of [Zcompare]. *) -Definition nat_compare (n m:nat) := - match lt_eq_lt_dec n m with - | inleft (left _) => Lt - | inleft (right _) => Eq - | inright _ => Gt +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. Lemma nat_compare_S : forall n m, nat_compare (S n) (S m) = nat_compare n m. Proof. - unfold nat_compare; intros. - simpl; destruct (lt_eq_lt_dec n m) as [[H|H]|H]; simpl; auto. + reflexivity. +Qed. + +Lemma nat_compare_eq_iff : forall n m, nat_compare n m = Eq <-> n = m. +Proof. + induction n; destruct m; simpl; split; auto; try discriminate; + destruct (IHn m); auto. Qed. Lemma nat_compare_eq : forall n m, nat_compare n m = Eq -> n = m. Proof. - induction n; destruct m; simpl; auto. - unfold nat_compare; destruct (lt_eq_lt_dec 0 (S m)) as [[H|H]|H]; - auto; intros; try discriminate. - unfold nat_compare; destruct (lt_eq_lt_dec (S n) 0) as [[H|H]|H]; - auto; intros; try discriminate. - rewrite nat_compare_S; auto. + intros; apply -> nat_compare_eq_iff; auto. Qed. Lemma nat_compare_lt : forall n m, n nat_compare n m = Lt. Proof. - induction n; destruct m; simpl. - unfold nat_compare; simpl; intuition; [inversion H | discriminate H]. - split; auto with arith. - split; [inversion 1 |]. - unfold nat_compare; destruct (lt_eq_lt_dec (S n) 0) as [[H|H]|H]; - auto; intros; try discriminate. - rewrite nat_compare_S. - generalize (IHn m); clear IHn; intuition. + 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. Qed. Lemma nat_compare_gt : forall n m, n>m <-> nat_compare n m = Gt. Proof. - induction n; destruct m; simpl. - unfold nat_compare; simpl; intuition; [inversion H | discriminate H]. - split; [inversion 1 |]. - unfold nat_compare; destruct (lt_eq_lt_dec 0 (S m)) as [[H|H]|H]; - auto; intros; try discriminate. - split; auto with arith. - rewrite nat_compare_S. - generalize (IHn m); clear IHn; intuition. + 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. Qed. Lemma nat_compare_le : forall n m, n<=m <-> nat_compare n m <> Gt. Proof. split. - intros. - intro. - destruct (nat_compare_gt n m). - generalize (le_lt_trans _ _ _ H (H2 H0)). - exact (lt_irrefl n). - intros. - apply not_gt. - contradict H. - destruct (nat_compare_gt n m); auto. -Qed. + 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. - intro. - destruct (nat_compare_lt n m). - generalize (le_lt_trans _ _ _ H (H2 H0)). - exact (lt_irrefl m). - intros. - apply not_lt. - contradict H. - destruct (nat_compare_lt n m); auto. -Qed. + 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. + +Lemma nat_compare_spec : forall x y, CompSpec eq lt x y (nat_compare x y). +Proof. + intros. + destruct (nat_compare x y) as [ ]_eqn; constructor. + apply nat_compare_eq; auto. + apply <- nat_compare_lt; auto. + apply <- nat_compare_gt; auto. +Qed. + + +(** Some projections of the above equivalences. *) + +Lemma nat_compare_Lt_lt : forall n m, nat_compare n m = Lt -> n n>m. +Proof. + intros; apply <- nat_compare_gt; auto. +Qed. + +(** A previous definition of [nat_compare] in terms of [lt_eq_lt_dec]. + The new version avoids the creation of proof parts. *) + +Definition nat_compare_alt (n m:nat) := + match lt_eq_lt_dec n m with + | inleft (left _) => Lt + | inleft (right _) => Eq + | inright _ => Gt + end. + +Lemma nat_compare_equiv: forall n m, + nat_compare 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. +Qed. + (** A boolean version of [le] over [nat]. *) @@ -200,48 +254,48 @@ Fixpoint leb (m:nat) : nat -> bool := end end. -Lemma leb_correct : forall m n:nat, m <= n -> leb m n = true. +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 in |- *. apply IHm. apply le_S_n. assumption. Qed. -Lemma leb_complete : forall m n:nat, leb m n = true -> m <= n. +Lemma leb_complete : forall m n, leb m n = true -> m <= n. Proof. induction m. trivial with arith. destruct n. intro H. discriminate H. auto with arith. Qed. -Lemma leb_correct_conv : forall m n:nat, m < n -> leb n m = false. +Lemma leb_iff : forall m n, leb m n = true <-> m <= n. Proof. - intros. + split; auto using leb_correct, leb_complete. +Qed. + +Lemma leb_correct_conv : forall m n, m < n -> leb n m = false. +Proof. + intros. generalize (leb_complete n m). destruct (leb n m); auto. - intros. - elim (lt_irrefl _ (lt_le_trans _ _ _ H (H0 (refl_equal true)))). + intros; elim (lt_not_le m n); auto. Qed. -Lemma leb_complete_conv : forall m n:nat, leb n m = false -> m < n. +Lemma leb_complete_conv : forall m n, leb n m = false -> m < n. Proof. - intros. elim (le_or_lt n m). intro. conditional trivial rewrite leb_correct in H. discriminate H. - trivial. + intros m n EQ. apply not_le. + intro LE. apply leb_correct in LE. rewrite LE in EQ; discriminate. +Qed. + +Lemma leb_iff_conv : forall m n, leb n m = false <-> m < n. +Proof. + split; auto using leb_complete_conv, leb_correct_conv. Qed. Lemma leb_compare : forall n m, leb n m = true <-> nat_compare n m <> Gt. Proof. - induction n; destruct m; simpl. - unfold nat_compare; simpl. - intuition; discriminate. - split; auto with arith. - unfold nat_compare; destruct (lt_eq_lt_dec 0 (S m)) as [[H|H]|H]; - intuition; try discriminate. - inversion H. - split; try (intros; discriminate). - unfold nat_compare; destruct (lt_eq_lt_dec (S n) 0) as [[H|H]|H]; - intuition; try discriminate. - inversion H. - rewrite nat_compare_S; auto. -Qed. + split; intros. + apply -> nat_compare_le. auto using leb_complete. + apply leb_correct. apply <- nat_compare_le; auto. +Qed. diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 7cab976f..999a6454 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Div2.v 11735 2009-01-02 17:22:31Z herbelin $ i*) +(*i $Id$ i*) Require Import Lt. Require Import Plus. @@ -36,7 +36,7 @@ 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. Qed. @@ -150,7 +150,7 @@ Proof fun n => proj2 (proj2 (even_odd_double n)). Hint Resolve even_double double_even odd_double double_odd: arith. -(** Application: +(** Application: - if [n] is even then there is a [p] such that [n = 2p] - if [n] is odd then there is a [p] such that [n = 2p+1] diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index a9244455..312b76e9 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: EqNat.v 9966 2007-07-10 23:54:53Z letouzey $ i*) +(*i $Id$ i*) (** Equality on natural numbers *) @@ -16,7 +16,7 @@ Implicit Types m n x y : nat. (** * Propositional equality *) -Fixpoint eq_nat n m {struct n} : Prop := +Fixpoint eq_nat n m : Prop := match n, m with | O, O => True | O, S _ => False @@ -68,7 +68,7 @@ Defined. (** * Boolean equality on [nat] *) -Fixpoint beq_nat n m {struct n} : bool := +Fixpoint beq_nat n m : bool := match n, m with | O, O => true | O, S _ => false @@ -99,3 +99,18 @@ Lemma beq_nat_false : forall x y, beq_nat x y = false -> x<>y. Proof. induction x; destruct y; simpl; auto; intros; discriminate. Qed. + +Lemma beq_nat_true_iff : forall x y, beq_nat x y = true <-> x=y. +Proof. + split. apply beq_nat_true. + intros; subst; symmetry; apply beq_nat_refl. +Qed. + +Lemma beq_nat_false_iff : forall x y, beq_nat x y = false <-> x<>y. +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. diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v index 3d6f1af5..f50dcc84 100644 --- a/theories/Arith/Euclid.v +++ b/theories/Arith/Euclid.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Euclid.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Import Mult. Require Import Compare_dec. diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index 59209370..eaa1bb2d 100644 --- a/theories/Arith/Even.v +++ b/theories/Arith/Even.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Even.v 11512 2008-10-27 12:28:36Z herbelin $ i*) +(*i $Id$ i*) (** Here we define the predicates [even] and [odd] by mutual induction and we prove the decidability and the exclusion of those predicates. @@ -17,7 +17,7 @@ Open Local Scope nat_scope. Implicit Types m n : nat. -(** * Definition of [even] and [odd], and basic facts *) +(** * Definition of [even] and [odd], and basic facts *) Inductive even : nat -> Prop := | even_O : even 0 @@ -52,9 +52,9 @@ Qed. (** * Facts about [even] & [odd] wrt. [plus] *) -Lemma even_plus_split : forall n m, +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, +with odd_plus_split : forall n m, odd (n + m) -> odd n /\ even m \/ even n /\ odd m. Proof. intros. clear even_plus_split. destruct n; simpl in *. @@ -95,7 +95,7 @@ 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_l : forall n m, even (n + m) -> even m -> even n. Proof. intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. @@ -120,13 +120,13 @@ 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_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_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. @@ -203,7 +203,7 @@ Proof. intros n m; case (even_mult_aux n m); auto. intros H H0; case H0; auto. Qed. - + Lemma even_mult_r : forall n m, even m -> even (n * m). Proof. intros n m; case (even_mult_aux n m); auto. @@ -219,7 +219,7 @@ Proof. intros H'3; elim H'3; auto. intros H; case (not_even_and_odd n); auto. Qed. - + Lemma even_mult_inv_l : forall n m, even (n * m) -> odd m -> even n. Proof. intros n m H' H'0. @@ -228,13 +228,13 @@ Proof. intros H'3; elim H'3; auto. intros H; case (not_even_and_odd m); auto. 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_inv_l : forall n m, odd (n * m) -> odd n. Proof. intros n m H'. diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v index 5e2f491a..8c531562 100644 --- a/theories/Arith/Factorial.v +++ b/theories/Arith/Factorial.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Factorial.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Import Plus. Require Import Mult. diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v index 5b1ee1b2..70169f52 100644 --- a/theories/Arith/Gt.v +++ b/theories/Arith/Gt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Gt.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) (** Theorems about [gt] in [nat]. [gt] is defined in [Init/Peano.v] as: << @@ -135,7 +135,7 @@ Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith v62. (** * Comparison to 0 *) -Theorem gt_O_eq : forall n, n > 0 \/ 0 = n. +Theorem gt_0_eq : forall n, n > 0 \/ 0 = n. Proof. intro n; apply gt_S; auto with arith. Qed. @@ -151,4 +151,8 @@ Lemma plus_gt_compat_l : forall n m p, n > m -> p + n > p + m. Proof. auto with arith. Qed. -Hint Resolve plus_gt_compat_l: arith v62. \ No newline at end of file +Hint Resolve plus_gt_compat_l: arith v62. + +(* begin hide *) +Notation gt_O_eq := gt_0_eq (only parsing). +(* end hide *) diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index e8b9e6be..d85178de 100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Le.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) (** Order on natural numbers. [le] is defined in [Init/Peano.v] as: << @@ -41,25 +41,25 @@ Hint Resolve le_trans: arith v62. (** Comparison to 0 *) -Theorem le_O_n : forall n, 0 <= n. +Theorem le_0_n : forall n, 0 <= n. Proof. induction n; auto. Qed. -Theorem le_Sn_O : forall n, ~ S n <= 0. +Theorem le_Sn_0 : forall n, ~ S n <= 0. Proof. red in |- *; intros n H. change (IsSucc 0) in |- *; elim H; simpl in |- *; auto with arith. Qed. -Hint Resolve le_O_n le_Sn_O: arith v62. +Hint Resolve le_0_n le_Sn_0: arith v62. -Theorem le_n_O_eq : forall n, n <= 0 -> 0 = n. +Theorem le_n_0_eq : forall n, n <= 0 -> 0 = n. Proof. induction n; auto with arith. - intro; contradiction le_Sn_O with n. + intro; contradiction le_Sn_0 with n. Qed. -Hint Immediate le_n_O_eq: arith v62. +Hint Immediate le_n_0_eq: arith v62. (** [le] and successor *) @@ -135,3 +135,9 @@ Proof. intros m Le. elim Le; auto with arith. Qed. + +(* begin hide *) +Notation le_O_n := le_0_n (only parsing). +Notation le_Sn_O := le_Sn_0 (only parsing). +Notation le_n_O_eq := le_n_0_eq (only parsing). +(* end hide *) diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v index 94cf3793..af435e54 100644 --- a/theories/Arith/Lt.v +++ b/theories/Arith/Lt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Lt.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) (** Theorems about [lt] in nat. [lt] is defined in library [Init/Peano.v] as: << @@ -26,7 +26,7 @@ Theorem lt_irrefl : forall n, ~ n < n. Proof le_Sn_n. Hint Resolve lt_irrefl: arith v62. -(** * Relationship between [le] and [lt] *) +(** * Relationship between [le] and [lt] *) Theorem lt_le_S : forall n m, n < m -> S n <= m. Proof. @@ -90,11 +90,11 @@ Proof. Qed. Hint Immediate lt_S_n: arith v62. -Theorem lt_O_Sn : forall n, 0 < S n. +Theorem lt_0_Sn : forall n, 0 < S n. Proof. auto with arith. Qed. -Hint Resolve lt_O_Sn: arith v62. +Hint Resolve lt_0_Sn: arith v62. Theorem lt_n_O : forall n, ~ n < 0. Proof le_Sn_O. @@ -144,6 +144,13 @@ Proof. induction 1; auto with arith. Qed. +Theorem le_lt_or_eq_iff : forall n m, n <= m <-> n < m \/ n = m. +Proof. + split. + intros; apply le_lt_or_eq; auto. + destruct 1; subst; auto with arith. +Qed. + Theorem lt_le_weak : forall n m, n < m -> n <= m. Proof. auto with arith. @@ -168,15 +175,21 @@ Qed. (** * Comparison to 0 *) -Theorem neq_O_lt : forall n, 0 <> n -> 0 < n. +Theorem neq_0_lt : forall n, 0 <> n -> 0 < n. Proof. induction n; auto with arith. intros; absurd (0 = 0); trivial with arith. Qed. -Hint Immediate neq_O_lt: arith v62. +Hint Immediate neq_0_lt: arith v62. -Theorem lt_O_neq : forall n, 0 < n -> 0 <> n. +Theorem lt_0_neq : forall n, 0 < n -> 0 <> n. Proof. induction 1; auto with arith. Qed. -Hint Immediate lt_O_neq: arith v62. \ No newline at end of file +Hint Immediate lt_0_neq: arith v62. + +(* begin hide *) +Notation lt_O_Sn := lt_0_Sn (only parsing). +Notation neq_O_lt := neq_0_lt (only parsing). +Notation lt_O_neq := lt_0_neq (only parsing). +(* end hide *) diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index 5de2298d..3d7fe9fc 100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -6,81 +6,39 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Max.v 11735 2009-01-02 17:22:31Z herbelin $ i*) - -Require Import Le. - -Open Local Scope nat_scope. - -Implicit Types m n : nat. - -(** * maximum of two natural numbers *) - -Fixpoint max n m {struct n} : nat := - match n, m with - | O, _ => m - | S n', O => n - | S n', S m' => S (max n' m') - end. - -(** * Simplifications of [max] *) - -Lemma max_SS : forall n m, S (max n m) = max (S n) (S m). -Proof. - auto with arith. -Qed. - -Theorem max_assoc : forall m n p : nat, max m (max n p) = max (max m n) p. -Proof. - induction m; destruct n; destruct p; trivial. - simpl. - auto using IHm. -Qed. - -Lemma max_comm : forall n m, max n m = max m n. -Proof. - induction n; induction m; simpl in |- *; auto with arith. -Qed. - -(** * [max] and [le] *) - -Lemma max_l : forall n m, m <= n -> max n m = n. -Proof. - induction n; induction m; simpl in |- *; auto with arith. -Qed. - -Lemma max_r : forall n m, n <= m -> max n m = m. -Proof. - induction n; induction m; simpl in |- *; auto with arith. -Qed. - -Lemma le_max_l : forall n m, n <= max n m. -Proof. - induction n; intros; simpl in |- *; auto with arith. - elim m; intros; simpl in |- *; auto with arith. -Qed. - -Lemma le_max_r : forall n m, m <= max n m. -Proof. - induction n; simpl in |- *; auto with arith. - induction m; simpl in |- *; auto with arith. -Qed. -Hint Resolve max_r max_l le_max_l le_max_r: arith v62. - - -(** * [max n m] is equal to [n] or [m] *) - -Lemma max_dec : forall n m, {max n m = n} + {max n m = m}. -Proof. - induction n; induction m; simpl in |- *; auto with arith. - elim (IHn m); intro H; elim H; auto. -Defined. - -Lemma max_case : forall n m (P:nat -> Type), P n -> P m -> P (max n m). -Proof. - induction n; simpl in |- *; auto with arith. - induction m; intros; simpl in |- *; auto with arith. - pattern (max n m) in |- *; apply IHn; auto with arith. -Defined. - +(*i $Id$ i*) + +(** THIS FILE IS DEPRECATED. Use [MinMax] instead. *) + +Require Export MinMax. + +Local Open Scope nat_scope. +Implicit Types m n p : nat. + +Notation max := MinMax.max (only parsing). + +Definition max_0_l := max_0_l. +Definition max_0_r := max_0_r. +Definition succ_max_distr := succ_max_distr. +Definition plus_max_distr_l := plus_max_distr_l. +Definition plus_max_distr_r := plus_max_distr_r. +Definition max_case_strong := max_case_strong. +Definition max_spec := max_spec. +Definition max_dec := max_dec. +Definition max_case := max_case. +Definition max_idempotent := max_id. +Definition max_assoc := max_assoc. +Definition max_comm := max_comm. +Definition max_l := max_l. +Definition max_r := max_r. +Definition le_max_l := le_max_l. +Definition le_max_r := le_max_r. +Definition max_lub_l := max_lub_l. +Definition max_lub_r := max_lub_r. +Definition max_lub := max_lub. + +(* begin hide *) +(* Compatibility *) Notation max_case2 := max_case (only parsing). +Notation max_SS := succ_max_distr (only parsing). +(* end hide *) diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v index aa009963..c52fc0dd 100644 --- a/theories/Arith/Min.v +++ b/theories/Arith/Min.v @@ -6,91 +6,39 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Min.v 9660 2007-02-19 11:36:30Z notin $ i*) +(*i $Id$ i*) -Require Import Le. +(** THIS FILE IS DEPRECATED. Use [MinMax] instead. *) -Open Local Scope nat_scope. - -Implicit Types m n : nat. - -(** * minimum of two natural numbers *) - -Fixpoint min n m {struct n} : nat := - match n, m with - | O, _ => 0 - | S n', O => 0 - | S n', S m' => S (min n' m') - end. - -(** * Simplifications of [min] *) - -Lemma min_0_l : forall n : nat, min 0 n = 0. -Proof. - trivial. -Qed. - -Lemma min_0_r : forall n : nat, min n 0 = 0. -Proof. - destruct n; trivial. -Qed. - -Lemma min_SS : forall n m, S (min n m) = min (S n) (S m). -Proof. - auto with arith. -Qed. - -Lemma min_assoc : forall m n p : nat, min m (min n p) = min (min m n) p. -Proof. - induction m; destruct n; destruct p; trivial. - simpl. - auto using (IHm n p). -Qed. - -Lemma min_comm : forall n m, min n m = min m n. -Proof. - induction n; induction m; simpl in |- *; auto with arith. -Qed. - -(** * [min] and [le] *) - -Lemma min_l : forall n m, n <= m -> min n m = n. -Proof. - induction n; induction m; simpl in |- *; auto with arith. -Qed. - -Lemma min_r : forall n m, m <= n -> min n m = m. -Proof. - induction n; induction m; simpl in |- *; auto with arith. -Qed. - -Lemma le_min_l : forall n m, min n m <= n. -Proof. - induction n; intros; simpl in |- *; auto with arith. - elim m; intros; simpl in |- *; auto with arith. -Qed. - -Lemma le_min_r : forall n m, min n m <= m. -Proof. - induction n; simpl in |- *; auto with arith. - induction m; simpl in |- *; auto with arith. -Qed. -Hint Resolve min_l min_r le_min_l le_min_r: arith v62. - -(** * [min n m] is equal to [n] or [m] *) - -Lemma min_dec : forall n m, {min n m = n} + {min n m = m}. -Proof. - induction n; induction m; simpl in |- *; auto with arith. - elim (IHn m); intro H; elim H; auto. -Qed. - -Lemma min_case : forall n m (P:nat -> Type), P n -> P m -> P (min n m). -Proof. - induction n; simpl in |- *; auto with arith. - induction m; intros; simpl in |- *; auto with arith. - pattern (min n m) in |- *; apply IHn; auto with arith. -Qed. +Require Export MinMax. +Open Local Scope nat_scope. +Implicit Types m n p : nat. + +Notation min := MinMax.min (only parsing). + +Definition min_0_l := min_0_l. +Definition min_0_r := min_0_r. +Definition succ_min_distr := succ_min_distr. +Definition plus_min_distr_l := plus_min_distr_l. +Definition plus_min_distr_r := plus_min_distr_r. +Definition min_case_strong := min_case_strong. +Definition min_spec := min_spec. +Definition min_dec := min_dec. +Definition min_case := min_case. +Definition min_idempotent := min_id. +Definition min_assoc := min_assoc. +Definition min_comm := min_comm. +Definition min_l := min_l. +Definition min_r := min_r. +Definition le_min_l := le_min_l. +Definition le_min_r := le_min_r. +Definition min_glb_l := min_glb_l. +Definition min_glb_r := min_glb_r. +Definition min_glb := min_glb. + +(* begin hide *) +(* Compatibility *) Notation min_case2 := min_case (only parsing). - +Notation min_SS := succ_min_distr (only parsing). +(* end hide *) \ No newline at end of file diff --git a/theories/Arith/MinMax.v b/theories/Arith/MinMax.v new file mode 100644 index 00000000..6e86a88c --- /dev/null +++ b/theories/Arith/MinMax.v @@ -0,0 +1,113 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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. + +(** These functions implement indeed a maximum and a minimum *) + +Lemma max_l : forall x y, y<=x -> max x y = x. +Proof. + induction x; destruct y; simpl; auto with arith. +Qed. + +Lemma max_r : forall x y, x<=y -> max x y = y. +Proof. + induction x; destruct y; simpl; auto with arith. +Qed. + +Lemma min_l : forall x y, x<=y -> min x y = x. +Proof. + induction x; destruct y; simpl; auto with arith. +Qed. + +Lemma min_r : forall x y, y<=x -> min x y = y. +Proof. + induction x; destruct y; simpl; auto with arith. +Qed. + + +Module NatHasMinMax <: HasMinMax Nat_as_OT. + Definition max := max. + Definition min := min. + Definition max_l := max_l. + Definition max_r := max_r. + Definition min_l := min_l. + Definition min_r := min_r. +End NatHasMinMax. + +(** We obtain hence all the generic properties of [max] and [min], + see file [GenericMinMax] or use SearchAbout. *) + +Module Export MMP := UsualMinMaxProperties Nat_as_OT NatHasMinMax. + + +(** * Properties specific to the [nat] domain *) + +(** Simplifications *) + +Lemma max_0_l : forall n, max 0 n = n. +Proof. reflexivity. Qed. + +Lemma max_0_r : forall n, max n 0 = n. +Proof. destruct n; auto. Qed. + +Lemma min_0_l : forall n, min 0 n = 0. +Proof. reflexivity. Qed. + +Lemma min_0_r : forall n, min n 0 = 0. +Proof. destruct n; auto. Qed. + +(** Compatibilities (consequences of monotonicity) *) + +Lemma succ_max_distr : forall n m, S (max n m) = max (S n) (S m). +Proof. auto. Qed. + +Lemma succ_min_distr : forall n m, S (min n m) = min (S n) (S m). +Proof. auto. Qed. + +Lemma plus_max_distr_l : forall n m p, max (p + n) (p + m) = p + max n m. +Proof. +intros. apply max_monotone. repeat red; auto with arith. +Qed. + +Lemma plus_max_distr_r : forall n m p, max (n + p) (m + p) = max n m + p. +Proof. +intros. apply max_monotone with (f:=fun x => x + p). +repeat red; auto with arith. +Qed. + +Lemma plus_min_distr_l : forall n m p, min (p + n) (p + m) = p + min n m. +Proof. +intros. apply min_monotone. repeat red; auto with arith. +Qed. + +Lemma plus_min_distr_r : forall n m p, min (n + p) (m + p) = min n m + p. +Proof. +intros. apply min_monotone with (f:=fun x => x + p). +repeat red; auto with arith. +Qed. + +Hint Resolve + max_l max_r le_max_l le_max_r + min_l min_r le_min_l le_min_r : arith v62. diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v index b961886d..cd6c0a29 100644 --- a/theories/Arith/Minus.v +++ b/theories/Arith/Minus.v @@ -6,11 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Minus.v 11072 2008-06-08 16:13:37Z herbelin $ i*) +(*i $Id$ i*) (** [minus] (difference between two natural numbers) is defined in [Init/Peano.v] as: << -Fixpoint minus (n m:nat) {struct n} : nat := +Fixpoint minus (n m:nat) : nat := match n, m with | O, _ => n | S k, O => S k @@ -120,10 +120,10 @@ Proof. intros n m Hnm; apply le_elim_rel with (n:=n) (m:=m); trivial. intros q; destruct q; auto with arith. - simpl. + simpl. apply le_trans with (m := p - 0); [apply HI | rewrite <- minus_n_O]; auto with arith. - + intros q r Hqr _. simpl. auto using HI. Qed. diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index a43579f9..8346cae3 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Mult.v 11015 2008-05-28 20:06:42Z herbelin $ i*) +(*i $Id$ i*) Require Export Plus. Require Export Minus. @@ -43,7 +43,7 @@ Hint Resolve mult_1_l: arith v62. Lemma mult_1_r : forall n, n * 1 = n. Proof. - induction n; [ trivial | + induction n; [ trivial | simpl; rewrite IHn; reflexivity]. Qed. Hint Resolve mult_1_r: arith v62. @@ -52,9 +52,9 @@ Hint Resolve mult_1_r: arith v62. Lemma mult_comm : forall n m, n * m = m * n. Proof. -intros; elim n; intros; simpl in |- *; auto with arith. -elim mult_n_Sm. -elim H; apply plus_comm. +intros; induction n; simpl; auto with arith. +rewrite <- mult_n_Sm. +rewrite IHn; apply plus_comm. Qed. Hint Resolve mult_comm: arith v62. @@ -62,29 +62,28 @@ Hint Resolve mult_comm: arith v62. Lemma mult_plus_distr_r : forall n m p, (n + m) * p = n * p + m * p. Proof. - intros; elim n; simpl in |- *; intros; auto with arith. - elim plus_assoc; elim H; auto with arith. + intros; induction n; simpl; auto with arith. + rewrite <- plus_assoc, IHn; auto with arith. Qed. Hint Resolve mult_plus_distr_r: arith v62. Lemma mult_plus_distr_l : forall n m p, n * (m + p) = n * m + n * p. Proof. induction n. trivial. - intros. simpl in |- *. rewrite (IHn m p). apply sym_eq. apply plus_permute_2_in_4. + intros. simpl in |- *. rewrite IHn. symmetry. apply plus_permute_2_in_4. Qed. Lemma mult_minus_distr_r : forall n m p, (n - m) * p = n * p - m * p. Proof. - intros; pattern n, m in |- *; apply nat_double_ind; simpl in |- *; intros; - auto with arith. - elim minus_plus_simpl_l_reverse; auto with arith. + intros; induction n m using nat_double_ind; simpl; auto with arith. + rewrite <- minus_plus_simpl_l_reverse; auto with arith. Qed. Hint Resolve mult_minus_distr_r: arith v62. Lemma mult_minus_distr_l : forall n m p, n * (m - p) = n * m - n * p. Proof. - intros n m p. rewrite mult_comm. rewrite mult_minus_distr_r. - rewrite (mult_comm m n); rewrite (mult_comm p n); reflexivity. + intros n m p. + rewrite mult_comm, mult_minus_distr_r, (mult_comm m n), (mult_comm p n); reflexivity. Qed. Hint Resolve mult_minus_distr_l: arith v62. @@ -92,9 +91,9 @@ Hint Resolve mult_minus_distr_l: arith v62. Lemma mult_assoc_reverse : forall n m p, n * m * p = n * (m * p). Proof. - intros; elim n; intros; simpl in |- *; auto with arith. + intros; induction n; simpl; auto with arith. rewrite mult_plus_distr_r. - elim H; auto with arith. + induction IHn; auto with arith. Qed. Hint Resolve mult_assoc_reverse: arith v62. @@ -108,23 +107,18 @@ Hint Resolve mult_assoc: arith v62. Lemma mult_is_O : forall n m, n * m = 0 -> n = 0 \/ m = 0. Proof. - destruct n as [| n]. - intros; left; trivial. - - simpl; intros m H; right. - assert (H':m = 0 /\ n * m = 0) by apply (plus_is_O _ _ H). - destruct H'; trivial. + destruct n as [| n]; simpl; intros m H. + left; trivial. + right; apply plus_is_O in H; destruct H; trivial. Qed. Lemma mult_is_one : forall n m, n * m = 1 -> n = 1 /\ m = 1. Proof. - destruct n as [|n]. - simpl; intros m H; elim (O_S _ H). - - simpl; intros m H. - destruct (plus_is_one _ _ H) as [[Hm Hnm] | [Hm Hnm]]. - rewrite Hm in H; simpl in H; rewrite mult_0_r in H; elim (O_S _ H). - rewrite Hm in Hnm; rewrite mult_1_r in Hnm; auto. + 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. Qed. (** ** Multiplication and successor *) @@ -151,18 +145,16 @@ Hint Resolve mult_O_le: arith v62. Lemma mult_le_compat_l : forall n m p, n <= m -> p * n <= p * m. Proof. - induction p as [| p IHp]. intros. simpl in |- *. apply le_n. - intros. simpl in |- *. apply plus_le_compat. assumption. - apply IHp. assumption. + induction p as [| p IHp]; intros; simpl in |- *. + apply le_n. + auto using plus_le_compat. Qed. Hint Resolve mult_le_compat_l: arith. Lemma mult_le_compat_r : forall n m p, n <= m -> n * p <= m * p. Proof. - intros m n p H. - rewrite mult_comm. rewrite (mult_comm n). - auto with arith. + intros m n p H; rewrite mult_comm, (mult_comm n); auto with arith. Qed. Lemma mult_le_compat : @@ -184,8 +176,9 @@ Qed. Lemma mult_S_lt_compat_l : forall n m p, m < p -> S n * m < S n * p. Proof. - intro m; induction m. intros. simpl in |- *. rewrite <- plus_n_O. rewrite <- plus_n_O. assumption. - intros. exact (plus_lt_compat _ _ _ _ H (IHm _ _ H)). + induction n; intros; simpl in *. + rewrite <- 2! plus_n_O; assumption. + auto using plus_lt_compat. Qed. Hint Resolve mult_S_lt_compat_l: arith. @@ -201,40 +194,36 @@ Qed. Lemma mult_S_le_reg_l : forall n m p, S n * m <= S n * p -> m <= p. Proof. - intros m n p H. elim (le_or_lt n p). trivial. - intro H0. cut (S m * n < S m * n). intro. elim (lt_irrefl _ H1). - apply le_lt_trans with (m := S m * p). assumption. - apply mult_S_lt_compat_l. assumption. + 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). Qed. (** * n|->2*n and n|->2n+1 have disjoint image *) Theorem odd_even_lem : forall p q, 2 * p + 1 <> 2 * q. Proof. - intros p; elim p; auto. - intros q; case q; simpl in |- *. - red in |- *; intros; discriminate. - intros q'; rewrite (fun x y => plus_comm x (S y)); simpl in |- *; red in |- *; - intros; discriminate. - intros p' H q; case q. - simpl in |- *; red in |- *; intros; discriminate. - intros q'; red in |- *; intros H0; case (H q'). - replace (2 * q') with (2 * S q' - 2). - rewrite <- H0; simpl in |- *; auto. - repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *; auto. - simpl in |- *; repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *; - auto. - case q'; simpl in |- *; auto. + 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. Qed. (** * Tail-recursive mult *) -(** [tail_mult] is an alternative definition for [mult] which is - tail-recursive, whereas [mult] is not. This can be useful +(** [tail_mult] is an alternative definition for [mult] which is + tail-recursive, whereas [mult] is not. This can be useful when extracting programs. *) -Fixpoint mult_acc (s:nat) m n {struct n} : nat := +Fixpoint mult_acc (s:nat) m n : nat := match n with | O => s | S p => mult_acc (tail_plus m s) m p @@ -244,7 +233,7 @@ Lemma mult_acc_aux : forall n m p, m + n * p = mult_acc m p n. Proof. induction n as [| p IHp]; simpl in |- *; auto. intros s m; rewrite <- plus_tail_plus; rewrite <- IHp. - rewrite <- plus_assoc_reverse; apply (f_equal2 (A1:=nat) (A2:=nat)); auto. + rewrite <- plus_assoc_reverse; apply f_equal2; auto. rewrite plus_comm; auto. Qed. @@ -255,7 +244,7 @@ Proof. intros; unfold tail_mult in |- *; rewrite <- mult_acc_aux; auto. Qed. -(** [TailSimpl] transforms any [tail_plus] and [tail_mult] into [plus] +(** [TailSimpl] transforms any [tail_plus] and [tail_mult] into [plus] and [mult] and simplify *) Ltac tail_simpl := diff --git a/theories/Arith/NatOrderedType.v b/theories/Arith/NatOrderedType.v new file mode 100644 index 00000000..df5b37e0 --- /dev/null +++ b/theories/Arith/NatOrderedType.v @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Logic.eq==>iff) lt. + Proof. repeat red; intros; subst; auto. Qed. + + Definition le_lteq := le_lt_or_eq_iff. + Definition compare_spec := nat_compare_spec. + +End Nat_as_OT. + +(** Note that [Nat_as_OT] can also be seen as a [UsualOrderedType] + and a [OrderedType] (and also as a [DecidableType]). *) + + + +(** * An [order] tactic for Peano numbers *) + +Module NatOrder := OTF_to_OrderTac Nat_as_OT. +Ltac nat_order := NatOrder.order. + +(** 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 Test. +Let test : forall x y : nat, x<=y -> y<=x -> x=y. +Proof. nat_order. Qed. +End Test. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index cc970ae4..42335f98 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Peano_dec.v 9698 2007-03-12 17:11:32Z letouzey $ i*) +(*i $Id$ i*) Require Import Decidable. diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v index 6d510447..9b7c6261 100644 --- a/theories/Arith/Plus.v +++ b/theories/Arith/Plus.v @@ -6,11 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Plus.v 9750 2007-04-06 00:58:14Z letouzey $ i*) +(*i $Id$ i*) (** Properties of addition. [add] is defined in [Init/Peano.v] as: << -Fixpoint plus (n m:nat) {struct n} : nat := +Fixpoint plus (n m:nat) : nat := match n with | O => m | S p => S (p + m) @@ -65,7 +65,7 @@ Qed. Hint Resolve plus_assoc: arith v62. Lemma plus_permute : forall n m p, n + (m + p) = m + (n + p). -Proof. +Proof. intros; rewrite (plus_assoc m n p); rewrite (plus_comm m n); auto with arith. Qed. @@ -179,7 +179,7 @@ Definition plus_is_one : Proof. intro m; destruct m as [| n]; auto. destruct n; auto. - intros. + intros. simpl in H. discriminate H. Defined. @@ -187,18 +187,18 @@ Defined. 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. + 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. (** * Tail-recursive plus *) -(** [tail_plus] is an alternative definition for [plus] which is +(** [tail_plus] is an alternative definition for [plus] which is tail-recursive, whereas [plus] is not. This can be useful when extracting programs. *) -Fixpoint tail_plus n m {struct n} : nat := +Fixpoint tail_plus n m : nat := match n with | O => m | S n => tail_plus n (S m) @@ -215,7 +215,7 @@ Lemma succ_plus_discr : forall n m, n <> S (plus 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; + intro H; apply IHn; apply eq_add_S; rewrite H; rewrite <- plus_n_Sm; reflexivity. Qed. diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index 6ad640eb..5bc5d2a5 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Wf_nat.v 11072 2008-06-08 16:13:37Z herbelin $ i*) +(*i $Id$ i*) (** Well-founded relations and natural numbers *) @@ -46,9 +46,9 @@ Defined. (** It is possible to directly prove the induction principle going back to primitive recursion on natural numbers ([induction_ltof1]) or to use the previous lemmas to extract a program with a fixpoint - ([induction_ltof2]) + ([induction_ltof2]) -the ML-like program for [induction_ltof1] is : +the ML-like program for [induction_ltof1] is : [[ let induction_ltof1 f F a = let rec indrec n k = @@ -58,7 +58,7 @@ let induction_ltof1 f F a = in indrec (f a + 1) a ]] -the ML-like program for [induction_ltof2] is : +the ML-like program for [induction_ltof2] is : [[ let induction_ltof2 F a = indrec a where rec indrec a = F a indrec;; @@ -78,7 +78,7 @@ Proof. unfold ltof in |- *; intros b ltfafb. apply IHn. apply lt_le_trans with (f a); auto with arith. -Defined. +Defined. Theorem induction_gtof1 : forall P:A -> Set, @@ -262,7 +262,7 @@ Unset Implicit Arguments. (** [n]th iteration of the function [f] *) -Fixpoint iter_nat (n:nat) (A:Type) (f:A -> A) (x:A) {struct n} : A := +Fixpoint iter_nat (n:nat) (A:Type) (f:A -> A) (x:A) : A := match n with | O => x | S n' => f (iter_nat n' A f x) @@ -271,8 +271,8 @@ Fixpoint iter_nat (n:nat) (A:Type) (f:A -> A) (x:A) {struct n} : A := Theorem iter_nat_plus : forall (n m:nat) (A:Type) (f:A -> A) (x:A), iter_nat (n + m) A f x = iter_nat n A f (iter_nat m A f x). -Proof. +Proof. simple induction n; [ simpl in |- *; auto with arith - | intros; simpl in |- *; apply f_equal with (f := f); apply H ]. + | intros; simpl in |- *; apply f_equal with (f := f); apply H ]. Qed. diff --git a/theories/Arith/vo.itarget b/theories/Arith/vo.itarget new file mode 100644 index 00000000..c3f29d21 --- /dev/null +++ b/theories/Arith/vo.itarget @@ -0,0 +1,23 @@ +Arith_base.vo +Arith.vo +Between.vo +Bool_nat.vo +Compare_dec.vo +Compare.vo +Div2.vo +EqNat.vo +Euclid.vo +Even.vo +Factorial.vo +Gt.vo +Le.vo +Lt.vo +Max.vo +Minus.vo +Min.vo +Mult.vo +Peano_dec.vo +Plus.vo +Wf_nat.vo +NatOrderedType.vo +MinMax.vo diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 47b9fc83..7f54efa3 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -6,12 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Bool.v 10812 2008-04-17 16:42:37Z letouzey $ i*) +(*i $Id$ i*) (** The type [bool] is defined in the prelude as [Inductive bool : Set := true : bool | false : bool] *) +(** Most of the lemmas in this file are trivial after breaking all booleans *) + +Ltac destr_bool := + intros; destruct_all bool; simpl in *; trivial; try discriminate. + (** Interpretation of booleans as propositions *) + Definition Is_true (b:bool) := match b with | true => True @@ -33,42 +39,40 @@ Defined. Lemma diff_true_false : true <> false. Proof. - unfold not in |- *; intro contr; change (Is_true false) in |- *. - elim contr; simpl in |- *; trivial. + discriminate. Qed. Hint Resolve diff_true_false : bool v62. Lemma diff_false_true : false <> true. -Proof. - red in |- *; intros H; apply diff_true_false. - symmetry in |- *. -assumption. +Proof. + discriminate. Qed. Hint Resolve diff_false_true : bool v62. Hint Extern 1 (false <> true) => exact diff_false_true. Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False. Proof. - intros b H; rewrite H; auto with bool. + destr_bool. Qed. Lemma not_true_is_false : forall b:bool, b <> true -> b = false. Proof. - destruct b. - intros. - red in H; elim H. - reflexivity. - intros abs. - reflexivity. + destr_bool; intuition. Qed. Lemma not_false_is_true : forall b:bool, b <> false -> b = true. Proof. - destruct b. - intros. - reflexivity. - intro H; red in H; elim H. - reflexivity. + destr_bool; intuition. +Qed. + +Lemma not_true_iff_false : forall b, b <> true <-> b = false. +Proof. + destr_bool; intuition. +Qed. + +Lemma not_false_iff_true : forall b, b <> false <-> b = true. +Proof. + destr_bool; intuition. Qed. (**********************) @@ -82,6 +86,11 @@ Definition leb (b1 b2:bool) := end. Hint Unfold leb: bool v62. +Lemma leb_implb : forall b1 b2, leb b1 b2 <-> implb b1 b2 = true. +Proof. + destr_bool; intuition. +Qed. + (* Infix "<=" := leb : bool_scope. *) (*************) @@ -99,37 +108,33 @@ Definition eqb (b1 b2:bool) : bool := Lemma eqb_subst : forall (P:bool -> Prop) (b1 b2:bool), eqb b1 b2 = true -> P b1 -> P b2. Proof. - unfold eqb in |- *. - intros P b1. - intros b2. - case b1. - case b2. - trivial with bool. - intros H. - inversion_clear H. - case b2. - intros H. - inversion_clear H. - trivial with bool. + destr_bool. Qed. Lemma eqb_reflx : forall b:bool, eqb b b = true. Proof. - intro b. - case b. - trivial with bool. - trivial with bool. + destr_bool. Qed. Lemma eqb_prop : forall a b:bool, eqb a b = true -> a = b. Proof. - destruct a; destruct b; simpl in |- *; intro; discriminate H || reflexivity. + destr_bool. +Qed. + +Lemma eqb_true_iff : forall a b:bool, eqb a b = true <-> a = b. +Proof. + destr_bool; intuition. +Qed. + +Lemma eqb_false_iff : forall a b:bool, eqb a b = false <-> a <> b. +Proof. + destr_bool; intuition. Qed. (************************) (** * A synonym of [if] on [bool] *) (************************) - + Definition ifb (b1 b2 b3:bool) : bool := match b1 with | true => b2 @@ -144,12 +149,12 @@ Open Scope bool_scope. Lemma negb_orb : forall b1 b2:bool, negb (b1 || b2) = negb b1 && negb b2. Proof. - destruct b1; destruct b2; simpl in |- *; reflexivity. + destr_bool. Qed. Lemma negb_andb : forall b1 b2:bool, negb (b1 && b2) = negb b1 || negb b2. Proof. - destruct b1; destruct b2; simpl in |- *; reflexivity. + destr_bool. Qed. (********************************) @@ -158,12 +163,12 @@ Qed. Lemma negb_involutive : forall b:bool, negb (negb b) = b. Proof. - destruct b; reflexivity. + destr_bool. Qed. Lemma negb_involutive_reverse : forall b:bool, b = negb (negb b). Proof. - destruct b; reflexivity. + destr_bool. Qed. Notation negb_elim := negb_involutive (only parsing). @@ -171,35 +176,39 @@ Notation negb_intro := negb_involutive_reverse (only parsing). Lemma negb_sym : forall b b':bool, b' = negb b -> b = negb b'. Proof. - destruct b; destruct b'; intros; simpl in |- *; trivial with bool. + destr_bool. Qed. Lemma no_fixpoint_negb : forall b:bool, negb b <> b. Proof. - destruct b; simpl in |- *; intro; apply diff_true_false; - auto with bool. + destr_bool. Qed. Lemma eqb_negb1 : forall b:bool, eqb (negb b) b = false. Proof. - destruct b. - trivial with bool. - trivial with bool. + destr_bool. Qed. - + Lemma eqb_negb2 : forall b:bool, eqb b (negb b) = false. Proof. - destruct b. - trivial with bool. - trivial with bool. + destr_bool. Qed. - Lemma if_negb : forall (A:Type) (b:bool) (x y:A), (if negb b then x else y) = (if b then y else x). Proof. - destruct b; trivial. + destr_bool. +Qed. + +Lemma negb_true_iff : forall b, negb b = true <-> b = false. +Proof. + destr_bool; intuition. +Qed. + +Lemma negb_false_iff : forall b, negb b = false <-> b = true. +Proof. + destr_bool; intuition. Qed. @@ -207,46 +216,60 @@ Qed. (** * Properties of [orb] *) (********************************) +Lemma orb_true_iff : + forall b1 b2, b1 || b2 = true <-> b1 = true \/ b2 = true. +Proof. + destr_bool; intuition. +Qed. + +Lemma orb_false_iff : + forall b1 b2, b1 || b2 = false <-> b1 = false /\ b2 = false. +Proof. + destr_bool; intuition. +Qed. + Lemma orb_true_elim : forall b1 b2:bool, b1 || b2 = true -> {b1 = true} + {b2 = true}. Proof. - destruct b1; simpl in |- *; auto with bool. + destruct b1; simpl; auto. Defined. Lemma orb_prop : forall a b:bool, a || b = true -> a = true \/ b = true. Proof. - destruct a; destruct b; simpl in |- *; try (intro H; discriminate H); - auto with bool. + intros; apply orb_true_iff; trivial. Qed. Lemma orb_true_intro : forall b1 b2:bool, b1 = true \/ b2 = true -> b1 || b2 = true. Proof. - destruct b1; auto with bool. - destruct 1; intros. - elim diff_true_false; auto with bool. - rewrite H; trivial with bool. + intros; apply orb_true_iff; trivial. Qed. Hint Resolve orb_true_intro: bool v62. Lemma orb_false_intro : forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false. Proof. - intros b1 b2 H1 H2; rewrite H1; rewrite H2; trivial with bool. + intros. subst. reflexivity. Qed. Hint Resolve orb_false_intro: bool v62. +Lemma orb_false_elim : + forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false. +Proof. + intros. apply orb_false_iff; trivial. +Qed. + (** [true] is a zero for [orb] *) Lemma orb_true_r : forall b:bool, b || true = true. Proof. - auto with bool. + destr_bool. Qed. Hint Resolve orb_true_r: bool v62. Lemma orb_true_l : forall b:bool, true || b = true. Proof. - trivial with bool. + reflexivity. Qed. Notation orb_b_true := orb_true_r (only parsing). @@ -256,34 +279,24 @@ Notation orb_true_b := orb_true_l (only parsing). Lemma orb_false_r : forall b:bool, b || false = b. Proof. - destruct b; trivial with bool. + destr_bool. Qed. Hint Resolve orb_false_r: bool v62. Lemma orb_false_l : forall b:bool, false || b = b. Proof. - destruct b; trivial with bool. + destr_bool. Qed. Hint Resolve orb_false_l: bool v62. Notation orb_b_false := orb_false_r (only parsing). Notation orb_false_b := orb_false_l (only parsing). -Lemma orb_false_elim : - forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false. -Proof. - destruct b1. - intros; elim diff_true_false; auto with bool. - destruct b2. - intros; elim diff_true_false; auto with bool. - auto with bool. -Qed. - (** Complementation *) Lemma orb_negb_r : forall b:bool, b || negb b = true. Proof. - destruct b; reflexivity. + destr_bool. Qed. Hint Resolve orb_negb_r: bool v62. @@ -293,14 +306,14 @@ Notation orb_neg_b := orb_negb_r (only parsing). Lemma orb_comm : forall b1 b2:bool, b1 || b2 = b2 || b1. Proof. - destruct b1; destruct b2; reflexivity. + destr_bool. Qed. (** Associativity *) Lemma orb_assoc : forall b1 b2 b3:bool, b1 || (b2 || b3) = b1 || b2 || b3. Proof. - destruct b1; destruct b2; destruct b3; reflexivity. + destr_bool. Qed. Hint Resolve orb_comm orb_assoc: bool v62. @@ -308,38 +321,44 @@ Hint Resolve orb_comm orb_assoc: bool v62. (** * Properties of [andb] *) (*******************************) -Lemma andb_true_iff : +Lemma andb_true_iff : forall b1 b2:bool, b1 && b2 = true <-> b1 = true /\ b2 = true. Proof. - destruct b1; destruct b2; intuition. + destr_bool; intuition. +Qed. + +Lemma andb_false_iff : + forall b1 b2:bool, b1 && b2 = false <-> b1 = false \/ b2 = false. +Proof. + destr_bool; intuition. Qed. Lemma andb_true_eq : forall a b:bool, true = a && b -> true = a /\ true = b. Proof. - destruct a; destruct b; auto. + destr_bool. auto. Defined. Lemma andb_false_intro1 : forall b1 b2:bool, b1 = false -> b1 && b2 = false. Proof. - destruct b1; destruct b2; simpl in |- *; tauto || auto with bool. + intros. apply andb_false_iff. auto. Qed. Lemma andb_false_intro2 : forall b1 b2:bool, b2 = false -> b1 && b2 = false. Proof. - destruct b1; destruct b2; simpl in |- *; tauto || auto with bool. + intros. apply andb_false_iff. auto. Qed. (** [false] is a zero for [andb] *) Lemma andb_false_r : forall b:bool, b && false = false. Proof. - destruct b; auto with bool. + destr_bool. Qed. Lemma andb_false_l : forall b:bool, false && b = false. Proof. - trivial with bool. + reflexivity. Qed. Notation andb_b_false := andb_false_r (only parsing). @@ -349,12 +368,12 @@ Notation andb_false_b := andb_false_l (only parsing). Lemma andb_true_r : forall b:bool, b && true = b. Proof. - destruct b; auto with bool. + destr_bool. Qed. Lemma andb_true_l : forall b:bool, true && b = b. Proof. - trivial with bool. + reflexivity. Qed. Notation andb_b_true := andb_true_r (only parsing). @@ -363,7 +382,7 @@ Notation andb_true_b := andb_true_l (only parsing). Lemma andb_false_elim : forall b1 b2:bool, b1 && b2 = false -> {b1 = false} + {b2 = false}. Proof. - destruct b1; simpl in |- *; auto with bool. + destruct b1; simpl; auto. Defined. Hint Resolve andb_false_elim: bool v62. @@ -371,8 +390,8 @@ Hint Resolve andb_false_elim: bool v62. Lemma andb_negb_r : forall b:bool, b && negb b = false. Proof. - destruct b; reflexivity. -Qed. + destr_bool. +Qed. Hint Resolve andb_negb_r: bool v62. Notation andb_neg_b := andb_negb_r (only parsing). @@ -381,14 +400,14 @@ Notation andb_neg_b := andb_negb_r (only parsing). Lemma andb_comm : forall b1 b2:bool, b1 && b2 = b2 && b1. Proof. - destruct b1; destruct b2; reflexivity. + destr_bool. Qed. (** Associativity *) Lemma andb_assoc : forall b1 b2 b3:bool, b1 && (b2 && b3) = b1 && b2 && b3. Proof. - destruct b1; destruct b2; destruct b3; reflexivity. + destr_bool. Qed. Hint Resolve andb_comm andb_assoc: bool v62. @@ -402,25 +421,25 @@ Hint Resolve andb_comm andb_assoc: bool v62. Lemma andb_orb_distrib_r : forall b1 b2 b3:bool, b1 && (b2 || b3) = b1 && b2 || b1 && b3. Proof. - destruct b1; destruct b2; destruct b3; reflexivity. + destr_bool. Qed. Lemma andb_orb_distrib_l : forall b1 b2 b3:bool, (b1 || b2) && b3 = b1 && b3 || b2 && b3. Proof. - destruct b1; destruct b2; destruct b3; reflexivity. + destr_bool. Qed. Lemma orb_andb_distrib_r : forall b1 b2 b3:bool, b1 || b2 && b3 = (b1 || b2) && (b1 || b3). Proof. - destruct b1; destruct b2; destruct b3; reflexivity. + destr_bool. Qed. Lemma orb_andb_distrib_l : forall b1 b2 b3:bool, b1 && b2 || b3 = (b1 || b3) && (b2 || b3). Proof. - destruct b1; destruct b2; destruct b3; reflexivity. + destr_bool. Qed. (* Compatibility *) @@ -433,12 +452,12 @@ Notation demorgan4 := orb_andb_distrib_l (only parsing). Lemma absoption_andb : forall b1 b2:bool, b1 && (b1 || b2) = b1. Proof. - destruct b1; destruct b2; simpl in |- *; reflexivity. + destr_bool. Qed. Lemma absoption_orb : forall b1 b2:bool, b1 || b1 && b2 = b1. Proof. - destruct b1; destruct b2; simpl in |- *; reflexivity. + destr_bool. Qed. (*********************************) @@ -449,12 +468,12 @@ Qed. Lemma xorb_false_r : forall b:bool, xorb b false = b. Proof. - destruct b; trivial. + destr_bool. Qed. Lemma xorb_false_l : forall b:bool, xorb false b = b. Proof. - destruct b; trivial. + destr_bool. Qed. Notation xorb_false := xorb_false_r (only parsing). @@ -464,12 +483,12 @@ Notation false_xorb := xorb_false_l (only parsing). Lemma xorb_true_r : forall b:bool, xorb b true = negb b. Proof. - trivial. + reflexivity. Qed. Lemma xorb_true_l : forall b:bool, xorb true b = negb b. Proof. - destruct b; trivial. + reflexivity. Qed. Notation xorb_true := xorb_true_r (only parsing). @@ -479,14 +498,14 @@ Notation true_xorb := xorb_true_l (only parsing). Lemma xorb_nilpotent : forall b:bool, xorb b b = false. Proof. - destruct b; trivial. + destr_bool. Qed. (** Commutativity *) Lemma xorb_comm : forall b b':bool, xorb b b' = xorb b' b. Proof. - destruct b; destruct b'; trivial. + destr_bool. Qed. (** Associativity *) @@ -494,61 +513,64 @@ Qed. Lemma xorb_assoc_reverse : forall b b' b'':bool, xorb (xorb b b') b'' = xorb b (xorb b' b''). Proof. - destruct b; destruct b'; destruct b''; trivial. + destr_bool. Qed. Notation xorb_assoc := xorb_assoc_reverse (only parsing). (* Compatibility *) Lemma xorb_eq : forall b b':bool, xorb b b' = false -> b = b'. Proof. - destruct b; destruct b'; trivial. - unfold xorb in |- *. intros. rewrite H. reflexivity. + destr_bool. Qed. Lemma xorb_move_l_r_1 : forall b b' b'':bool, xorb b b' = b'' -> b' = xorb b b''. Proof. - intros. rewrite <- (false_xorb b'). rewrite <- (xorb_nilpotent b). rewrite xorb_assoc. - rewrite H. reflexivity. + destr_bool. Qed. Lemma xorb_move_l_r_2 : forall b b' b'':bool, xorb b b' = b'' -> b = xorb b'' b'. Proof. - intros. rewrite xorb_comm in H. rewrite (xorb_move_l_r_1 b' b b'' H). apply xorb_comm. + destr_bool. Qed. Lemma xorb_move_r_l_1 : forall b b' b'':bool, b = xorb b' b'' -> xorb b' b = b''. Proof. - intros. rewrite H. rewrite <- xorb_assoc. rewrite xorb_nilpotent. apply false_xorb. + destr_bool. Qed. Lemma xorb_move_r_l_2 : forall b b' b'':bool, b = xorb b' b'' -> xorb b b'' = b'. Proof. - intros. rewrite H. rewrite xorb_assoc. rewrite xorb_nilpotent. apply xorb_false. + destr_bool. Qed. (** Lemmas about the [b = true] embedding of [bool] to [Prop] *) -Lemma eq_true_iff_eq : forall b1 b2, (b1 = true <-> b2 = true) -> b1 = b2. -Proof. - intros b1 b2; case b1; case b2; intuition. +Lemma eq_iff_eq_true : forall b1 b2, b1 = b2 <-> (b1 = true <-> b2 = true). +Proof. + destr_bool; intuition. +Qed. + +Lemma eq_true_iff_eq : forall b1 b2, (b1 = true <-> b2 = true) -> b1 = b2. +Proof. + apply eq_iff_eq_true. Qed. Notation bool_1 := eq_true_iff_eq (only parsing). (* Compatibility *) Lemma eq_true_negb_classical : forall b:bool, negb b <> true -> b = true. Proof. - destruct b; intuition. + destr_bool; intuition. Qed. Notation bool_3 := eq_true_negb_classical (only parsing). (* Compatibility *) -Lemma eq_true_not_negb : forall b:bool, b <> true -> negb b = true. +Lemma eq_true_not_negb : forall b:bool, b <> true -> negb b = true. Proof. - destruct b; intuition. + destr_bool; intuition. Qed. Notation bool_6 := eq_true_not_negb (only parsing). (* Compatibility *) @@ -589,17 +611,17 @@ Hint Unfold Is_true: bool. Lemma Is_true_eq_true : forall x:bool, Is_true x -> x = true. Proof. - destruct x; simpl in |- *; tauto. + destr_bool; tauto. Qed. Lemma Is_true_eq_left : forall x:bool, x = true -> Is_true x. Proof. - intros; rewrite H; auto with bool. + intros; subst; auto with bool. Qed. Lemma Is_true_eq_right : forall x:bool, true = x -> Is_true x. Proof. - intros; rewrite <- H; auto with bool. + intros; subst; auto with bool. Qed. Notation Is_true_eq_true2 := Is_true_eq_right (only parsing). @@ -608,34 +630,34 @@ Hint Immediate Is_true_eq_right Is_true_eq_left: bool. Lemma eqb_refl : forall x:bool, Is_true (eqb x x). Proof. - destruct x; simpl; auto with bool. + destr_bool. Qed. Lemma eqb_eq : forall x y:bool, Is_true (eqb x y) -> x = y. Proof. - destruct x; destruct y; simpl; tauto. + destr_bool; tauto. Qed. (** [Is_true] and connectives *) -Lemma orb_prop_elim : +Lemma orb_prop_elim : forall a b:bool, Is_true (a || b) -> Is_true a \/ Is_true b. Proof. - destruct a; destruct b; simpl; tauto. + destr_bool; tauto. Qed. Notation orb_prop2 := orb_prop_elim (only parsing). -Lemma orb_prop_intro : +Lemma orb_prop_intro : forall a b:bool, Is_true a \/ Is_true b -> Is_true (a || b). Proof. - destruct a; destruct b; simpl; tauto. + destr_bool; tauto. Qed. Lemma andb_prop_intro : forall b1 b2:bool, Is_true b1 /\ Is_true b2 -> Is_true (b1 && b2). Proof. - destruct b1; destruct b2; simpl in |- *; tauto. + destr_bool; tauto. Qed. Hint Resolve andb_prop_intro: bool v62. @@ -646,66 +668,65 @@ Notation andb_true_intro2 := Lemma andb_prop_elim : forall a b:bool, Is_true (a && b) -> Is_true a /\ Is_true b. Proof. - destruct a; destruct b; simpl in |- *; try (intro H; discriminate H); - auto with bool. + destr_bool; auto. Qed. Hint Resolve andb_prop_elim: bool v62. Notation andb_prop2 := andb_prop_elim (only parsing). -Lemma eq_bool_prop_intro : - forall b1 b2, (Is_true b1 <-> Is_true b2) -> b1 = b2. -Proof. - destruct b1; destruct b2; simpl in *; intuition. +Lemma eq_bool_prop_intro : + forall b1 b2, (Is_true b1 <-> Is_true b2) -> b1 = b2. +Proof. + destr_bool; tauto. Qed. Lemma eq_bool_prop_elim : forall b1 b2, b1 = b2 -> (Is_true b1 <-> Is_true b2). -Proof. - intros b1 b2; case b1; case b2; intuition. -Qed. +Proof. + destr_bool; tauto. +Qed. Lemma negb_prop_elim : forall b, Is_true (negb b) -> ~ Is_true b. Proof. - destruct b; intuition. + destr_bool; tauto. Qed. Lemma negb_prop_intro : forall b, ~ Is_true b -> Is_true (negb b). Proof. - destruct b; simpl in *; intuition. + destr_bool; tauto. Qed. Lemma negb_prop_classical : forall b, ~ Is_true (negb b) -> Is_true b. Proof. - destruct b; intuition. + destr_bool; tauto. Qed. Lemma negb_prop_involutive : forall b, Is_true b -> ~ Is_true (negb b). Proof. - destruct b; intuition. + destr_bool; tauto. Qed. (** Rewrite rules about andb, orb and if (used in romega) *) -Lemma andb_if : forall (A:Type)(a a':A)(b b' : bool), - (if b && b' then a else a') = +Lemma andb_if : forall (A:Type)(a a':A)(b b' : bool), + (if b && b' then a else a') = (if b then if b' then a else a' else a'). Proof. - destruct b; destruct b'; auto. + destr_bool. Qed. -Lemma negb_if : forall (A:Type)(a a':A)(b:bool), - (if negb b then a else a') = +Lemma negb_if : forall (A:Type)(a a':A)(b:bool), + (if negb b then a else a') = (if b then a' else a). Proof. - destruct b; auto. + destr_bool. Qed. (*****************************************) -(** * Alternative versions of [andb] and [orb] +(** * Alternative versions of [andb] and [orb] with lazy behavior (for vm_compute) *) (*****************************************) -Notation "a &&& b" := (if a then b else false) +Notation "a &&& b" := (if a then b else false) (at level 40, left associativity) : lazy_bool_scope. Notation "a ||| b" := (if a then true else b) (at level 50, left associativity) : lazy_bool_scope. @@ -714,12 +735,51 @@ Open Local Scope lazy_bool_scope. Lemma andb_lazy_alt : forall a b : bool, a && b = a &&& b. Proof. - unfold andb; auto. + reflexivity. Qed. Lemma orb_lazy_alt : forall a b : bool, a || b = a ||| b. Proof. - unfold orb; auto. + reflexivity. +Qed. + +(*****************************************) +(** * Reflect: a specialized inductive type for + relating propositions and booleans, + as popularized by the Ssreflect library. *) +(*****************************************) + +Inductive reflect (P : Prop) : bool -> Set := + | ReflectT : P -> reflect P true + | ReflectF : ~ P -> reflect P false. +Hint Constructors reflect : bool. + +(** Interest: a case on a reflect lemma or hyp performs clever + unification, and leave the goal in a convenient shape + (a bit like case_eq). *) + +(** Relation with iff : *) + +Lemma reflect_iff : forall P b, reflect P b -> (P<->b=true). +Proof. + destruct 1; intuition; discriminate. +Qed. + +Lemma iff_reflect : forall P b, (P<->b=true) -> reflect P b. +Proof. + destr_bool; intuition. Qed. +(** It would be nice to join [reflect_iff] and [iff_reflect] + in a unique [iff] statement, but this isn't allowed since + [iff] is in Prop. *) + +(** Reflect implies decidability of the proposition *) + +Lemma reflect_dec : forall P b, reflect P b -> {P}+{~P}. +Proof. + destruct 1; auto. +Qed. +(** Reciprocally, from a decidability, we could state a + [reflect] as soon as we have a [bool_of_sumbool]. *) diff --git a/theories/Bool/BoolEq.v b/theories/Bool/BoolEq.v index 806ac70f..625cbd19 100644 --- a/theories/Bool/BoolEq.v +++ b/theories/Bool/BoolEq.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BoolEq.v 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id$ i*) (* Cuihtlauac Alvarado - octobre 2000 *) (** Properties of a boolean equality *) diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v index 0e8ea33c..7ecfa43f 100644 --- a/theories/Bool/Bvector.v +++ b/theories/Bool/Bvector.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Bvector.v 11004 2008-05-28 09:09:12Z herbelin $ i*) +(*i $Id$ i*) (** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *) @@ -16,34 +16,34 @@ Require Import Arith. Open Local Scope nat_scope. -(** -On s'inspire de List.v pour fabriquer les vecteurs de bits. -La dimension du vecteur est un paramtre trop important pour -se contenter de la fonction "length". -La premire ide est de faire un record avec la liste et la longueur. -Malheureusement, cette verification a posteriori amene a faire -de nombreux lemmes pour gerer les longueurs. -La seconde ide est de faire un type dpendant dans lequel la -longueur est un paramtre de construction. Cela complique un -peu les inductions structurelles et dans certains cas on -utilisera un terme de preuve comme dfinition, car le -mcanisme d'infrence du type du filtrage n'est pas toujours -aussi puissant que celui implant par les tactiques d'limination. +(** +We build bit vectors in the spirit of List.v. +The size of the vector is a parameter which is too important +to be accessible only via function "length". +The first idea is to build a record with both the list and the length. +Unfortunately, this a posteriori verification leads to +numerous lemmas for handling lengths. +The second idea is to use a dependent type in which the length +is a building parameter. This leads to structural induction that +are slightly more complex and in some cases we will use a proof-term +as definition, since the type inference mechanism for pattern-matching +is sometimes weaker that the one implemented for elimination tactiques. *) Section VECTORS. -(** -Un vecteur est une liste de taille n d'lments d'un ensemble A. -Si la taille est non nulle, on peut extraire la premire composante et -le reste du vecteur, la dernire composante ou rajouter ou enlever -une composante (carry) ou repeter la dernire composante en fin de vecteur. -On peut aussi tronquer le vecteur de ses p dernires composantes ou -au contraire l'tendre (concatner) d'un vecteur de longueur p. -Une fonction unaire sur A gnre une fonction des vecteurs de taille n -dans les vecteurs de taille n en appliquant f terme terme. -Une fonction binaire sur A gnre une fonction des couples de vecteurs -de taille n dans les vecteurs de taille n en appliquant f terme terme. +(** +A vector is a list of size n whose elements belongs to a set A. +If the size is non-zero, we can extract the first component and the +rest of the vector, as well as the last component, or adding or +removing a component (carry) or repeating the last component at the +end of the vector. +We can also truncate the vector and remove its p last components or +reciprocally extend the vector by concatenation. +A unary function over A generates a function on vectors of size n by +applying f pointwise. +A binary function over A generates a function on pairs of vectors of +size n by applying f pointwise. *) Variable A : Type. @@ -93,7 +93,7 @@ Lemma Vshiftin : forall n:nat, A -> vector n -> vector (S n). Proof. induction n as [| n f]; intros a v. exact (Vcons a 0 v). - + inversion v as [| a0 n0 H0 H1 ]. exact (Vcons a (S n) (f a H0)). Defined. @@ -103,7 +103,7 @@ Proof. induction n as [| n f]; intro v. inversion v. exact (Vcons a 1 v). - + inversion v as [| a n0 H0 H1 ]. exact (Vcons a (S (S n)) (f H0)). Defined. @@ -113,9 +113,9 @@ Proof. induction p as [| p f]; intros H v. rewrite <- minus_n_O. exact v. - + apply (Vshiftout (n - S p)). - + rewrite minus_Sn_m. apply f. auto with *. @@ -147,7 +147,7 @@ Lemma Vbinary : forall n:nat, vector n -> vector n -> vector n. Proof. induction n as [| n h]; intros v v0. exact Vnil. - + inversion v as [| a n0 H0 H1]; inversion v0 as [| a0 n1 H2 H3]. exact (Vcons (g a a0) n (h H0 H2)). Defined. @@ -180,7 +180,7 @@ Qed. End VECTORS. -(* suppressed: incompatible with Coq-Art book +(* suppressed: incompatible with Coq-Art book Implicit Arguments Vnil [A]. Implicit Arguments Vcons [A n]. *) @@ -188,15 +188,16 @@ Implicit Arguments Vcons [A n]. Section BOOLEAN_VECTORS. (** -Un vecteur de bits est un vecteur sur l'ensemble des boolens de longueur fixe. -ATTENTION : le stockage s'effectue poids FAIBLE en tte. -On en extrait le bit de poids faible (head) et la fin du vecteur (tail). -On calcule la ngation d'un vecteur, le et, le ou et le xor bit bit de 2 vecteurs. -On calcule les dcalages d'une position vers la gauche (vers les poids forts, on -utilise donc Vshiftout, vers la droite (vers les poids faibles, on utilise Vshiftin) en -insrant un bit 'carry' (logique) ou en rptant le bit de poids fort (arithmtique). -ATTENTION : Tous les dcalages prennent la taille moins un comme paramtre -(ils ne travaillent que sur des vecteurs au moins de longueur un). +A bit vector is a vector over booleans. +Notice that the LEAST significant bit comes first (little-endian representation). +We extract the least significant bit (head) and the rest of the vector (tail). +We compute bitwise operation on vector: negation, and, or, xor. +We compute size-preserving shifts: to the left (towards most significant bits, +we hence use Vshiftout) and to the right (towards least significant bits, +we use Vshiftin) by inserting a 'carry' bit (logical shift) or by repeating +the most significant bit (arithmetical shift). +NOTA BENE: all shift operations expect predecessor of size as parameter +(they only work on non-empty vectors). *) Definition Bvector := vector bool. @@ -232,22 +233,19 @@ Definition BshiftRl (n:nat) (bv:Bvector (S n)) (carry:bool) := Definition BshiftRa (n:nat) (bv:Bvector (S n)) := Bhigh (S n) (Vshiftrepeat bool n bv). -Fixpoint BshiftL_iter (n:nat) (bv:Bvector (S n)) (p:nat) {struct p} : - Bvector (S n) := +Fixpoint BshiftL_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) := match p with | O => bv | S p' => BshiftL n (BshiftL_iter n bv p') false end. -Fixpoint BshiftRl_iter (n:nat) (bv:Bvector (S n)) (p:nat) {struct p} : - Bvector (S n) := +Fixpoint BshiftRl_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) := match p with | O => bv | S p' => BshiftRl n (BshiftRl_iter n bv p') false end. -Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) {struct p} : - Bvector (S n) := +Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) := match p with | O => bv | S p' => BshiftRa n (BshiftRa_iter n bv p') diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v index af9acea1..90f7ee66 100644 --- a/theories/Bool/DecBool.v +++ b/theories/Bool/DecBool.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: DecBool.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Set Implicit Arguments. diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v index 0a98c32a..c2b5ed79 100644 --- a/theories/Bool/IfProp.v +++ b/theories/Bool/IfProp.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: IfProp.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id$ i*) Require Import Bool. diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v index 0da72f56..06ab77cf 100644 --- a/theories/Bool/Sumbool.v +++ b/theories/Bool/Sumbool.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Sumbool.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) (** Here are collected some results about the type sumbool (see INIT/Specif.v) [sumbool A B], which is written [{A}+{B}], is the informative @@ -39,18 +39,18 @@ Defined. Section connectives. Variables A B C D : Prop. - + Hypothesis H1 : {A} + {B}. Hypothesis H2 : {C} + {D}. - + Definition sumbool_and : {A /\ C} + {B \/ D}. case H1; case H2; auto. Defined. - + Definition sumbool_or : {A \/ C} + {B /\ D}. case H1; case H2; auto. Defined. - + Definition sumbool_not : {B} + {A}. case H1; auto. Defined. diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v index fe656777..5e9d4afa 100644 --- a/theories/Bool/Zerob.v +++ b/theories/Bool/Zerob.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zerob.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Import Arith. Require Import Bool. diff --git a/theories/Bool/vo.itarget b/theories/Bool/vo.itarget new file mode 100644 index 00000000..24cbf4ed --- /dev/null +++ b/theories/Bool/vo.itarget @@ -0,0 +1,7 @@ +BoolEq.vo +Bool.vo +Bvector.vo +DecBool.vo +IfProp.vo +Sumbool.vo +Zerob.vo diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index 15cabf81..0a35ef45 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -6,46 +6,51 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Decidable equivalences. - * - * Author: Matthieu Sozeau - * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud - * 91405 Orsay, France *) +(** * Decidable equivalences. -(* $Id: EquivDec.v 12187 2009-06-13 19:36:59Z msozeau $ *) + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) + +(* $Id$ *) (** Export notations. *) Require Export Coq.Classes.Equivalence. -(** The [DecidableSetoid] class asserts decidability of a [Setoid]. It can be useful in proofs to reason more - classically. *) +(** The [DecidableSetoid] class asserts decidability of a [Setoid]. + It can be useful in proofs to reason more classically. *) Require Import Coq.Logic.Decidable. +Require Import Coq.Bool.Bool. +Require Import Coq.Arith.Peano_dec. +Require Import Coq.Program.Program. + +Generalizable Variables A B R. Open Scope equiv_scope. Class DecidableEquivalence `(equiv : Equivalence A) := setoid_decidable : forall x y : A, decidable (x === y). -(** The [EqDec] class gives a decision procedure for a particular setoid equality. *) +(** The [EqDec] class gives a decision procedure for a particular + setoid equality. *) Class EqDec A R {equiv : Equivalence R} := equiv_dec : forall x y : A, { x === y } + { x =/= y }. -(** We define the [==] overloaded notation for deciding equality. It does not take precedence - of [==] defined in the type scope, hence we can have both at the same time. *) +(** We define the [==] overloaded notation for deciding equality. It does not + take precedence of [==] defined in the type scope, hence we can have both + at the same time. *) Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70) : equiv_scope. Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } := match x with - | left H => @right _ _ H - | right H => @left _ _ H + | left H => @right _ _ H + | right H => @left _ _ H end. -Require Import Coq.Program.Program. - Open Local Scope program_scope. (** Invert the branches. *) @@ -69,17 +74,14 @@ Infix "<>b" := nequiv_decb (no associativity, at level 70). (** Decidable leibniz equality instances. *) -Require Import Coq.Arith.Peano_dec. - -(** The equiv is burried inside the setoid, but we can recover it by specifying which setoid we're talking about. *) +(** The equiv is burried inside the setoid, but we can recover it by specifying + which setoid we're talking about. *) Program Instance nat_eq_eqdec : EqDec nat eq := eq_nat_dec. -Require Import Coq.Bool.Bool. - Program Instance bool_eqdec : EqDec bool eq := bool_dec. -Program Instance unit_eqdec : EqDec unit eq := λ x y, in_left. +Program Instance unit_eqdec : EqDec unit eq := fun x y => in_left. Next Obligation. Proof. @@ -87,41 +89,37 @@ Program Instance unit_eqdec : EqDec unit eq := λ x y, in_left. reflexivity. Qed. +Obligation Tactic := unfold complement, equiv ; program_simpl. + Program Instance prod_eqdec `(EqDec A eq, EqDec B eq) : ! EqDec (prod A B) eq := { equiv_dec x y := - let '(x1, x2) := x in - let '(y1, y2) := y in - if x1 == y1 then + let '(x1, x2) := x in + let '(y1, y2) := y in + if x1 == y1 then if x2 == y2 then in_left else in_right else in_right }. - Solve Obligations using unfold complement, equiv ; program_simpl. - Program Instance sum_eqdec `(EqDec A eq, EqDec B eq) : EqDec (sum A B) eq := { - equiv_dec x y := + equiv_dec x y := match x, y with | inl a, inl b => if a == b then in_left else in_right | inr a, inr b => if a == b then in_left else in_right | inl _, inr _ | inr _, inl _ => in_right end }. - Solve Obligations using unfold complement, equiv ; program_simpl. - -(** Objects of function spaces with countable domains like bool have decidable equality. - Proving the reflection requires functional extensionality though. *) +(** Objects of function spaces with countable domains like bool have decidable + equality. Proving the reflection requires functional extensionality though. *) Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq := - { equiv_dec f g := + { equiv_dec f g := if f true == g true then if f false == g false then in_left else in_right else in_right }. - Solve Obligations using try red ; unfold equiv, complement ; program_simpl. - Next Obligation. Proof. extensionality x. @@ -131,21 +129,19 @@ Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq := Require Import List. Program Instance list_eqdec `(eqa : EqDec A eq) : ! EqDec (list A) eq := - { equiv_dec := - fix aux (x : list A) y { struct x } := + { equiv_dec := + fix aux (x y : list A) := match x, y with | nil, nil => in_left - | cons hd tl, cons hd' tl' => + | cons hd tl, cons hd' tl' => if hd == hd' then if aux tl tl' then in_left else in_right else in_right | _, _ => in_right end }. - Solve Obligations using unfold equiv, complement in *; program_simpl; - intuition (discriminate || eauto). + Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto). - Next Obligation. destruct x ; destruct y ; intuition eauto. Defined. + Next Obligation. destruct y ; intuition eauto. Defined. - Solve Obligations using unfold equiv, complement in *; program_simpl; - intuition (discriminate || eauto). + Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto). diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v index 7068bc6b..d0f24347 100644 --- a/theories/Classes/Equivalence.v +++ b/theories/Classes/Equivalence.v @@ -6,13 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Typeclass-based setoids. Definitions on [Equivalence]. - +(** * Typeclass-based setoids. Definitions on [Equivalence]. + Author: Matthieu Sozeau - Institution: LRI, CNRS UMR 8623 - Universitcopyright Paris Sud - 91405 Orsay, France *) + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) -(* $Id: Equivalence.v 12187 2009-06-13 19:36:59Z msozeau $ *) +(* $Id$ *) Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. @@ -25,16 +25,20 @@ Require Import Coq.Classes.Morphisms. Set Implicit Arguments. Unset Strict Implicit. +Generalizable Variables A R eqA B S eqB. +Local Obligation Tactic := simpl_relation. + Open Local Scope signature_scope. Definition equiv `{Equivalence A R} : relation A := R. -(** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *) +(** Overloaded notations for setoid equivalence and inequivalence. + Not to be confused with [eq] and [=]. *) Notation " x === y " := (equiv x y) (at level 70, no associativity) : equiv_scope. Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : equiv_scope. - + Open Local Scope equiv_scope. (** Overloading for [PER]. *) @@ -60,7 +64,7 @@ Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv. (** Use the [substitute] command which substitutes an equivalence in every hypothesis. *) -Ltac setoid_subst H := +Ltac setoid_subst H := match type of H with ?x === ?y => substitute H ; clear H x end. @@ -70,7 +74,7 @@ Ltac setoid_subst_nofail := | [ 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. @@ -100,19 +104,19 @@ Ltac equivify := repeat equivify_tac. Section Respecting. - (** Here we build an equivalence instance for functions which relates respectful ones only, + (** Here we build an equivalence instance for functions which relates respectful ones only, we do not export it. *) - Definition respecting `(eqa : Equivalence A (R : relation A), eqb : Equivalence B (R' : relation B)) : Type := + Definition respecting `(eqa : Equivalence A (R : relation A), eqb : Equivalence B (R' : relation 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' (proj1_sig f x) (proj1_sig g y)). - + Solve Obligations using unfold respecting in * ; simpl_relation ; program_simpl. Next Obligation. - Proof. + Proof. unfold respecting in *. program_simpl. transitivity (y y0); auto. apply H0. reflexivity. Qed. diff --git a/theories/Classes/Functions.v b/theories/Classes/Functions.v deleted file mode 100644 index 998f8cb7..00000000 --- a/theories/Classes/Functions.v +++ /dev/null @@ -1,41 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* B) (RA ++> RB) f) : Prop := - injective : forall x y : A, RB (f x) (f y) -> RA x y. - -Class Surjective `(m : Morphism (A -> B) (RA ++> RB) f) : Prop := - surjective : forall y, exists x : A, RB y (f x). - -Definition Bijective `(m : Morphism (A -> B) (RA ++> RB) (f : A -> B)) := - Injective m /\ Surjective m. - -Class MonoMorphism `(m : Morphism (A -> B) (eqA ++> eqB)) := - monic :> Injective m. - -Class EpiMorphism `(m : Morphism (A -> B) (eqA ++> eqB)) := - epic :> Surjective m. - -Class IsoMorphism `(m : Morphism (A -> B) (eqA ++> eqB)) := - { monomorphism :> MonoMorphism m ; epimorphism :> EpiMorphism m }. - -Class AutoMorphism `(m : Morphism (A -> A) (eqA ++> eqA)) {I : IsoMorphism m}. diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v index 762cc5c1..f6e51018 100644 --- a/theories/Classes/Init.v +++ b/theories/Classes/Init.v @@ -6,22 +6,26 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Initialization code for typeclasses, setting up the default tactic +(** * Initialization code for typeclasses, setting up the default tactic for instance search. Author: Matthieu Sozeau - Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud - 91405 Orsay, France *) + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) -(* $Id: Init.v 12187 2009-06-13 19:36:59Z msozeau $ *) +(* $Id$ *) (** Hints for the proof search: these combinators should be considered rigid. *) Require Import Coq.Program.Basics. -Typeclasses Opaque id const flip compose arrow impl iff. +Typeclasses Opaque id const flip compose arrow impl iff not all. -(** The unconvertible typeclass, to test that two objects of the same type are +(** Apply using the same opacity information as typeclass proof search. *) + +Ltac class_apply c := autoapply c using typeclass_instances. + +(** The unconvertible typeclass, to test that two objects of the same type are actually different. *) Class Unconvertible (A : Type) (a b : A) := unconvertible : unit. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 2b653e27..370321c0 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Type) (D : B -> Type) - (R : A -> B -> Prop) - (R' : forall (x : A) (y : B), C x -> D y -> Prop) : - (forall x : A, C x) -> (forall x : B, D x) -> Prop := +Definition respectful_hetero + (A B : Type) + (C : A -> Type) (D : B -> Type) + (R : A -> B -> Prop) + (R' : forall (x : A) (y : B), C x -> D y -> Prop) : + (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. *) @@ -53,27 +57,27 @@ Definition respectful {A B : Type} Delimit Scope signature_scope with signature. -Arguments Scope Morphism [type_scope signature_scope]. +Arguments Scope Proper [type_scope signature_scope]. Arguments Scope respectful [type_scope type_scope signature_scope signature_scope]. -Module MorphismNotations. +Module ProperNotations. - Notation " R ++> R' " := (@respectful _ _ (R%signature) (R'%signature)) + 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 _ _ (inverse (R%signature)) (R'%signature)) (right associativity, at level 55) : signature_scope. -End MorphismNotations. +End ProperNotations. -Export MorphismNotations. +Export ProperNotations. Open Local Scope signature_scope. -(** Dependent pointwise lifting of a relation on the range. *) +(** Dependent pointwise lifting of a relation on the range. *) Definition forall_relation {A : Type} {B : A -> Type} (sig : Π a : A, relation (B a)) : relation (Π x : A, B x) := λ f g, Π a : A, sig a (f a) (g a). @@ -82,10 +86,10 @@ Arguments Scope forall_relation [type_scope type_scope signature_scope]. (** Non-dependent pointwise lifting *) -Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) := +Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) := Eval compute in forall_relation (B:=λ _, B) (λ _, R). -Lemma pointwise_pointwise A B (R : relation B) : +Lemma pointwise_pointwise A B (R : relation B) : relation_equivalence (pointwise_relation A R) (@eq A ==> R). Proof. intros. split. simpl_relation. firstorder. Qed. @@ -98,8 +102,7 @@ Hint Unfold Transitive : core. Typeclasses Opaque respectful pointwise_relation forall_relation. -Program Instance respectful_per `(PER A (R : relation A), PER B (R' : relation B)) : - PER (R ==> R'). +Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R'). Next Obligation. Proof with auto. @@ -110,47 +113,46 @@ Program Instance respectful_per `(PER A (R : relation A), PER B (R' : relation B (** Subrelations induce a morphism on the identity. *) -Instance subrelation_id_morphism `(subrelation A R₁ R₂) : Morphism (R₁ ==> R₂) id. +Instance subrelation_id_proper `(subrelation A R₁ R₂) : Proper (R₁ ==> R₂) id. Proof. firstorder. Qed. (** The subrelation property goes through products as usual. *) -Instance morphisms_subrelation_respectful `(subl : subrelation A R₂ R₁, subr : subrelation B S₁ S₂) : +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. *) -Instance morphisms_subrelation_refl : ! subrelation A R R. +Lemma subrelation_refl A R : @subrelation A R R. Proof. simpl_relation. Qed. -(** [Morphism] is itself a covariant morphism for [subrelation]. *) +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. -Lemma subrelation_morphism `(mor : Morphism A R₁ m, unc : Unconvertible (relation A) R₁ R₂, - sub : subrelation A R₁ R₂) : Morphism R₂ m. +(** [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. -Instance morphism_subrelation_morphism : - Morphism (subrelation ++> @eq _ ==> impl) (@Morphism A). -Proof. reduce. subst. firstorder. Qed. - -(** We use an external tactic to manage the application of subrelation, which is otherwise - always applicable. We allow its use only once per branch. *) - -Inductive subrelation_done : Prop := did_subrelation : subrelation_done. +CoInductive apply_subrelation : Prop := do_subrelation. -Inductive normalization_done : Prop := did_normalization. - -Ltac subrelation_tac := +Ltac proper_subrelation := match goal with - | [ _ : subrelation_done |- _ ] => fail 1 - | [ |- @Morphism _ _ _ ] => let H := fresh "H" in - set(H:=did_subrelation) ; eapply @subrelation_morphism + [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper end. -Hint Extern 5 (@Morphism _ _ _) => subrelation_tac : typeclass_instances. +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]. *) @@ -164,11 +166,29 @@ 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. -(** The complement of a relation conserves its morphisms. *) +(** 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. + +Hint Extern 4 (subrelation (inverse _) _) => + class_apply @subrelation_symmetric : typeclass_instances. -Program Instance complement_morphism - `(mR : Morphism (A -> A -> Prop) (RA ==> RA ==> iff) R) : - Morphism (RA ==> RA ==> iff) (complement R). +(** The complement of a relation conserves its proper elements. *) + +Program Instance complement_proper + `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : + Proper (RA ==> RA ==> iff) (complement R). Next Obligation. Proof. @@ -177,22 +197,22 @@ Program Instance complement_morphism intuition. Qed. -(** The [inverse] too, actually the [flip] instance is a bit more general. *) +(** The [inverse] too, actually the [flip] instance is a bit more general. *) -Program Instance flip_morphism - `(mor : Morphism (A -> B -> C) (RA ==> RB ==> RC) f) : - Morphism (RB ==> RA ==> RC) (flip f). +Program Instance 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 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) : Morphism (R --> R ++> impl) R. + `(Transitive A R) : Proper (R --> R ++> impl) R. Next Obligation. Proof with auto. @@ -200,10 +220,10 @@ Program Instance trans_contra_co_morphism transitivity x0... Qed. -(** Morphism declarations for partial applications. *) +(** Proper declarations for partial applications. *) Program Instance trans_contra_inv_impl_morphism - `(Transitive A R) : Morphism (R --> inverse impl) (R x) | 3. + `(Transitive A R) : Proper (R --> inverse impl) (R x) | 3. Next Obligation. Proof with auto. @@ -211,7 +231,7 @@ Program Instance trans_contra_inv_impl_morphism Qed. Program Instance trans_co_impl_morphism - `(Transitive A R) : Morphism (R ==> impl) (R x) | 3. + `(Transitive A R) : Proper (R ++> impl) (R x) | 3. Next Obligation. Proof with auto. @@ -219,7 +239,7 @@ Program Instance trans_co_impl_morphism Qed. Program Instance trans_sym_co_inv_impl_morphism - `(PER A R) : Morphism (R ==> inverse impl) (R x) | 2. + `(PER A R) : Proper (R ++> inverse impl) (R x) | 3. Next Obligation. Proof with auto. @@ -227,7 +247,7 @@ Program Instance trans_sym_co_inv_impl_morphism Qed. Program Instance trans_sym_contra_impl_morphism - `(PER A R) : Morphism (R --> impl) (R x) | 2. + `(PER A R) : Proper (R --> impl) (R x) | 3. Next Obligation. Proof with auto. @@ -235,7 +255,7 @@ Program Instance trans_sym_contra_impl_morphism Qed. Program Instance per_partial_app_morphism - `(PER A R) : Morphism (R ==> iff) (R x) | 1. + `(PER A R) : Proper (R ==> iff) (R x) | 2. Next Obligation. Proof with auto. @@ -249,7 +269,7 @@ Program Instance per_partial_app_morphism to get an [R y z] goal. *) Program Instance trans_co_eq_inv_impl_morphism - `(Transitive A R) : Morphism (R ==> (@eq A) ==> inverse impl) R | 2. + `(Transitive A R) : Proper (R ==> (@eq A) ==> inverse impl) R | 2. Next Obligation. Proof with auto. @@ -258,21 +278,21 @@ Program Instance trans_co_eq_inv_impl_morphism (** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *) -Program Instance PER_morphism `(PER A R) : Morphism (R ==> R ==> iff) R | 1. +Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. Next Obligation. Proof with auto. split ; intros. transitivity x0... transitivity x... symmetry... - + transitivity y... transitivity y0... symmetry... Qed. Lemma symmetric_equiv_inverse `(Symmetric A R) : relation_equivalence R (flip R). Proof. firstorder. Qed. - -Program Instance compose_morphism A B C R₀ R₁ R₂ : - Morphism ((R₁ ==> R₂) ==> (R₀ ==> R₁) ==> (R₀ ==> R₂)) (@compose A B C). + +Program Instance compose_proper A B C R₀ R₁ R₂ : + Proper ((R₁ ==> R₂) ==> (R₀ ==> R₁) ==> (R₀ ==> R₂)) (@compose A B C). Next Obligation. Proof. @@ -280,7 +300,7 @@ Program Instance compose_morphism A B C R₀ R₁ R₂ : unfold compose. apply H. apply H0. apply H1. Qed. -(** Coq functions are morphisms for leibniz equality, +(** Coq functions are morphisms for Leibniz equality, applied only if really needed. *) Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') : @@ -289,13 +309,13 @@ Proof. simpl_relation. Qed. (** [respectful] is a morphism for relation equivalence. *) -Instance respectful_morphism : - Morphism (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B). +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. @@ -309,43 +329,50 @@ 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 - [Morphism (A -> B) _ _] goal, making proof-search much slower. A cleaner solution would be to be able + 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.*) + resolution of a type class constraint.*) -Class MorphismProxy {A} (R : relation A) (m : A) : Prop := - respect_proxy : R m m. +Class ProperProxy {A} (R : relation A) (m : A) : Prop := + proper_proxy : R m m. -Instance reflexive_morphism_proxy - `(Reflexive A R) (x : A) : MorphismProxy R x | 1. +Lemma eq_proper_proxy A (x : A) : ProperProxy (@eq A) x. Proof. firstorder. Qed. -Instance morphism_morphism_proxy - `(Morphism A R x) : MorphismProxy R x | 2. +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. + (** [R] is Reflexive, hence we can build the needed proof. *) -Lemma Reflexive_partial_app_morphism `(Morphism (A -> B) (R ==> R') m, MorphismProxy A R x) : - Morphism R' (m x). +Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) : + Proper R' (m x). Proof. simpl_relation. Qed. Class Params {A : Type} (of : A) (arity : nat). Class PartialApplication. -Ltac partial_application_tactic := +CoInductive normalization_done : Prop := did_normalization. + +Ltac partial_application_tactic := let rec do_partial_apps H m := match m with - | ?m' ?x => eapply @Reflexive_partial_app_morphism ; [do_partial_apps H m'|clear H] + | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; [do_partial_apps H m'|clear H] | _ => idtac end in let rec do_partial H ar m := match ar with | 0 => do_partial_apps H m - | S ?n' => + | S ?n' => match m with ?m' ?x => do_partial H n' m' end @@ -357,25 +384,24 @@ Ltac partial_application_tactic := 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 + let v' := eval compute in v in subst m'; do_partial H v' m in match goal with - | [ _ : subrelation_done |- _ ] => fail 1 | [ _ : normalization_done |- _ ] => fail 1 | [ _ : @Params _ _ _ |- _ ] => fail 1 - | [ |- @Morphism ?T _ (?m ?x) ] => - match goal with - | [ _ : PartialApplication |- _ ] => - eapply @Reflexive_partial_app_morphism - | _ => - on_morphism (m x) || - (eapply @Reflexive_partial_app_morphism ; + | [ |- @Proper ?T _ (?m ?x) ] => + match goal with + | [ _ : PartialApplication |- _ ] => + class_apply @Reflexive_partial_app_morphism + | _ => + on_morphism (m x) || + (class_apply @Reflexive_partial_app_morphism ; [ pose Build_PartialApplication | idtac ]) end end. -Hint Extern 4 (@Morphism _ _ _) => partial_application_tactic : typeclass_instances. +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'). @@ -387,7 +413,7 @@ Qed. (** Special-purpose class to do normalization of signatures w.r.t. inverse. *) -Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop := +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] @@ -400,19 +426,19 @@ 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. intros. +Proof. unfold Normalizes in *. intros. rewrite NA, NB. firstorder. Qed. -Ltac inverse := +Ltac inverse := match goal with - | [ |- Normalizes _ (respectful _ _) _ ] => eapply @inverse_arrow - | _ => eapply @inverse_atom + | [ |- 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 +(** 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. @@ -421,18 +447,25 @@ Proof. firstorder. Qed. Lemma inverse2 `(subrelation A R R') : subrelation R (inverse (inverse R')). Proof. firstorder. Qed. -Hint Extern 1 (subrelation (flip _) _) => eapply @inverse1 : typeclass_instances. -Hint Extern 1 (subrelation _ (flip _)) => eapply @inverse2 : typeclass_instances. +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 morphism_inverse_morphism `(mor : Morphism A R m) : Morphism (inverse R) m := mor. +Definition proper_inverse_proper `(mor : Proper A R m) : Proper (inverse R) m := mor. -Hint Extern 2 (@Morphism _ (flip _) _) => eapply @morphism_inverse_morphism : typeclass_instances. +Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_inverse_proper : typeclass_instances. (** Bootstrap !!! *) -Instance morphism_morphism : Morphism (relation_equivalence ==> @eq _ ==> iff) (@Morphism A). +Instance proper_proper : Proper (relation_equivalence ==> eq ==> iff) (@Proper A). Proof. simpl_relation. reduce in H. @@ -443,37 +476,139 @@ Proof. apply H0. Qed. -Lemma morphism_releq_morphism `(Normalizes A R R', Morphism _ R' m) : Morphism R m. +Lemma proper_normalizes_proper `(Normalizes A R0 R1, Proper A R1 m) : Proper R0 m. Proof. - intros. - - pose respect as r. - pose normalizes as norm. - setoid_rewrite norm. + red in H, H0. + setoid_rewrite H. assumption. Qed. -Ltac morphism_normalization := +Ltac proper_normalization := match goal with - | [ _ : subrelation_done |- _ ] => fail 1 | [ _ : normalization_done |- _ ] => fail 1 - | [ |- @Morphism _ _ _ ] => let H := fresh "H" in - set(H:=did_normalization) ; eapply @morphism_releq_morphism + | [ _ : apply_subrelation |- @Proper _ ?R _ ] => let H := fresh "H" in + set(H:=did_normalization) ; class_apply @proper_normalizes_proper end. -Hint Extern 6 (@Morphism _ _ _) => morphism_normalization : typeclass_instances. +Hint Extern 6 (@Proper _ _ _) => proper_normalization : typeclass_instances. (** Every reflexive relation gives rise to a morphism, only for immediately solving goals without variables. *) -Lemma reflexive_morphism `{Reflexive A R} (x : A) - : Morphism R x. +Lemma reflexive_proper `{Reflexive A R} (x : A) + : Proper R x. Proof. firstorder. Qed. -Ltac morphism_reflexive := +Lemma proper_eq A (x : A) : Proper (@eq A) x. +Proof. intros. apply reflexive_proper. Qed. + +Ltac proper_reflexive := match goal with | [ _ : normalization_done |- _ ] => fail 1 - | [ _ : subrelation_done |- _ ] => fail 1 - | [ |- @Morphism _ _ _ ] => eapply @reflexive_morphism + | _ => class_apply proper_eq || class_apply @reflexive_proper end. -Hint Extern 7 (@Morphism _ _ _) => morphism_reflexive : typeclass_instances. +Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances. + + +(** When the relation on the domain is symmetric, we can + inverse 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. +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==>inverse 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 relation on the domain is symmetric, a predicate is + compatible with [iff] as soon as it is compatible with [impl]. + Same with a binary relation. *) + +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_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. + +(** A [PartialOrder] is compatible with its underlying equivalence. *) + +Instance PartialOrder_proper `(PartialOrder A eqA R) : + Proper (eqA==>eqA==>iff) R. +Proof. +intros. +apply proper_sym_impl_iff_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. + +Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => + class_apply PartialOrder_StrictOrder : typeclass_instances. + +(** 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==>iff) 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==>iff) 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 (PartialOrder _ (relation_disjunction _ _)) => + class_apply StrictOrder_PartialOrder : typeclass_instances. diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v index 3bbd56cf..2dc033d2 100644 --- a/theories/Classes/Morphisms_Prop.v +++ b/theories/Classes/Morphisms_Prop.v @@ -6,81 +6,83 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Morphism instances for propositional connectives. - +(** * [Proper] instances for propositional connectives. + Author: Matthieu Sozeau - Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud - 91405 Orsay, France *) + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) Require Import Coq.Classes.Morphisms. Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. +Local Obligation Tactic := simpl_relation. + (** Standard instances for [not], [iff] and [impl]. *) (** Logical negation. *) Program Instance not_impl_morphism : - Morphism (impl --> impl) not. + Proper (impl --> impl) not | 1. -Program Instance not_iff_morphism : - Morphism (iff ++> iff) not. +Program Instance not_iff_morphism : + Proper (iff ++> iff) not. (** Logical conjunction. *) Program Instance and_impl_morphism : - Morphism (impl ==> impl ==> impl) and. + Proper (impl ==> impl ==> impl) and | 1. -Program Instance and_iff_morphism : - Morphism (iff ==> iff ==> iff) and. +Program Instance and_iff_morphism : + Proper (iff ==> iff ==> iff) and. (** Logical disjunction. *) -Program Instance or_impl_morphism : - Morphism (impl ==> impl ==> impl) or. +Program Instance or_impl_morphism : + Proper (impl ==> impl ==> impl) or | 1. -Program Instance or_iff_morphism : - Morphism (iff ==> iff ==> iff) or. +Program Instance or_iff_morphism : + Proper (iff ==> iff ==> iff) or. (** Logical implication [impl] is a morphism for logical equivalence. *) -Program Instance iff_iff_iff_impl_morphism : Morphism (iff ==> iff ==> iff) impl. +Program Instance iff_iff_iff_impl_morphism : Proper (iff ==> iff ==> iff) impl. (** Morphisms for quantifiers *) -Program Instance ex_iff_morphism {A : Type} : Morphism (pointwise_relation A iff ==> iff) (@ex A). +Program Instance ex_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@ex A). Next Obligation. Proof. - unfold pointwise_relation in H. + unfold pointwise_relation in H. split ; intros. - destruct H0 as [x₁ H₁]. - exists x₁. rewrite H in H₁. assumption. - - destruct H0 as [x₁ H₁]. - exists x₁. rewrite H. assumption. + 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} : - Morphism (pointwise_relation A impl ==> impl) (@ex A). + Proper (pointwise_relation A impl ==> impl) (@ex A) | 1. Next Obligation. Proof. - unfold pointwise_relation in H. + unfold pointwise_relation in H. exists H0. apply H. assumption. Qed. -Program Instance ex_inverse_impl_morphism {A : Type} : - Morphism (pointwise_relation A (inverse impl) ==> inverse impl) (@ex A). +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. + unfold pointwise_relation in H. exists H0. apply H. assumption. Qed. -Program Instance all_iff_morphism {A : Type} : - Morphism (pointwise_relation A iff ==> iff) (@all A). +Program Instance all_iff_morphism {A : Type} : + Proper (pointwise_relation A iff ==> iff) (@all A). Next Obligation. Proof. @@ -88,18 +90,18 @@ Program Instance all_iff_morphism {A : Type} : intuition ; specialize (H x0) ; intuition. Qed. -Program Instance all_impl_morphism {A : Type} : - Morphism (pointwise_relation A impl ==> impl) (@all A). - +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} : - Morphism (pointwise_relation A (inverse impl) ==> inverse impl) (@all A). - +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 *. diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v index 4654e654..d8365abc 100644 --- a/theories/Classes/Morphisms_Relations.v +++ b/theories/Classes/Morphisms_Relations.v @@ -6,23 +6,25 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Morphism instances for relations. - +(** * Morphism instances for relations. + Author: Matthieu Sozeau - Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud - 91405 Orsay, France *) + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) Require Import Relation_Definitions. Require Import Coq.Classes.Morphisms. Require Import Coq.Program.Program. +Generalizable Variables A l. + (** Morphisms for relations *) -Instance relation_conjunction_morphism : Morphism (relation_equivalence (A:=A) ==> +Instance relation_conjunction_morphism : Proper (relation_equivalence (A:=A) ==> relation_equivalence ==> relation_equivalence) relation_conjunction. Proof. firstorder. Qed. -Instance relation_disjunction_morphism : Morphism (relation_equivalence (A:=A) ==> +Instance relation_disjunction_morphism : Proper (relation_equivalence (A:=A) ==> relation_equivalence ==> relation_equivalence) relation_disjunction. Proof. firstorder. Qed. @@ -31,25 +33,25 @@ Instance relation_disjunction_morphism : Morphism (relation_equivalence (A:=A) = Require Import List. Lemma predicate_equivalence_pointwise (l : list Type) : - Morphism (@predicate_equivalence l ==> pointwise_lifting iff l) id. + Proper (@predicate_equivalence l ==> pointwise_lifting iff l) id. Proof. do 2 red. unfold predicate_equivalence. auto. Qed. Lemma predicate_implication_pointwise (l : list Type) : - Morphism (@predicate_implication l ==> pointwise_lifting impl l) id. + 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 [R x y] to [R' x y] *) -(* when [R] and [R'] are in [relation_equivalence]. *) +(** The instanciation at relation allows to rewrite applications of relations + [R x y] to [R' x y] when [R] and [R'] are in [relation_equivalence]. *) Instance relation_equivalence_pointwise : - Morphism (relation_equivalence ==> pointwise_relation A (pointwise_relation A iff)) id. + Proper (relation_equivalence ==> pointwise_relation A (pointwise_relation A iff)) id. Proof. intro. apply (predicate_equivalence_pointwise (cons A (cons A nil))). Qed. Instance subrelation_pointwise : - Morphism (subrelation ==> pointwise_relation A (pointwise_relation A impl)) id. + Proper (subrelation ==> pointwise_relation A (pointwise_relation A impl)) id. Proof. intro. apply (predicate_implication_pointwise (cons A (cons A nil))). Qed. -Lemma inverse_pointwise_relation A (R : relation A) : +Lemma inverse_pointwise_relation A (R : relation A) : relation_equivalence (pointwise_relation A (inverse R)) (inverse (pointwise_relation A R)). Proof. intros. split; firstorder. Qed. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index e1de9ee9..9b848551 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Reflexive (complement R). +Class Irreflexive {A} (R : relation A) := + irreflexivity : Reflexive (complement R). -Class Symmetric {A} (R : relation A) := +Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. + +Class Symmetric {A} (R : relation A) := symmetry : forall x y, R x y -> R y x. -Class Asymmetric {A} (R : relation A) := +Class Asymmetric {A} (R : relation A) := asymmetry : forall x y, R x y -> R y x -> False. -Class Transitive {A} (R : relation A) := +Class Transitive {A} (R : relation A) := transitivity : forall x y z, R x y -> R y z -> R x z. Hint Resolve @irreflexivity : ord. @@ -61,7 +65,7 @@ Unset Implicit Arguments. (** A HintDb for relations. *) Ltac solve_relation := - match goal with + match goal with | [ |- ?R ?x ?x ] => reflexivity | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H end. @@ -70,34 +74,39 @@ Hint Extern 4 => solve_relation : relations. (** We can already dualize all these properties. *) -Program Instance flip_Reflexive `(Reflexive A R) : Reflexive (flip R) := - reflexivity (R:=R). +Generalizable Variables A B C D R S T U l eqA eqB eqC eqD. -Program Instance flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) := - irreflexivity (R:=R). +Program Lemma flip_Reflexive `(Reflexive A R) : Reflexive (flip R). +Proof. tauto. Qed. + +Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. -Program Instance flip_Symmetric `(Symmetric A R) : Symmetric (flip R). +Program Definition flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) := + irreflexivity (R:=R). - Solve Obligations using unfold flip ; intros ; tcapp symmetry ; assumption. +Program Definition flip_Symmetric `(Symmetric A R) : Symmetric (flip R) := + fun x y H => symmetry (R:=R) H. -Program Instance flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R). - - Solve Obligations using program_simpl ; unfold flip in * ; intros ; typeclass_app asymmetry ; eauto. +Program Definition flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R) := + fun x y H H' => asymmetry (R:=R) H H'. -Program Instance flip_Transitive `(Transitive A R) : Transitive (flip R). +Program Definition flip_Transitive `(Transitive A R) : Transitive (flip R) := + fun x y z H H' => transitivity (R:=R) H' H. - Solve Obligations using unfold flip ; program_simpl ; typeclass_app transitivity ; eauto. +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. -Program Instance Reflexive_complement_Irreflexive `(Reflexive A (R : relation A)) +Definition Reflexive_complement_Irreflexive `(Reflexive A (R : relation A)) : Irreflexive (complement R). +Proof. firstorder. Qed. - Next Obligation. - Proof. firstorder. Qed. - -Program Instance complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R). +Definition complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R). +Proof. firstorder. Qed. - Next Obligation. - 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. *) @@ -117,7 +126,7 @@ Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid. Ltac reduce := reduce_goal. -Tactic Notation "apply" "*" constr(t) := +Tactic Notation "apply" "*" constr(t) := first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) | refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ]. @@ -125,7 +134,7 @@ Ltac simpl_relation := unfold flip, impl, arrow ; try reduce ; program_simpl ; try ( solve [ intuition ]). -Ltac obligation_tactic ::= simpl_relation. +Local Obligation Tactic := simpl_relation. (** Logical implication. *) @@ -174,13 +183,14 @@ Instance Equivalence_PER `(Equivalence A R) : PER R | 10 := (** 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. + antisymmetry : forall {x y}, R x y -> R y x -> eqA x y. -Program Instance flip_antiSymmetric `(Antisymmetric A eqA R) : - ! Antisymmetric A eqA (flip R). +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 + The instance has low priority as it is always applicable if only the type is constrained. *) Program Instance eq_equivalence : Equivalence (@eq A) | 10. @@ -193,26 +203,24 @@ Program Instance iff_equivalence : Equivalence iff. The resulting theory can be applied to homogeneous binary relations but also to arbitrary n-ary predicates. *) -Require Import Coq.Lists.List. +Local Open Scope list_scope. (* Notation " [ ] " := nil : list_scope. *) (* Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) (at level 1) : list_scope. *) -(* Open Local Scope list_scope. *) - (** A compact representation of non-dependent arities, with the codomain singled-out. *) -Fixpoint arrows (l : list Type) (r : Type) : Type := - match l with +Fixpoint arrows (l : list Type) (r : Type) : Type := + match l with | nil => r | A :: l' => A -> arrows l' r end. (** We can define abbreviations for operation and relation types based on [arrows]. *) -Definition unary_operation A := arrows (cons A nil) A. -Definition binary_operation A := arrows (cons A (cons A nil)) A. -Definition ternary_operation A := arrows (cons A (cons A (cons A nil))) A. +Definition unary_operation A := arrows (A::nil) A. +Definition binary_operation A := arrows (A::A::nil) A. +Definition ternary_operation A := arrows (A::A::A::nil) A. (** We define n-ary [predicate]s as functions into [Prop]. *) @@ -220,13 +228,13 @@ Notation predicate l := (arrows l Prop). (** Unary predicates, or sets. *) -Definition unary_predicate A := predicate (cons A nil). +Definition unary_predicate A := predicate (A::nil). (** Homogeneous binary relations, equivalent to [relation A]. *) -Definition binary_relation A := predicate (cons A (cons A nil)). +Definition binary_relation A := predicate (A::A::nil). -(** We can close a predicate by universal or existential quantification. *) +(** We can close a predicate by universal or existential quantification. *) Fixpoint predicate_all (l : list Type) : predicate l -> Prop := match l with @@ -240,7 +248,7 @@ Fixpoint predicate_exists (l : list Type) : predicate l -> Prop := | A :: tl => fun f => exists x : A, predicate_exists tl (f x) end. -(** Pointwise extension of a binary operation on [T] to a binary operation +(** Pointwise extension of a binary operation on [T] to a binary operation on functions whose codomain is [T]. For an operator on [Prop] this lifts the operator to a binary operation. *) @@ -248,7 +256,7 @@ Fixpoint pointwise_extension {T : Type} (op : binary_operation T) (l : list Type) : binary_operation (arrows l T) := match l with | nil => fun R R' => op R R' - | A :: tl => fun R R' => + | A :: tl => fun R R' => fun x => pointwise_extension op tl (R x) (R' x) end. @@ -257,7 +265,7 @@ Fixpoint pointwise_extension {T : Type} (op : binary_operation T) Fixpoint pointwise_lifting (op : binary_relation Prop) (l : list Type) : binary_relation (predicate l) := match l with | nil => fun R R' => op R R' - | A :: tl => fun R R' => + | A :: tl => fun R R' => forall x, pointwise_lifting op tl (R x) (R' x) end. @@ -289,7 +297,7 @@ Infix "\∙/" := predicate_union (at level 85, right associativity) : predicate_ (** The always [True] and always [False] predicates. *) -Fixpoint true_predicate {l : list Type} : predicate l := +Fixpoint true_predicate {l : list Type} : predicate l := match l with | nil => True | A :: tl => fun _ => @true_predicate tl @@ -306,17 +314,13 @@ 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. Qed. - Next Obligation. induction l ; firstorder. Qed. - Next Obligation. fold pointwise_lifting. induction l. firstorder. @@ -326,59 +330,59 @@ Program Instance predicate_equivalence_equivalence : Program Instance predicate_implication_preorder : PreOrder (@predicate_implication l). - Next Obligation. induction l ; firstorder. Qed. - Next Obligation. induction l. firstorder. - unfold predicate_implication in *. simpl in *. + unfold predicate_implication in *. simpl in *. intro. pose (IHl (x x0) (y x0) (z x0)). firstorder. Qed. -(** We define the various operations which define the algebra on binary relations, +(** 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 (cons _ (cons _ nil)). + @predicate_equivalence (_::_::nil). Class subrelation {A:Type} (R R' : relation A) : Prop := - is_subrelation : @predicate_implication (cons A (cons A nil)) R R'. + is_subrelation : @predicate_implication (A::A::nil) R R'. Implicit Arguments subrelation [[A]]. Definition relation_conjunction {A} (R : relation A) (R' : relation A) : relation A := - @predicate_intersection (cons A (cons A nil)) R R'. + @predicate_intersection (A::A::nil) R R'. Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relation A := - @predicate_union (cons A (cons A nil)) R R'. + @predicate_union (A::A::nil) 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. intro A. exact (@predicate_equivalence_equivalence (cons A (cons A nil))). Qed. +Proof. exact (@predicate_equivalence_equivalence (A::A::nil)). Qed. -Instance relation_implication_preorder : PreOrder (@subrelation A). -Proof. intro A. exact (@predicate_implication_preorder (cons A (cons A nil))). Qed. +Instance relation_implication_preorder A : PreOrder (@subrelation A). +Proof. exact (@predicate_implication_preorder (A::A::nil)). Qed. (** *** Partial Order. A partial order is a preorder which is additionally antisymmetric. - We give an equivalent definition, up-to an equivalence relation + 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)). -(** The equivalence proof is sufficient for proving that [R] must be a morphism +(** 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. + reduce_goal. + pose proof partial_order_equivalence as poe. do 3 red in poe. apply <- poe. firstorder. Qed. @@ -392,5 +396,52 @@ Program Instance subrelation_partial_order : unfold relation_equivalence in *. firstorder. Qed. -Typeclasses Opaque arrows predicate_implication predicate_equivalence +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) := { + 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. diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v new file mode 100644 index 00000000..7972c96c --- /dev/null +++ b/theories/Classes/RelationPairs.v @@ -0,0 +1,153 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* B) : relation A := + fun a a' => R (f a) (f a'). + +Infix "@@" := RelCompFun (at level 30, right associativity) : signature_scope. + +Notation "R @@1" := (R @@ Fst)%signature (at level 30) : signature_scope. +Notation "R @@2" := (R @@ Snd)%signature (at level 30) : signature_scope. + +(** We declare measures to the system using the [Measure] class. + Otherwise the instances would easily introduce loops, + never instantiating the [f] function. *) + +Class Measure {A B} (f : A -> B). + +(** Standard measures. *) + +Instance fst_measure : @Measure (A * B) A Fst. +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). + +Infix "*" := RelProd : signature_scope. + +Section RelCompFun_Instances. + Context {A B : Type} (R : relation B). + + Global Instance RelCompFun_Reflexive + `(Measure A B f, Reflexive _ R) : Reflexive (R@@f). + Proof. firstorder. Qed. + + Global Instance RelCompFun_Symmetric + `(Measure A B f, Symmetric _ R) : Symmetric (R@@f). + Proof. firstorder. Qed. + + Global Instance RelCompFun_Transitive + `(Measure A B f, Transitive _ R) : Transitive (R@@f). + Proof. firstorder. Qed. + + Global Instance RelCompFun_Irreflexive + `(Measure A B f, Irreflexive _ R) : Irreflexive (R@@f). + Proof. firstorder. Qed. + + Global Instance RelCompFun_Equivalence + `(Measure A B f, Equivalence _ R) : Equivalence (R@@f). + + Global Instance RelCompFun_StrictOrder + `(Measure A B f, StrictOrder _ R) : StrictOrder (R@@f). + +End RelCompFun_Instances. + +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. + +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. + +Hint Unfold RelProd RelCompFun. +Hint Extern 2 (RelProd _ _ _ _) => split. + diff --git a/theories/Classes/SetoidAxioms.v b/theories/Classes/SetoidAxioms.v deleted file mode 100644 index 03bb9a80..00000000 --- a/theories/Classes/SetoidAxioms.v +++ /dev/null @@ -1,34 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* x = y. - -(** Application of the extensionality principle for setoids. *) - -Ltac setoid_extensionality := - match goal with - [ |- @eq ?A ?X ?Y ] => apply (setoideq_eq (a:=A) (x:=X) (y:=Y)) - end. diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index d3da7d5a..c41c5769 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -6,23 +6,24 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Typeclass-based setoids, tactics and standard instances. - +(** * Typeclass-based setoids, tactics and standard instances. + Author: Matthieu Sozeau - Institution: LRI, CNRS UMR 8623 - Universitcopyright Paris Sud - 91405 Orsay, France *) + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) -(* $Id: SetoidClass.v 12187 2009-06-13 19:36:59Z msozeau $ *) +(* $Id$ *) Set Implicit Arguments. Unset Strict Implicit. +Generalizable Variables A. + Require Import Coq.Program.Program. Require Import Relation_Definitions. Require Export Coq.Classes.RelationClasses. Require Export Coq.Classes.Morphisms. -Require Import Coq.Classes.Functions. (** A setoid wraps an equivalence. *) @@ -55,7 +56,7 @@ Existing Instance setoid_trans. (* Program Instance eq_setoid : Setoid A := *) (* equiv := eq ; setoid_equiv := eq_equivalence. *) -Program Instance iff_setoid : Setoid Prop := +Program Instance iff_setoid : Setoid Prop := { equiv := iff ; setoid_equiv := iff_equivalence }. (** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *) @@ -69,7 +70,7 @@ Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : (** Use the [clsubstitute] command which substitutes an equality in every hypothesis. *) -Ltac clsubst H := +Ltac clsubst H := match type of H with ?x == ?y => substitute H ; clear H x end. @@ -79,7 +80,7 @@ Ltac clsubst_nofail := | [ H : ?x == ?y |- _ ] => clsubst H ; clsubst_nofail | _ => idtac end. - + (** [subst*] will try its best at substituting every equality in the goal. *) Tactic Notation "clsubst" "*" := clsubst_nofail. @@ -94,7 +95,7 @@ Qed. Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z. Proof. - intros; intro. + intros; intro. assert(y == x) by (symmetry ; auto). assert(y == z) by (transitivity x ; eauto). contradiction. @@ -119,25 +120,15 @@ Ltac setoidify := repeat setoidify_tac. (** Every setoid relation gives rise to a morphism, in fact every partial setoid does. *) -Program Instance setoid_morphism `(sa : Setoid A) : Morphism (equiv ++> equiv ++> iff) equiv := - respect. - -Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Morphism (equiv ++> iff) (equiv x) := - respect. - -Ltac morphism_tac := try red ; unfold arrow ; intros ; program_simpl ; try tauto. - -Ltac obligation_tactic ::= morphism_tac. - -(** These are morphisms used to rewrite at the top level of a proof, - using [iff_impl_id_morphism] if the proof is in [Prop] and - [eq_arrow_id_morphism] if it is in Type. *) +Program Instance setoid_morphism `(sa : Setoid A) : Proper (equiv ++> equiv ++> iff) equiv := + proper_prf. -Program Instance iff_impl_id_morphism : Morphism (iff ++> impl) id. +Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Proper (equiv ++> iff) (equiv x) := + proper_prf. (** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *) -Class PartialSetoid (A : Type) := +Class PartialSetoid (A : Type) := { pequiv : relation A ; pequiv_prf :> PER pequiv }. (** Overloaded notation for partial setoid equivalence. *) @@ -146,4 +137,4 @@ Infix "=~=" := pequiv (at level 70, no associativity) : type_scope. (** Reset the default Program tactic. *) -Ltac obligation_tactic ::= program_simpl. +Obligation Tactic := program_simpl. diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index bac64724..33b4350f 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* ) (y :>)) (no associativity, at level 70). Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } := match x with - | left H => @right _ _ H - | right H => @left _ _ H + | left H => @right _ _ H + | right H => @left _ _ H end. Require Import Coq.Program.Program. @@ -72,7 +77,8 @@ Infix "<>b" := nequiv_decb (no associativity, at level 70). Require Import Coq.Arith.Arith. -(** The equiv is burried inside the setoid, but we can recover it by specifying which setoid we're talking about. *) +(** The equiv is burried inside the setoid, but we can recover + it by specifying which setoid we're talking about. *) Program Instance eq_setoid A : Setoid A | 10 := { equiv := eq ; setoid_equiv := eq_equivalence }. @@ -96,16 +102,17 @@ Program Instance unit_eqdec : EqDec (eq_setoid unit) := Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B)) : EqDec (eq_setoid (prod A B)) := λ x y, - let '(x1, x2) := x in - let '(y1, y2) := y in - if x1 == y1 then + let '(x1, x2) := x in + let '(y1, y2) := y in + if x1 == y1 then if x2 == y2 then in_left else in_right else in_right. Solve Obligations using unfold complement ; program_simpl. -(** Objects of function spaces with countable domains like bool have decidable equality. *) +(** Objects of function spaces with countable domains like bool + have decidable equality. *) Program Instance bool_function_eqdec `(! EqDec (eq_setoid A)) : EqDec (eq_setoid (bool -> A)) := λ f g, diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v index 36f05e31..669be8b0 100644 --- a/theories/Classes/SetoidTactics.v +++ b/theories/Classes/SetoidTactics.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.SetoidTactics") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* idtac end. -Ltac destruct_morphism := +Ltac destruct_proper := match goal with - | [ |- @Morphism ?A ?R ?m ] => red + | [ |- @Proper ?A ?R ?m ] => red end. Ltac reverse_arrows x := @@ -179,11 +171,13 @@ Ltac reverse_arrows x := Ltac default_add_morphism_tactic := unfold flip ; intros ; - (try destruct_morphism) ; + (try destruct_proper) ; match goal with | [ |- (?x ==> ?y) _ _ ] => red_subst_eq_morphism (x ==> y) ; reverse_arrows (x ==> y) end. Ltac add_morphism_tactic := default_add_morphism_tactic. -Ltac obligation_tactic ::= program_simpl. +Obligation Tactic := program_simpl. + +(* Notation "'Morphism' s t " := (@Proper _ (s%signature) t) (at level 10, s at next level, t at next level). *) diff --git a/theories/Classes/vo.itarget b/theories/Classes/vo.itarget new file mode 100644 index 00000000..9daf133b --- /dev/null +++ b/theories/Classes/vo.itarget @@ -0,0 +1,11 @@ +Equivalence.vo +EquivDec.vo +Init.vo +Morphisms_Prop.vo +Morphisms_Relations.vo +Morphisms.vo +RelationClasses.vo +SetoidClass.vo +SetoidDec.vo +SetoidTactics.vo +RelationPairs.vo diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 8cb1236e..8158324e 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -1,4 +1,3 @@ - (***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* true | _ => false end. to achieve logarithmic complexity. *) Fixpoint mem x m : bool := - match m with - | Leaf => false - | Node l y _ r _ => match X.compare x y with - | LT _ => mem x l + match m with + | Leaf => false + | Node l y _ r _ => match X.compare x y with + | LT _ => mem x l | EQ _ => true | GT _ => mem x r end end. -Fixpoint find x m : option elt := - match m with - | Leaf => None - | Node l y d r _ => match X.compare x y with - | LT _ => find x l +Fixpoint find x m : option elt := + match m with + | Leaf => None + | Node l y d r _ => match X.compare x y with + | LT _ => find x l | EQ _ => Some d | GT _ => find x r end @@ -109,7 +108,7 @@ Fixpoint find x m : option elt := (** [create l x r] creates a node, assuming [l] and [r] to be balanced and [|height l - height r| <= 2]. *) -Definition create l x e r := +Definition create l x e r := Node l x e r (max (height l) (height r) + 1). (** [bal l x e r] acts as [create], but performs one step of @@ -117,45 +116,45 @@ Definition create l x e r := Definition assert_false := create. -Fixpoint bal l x d r := - let hl := height l in +Fixpoint bal l x d r := + let hl := height l in let hr := height r in - if gt_le_dec hl (hr+2) then - match l with + if gt_le_dec hl (hr+2) then + match l with | Leaf => assert_false l x d r - | Node ll lx ld lr _ => - if ge_lt_dec (height ll) (height lr) then + | Node ll lx ld lr _ => + if ge_lt_dec (height ll) (height lr) then create ll lx ld (create lr x d r) - else - match lr with + else + match lr with | Leaf => assert_false l x d r - | Node lrl lrx lrd lrr _ => + | Node lrl lrx lrd lrr _ => create (create ll lx ld lrl) lrx lrd (create lrr x d r) end end - else - if gt_le_dec hr (hl+2) then + else + if gt_le_dec hr (hl+2) then match r with | Leaf => assert_false l x d r | Node rl rx rd rr _ => - if ge_lt_dec (height rr) (height rl) then + if ge_lt_dec (height rr) (height rl) then create (create l x d rl) rx rd rr - else + else match rl with | Leaf => assert_false l x d r - | Node rll rlx rld rlr _ => - create (create l x d rll) rlx rld (create rlr rx rd rr) + | Node rll rlx rld rlr _ => + create (create l x d rll) rlx rld (create rlr rx rd rr) end end - else + else create l x d r. (** * Insertion *) -Fixpoint add x d m := - match m with +Fixpoint add x d m := + match m with | Leaf => Node Leaf x d Leaf 1 - | Node l y d' r h => + | Node l y d' r h => match X.compare x y with | LT _ => bal (add x d l) y d' r | EQ _ => Node l y d r h @@ -165,16 +164,16 @@ Fixpoint add x d m := (** * Extraction of minimum binding - Morally, [remove_min] is to be applied to a non-empty tree - [t = Node l x e r h]. Since we can't deal here with [assert false] - for [t=Leaf], we pre-unpack [t] (and forget about [h]). + Morally, [remove_min] is to be applied to a non-empty tree + [t = Node l x e r h]. Since we can't deal here with [assert false] + for [t=Leaf], we pre-unpack [t] (and forget about [h]). *) - -Fixpoint remove_min l x d r : t*(key*elt) := + +Fixpoint remove_min l x d r : t*(key*elt) := match l with | Leaf => (r,(x,d)) - | Node ll lx ld lr lh => - let (l',m) := remove_min ll lx ld lr in + | Node ll lx ld lr lh => + let (l',m) := remove_min ll lx ld lr in (bal l' x d r, m) end. @@ -185,18 +184,18 @@ Fixpoint remove_min l x d r : t*(key*elt) := [|height t1 - height t2| <= 2]. *) -Fixpoint merge s1 s2 := match s1,s2 with - | Leaf, _ => s2 +Fixpoint merge s1 s2 := match s1,s2 with + | Leaf, _ => s2 | _, Leaf => s1 - | _, Node l2 x2 d2 r2 h2 => - match remove_min l2 x2 d2 r2 with + | _, Node l2 x2 d2 r2 h2 => + match remove_min l2 x2 d2 r2 with (s2',(x,d)) => bal s1 x d s2' end end. (** * Deletion *) -Fixpoint remove x m := match m with +Fixpoint remove x m := match m with | Leaf => Leaf | Node l y d r h => match X.compare x y with @@ -206,26 +205,26 @@ Fixpoint remove x m := match m with end end. -(** * join - - Same as [bal] but does not assume anything regarding heights of [l] +(** * join + + Same as [bal] but does not assume anything regarding heights of [l] and [r]. *) Fixpoint join l : key -> elt -> t -> t := match l with | Leaf => add - | Node ll lx ld lr lh => fun x d => - fix join_aux (r:t) : t := match r with + | Node ll lx ld lr lh => fun x d => + fix join_aux (r:t) : t := match r with | Leaf => add x d l - | Node rl rx rd rr rh => + | Node rl rx rd rr rh => if gt_le_dec lh (rh+2) then bal ll lx ld (join lr x d r) - else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr + else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr else create l x d r end end. -(** * Splitting +(** * Splitting [split x m] returns a triple [(l, o, r)] where - [l] is the set of elements of [m] that are [< x] @@ -236,17 +235,17 @@ Fixpoint join l : key -> elt -> t -> t := Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). -Fixpoint split x m : triple := match m with +Fixpoint split x m : triple := match m with | Leaf => << Leaf, None, Leaf >> - | Node l y d r h => - match X.compare x y with + | Node l y d r h => + match X.compare x y with | LT _ => let (ll,o,rl) := split x l in << ll, o, join rl y d r >> | EQ _ => << l, Some d, r >> | GT _ => let (rl,o,rr) := split x r in << join l y d rl, o, rr >> end end. -(** * Concatenation +(** * Concatenation Same as [merge] but does not assume anything about heights. *) @@ -256,7 +255,7 @@ Definition concat m1 m2 := | Leaf, _ => m2 | _ , Leaf => m1 | _, Node l2 x2 d2 r2 _ => - let (m2',xd) := remove_min l2 x2 d2 r2 in + let (m2',xd) := remove_min l2 x2 d2 r2 in join m1 xd#1 xd#2 m2' end. @@ -277,7 +276,7 @@ Definition elements := elements_aux nil. (** * Fold *) -Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A := +Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A := fun a => match m with | Leaf => a | Node l x d r _ => fold f r (f x d (fold f l a)) @@ -293,11 +292,11 @@ Inductive enumeration := | End : enumeration | More : key -> elt -> t -> enumeration -> enumeration. -(** [cons m e] adds the elements of tree [m] on the head of +(** [cons m e] adds the elements of tree [m] on the head of enumeration [e]. *) -Fixpoint cons m e : enumeration := - match m with +Fixpoint cons m e : enumeration := + match m with | Leaf => e | Node l x d r h => cons l (More x d r e) end. @@ -316,7 +315,7 @@ Definition equal_more x1 d1 (cont:enumeration->bool) e2 := (** Comparison of left tree, middle element, then right tree *) -Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := +Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := match m1 with | Leaf => cont e2 | Node l1 x1 d1 r1 _ => @@ -341,8 +340,8 @@ Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). (** * Map *) -Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := - match m with +Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := + match m with | Leaf => Leaf _ | Node l x d r h => Node (map f l) x (f d) (map f r) h end. @@ -350,7 +349,7 @@ Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := (* * Mapi *) Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := - match m with + match m with | Leaf => Leaf _ | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h end. @@ -358,28 +357,28 @@ Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := (** * Map with removal *) Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt) - : t elt' := - match m with + : t elt' := + match m with | Leaf => Leaf _ - | Node l x d r h => - match f x d with + | Node l x d r h => + match f x d with | Some d' => join (map_option f l) x d' (map_option f r) | None => concat (map_option f l) (map_option f r) end end. (** * Optimized map2 - - Suggestion by B. Gregoire: a [map2] function with specialized - arguments allowing to bypass some tree traversal. Instead of one - [f0] of type [key -> option elt -> option elt' -> option elt''], - we ask here for: + + Suggestion by B. Gregoire: a [map2] function with specialized + arguments allowing to bypass some tree traversal. Instead of one + [f0] of type [key -> option elt -> option elt' -> option elt''], + we ask here for: - [f] which is a specialisation of [f0] when first option isn't [None] - [mapl] treats a [tree elt] with [f0] when second option is [None] - [mapr] treats a [tree elt'] with [f0] when first option is [None] - The idea is that [mapl] and [mapr] can be instantaneous (e.g. - the identity or some constant function). + The idea is that [mapl] and [mapr] can be instantaneous (e.g. + the identity or some constant function). *) Section Map2_opt. @@ -388,13 +387,13 @@ Variable f : key -> elt -> option elt' -> option elt''. Variable mapl : t elt -> t elt''. Variable mapr : t elt' -> t elt''. -Fixpoint map2_opt m1 m2 := - match m1, m2 with - | Leaf, _ => mapr m2 +Fixpoint map2_opt m1 m2 := + match m1, m2 with + | Leaf, _ => mapr m2 | _, Leaf => mapl m1 - | Node l1 x1 d1 r1 h1, _ => + | Node l1 x1 d1 r1 h1, _ => let (l2',o2,r2') := split x1 m2 in - match f x1 d1 o2 with + match f x1 d1 o2 with | Some e => join (map2_opt l1 l2') x1 e (map2_opt r1 r2') | None => concat (map2_opt l1 l2') (map2_opt r1 r2') end @@ -403,8 +402,8 @@ Fixpoint map2_opt m1 m2 := End Map2_opt. (** * Map2 - - The [map2] function of the Map interface can be implemented + + The [map2] function of the Map interface can be implemented via [map2_opt] and [map_option]. *) @@ -412,8 +411,8 @@ Section Map2. Variable elt elt' elt'' : Type. Variable f : option elt -> option elt' -> option elt''. -Definition map2 : t elt -> t elt' -> t elt'' := - map2_opt +Definition map2 : t elt -> t elt' -> t elt'' := + map2_opt (fun _ d o => f (Some d) o) (map_option (fun _ d => f (Some d) None)) (map_option (fun _ d' => f None (Some d'))). @@ -432,24 +431,24 @@ Variable elt : Type. Inductive MapsTo (x : key)(e : elt) : t elt -> Prop := | MapsRoot : forall l r h y, X.eq x y -> MapsTo x e (Node l y e r h) - | MapsLeft : forall l r h y e', + | MapsLeft : forall l r h y e', MapsTo x e l -> MapsTo x e (Node l y e' r h) - | MapsRight : forall l r h y e', + | MapsRight : forall l r h y e', MapsTo x e r -> MapsTo x e (Node l y e' r h). Inductive In (x : key) : t elt -> Prop := | InRoot : forall l r h y e, X.eq x y -> In x (Node l y e r h) - | InLeft : forall l r h y e', + | InLeft : forall l r h y e', In x l -> In x (Node l y e' r h) - | InRight : forall l r h y e', + | InRight : forall l r h y e', In x r -> In x (Node l y e' r h). Definition In0 k m := exists e:elt, MapsTo k e m. (** ** Binary search trees *) -(** [lt_tree x s]: all elements in [s] are smaller than [x] +(** [lt_tree x s]: all elements in [s] are smaller than [x] (resp. greater for [gt_tree]) *) Definition lt_tree x m := forall y, In y m -> X.lt y x. @@ -459,7 +458,7 @@ Definition gt_tree x m := forall y, In y m -> X.lt x y. Inductive bst : t elt -> Prop := | BSLeaf : bst (Leaf _) - | BSNode : forall x e l r h, bst l -> bst r -> + | BSNode : forall x e l r h, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (Node l x e r h). End Invariants. @@ -474,10 +473,10 @@ Module Proofs. Functional Scheme mem_ind := Induction for mem Sort Prop. Functional Scheme find_ind := Induction for find Sort Prop. -Functional Scheme bal_ind := Induction for bal Sort Prop. +Functional Scheme bal_ind := Induction for bal Sort Prop. Functional Scheme add_ind := Induction for add Sort Prop. Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. -Functional Scheme merge_ind := Induction for merge Sort Prop. +Functional Scheme merge_ind := Induction for merge Sort Prop. Functional Scheme remove_ind := Induction for remove Sort Prop. Functional Scheme concat_ind := Induction for concat Sort Prop. Functional Scheme split_ind := Induction for split Sort Prop. @@ -489,24 +488,24 @@ Functional Scheme map2_opt_ind := Induction for map2_opt Sort Prop. Hint Constructors tree MapsTo In bst. Hint Unfold lt_tree gt_tree. -Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) - "as" ident(s) := +Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) + "as" ident(s) := set (s:=Node l x d r h) in *; clearbody s; clear l x d r h. (** A tactic for cleaning hypothesis after use of functional induction. *) Ltac clearf := - match goal with + match goal with | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf | _ => idtac end. -(** A tactic to repeat [inversion_clear] on all hyps of the +(** A tactic to repeat [inversion_clear] on all hyps of the form [(f (Node ...))] *) Ltac inv f := - match goal with + match goal with | H:f (Leaf _) |- _ => inversion_clear H; inv f | H:f _ (Leaf _) |- _ => inversion_clear H; inv f | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f @@ -518,8 +517,8 @@ Ltac inv f := | _ => idtac end. -Ltac inv_all f := - match goal with +Ltac inv_all f := + match goal with | H: f _ |- _ => inversion_clear H; inv f | H: f _ _ |- _ => inversion_clear H; inv f | H: f _ _ _ |- _ => inversion_clear H; inv f @@ -529,7 +528,7 @@ Ltac inv_all f := (** Helper tactic concerning order of elements. *) -Ltac order := match goal with +Ltac order := match goal with | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order | _ => MX.order @@ -537,21 +536,21 @@ end. Ltac intuition_in := repeat progress (intuition; inv In; inv MapsTo). -(* Function/Functional Scheme can't deal with internal fix. +(* Function/Functional Scheme can't deal with internal fix. Let's do its job by hand: *) -Ltac join_tac := - intros l; induction l as [| ll _ lx ld lr Hlr lh]; +Ltac join_tac := + intros l; induction l as [| ll _ lx ld lr Hlr lh]; [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join; - [ | destruct (gt_le_dec lh (rh+2)); + [ | destruct (gt_le_dec lh (rh+2)); [ match goal with |- context [ bal ?u ?v ?w ?z ] => - replace (bal u v w z) + replace (bal u v w z) with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto] - end - | destruct (gt_le_dec rh (lh+2)); - [ match goal with |- context [ bal ?u ?v ?w ?z ] => - replace (bal u v w z) - with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] + end + | destruct (gt_le_dec rh (lh+2)); + [ match goal with |- context [ bal ?u ?v ?w ?z ] => + replace (bal u v w z) + with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] end | ] ] ] ]; intros. @@ -575,7 +574,7 @@ Proof. Qed. Lemma In_alt : forall k m, In0 k m <-> In k m. -Proof. +Proof. split. intros (e,H); eauto. unfold In0; apply In_MapsTo; auto. @@ -588,14 +587,14 @@ Proof. Qed. Hint Immediate MapsTo_1. -Lemma In_1 : +Lemma In_1 : forall m x y, X.eq x y -> In x m -> In y m. Proof. intros m x y; induction m; simpl; intuition_in; eauto. Qed. -Lemma In_node_iff : - forall l x e r h y, +Lemma In_node_iff : + forall l x e r h y, In y (Node l x e r h) <-> In y l \/ X.eq y x \/ In y r. Proof. intuition_in. @@ -613,7 +612,7 @@ Proof. unfold gt_tree in |- *; intros; intuition_in. Qed. -Lemma lt_tree_node : forall x y l r e h, +Lemma lt_tree_node : forall x y l r e h, lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y e r h). Proof. unfold lt_tree in *; intuition_in; order. @@ -627,25 +626,25 @@ Qed. Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. -Lemma lt_left : forall x y l r e h, +Lemma lt_left : forall x y l r e h, lt_tree x (Node l y e r h) -> lt_tree x l. Proof. intuition_in. Qed. -Lemma lt_right : forall x y l r e h, +Lemma lt_right : forall x y l r e h, lt_tree x (Node l y e r h) -> lt_tree x r. Proof. intuition_in. Qed. -Lemma gt_left : forall x y l r e h, +Lemma gt_left : forall x y l r e h, gt_tree x (Node l y e r h) -> gt_tree x l. Proof. intuition_in. Qed. -Lemma gt_right : forall x y l r e h, +Lemma gt_right : forall x y l r e h, gt_tree x (Node l y e r h) -> gt_tree x r. Proof. intuition_in. @@ -695,39 +694,39 @@ Qed. (** * Emptyness test *) -Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. +Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. Proof. destruct m as [|r x e l h]; simpl; auto. intro H; elim (H x e); auto. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. -Proof. +Proof. destruct m; simpl; intros; try discriminate; red; intuition_in. Qed. (** * Appartness *) Lemma mem_1 : forall m x, bst m -> In x m -> mem x m = true. -Proof. +Proof. intros m x; functional induction (mem x m); auto; intros; clearf; inv bst; intuition_in; order. Qed. -Lemma mem_2 : forall m x, mem x m = true -> In x m. -Proof. +Lemma mem_2 : forall m x, mem x m = true -> In x m. +Proof. intros m x; functional induction (mem x m); auto; intros; discriminate. Qed. Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e. -Proof. +Proof. intros m x; functional induction (find x m); auto; intros; clearf; - inv bst; intuition_in; simpl; auto; + inv bst; intuition_in; simpl; auto; try solve [order | absurd (X.lt x y); eauto | absurd (X.lt y x); eauto]. Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. -Proof. +Proof. intros m x; functional induction (find x m); subst; intros; clearf; try discriminate. constructor 2; auto. @@ -735,7 +734,7 @@ Proof. constructor 3; auto. Qed. -Lemma find_iff : forall m x e, bst m -> +Lemma find_iff : forall m x e, bst m -> (find x m = Some e <-> MapsTo x e m). Proof. split; auto using find_1, find_2. @@ -745,7 +744,7 @@ Lemma find_in : forall m x, find x m <> None -> In x m. Proof. intros. case_eq (find x m); [intros|congruence]. - apply MapsTo_In with e; apply find_2; auto. + apply MapsTo_In with e; apply find_2; auto. Qed. Lemma in_find : forall m x, bst m -> In x m -> find x m <> None. @@ -755,7 +754,7 @@ Proof. rewrite (find_1 H Hd); discriminate. Qed. -Lemma find_in_iff : forall m x, bst m -> +Lemma find_in_iff : forall m x, bst m -> (find x m <> None <-> In x m). Proof. split; auto using find_in, in_find. @@ -771,11 +770,11 @@ Proof. elim H0; apply find_in; congruence. Qed. -Lemma find_find : forall m m' x, - find x m = find x m' <-> +Lemma find_find : forall m m' x, + find x m = find x m' <-> (forall d, find x m = Some d <-> find x m' = Some d). Proof. - intros; destruct (find x m); destruct (find x m'); split; intros; + intros; destruct (find x m); destruct (find x m'); split; intros; try split; try congruence. rewrite H; auto. symmetry; rewrite <- H; auto. @@ -783,7 +782,7 @@ Proof. Qed. Lemma find_mapsto_equiv : forall m m' x, bst m -> bst m' -> - (find x m = find x m' <-> + (find x m = find x m' <-> (forall d, MapsTo x d m <-> MapsTo x d m')). Proof. intros m m' x Hm Hm'. @@ -793,8 +792,8 @@ Proof. rewrite 2 find_iff; auto. Qed. -Lemma find_in_equiv : forall m m' x, bst m -> bst m' -> - find x m = find x m' -> +Lemma find_in_equiv : forall m m' x, bst m -> bst m' -> + find x m = find x m' -> (In x m <-> In x m'). Proof. split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ]; @@ -803,27 +802,27 @@ Qed. (** * Helper functions *) -Lemma create_bst : - forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> +Lemma create_bst : + forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (create l x e r). Proof. unfold create; auto. Qed. Hint Resolve create_bst. -Lemma create_in : - forall l x e r y, +Lemma create_in : + forall l x e r y, In y (create l x e r) <-> X.eq y x \/ In y l \/ In y r. Proof. unfold create; split; [ inversion_clear 1 | ]; intuition. Qed. -Lemma bal_bst : forall l x e r, bst l -> bst r -> +Lemma bal_bst : forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (bal l x e r). Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv bst; repeat apply create_bst; auto; unfold create; try constructor; - (apply lt_tree_node || apply gt_tree_node); auto; + (apply lt_tree_node || apply gt_tree_node); auto; (eapply lt_tree_trans || eapply gt_tree_trans); eauto. Qed. Hint Resolve bal_bst. @@ -842,7 +841,7 @@ Proof. unfold assert_false, create; intuition_in. Qed. -Lemma bal_find : forall l x e r y, +Lemma bal_find : forall l x e r y, bst l -> bst r -> lt_tree x l -> gt_tree x r -> find y (bal l x e r) = find y (create l x e r). Proof. @@ -870,32 +869,32 @@ Qed. Hint Resolve add_bst. Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). -Proof. - intros m x y e; functional induction (add x e m); +Proof. + intros m x y e; functional induction (add x e m); intros; inv bst; try rewrite bal_mapsto; unfold create; eauto. Qed. -Lemma add_2 : forall m x y e e', ~X.eq x y -> +Lemma add_2 : forall m x y e e', ~X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m x y e e'; induction m; simpl; auto. destruct (X.compare x k); - intros; inv bst; try rewrite bal_mapsto; unfold create; auto; + intros; inv bst; try rewrite bal_mapsto; unfold create; auto; inv MapsTo; auto; order. Qed. -Lemma add_3 : forall m x y e e', ~X.eq x y -> +Lemma add_3 : forall m x y e e', ~X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. - intros m x y e e'; induction m; simpl; auto. + intros m x y e e'; induction m; simpl; auto. intros; inv MapsTo; auto; order. - destruct (X.compare x k); intro; - try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; + destruct (X.compare x k); intro; + try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; order. Qed. -Lemma add_find : forall m x y e, bst m -> - find y (add x e m) = +Lemma add_find : forall m x y e, bst m -> + find y (add x e m) = match X.compare y x with EQ _ => Some e | _ => find y m end. Proof. intros. @@ -909,7 +908,7 @@ Qed. (** * Extraction of minimum binding *) Lemma remove_min_in : forall l x e r h y, - In y (Node l x e r h) <-> + In y (Node l x e r h) <-> X.eq y (remove_min l x e r)#2#1 \/ In y (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. @@ -919,7 +918,7 @@ Proof. Qed. Lemma remove_min_mapsto : forall l x e r h y e', - MapsTo y e' (Node l x e r h) <-> + MapsTo y e' (Node l x e r h) <-> ((X.eq y (remove_min l x e r)#2#1) /\ e' = (remove_min l x e r)#2#2) \/ MapsTo y e' (remove_min l x e r)#1. Proof. @@ -933,7 +932,7 @@ Proof. inversion_clear H3; intuition. Qed. -Lemma remove_min_bst : forall l x e r h, +Lemma remove_min_bst : forall l x e r h, bst (Node l x e r h) -> bst (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. @@ -949,8 +948,8 @@ Proof. Qed. Hint Resolve remove_min_bst. -Lemma remove_min_gt_tree : forall l x e r h, - bst (Node l x e r h) -> +Lemma remove_min_gt_tree : forall l x e r h, + bst (Node l x e r h) -> gt_tree (remove_min l x e r)#2#1 (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. @@ -968,10 +967,10 @@ Proof. Qed. Hint Resolve remove_min_gt_tree. -Lemma remove_min_find : forall l x e r h y, - bst (Node l x e r h) -> - find y (Node l x e r h) = - match X.compare y (remove_min l x e r)#2#1 with +Lemma remove_min_find : forall l x e r h y, + bst (Node l x e r h) -> + find y (Node l x e r h) = + match X.compare y (remove_min l x e r)#2#1 with | LT _ => None | EQ _ => Some (remove_min l x e r)#2#2 | GT _ => find y (remove_min l x e r)#1 @@ -990,9 +989,9 @@ Qed. (** * Merging two trees *) -Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 -> +Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 -> (In y (merge m1 m2) <-> In y m1 \/ In y m2). -Proof. +Proof. intros m1 m2; functional induction (merge m1 m2);intros; try factornode _x _x0 _x1 _x2 _x3 as m1. intuition_in. @@ -1000,10 +999,10 @@ Proof. rewrite bal_in, remove_min_in, e1; simpl; intuition. Qed. -Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 -> +Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 -> (MapsTo y e (merge m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2). Proof. - intros m1 m2; functional induction (merge m1 m2); intros; + intros m1 m2; functional induction (merge m1 m2); intros; try factornode _x _x0 _x1 _x2 _x3 as m1. intuition_in. intuition_in. @@ -1013,12 +1012,12 @@ Proof. inversion_clear H1; intuition. Qed. -Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 -> - (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> - bst (merge m1 m2). +Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 -> + (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> + bst (merge m1 m2). Proof. intros m1 m2; functional induction (merge m1 m2); intros; auto; - try factornode _x _x0 _x1 _x2 _x3 as m1. + try factornode _x _x0 _x1 _x2 _x3 as m1. apply bal_bst; auto. generalize (remove_min_bst H0); rewrite e1; simpl in *; auto. intro; intro. @@ -1029,7 +1028,7 @@ Qed. (** * Deletion *) -Lemma remove_in : forall m x y, bst m -> +Lemma remove_in : forall m x y, bst m -> (In y (remove x m) <-> ~ X.eq y x /\ In y m). Proof. intros m x; functional induction (remove x m); simpl; intros. @@ -1049,7 +1048,7 @@ Proof. Qed. Lemma remove_bst : forall m x, bst m -> bst (remove x m). -Proof. +Proof. intros m x; functional induction (remove x m); simpl; intros. auto. (* LT *) @@ -1061,7 +1060,7 @@ Proof. (* EQ *) inv bst. apply merge_bst; eauto. - (* GT *) + (* GT *) inv bst. apply bal_bst; auto. intro; intro. @@ -1070,16 +1069,16 @@ Proof. Qed. Lemma remove_1 : forall m x y, bst m -> X.eq x y -> ~ In y (remove x m). -Proof. +Proof. intros; rewrite remove_in; intuition. Qed. -Lemma remove_2 : forall m x y e, bst m -> ~X.eq x y -> +Lemma remove_2 : forall m x y e, bst m -> ~X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m x y e; induction m; simpl; auto. - destruct (X.compare x k); - intros; inv bst; try rewrite bal_mapsto; unfold create; auto; + destruct (X.compare x k); + intros; inv bst; try rewrite bal_mapsto; unfold create; auto; try solve [inv MapsTo; auto]. rewrite merge_mapsto; auto. inv MapsTo; auto; order. @@ -1089,7 +1088,7 @@ Lemma remove_3 : forall m x y e, bst m -> MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m x y e; induction m; simpl; auto. - destruct (X.compare x k); intros Bs; inv bst; + destruct (X.compare x k); intros Bs; inv bst; try rewrite bal_mapsto; auto; unfold create. intros; inv MapsTo; auto. rewrite merge_mapsto; intuition. @@ -1098,7 +1097,7 @@ Qed. (** * join *) -Lemma join_in : forall l x d r y, +Lemma join_in : forall l x d r y, In y (join l x d r) <-> X.eq y x \/ In y l \/ In y r. Proof. join_tac. @@ -1110,23 +1109,23 @@ Proof. apply create_in. Qed. -Lemma join_bst : forall l x d r, bst l -> bst r -> +Lemma join_bst : forall l x d r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (join l x d r). Proof. - join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; + join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; clear Hrl Hlr z; intro; intros; rewrite join_in in *. intuition; [ apply MX.lt_eq with x | ]; eauto. intuition; [ apply MX.eq_lt with x | ]; eauto. Qed. Hint Resolve join_bst. -Lemma join_find : forall l x d r y, - bst l -> bst r -> lt_tree x l -> gt_tree x r -> +Lemma join_find : forall l x d r y, + bst l -> bst r -> lt_tree x l -> gt_tree x r -> find y (join l x d r) = find y (create l x d r). Proof. join_tac; auto; inv bst; - simpl (join (Leaf elt)); - try (assert (X.lt lx x) by auto); + simpl (join (Leaf elt)); + try (assert (X.lt lx x) by auto); try (assert (X.lt x rx) by auto); rewrite ?add_find, ?bal_find; auto. @@ -1150,10 +1149,10 @@ Qed. (** * split *) -Lemma split_in_1 : forall m x, bst m -> forall y, +Lemma split_in_1 : forall m x, bst m -> forall y, (In y (split x m)#l <-> In y m /\ X.lt y x). Proof. - intros m x; functional induction (split x m); simpl; intros; + intros m x; functional induction (split x m); simpl; intros; inv bst; try clear e0. intuition_in. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. @@ -1162,10 +1161,10 @@ Proof. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma split_in_2 : forall m x, bst m -> forall y, +Lemma split_in_2 : forall m x, bst m -> forall y, (In y (split x m)#r <-> In y m /\ X.lt x y). -Proof. - intros m x; functional induction (split x m); subst; simpl; intros; +Proof. + intros m x; functional induction (split x m); subst; simpl; intros; inv bst; try clear e0. intuition_in. rewrite join_in. @@ -1174,18 +1173,18 @@ Proof. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma split_in_3 : forall m x, bst m -> +Lemma split_in_3 : forall m x, bst m -> (split x m)#o = find x m. Proof. intros m x; functional induction (split x m); subst; simpl; auto; - intros; inv bst; try clear e0; - destruct X.compare; try (order;fail); rewrite <-IHt, e1; auto. + intros; inv bst; try clear e0; + destruct X.compare; try order; trivial; rewrite <- IHt, e1; auto. Qed. -Lemma split_bst : forall m x, bst m -> +Lemma split_bst : forall m x, bst m -> bst (split x m)#l /\ bst (split x m)#r. -Proof. - intros m x; functional induction (split x m); subst; simpl; intros; +Proof. + intros m x; functional induction (split x m); subst; simpl; intros; inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition; apply join_bst; auto. intros y0. @@ -1204,17 +1203,17 @@ Proof. intros m x B y Hy; rewrite split_in_2 in Hy; intuition. Qed. -Lemma split_find : forall m x y, bst m -> - find y m = match X.compare y x with +Lemma split_find : forall m x y, bst m -> + find y m = match X.compare y x with | LT _ => find y (split x m)#l | EQ _ => (split x m)#o | GT _ => find y (split x m)#r end. Proof. - intros m x; functional induction (split x m); subst; simpl; intros; - inv bst; try clear e0; try rewrite e1 in *; simpl in *; + intros m x; functional induction (split x m); subst; simpl; intros; + inv bst; try clear e0; try rewrite e1 in *; simpl in *; [ destruct X.compare; auto | .. ]; - try match goal with E:split ?x ?t = _, B:bst ?t |- _ => + try match goal with E:split ?x ?t = _, B:bst ?t |- _ => generalize (split_in_1 x B)(split_in_2 x B)(split_bst x B); rewrite E; simpl; destruct 3 end. @@ -1231,7 +1230,7 @@ Qed. (** * Concatenation *) -Lemma concat_in : forall m1 m2 y, +Lemma concat_in : forall m1 m2 y, In y (concat m1 m2) <-> In y m1 \/ In y m2. Proof. intros m1 m2; functional induction (concat m1 m2); intros; @@ -1241,11 +1240,11 @@ Proof. rewrite join_in, remove_min_in, e1; simpl; intuition. Qed. -Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 -> - (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> +Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 -> + (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> bst (concat m1 m2). Proof. - intros m1 m2; functional induction (concat m1 m2); intros; auto; + 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. @@ -1256,19 +1255,19 @@ Proof. Qed. Hint Resolve concat_bst. -Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> - (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> - find y (concat m1 m2) = +Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> + (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> + find y (concat m1 m2) = match find y m2 with Some d => Some d | None => find y m1 end. Proof. - intros m1 m2; functional induction (concat m1 m2); intros; auto; + intros m1 m2; functional induction (concat m1 m2); intros; auto; try factornode _x _x0 _x1 _x2 _x3 as m1. simpl; destruct (find y m2); auto. generalize (remove_min_find y H0)(remove_min_in l2 x2 d2 r2 _x4) - (remove_min_bst H0)(remove_min_gt_tree H0); + (remove_min_bst H0)(remove_min_gt_tree H0); rewrite e1; simpl fst; simpl snd; intros. - + inv bst. rewrite H2, join_find; auto; clear H2. simpl; destruct X.compare; simpl; auto. @@ -1286,7 +1285,7 @@ Notation eqk := (PX.eqk (elt:= elt)). Notation eqke := (PX.eqke (elt:= elt)). Notation ltk := (PX.ltk (elt:= elt)). -Lemma elements_aux_mapsto : forall (s:t elt) acc x e, +Lemma elements_aux_mapsto : forall (s:t elt) acc x e, InA eqke (x,e) (elements_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc. Proof. induction s as [ | l Hl x e r Hr h ]; simpl; auto. @@ -1299,8 +1298,8 @@ Proof. destruct H0; simpl in *; subst; intuition. Qed. -Lemma elements_mapsto : forall (s:t elt) x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. -Proof. +Lemma elements_mapsto : forall (s:t elt) x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. +Proof. intros; generalize (elements_aux_mapsto s nil x e); intuition. inversion_clear H0. Qed. @@ -1324,9 +1323,9 @@ Proof. induction s as [ | l Hl y e r Hr h]; simpl; intuition. inv bst. apply Hl; auto. - constructor. + constructor. apply Hr; eauto. - apply (InA_InfA (PX.eqke_refl (elt:=elt))); intros (y',e') H6. + apply InA_InfA with (eqA:=eqke); auto with *. intros (y',e') H6. destruct (elements_aux_mapsto r acc y' e'); intuition. red; simpl; eauto. red; simpl; eauto. @@ -1382,7 +1381,7 @@ Qed. (** * Fold *) -Definition fold' (A : Type) (f : key -> elt -> A -> A)(s : t elt) := +Definition fold' (A : Type) (f : key -> elt -> A -> A)(s : t elt) := L.fold f (elements s). Lemma fold_equiv_aux : @@ -1401,14 +1400,14 @@ Lemma fold_equiv : forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A), fold f s a = fold' f s a. Proof. - unfold fold', elements in |- *. + unfold fold', elements in |- *. simple induction s; simpl in |- *; auto; intros. rewrite fold_equiv_aux. rewrite H0. simpl in |- *; auto. Qed. -Lemma fold_1 : +Lemma fold_1 : forall (s:t elt)(Hs:bst s)(A : Type)(i:A)(f : key -> elt -> A -> A), fold f s i = fold_left (fun a p => f p#1 p#2 a) (elements s) i. Proof. @@ -1421,9 +1420,9 @@ Qed. (** * Comparison *) -(** [flatten_e e] returns the list of elements of the enumeration [e] +(** [flatten_e e] returns the list of elements of the enumeration [e] i.e. the list of elements actually compared *) - + Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with | End => nil | More x e t r => (x,e) :: elements t ++ flatten_e r @@ -1431,13 +1430,13 @@ Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with Lemma flatten_e_elements : forall (l:t elt) r x d z e, - elements l ++ flatten_e (More x d r e) = + 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. Qed. -Lemma cons_1 : forall (s:t elt) e, +Lemma cons_1 : forall (s:t elt) e, flatten_e (cons s e) = elements s ++ flatten_e e. Proof. induction s; simpl; auto; intros. @@ -1450,24 +1449,24 @@ Variable cmp : elt->elt->bool. Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b. -Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, - X.eq x1 x2 -> cmp d1 d2 = true -> - IfEq b l1 l2 -> +Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, + X.eq x1 x2 -> cmp d1 d2 = true -> + IfEq b l1 l2 -> IfEq b ((x1,d1)::l1) ((x2,d2)::l2). Proof. - unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl; + unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl; try rewrite H0; auto; order. Qed. -Lemma equal_end_IfEq : forall e2, +Lemma equal_end_IfEq : forall e2, IfEq (equal_end e2) nil (flatten_e e2). Proof. destruct e2; red; auto. Qed. -Lemma equal_more_IfEq : - forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, - IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> +Lemma equal_more_IfEq : + forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, + IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l) (flatten_e (More x2 d2 r2 e2)). Proof. @@ -1475,7 +1474,7 @@ Proof. rewrite <-andb_lazy_alt; f_equal; auto. Qed. -Lemma equal_cont_IfEq : forall m1 cont e2 l, +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. @@ -1493,18 +1492,18 @@ Lemma equal_IfEq : forall (m1 m2:t elt), Proof. intros; unfold equal. rewrite (app_nil_end (elements m1)). - replace (elements m2) with (flatten_e (cons m2 (End _))) + replace (elements m2) with (flatten_e (cons m2 (End _))) by (rewrite cons_1; simpl; rewrite <-app_nil_end; auto). apply equal_cont_IfEq. intros. apply equal_end_IfEq; auto. Qed. -Definition Equivb m m' := - (forall k, In k m <-> In k m') /\ +Definition Equivb m m' := + (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Lemma Equivb_elements : forall s s', +Lemma Equivb_elements : forall s s', Equivb s s' <-> L.Equivb cmp (elements s) (elements s'). Proof. unfold Equivb, L.Equivb; split; split; intros. @@ -1516,7 +1515,7 @@ destruct H. apply (H2 k); unfold L.PX.MapsTo; rewrite elements_mapsto; auto. Qed. -Lemma equal_Equivb : forall (s s': t elt), bst s -> bst s' -> +Lemma equal_Equivb : forall (s s': t elt), bst s -> bst s' -> (equal cmp s s' = true <-> Equivb s s'). Proof. intros s s' B B'. @@ -1526,17 +1525,17 @@ Qed. End Elt. -Section Map. +Section Map. Variable elt elt' : Type. -Variable f : elt -> elt'. +Variable f : elt -> elt'. -Lemma map_1 : forall (m: t elt)(x:key)(e:elt), +Lemma map_1 : forall (m: t elt)(x:key)(e:elt), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. induction m; simpl; inversion_clear 1; auto. Qed. -Lemma map_2 : forall (m: t elt)(x:key), +Lemma map_2 : forall (m: t elt)(x:key), In x (map f m) -> In x m. Proof. induction m; simpl; inversion_clear 1; auto. @@ -1545,7 +1544,7 @@ Qed. Lemma map_bst : forall m, bst m -> bst (map f m). Proof. induction m; simpl; auto. -inversion_clear 1; constructor; auto; +inversion_clear 1; constructor; auto; red; auto using map_2. Qed. @@ -1554,7 +1553,7 @@ Section Mapi. Variable elt elt' : Type. Variable f : key -> elt -> elt'. -Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), +Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. induction m; simpl; inversion_clear 1; auto. @@ -1565,7 +1564,7 @@ destruct (IHm2 _ _ H0). exists x0; intuition. Qed. -Lemma mapi_2 : forall (m: t elt)(x:key), +Lemma mapi_2 : forall (m: t elt)(x:key), In x (mapi f m) -> In x m. Proof. induction m; simpl; inversion_clear 1; auto. @@ -1574,7 +1573,7 @@ Qed. Lemma mapi_bst : forall m, bst m -> bst (mapi f m). Proof. induction m; simpl; auto. -inversion_clear 1; constructor; auto; +inversion_clear 1; constructor; auto; red; auto using mapi_2. Qed. @@ -1585,7 +1584,7 @@ Variable elt elt' : Type. Variable f : key -> elt -> option elt'. Hypothesis f_compat : forall x x' d, X.eq x x' -> f x d = f x' d. -Lemma map_option_2 : forall (m:t elt)(x:key), +Lemma map_option_2 : forall (m:t elt)(x:key), In x (map_option f m) -> exists d, MapsTo x d m /\ f x d <> None. Proof. intros m; functional induction (map_option f m); simpl; auto; intros. @@ -1601,9 +1600,9 @@ Qed. Lemma map_option_bst : forall m, bst m -> bst (map_option f m). Proof. -intros m; functional induction (map_option f m); simpl; auto; intros; +intros m; functional induction (map_option f m); simpl; auto; intros; inv bst. -apply join_bst; auto; intros y H; +apply join_bst; auto; intros y H; destruct (map_option_2 H) as (d0 & ? & ?); eauto using MapsTo_In. apply concat_bst; auto; intros y y' H H'. destruct (map_option_2 H) as (d0 & ? & ?). @@ -1612,22 +1611,22 @@ eapply X.lt_trans with x; eauto using MapsTo_In. Qed. Hint Resolve map_option_bst. -Ltac nonify e := - replace e with (@None elt) by +Ltac nonify e := + replace e with (@None elt) by (symmetry; rewrite not_find_iff; auto; intro; order). -Lemma map_option_find : forall (m:t elt)(x:key), - bst m -> - find x (map_option f m) = +Lemma map_option_find : forall (m:t elt)(x:key), + bst m -> + find x (map_option f m) = match (find x m) with Some d => f x d | None => None end. Proof. intros m; functional induction (map_option f m); simpl; auto; intros; - inv bst; rewrite join_find || rewrite concat_find; auto; simpl; + inv bst; rewrite join_find || rewrite concat_find; auto; simpl; try destruct X.compare; simpl; auto. rewrite (f_compat d e); auto. intros y H; destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In. -intros y H; +intros y H; destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In. rewrite <- IHt, IHt0; auto; nonify (find x0 r); auto. @@ -1653,21 +1652,21 @@ Variable mapr : t elt' -> t elt''. Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o. Hypothesis mapl_bst : forall m, bst m -> bst (mapl m). Hypothesis mapr_bst : forall m', bst m' -> bst (mapr m'). -Hypothesis mapl_f0 : forall x m, bst m -> - find x (mapl m) = +Hypothesis mapl_f0 : forall x m, bst m -> + find x (mapl m) = match find x m with Some d => f0 x (Some d) None | None => None end. -Hypothesis mapr_f0 : forall x m', bst m' -> - find x (mapr m') = +Hypothesis mapr_f0 : forall x m', bst m' -> + find x (mapr m') = match find x m' with Some d' => f0 x None (Some d') | None => None end. Hypothesis f0_compat : forall x x' o o', X.eq x x' -> f0 x o o' = f0 x' o o'. Notation map2_opt := (map2_opt f mapl mapr). -Lemma map2_opt_2 : forall m m' y, bst m -> bst m' -> +Lemma map2_opt_2 : forall m m' y, bst m -> bst m' -> In y (map2_opt m m') -> In y m \/ In y m'. Proof. intros m m'; functional induction (map2_opt m m'); intros; - auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; + auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; try (generalize (split_in_1 x1 H0 y)(split_in_2 x1 H0 y) (split_bst x1 H0); rewrite e1; simpl; destruct 3; inv bst). @@ -1689,12 +1688,12 @@ destruct (IHt1 y H6 H4 H'); intuition. destruct (IHt0 y H7 H5 H'); intuition. Qed. -Lemma map2_opt_bst : forall m m', bst m -> bst m' -> +Lemma map2_opt_bst : forall m m', bst m -> bst m' -> bst (map2_opt m m'). Proof. intros m m'; functional induction (map2_opt m m'); intros; - auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst; - generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0); + auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst; + generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0); rewrite e1; simpl in *; destruct 3. apply join_bst; auto. @@ -1711,31 +1710,31 @@ destruct (map2_opt_2 H2 H7 Hy'); intuition. Qed. Hint Resolve map2_opt_bst. -Ltac map2_aux := +Ltac map2_aux := match goal with - | H : In ?x _ \/ In ?x ?m, - H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ => - destruct H; [ intuition_in; order | + | H : In ?x _ \/ In ?x ?m, + H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ => + destruct H; [ intuition_in; order | rewrite <-(find_in_equiv B B' H'); auto ] end. -Ltac nonify t := - match t with (find ?y (map2_opt ?m ?m')) => +Ltac nonify t := + match t with (find ?y (map2_opt ?m ?m')) => replace t with (@None elt''); [ | symmetry; rewrite not_find_iff; auto; intro; destruct (@map2_opt_2 m m' y); auto; order ] end. -Lemma map2_opt_1 : forall m m' y, bst m -> bst m' -> +Lemma map2_opt_1 : forall m m' y, bst m -> bst m' -> In y m \/ In y m' -> find y (map2_opt m m') = f0 y (find y m) (find y m'). Proof. intros m m'; functional induction (map2_opt m m'); intros; - auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; + auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; try (generalize (split_in_1 x1 H0)(split_in_2 x1 H0) (split_in_3 x1 H0)(split_bst x1 H0)(split_find x1 y H0) (split_lt_tree (x:=x1) H0)(split_gt_tree (x:=x1) H0); - rewrite e1; simpl in *; destruct 4; intros; inv bst; + rewrite e1; simpl in *; destruct 4; intros; inv bst; subst o2; rewrite H7, ?join_find, ?concat_find; auto). simpl; destruct H1; [ inversion_clear H1 | ]. @@ -1777,23 +1776,23 @@ Variable f : option elt -> option elt' -> option elt''. Lemma map2_bst : forall m m', bst m -> bst m' -> bst (map2 f m m'). Proof. unfold map2; intros. -apply map2_opt_bst with (fun _ => f); auto using map_option_bst; +apply map2_opt_bst with (fun _ => f); auto using map_option_bst; intros; rewrite map_option_find; auto. Qed. -Lemma map2_1 : forall m m' y, bst m -> bst m' -> +Lemma map2_1 : forall m m' y, bst m -> bst m' -> In y m \/ In y m' -> find y (map2 f m m') = f (find y m) (find y m'). Proof. unfold map2; intros. -rewrite (map2_opt_1 (f0:=fun _ => f)); +rewrite (map2_opt_1 (f0:=fun _ => f)); auto using map_option_bst; intros; rewrite map_option_find; auto. Qed. -Lemma map2_2 : forall m m' y, bst m -> bst m' -> +Lemma map2_2 : forall m m' y, bst m -> bst m' -> In y (map2 f m m') -> In y m \/ In y m'. Proof. unfold map2; intros. -eapply map2_opt_2 with (f0:=fun _ => f); eauto; intros. +eapply map2_opt_2 with (f0:=fun _ => f); try eassumption; trivial; intros. apply map_option_bst; auto. apply map_option_bst; auto. rewrite map_option_find; auto. @@ -1806,38 +1805,38 @@ End Raw. (** * Encapsulation - Now, in order to really provide a functor implementing [S], we + Now, in order to really provide a functor implementing [S], we need to encapsulate everything into a type of balanced binary search trees. *) Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Module E := X. - Module Raw := Raw I X. + Module Raw := Raw I X. Import Raw.Proofs. - Record bst (elt:Type) := + Record bst (elt:Type) := Bst {this :> Raw.tree elt; is_bst : Raw.bst this}. - - Definition t := bst. + + Definition t := bst. Definition key := E.t. - - Section Elt. + + Section Elt. Variable elt elt' elt'': Type. Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. + Implicit Types x y : key. + Implicit Types e : elt. Definition empty : t elt := Bst (empty_bst elt). Definition is_empty m : bool := Raw.is_empty m.(this). Definition add x e m : t elt := Bst (add_bst x e m.(is_bst)). - Definition remove x m : t elt := Bst (remove_bst x m.(is_bst)). + Definition remove x m : t elt := Bst (remove_bst x m.(is_bst)). Definition mem x m : bool := Raw.mem x m.(this). Definition find x m : option elt := Raw.find x m.(this). Definition map f m : t elt' := Bst (map_bst f m.(is_bst)). - Definition mapi (f:key->elt->elt') m : t elt' := + Definition mapi (f:key->elt->elt') m : t elt' := Bst (mapi_bst f m.(is_bst)). - Definition map2 f m (m':t elt') : t elt'' := + Definition map2 f m (m':t elt') : t elt'' := Bst (map2_bst f m.(is_bst) m'.(is_bst)). Definition elements m : list (key*elt) := Raw.elements m.(this). Definition cardinal m := Raw.cardinal m.(this). @@ -1854,14 +1853,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. - + Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. apply m.(is_bst). Qed. - - Lemma mem_2 : forall m x, mem x m = true -> In x m. + + Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto. Qed. @@ -1892,7 +1891,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@find_2 elt m.(this)). Qed. @@ -1901,36 +1900,36 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. - Lemma elements_1 : forall m x e, + Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto. Qed. - Lemma elements_2 : forall m x e, + Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto. Qed. - Lemma elements_3 : forall m, sort lt_key (elements m). + Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed. Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp := Equiv (Cmp cmp). - Lemma Equivb_Equivb : forall cmp m m', + Lemma Equivb_Equivb : forall cmp m m', Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. - Proof. + Proof. intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. @@ -1938,23 +1937,23 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. generalize (H0 k); do 2 rewrite <- In_alt; intuition. Qed. - Lemma equal_1 : forall m m' cmp, - Equivb cmp m m' -> equal cmp m m' = true. - Proof. - unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; + Lemma equal_1 : forall m m' cmp, + Equivb cmp m m' -> equal cmp m m' = true. + Proof. + unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite equal_Equivb; auto. - Qed. + Qed. - Lemma equal_2 : forall m m' cmp, + Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. - unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; + Proof. + unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite <-equal_Equivb; auto. Qed. End Elt. - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. @@ -1962,10 +1961,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl. apply map_2; auto. - Qed. + Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) @@ -1975,10 +1974,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. apply m.(is_bst). @@ -1986,9 +1985,9 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - Proof. + Proof. unfold In, map2; intros elt elt' elt'' m m' x f. do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. apply m.(is_bst). @@ -1998,19 +1997,19 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. End IntMake. -Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: - Sord with Module Data := D +Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: + Sord with Module Data := D with Module MapS.E := X. Module Data := D. - Module Import MapS := IntMake(I)(X). + Module Import MapS := IntMake(I)(X). Module LO := FMapList.Make_ord(X)(D). Module R := Raw. Module P := Raw.Proofs. Definition t := MapS.t D.t. - Definition cmp e e' := + Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. (** One step of comparison of elements *) @@ -2020,9 +2019,9 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: | R.End => Gt | R.More x2 d2 r2 e2 => match X.compare x1 x2 with - | EQ _ => match D.compare d1 d2 with + | EQ _ => match D.compare d1 d2 with | EQ _ => cont (R.cons r2 e2) - | LT _ => Lt + | LT _ => Lt | GT _ => Gt end | LT _ => Lt @@ -2046,7 +2045,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: (** The complete comparison *) - Definition compare_pure s1 s2 := + Definition compare_pure s1 s2 := compare_cont s1 compare_end (R.cons s2 (Raw.End _)). (** Correctness of this comparison *) @@ -2058,7 +2057,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: | Gt => (fun l1 l2 => LO.lt_list l2 l1) end. - Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, + Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, X.eq x1 x2 -> D.eq d1 d2 -> Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). Proof. @@ -2077,10 +2076,10 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l) (P.flatten_e (R.More x2 d2 r2 e2)). Proof. - simpl; intros; destruct X.compare; simpl; + simpl; intros; destruct X.compare; simpl; try destruct D.compare; simpl; auto; P.MX.elim_comp; auto. Qed. - + Lemma compare_cont_Cmp : forall s1 cont e2 l, (forall e, Cmp (cont e) l (P.flatten_e e)) -> Cmp (compare_cont s1 cont e2) (R.elements s1 ++ l) (P.flatten_e e2). @@ -2110,14 +2109,14 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Definition compare (s s':t) : Compare lt eq s s'. Proof. - intros (s,b) (s',b'). + destruct s as (s,b), s' as (s',b'). generalize (compare_Cmp s s'). destruct compare_pure; intros; [apply EQ|apply LT|apply GT]; red; auto. Defined. - + (* Proofs about [eq] and [lt] *) - Definition selements (m1 : t) := + Definition selements (m1 : t) := LO.MapS.Build_slist (P.elements_sort m1.(is_bst)). Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). @@ -2154,7 +2153,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Qed. Lemma eq_refl : forall m : t, eq m m. - Proof. + Proof. intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl. Qed. @@ -2171,13 +2170,13 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Proof. - intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; + intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; intros; eapply LO.lt_trans; eauto. Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. - intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; + intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; intros; apply LO.lt_not_eq; auto. Qed. @@ -2188,8 +2187,8 @@ End IntMake_ord. Module Make (X: OrderedType) <: S with Module E := X :=IntMake(Z_as_Int)(X). -Module Make_ord (X: OrderedType)(D: OrderedType) - <: Sord with Module Data := D +Module Make_ord (X: OrderedType)(D: OrderedType) + <: Sord with Module Data := D with Module MapS.E := X :=IntMake_ord(Z_as_Int)(X)(D). diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index d91eb87a..4c59971c 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -6,25 +6,22 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapFacts.v 12187 2009-06-13 19:36:59Z msozeau $ *) +(* $Id$ *) (** * Finite maps library *) (** This functor derives additional facts from [FMapInterface.S]. These - facts are mainly the specifications of [FMapInterface.S] written using - different styles: equivalence and boolean equalities. + facts are mainly the specifications of [FMapInterface.S] written using + different styles: equivalence and boolean equalities. *) Require Import Bool DecidableType DecidableTypeEx OrderedType Morphisms. -Require Export FMapInterface. +Require Export FMapInterface. Set Implicit Arguments. Unset Strict Implicit. Hint Extern 1 (Equivalence _) => constructor; congruence. -Notation Leibniz := (@eq _) (only parsing). - - (** * Facts about weak maps *) Module WFacts_fun (E:DecidableType)(Import M:WSfun E). @@ -46,7 +43,7 @@ destruct o; destruct o'; try rewrite H; auto. symmetry; rewrite <- H; auto. Qed. -Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), +Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), MapsTo x e m -> MapsTo x e' m -> e=e'. Proof. intros. @@ -56,7 +53,7 @@ Qed. (** ** Specifications written using equivalences *) -Section IffSpec. +Section IffSpec. Variable elt elt' elt'': Type. Implicit Type m: t elt. Implicit Type x y z: key. @@ -101,7 +98,7 @@ Lemma not_find_in_iff : forall m x, ~In x m <-> find x m = None. Proof. split; intros. rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff. -split; intro H'; try discriminate. elim H; exists e; auto. +split; try discriminate. intro H'; elim H; exists e; auto. intros (e,He); rewrite find_mapsto_iff,H in He; discriminate. Qed. @@ -112,7 +109,7 @@ destruct mem; intuition. Qed. Lemma equal_iff : forall m m' cmp, Equivb cmp m m' <-> equal cmp m m' = true. -Proof. +Proof. split; [apply equal_1|apply equal_2]. Qed. @@ -127,16 +124,16 @@ unfold In. split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition. Qed. -Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. -Proof. +Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. +Proof. split; [apply is_empty_1|apply is_empty_2]. Qed. -Lemma add_mapsto_iff : forall m x y e e', - MapsTo y e' (add x e m) <-> - (E.eq x y /\ e=e') \/ +Lemma add_mapsto_iff : forall m x y e e', + MapsTo y e' (add x e m) <-> + (E.eq x y /\ e=e') \/ (~E.eq x y /\ MapsTo y e' m). -Proof. +Proof. intros. intuition. destruct (eq_dec x y); [left|right]. @@ -147,7 +144,7 @@ subst; auto with map. Qed. Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m. -Proof. +Proof. unfold In; split. intros (e',H). destruct (eq_dec x y) as [E|E]; auto. @@ -161,13 +158,13 @@ destruct E; auto. exists e'; apply add_2; auto. Qed. -Lemma add_neq_mapsto_iff : forall m x y e e', +Lemma add_neq_mapsto_iff : forall m x y e e', ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m). Proof. split; [apply add_3|apply add_2]; auto. Qed. -Lemma add_neq_in_iff : forall m x y e, +Lemma add_neq_in_iff : forall m x y e, ~ E.eq x y -> (In y (add x e m) <-> In y m). Proof. split; intros (e',H0); exists e'. @@ -175,9 +172,9 @@ apply (add_3 H H0). apply add_2; auto. Qed. -Lemma remove_mapsto_iff : forall m x y e, +Lemma remove_mapsto_iff : forall m x y e, MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m. -Proof. +Proof. intros. split; intros. split. @@ -188,7 +185,7 @@ apply remove_2; intuition. Qed. Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m. -Proof. +Proof. unfold In; split. intros (e,H). split. @@ -198,13 +195,13 @@ exists e; apply remove_3 with x; auto. intros (H,(e,H0)); exists e; apply remove_2; auto. Qed. -Lemma remove_neq_mapsto_iff : forall m x y e, +Lemma remove_neq_mapsto_iff : forall m x y e, ~ E.eq x y -> (MapsTo y e (remove x m) <-> MapsTo y e m). Proof. split; [apply remove_3|apply remove_2]; auto. Qed. -Lemma remove_neq_in_iff : forall m x y, +Lemma remove_neq_in_iff : forall m x y, ~ E.eq x y -> (In y (remove x m) <-> In y m). Proof. split; intros (e',H0); exists e'. @@ -212,19 +209,19 @@ apply (remove_3 H0). apply remove_2; auto. Qed. -Lemma elements_mapsto_iff : forall m x e, +Lemma elements_mapsto_iff : forall m x e, MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m). -Proof. +Proof. split; [apply elements_1 | apply elements_2]. Qed. -Lemma elements_in_iff : forall m x, +Lemma elements_in_iff : forall m x, In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m). -Proof. +Proof. unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto. Qed. -Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), +Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m. Proof. split. @@ -240,7 +237,7 @@ intros (a,(H,H0)). subst b; auto with map. Qed. -Lemma map_in_iff : forall m x (f : elt -> elt'), +Lemma map_in_iff : forall m x (f : elt -> elt'), In x (map f m) <-> In x m. Proof. split; intros; eauto with map. @@ -257,11 +254,11 @@ destruct (mapi_1 f H) as (y,(H0,H1)). exists (f y a); auto. Qed. -(** Unfortunately, we don't have simple equivalences for [mapi] - and [MapsTo]. The only correct one needs compatibility of [f]. *) +(** Unfortunately, we don't have simple equivalences for [mapi] + and [MapsTo]. The only correct one needs compatibility of [f]. *) -Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), - MapsTo x b (mapi f m) -> +Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), + MapsTo x b (mapi f m) -> exists a, exists y, E.eq y x /\ b = f y a /\ MapsTo x a m. Proof. intros; case_eq (find x m); intros. @@ -275,8 +272,8 @@ destruct (mapi_2 H1) as (a,H2). rewrite (find_1 H2) in H0; discriminate. Qed. -Lemma mapi_1bis : forall m x e (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> +Lemma mapi_1bis : forall m x e (f:key->elt->elt'), + (forall x y e, E.eq x y -> f x e = f y e) -> MapsTo x e m -> MapsTo x (f x e) (mapi f m). Proof. intros. @@ -286,7 +283,7 @@ auto. Qed. Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> + (forall x y e, E.eq x y -> f x e = f y e) -> (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m). Proof. split. @@ -299,14 +296,14 @@ subst b. apply mapi_1bis; auto. Qed. -(** Things are even worse for [map2] : we don't try to state any +(** Things are even worse for [map2] : we don't try to state any equivalence, see instead boolean results below. *) End IffSpec. (** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *) - -Ltac map_iff := + +Ltac map_iff := repeat (progress ( rewrite add_mapsto_iff || rewrite add_in_iff || rewrite remove_mapsto_iff || rewrite remove_in_iff || @@ -318,7 +315,7 @@ Ltac map_iff := Section BoolSpec. -Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false. +Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false. Proof. intros. generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In. @@ -336,7 +333,7 @@ Implicit Types x y z : key. Implicit Types e : elt. Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m. -Proof. +Proof. intros. generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H). destruct (mem x m); destruct (mem y m); intuition. @@ -362,14 +359,14 @@ generalize (mem_2 H). rewrite empty_in_iff; intuition. Qed. -Lemma add_eq_o : forall m x y e, +Lemma add_eq_o : forall m x y e, E.eq x y -> find y (add x e m) = Some e. Proof. auto with map. Qed. -Lemma add_neq_o : forall m x y e, - ~ E.eq x y -> find y (add x e m) = find y m. +Lemma add_neq_o : forall m x y e, + ~ E.eq x y -> find y (add x e m) = find y m. Proof. intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. apply add_neq_mapsto_iff; auto. @@ -382,26 +379,26 @@ Proof. intros; destruct (eq_dec x y); auto with map. Qed. -Lemma add_eq_b : forall m x y e, +Lemma add_eq_b : forall m x y e, E.eq x y -> mem y (add x e m) = true. Proof. intros; rewrite mem_find_b; rewrite add_eq_o; auto. Qed. -Lemma add_neq_b : forall m x y e, +Lemma add_neq_b : forall m x y e, ~E.eq x y -> mem y (add x e m) = mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto. Qed. -Lemma add_b : forall m x y e, - mem y (add x e m) = eqb x y || mem y m. +Lemma add_b : forall m x y e, + mem y (add x e m) = eqb x y || mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb. destruct (eq_dec x y); simpl; auto. Qed. -Lemma remove_eq_o : forall m x y, +Lemma remove_eq_o : forall m x y, E.eq x y -> find y (remove x m) = None. Proof. intros. rewrite eq_option_alt. intro e. @@ -442,14 +439,14 @@ 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 +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). +Lemma map_o : forall m x (f:elt->elt'), + find x (map f m) = option_map f (find x m). Proof. intros. generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x) @@ -463,14 +460,14 @@ rewrite H0 in H2; discriminate. rewrite <- H; rewrite H1; exists e; rewrite H0; auto. Qed. -Lemma map_b : forall m x (f:elt->elt'), +Lemma map_b : forall m x (f:elt->elt'), mem x (map f m) = mem x m. Proof. intros; do 2 rewrite mem_find_b; rewrite map_o. destruct (find x m); simpl; auto. Qed. -Lemma mapi_b : forall m x (f:key->elt->elt'), +Lemma mapi_b : forall m x (f:key->elt->elt'), mem x (mapi f m) = mem x m. Proof. intros. @@ -480,12 +477,12 @@ symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto. rewrite <- H; rewrite H1; rewrite H0; auto. Qed. -Lemma mapi_o : forall m x (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> +Lemma mapi_o : forall m x (f:key->elt->elt'), + (forall x y e, E.eq x y -> f x e = f y e) -> find x (mapi f m) = option_map (f x) (find x m). Proof. intros. -generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) +generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) (fun b => mapi_mapsto_iff m x b H). destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros. rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto. @@ -496,9 +493,9 @@ rewrite H1 in H3; discriminate. rewrite <- H0; rewrite H2; exists e; rewrite H1; auto. Qed. -Lemma map2_1bis : forall (m: t elt)(m': t elt') x - (f:option elt->option elt'->option elt''), - f None None = None -> +Lemma map2_1bis : forall (m: t elt)(m': t elt') x + (f:option elt->option elt'->option elt''), + f None None = None -> find x (map2 f m m') = f (find x m) (find x m'). Proof. intros. @@ -574,7 +571,7 @@ Qed. (** First, [Equal] is [Equiv] with Leibniz on elements. *) Lemma Equal_Equiv : forall (m m' : t elt), - Equal m m' <-> Equiv (@Logic.eq elt) m m'. + Equal m m' <-> Equiv Logic.eq m m'. Proof. intros. rewrite Equal_mapsto_iff. split; intros. split. @@ -598,7 +595,7 @@ Section Cmp. Variable eq_elt : elt->elt->Prop. Variable cmp : elt->elt->bool. -Definition compat_cmp := +Definition compat_cmp := forall e e', cmp e e' = true <-> eq_elt e e'. Lemma Equiv_Equivb : compat_cmp -> @@ -613,17 +610,17 @@ End Cmp. (** Composition of the two last results: relation between [Equal] and [Equivb]. *) -Lemma Equal_Equivb : forall cmp, - (forall e e', cmp e e' = true <-> e = e') -> +Lemma Equal_Equivb : forall cmp, + (forall e e', cmp e e' = true <-> e = e') -> forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. Proof. intros; rewrite Equal_Equiv. apply Equiv_Equivb; auto. Qed. -Lemma Equal_Equivb_eqdec : +Lemma Equal_Equivb_eqdec : forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }), - let cmp := fun e e' => if eq_elt_dec e e' then true else false in + let cmp := fun e e' => if eq_elt_dec e e' then true else false in forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. Proof. intros; apply Equal_Equivb. @@ -638,11 +635,11 @@ End Equalities. Lemma Equal_refl : forall (elt:Type)(m : t elt), Equal m m. Proof. red; reflexivity. Qed. -Lemma Equal_sym : forall (elt:Type)(m m' : t elt), +Lemma Equal_sym : forall (elt:Type)(m m' : t elt), Equal m m' -> Equal m' m. Proof. unfold Equal; auto. Qed. -Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), +Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), Equal m m' -> Equal m' m'' -> Equal m m''. Proof. unfold Equal; congruence. Qed. @@ -651,15 +648,15 @@ Proof. constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans]. Qed. -Add Relation key E.eq - reflexivity proved by E.eq_refl +Add Relation key E.eq + reflexivity proved by E.eq_refl symmetry proved by E.eq_sym - transitivity proved by E.eq_trans + transitivity proved by E.eq_trans as KeySetoid. Implicit Arguments Equal [[elt]]. -Add Parametric Relation (elt : Type) : (t elt) Equal +Add Parametric Relation (elt : Type) : (t elt) Equal reflexivity proved by (@Equal_refl elt) symmetry proved by (@Equal_sym elt) transitivity proved by (@Equal_trans elt) @@ -673,7 +670,7 @@ rewrite (In_iff m Hk), in_find_iff, in_find_iff, Hm; intuition. Qed. Add Parametric Morphism elt : (@MapsTo elt) - with signature E.eq ==> Leibniz ==> Equal ==> iff as MapsTo_m. + with signature E.eq ==> eq ==> Equal ==> iff as MapsTo_m. Proof. unfold Equal; intros k k' Hk e m m' Hm. rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm; @@ -689,28 +686,28 @@ rewrite Hm in H0; eauto. Qed. Add Parametric Morphism elt : (@is_empty elt) - with signature Equal ==> Leibniz as is_empty_m. + with signature Equal ==> eq as is_empty_m. Proof. intros m m' Hm. rewrite eq_bool_alt, <-is_empty_iff, <-is_empty_iff, Hm; intuition. Qed. Add Parametric Morphism elt : (@mem elt) - with signature E.eq ==> Equal ==> Leibniz as mem_m. + with signature E.eq ==> Equal ==> eq as mem_m. Proof. intros k k' Hk m m' Hm. rewrite eq_bool_alt, <- mem_in_iff, <-mem_in_iff, Hk, Hm; intuition. Qed. Add Parametric Morphism elt : (@find elt) - with signature E.eq ==> Equal ==> Leibniz as find_m. + with signature E.eq ==> Equal ==> eq as find_m. Proof. intros k k' Hk m m' Hm. rewrite eq_option_alt. intro e. rewrite <- 2 find_mapsto_iff, Hk, Hm. split; auto. Qed. Add Parametric Morphism elt : (@add elt) - with signature E.eq ==> Leibniz ==> Equal ==> Equal as add_m. + 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. @@ -728,7 +725,7 @@ elim n; rewrite Hk; auto. Qed. Add Parametric Morphism elt elt' : (@map elt elt') - with signature Leibniz ==> Equal ==> Equal as map_m. + with signature eq ==> Equal ==> Equal as map_m. Proof. intros f m m' Hm y. rewrite map_o, map_o, Hm; auto. @@ -763,6 +760,16 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Notation eqke := (@eq_key_elt elt). Notation eqk := (@eq_key elt). + Instance eqk_equiv : Equivalence eqk. + Proof. split; repeat red; eauto. Qed. + + Instance eqke_equiv : Equivalence eqke. + Proof. + unfold eq_key_elt; split; repeat red; firstorder. + eauto with *. + congruence. + Qed. + (** Complements about InA, NoDupA and findA *) Lemma InA_eqke_eqk : forall k1 k2 e1 e2 l, @@ -790,12 +797,12 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). intros. symmetry. unfold eqb. rewrite <- findA_NoDupA, InA_rev, findA_NoDupA - by eauto using NoDupA_rev; eauto. + by (eauto using NoDupA_rev with *); eauto. case_eq (findA (eqb k) (rev l)); auto. intros e. unfold eqb. rewrite <- findA_NoDupA, InA_rev, findA_NoDupA - by eauto using NoDupA_rev. + by (eauto using NoDupA_rev with *). intro Eq; rewrite Eq; auto. Qed. @@ -896,9 +903,10 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' -> Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)). intros k e a m' m'' H ? ? ?; eapply Hstep; eauto. - revert H; unfold l; rewrite InA_rev, elements_mapsto_iff; auto. + revert H; unfold l; rewrite InA_rev, elements_mapsto_iff; auto with *. assert (Hdup : NoDupA eqk l). - unfold l. apply NoDupA_rev; try red; eauto. apply elements_3w. + unfold l. apply NoDupA_rev; try red; unfold eq_key ; eauto with *. + apply elements_3w. assert (Hsame : forall k, find k m = findA (eqb k) l). intros k. unfold l. rewrite elements_o, findA_rev; auto. apply elements_3w. @@ -979,7 +987,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). set (l:=rev (elements m)). assert (Rstep' : forall k e a b, InA eqke (k,e) l -> R a b -> R (f k e a) (g k e b)) by - (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; auto). + (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; auto with *). clearbody l; clear Rstep m. induction l; simpl; auto. apply Rstep'; auto. @@ -1020,7 +1028,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff. intro; elim (Heq k' e'); auto. intros k e a m' m'' _ _ Hadd Heq k'. - rewrite Hadd, 2 add_o, Heq; auto. + red in Heq. rewrite Hadd, 2 add_o, Heq; auto. Qed. Section Fold_More. @@ -1034,8 +1042,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). (** This is more convenient than a [compat_op eqke ...]. In fact, every [compat_op], [compat_bool], etc, should - become a [Morphism] someday. *) - Hypothesis Comp : Morphism (E.eq==>Leibniz==>eqA==>eqA) f. + become a [Proper] someday. *) + Hypothesis Comp : Proper (E.eq==>eq==>eqA==>eqA) f. Lemma fold_init : forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i'). @@ -1086,77 +1094,53 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). contradict Hnotin; rewrite <- Hnotin; exists e0; auto. Qed. + Hint Resolve NoDupA_eqk_eqke NoDupA_rev elements_3w : map. + Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 -> eqA (fold f m1 i) (fold f m2 i). Proof. - assert (eqke_refl : forall p, eqke p p). - red; auto. - assert (eqke_sym : forall p p', eqke p p' -> eqke p' p). - intros (x1,x2) (y1,y2); unfold eq_key_elt; simpl; intuition. - assert (eqke_trans : forall p p' p'', eqke p p' -> eqke p' p'' -> eqke p p''). - intros (x1,x2) (y1,y2) (z1,z2); unfold eq_key_elt; simpl. - intuition; eauto; congruence. intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. - apply fold_right_equivlistA_restr with - (R:=fun p p' => ~eqk p p') (eqA:=eqke) (eqB:=eqA); auto. - intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; simpl in *; apply Comp; auto. - unfold eq_key; auto. - intros (k1,e1) (k2,e2) (k3,e3). unfold eq_key_elt, eq_key; simpl. - intuition eauto. + assert (NoDupA eqk (rev (elements m1))) by (auto with *). + assert (NoDupA eqk (rev (elements m2))) by (auto with *). + apply fold_right_equivlistA_restr with (R:=complement eqk)(eqA:=eqke); + auto with *. + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto. + unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto. intros (k,e) (k',e'); unfold eq_key; simpl; auto. - apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. - apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. - apply ForallList2_equiv1 with (eqA:=eqk); try red; eauto. - apply NoDupA_rev; try red; eauto. apply elements_3w. - red; intros. - do 2 rewrite InA_rev. - destruct x; do 2 rewrite <- elements_mapsto_iff. - do 2 rewrite find_mapsto_iff. - rewrite H; split; 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. - assert (eqke_refl : forall p, eqke p p). - red; auto. - assert (eqke_sym : forall p p', eqke p p' -> eqke p' p). - intros (x1,x2) (y1,y2); unfold eq_key_elt; simpl; intuition. - assert (eqke_trans : forall p p' p'', eqke p p' -> eqke p' p'' -> eqke p p''). - intros (x1,x2) (y1,y2) (z1,z2); unfold eq_key_elt; simpl. - intuition; eauto; congruence. intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. set (f':=fun y x0 => f (fst y) (snd y) x0) in *. change (f k e (fold_right f' i (rev (elements m1)))) with (f' (k,e) (fold_right f' i (rev (elements m1)))). + assert (NoDupA eqk (rev (elements m1))) by (auto with *). + assert (NoDupA eqk (rev (elements m2))) by (auto with *). apply fold_right_add_restr with - (R:=fun p p'=>~eqk p p')(eqA:=eqke)(eqB:=eqA); auto. - intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *. apply Comp; auto. - - unfold eq_key; auto. - intros (k1,e1) (k2,e2) (k3,e3). unfold eq_key_elt, eq_key; simpl. - intuition eauto. + (R:=complement eqk)(eqA:=eqke)(eqB:=eqA); auto with *. + intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. apply Comp; auto. + unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto. unfold f'; intros (k1,e1) (k2,e2); unfold eq_key; simpl; auto. - apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. - apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. - apply ForallList2_equiv1 with (eqA:=eqk); try red; eauto. - apply NoDupA_rev; try red; eauto. apply elements_3w. - rewrite InA_rev. - contradict H. - exists e. - rewrite elements_mapsto_iff; auto. - intros a. - rewrite InA_cons; do 2 rewrite InA_rev; - destruct a as (a,b); do 2 rewrite <- elements_mapsto_iff. - do 2 rewrite find_mapsto_iff; unfold eq_key_elt; simpl. + rewrite <- NoDupA_altdef; auto. + rewrite InA_rev, <- elements_mapsto_iff by (auto with *). firstorder. + intros (a,b). + rewrite InA_cons, 2 InA_rev, <- 2 elements_mapsto_iff, + 2 find_mapsto_iff by (auto with *). + unfold eq_key_elt; simpl. rewrite H0. rewrite add_o. - destruct (eq_dec k a); intuition. - inversion H1; auto. - f_equal; auto. - elim H. - exists b; apply MapsTo_1 with a; auto with map. - elim n; auto. + destruct (eq_dec k a) as [EQ|NEQ]; split; auto. + intros EQ'; inversion EQ'; auto. + intuition; subst; auto. + elim H. exists b; rewrite EQ; auto with map. + intuition. + elim NEQ; auto. Qed. Lemma fold_add : forall m k e i, ~In k m -> @@ -1188,7 +1172,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Equal m m' -> cardinal m = cardinal m'. Proof. intros; do 2 rewrite cardinal_fold. - apply fold_Equal with (eqA:=Leibniz); compute; auto. + apply fold_Equal with (eqA:=eq); compute; auto. Qed. Lemma cardinal_1 : forall m : t elt, Empty m -> cardinal m = 0. @@ -1201,22 +1185,22 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Proof. intros; do 2 rewrite cardinal_fold. change S with ((fun _ _ => S) x e). - apply fold_Add with (eqA:=Leibniz); compute; auto. + apply fold_Add with (eqA:=eq); compute; auto. Qed. - Lemma cardinal_inv_1 : forall m : t elt, + Lemma cardinal_inv_1 : forall m : t elt, cardinal m = 0 -> Empty m. Proof. - intros; rewrite cardinal_Empty; auto. + intros; rewrite cardinal_Empty; auto. Qed. Hint Resolve cardinal_inv_1 : map. Lemma cardinal_inv_2 : forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }. - Proof. + Proof. intros; rewrite M.cardinal_1 in *. generalize (elements_mapsto_iff m). - destruct (elements m); try discriminate. + destruct (elements m); try discriminate. exists p; auto. rewrite H0; destruct p; simpl; auto. constructor; red; auto. @@ -1242,16 +1226,16 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). (** * Emulation of some functions lacking in the interface *) - Definition filter (f : key -> elt -> bool)(m : t elt) := + Definition filter (f : key -> elt -> bool)(m : t elt) := fold (fun k e m => if f k e then add k e m else m) m (empty _). - Definition for_all (f : key -> elt -> bool)(m : t elt) := + Definition for_all (f : key -> elt -> bool)(m : t elt) := fold (fun k e b => if f k e then b else false) m true. - Definition exists_ (f : key -> elt -> bool)(m : t elt) := + Definition exists_ (f : key -> elt -> bool)(m : t elt) := fold (fun k e b => if f k e then true else b) m false. - Definition partition (f : key -> elt -> bool)(m : t elt) := + Definition partition (f : key -> elt -> bool)(m : t elt) := (filter f m, filter (fun k e => negb (f k e)) m). (** [update] adds to [m1] all the bindings of [m2]. It can be seen as @@ -1272,7 +1256,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Section Specs. Variable f : key -> elt -> bool. - Hypothesis Hf : Morphism (E.eq==>Leibniz==>Leibniz) f. + Hypothesis Hf : Proper (E.eq==>eq==>eq) f. Lemma filter_iff : forall m k e, MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. @@ -1315,8 +1299,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). apply Hmapsto. rewrite Hadd, add_mapsto_iff; right; split; auto. contradict Hn; exists e'; rewrite Hn; auto. (* f k e = false *) - split; intros H; try discriminate. - rewrite <- Hfke. apply H. + split; try discriminate. + intros Hmapsto. rewrite <- Hfke. apply Hmapsto. rewrite Hadd, add_mapsto_iff; auto. Qed. @@ -1328,7 +1312,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). set (f':=fun k e b => if f k e then true else b). intro m. pattern m, (fold f' m false). apply fold_rec. - intros m' Hm'. split; try (intros; discriminate). + intros m' Hm'. split; try discriminate. intros ((k,e),(Hke,_)); simpl in *. elim (Hm' k e); auto. intros k e b m1 m2 _ Hn Hadd IH. clear m. @@ -1365,7 +1349,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Section Partition. Variable f : key -> elt -> bool. - Hypothesis Hf : Morphism (E.eq==>Leibniz==>Leibniz) f. + Hypothesis Hf : Proper (E.eq==>eq==>eq) f. Lemma partition_iff_1 : forall m m1 k e, m1 = fst (partition f m) -> @@ -1494,7 +1478,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Lemma Partition_fold : forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A), - Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + Proper (E.eq==>eq==>eqA==>eqA) f -> transpose_neqkey eqA f -> forall m m1 m2 i, Partition m m1 m2 -> @@ -1547,9 +1531,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). set (f:=fun (_:key)(_:elt)=>S). setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)). rewrite <- cardinal_fold. - intros. apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. - apply Partition_fold with (eqA:=@Logic.eq _); try red; auto. - compute; auto. + apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. + apply Partition_fold with (eqA:=eq); repeat red; auto. Qed. Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 -> @@ -1557,7 +1540,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)). Proof. intros m m1 m2 Hm f. - assert (Hf : Morphism (E.eq==>Leibniz==>Leibniz) f). + assert (Hf : Proper (E.eq==>eq==>eq) f). intros k k' Hk e e' _; unfold f; rewrite Hk; auto. set (m1':= fst (partition f m)). set (m2':= snd (partition f m)). @@ -1673,7 +1656,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). End Elt. Add Parametric Morphism elt : (@cardinal elt) - with signature Equal ==> Leibniz as cardinal_m. + with signature Equal ==> eq as cardinal_m. Proof. intros; apply Equal_cardinal; auto. Qed. Add Parametric Morphism elt : (@Disjoint elt) @@ -1761,7 +1744,7 @@ Module OrdProperties (M:S). Import F. Import M. - Section Elt. + Section Elt. Variable elt:Type. Notation eqke := (@eqke elt). @@ -1779,15 +1762,14 @@ Module OrdProperties (M:S). Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt), sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'. Proof. - apply SortA_equivlistA_eqlistA; eauto; - unfold O.eqke, O.ltk; simpl; intuition; eauto. + apply SortA_equivlistA_eqlistA; eauto with *. Qed. Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto. Definition gtb (p p':key*elt) := match E.compare (fst p) (fst p') with GT _ => true | _ => false end. - Definition leb p := fun p' => negb (gtb p p'). + Definition leb p := fun p' => negb (gtb p p'). Definition elements_lt p m := List.filter (gtb p) (elements m). Definition elements_ge p m := List.filter (leb p) (elements m). @@ -1804,10 +1786,10 @@ Module OrdProperties (M:S). destruct (E.compare x y); intuition; try discriminate; ME.order. Qed. - Lemma gtb_compat : forall p, compat_bool eqke (gtb p). + Lemma gtb_compat : forall p, Proper (eqke==>eq) (gtb p). Proof. red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H. - generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); + generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto. unfold O.ltk in *; simpl in *; intros. symmetry; rewrite H2. @@ -1819,7 +1801,7 @@ Module OrdProperties (M:S). rewrite <- H2; auto. Qed. - Lemma leb_compat : forall p, compat_bool eqke (leb p). + Lemma leb_compat : forall p, Proper (eqke==>eq) (leb p). Proof. red; intros x a b H. unfold leb; f_equal; apply gtb_compat; auto. @@ -1827,11 +1809,11 @@ Module OrdProperties (M:S). Hint Resolve gtb_compat leb_compat elements_3 : map. - Lemma elements_split : forall p m, + Lemma elements_split : forall p m, elements m = elements_lt p m ++ elements_ge p m. Proof. unfold elements_lt, elements_ge, leb; intros. - apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with map. + apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with *. intros; destruct x; destruct y; destruct p. rewrite gtb_1 in H; unfold O.ltk in H; simpl in *. assert (~ltk (t1,e0) (k,e1)). @@ -1840,19 +1822,19 @@ Module OrdProperties (M:S). unfold O.ltk in *; simpl in *; ME.order. Qed. - Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> - eqlistA eqke (elements m') + Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> + eqlistA eqke (elements m') (elements_lt (x,e) m ++ (x,e):: elements_ge (x,e) m). Proof. intros; unfold elements_lt, elements_ge. - apply sort_equivlistA_eqlistA; auto with map. - apply (@SortA_app _ eqke); auto with map. - apply (@filter_sort _ eqke); auto with map; clean_eauto. + apply sort_equivlistA_eqlistA; auto with *. + apply (@SortA_app _ eqke); auto with *. + apply (@filter_sort _ eqke); auto with *; clean_eauto. constructor; auto with map. - apply (@filter_sort _ eqke); auto with map; clean_eauto. - rewrite (@InfA_alt _ eqke); auto with map; try (clean_eauto; fail). + apply (@filter_sort _ eqke); auto with *; clean_eauto. + rewrite (@InfA_alt _ eqke); auto with *; try (clean_eauto; fail). intros. - rewrite filter_InA in H1; auto with map; destruct H1. + rewrite filter_InA in H1; auto with *; destruct H1. rewrite leb_1 in H2. destruct y; unfold O.ltk in *; simpl in *. rewrite <- elements_mapsto_iff in H1. @@ -1860,24 +1842,22 @@ Module OrdProperties (M:S). contradict H. exists e0; apply MapsTo_1 with t0; auto. ME.order. - apply (@filter_sort _ eqke); auto with map; clean_eauto. + apply (@filter_sort _ eqke); auto with *; clean_eauto. intros. - rewrite filter_InA in H1; auto with map; destruct H1. + rewrite filter_InA in H1; auto with *; destruct H1. rewrite gtb_1 in H3. destruct y; destruct x0; unfold O.ltk in *; simpl in *. inversion_clear H2. red in H4; simpl in *; destruct H4. ME.order. - rewrite filter_InA in H4; auto with map; destruct H4. + rewrite filter_InA in H4; auto with *; destruct H4. rewrite leb_1 in H4. unfold O.ltk in *; simpl in *; ME.order. red; intros a; destruct a. - rewrite InA_app_iff; rewrite InA_cons. - do 2 (rewrite filter_InA; auto with map). - do 2 rewrite <- elements_mapsto_iff. - rewrite leb_1; rewrite gtb_1. - rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. - rewrite add_mapsto_iff. + rewrite InA_app_iff, InA_cons, 2 filter_InA, + <-2 elements_mapsto_iff, leb_1, gtb_1, + find_mapsto_iff, (H0 t0), <- find_mapsto_iff, + add_mapsto_iff by (auto with *). unfold O.eqke, O.ltk; simpl. destruct (E.compare t0 x); intuition. right; split; auto; ME.order. @@ -1889,13 +1869,13 @@ Module OrdProperties (M:S). right; split; auto; ME.order. Qed. - Lemma elements_Add_Above : forall m m' x e, - Above x m -> Add x e m m' -> + Lemma elements_Add_Above : forall m m' x e, + Above x m -> Add x e m m' -> eqlistA eqke (elements m') (elements m ++ (x,e)::nil). Proof. intros. - apply sort_equivlistA_eqlistA; auto with map. - apply (@SortA_app _ eqke); auto with map. + apply sort_equivlistA_eqlistA; auto with *. + apply (@SortA_app _ eqke); auto with *. intros. inversion_clear H2. destruct x0; destruct y. @@ -1905,27 +1885,26 @@ Module OrdProperties (M:S). apply H; firstorder. inversion H3. red; intros a; destruct a. - rewrite InA_app_iff; rewrite InA_cons; rewrite InA_nil. - do 2 rewrite <- elements_mapsto_iff. - rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. - rewrite add_mapsto_iff; unfold O.eqke; simpl. - intuition. + rewrite InA_app_iff, InA_cons, InA_nil, <- 2 elements_mapsto_iff, + find_mapsto_iff, (H0 t0), <- find_mapsto_iff, + add_mapsto_iff by (auto with *). + unfold O.eqke; simpl. intuition. destruct (E.eq_dec x t0); auto. - elimtype False. + exfalso. assert (In t0 m). exists e0; auto. generalize (H t0 H1). ME.order. Qed. - Lemma elements_Add_Below : forall m m' x e, - Below x m -> Add x e m m' -> + Lemma elements_Add_Below : forall m m' x e, + Below x m -> Add x e m m' -> eqlistA eqke (elements m') ((x,e)::elements m). Proof. intros. - apply sort_equivlistA_eqlistA; auto with map. + apply sort_equivlistA_eqlistA; auto with *. change (sort ltk (((x,e)::nil) ++ elements m)). - apply (@SortA_app _ eqke); auto with map. + apply (@SortA_app _ eqke); auto with *. intros. inversion_clear H1. destruct y; destruct x0. @@ -1935,24 +1914,23 @@ Module OrdProperties (M:S). apply H; firstorder. inversion H3. red; intros a; destruct a. - rewrite InA_cons. - do 2 rewrite <- elements_mapsto_iff. - rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. - rewrite add_mapsto_iff; unfold O.eqke; simpl. - intuition. + rewrite InA_cons, <- 2 elements_mapsto_iff, + 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. - elimtype False. + exfalso. assert (In t0 m). exists e0; auto. generalize (H t0 H1). ME.order. Qed. - Lemma elements_Equal_eqlistA : forall (m m': t elt), + Lemma elements_Equal_eqlistA : forall (m m': t elt), Equal m m' -> eqlistA eqke (elements m) (elements m'). Proof. intros. - apply sort_equivlistA_eqlistA; auto with map. + apply sort_equivlistA_eqlistA; auto with *. red; intros. destruct x; do 2 rewrite <- elements_mapsto_iff. do 2 rewrite find_mapsto_iff; rewrite H; split; auto. @@ -1963,15 +1941,15 @@ Module OrdProperties (M:S). Section Min_Max_Elt. (** We emulate two [max_elt] and [min_elt] functions. *) - - Fixpoint max_elt_aux (l:list (key*elt)) := match l with - | nil => None + + Fixpoint max_elt_aux (l:list (key*elt)) := match l with + | nil => None | (x,e)::nil => Some (x,e) | (x,e)::l => max_elt_aux l end. Definition max_elt m := max_elt_aux (elements m). - Lemma max_elt_Above : + Lemma max_elt_Above : forall m x e, max_elt m = Some (x,e) -> Above x (remove x m). Proof. red; intros. @@ -2010,8 +1988,8 @@ Module OrdProperties (M:S). red; eauto. inversion H2; auto. Qed. - - Lemma max_elt_MapsTo : + + Lemma max_elt_MapsTo : forall m x e, max_elt m = Some (x,e) -> MapsTo x e m. Proof. intros. @@ -2024,7 +2002,7 @@ Module OrdProperties (M:S). constructor 2; auto. Qed. - Lemma max_elt_Empty : + Lemma max_elt_Empty : forall m, max_elt m = None -> Empty m. Proof. intros. @@ -2035,12 +2013,12 @@ Module OrdProperties (M:S). assert (H':=IHl H); discriminate. Qed. - Definition min_elt m : option (key*elt) := match elements m with + Definition min_elt m : option (key*elt) := match elements m with | nil => None | (x,e)::_ => Some (x,e) end. - Lemma min_elt_Below : + Lemma min_elt_Below : forall m x e, min_elt m = Some (x,e) -> Below x (remove x m). Proof. unfold min_elt, Below; intros. @@ -2054,14 +2032,11 @@ Module OrdProperties (M:S). inversion_clear H1. red in H2; destruct H2; simpl in *; ME.order. inversion_clear H4. - rewrite (@InfA_alt _ eqke) in H3; eauto. + rewrite (@InfA_alt _ eqke) in H3; eauto with *. apply (H3 (y,x0)); auto. - unfold lt_key; simpl; intuition; eauto. - intros (x1,x2) (y1,y2) (z1,z2); compute; intuition; eauto. - intros (x1,x2) (y1,y2) (z1,z2); compute; intuition; eauto. Qed. - - Lemma min_elt_MapsTo : + + Lemma min_elt_MapsTo : forall m x e, min_elt m = Some (x,e) -> MapsTo x e m. Proof. intros. @@ -2073,7 +2048,7 @@ Module OrdProperties (M:S). injection H; intros; subst; constructor; red; auto. Qed. - Lemma min_elt_Empty : + Lemma min_elt_Empty : forall m, min_elt m = None -> Empty m. Proof. intros. @@ -2108,7 +2083,7 @@ Module OrdProperties (M:S). assert (S n = S (cardinal (remove k m))). rewrite Heqn. eapply cardinal_2; eauto with map. - inversion H1; auto. + inversion H1; auto. eapply max_elt_Above; eauto. apply X; apply max_elt_Empty; auto. @@ -2135,7 +2110,7 @@ Module OrdProperties (M:S). assert (S n = S (cardinal (remove k m))). rewrite Heqn. eapply cardinal_2; eauto with map. - inversion H1; auto. + inversion H1; auto. eapply min_elt_Below; eauto. apply X; apply min_elt_Empty; auto. @@ -2150,7 +2125,7 @@ Module OrdProperties (M:S). Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f:key->elt->A->A)(i:A), - Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + Proper (E.eq==>eq==>eqA==>eqA) f -> Equal m1 m2 -> eqA (fold f m1 i) (fold f m2 i). Proof. @@ -2158,13 +2133,12 @@ Module OrdProperties (M:S). do 2 rewrite fold_1. do 2 rewrite <- fold_left_rev_right. apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k,e) (k',e') a a' (Hk,He) Ha; simpl in *; apply Hf; auto. + intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto. apply eqlistA_rev. apply elements_Equal_eqlistA. auto. Qed. Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A), - Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), Above x m1 -> Add x e m1 m2 -> eqA (fold f m2 i) (f x e (fold f m1 i)). Proof. @@ -2172,7 +2146,7 @@ Module OrdProperties (M:S). set (f':=fun y x0 => f (fst y) (snd y) x0) in *. transitivity (fold_right f' i (rev (elements m1 ++ (x,e)::nil))). apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *; apply H; auto. + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto. apply eqlistA_rev. apply elements_Add_Above; auto. rewrite distr_rev; simpl. @@ -2180,8 +2154,7 @@ Module OrdProperties (M:S). Qed. Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A), - Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), Below x m1 -> Add x e m1 m2 -> eqA (fold f m2 i) (fold f m1 (f x e i)). Proof. @@ -2189,7 +2162,7 @@ Module OrdProperties (M:S). set (f':=fun y x0 => f (fst y) (snd y) x0) in *. transitivity (fold_right f' i (rev (((x,e)::nil)++elements m1))). apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *; apply H; auto. + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto. apply eqlistA_rev. simpl; apply elements_Add_Below; auto. rewrite distr_rev; simpl. diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 57cbbcc4..e4f8b4df 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -1,4 +1,3 @@ - (***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Prop := | RBLeaf : avl (Leaf _) - | RBNode : forall x e l r h, + | RBNode : forall x e l r h, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - h = max (height l) (height r) + 1 -> + h = max (height l) (height r) + 1 -> avl (Node l x e r h). @@ -64,28 +65,28 @@ Inductive avl : t elt -> Prop := Hint Constructors avl. -Lemma height_non_negative : forall (s : t elt), avl s -> +Lemma height_non_negative : forall (s : t elt), avl s -> height s >= 0. Proof. induction s; simpl; intros; auto with zarith. inv avl; intuition; omega_max. Qed. -Ltac avl_nn_hyp H := +Ltac avl_nn_hyp H := let nz := fresh "nz" in assert (nz := height_non_negative H). -Ltac avl_nn h := - let t := type of h in - match type of t with +Ltac avl_nn h := + let t := type of h in + match type of t with | Prop => avl_nn_hyp h | _ => match goal with H : avl h |- _ => avl_nn_hyp H end end. -(* Repeat the previous tactic. +(* Repeat the previous tactic. Drawback: need to clear the [avl _] hyps ... Thank you Ltac *) Ltac avl_nns := - match goal with + match goal with | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns | _ => idtac end. @@ -103,49 +104,49 @@ Hint Resolve avl_node. (** Results about [height] *) -Lemma height_0 : forall l, avl l -> height l = 0 -> +Lemma height_0 : forall l, avl l -> height l = 0 -> l = Leaf _. Proof. destruct 1; intuition; simpl in *. - avl_nns; simpl in *; elimtype False; omega_max. + avl_nns; simpl in *; exfalso; omega_max. Qed. (** * Empty map *) Lemma empty_avl : avl (empty elt). -Proof. +Proof. unfold empty; auto. Qed. (** * Helper functions *) -Lemma create_avl : - forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> +Lemma create_avl : + forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> avl (create l x e r). Proof. unfold create; auto. Qed. -Lemma create_height : - forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> +Lemma create_height : + forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> height (create l x e r) = max (height l) (height r) + 1. Proof. unfold create; intros; auto. Qed. -Lemma bal_avl : forall l x e r, avl l -> avl r -> +Lemma bal_avl : forall l x e r, avl l -> avl r -> -(3) <= height l - height r <= 3 -> avl (bal l x e r). Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; - inv avl; simpl in *; + inv avl; simpl in *; match goal with |- avl (assert_false _ _ _ _) => avl_nns | _ => repeat apply create_avl; simpl in *; auto end; omega_max. Qed. -Lemma bal_height_1 : forall l x e r, avl l -> avl r -> +Lemma bal_height_1 : forall l x e r, avl l -> avl r -> -(3) <= height l - height r <= 3 -> 0 <= height (bal l x e r) - max (height l) (height r) <= 1. Proof. @@ -153,25 +154,25 @@ Proof. inv avl; avl_nns; simpl in *; omega_max. Qed. -Lemma bal_height_2 : - forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> +Lemma bal_height_2 : + forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> height (bal l x e r) == max (height l) (height r) +1. Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv avl; avl_nns; simpl in *; omega_max. Qed. -Ltac omega_bal := match goal with - | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => - generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); +Ltac omega_bal := match goal with + | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => + generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); omega_max end. (** * Insertion *) -Lemma add_avl_1 : forall m x e, avl m -> +Lemma add_avl_1 : forall m x e, avl m -> avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1. -Proof. +Proof. intros m x e; functional induction (add x e m); intros; inv avl; simpl in *. intuition; try constructor; simpl; auto; try omega_max. (* LT *) @@ -196,8 +197,8 @@ Hint Resolve add_avl. (** * Extraction of minimum binding *) -Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) -> - avl (remove_min l x e r)#1 /\ +Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) -> + avl (remove_min l x e r)#1 /\ 0 <= height (Node l x e r h) - height (remove_min l x e r)#1 <= 1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. @@ -210,20 +211,20 @@ Proof. omega_bal. Qed. -Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) -> - avl (remove_min l x e r)#1. +Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) -> + avl (remove_min l x e r)#1. Proof. intros; generalize (remove_min_avl_1 H); intuition. Qed. (** * Merging two trees *) -Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 -> - -(2) <= height m1 - height m2 <= 2 -> - avl (merge m1 m2) /\ +Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 -> + -(2) <= height m1 - height m2 <= 2 -> + avl (merge m1 m2) /\ 0<= height (merge m1 m2) - max (height m1) (height m2) <=1. Proof. - intros m1 m2; functional induction (merge m1 m2); intros; + intros m1 m2; functional induction (merge m1 m2); intros; try factornode _x _x0 _x1 _x2 _x3 as m1. simpl; split; auto; avl_nns; omega_max. simpl; split; auto; avl_nns; omega_max. @@ -235,16 +236,16 @@ Proof. omega_bal. Qed. -Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 -> +Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 -> -(2) <= height m1 - height m2 <= 2 -> avl (merge m1 m2). -Proof. +Proof. intros; generalize (merge_avl_1 H H0 H1); intuition. Qed. (** * Deletion *) -Lemma remove_avl_1 : forall m x, avl m -> +Lemma remove_avl_1 : forall m x, avl m -> avl (remove x m) /\ 0 <= height m - height (remove x m) <= 1. Proof. intros m x; functional induction (remove x m); intros. @@ -252,25 +253,25 @@ Proof. (* LT *) inv avl. destruct (IHt H0). - split. + split. apply bal_avl; auto. omega_max. omega_bal. (* EQ *) - inv avl. + inv avl. generalize (merge_avl_1 H0 H1 H2). intuition omega_max. (* GT *) inv avl. destruct (IHt H1). - split. + split. apply bal_avl; auto. omega_max. omega_bal. Qed. Lemma remove_avl : forall m x, avl m -> avl (remove x m). -Proof. +Proof. intros; generalize (remove_avl_1 x H); intuition. Qed. Hint Resolve remove_avl. @@ -278,7 +279,7 @@ Hint Resolve remove_avl. (** * Join *) -Lemma join_avl_1 : forall l x d r, avl l -> avl r -> +Lemma join_avl_1 : forall l x d r, avl l -> avl r -> avl (join l x d r) /\ 0<= height (join l x d r) - max (height l) (height r) <= 1. Proof. @@ -344,9 +345,9 @@ Hint Resolve concat_avl. (** split *) -Lemma split_avl : forall m x, avl m -> +Lemma split_avl : forall m x, avl m -> avl (split x m)#l /\ avl (split x m)#r. -Proof. +Proof. intros m x; functional induction (split x m); simpl; auto. rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. simpl; inversion_clear 1; auto. @@ -356,12 +357,12 @@ Qed. End Elt. Hint Constructors avl. -Section Map. +Section Map. Variable elt elt' : Type. -Variable f : elt -> elt'. +Variable f : elt -> elt'. Lemma map_height : forall m, height (map f m) = height m. -Proof. +Proof. destruct m; simpl; auto. Qed. @@ -375,10 +376,10 @@ End Map. Section Mapi. Variable elt elt' : Type. -Variable f : key -> elt -> elt'. +Variable f : key -> elt -> elt'. Lemma mapi_height : forall m, height (mapi f m) = height m. -Proof. +Proof. destruct m; simpl; auto. Qed. @@ -390,7 +391,7 @@ Qed. End Mapi. -Section Map_option. +Section Map_option. Variable elt elt' : Type. Variable f : key -> elt -> option elt'. @@ -412,12 +413,12 @@ Hypothesis mapr_avl : forall m', avl m' -> avl (mapr m'). Notation map2_opt := (map2_opt f mapl mapr). -Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 -> +Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 -> avl (map2_opt m1 m2). Proof. -intros m1 m2; functional induction (map2_opt m1 m2); auto; -factornode _x0 _x1 _x2 _x3 _x4 as r2; intros; -destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl; +intros m1 m2; functional induction (map2_opt m1 m2); auto; +factornode _x0 _x1 _x2 _x3 _x4 as r2; intros; +destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl; auto using join_avl, concat_avl. Qed. @@ -437,11 +438,11 @@ End AvlProofs. (** * Encapsulation - We can implement [S] with balanced binary search trees. + We can implement [S] with balanced binary search trees. When compared to [FMapAVL], we maintain here two invariants (bst and avl) instead of only bst, which is enough for fulfilling the FMap interface. -*) +*) Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. @@ -450,32 +451,32 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Import Raw. Import Raw.Proofs. - Record bbst (elt:Type) := + Record bbst (elt:Type) := Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}. - + Definition t := bbst. Definition key := E.t. - + Section Elt. Variable elt elt' elt'': Type. Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. + Implicit Types x y : key. + Implicit Types e : elt. Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt). Definition is_empty m : bool := is_empty m.(this). - Definition add x e m : t elt := + Definition add x e m : t elt := Bbst (add_bst x e m.(is_bst)) (add_avl x e m.(is_avl)). - Definition remove x m : t elt := + Definition remove x m : t elt := Bbst (remove_bst x m.(is_bst)) (remove_avl x m.(is_avl)). Definition mem x m : bool := mem x m.(this). Definition find x m : option elt := find x m.(this). - Definition map f m : t elt' := + Definition map f m : t elt' := Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)). - Definition mapi (f:key->elt->elt') m : t elt' := + Definition mapi (f:key->elt->elt') m : t elt' := Bbst (mapi_bst f m.(is_bst)) (mapi_avl f m.(is_avl)). - Definition map2 f m (m':t elt') : t elt'' := + Definition map2 f m (m':t elt') : t elt'' := Bbst (map2_bst f m.(is_bst) m'.(is_bst)) (map2_avl f m.(is_avl) m'.(is_avl)). Definition elements m : list (key*elt) := elements m.(this). Definition cardinal m := cardinal m.(this). @@ -492,14 +493,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. - + Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. apply m.(is_bst). Qed. - - Lemma mem_2 : forall m x, mem x m = true -> In x m. + + Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto. Qed. @@ -530,7 +531,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@find_2 elt m.(this)). Qed. @@ -539,36 +540,36 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. - Lemma elements_1 : forall m x e, + Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto. Qed. - Lemma elements_2 : forall m x e, + Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto. Qed. - Lemma elements_3 : forall m, sort lt_key (elements m). + Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed. Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp := Equiv (Cmp cmp). - Lemma Equivb_Equivb : forall cmp m m', + Lemma Equivb_Equivb : forall cmp m m', Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. - Proof. + Proof. intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. @@ -576,23 +577,23 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. generalize (H0 k); do 2 rewrite <- In_alt; intuition. Qed. - Lemma equal_1 : forall m m' cmp, - Equivb cmp m m' -> equal cmp m m' = true. - Proof. - unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; + Lemma equal_1 : forall m m' cmp, + Equivb cmp m m' -> equal cmp m m' = true. + Proof. + unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite equal_Equivb; auto. - Qed. + Qed. - Lemma equal_2 : forall m m' cmp, + Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. - unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; + Proof. + unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite <-equal_Equivb; auto. Qed. End Elt. - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. @@ -600,10 +601,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl. apply map_2; auto. - Qed. + Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) @@ -613,10 +614,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. apply m.(is_bst). @@ -624,9 +625,9 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - Proof. + Proof. unfold In, map2; intros elt elt' elt'' m m' x f. do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. apply m.(is_bst). @@ -636,54 +637,54 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. End IntMake. -Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: - Sord with Module Data := D +Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: + Sord with Module Data := D with Module MapS.E := X. Module Data := D. - Module Import MapS := IntMake(I)(X). + Module Import MapS := IntMake(I)(X). Import AvlProofs. Import Raw.Proofs. Module Import MD := OrderedTypeFacts(D). Module LO := FMapList.Make_ord(X)(D). - Definition t := MapS.t D.t. + Definition t := MapS.t D.t. - Definition cmp e e' := + Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. - Definition elements (m:t) := + Definition elements (m:t) := LO.MapS.Build_slist (Raw.Proofs.elements_sort m.(is_bst)). - (** * As comparison function, we propose here a non-structural - version faithful to the code of Ocaml's Map library, instead of + (** * As comparison function, we propose here a non-structural + version faithful to the code of Ocaml's Map library, instead of the structural version of FMapAVL *) - Fixpoint cardinal_e (e:Raw.enumeration D.t) := - match e with + Fixpoint cardinal_e (e:Raw.enumeration D.t) := + match e with | Raw.End => 0%nat | Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e) end. - Lemma cons_cardinal_e : forall m e, + Lemma cons_cardinal_e : forall m e, cardinal_e (Raw.cons m e) = (Raw.cardinal m + cardinal_e e)%nat. Proof. induction m; simpl; intros; auto. rewrite IHm1; simpl; rewrite <- plus_n_Sm; auto with arith. Qed. - Definition cardinal_e_2 ee := + Definition cardinal_e_2 ee := (cardinal_e (fst ee) + cardinal_e (snd ee))%nat. - Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t) - { measure cardinal_e_2 ee } : comparison := - match ee with + 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.More x1 d1 r1 e1, Raw.More x2 d2 r2 e2) => match X.compare x1 x2 with - | EQ _ => match D.compare d1 d2 with + | EQ _ => match D.compare d1 d2 with | EQ _ => compare_aux (Raw.cons r1 e1, Raw.cons r2 e2) | LT _ => Lt | GT _ => Gt @@ -693,10 +694,10 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: end end. Proof. - intros; unfold cardinal_e_2; simpl; + intros; unfold cardinal_e_2; simpl; abstract (do 2 rewrite cons_cardinal_e; romega with * ). Defined. - + Definition Cmp c := match c with | Eq => LO.eq_list @@ -704,7 +705,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: | Gt => (fun l1 l2 => LO.lt_list l2 l1) end. - Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, + Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, X.eq x1 x2 -> D.eq d1 d2 -> Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). Proof. @@ -712,23 +713,23 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Qed. Hint Resolve cons_Cmp. - Lemma compare_aux_Cmp : forall e, + Lemma compare_aux_Cmp : forall e, Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)). Proof. - intros e; functional induction (compare_aux e); simpl in *; + intros e; functional induction (compare_aux e); simpl in *; auto; intros; try clear e0; try clear e3; try MX.elim_comp; auto. rewrite 2 cons_1 in IHc; auto. Qed. - Lemma compare_Cmp : forall m1 m2, - Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))) + Lemma compare_Cmp : forall m1 m2, + Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))) (Raw.elements m1) (Raw.elements m2). Proof. - intros. + 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. - apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _), + apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))). Qed. @@ -737,15 +738,15 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Definition compare (s s':t) : Compare lt eq s s'. Proof. - intros (s,b,a) (s',b',a'). + destruct s as (s,b,a), s' as (s',b',a'). generalize (compare_Cmp s s'). destruct compare_aux; intros; [apply EQ|apply LT|apply GT]; red; auto. Defined. - + (* Proofs about [eq] and [lt] *) - Definition selements (m1 : t) := + Definition selements (m1 : t) := LO.MapS.Build_slist (elements_sort m1.(is_bst)). Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). @@ -782,7 +783,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Qed. Lemma eq_refl : forall m : t, eq m m. - Proof. + Proof. intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl. Qed. @@ -799,13 +800,13 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Proof. - intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; + intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; intros; eapply LO.lt_trans; eauto. Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. - intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; + intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; intros; apply LO.lt_not_eq; auto. Qed. @@ -816,8 +817,8 @@ End IntMake_ord. Module Make (X: OrderedType) <: S with Module E := X :=IntMake(Z_as_Int)(X). -Module Make_ord (X: OrderedType)(D: OrderedType) - <: Sord with Module Data := D +Module Make_ord (X: OrderedType)(D: OrderedType) + <: Sord with Module Data := D with Module MapS.E := X :=IntMake_ord(Z_as_Int)(X)(D). diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index ebdc9c57..e60cca9d 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapInterface.v 11699 2008-12-18 11:49:08Z letouzey $ *) +(* $Id$ *) -(** * Finite map library *) +(** * Finite map library *) (** This file proposes interfaces for finite maps *) @@ -16,8 +16,8 @@ Require Export Bool DecidableType OrderedType. Set Implicit Arguments. Unset Strict Implicit. -(** When compared with Ocaml Map, this signature has been split in - several parts : +(** When compared with Ocaml Map, this signature has been split in + several parts : - The first parts [WSfun] and [WS] propose signatures for weak maps, which are maps with no ordering on the key type nor the @@ -29,18 +29,18 @@ Unset Strict Implicit. (add, find, ...). The only function that asks for more is [equal], whose first argument should be a comparison on data. - - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the - case where the key type is ordered. The main novelty is that + - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the + case where the key type is ordered. The main novelty is that [elements] is required to produce sorted lists. - - Finally, [Sord] extends [S] with a complete comparison function. For - that, the data type should have a decidable total ordering as well. + - Finally, [Sord] extends [S] with a complete comparison function. For + that, the data type should have a decidable total ordering as well. If unsure, what you're looking for is probably [S]: apart from [Sord], - all other signatures are subsets of [S]. + all other signatures are subsets of [S]. + + Some additional differences with Ocaml: - Some additional differences with Ocaml: - - no [iter] function, useless since Coq is purely functional - [option] types are used instead of [Not_found] exceptions - more functions are provided: [elements] and [cardinal] and [map2] @@ -51,7 +51,7 @@ Unset Strict Implicit. Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. (** ** Weak signature for maps - + No requirements for an ordering on keys nor elements, only decidability of equality on keys. First, a functorial signature: *) @@ -61,8 +61,8 @@ Module Type WSfun (E : DecidableType). Parameter t : Type -> Type. (** the abstract type of maps *) - - Section Types. + + Section Types. Variable elt:Type. @@ -73,61 +73,61 @@ Module Type WSfun (E : DecidableType). (** Test whether a map is empty or not. *) Parameter add : key -> elt -> t elt -> t elt. - (** [add x y m] returns a map containing the same bindings as [m], - plus a binding of [x] to [y]. If [x] was already bound in [m], + (** [add x y m] returns a map containing the same bindings as [m], + plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) - Parameter find : key -> t elt -> option elt. - (** [find x m] returns the current binding of [x] in [m], + Parameter find : key -> t elt -> option elt. + (** [find x m] returns the current binding of [x] in [m], or [None] if no such binding exists. *) Parameter remove : key -> t elt -> t elt. - (** [remove x m] returns a map containing the same bindings as [m], + (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. *) Parameter mem : key -> t elt -> bool. - (** [mem x m] returns [true] if [m] contains a binding for [x], + (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) Variable elt' elt'' : Type. Parameter map : (elt -> elt') -> t elt -> t elt'. - (** [map f m] returns a map with same domain as [m], where the associated + (** [map f m] returns a map with same domain as [m], where the associated value a of all bindings of [m] has been replaced by the result of the application of [f] to [a]. Since Coq is purely functional, the order in which the bindings are passed to [f] is irrelevant. *) Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. - (** Same as [map], but the function receives as arguments both the + (** Same as [map], but the function receives as arguments both the key and the associated value for each binding of the map. *) - Parameter map2 : + Parameter map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' -> t elt''. - (** [map2 f m m'] creates a new map whose bindings belong to the ones - of either [m] or [m']. The presence and value for a key [k] is - determined by [f e e'] where [e] and [e'] are the (optional) bindings + (** [map2 f m m'] creates a new map whose bindings belong to the ones + of either [m] or [m']. The presence and value for a key [k] is + determined by [f e e'] where [e] and [e'] are the (optional) bindings of [k] in [m] and [m']. *) Parameter elements : t elt -> list (key*elt). - (** [elements m] returns an assoc list corresponding to the bindings + (** [elements m] returns an assoc list corresponding to the bindings of [m], in any order. *) - Parameter cardinal : t elt -> nat. + Parameter cardinal : t elt -> nat. (** [cardinal m] returns the number of bindings in [m]. *) Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A. - (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], - where [k1] ... [kN] are the keys of all bindings in [m] + (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1] ... [kN] are the keys of all bindings in [m] (in any order), and [d1] ... [dN] are the associated data. *) Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. - (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, - that is, contain equal keys and associate them with equal data. - [cmp] is the equality predicate used to compare the data associated + (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, + that is, contain equal keys and associate them with equal data. + [cmp] is the equality predicate used to compare the data associated with the keys. *) - Section Spec. - + Section Spec. + Variable m m' m'' : t elt. Variable x y z : key. Variable e e' : elt. @@ -139,24 +139,24 @@ Module Type WSfun (E : DecidableType). Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p'). - - Definition eq_key_elt (p p':key*elt) := + + Definition eq_key_elt (p p':key*elt) := E.eq (fst p) (fst p') /\ (snd p) = (snd p'). (** Specification of [MapsTo] *) Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. - + (** Specification of [mem] *) Parameter mem_1 : In x m -> mem x m = true. - Parameter mem_2 : mem x m = true -> In x m. - + Parameter mem_2 : mem x m = true -> In x m. + (** Specification of [empty] *) Parameter empty_1 : Empty empty. (** Specification of [is_empty] *) - Parameter is_empty_1 : Empty m -> is_empty m = true. + Parameter is_empty_1 : Empty m -> is_empty m = true. Parameter is_empty_2 : is_empty m = true -> Empty m. - + (** Specification of [add] *) Parameter add_1 : E.eq x y -> MapsTo y e (add x e m). Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). @@ -168,50 +168,50 @@ Module Type WSfun (E : DecidableType). Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. (** Specification of [find] *) - Parameter find_1 : MapsTo x e m -> find x m = Some e. + Parameter find_1 : MapsTo x e m -> find x m = Some e. Parameter find_2 : find x m = Some e -> MapsTo x e m. (** Specification of [elements] *) - Parameter elements_1 : + Parameter elements_1 : MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Parameter elements_2 : + Parameter elements_2 : InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - (** When compared with ordered maps, here comes the only + (** When compared with ordered maps, here comes the only property that is really weaker: *) - Parameter elements_3w : NoDupA eq_key (elements m). + Parameter elements_3w : NoDupA eq_key (elements m). (** Specification of [cardinal] *) Parameter cardinal_1 : cardinal m = length (elements m). - (** Specification of [fold] *) + (** Specification of [fold] *) Parameter fold_1 : forall (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. (** Equality of maps *) - + (** Caveat: there are at least three distinct equality predicates on maps. - - The simpliest (and maybe most natural) way is to consider keys up to - their equivalence [E.eq], but elements up to Leibniz equality, in + - The simpliest (and maybe most natural) way is to consider keys up to + their equivalence [E.eq], but elements up to Leibniz equality, in the spirit of [eq_key_elt] above. This leads to predicate [Equal]. - Unfortunately, this [Equal] predicate can't be used to describe - the [equal] function, since this function (for compatibility with - ocaml) expects a boolean comparison [cmp] that may identify more - elements than Leibniz. So logical specification of [equal] is done + the [equal] function, since this function (for compatibility with + ocaml) expects a boolean comparison [cmp] that may identify more + elements than Leibniz. So logical specification of [equal] is done via another predicate [Equivb] - This predicate [Equivb] is quite ad-hoc with its boolean [cmp], it can be generalized in a [Equiv] expecting a more general (possibly non-decidable) equality predicate on elements *) Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). (** Specification of [equal] *) - Variable cmp : elt -> elt -> bool. + Variable cmp : elt -> elt -> bool. Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true. Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'. @@ -220,26 +220,26 @@ Module Type WSfun (E : DecidableType). End Types. (** Specification of [map] *) - Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. - + (** Specification of [mapi] *) Parameter mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Parameter mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. (** Specification of [map2] *) Parameter map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). Parameter map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Hint Immediate MapsTo_1 mem_2 is_empty_2 @@ -252,13 +252,13 @@ Module Type WSfun (E : DecidableType). End WSfun. -(** ** Static signature for Weak Maps +(** ** Static signature for Weak Maps Similar to [WSfun] but expressed in a self-contained way. *) -Module Type WS. +Module Type WS. Declare Module E : DecidableType. - Include Type WSfun E. + Include WSfun E. End WS. @@ -266,7 +266,7 @@ End WS. (** ** Maps on ordered keys, functorial signature *) Module Type Sfun (E : OrderedType). - Include Type WSfun E. + Include WSfun E. Section elt. Variable elt:Type. Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p'). @@ -274,7 +274,7 @@ Module Type Sfun (E : OrderedType). Parameter elements_3 : forall m, sort lt_key (elements m). (** Remark: since [fold] is specified via [elements], this stronger specification of [elements] has an indirect impact on [fold], - which can now be proved to receive elements in increasing order. *) + which can now be proved to receive elements in increasing order. *) End elt. End Sfun. @@ -282,9 +282,9 @@ End Sfun. (** ** Maps on ordered keys, self-contained signature *) -Module Type S. +Module Type S. Declare Module E : OrderedType. - Include Type Sfun E. + Include Sfun E. End S. @@ -293,28 +293,28 @@ End S. Module Type Sord. - Declare Module Data : OrderedType. - Declare Module MapS : S. + Declare Module Data : OrderedType. + Declare Module MapS : S. Import MapS. - - Definition t := MapS.t Data.t. + + Definition t := MapS.t Data.t. Parameter eq : t -> t -> Prop. - Parameter lt : t -> t -> Prop. - + Parameter lt : t -> t -> Prop. + Axiom eq_refl : forall m : t, eq m m. Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. - Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end. + Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end. Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'. Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'. Parameter compare : forall m1 m2, Compare lt eq m1 m2. - (** Total ordering between maps. [Data.compare] is a total ordering + (** Total ordering between maps. [Data.compare] is a total ordering used to compare data associated with equal keys in the two maps. *) End Sord. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 0ec5ef36..56fc35d8 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapList.v 11699 2008-12-18 11:49:08Z letouzey $ *) +(* $Id$ *) (** * Finite map library *) @@ -30,7 +30,7 @@ Definition t (elt:Type) := list (X.t * elt). Section Elt. Variable elt : Type. -Notation eqk := (eqk (elt:=elt)). +Notation eqk := (eqk (elt:=elt)). Notation eqke := (eqke (elt:=elt)). Notation ltk := (ltk (elt:=elt)). Notation MapsTo := (MapsTo (elt:=elt)). @@ -45,7 +45,7 @@ Definition empty : t elt := nil. Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. Lemma empty_1 : Empty empty. -Proof. +Proof. unfold Empty,empty. intros a e. intro abs. @@ -54,7 +54,7 @@ Qed. Hint Resolve empty_1. Lemma empty_sorted : Sort empty. -Proof. +Proof. unfold empty; auto. Qed. @@ -62,7 +62,7 @@ Qed. Definition is_empty (l : t elt) : bool := if l then true else false. -Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. +Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. Proof. unfold Empty, PX.MapsTo. intros m. @@ -72,7 +72,7 @@ Proof. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. -Proof. +Proof. intros m. case m;auto. intros p l abs. @@ -93,12 +93,12 @@ Function mem (k : key) (s : t elt) {struct s} : bool := end. Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true. -Proof. - intros m Hm x; generalize Hm; clear Hm. +Proof. + intros m Hm x; generalize Hm; clear Hm. functional induction (mem x m);intros sorted belong1;trivial. - + inversion belong1. inversion H. - + absurd (In x ((k', _x) :: l));try assumption. apply Sort_Inf_NotIn with _x;auto. @@ -107,13 +107,13 @@ Proof. elim (In_inv belong1);auto. intro abs. absurd (X.eq x k');auto. -Qed. +Qed. -Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. +Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. Proof. intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail). - exists _x; auto. + exists _x; auto. induction IHb; auto. exists x0; auto. inversion_clear sorted; auto. @@ -124,7 +124,7 @@ Qed. Function find (k:key) (s: t elt) {struct s} : option elt := match s with | nil => None - | (k',x)::s' => + | (k',x)::s' => match X.compare k k' with | LT _ => None | EQ _ => Some x @@ -138,7 +138,7 @@ Proof. functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto. Qed. -Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. +Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. Proof. intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (find x m);simpl; subst; try clear H_eq_1. @@ -150,9 +150,9 @@ Proof. clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. clear e1;inversion_clear 2. - compute in H0; destruct H0; intuition congruence. + compute in H0; destruct H0; intuition congruence. generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. - + clear e1; do 2 inversion_clear 1; auto. compute in H2; destruct H2; order. Qed. @@ -177,10 +177,10 @@ Proof. functional induction (add x e m);simpl;auto. Qed. -Lemma add_2 : forall m x y e e', +Lemma add_2 : forall m x y e e', ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. - intros m x y e e'. + intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. functional induction (add x e' m) ;simpl;auto; clear e0. subst;auto. @@ -191,7 +191,7 @@ Proof. auto. intros y' e'' eqky'; inversion_clear 1; intuition. Qed. - + Lemma add_3 : forall m x y e e', ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. @@ -200,15 +200,15 @@ Proof. functional induction (add x e' m);simpl; intros. apply (In_inv_3 H0); compute; auto. apply (In_inv_3 H0); compute; auto. - constructor 2; apply (In_inv_3 H0); compute; auto. + constructor 2; apply (In_inv_3 H0); compute; auto. inversion_clear H0; auto. Qed. -Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), +Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m). Proof. - induction m. + induction m. simpl; intuition. intros. destruct a as (x'',e''). @@ -227,7 +227,7 @@ Proof. simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. constructor; auto. apply Inf_eq with (x',e'); auto. -Qed. +Qed. (** * [remove] *) @@ -240,48 +240,48 @@ Function remove (k : key) (s : t elt) {struct s} : t elt := | EQ _ => l | GT _ => (k',x) :: remove k l end - end. + end. Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m). Proof. intros m Hm x y; generalize Hm; clear Hm. functional induction (remove x m);simpl;intros;subst. - + red; inversion 1; inversion H1. apply Sort_Inf_NotIn with x0; auto. clear e0;constructor; compute; order. - + clear e0;inversion_clear Hm. - apply Sort_Inf_NotIn with x0; auto. + apply Sort_Inf_NotIn with x0; auto. apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto. clear e0;inversion_clear Hm. assert (notin:~ In y (remove x l)) by auto. intros (x1,abs). - inversion_clear abs. + inversion_clear abs. compute in H2; destruct H2; order. apply notin; exists x1; auto. Qed. -Lemma remove_2 : forall m (Hm:Sort m) x y e, +Lemma remove_2 : forall m (Hm:Sort m) x y e, ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. - functional induction (remove x m);subst;auto; - match goal with + functional induction (remove x m);subst;auto; + match goal with | [H: X.compare _ _ = _ |- _ ] => clear H | _ => idtac end. inversion_clear 3; auto. compute in H1; destruct H1; order. - + inversion_clear 1; inversion_clear 2; auto. Qed. -Lemma remove_3 : forall m (Hm:Sort m) x y e, +Lemma remove_3 : forall m (Hm:Sort m) x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. @@ -289,10 +289,10 @@ Proof. inversion_clear 1; inversion_clear 1; auto. Qed. -Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), +Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), Inf (x',e') m -> Inf (x',e') (remove x m). Proof. - induction m. + induction m. simpl; intuition. intros. destruct a as (x'',e''). @@ -311,31 +311,31 @@ Proof. intros. destruct a as (x',e'). simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. -Qed. +Qed. (** * [elements] *) Definition elements (m: t elt) := m. -Lemma elements_1 : forall m x e, +Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m). Proof. auto. Qed. -Lemma elements_2 : forall m x e, +Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. -Proof. +Proof. auto. Qed. -Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). -Proof. +Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). +Proof. auto. Qed. -Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). -Proof. +Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). +Proof. intros. apply Sort_NoDupA. apply elements_3; auto. @@ -351,30 +351,30 @@ Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} : A := Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. -Proof. +Proof. intros; functional induction (fold f m i); auto. Qed. (** * [equal] *) -Function equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool := - match m, m' with +Function equal (cmp:elt->elt->bool)(m m' : t elt) {struct m} : bool := + match m, m' with | nil, nil => true - | (x,e)::l, (x',e')::l' => - match X.compare x x' with + | (x,e)::l, (x',e')::l' => + match X.compare x x' with | EQ _ => cmp e e' && equal cmp l l' | _ => false - end - | _, _ => false + end + | _, _ => false end. -Definition Equivb cmp m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). +Definition Equivb cmp m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. +Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, + Equivb cmp m m' -> equal cmp m m' = true. +Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; intuition; subst. @@ -407,7 +407,7 @@ Proof. destruct (X.compare x x'); try contradiction; clear y. destruct (H0 x). - assert (In x ((x',e')::l')). + assert (In x ((x',e')::l')). apply H; auto. exists e; auto. destruct (In_inv H3). @@ -418,7 +418,7 @@ Proof. elim (Sort_Inf_NotIn H5 H7 H4). destruct (H0 x'). - assert (In x' ((x,e)::l)). + assert (In x' ((x,e)::l)). apply H2; auto. exists e'; auto. destruct (In_inv H3). @@ -430,7 +430,7 @@ Proof. destruct m; destruct m';try contradiction. - + clear H1;destruct p as (k,e). destruct (H0 k). destruct H1. @@ -447,18 +447,18 @@ Proof. Qed. -Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, +Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. - functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; - intuition; try discriminate; subst; + functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; + intuition; try discriminate; subst; try match goal with H: X.compare _ _ = _ |- _ => clear H end. inversion H0. inversion_clear Hm;inversion_clear Hm'. - destruct (andb_prop _ _ H); clear H. + destruct (andb_prop _ _ H); clear H. destruct (IHb H1 H3 H6). destruct (In_inv H0). exists e'; constructor; split; trivial; apply X.eq_trans with x; auto. @@ -467,7 +467,7 @@ Proof. exists e''; auto. inversion_clear Hm;inversion_clear Hm'. - destruct (andb_prop _ _ H); clear H. + destruct (andb_prop _ _ H); clear H. destruct (IHb H1 H3 H6). destruct (In_inv H0). exists e; constructor; split; trivial; apply X.eq_trans with x'; auto. @@ -476,15 +476,15 @@ Proof. exists e''; auto. inversion_clear Hm;inversion_clear Hm'. - destruct (andb_prop _ _ H); clear H. + destruct (andb_prop _ _ H); clear H. destruct (IHb H2 H4 H7). inversion_clear H0. destruct H9; simpl in *; subst. - inversion_clear H1. + inversion_clear H1. destruct H9; simpl in *; subst; auto. elim (Sort_Inf_NotIn H4 H5). exists e'0; apply MapsTo_eq with k; auto; order. - inversion_clear H1. + inversion_clear H1. destruct H0; simpl in *; subst; auto. elim (Sort_Inf_NotIn H2 H3). exists e0; apply MapsTo_eq with k; auto; order. @@ -494,7 +494,7 @@ Qed. (** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *) Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) -> - eqk x y -> cmp (snd x) (snd y) = true -> + eqk x y -> cmp (snd x) (snd y) = true -> (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)). Proof. intros. @@ -517,38 +517,38 @@ Qed. Variable elt':Type. (** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' := + +Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := match m with | nil => nil | (k,e)::m' => (k,f e) :: map f m' end. -Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' := +Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := match m with | nil => nil | (k,e)::m' => (k,f k e) :: mapi f m' end. End Elt. -Section Elt2. -(* A new section is necessary for previous definitions to work +Section Elt2. +(* A new section is necessary for previous definitions to work with different [elt], especially [MapsTo]... *) - + Variable elt elt' : Type. (** Specification of [map] *) -Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), +Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros m x e f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. - + destruct a as (x',e'). - simpl. + simpl. inversion_clear 1. constructor 1. unfold eqke in *; simpl in *; intuition congruence. @@ -556,15 +556,15 @@ Proof. unfold MapsTo in *; auto. Qed. -Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), +Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. - intros m x f. + intros m x f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. - + destruct a as (x',e). intros hyp. inversion hyp. clear hyp. @@ -578,9 +578,9 @@ Proof. Qed. Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'), - lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt) (x,e) m -> lelistA (@ltk elt') (x,e') (map f m). -Proof. +Proof. induction m; simpl; auto. intros. destruct a as (x0,e0). @@ -589,30 +589,30 @@ Qed. Hint Resolve map_lelistA. -Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), +Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), sort (@ltk elt') (map f m). -Proof. +Proof. induction m; simpl; auto. intros. destruct a as (x',e'). inversion_clear Hm. constructor; auto. exact (map_lelistA _ _ H0). -Qed. - +Qed. + (** Specification of [mapi] *) -Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> +Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros m x e f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. - + destruct a as (x',e'). - simpl. + simpl. inversion_clear 1. exists x'. destruct H0; simpl in *. @@ -621,18 +621,18 @@ Proof. unfold eqke in *; simpl in *; intuition congruence. destruct IHm as (y, hyp); auto. exists y; intuition. -Qed. +Qed. -Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), +Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. - intros m x f. + intros m x f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. - + destruct a as (x',e). intros hyp. inversion hyp. clear hyp. @@ -646,9 +646,9 @@ Proof. Qed. Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'), - lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt) (x,e) m -> lelistA (@ltk elt') (x,f x e) (mapi f m). -Proof. +Proof. induction m; simpl; auto. intros. destruct a as (x',e'). @@ -657,7 +657,7 @@ Qed. Hint Resolve mapi_lelistA. -Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), +Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), sort (@ltk elt') (mapi f m). Proof. induction m; simpl; auto. @@ -666,7 +666,7 @@ Proof. inversion_clear Hm; auto. Qed. -End Elt2. +End Elt2. Section Elt3. (** * [map2] *) @@ -674,27 +674,27 @@ Section Elt3. Variable elt elt' elt'' : Type. Variable f : option elt -> option elt' -> option elt''. -Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := - match o with +Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := + match o with | Some e => (k,e)::l | None => l end. -Fixpoint map2_l (m : t elt) : t elt'' := - match m with - | nil => nil +Fixpoint map2_l (m : t elt) : t elt'' := + match m with + | nil => nil | (k,e)::l => option_cons k (f (Some e) None) (map2_l l) - end. + end. -Fixpoint map2_r (m' : t elt') : t elt'' := - match m' with - | nil => nil +Fixpoint map2_r (m' : t elt') : t elt'' := + match m' with + | nil => nil | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l') - end. + end. Fixpoint map2 (m : t elt) : t elt' -> t elt'' := match m with - | nil => map2_r + | nil => map2_r | (k,e) :: l => fix map2_aux (m' : t elt') : t elt'' := match m' with @@ -706,7 +706,7 @@ Fixpoint map2 (m : t elt) : t elt' -> t elt'' := | GT _ => option_cons k' (f None (Some e')) (map2_aux l') end end - end. + end. Notation oee' := (option elt * option elt')%type. @@ -724,14 +724,14 @@ Fixpoint combine (m : t elt) : t elt' -> t oee' := | GT _ => (k',(None,Some e'))::combine_aux l' end end - end. + end. -Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := +Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := List.fold_right (fun p => f (fst p) (snd p)) i l. -Definition map2_alt m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in +Definition map2_alt m m' := + let m0 : t oee' := combine m m' in + let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in fold_right_pair (option_cons (A:=elt'')) m1 nil. Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'. @@ -758,20 +758,20 @@ Proof. apply IHm'. Qed. -Lemma combine_lelistA : - forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), - lelistA (@ltk elt) (x,e) m -> - lelistA (@ltk elt') (x,e') m' -> +Lemma combine_lelistA : + forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), + lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt') (x,e') m' -> lelistA (@ltk oee') (x,e'') (combine m m'). Proof. - induction m. + induction m. intros. simpl. exact (map_lelistA _ _ H0). - induction m'. + induction m'. intros. destruct a. - replace (combine ((t0, e0) :: m) nil) with + replace (combine ((t0, e0) :: m) nil) with (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. exact (map_lelistA _ _ H). intros. @@ -784,18 +784,18 @@ Proof. Qed. Hint Resolve combine_lelistA. -Lemma combine_sorted : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), +Lemma combine_sorted : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), sort (@ltk oee') (combine m m'). Proof. - induction m. + induction m. intros; clear Hm. simpl. apply map_sorted; auto. - induction m'. + induction m'. intros; clear Hm'. destruct a. - replace (combine ((t0, e) :: m) nil) with + replace (combine ((t0, e) :: m) nil) with (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. apply map_sorted; auto. intros. @@ -805,11 +805,11 @@ Proof. inversion_clear Hm. constructor; auto. assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto. - exact (combine_lelistA _ H0 H1). + exact (combine_lelistA _ H0 H1). inversion_clear Hm; inversion_clear Hm'. constructor; auto. assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto). - exact (combine_lelistA _ H0 H3). + exact (combine_lelistA _ H0 H3). inversion_clear Hm; inversion_clear Hm'. constructor; auto. change (lelistA (ltk (elt:=oee')) (k', (None, Some e')) @@ -818,8 +818,8 @@ Proof. exact (combine_lelistA _ H3 H2). Qed. -Lemma map2_sorted : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), +Lemma map2_sorted : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), sort (@ltk elt'') (map2 m m'). Proof. intros. @@ -829,7 +829,7 @@ Proof. set (l0:=combine m m') in *; clearbody l0. set (f':= fun p : oee' => f (fst p) (snd p)). assert (H1:=map_sorted (elt' := option elt'') H0 f'). - set (l1:=map f' l0) in *; clearbody l1. + set (l1:=map f' l0) in *; clearbody l1. clear f' f H0 l0 Hm Hm' m m'. induction l1. simpl; auto. @@ -848,16 +848,16 @@ Proof. apply IHl1; auto. apply Inf_lt with (t1, None (A:=elt'')); auto. Qed. - -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None + +Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None | _, _ => Some (o,o') end. -Lemma combine_1 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), - find x (combine m m') = at_least_one (find x m) (find x m'). +Lemma combine_1 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), + find x (combine m m') = at_least_one (find x m) (find x m'). Proof. induction m. intros. @@ -881,32 +881,32 @@ Proof. destruct a as (k,e); destruct a0 as (k',e'); simpl. inversion Hm; inversion Hm'; subst. destruct (X.compare k k'); simpl; - destruct (X.compare x k); + destruct (X.compare x k); elim_comp || destruct (X.compare x k'); simpl; auto. rewrite IHm; auto; simpl; elim_comp; auto. rewrite IHm; auto; simpl; elim_comp; auto. rewrite IHm; auto; simpl; elim_comp; auto. change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). - rewrite IHm'; auto. + rewrite IHm'; auto. simpl find; elim_comp; auto. change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). - rewrite IHm'; auto. + rewrite IHm'; auto. simpl find; elim_comp; auto. - change (find x (combine ((k, e) :: m) m') = + change (find x (combine ((k, e) :: m) m') = at_least_one (find x m) (find x m')). - rewrite IHm'; auto. + rewrite IHm'; auto. simpl find; elim_comp; auto. Qed. -Definition at_least_one_then_f (o:option elt)(o':option elt') := - match o, o' with - | None, None => None +Definition at_least_one_then_f (o:option elt)(o':option elt') := + match o, o' with + | None, None => None | _, _ => f o o' end. -Lemma map2_0 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), - find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). +Lemma map2_0 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), + find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). Proof. intros. rewrite <- map2_alt_equiv. @@ -915,7 +915,7 @@ Proof. assert (H2:=combine_sorted Hm Hm'). set (f':= fun p : oee' => f (fst p) (snd p)). set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. + set (o:=find x m) in *; clearbody o. set (o':=find x m') in *; clearbody o'. clear Hm Hm' m m'. generalize H; clear H. @@ -984,10 +984,10 @@ Qed. (** Specification of [map2] *) -Lemma map2_1 : +Lemma map2_1 : forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), - In x m \/ In x m' -> - find x (map2 m m') = f (find x m) (find x m'). + In x m \/ In x m' -> + find x (map2 m m') = f (find x m) (find x m'). Proof. intros. rewrite map2_0; auto. @@ -997,10 +997,10 @@ Proof. rewrite (find_1 Hm' H). destruct (find x m); simpl; auto. Qed. - -Lemma map2_2 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), - In x (map2 m m') -> In x m \/ In x m'. + +Lemma map2_2 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), + In x (map2 m m') -> In x m \/ In x m'. Proof. intros. destruct H as (e,H). @@ -1008,9 +1008,9 @@ Proof. rewrite (find_1 (map2_sorted Hm Hm') H). generalize (@find_2 _ m x). generalize (@find_2 _ m' x). - destruct (find x m); + destruct (find x m); destruct (find x m'); simpl; intros. - left; exists e0; auto. + left; exists e0; auto. left; exists e0; auto. right; exists e0; auto. discriminate. @@ -1020,31 +1020,31 @@ End Elt3. End Raw. Module Make (X: OrderedType) <: S with Module E := X. -Module Raw := Raw X. +Module Raw := Raw X. Module E := X. Definition key := E.t. -Record slist (elt:Type) := +Record slist (elt:Type) := {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. -Definition t (elt:Type) : Type := slist elt. +Definition t (elt:Type) : Type := slist elt. -Section Elt. - Variable elt elt' elt'':Type. +Section Elt. + Variable elt elt' elt'':Type. Implicit Types m : t elt. - Implicit Types x y : key. + Implicit Types x y : key. Implicit Types e : elt. Definition empty : t elt := Build_slist (Raw.empty_sorted elt). Definition is_empty m : bool := Raw.is_empty m.(this). Definition add x e m : t elt := Build_slist (Raw.add_sorted m.(sorted) x e). Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x). + Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x). Definition mem x m : bool := Raw.mem x m.(this). Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f). Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f). - Definition map2 f m (m':t elt') : t elt'' := + Definition map2 f m (m':t elt') : t elt'' := Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)). Definition elements m : list (key*elt) := @Raw.elements elt m.(this). Definition cardinal m := length m.(this). @@ -1056,9 +1056,9 @@ Section Elt. Definition Empty m : Prop := Raw.Empty m.(this). Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. @@ -1095,7 +1095,7 @@ Section Elt. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(sorted)). Qed. - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(sorted)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. @@ -1104,9 +1104,9 @@ Section Elt. Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. - Lemma elements_3 : forall m, sort lt_key (elements m). + Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(sorted)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(sorted)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). @@ -1116,22 +1116,22 @@ Section Elt. fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. - Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. + Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. End Elt. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) @@ -1139,58 +1139,58 @@ Section Elt. Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - intros elt elt' elt'' m m' x f; + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. + intros elt elt' elt'' m m' x f; exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - Proof. - intros elt elt' elt'' m m' x f; + Proof. + intros elt elt' elt'' m m' x f; exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). Qed. End Make. -Module Make_ord (X: OrderedType)(D : OrderedType) <: -Sord with Module Data := D +Module Make_ord (X: OrderedType)(D : OrderedType) <: +Sord with Module Data := D with Module MapS.E := X. Module Data := D. -Module MapS := Make(X). +Module MapS := Make(X). Import MapS. Module MD := OrderedTypeFacts(D). Import MD. -Definition t := MapS.t D.t. +Definition t := MapS.t D.t. Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. -Fixpoint eq_list (m m' : list (X.t * D.t)) { struct m } : Prop := - match m, m' with +Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop := + match m, m' with | nil, nil => True - | (x,e)::l, (x',e')::l' => - match X.compare x x' with + | (x,e)::l, (x',e')::l' => + match X.compare x x' with | EQ _ => D.eq e e' /\ eq_list l l' | _ => False - end + end | _, _ => False end. Definition eq m m' := eq_list m.(this) m'.(this). -Fixpoint lt_list (m m' : list (X.t * D.t)) {struct m} : Prop := - match m, m' with +Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := + match m, m' with | nil, nil => False | nil, _ => True | _, nil => False - | (x,e)::l, (x',e')::l' => - match X.compare x x' with + | (x,e)::l, (x',e')::l' => + match X.compare x x' with | LT _ => True | GT _ => False | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l') @@ -1209,9 +1209,9 @@ Proof. destruct a; unfold equal; simpl; intuition. destruct a as (x,e). destruct p as (x',e'). - unfold equal; simpl. + unfold equal; simpl. destruct (X.compare x x'); simpl; intuition. - unfold cmp at 1. + unfold cmp at 1. MD.elim_comp; clear H; simpl. inversion_clear Hl. inversion_clear Hl'. @@ -1258,7 +1258,7 @@ Qed. Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. Proof. - intros (m,Hm); induction m; + 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. @@ -1267,17 +1267,16 @@ Proof. Qed. Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold eq; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold eq; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare x x'); - destruct (X.compare x' x''); - MapS.Raw.MX.elim_comp. - intuition. + destruct (X.compare x x'); + destruct (X.compare x' x''); + MapS.Raw.MX.elim_comp; intuition. apply D.eq_trans with e'; auto. inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition. @@ -1285,16 +1284,15 @@ Qed. Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold lt; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold lt; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare x x'); - destruct (X.compare x' x''); - MapS.Raw.MX.elim_comp; auto. - intuition. + destruct (X.compare x x'); + destruct (X.compare x' x''); + MapS.Raw.MX.elim_comp; intuition. left; apply D.lt_trans with e'; auto. left; apply lt_eq with e'; auto. left; apply eq_lt with e'; auto. @@ -1307,9 +1305,9 @@ Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; - try destruct a as (x,e); + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; + try destruct a as (x,e); try destruct p as (x',e'); try contradiction; auto. destruct (X.compare x x'); auto. intuition. @@ -1322,20 +1320,20 @@ Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto. Definition compare : forall m1 m2, Compare lt eq m1 m2. Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; [ apply EQ | apply LT | apply GT | ]; cmp_solve. - destruct a as (x,e); destruct p as (x',e'). - destruct (X.compare x x'); + destruct a as (x,e); destruct p as (x',e'). + destruct (X.compare x x'); [ apply LT | | apply GT ]; cmp_solve. - destruct (D.compare e e'); + destruct (D.compare e e'); [ apply LT | | apply GT ]; cmp_solve. assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1). inversion_clear Hm1; auto. assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2). inversion_clear Hm2; auto. - destruct (IHm1 Hm11 (Build_slist Hm22)); + destruct (IHm1 Hm11 (Build_slist Hm22)); [ apply LT | apply EQ | apply GT ]; cmp_solve. Qed. -End Make_ord. +End Make_ord. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 7fbc3d47..7c5a4fa1 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -6,131 +6,36 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre - * Institution: LRI, CNRS UMR 8623 - Université Paris Sud - * 91405 Orsay, France *) +(* $Id$ *) -(* $Id: FMapPositive.v 11699 2008-12-18 11:49:08Z letouzey $ *) +(** * FMapPositive : an implementation of FMapInterface for [positive] keys. *) -Require Import Bool. -Require Import ZArith. -Require Import OrderedType. -Require Import OrderedTypeEx. -Require Import FMapInterface. +Require Import Bool ZArith OrderedType OrderedTypeEx FMapInterface. Set Implicit Arguments. - Open Local Scope positive_scope. -(** * An implementation of [FMapInterface.S] for positive keys. *) +Local Unset Elimination Schemes. +Local Unset Case Analysis Schemes. -(** This file is an adaptation to the [FMap] framework of a work by +(** This file is an adaptation to the [FMap] framework of a work by Xavier Leroy and Sandrine Blazy (used for building certified compilers). - Keys are of type [positive], and maps are binary trees: the sequence + Keys are of type [positive], and maps are binary trees: the sequence of binary digits of a positive number corresponds to a path in such a tree. - This is quite similar to the [IntMap] library, except that no path compression - is implemented, and that the current file is simple enough to be + This is quite similar to the [IntMap] library, except that no path + compression is implemented, and that the current file is simple enough to be self-contained. *) -(** Even if [positive] can be seen as an ordered type with respect to the - usual order (see [OrderedTypeEx]), we use here a lexicographic order - over bits, which is more natural here (lower bits are considered first). *) - -Module PositiveOrderedTypeBits <: UsualOrderedType. - Definition t:=positive. - Definition eq:=@eq positive. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - - Fixpoint bits_lt (p q:positive) { struct p } : Prop := - match p, q with - | xH, xI _ => True - | xH, _ => False - | xO p, xO q => bits_lt p q - | xO _, _ => True - | xI p, xI q => bits_lt p q - | xI _, _ => False - end. - - Definition lt:=bits_lt. - - Lemma bits_lt_trans : forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z. - Proof. - induction x. - induction y; destruct z; simpl; eauto; intuition. - induction y; destruct z; simpl; eauto; intuition. - induction y; destruct z; simpl; eauto; intuition. - Qed. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. - exact bits_lt_trans. - Qed. - - Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x. - Proof. - induction x; simpl; auto. - Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros; intro. - rewrite <- H0 in H; clear H0 y. - unfold lt in H. - exact (bits_lt_antirefl x H). - Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - Proof. - induction x; destruct y. - (* I I *) - destruct (IHx y). - apply LT; auto. - apply EQ; rewrite e; red; auto. - apply GT; auto. - (* I O *) - apply GT; simpl; auto. - (* I H *) - apply GT; simpl; auto. - (* O I *) - apply LT; simpl; auto. - (* O O *) - destruct (IHx y). - apply LT; auto. - apply EQ; rewrite e; red; auto. - apply GT; auto. - (* O H *) - apply LT; simpl; auto. - (* H I *) - apply LT; simpl; auto. - (* H O *) - apply GT; simpl; auto. - (* H H *) - apply EQ; red; auto. - Qed. - - Lemma eq_dec (x y: positive): {x = y} + {x <> y}. - Proof. - intros. case_eq ((x ?= y) Eq); intros. - left. apply Pcompare_Eq_eq; auto. - right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate. - right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate. - Qed. +(** First, some stuff about [positive] *) -End PositiveOrderedTypeBits. - -(** Other positive stuff *) - -Fixpoint append (i j : positive) {struct i} : positive := +Fixpoint append (i j : positive) : positive := match i with | xH => j | xI ii => xI (append ii j) | xO ii => xO (append ii j) end. -Lemma append_assoc_0 : +Lemma append_assoc_0 : forall (i j : positive), append i (xO j) = append (append i (xO xH)) j. Proof. induction i; intros; destruct j; simpl; @@ -140,7 +45,7 @@ Proof. auto. Qed. -Lemma append_assoc_1 : +Lemma append_assoc_1 : forall (i j : positive), append i (xI j) = append (append i (xI xH)) j. Proof. induction i; intros; destruct j; simpl; @@ -159,7 +64,7 @@ Lemma append_neutral_l : forall (i : positive), append xH i = i. Proof. simpl; auto. Qed. - + (** The module of maps over positive keys *) @@ -174,6 +79,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | Leaf : tree A | Node : tree A -> option A -> tree A -> tree A. + Scheme tree_ind := Induction for tree Sort Prop. + Definition t := tree. Section A. @@ -182,15 +89,15 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Implicit Arguments Leaf [A]. Definition empty : t A := Leaf. - - Fixpoint is_empty (m : t A) {struct m} : bool := - match m with + + Fixpoint is_empty (m : t A) : bool := + match m with | Leaf => true | Node l None r => (is_empty l) && (is_empty r) | _ => false end. - Fixpoint find (i : positive) (m : t A) {struct i} : option A := + Fixpoint find (i : positive) (m : t A) : option A := match m with | Leaf => None | Node l o r => @@ -201,7 +108,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint mem (i : positive) (m : t A) {struct i} : bool := + Fixpoint mem (i : positive) (m : t A) : bool := match m with | Leaf => false | Node l o r => @@ -212,7 +119,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint add (i : positive) (v : A) (m : t A) {struct i} : t A := + Fixpoint add (i : positive) (v : A) (m : t A) : t A := match m with | Leaf => match i with @@ -228,7 +135,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint remove (i : positive) (m : t A) {struct i} : t A := + Fixpoint remove (i : positive) (m : t A) : t A := match i with | xH => match m with @@ -260,8 +167,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. (** [elements] *) - Fixpoint xelements (m : t A) (i : positive) {struct m} - : list (positive * A) := + Fixpoint xelements (m : t A) (i : positive) : list (positive * A) := match m with | Leaf => nil | Node l None r => @@ -279,8 +185,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. (** [cardinal] *) Fixpoint cardinal (m : t A) : nat := - match m with - | Leaf => 0%nat + match m with + | Leaf => 0%nat | Node l None r => (cardinal l + cardinal r)%nat | Node l (Some _) r => S (cardinal l + cardinal r) end. @@ -387,7 +293,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. exact (xelements_correct m i xH H). Qed. - Fixpoint xfind (i j : positive) (m : t A) {struct j} : option A := + Fixpoint xfind (i j : positive) (m : t A) : option A := match i, j with | _, xH => find i m | xO ii, xO jj => xfind ii jj m @@ -400,7 +306,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v. Proof. induction j; intros; destruct i; simpl; simpl in H; auto; try congruence. - destruct i; congruence. + destruct i; simpl in *; auto. Qed. Lemma xelements_ii : @@ -565,7 +471,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. exact (xelements_complete i xH m v H). Qed. - Lemma cardinal_1 : + Lemma cardinal_1 : forall (m: t A), cardinal m = length (elements m). Proof. unfold elements. @@ -584,13 +490,17 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Definition Empty m := forall (a : positive)(e:A) , ~ MapsTo a e m. Definition eq_key (p p':positive*A) := E.eq (fst p) (fst p'). - - Definition eq_key_elt (p p':positive*A) := + + Definition eq_key_elt (p p':positive*A) := E.eq (fst p) (fst p') /\ (snd p) = (snd p'). Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p'). - Lemma mem_find : + Global Instance eqk_equiv : Equivalence eq_key. + Global Instance eqke_equiv : Equivalence eq_key_elt. + Global Instance ltk_strorder : StrictOrder lt_key. + + Lemma mem_find : forall m x, mem x m = match find x m with None => false | _ => true end. Proof. induction m; destruct x; simpl; auto. @@ -625,7 +535,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl; generalize H0; rewrite Empty_alt; auto. Qed. - Section FMapSpec. + Section FMapSpec. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. @@ -633,7 +543,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. destruct 1 as (e0,H0); rewrite H0; auto. Qed. - Lemma mem_2 : forall m x, mem x m = true -> In x m. + Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. unfold In, MapsTo; intros m x; rewrite mem_find. destruct (find x m). @@ -659,7 +569,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. rewrite Empty_alt; apply gempty. Qed. - Lemma is_empty_1 : Empty m -> is_empty m = true. + Lemma is_empty_1 : Empty m -> is_empty m = true. Proof. induction m; simpl; auto. rewrite Empty_Node. @@ -699,10 +609,11 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma remove_1 : E.eq x y -> ~ In y (remove x m). - Proof. + Proof. intros; intro. generalize (mem_1 H0). rewrite mem_find. + red in H. rewrite H. rewrite grs. intros; discriminate. @@ -715,15 +626,15 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. - Proof. + Proof. unfold MapsTo. destruct (E.eq_dec x y). subst. rewrite grs; intros; discriminate. rewrite gro; auto. Qed. - - Lemma elements_1 : + + Lemma elements_1 : MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. unfold MapsTo. @@ -735,7 +646,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. apply elements_correct; auto. Qed. - Lemma elements_2 : + Lemma elements_2 : InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. unfold MapsTo. @@ -745,7 +656,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. apply elements_complete; auto. Qed. - Lemma xelements_bits_lt_1 : forall p p0 q m v, + Lemma xelements_bits_lt_1 : forall p p0 q m v, List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p. Proof. intros. @@ -754,7 +665,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. induction p; destruct p0; simpl; intros; eauto; try discriminate. Qed. - Lemma xelements_bits_lt_2 : forall p p0 q m v, + Lemma xelements_bits_lt_2 : forall p p0 q m v, List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0. Proof. intros. @@ -769,8 +680,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl; auto. destruct o; simpl; intros. (* Some *) - apply (SortA_app (eqA:=eq_key_elt)); auto. - compute; intuition. + apply (SortA_app (eqA:=eq_key_elt)); auto with *. constructor; auto. apply In_InfA; intros. destruct y0. @@ -789,8 +699,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. eapply xelements_bits_lt_1; eauto. eapply xelements_bits_lt_2; eauto. (* None *) - apply (SortA_app (eqA:=eq_key_elt)); auto. - compute; intuition. + apply (SortA_app (eqA:=eq_key_elt)); auto with *. intros x0 y0. do 2 rewrite InA_alt. intros (y1,(Hy1,H)) (y2,(Hy2,H0)). @@ -802,7 +711,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. eapply xelements_bits_lt_2; eauto. Qed. - Lemma elements_3 : sort lt_key (elements m). + Lemma elements_3 : sort lt_key (elements m). Proof. unfold elements. apply xelements_sort; auto. @@ -817,14 +726,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End FMapSpec. (** [map] and [mapi] *) - + Variable B : Type. Section Mapi. Variable f : positive -> A -> B. - Fixpoint xmapi (m : t A) (i : positive) {struct m} : t B := + Fixpoint xmapi (m : t A) (i : positive) : t B := match m with | Leaf => @Leaf B | Node l o r => Node (xmapi l (append i (xO xH))) @@ -861,9 +770,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. rewrite append_neutral_l; auto. Qed. - Lemma mapi_1 : - forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> + Lemma mapi_1 : + forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros. @@ -876,8 +785,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl; auto. Qed. - Lemma mapi_2 : - forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'), + Lemma mapi_2 : + forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros. @@ -890,14 +799,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl in *; discriminate. Qed. - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros; unfold map. destruct (mapi_1 (fun _ => f) H); intuition. Qed. - - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros; unfold map in *; eapply mapi_2; eauto. @@ -906,10 +815,10 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section map2. Variable A B C : Type. Variable f : option A -> option B -> option C. - + Implicit Arguments Leaf [A]. - Fixpoint xmap2_l (m : t A) {struct m} : t C := + Fixpoint xmap2_l (m : t A) : t C := match m with | Leaf => Leaf | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r) @@ -921,7 +830,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. induction i; intros; destruct m; simpl; auto. Qed. - Fixpoint xmap2_r (m : t B) {struct m} : t C := + Fixpoint xmap2_r (m : t B) : t C := match m with | Leaf => Leaf | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r) @@ -933,7 +842,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. induction i; intros; destruct m; simpl; auto. Qed. - Fixpoint _map2 (m1 : t A)(m2 : t B) {struct m1} : t C := + Fixpoint _map2 (m1 : t A)(m2 : t B) : t C := match m1 with | Leaf => xmap2_r m2 | Node l1 o1 r1 => @@ -953,14 +862,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End map2. - Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') := + Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') := _map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end). Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. intros. unfold map2. rewrite gmap2; auto. @@ -973,7 +882,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. intros. @@ -1031,12 +940,12 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. rewrite xfoldi_1; reflexivity. Qed. - Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool := - match m1, m2 with + Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool := + match m1, m2 with | Leaf, _ => is_empty m2 | _, Leaf => is_empty m1 - | Node l1 o1 r1, Node l2 o2 r2 => - (match o1, o2 with + | Node l1 o1 r1, Node l2 o2 r2 => + (match o1, o2 with | None, None => true | Some v1, Some v2 => cmp v1 v2 | _, _ => false @@ -1044,19 +953,19 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. && equal cmp l1 l2 && equal cmp r1 r2 end. - Definition Equal (A:Type)(m m':t A) := + Definition Equal (A:Type)(m m':t A) := forall y, find y m = find y m'. - Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp). - Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), - Equivb cmp m m' -> equal cmp m m' = true. - Proof. + Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), + Equivb cmp m m' -> equal cmp m m' = true. + Proof. induction m. (* m = Leaf *) - destruct 1. + destruct 1. simpl. apply is_empty_1. red; red; intros. @@ -1068,7 +977,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. (* m = Node *) destruct m'. (* m' = Leaf *) - destruct 1. + destruct 1. simpl. destruct o. assert (In xH (Leaf A)). @@ -1105,9 +1014,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. apply andb_true_intro; split; auto. Qed. - Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), - equal cmp m m' = true -> Equivb cmp m m'. - Proof. + Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), + equal cmp m m' = true -> Equivb cmp m m'. + Proof. induction m. (* m = Leaf *) simpl. @@ -1181,7 +1090,7 @@ Module PositiveMapAdditionalFacts. rewrite (IHi m2 v H); congruence. rewrite (IHi m1 v H); congruence. Qed. - + Lemma xmap2_lr : forall (A B : Type)(f g: option A -> option A -> option B)(m : t A), (forall (i j : option A), f i j = g j i) -> @@ -1209,7 +1118,7 @@ Module PositiveMapAdditionalFacts. auto. rewrite IHm1_1. rewrite IHm1_2. - auto. + auto. Qed. End PositiveMapAdditionalFacts. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index be09e41a..38ed172b 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapWeakList.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id$ *) -(** * Finite map library *) +(** * Finite map library *) (** This file proposes an implementation of the non-dependant interface [FMapInterface.WS] using lists of pairs, unordered but without redundancy. *) @@ -29,7 +29,7 @@ Section Elt. Variable elt : Type. -Notation eqk := (eqk (elt:=elt)). +Notation eqk := (eqk (elt:=elt)). Notation eqke := (eqke (elt:=elt)). Notation MapsTo := (MapsTo (elt:=elt)). Notation In := (In (elt:=elt)). @@ -52,7 +52,7 @@ Qed. Hint Resolve empty_1. Lemma empty_NoDup : NoDupA empty. -Proof. +Proof. unfold empty; auto. Qed. @@ -60,7 +60,7 @@ Qed. Definition is_empty (l : t elt) : bool := if l then true else false. -Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. +Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. Proof. unfold Empty, PX.MapsTo. intros m. @@ -88,7 +88,7 @@ Function mem (k : key) (s : t elt) {struct s} : bool := Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true. Proof. - intros m Hm x; generalize Hm; clear Hm. + intros m Hm x; generalize Hm; clear Hm. functional induction (mem x m);intros NoDup belong1;trivial. inversion belong1. inversion H. inversion_clear NoDup. @@ -98,13 +98,13 @@ Proof. contradiction. apply IHb; auto. exists x0; auto. -Qed. +Qed. -Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. +Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. Proof. intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. functional induction (mem x m); intros NoDup hyp; try discriminate. - exists _x; auto. + exists _x; auto. inversion_clear NoDup. destruct IHb; auto. exists x0; auto. @@ -124,8 +124,8 @@ Proof. functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto. Qed. -Lemma find_1 : forall m (Hm:NoDupA m) x e, - MapsTo x e m -> find x m = Some e. +Lemma find_1 : forall m (Hm:NoDupA m) x e, + MapsTo x e m -> find x m = Some e. Proof. intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (find x m);simpl; subst; try clear H_eq_1. @@ -142,7 +142,7 @@ Qed. (* Not part of the exported specifications, used later for [combine]. *) -Lemma find_eq : forall m (Hm:NoDupA m) x x', +Lemma find_eq : forall m (Hm:NoDupA m) x x', X.eq x x' -> find x m = find x' m. Proof. induction m; simpl; auto; destruct a; intros. @@ -167,7 +167,7 @@ Proof. functional induction (add x e m);simpl;auto. Qed. -Lemma add_2 : forall m x y e e', +Lemma add_2 : forall m x y e e', ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m x y e e'; generalize y e; clear y e; unfold PX.MapsTo. @@ -178,7 +178,7 @@ Proof. auto. intros y' e'' eqky'; inversion_clear 1; intuition. Qed. - + Lemma add_3 : forall m x y e e', ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. @@ -189,14 +189,14 @@ Proof. inversion_clear 2; auto. Qed. -Lemma add_3' : forall m x y e e', - ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. +Lemma add_3' : forall m x y e e', + ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. Proof. intros m x y e e'. generalize y e; clear y e. functional induction (add x e' m);simpl;auto. inversion_clear 2. compute in H1; elim H; auto. - inversion H1. + inversion H1. constructor 2; inversion_clear H0; auto. compute in H1; elim H; auto. inversion_clear 2; auto. @@ -218,7 +218,7 @@ Qed. (* Not part of the exported specifications, used later for [combine]. *) -Lemma add_eq : forall m (Hm:NoDupA m) x a e, +Lemma add_eq : forall m (Hm:NoDupA m) x a e, X.eq x a -> find x (add a e m) = Some e. Proof. intros. @@ -227,7 +227,7 @@ Proof. apply add_1; auto. Qed. -Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, +Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, ~X.eq x a -> find x (add a e m) = find x m. Proof. intros. @@ -250,7 +250,7 @@ Function remove (k : key) (s : t elt) {struct s} : t elt := match s with | nil => nil | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l - end. + end. Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m). Proof. @@ -265,7 +265,7 @@ Proof. destruct H0 as (e,H2); unfold PX.MapsTo in H2. apply InA_eqk with (y,e); auto. compute; apply X.eq_trans with x; auto. - + intro H2. destruct H2 as (e,H2); inversion_clear H2. compute in H0; destruct H0. @@ -274,8 +274,8 @@ Proof. elim (IHt0 H2 H). exists e; auto. Qed. - -Lemma remove_2 : forall m (Hm:NoDupA m) x y e, + +Lemma remove_2 : forall m (Hm:NoDupA m) x y e, ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. @@ -283,11 +283,11 @@ Proof. inversion_clear 3; auto. compute in H1; destruct H1. elim H; apply X.eq_trans with k'; auto. - + inversion_clear 1; inversion_clear 2; auto. Qed. -Lemma remove_3 : forall m (Hm:NoDupA m) x y e, +Lemma remove_3 : forall m (Hm:NoDupA m) x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. @@ -295,7 +295,7 @@ Proof. do 2 inversion_clear 1; auto. Qed. -Lemma remove_3' : forall m (Hm:NoDupA m) x y e, +Lemma remove_3' : forall m (Hm:NoDupA m) x y e, InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. @@ -313,7 +313,7 @@ Proof. simpl; case (X.eq_dec x x'); auto. constructor; auto. contradict H; apply remove_3' with x; auto. -Qed. +Qed. (** * [elements] *) @@ -325,12 +325,12 @@ Proof. Qed. Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. -Proof. +Proof. auto. Qed. -Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). -Proof. +Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). +Proof. auto. Qed. @@ -344,34 +344,34 @@ Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} : A := Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. -Proof. +Proof. intros; functional induction (@fold A f m i); auto. Qed. (** * [equal] *) -Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := - match find k m' with +Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := + match find k m' with | None => false | Some e' => cmp e e' end. -Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := - fold (fun k e b => andb (check cmp k e m') b) m true. - +Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := + fold (fun k e b => andb (check cmp k e m') b) m true. + Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). -Definition Submap cmp m m' := - (forall k, In k m -> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). +Definition Submap cmp m m' := + (forall k, In k m -> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Definition Equivb cmp m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). +Definition Equivb cmp m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Submap cmp m m' -> submap cmp m m' = true. +Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + Submap cmp m m' -> submap cmp m m' = true. Proof. unfold Submap, submap. induction m. @@ -390,9 +390,9 @@ Proof. destruct H5 as (e'',H5); exists e''; auto. apply H0 with k; auto. Qed. - -Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - submap cmp m m' = true -> Submap cmp m m'. + +Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + submap cmp m m' = true -> Submap cmp m m'. Proof. unfold Submap, submap. induction m. @@ -400,7 +400,7 @@ Proof. intuition. destruct H0; inversion H0. inversion H0. - + destruct a; simpl; intros. inversion_clear Hm. rewrite andb_b_true in H. @@ -414,7 +414,7 @@ Proof. rewrite H2 in H. destruct (IHm H1 m' Hm' cmp H); auto. unfold check in H2. - case_eq (find t0 m'); [intros e' H5 | intros H5]; + case_eq (find t0 m'); [intros e' H5 | intros H5]; rewrite H5 in H2; try discriminate. split; intros. destruct H6 as (e0,H6); inversion_clear H6. @@ -432,15 +432,15 @@ Qed. (** Specification of [equal] *) -Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. +Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + Equivb cmp m m' -> equal cmp m m' = true. +Proof. unfold Equivb, equal. intuition. apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. Qed. -Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, +Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. unfold Equivb, equal. @@ -449,43 +449,43 @@ Proof. generalize (submap_2 Hm Hm' H0). generalize (submap_2 Hm' Hm H1). firstorder. -Qed. +Qed. Variable elt':Type. (** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' := + +Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := match m with | nil => nil | (k,e)::m' => (k,f e) :: map f m' end. -Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' := +Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := match m with | nil => nil | (k,e)::m' => (k,f k e) :: mapi f m' end. End Elt. -Section Elt2. -(* A new section is necessary for previous definitions to work +Section Elt2. +(* A new section is necessary for previous definitions to work with different [elt], especially [MapsTo]... *) - + Variable elt elt' : Type. (** Specification of [map] *) -Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), +Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros m x e f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. - + destruct a as (x',e'). - simpl. + simpl. inversion_clear 1. constructor 1. unfold eqke in *; simpl in *; intuition congruence. @@ -493,15 +493,15 @@ Proof. unfold MapsTo in *; auto. Qed. -Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), +Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. - intros m x f. + intros m x f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. - + destruct a as (x',e). intros hyp. inversion hyp. clear hyp. @@ -514,9 +514,9 @@ Proof. constructor 2; auto. Qed. -Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), +Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), NoDupA (@eqk elt') (map f m). -Proof. +Proof. induction m; simpl; auto. intros. destruct a as (x',e'). @@ -524,25 +524,25 @@ Proof. constructor; auto. contradict H. (* il faut un map_1 avec eqk au lieu de eqke *) - clear IHm H0. + clear IHm H0. induction m; simpl in *; auto. inversion H. destruct a; inversion H; auto. -Qed. - +Qed. + (** Specification of [mapi] *) -Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> +Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros m x e f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. - + destruct a as (x',e'). - simpl. + simpl. inversion_clear 1. exists x'. destruct H0; simpl in *. @@ -551,17 +551,17 @@ Proof. unfold eqke in *; simpl in *; intuition congruence. destruct IHm as (y, hyp); auto. exists y; intuition. -Qed. +Qed. -Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), +Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. - intros m x f. + intros m x f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. - + destruct a as (x',e). intros hyp. inversion hyp. clear hyp. @@ -574,7 +574,7 @@ Proof. constructor 2; auto. Qed. -Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), +Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), NoDupA (@eqk elt') (mapi f m). Proof. induction m; simpl; auto. @@ -589,30 +589,30 @@ Proof. destruct a; inversion_clear H; auto. Qed. -End Elt2. +End Elt2. Section Elt3. Variable elt elt' elt'' : Type. Notation oee' := (option elt * option elt')%type. - + Definition combine_l (m:t elt)(m':t elt') : t oee' := - mapi (fun k e => (Some e, find k m')) m. + mapi (fun k e => (Some e, find k m')) m. Definition combine_r (m:t elt)(m':t elt') : t oee' := - mapi (fun k e' => (find k m, Some e')) m'. + 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) := +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 combine (m:t elt)(m':t elt') : t oee' := - let l := combine_l m m' in - let r := combine_r m m' in +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. -Lemma fold_right_pair_NoDup : - forall l r (Hl: NoDupA (eqk (elt:=oee')) l) - (Hl: NoDupA (eqk (elt:=oee')) r), +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). Proof. induction l; simpl; auto. @@ -622,8 +622,8 @@ Proof. Qed. Hint Resolve fold_right_pair_NoDup. -Lemma combine_NoDup : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), +Lemma combine_NoDup : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), NoDupA (@eqk oee') (combine m m'). Proof. unfold combine, combine_r, combine_l. @@ -637,21 +637,21 @@ Proof. auto. Qed. -Definition at_least_left (o:option elt)(o':option elt') := - match o with - | None => None +Definition at_least_left (o:option elt)(o':option elt') := + match o with + | None => None | _ => Some (o,o') end. -Definition at_least_right (o:option elt)(o':option elt') := - match o' with - | None => None +Definition at_least_right (o:option elt)(o':option elt') := + match o' with + | None => None | _ => Some (o,o') end. -Lemma combine_l_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine_l m m') = at_least_left (find x m) (find x m'). +Lemma combine_l_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine_l m m') = at_least_left (find x m) (find x m'). Proof. unfold combine_l. intros. @@ -668,9 +668,9 @@ Proof. rewrite (find_1 Hm H1) in H; discriminate. Qed. -Lemma combine_r_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine_r m m') = at_least_right (find x m) (find x m'). +Lemma combine_r_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine_r m m') = at_least_right (find x m) (find x m'). Proof. unfold combine_r. intros. @@ -687,15 +687,15 @@ Proof. rewrite (find_1 Hm' H1) in H; discriminate. Qed. -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None +Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None | _, _ => Some (o,o') end. -Lemma combine_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine m m') = at_least_one (find x m) (find x m'). +Lemma combine_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine m m') = at_least_one (find x m) (find x m'). Proof. unfold combine. intros. @@ -726,19 +726,19 @@ Qed. Variable f : option elt -> option elt' -> option elt''. -Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := +Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := match o with | Some e => (k,e)::l | None => l end. -Definition map2 m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in +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. -Lemma map2_NoDup : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), +Lemma map2_NoDup : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), NoDupA (@eqk elt'') (map2 m m'). Proof. intros. @@ -747,7 +747,7 @@ Proof. set (l0:=combine m m') in *; clearbody l0. set (f':= fun p : oee' => f (fst p) (snd p)). assert (H1:=map_NoDup (elt' := option elt'') H0 f'). - set (l1:=map f' l0) in *; clearbody l1. + set (l1:=map f' l0) in *; clearbody l1. clear f' f H0 l0 Hm Hm' m m'. induction l1. simpl; auto. @@ -763,15 +763,15 @@ Proof. inversion_clear H; auto. Qed. -Definition at_least_one_then_f (o:option elt)(o':option elt') := - match o, o' with - | None, None => None +Definition at_least_one_then_f (o:option elt)(o':option elt') := + match o, o' with + | None, None => None | _, _ => f o o' end. -Lemma map2_0 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). +Lemma map2_0 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). Proof. intros. unfold map2. @@ -779,7 +779,7 @@ Proof. assert (H2:=combine_NoDup Hm Hm'). set (f':= fun p : oee' => f (fst p) (snd p)). set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. + set (o:=find x m) in *; clearbody o. set (o':=find x m') in *; clearbody o'. clear Hm Hm' m m'. generalize H; clear H. @@ -795,14 +795,14 @@ Proof. destruct o; destruct o'; simpl in *; inversion_clear H; auto. rewrite H2. unfold f'; simpl. - destruct (f oo oo'); simpl. + destruct (f oo oo'); simpl. destruct (X.eq_dec x k); try contradict n; auto. destruct (IHm0 H1) as (_,H4); apply H4; auto. case_eq (find x m0); intros; auto. elim H0. apply InA_eqk with (x,p); auto. apply InA_eqke_eqk. - exact (find_2 H3). + exact (find_2 H3). (* k < x *) unfold f'; simpl. destruct (f oo oo'); simpl. @@ -826,10 +826,10 @@ Proof. Qed. (** Specification of [map2] *) -Lemma map2_1 : +Lemma map2_1 : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - In x m \/ In x m' -> - find x (map2 m m') = f (find x m) (find x m'). + In x m \/ In x m' -> + find x (map2 m m') = f (find x m) (find x m'). Proof. intros. rewrite map2_0; auto. @@ -839,10 +839,10 @@ Proof. rewrite (find_1 Hm' H). destruct (find x m); simpl; auto. Qed. - -Lemma map2_2 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - In x (map2 m m') -> In x m \/ In x m'. + +Lemma map2_2 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + In x (map2 m m') -> In x m \/ In x m'. Proof. intros. destruct H as (e,H). @@ -850,9 +850,9 @@ Proof. rewrite (find_1 (map2_NoDup Hm Hm') H). generalize (@find_2 _ m x). generalize (@find_2 _ m' x). - destruct (find x m); + destruct (find x m); destruct (find x m'); simpl; intros. - left; exists e0; auto. + left; exists e0; auto. left; exists e0; auto. right; exists e0; auto. discriminate. @@ -863,31 +863,31 @@ End Raw. Module Make (X: DecidableType) <: WS with Module E:=X. - Module Raw := Raw X. + Module Raw := Raw X. Module E := X. - Definition key := E.t. + Definition key := E.t. - Record slist (elt:Type) := + Record slist (elt:Type) := {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. - Definition t (elt:Type) := slist elt. + Definition t (elt:Type) := slist elt. -Section Elt. - Variable elt elt' elt'':Type. +Section Elt. + Variable elt elt' elt'':Type. Implicit Types m : t elt. - Implicit Types x y : key. + Implicit Types x y : key. Implicit Types e : elt. Definition empty : t elt := Build_slist (Raw.empty_NoDup elt). Definition is_empty m : bool := Raw.is_empty m.(this). Definition add x e m : t elt := Build_slist (Raw.add_NoDup m.(NoDup) x e). Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x). + Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x). Definition mem x m : bool := Raw.mem x m.(this). Definition map f m : t elt' := Build_slist (Raw.map_NoDup m.(NoDup) f). Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup m.(NoDup) f). - Definition map2 f m (m':t elt') : t elt'' := + Definition map2 f m (m':t elt') : t elt'' := Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)). Definition elements m : list (key*elt) := @Raw.elements elt m.(this). Definition cardinal m := length m.(this). @@ -898,9 +898,9 @@ Section Elt. Definition Empty m : Prop := Raw.Empty m.(this). Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. @@ -936,7 +936,7 @@ Section Elt. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(NoDup)). Qed. - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(NoDup)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. @@ -945,32 +945,32 @@ Section Elt. Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(NoDup)). Qed. - - Lemma cardinal_1 : forall m, cardinal m = length (elements m). + + Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intros; reflexivity. Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. - Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. + Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. End Elt. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) @@ -978,18 +978,18 @@ Section Elt. Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - intros elt elt' elt'' m m' x f; + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. + intros elt elt' elt'' m m' x f; exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - Proof. - intros elt elt' elt'' m m' x f; + Proof. + intros elt elt' elt'' m m' x f; exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). Qed. diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v index 75904202..6b110240 100644 --- a/theories/FSets/FMaps.v +++ b/theories/FSets/FMaps.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMaps.v 10699 2008-03-19 20:56:43Z letouzey $ *) +(* $Id$ *) Require Export OrderedType OrderedTypeEx OrderedTypeAlt. diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v index cc1c0a76..bc6c731f 100644 --- a/theories/FSets/FSetAVL.v +++ b/theories/FSets/FSetAVL.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* X.t -> tree -> int -> tree. - -Notation t := tree. - -(** * Basic functions on trees: height and cardinal *) - -Definition height (s : tree) : int := - match s with - | Leaf => 0 - | Node _ _ _ h => h - end. - -Fixpoint cardinal (s : tree) : nat := - match s with - | Leaf => 0%nat - | Node l _ r _ => S (cardinal l + cardinal r) - end. - -(** * Empty Set *) - -Definition empty := Leaf. - -(** * Emptyness test *) - -Definition is_empty s := - match s with Leaf => true | _ => false end. - -(** * Appartness *) - -(** The [mem] function is deciding appartness. It exploits the - binary search tree invariant to achieve logarithmic complexity. *) - -Fixpoint mem x s := - match s with - | Leaf => false - | Node l y r _ => match X.compare x y with - | LT _ => mem x l - | EQ _ => true - | GT _ => mem x r - end - end. - -(** * Singleton set *) - -Definition singleton x := Node Leaf x Leaf 1. - -(** * Helper functions *) - -(** [create l x r] creates a node, assuming [l] and [r] - to be balanced and [|height l - height r| <= 2]. *) - -Definition create l x r := - Node l x r (max (height l) (height r) + 1). - -(** [bal l x r] acts as [create], but performs one step of - rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) - -Definition assert_false := create. - -Definition bal l x r := - let hl := height l in - let hr := height r in - if gt_le_dec hl (hr+2) then - match l with - | Leaf => assert_false l x r - | Node ll lx lr _ => - if ge_lt_dec (height ll) (height lr) then - create ll lx (create lr x r) - else - match lr with - | Leaf => assert_false l x r - | Node lrl lrx lrr _ => - create (create ll lx lrl) lrx (create lrr x r) - end - end - else - if gt_le_dec hr (hl+2) then - match r with - | Leaf => assert_false l x r - | Node rl rx rr _ => - if ge_lt_dec (height rr) (height rl) then - create (create l x rl) rx rr - else - match rl with - | Leaf => assert_false l x r - | Node rll rlx rlr _ => - create (create l x rll) rlx (create rlr rx rr) - end - end - else - create l x r. - -(** * Insertion *) - -Fixpoint add x s := match s with - | Leaf => Node Leaf x Leaf 1 - | Node l y r h => - match X.compare x y with - | LT _ => bal (add x l) y r - | EQ _ => Node l y r h - | GT _ => bal l y (add x r) - end - end. - -(** * Join - - Same as [bal] but does not assume anything regarding heights - of [l] and [r]. -*) - -Fixpoint join l : elt -> t -> t := - match l with - | Leaf => add - | Node ll lx lr lh => fun x => - fix join_aux (r:t) : t := match r with - | Leaf => add x l - | Node rl rx rr rh => - if gt_le_dec lh (rh+2) then bal ll lx (join lr x r) - else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr - else create l x r - end - end. - -(** * Extraction of minimum element - - Morally, [remove_min] is to be applied to a non-empty tree - [t = Node l x r h]. Since we can't deal here with [assert false] - for [t=Leaf], we pre-unpack [t] (and forget about [h]). -*) - -Fixpoint remove_min l x r : t*elt := - match l with - | Leaf => (r,x) - | Node ll lx lr lh => - let (l',m) := remove_min ll lx lr in (bal l' x r, m) - end. - -(** * Merging two trees - - [merge t1 t2] builds the union of [t1] and [t2] assuming all elements - of [t1] to be smaller than all elements of [t2], and - [|height t1 - height t2| <= 2]. -*) - -Definition merge s1 s2 := match s1,s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node l2 x2 r2 h2 => - let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2' -end. - -(** * Deletion *) - -Fixpoint remove x s := match s with - | Leaf => Leaf - | Node l y r h => - match X.compare x y with - | LT _ => bal (remove x l) y r - | EQ _ => merge l r - | GT _ => bal l y (remove x r) - end - end. - -(** * Minimum element *) - -Fixpoint min_elt s := match s with - | Leaf => None - | Node Leaf y _ _ => Some y - | Node l _ _ _ => min_elt l -end. - -(** * Maximum element *) - -Fixpoint max_elt s := match s with - | Leaf => None - | Node _ y Leaf _ => Some y - | Node _ _ r _ => max_elt r -end. - -(** * Any element *) - -Definition choose := min_elt. - -(** * Concatenation - - Same as [merge] but does not assume anything about heights. -*) - -Definition concat s1 s2 := - match s1, s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node l2 x2 r2 _ => - let (s2',m) := remove_min l2 x2 r2 in - join s1 m s2' - end. - -(** * Splitting - - [split x s] returns a triple [(l, present, r)] where - - [l] is the set of elements of [s] that are [< x] - - [r] is the set of elements of [s] that are [> x] - - [present] is [true] if and only if [s] contains [x]. -*) - -Record triple := mktriple { t_left:t; t_in:bool; t_right:t }. -Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). -Notation "t #l" := (t_left t) (at level 9, format "t '#l'"). -Notation "t #b" := (t_in t) (at level 9, format "t '#b'"). -Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). - -Fixpoint split x s : triple := match s with - | Leaf => << Leaf, false, Leaf >> - | Node l y r h => - match X.compare x y with - | LT _ => let (ll,b,rl) := split x l in << ll, b, join rl y r >> - | EQ _ => << l, true, r >> - | GT _ => let (rl,b,rr) := split x r in << join l y rl, b, rr >> - end - end. - -(** * Intersection *) - -Fixpoint inter s1 s2 := match s1, s2 with - | Leaf, _ => Leaf - | _, Leaf => Leaf - | Node l1 x1 r1 h1, _ => - let (l2',pres,r2') := split x1 s2 in - if pres then join (inter l1 l2') x1 (inter r1 r2') - else concat (inter l1 l2') (inter r1 r2') - end. - -(** * Difference *) - -Fixpoint diff s1 s2 := match s1, s2 with - | Leaf, _ => Leaf - | _, Leaf => s1 - | Node l1 x1 r1 h1, _ => - let (l2',pres,r2') := split x1 s2 in - if pres then concat (diff l1 l2') (diff r1 r2') - else join (diff l1 l2') x1 (diff r1 r2') -end. - -(** * Union *) - -(** In ocaml, heights of [s1] and [s2] are compared each time in order - to recursively perform the split on the smaller set. - Unfortunately, this leads to a non-structural algorithm. The - following code is a simplification of the ocaml version: no - comparison of heights. It might be slightly slower, but - experimentally all the tests I've made in ocaml have shown this - potential slowdown to be non-significant. Anyway, the exact code - of ocaml has also been formalized thanks to Function+measure, see - [ocaml_union] in [FSetFullAVL]. -*) - -Fixpoint union s1 s2 := - match s1, s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | Node l1 x1 r1 h1, _ => - let (l2',_,r2') := split x1 s2 in - join (union l1 l2') x1 (union r1 r2') - end. - -(** * Elements *) - -(** [elements_tree_aux acc t] catenates the elements of [t] in infix - order to the list [acc] *) - -Fixpoint elements_aux (acc : list X.t) (t : tree) : list X.t := - match t with - | Leaf => acc - | Node l x r _ => elements_aux (x :: elements_aux acc r) l - end. - -(** then [elements] is an instanciation with an empty [acc] *) - -Definition elements := elements_aux nil. - -(** * Filter *) - -Fixpoint filter_acc (f:elt->bool) acc s := match s with - | Leaf => acc - | Node l x r h => - filter_acc f (filter_acc f (if f x then add x acc else acc) l) r - end. - -Definition filter f := filter_acc f Leaf. - - -(** * Partition *) - -Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t := - match s with - | Leaf => acc - | Node l x r _ => - let (acct,accf) := acc in - partition_acc f - (partition_acc f - (if f x then (add x acct, accf) else (acct, add x accf)) l) r - end. - -Definition partition f := partition_acc f (Leaf,Leaf). - -(** * [for_all] and [exists] *) - -Fixpoint for_all (f:elt->bool) s := match s with - | Leaf => true - | Node l x r _ => f x &&& for_all f l &&& for_all f r -end. - -Fixpoint exists_ (f:elt->bool) s := match s with - | Leaf => false - | Node l x r _ => f x ||| exists_ f l ||| exists_ f r -end. - -(** * Fold *) - -Fixpoint fold (A : Type) (f : elt -> A -> A)(s : tree) : A -> A := - fun a => match s with - | Leaf => a - | Node l x r _ => fold f r (f x (fold f l a)) - end. -Implicit Arguments fold [A]. - - -(** * Subset *) - -(** In ocaml, recursive calls are made on "half-trees" such as - (Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these - non-structural calls, we propose here two specialized functions for - these situations. This version should be almost as efficient as - the one of ocaml (closures as arguments may slow things a bit), - it is simply less compact. The exact ocaml version has also been - formalized (thanks to Function+measure), see [ocaml_subset] in - [FSetFullAVL]. - *) - -Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool := - match s2 with - | Leaf => false - | Node l2 x2 r2 h2 => - match X.compare x1 x2 with - | EQ _ => subset_l1 l2 - | LT _ => subsetl subset_l1 x1 l2 - | GT _ => mem x1 r2 &&& subset_l1 s2 - end - end. - -Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool := - match s2 with - | Leaf => false - | Node l2 x2 r2 h2 => - match X.compare x1 x2 with - | EQ _ => subset_r1 r2 - | LT _ => mem x1 l2 &&& subset_r1 s2 - | GT _ => subsetr subset_r1 x1 r2 - end - end. - -Fixpoint subset s1 s2 : bool := match s1, s2 with - | Leaf, _ => true - | Node _ _ _ _, Leaf => false - | Node l1 x1 r1 h1, Node l2 x2 r2 h2 => - match X.compare x1 x2 with - | EQ _ => subset l1 l2 &&& subset r1 r2 - | LT _ => subsetl (subset l1) x1 l2 &&& subset r1 s2 - | GT _ => subsetr (subset r1) x1 r2 &&& subset l1 s2 - end - end. - -(** * A new comparison algorithm suggested by Xavier Leroy - - Transformation in C.P.S. suggested by Benjamin Grégoire. - The original ocaml code (with non-structural recursive calls) - has also been formalized (thanks to Function+measure), see - [ocaml_compare] in [FSetFullAVL]. The following code with - continuations computes dramatically faster in Coq, and - should be almost as efficient after extraction. -*) - -(** Enumeration of the elements of a tree *) - -Inductive enumeration := - | End : enumeration - | More : elt -> tree -> enumeration -> enumeration. - - -(** [cons t e] adds the elements of tree [t] on the head of - enumeration [e]. *) - -Fixpoint cons s e : enumeration := - match s with - | Leaf => e - | Node l x r h => cons l (More x r e) - end. - -(** One step of comparison of elements *) - -Definition compare_more x1 (cont:enumeration->comparison) e2 := - match e2 with - | End => Gt - | More x2 r2 e2 => - match X.compare x1 x2 with - | EQ _ => cont (cons r2 e2) - | LT _ => Lt - | GT _ => Gt - end - end. - -(** Comparison of left tree, middle element, then right tree *) - -Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := - match s1 with - | Leaf => cont e2 - | Node l1 x1 r1 _ => - compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2 - end. - -(** Initial continuation *) - -Definition compare_end e2 := - match e2 with End => Eq | _ => Lt end. - -(** The complete comparison *) - -Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End). - -(** * Equality test *) - -Definition equal s1 s2 : bool := - match compare s1 s2 with - | Eq => true - | _ => false - end. - - - - -(** * Invariants *) - -(** ** Occurrence in a tree *) - -Inductive In (x : elt) : tree -> Prop := - | IsRoot : forall l r h y, X.eq x y -> In x (Node l y r h) - | InLeft : forall l r h y, In x l -> In x (Node l y r h) - | InRight : forall l r h y, In x r -> In x (Node l y r h). - -(** ** Binary search trees *) - -(** [lt_tree x s]: all elements in [s] are smaller than [x] - (resp. greater for [gt_tree]) *) - -Definition lt_tree x s := forall y, In y s -> X.lt y x. -Definition gt_tree x s := forall y, In y s -> X.lt x y. - -(** [bst t] : [t] is a binary search tree *) - -Inductive bst : tree -> Prop := - | BSLeaf : bst Leaf - | BSNode : forall x l r h, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (Node l x r h). - - - - -(** * Some shortcuts *) - -Definition Equal s s' := forall a : elt, In a s <-> In a s'. -Definition Subset s s' := forall a : elt, In a s -> In a s'. -Definition Empty s := forall a : elt, ~ In a s. -Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. -Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - - -(** * Correctness proofs, isolated in a sub-module *) - -Module Proofs. - Module MX := OrderedTypeFacts X. - Module L := FSetList.Raw X. - -(** * Automation and dedicated tactics *) - -Hint Constructors In bst. -Hint Unfold lt_tree gt_tree. - -Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h) - "as" ident(s) := - set (s:=Node l x r h) in *; clearbody s; clear l x r h. - -(** A tactic to repeat [inversion_clear] on all hyps of the - form [(f (Node _ _ _ _))] *) - -Ltac inv f := - match goal with - | H:f Leaf |- _ => inversion_clear H; inv f - | H:f _ Leaf |- _ => inversion_clear H; inv f - | H:f (Node _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ (Node _ _ _ _) |- _ => inversion_clear H; inv f - | _ => idtac - end. - -Ltac intuition_in := repeat progress (intuition; inv In). - -(** Helper tactic concerning order of elements. *) - -Ltac order := match goal with - | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order - | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order - | _ => MX.order -end. - - -(** * Basic results about [In], [lt_tree], [gt_tree], [height] *) - -(** [In] is compatible with [X.eq] *) - -Lemma In_1 : - forall s x y, X.eq x y -> In x s -> In y s. -Proof. - induction s; simpl; intuition_in; eauto. -Qed. -Hint Immediate In_1. - -Lemma In_node_iff : - forall l x r h y, - In y (Node l x r h) <-> In y l \/ X.eq y x \/ In y r. -Proof. - intuition_in. -Qed. - -(** Results about [lt_tree] and [gt_tree] *) - -Lemma lt_leaf : forall x : elt, lt_tree x Leaf. -Proof. - red; inversion 1. -Qed. - -Lemma gt_leaf : forall x : elt, gt_tree x Leaf. -Proof. - red; inversion 1. -Qed. - -Lemma lt_tree_node : - forall (x y : elt) (l r : tree) (h : int), - lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h). -Proof. - unfold lt_tree; intuition_in; order. -Qed. - -Lemma gt_tree_node : - forall (x y : elt) (l r : tree) (h : int), - gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h). -Proof. - unfold gt_tree; intuition_in; order. -Qed. - -Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. - -Lemma lt_tree_not_in : - forall (x : elt) (t : tree), lt_tree x t -> ~ In x t. -Proof. - intros; intro; order. -Qed. - -Lemma lt_tree_trans : - forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t. -Proof. - eauto. -Qed. - -Lemma gt_tree_not_in : - forall (x : elt) (t : tree), gt_tree x t -> ~ In x t. -Proof. - intros; intro; order. -Qed. - -Lemma gt_tree_trans : - forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t. -Proof. - eauto. -Qed. - -Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. - -(** * Inductions principles *) - -Functional Scheme mem_ind := Induction for mem Sort Prop. -Functional Scheme bal_ind := Induction for bal Sort Prop. -Functional Scheme add_ind := Induction for add Sort Prop. -Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. -Functional Scheme merge_ind := Induction for merge Sort Prop. -Functional Scheme remove_ind := Induction for remove Sort Prop. -Functional Scheme min_elt_ind := Induction for min_elt Sort Prop. -Functional Scheme max_elt_ind := Induction for max_elt Sort Prop. -Functional Scheme concat_ind := Induction for concat Sort Prop. -Functional Scheme split_ind := Induction for split Sort Prop. -Functional Scheme inter_ind := Induction for inter Sort Prop. -Functional Scheme diff_ind := Induction for diff Sort Prop. -Functional Scheme union_ind := Induction for union Sort Prop. - - -(** * Empty set *) - -Lemma empty_1 : Empty empty. -Proof. - intro; intro. - inversion H. -Qed. - -Lemma empty_bst : bst empty. -Proof. - auto. -Qed. - -(** * Emptyness test *) - -Lemma is_empty_1 : forall s, Empty s -> is_empty s = true. -Proof. - destruct s as [|r x l h]; simpl; auto. - intro H; elim (H x); auto. -Qed. - -Lemma is_empty_2 : forall s, is_empty s = true -> Empty s. -Proof. - destruct s; simpl; intros; try discriminate; red; auto. -Qed. - - - -(** * Appartness *) - -Lemma mem_1 : forall s x, bst s -> In x s -> mem x s = true. -Proof. - intros s x; functional induction mem x s; auto; intros; try clear e0; - inv bst; intuition_in; order. -Qed. - -Lemma mem_2 : forall s x, mem x s = true -> In x s. -Proof. - intros s x; functional induction mem x s; auto; intros; discriminate. -Qed. - - - -(** * Singleton set *) - -Lemma singleton_1 : forall x y, In y (singleton x) -> X.eq x y. -Proof. - unfold singleton; intros; inv In; order. -Qed. - -Lemma singleton_2 : forall x y, X.eq x y -> In y (singleton x). -Proof. - unfold singleton; auto. -Qed. - -Lemma singleton_bst : forall x : elt, bst (singleton x). -Proof. - unfold singleton; auto. -Qed. - - - -(** * Helper functions *) - -Lemma create_in : - forall l x r y, In y (create l x r) <-> X.eq y x \/ In y l \/ In y r. -Proof. - unfold create; split; [ inversion_clear 1 | ]; intuition. -Qed. - -Lemma create_bst : - forall l x r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> - bst (create l x r). -Proof. - unfold create; auto. -Qed. -Hint Resolve create_bst. - -Lemma bal_in : forall l x r y, - In y (bal l x r) <-> X.eq y x \/ In y l \/ In y r. -Proof. - intros l x r; functional induction bal l x r; intros; try clear e0; - rewrite !create_in; intuition_in. -Qed. - -Lemma bal_bst : forall l x r, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (bal l x r). -Proof. - intros l x r; functional induction bal l x r; intros; - inv bst; repeat apply create_bst; auto; unfold create; - (apply lt_tree_node || apply gt_tree_node); auto; - (eapply lt_tree_trans || eapply gt_tree_trans); eauto. -Qed. -Hint Resolve bal_bst. - - - -(** * Insertion *) - -Lemma add_in : forall s x y, - In y (add x s) <-> X.eq y x \/ In y s. -Proof. - intros s x; functional induction (add x s); auto; intros; - try rewrite bal_in, IHt; intuition_in. - eapply In_1; eauto. -Qed. - -Lemma add_bst : forall s x, bst s -> bst (add x s). -Proof. - intros s x; functional induction (add x s); auto; intros; - inv bst; apply bal_bst; auto. - (* lt_tree -> lt_tree (add ...) *) - red; red in H3. - intros. - rewrite add_in in H. - intuition. - eauto. - inv bst; auto using bal_bst. - (* gt_tree -> gt_tree (add ...) *) - red; red in H3. - intros. - rewrite add_in in H. - intuition. - apply MX.lt_eq with x; auto. -Qed. -Hint Resolve add_bst. - - +(** This is just a compatibility layer, the real implementation + is now in [MSetAVL] *) -(** * Join *) - -(* Function/Functional Scheme can't deal with internal fix. - Let's do its job by hand: *) - -Ltac join_tac := - intro l; induction l as [| ll _ lx lr Hlr lh]; - [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join; - [ | destruct (gt_le_dec lh (rh+2)); - [ match goal with |- context b [ bal ?a ?b ?c] => - replace (bal a b c) - with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto] - end - | destruct (gt_le_dec rh (lh+2)); - [ match goal with |- context b [ bal ?a ?b ?c] => - replace (bal a b c) - with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto] - end - | ] ] ] ]; intros. - -Lemma join_in : forall l x r y, - In y (join l x r) <-> X.eq y x \/ In y l \/ In y r. -Proof. - join_tac. - simpl. - rewrite add_in; intuition_in. - rewrite add_in; intuition_in. - rewrite bal_in, Hlr; clear Hlr Hrl; intuition_in. - rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in. - apply create_in. -Qed. - -Lemma join_bst : forall l x r, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (join l x r). -Proof. - join_tac; auto; inv bst; apply bal_bst; auto; - clear Hrl Hlr z; intro; intros; rewrite join_in in *. - intuition; [ apply MX.lt_eq with x | ]; eauto. - intuition; [ apply MX.eq_lt with x | ]; eauto. -Qed. -Hint Resolve join_bst. - - - -(** * Extraction of minimum element *) - -Lemma remove_min_in : forall l x r h y, - In y (Node l x r h) <-> - X.eq y (remove_min l x r)#2 \/ In y (remove_min l x r)#1. -Proof. - intros l x r; functional induction (remove_min l x r); simpl in *; intros. - intuition_in. - rewrite bal_in, In_node_iff, IHp, e0; simpl; intuition. -Qed. - -Lemma remove_min_bst : forall l x r h, - bst (Node l x r h) -> bst (remove_min l x r)#1. -Proof. - intros l x r; functional induction (remove_min l x r); simpl; intros. - inv bst; auto. - inversion_clear H. - specialize IHp with (1:=H0); rewrite e0 in IHp; auto. - apply bal_bst; auto. - intro y; specialize (H2 y). - rewrite remove_min_in, e0 in H2; simpl in H2; intuition. -Qed. - -Lemma remove_min_gt_tree : forall l x r h, - bst (Node l x r h) -> - gt_tree (remove_min l x r)#2 (remove_min l x r)#1. -Proof. - intros l x r; functional induction (remove_min l x r); simpl; intros. - inv bst; auto. - inversion_clear H. - specialize IHp with (1:=H0); rewrite e0 in IHp; simpl in IHp. - intro y; rewrite bal_in; intuition; - specialize (H2 m); rewrite remove_min_in, e0 in H2; simpl in H2; - [ apply MX.lt_eq with x | ]; eauto. -Qed. -Hint Resolve remove_min_bst remove_min_gt_tree. - - - -(** * Merging two trees *) - -Lemma merge_in : forall s1 s2 y, - In y (merge s1 s2) <-> In y s1 \/ In y s2. -Proof. - intros s1 s2; functional induction (merge s1 s2); intros; - try factornode _x _x0 _x1 _x2 as s1. - intuition_in. - intuition_in. - rewrite bal_in, remove_min_in, e1; simpl; intuition. -Qed. - -Lemma merge_bst : forall s1 s2, bst s1 -> bst s2 -> - (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> - bst (merge s1 s2). -Proof. - intros s1 s2; functional induction (merge s1 s2); intros; auto; - try factornode _x _x0 _x1 _x2 as s1. - apply bal_bst; auto. - change s2' with ((s2',m)#1); rewrite <-e1; eauto. - intros y Hy. - apply H1; auto. - rewrite remove_min_in, e1; simpl; auto. - change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto. -Qed. -Hint Resolve merge_bst. - - - -(** * Deletion *) - -Lemma remove_in : forall s x y, bst s -> - (In y (remove x s) <-> ~ X.eq y x /\ In y s). -Proof. - intros s x; functional induction (remove x s); intros; inv bst. - intuition_in. - rewrite bal_in, IHt; clear e0 IHt; intuition; [order|order|intuition_in]. - rewrite merge_in; clear e0; intuition; [order|order|intuition_in]. - elim H4; eauto. - rewrite bal_in, IHt; clear e0 IHt; intuition; [order|order|intuition_in]. -Qed. - -Lemma remove_bst : forall s x, bst s -> bst (remove x s). -Proof. - intros s x; functional induction (remove x s); intros; inv bst. - auto. - (* LT *) - apply bal_bst; auto. - intro z; rewrite remove_in; auto; destruct 1; eauto. - (* EQ *) - eauto. - (* GT *) - apply bal_bst; auto. - intro z; rewrite remove_in; auto; destruct 1; eauto. -Qed. -Hint Resolve remove_bst. - - -(** * Minimum element *) - -Lemma min_elt_1 : forall s x, min_elt s = Some x -> In x s. -Proof. - intro s; functional induction (min_elt s); auto; inversion 1; auto. -Qed. - -Lemma min_elt_2 : forall s x y, bst s -> - min_elt s = Some x -> In y s -> ~ X.lt y x. -Proof. - intro s; functional induction (min_elt s); - try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. - inversion_clear 2. - inversion_clear 1. - inversion 1; subst. - inversion_clear 1; auto. - inversion_clear H5. - inversion_clear 1. - simpl. - destruct l1. - inversion 1; subst. - assert (X.lt x y) by (apply H2; auto). - inversion_clear 1; auto; order. - assert (X.lt x1 y) by auto. - inversion_clear 2; auto; - (assert (~ X.lt x1 x) by auto); order. -Qed. - -Lemma min_elt_3 : forall s, min_elt s = None -> Empty s. -Proof. - intro s; functional induction (min_elt s). - red; red; inversion 2. - inversion 1. - intro H0. - destruct (IHo H0 _x2); auto. -Qed. - - - -(** * Maximum element *) - -Lemma max_elt_1 : forall s x, max_elt s = Some x -> In x s. -Proof. - intro s; functional induction (max_elt s); auto; inversion 1; auto. -Qed. - -Lemma max_elt_2 : forall s x y, bst s -> - max_elt s = Some x -> In y s -> ~ X.lt x y. -Proof. - intro s; functional induction (max_elt s); - try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. - inversion_clear 2. - inversion_clear 1. - inversion 1; subst. - inversion_clear 1; auto. - inversion_clear H5. - inversion_clear 1. - assert (X.lt y x1) by auto. - inversion_clear 2; auto; - (assert (~ X.lt x x1) by auto); order. -Qed. - -Lemma max_elt_3 : forall s, max_elt s = None -> Empty s. -Proof. - intro s; functional induction (max_elt s). - red; auto. - inversion 1. - intros H0; destruct (IHo H0 _x2); auto. -Qed. - - - -(** * Any element *) - -Lemma choose_1 : forall s x, choose s = Some x -> In x s. -Proof. - exact min_elt_1. -Qed. - -Lemma choose_2 : forall s, choose s = None -> Empty s. -Proof. - exact min_elt_3. -Qed. - -Lemma choose_3 : forall s s', bst s -> bst s' -> - forall x x', choose s = Some x -> choose s' = Some x' -> - Equal s s' -> X.eq x x'. -Proof. - unfold choose, Equal; intros s s' Hb Hb' x x' Hx Hx' H. - assert (~X.lt x x'). - apply min_elt_2 with s'; auto. - rewrite <-H; auto using min_elt_1. - assert (~X.lt x' x). - apply min_elt_2 with s; auto. - rewrite H; auto using min_elt_1. - destruct (X.compare x x'); intuition. -Qed. - - -(** * Concatenation *) - -Lemma concat_in : forall s1 s2 y, - In y (concat s1 s2) <-> In y s1 \/ In y s2. -Proof. - intros s1 s2; functional induction (concat s1 s2); intros; - try factornode _x _x0 _x1 _x2 as s1. - intuition_in. - intuition_in. - rewrite join_in, remove_min_in, e1; simpl; intuition. -Qed. - -Lemma concat_bst : forall s1 s2, bst s1 -> bst s2 -> - (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> - bst (concat s1 s2). -Proof. - intros s1 s2; functional induction (concat s1 s2); intros; auto; - try factornode _x _x0 _x1 _x2 as s1. - apply join_bst; auto. - change (bst (s2',m)#1); rewrite <-e1; eauto. - intros y Hy. - apply H1; auto. - rewrite remove_min_in, e1; simpl; auto. - change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto. -Qed. -Hint Resolve concat_bst. - - -(** * Splitting *) - -Lemma split_in_1 : forall s x y, bst s -> - (In y (split x s)#l <-> In y s /\ X.lt y x). -Proof. - intros s x; functional induction (split x s); simpl; intros; - inv bst; try clear e0. - intuition_in. - rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. - intuition_in; order. - rewrite join_in. - rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. -Qed. - -Lemma split_in_2 : forall s x y, bst s -> - (In y (split x s)#r <-> In y s /\ X.lt x y). -Proof. - intros s x; functional induction (split x s); subst; simpl; intros; - inv bst; try clear e0. - intuition_in. - rewrite join_in. - rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. - intuition_in; order. - rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. -Qed. - -Lemma split_in_3 : forall s x, bst s -> - ((split x s)#b = true <-> In x s). -Proof. - intros s x; functional induction (split x s); subst; simpl; intros; - inv bst; try clear e0. - intuition_in; try discriminate. - rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. - intuition. - rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. -Qed. - -Lemma split_bst : forall s x, bst s -> - bst (split x s)#l /\ bst (split x s)#r. -Proof. - intros s x; functional induction (split x s); subst; simpl; intros; - inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition; - apply join_bst; auto. - intros y0. - generalize (split_in_2 x y0 H0); rewrite e1; simpl; intuition. - intros y0. - generalize (split_in_1 x y0 H1); rewrite e1; simpl; intuition. -Qed. - - - -(** * Intersection *) - -Lemma inter_bst_in : forall s1 s2, bst s1 -> bst s2 -> - bst (inter s1 s2) /\ (forall y, In y (inter s1 s2) <-> In y s1 /\ In y s2). -Proof. - intros s1 s2; functional induction inter s1 s2; intros B1 B2; - [intuition_in|intuition_in | | ]; - factornode _x0 _x1 _x2 _x3 as s2; - generalize (split_bst x1 B2); - rewrite e1; simpl; destruct 1; inv bst; - destruct IHt as (IHb1,IHi1); auto; - destruct IHt0 as (IHb2,IHi2); auto; - generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1) - (split_in_3 x1 B2)(split_bst x1 B2); - rewrite e1; simpl; split; intros. - (* bst join *) - apply join_bst; auto; intro y; [rewrite IHi1|rewrite IHi2]; intuition. (* In join *) - rewrite join_in, IHi1, IHi2, H5, H6; intuition_in. - apply In_1 with x1; auto. - (* bst concat *) - apply concat_bst; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order. - (* In concat *) - rewrite concat_in, IHi1, IHi2, H5, H6; auto. - assert (~In x1 s2) by (rewrite <- H7; auto). - intuition_in. - elim H9. - apply In_1 with y; auto. -Qed. - -Lemma inter_in : forall s1 s2 y, bst s1 -> bst s2 -> - (In y (inter s1 s2) <-> In y s1 /\ In y s2). -Proof. - intros s1 s2 y B1 B2; destruct (inter_bst_in B1 B2); auto. -Qed. - -Lemma inter_bst : forall s1 s2, bst s1 -> bst s2 -> bst (inter s1 s2). -Proof. - intros s1 s2 B1 B2; destruct (inter_bst_in B1 B2); auto. -Qed. - - -(** * Difference *) - -Lemma diff_bst_in : forall s1 s2, bst s1 -> bst s2 -> - bst (diff s1 s2) /\ (forall y, In y (diff s1 s2) <-> In y s1 /\ ~In y s2). -Proof. - intros s1 s2; functional induction diff s1 s2; intros B1 B2; - [intuition_in|intuition_in | | ]; - factornode _x0 _x1 _x2 _x3 as s2; - generalize (split_bst x1 B2); - rewrite e1; simpl; destruct 1; - inv avl; inv bst; - destruct IHt as (IHb1,IHi1); auto; - destruct IHt0 as (IHb2,IHi2); auto; - generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1) - (split_in_3 x1 B2)(split_bst x1 B2); - rewrite e1; simpl; split; intros. - (* bst concat *) - apply concat_bst; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order. - (* In concat *) - rewrite concat_in, IHi1, IHi2, H5, H6; intuition_in. - elim H13. - apply In_1 with x1; auto. - (* bst join *) - apply join_bst; auto; intro y; [rewrite IHi1|rewrite IHi2]; intuition. (* In join *) - rewrite join_in, IHi1, IHi2, H5, H6; auto. - assert (~In x1 s2) by (rewrite <- H7; auto). - intuition_in. - elim H9. - apply In_1 with y; auto. -Qed. - -Lemma diff_in : forall s1 s2 y, bst s1 -> bst s2 -> - (In y (diff s1 s2) <-> In y s1 /\ ~In y s2). -Proof. - intros s1 s2 y B1 B2; destruct (diff_bst_in B1 B2); auto. -Qed. - -Lemma diff_bst : forall s1 s2, bst s1 -> bst s2 -> bst (diff s1 s2). -Proof. - intros s1 s2 B1 B2; destruct (diff_bst_in B1 B2); auto. -Qed. - - -(** * Union *) - -Lemma union_in : forall s1 s2 y, bst s1 -> bst s2 -> - (In y (union s1 s2) <-> In y s1 \/ In y s2). -Proof. - intros s1 s2; functional induction union s1 s2; intros y B1 B2. - intuition_in. - intuition_in. - factornode _x0 _x1 _x2 _x3 as s2. - generalize (split_in_1 x1 y B2)(split_in_2 x1 y B2)(split_bst x1 B2). - rewrite e1; simpl. - destruct 3; inv bst. - rewrite join_in, IHt, IHt0, H, H0; auto. - case (X.compare y x1); intuition_in. -Qed. - -Lemma union_bst : forall s1 s2, bst s1 -> bst s2 -> - bst (union s1 s2). -Proof. - intros s1 s2; functional induction union s1 s2; intros B1 B2; auto. - factornode _x0 _x1 _x2 _x3 as s2. - generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1)(split_bst x1 B2). - rewrite e1; simpl; destruct 3. - inv bst. - apply join_bst; auto. - intro y; rewrite union_in, H; intuition_in. - intro y; rewrite union_in, H0; intuition_in. -Qed. - - -(** * Elements *) - -Lemma elements_aux_in : forall s acc x, - InA X.eq x (elements_aux acc s) <-> In x s \/ InA X.eq x acc. -Proof. - induction s as [ | l Hl x r Hr h ]; simpl; auto. - intuition. - inversion H0. - intros. - rewrite Hl. - destruct (Hr acc x0); clear Hl Hr. - intuition; inversion_clear H3; intuition. -Qed. - -Lemma elements_in : forall s x, InA X.eq x (elements s) <-> In x s. -Proof. - intros; generalize (elements_aux_in s nil x); intuition. - inversion_clear H0. -Qed. - -Lemma elements_aux_sort : forall s acc, bst s -> sort X.lt acc -> - (forall x y : elt, InA X.eq x acc -> In y s -> X.lt y x) -> - sort X.lt (elements_aux acc s). -Proof. - induction s as [ | l Hl y r Hr h]; simpl; intuition. - inv bst. - apply Hl; auto. - constructor. - apply Hr; auto. - apply MX.In_Inf; intros. - destruct (elements_aux_in r acc y0); intuition. - intros. - inversion_clear H. - order. - destruct (elements_aux_in r acc x); intuition eauto. -Qed. - -Lemma elements_sort : forall s : tree, bst s -> sort X.lt (elements s). -Proof. - intros; unfold elements; apply elements_aux_sort; auto. - intros; inversion H0. -Qed. -Hint Resolve elements_sort. - -Lemma elements_nodup : forall s : tree, bst s -> NoDupA X.eq (elements s). -Proof. - auto. -Qed. - -Lemma elements_aux_cardinal : - forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s). -Proof. - simple induction s; simpl in |- *; intuition. - rewrite <- H. - simpl in |- *. - rewrite <- H0; omega. -Qed. - -Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s). -Proof. - exact (fun s => elements_aux_cardinal s nil). -Qed. - -Lemma elements_app : - forall s acc, elements_aux acc s = elements s ++ acc. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1, IHs2. - unfold elements; simpl. - rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto. -Qed. - -Lemma elements_node : - forall l x r h acc, - elements l ++ x :: elements r ++ acc = - elements (Node l x r h) ++ acc. -Proof. - unfold elements; simpl; intros; auto. - rewrite !elements_app, <- !app_nil_end, !app_ass; auto. -Qed. - - -(** * Filter *) - -Section F. -Variable f : elt -> bool. - -Lemma filter_acc_in : forall s acc, - compat_bool X.eq f -> forall x : elt, - In x (filter_acc f acc s) <-> In x acc \/ In x s /\ f x = true. -Proof. - induction s; simpl; intros. - intuition_in. - rewrite IHs2, IHs1 by (destruct (f t); auto). - case_eq (f t); intros. - rewrite (add_in); auto. - intuition_in. - rewrite (H _ _ H2). - intuition. - intuition_in. - rewrite (H _ _ H2) in H3. - rewrite H0 in H3; discriminate. -Qed. - -Lemma filter_acc_bst : forall s acc, bst s -> bst acc -> - bst (filter_acc f acc s). -Proof. - induction s; simpl; auto. - intros. - inv bst. - destruct (f t); auto. -Qed. - -Lemma filter_in : forall s, - compat_bool X.eq f -> forall x : elt, - In x (filter f s) <-> In x s /\ f x = true. -Proof. - unfold filter; intros; rewrite filter_acc_in; intuition_in. -Qed. - -Lemma filter_bst : forall s, bst s -> bst (filter f s). -Proof. - unfold filter; intros; apply filter_acc_bst; auto. -Qed. - - - -(** * Partition *) - -Lemma partition_acc_in_1 : forall s acc, - compat_bool X.eq f -> forall x : elt, - In x (partition_acc f acc s)#1 <-> - In x acc#1 \/ In x s /\ f x = true. -Proof. - induction s; simpl; intros. - intuition_in. - destruct acc as [acct accf]; simpl in *. - rewrite IHs2 by - (destruct (f t); auto; apply partition_acc_avl_1; simpl; auto). - rewrite IHs1 by (destruct (f t); simpl; auto). - case_eq (f t); simpl; intros. - rewrite (add_in); auto. - intuition_in. - rewrite (H _ _ H2). - intuition. - intuition_in. - rewrite (H _ _ H2) in H3. - rewrite H0 in H3; discriminate. -Qed. - -Lemma partition_acc_in_2 : forall s acc, - compat_bool X.eq f -> forall x : elt, - In x (partition_acc f acc s)#2 <-> - In x acc#2 \/ In x s /\ f x = false. -Proof. - induction s; simpl; intros. - intuition_in. - destruct acc as [acct accf]; simpl in *. - rewrite IHs2 by - (destruct (f t); auto; apply partition_acc_avl_2; simpl; auto). - rewrite IHs1 by (destruct (f t); simpl; auto). - case_eq (f t); simpl; intros. - intuition. - intuition_in. - rewrite (H _ _ H2) in H3. - rewrite H0 in H3; discriminate. - rewrite (add_in); auto. - intuition_in. - rewrite (H _ _ H2). - intuition. -Qed. - -Lemma partition_in_1 : forall s, - compat_bool X.eq f -> forall x : elt, - In x (partition f s)#1 <-> In x s /\ f x = true. -Proof. - unfold partition; intros; rewrite partition_acc_in_1; - simpl in *; intuition_in. -Qed. - -Lemma partition_in_2 : forall s, - compat_bool X.eq f -> forall x : elt, - In x (partition f s)#2 <-> In x s /\ f x = false. -Proof. - unfold partition; intros; rewrite partition_acc_in_2; - simpl in *; intuition_in. -Qed. - -Lemma partition_acc_bst_1 : forall s acc, bst s -> bst acc#1 -> - bst (partition_acc f acc s)#1. -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. - inv bst. - destruct (f t); auto. - apply IHs2; simpl; auto. - apply IHs1; simpl; auto. -Qed. - -Lemma partition_acc_bst_2 : forall s acc, bst s -> bst acc#2 -> - bst (partition_acc f acc s)#2. -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. - inv bst. - destruct (f t); auto. - apply IHs2; simpl; auto. - apply IHs1; simpl; auto. -Qed. - -Lemma partition_bst_1 : forall s, bst s -> bst (partition f s)#1. -Proof. - unfold partition; intros; apply partition_acc_bst_1; auto. -Qed. - -Lemma partition_bst_2 : forall s, bst s -> bst (partition f s)#2. -Proof. - unfold partition; intros; apply partition_acc_bst_2; auto. -Qed. - - - -(** * [for_all] and [exists] *) - -Lemma for_all_1 : forall s, compat_bool X.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. -Proof. - induction s; simpl; auto. - intros. - rewrite IHs1; try red; auto. - rewrite IHs2; try red; auto. - generalize (H0 t). - destruct (f t); simpl; auto. -Qed. - -Lemma for_all_2 : forall s, compat_bool X.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. -Proof. - induction s; simpl; auto; intros; red; intros; inv In. - destruct (andb_prop _ _ H0); auto. - destruct (andb_prop _ _ H1); eauto. - apply IHs1; auto. - destruct (andb_prop _ _ H0); auto. - destruct (andb_prop _ _ H1); auto. - apply IHs2; auto. - destruct (andb_prop _ _ H0); auto. -Qed. - -Lemma exists_1 : forall s, compat_bool X.eq f -> - Exists (fun x => f x = true) s -> exists_ f s = true. -Proof. - induction s; simpl; destruct 2 as (x,(U,V)); inv In; rewrite <- ?orb_lazy_alt. - rewrite (H _ _ (X.eq_sym H0)); rewrite V; auto. - apply orb_true_intro; left. - apply orb_true_intro; right; apply IHs1; auto; exists x; auto. - apply orb_true_intro; right; apply IHs2; auto; exists x; auto. -Qed. - -Lemma exists_2 : forall s, compat_bool X.eq f -> - exists_ f s = true -> Exists (fun x => f x = true) s. -Proof. - induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *. - discriminate. - destruct (orb_true_elim _ _ H0) as [H1|H1]. - destruct (orb_true_elim _ _ H1) as [H2|H2]. - exists t; auto. - destruct (IHs1 H H2); auto; exists x; intuition. - destruct (IHs2 H H1); auto; exists x; intuition. -Qed. - -End F. - - - -(** * Fold *) - -Definition fold' (A : Type) (f : elt -> A -> A)(s : tree) := - L.fold f (elements s). -Implicit Arguments fold' [A]. - -Lemma fold_equiv_aux : - forall (A : Type) (s : tree) (f : elt -> A -> A) (a : A) (acc : list elt), - L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a). -Proof. - simple induction s. - simpl in |- *; intuition. - simpl in |- *; intros. - rewrite H. - simpl. - apply H0. -Qed. - -Lemma fold_equiv : - forall (A : Type) (s : tree) (f : elt -> A -> A) (a : A), - fold f s a = fold' f s a. -Proof. - unfold fold', elements in |- *. - simple induction s; simpl in |- *; auto; intros. - rewrite fold_equiv_aux. - rewrite H0. - simpl in |- *; auto. -Qed. - -Lemma fold_1 : - forall (s:t)(Hs:bst s)(A : Type)(f : elt -> A -> A)(i : A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. -Proof. - intros. - rewrite fold_equiv. - unfold fold'. - rewrite L.fold_1. - unfold L.elements; auto. - apply elements_sort; auto. -Qed. - -(** * Subset *) - -Lemma subsetl_12 : forall subset_l1 l1 x1 h1 s2, - bst (Node l1 x1 Leaf h1) -> bst s2 -> - (forall s, bst s -> (subset_l1 s = true <-> Subset l1 s)) -> - (subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ). -Proof. - induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. - unfold Subset; intuition; try discriminate. - assert (H': In x1 Leaf) by auto; inversion H'. - inversion_clear H0. - specialize (IHl2 H H2 H1). - specialize (IHr2 H H3 H1). - inv bst. clear H8. - destruct X.compare. - - rewrite IHl2; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (X.eq a x2) by order; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (H':=mem_2 H6); apply In_1 with x1; auto. - apply mem_1; auto. - assert (In x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order. -Qed. - - -Lemma subsetr_12 : forall subset_r1 r1 x1 h1 s2, - bst (Node Leaf x1 r1 h1) -> bst s2 -> - (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> - (subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2). -Proof. - induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. - unfold Subset; intuition; try discriminate. - assert (H': In x1 Leaf) by auto; inversion H'. - inversion_clear H0. - specialize (IHl2 H H2 H1). - specialize (IHr2 H H3 H1). - inv bst. clear H7. - destruct X.compare. - - rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (H':=mem_2 H1); apply In_1 with x1; auto. - apply mem_1; auto. - assert (In x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (X.eq a x2) by order; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite IHr2; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. -Qed. - - -Lemma subset_12 : forall s1 s2, bst s1 -> bst s2 -> - (subset s1 s2 = true <-> Subset s1 s2). -Proof. - induction s1 as [|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros. - unfold Subset; intuition_in. - destruct s2 as [|l2 x2 r2 h2]; simpl; intros. - unfold Subset; intuition_in; try discriminate. - assert (H': In x1 Leaf) by auto; inversion H'. - inv bst. - destruct X.compare. - - rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto. - rewrite (@subsetl_12 (subset l1) l1 x1 h1) by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - assert (X.eq a x2) by order; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto. - rewrite (@subsetr_12 (subset r1) r1 x1 h1) by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. -Qed. - - - -(** * Comparison *) - -(** ** Relations [eq] and [lt] over trees *) - -Definition eq := Equal. -Definition lt (s1 s2 : t) : Prop := L.lt (elements s1) (elements s2). - -Lemma eq_refl : forall s : t, Equal s s. -Proof. - unfold Equal; intuition. -Qed. - -Lemma eq_sym : forall s s' : t, Equal s s' -> Equal s' s. -Proof. - unfold Equal; intros s s' H x; destruct (H x); split; auto. -Qed. - -Lemma eq_trans : forall s s' s'' : t, - Equal s s' -> Equal s' s'' -> Equal s s''. -Proof. - unfold Equal; intros s s' s'' H1 H2 x; - destruct (H1 x); destruct (H2 x); split; auto. -Qed. - -Lemma eq_L_eq : - forall s s' : t, Equal s s' -> L.eq (elements s) (elements s'). -Proof. - unfold Equal, L.eq, L.Equal; intros; do 2 rewrite elements_in; auto. -Qed. - -Lemma L_eq_eq : - forall s s' : t, L.eq (elements s) (elements s') -> Equal s s'. -Proof. - unfold Equal, L.eq, L.Equal; intros; do 2 rewrite <-elements_in; auto. -Qed. -Hint Resolve eq_L_eq L_eq_eq. - -Definition lt_trans (s s' s'' : t) (h : lt s s') - (h' : lt s' s'') : lt s s'' := L.lt_trans h h'. - -Lemma lt_not_eq : forall s s' : t, - bst s -> bst s' -> lt s s' -> ~ Equal s s'. -Proof. - unfold lt in |- *; intros; intro. - apply L.lt_not_eq with (s := elements s) (s' := elements s'); auto. -Qed. - -Lemma L_eq_cons : - forall (l1 l2 : list elt) (x y : elt), - X.eq x y -> L.eq l1 l2 -> L.eq (x :: l1) (y :: l2). -Proof. - unfold L.eq, L.Equal in |- *; intuition. - inversion_clear H1; generalize (H0 a); clear H0; intuition. - apply InA_eqA with x; eauto. - inversion_clear H1; generalize (H0 a); clear H0; intuition. - apply InA_eqA with y; eauto. -Qed. -Hint Resolve L_eq_cons. - - -(** * A new comparison algorithm suggested by Xavier Leroy *) - -(** [flatten_e e] returns the list of elements of [e] i.e. the list - of elements actually compared *) - -Fixpoint flatten_e (e : enumeration) : list elt := match e with - | End => nil - | More x t r => x :: elements t ++ flatten_e r - end. - -Lemma flatten_e_elements : - forall l x r h e, - elements l ++ flatten_e (More x r e) = elements (Node l x r h) ++ flatten_e e. -Proof. - intros; simpl; apply elements_node. -Qed. - -Lemma cons_1 : forall s e, - flatten_e (cons s e) = elements s ++ flatten_e e. -Proof. - induction s; simpl; auto; intros. - rewrite IHs1; apply flatten_e_elements. -Qed. - -(** Correctness of this comparison *) - -Definition Cmp c := - match c with - | Eq => L.eq - | Lt => L.lt - | Gt => (fun l1 l2 => L.lt l2 l1) - end. - -Lemma cons_Cmp : forall c x1 x2 l1 l2, X.eq x1 x2 -> - Cmp c l1 l2 -> Cmp c (x1::l1) (x2::l2). -Proof. - destruct c; simpl; auto. -Qed. -Hint Resolve cons_Cmp. - -Lemma compare_end_Cmp : - forall e2, Cmp (compare_end e2) nil (flatten_e e2). -Proof. - destruct e2; simpl; auto. - apply L.eq_refl. -Qed. - -Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, - Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> - Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) - (flatten_e (More x2 r2 e2)). -Proof. - simpl; intros; destruct X.compare; simpl; auto. -Qed. - -Lemma compare_cont_Cmp : forall s1 cont e2 l, - (forall e, Cmp (cont e) l (flatten_e e)) -> - Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2). -Proof. - induction s1 as [|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto. - rewrite <- elements_node; simpl. - apply Hl1; auto. clear e2. intros [|x2 r2 e2]. - simpl; auto. - apply compare_more_Cmp. - rewrite <- cons_1; auto. -Qed. - -Lemma compare_Cmp : forall s1 s2, - Cmp (compare s1 s2) (elements s1) (elements s2). -Proof. - intros; unfold compare. - rewrite (app_nil_end (elements s1)). - replace (elements s2) with (flatten_e (cons s2 End)) by - (rewrite cons_1; simpl; rewrite <- app_nil_end; auto). - apply compare_cont_Cmp; auto. - intros. - apply compare_end_Cmp; auto. -Qed. - -(** * Equality test *) - -Lemma equal_1 : forall s1 s2, bst s1 -> bst s2 -> - Equal s1 s2 -> equal s1 s2 = true. -Proof. -unfold equal; intros s1 s2 B1 B2 E. -generalize (compare_Cmp s1 s2). -destruct (compare s1 s2); simpl in *; auto; intros. -elim (lt_not_eq B1 B2 H E); auto. -elim (lt_not_eq B2 B1 H (eq_sym E)); auto. -Qed. - -Lemma equal_2 : forall s1 s2, - equal s1 s2 = true -> Equal s1 s2. -Proof. -unfold equal; intros s1 s2 E. -generalize (compare_Cmp s1 s2); - destruct compare; auto; discriminate. -Qed. - -End Proofs. - -End Raw. - - - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of binary search trees. - They also happen to be well-balanced, but this has no influence - on the correctness of operations, so we won't state this here, - see [FSetFullAVL] if you need more than just the FSet interface. -*) +Require FSetCompat MSetAVL Orders OrdersAlt. Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. - - Module E := X. - Module Raw := Raw I X. - Import Raw.Proofs. - - Record bst := Bst {this :> Raw.t; is_bst : Raw.bst this}. - Definition t := bst. - Definition elt := E.t. - - Definition In (x : elt) (s : t) := Raw.In x s. - Definition Equal (s s':t) := forall a : elt, In a s <-> In a s'. - Definition Subset (s s':t) := forall a : elt, In a s -> In a s'. - Definition Empty (s:t) := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) (s:t) := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) (s:t) := exists x, In x s /\ P x. - - Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. - Proof. intro s; exact (@In_1 s). Qed. - - Definition mem (x:elt)(s:t) : bool := Raw.mem x s. - - Definition empty : t := Bst empty_bst. - Definition is_empty (s:t) : bool := Raw.is_empty s. - Definition singleton (x:elt) : t := Bst (singleton_bst x). - Definition add (x:elt)(s:t) : t := Bst (add_bst x (is_bst s)). - Definition remove (x:elt)(s:t) : t := Bst (remove_bst x (is_bst s)). - Definition inter (s s':t) : t := Bst (inter_bst (is_bst s) (is_bst s')). - Definition union (s s':t) : t := Bst (union_bst (is_bst s) (is_bst s')). - Definition diff (s s':t) : t := Bst (diff_bst (is_bst s) (is_bst s')). - Definition elements (s:t) : list elt := Raw.elements s. - Definition min_elt (s:t) : option elt := Raw.min_elt s. - Definition max_elt (s:t) : option elt := Raw.max_elt s. - Definition choose (s:t) : option elt := Raw.choose s. - Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := Raw.fold f s. - Definition cardinal (s:t) : nat := Raw.cardinal s. - Definition filter (f : elt -> bool) (s:t) : t := - Bst (filter_bst f (is_bst s)). - Definition for_all (f : elt -> bool) (s:t) : bool := Raw.for_all f s. - Definition exists_ (f : elt -> bool) (s:t) : bool := Raw.exists_ f s. - Definition partition (f : elt -> bool) (s:t) : t * t := - let p := Raw.partition f s in - (@Bst (fst p) (partition_bst_1 f (is_bst s)), - @Bst (snd p) (partition_bst_2 f (is_bst s))). - - Definition equal (s s':t) : bool := Raw.equal s s'. - Definition subset (s s':t) : bool := Raw.subset s s'. - - Definition eq (s s':t) : Prop := Raw.Equal s s'. - Definition lt (s s':t) : Prop := Raw.Proofs.lt s s'. - - Definition compare (s s':t) : Compare lt eq s s'. - Proof. - intros (s,b) (s',b'). - generalize (compare_Cmp s s'). - destruct Raw.compare; intros; [apply EQ|apply LT|apply GT]; red; auto. - Defined. - - Definition eq_dec (s s':t) : { eq s s' } + { ~ eq s s' }. - Proof. - intros (s,b) (s',b'); unfold eq; simpl. - case_eq (Raw.equal s s'); intro H; [left|right]. - apply equal_2; auto. - intro H'; rewrite equal_1 in H; auto; discriminate. - Defined. - - (* specs *) - Section Specs. - Variable s s' s'': t. - Variable x y : elt. - - Hint Resolve is_bst. - - Lemma mem_1 : In x s -> mem x s = true. - Proof. exact (mem_1 (is_bst s)). Qed. - Lemma mem_2 : mem x s = true -> In x s. - Proof. exact (@mem_2 s x). Qed. - - Lemma equal_1 : Equal s s' -> equal s s' = true. - Proof. exact (equal_1 (is_bst s) (is_bst s')). Qed. - Lemma equal_2 : equal s s' = true -> Equal s s'. - Proof. exact (@equal_2 s s'). Qed. - - Ltac wrap t H := unfold t, In; simpl; rewrite H; auto; intuition. - - Lemma subset_1 : Subset s s' -> subset s s' = true. - Proof. wrap subset subset_12. Qed. - Lemma subset_2 : subset s s' = true -> Subset s s'. - Proof. wrap subset subset_12. Qed. - - Lemma empty_1 : Empty empty. - Proof. exact empty_1. Qed. - - Lemma is_empty_1 : Empty s -> is_empty s = true. - Proof. exact (@is_empty_1 s). Qed. - Lemma is_empty_2 : is_empty s = true -> Empty s. - Proof. exact (@is_empty_2 s). Qed. - - Lemma add_1 : E.eq x y -> In y (add x s). - Proof. wrap add add_in. Qed. - Lemma add_2 : In y s -> In y (add x s). - Proof. wrap add add_in. Qed. - Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. - Proof. wrap add add_in. elim H; auto. Qed. - - Lemma remove_1 : E.eq x y -> ~ In y (remove x s). - Proof. wrap remove remove_in. Qed. - Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). - Proof. wrap remove remove_in. Qed. - Lemma remove_3 : In y (remove x s) -> In y s. - Proof. wrap remove remove_in. Qed. - - Lemma singleton_1 : In y (singleton x) -> E.eq x y. - Proof. exact (@singleton_1 x y). Qed. - Lemma singleton_2 : E.eq x y -> In y (singleton x). - Proof. exact (@singleton_2 x y). Qed. - - Lemma union_1 : In x (union s s') -> In x s \/ In x s'. - Proof. wrap union union_in. Qed. - Lemma union_2 : In x s -> In x (union s s'). - Proof. wrap union union_in. Qed. - Lemma union_3 : In x s' -> In x (union s s'). - Proof. wrap union union_in. Qed. - - Lemma inter_1 : In x (inter s s') -> In x s. - Proof. wrap inter inter_in. Qed. - Lemma inter_2 : In x (inter s s') -> In x s'. - Proof. wrap inter inter_in. Qed. - Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). - Proof. wrap inter inter_in. Qed. - - Lemma diff_1 : In x (diff s s') -> In x s. - Proof. wrap diff diff_in. Qed. - Lemma diff_2 : In x (diff s s') -> ~ In x s'. - Proof. wrap diff diff_in. Qed. - Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - Proof. wrap diff diff_in. Qed. - - Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. unfold fold, elements; intros; apply fold_1; auto. Qed. - - Lemma cardinal_1 : cardinal s = length (elements s). - Proof. - unfold cardinal, elements; intros; apply elements_cardinal; auto. - Qed. - - Section Filter. - Variable f : elt -> bool. - - Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Proof. intro. wrap filter filter_in. Qed. - Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Proof. intro. wrap filter filter_in. Qed. - Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. intro. wrap filter filter_in. Qed. - - Lemma for_all_1 : compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. - Proof. exact (@for_all_1 f s). Qed. - Lemma for_all_2 : compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. - Proof. exact (@for_all_2 f s). Qed. - - Lemma exists_1 : compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. exact (@exists_1 f s). Qed. - Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. exact (@exists_2 f s). Qed. - - Lemma partition_1 : compat_bool E.eq f -> - Equal (fst (partition f s)) (filter f s). - Proof. - unfold partition, filter, Equal, In; simpl ;intros H a. - rewrite partition_in_1, filter_in; intuition. - Qed. - - Lemma partition_2 : compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - unfold partition, filter, Equal, In; simpl ;intros H a. - rewrite partition_in_2, filter_in; intuition. - rewrite H2; auto. - destruct (f a); auto. - red; intros; f_equal. - rewrite (H _ _ H0); auto. - Qed. - - End Filter. - - Lemma elements_1 : In x s -> InA E.eq x (elements s). - Proof. wrap elements elements_in. Qed. - Lemma elements_2 : InA E.eq x (elements s) -> In x s. - Proof. wrap elements elements_in. Qed. - Lemma elements_3 : sort E.lt (elements s). - Proof. exact (elements_sort (is_bst s)). Qed. - Lemma elements_3w : NoDupA E.eq (elements s). - Proof. exact (elements_nodup (is_bst s)). Qed. - - Lemma min_elt_1 : min_elt s = Some x -> In x s. - Proof. exact (@min_elt_1 s x). Qed. - Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. - Proof. exact (@min_elt_2 s x y (is_bst s)). Qed. - Lemma min_elt_3 : min_elt s = None -> Empty s. - Proof. exact (@min_elt_3 s). Qed. - - Lemma max_elt_1 : max_elt s = Some x -> In x s. - Proof. exact (@max_elt_1 s x). Qed. - Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. - Proof. exact (@max_elt_2 s x y (is_bst s)). Qed. - Lemma max_elt_3 : max_elt s = None -> Empty s. - Proof. exact (@max_elt_3 s). Qed. - - Lemma choose_1 : choose s = Some x -> In x s. - Proof. exact (@choose_1 s x). Qed. - Lemma choose_2 : choose s = None -> Empty s. - Proof. exact (@choose_2 s). Qed. - Lemma choose_3 : choose s = Some x -> choose s' = Some y -> - Equal s s' -> E.eq x y. - Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed. - - Lemma eq_refl : eq s s. - Proof. exact (eq_refl s). Qed. - Lemma eq_sym : eq s s' -> eq s' s. - Proof. exact (@eq_sym s s'). Qed. - Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''. - Proof. exact (@eq_trans s s' s''). Qed. - - Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''. - Proof. exact (@lt_trans s s' s''). Qed. - Lemma lt_not_eq : lt s s' -> ~eq s s'. - Proof. exact (@lt_not_eq _ _ (is_bst s) (is_bst s')). Qed. - - End Specs. + Module X' := OrdersAlt.Update_OT X. + Module MSet := MSetAVL.IntMake I X'. + Include FSetCompat.Backport_Sets X MSet. End IntMake. (* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index c03fb92e..7f8c51d6 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetBridge.v 11699 2008-12-18 11:49:08Z letouzey $ *) +(* $Id$ *) (** * Finite sets library *) @@ -23,51 +23,51 @@ Set Firstorder Depth 2. Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition empty : {s : t | Empty s}. - Proof. + Proof. exists empty; auto with set. Qed. Definition is_empty : forall s : t, {Empty s} + {~ Empty s}. - Proof. + Proof. intros; generalize (is_empty_1 (s:=s)) (is_empty_2 (s:=s)). case (is_empty s); intuition. Qed. Definition mem : forall (x : elt) (s : t), {In x s} + {~ In x s}. - Proof. + Proof. intros; generalize (mem_1 (s:=s) (x:=x)) (mem_2 (s:=s) (x:=x)). case (mem x s); intuition. Qed. - + Definition Add (x : elt) (s s' : t) := forall y : elt, In y s' <-> E.eq x y \/ In y s. - + Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}. Proof. intros; exists (add x s); auto. unfold Add in |- *; intuition. elim (E.eq_dec x y); auto. - intros; right. + intros; right. eapply add_3; eauto. - Qed. - + Qed. + Definition singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. - Proof. + Proof. intros; exists (singleton x); intuition. Qed. - + Definition remove : forall (x : elt) (s : t), {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. Proof. intros; exists (remove x s); intuition. absurd (In x (remove x s)); auto with set. - apply In_1 with y; auto. + apply In_1 with y; auto. elim (E.eq_dec x y); intros; auto. absurd (In x (remove x s)); auto with set. - apply In_1 with y; auto. + apply In_1 with y; auto. eauto with set. Qed. @@ -75,47 +75,47 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}. Proof. intros; exists (union s s'); intuition. - Qed. + Qed. Definition inter : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}. - Proof. + Proof. intros; exists (inter s s'); intuition; eauto with set. Qed. Definition diff : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. - Proof. - intros; exists (diff s s'); intuition; eauto with set. - absurd (In x s'); eauto with set. - Qed. - + Proof. + intros; exists (diff s s'); intuition; eauto with set. + absurd (In x s'); eauto with set. + Qed. + Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}. - Proof. - intros. + Proof. + intros. generalize (equal_1 (s:=s) (s':=s')) (equal_2 (s:=s) (s':=s')). case (equal s s'); intuition. Qed. Definition subset : forall s s' : t, {Subset s s'} + {~Subset s s'}. - Proof. - intros. + Proof. + intros. generalize (subset_1 (s:=s) (s':=s')) (subset_2 (s:=s) (s':=s')). case (subset s s'); intuition. - Qed. + Qed. Definition elements : forall s : t, {l : list elt | sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}. Proof. - intros; exists (elements s); intuition. - Defined. + intros; exists (elements s); intuition. + Defined. Definition fold : forall (A : Type) (f : elt -> A -> A) (s : t) (i : A), - {r : A | let (l,_) := elements s in + {r : A | let (l,_) := elements s in r = fold_left (fun a e => f e a) l i}. - Proof. + Proof. intros; exists (fold (A:=A) f s i); exact (fold_1 s i f). Qed. @@ -124,16 +124,16 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. {r : nat | let (l,_) := elements s in r = length l }. Proof. intros; exists (cardinal s); exact (cardinal_1 s). - Qed. + Qed. Definition fdec (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) - (x : elt) := if Pdec x then true else false. + (x : elt) := if Pdec x then true else false. Lemma compat_P_aux : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}), compat_P E.eq P -> compat_bool E.eq (fdec Pdec). Proof. - unfold compat_P, compat_bool, fdec in |- *; intros. + unfold compat_P, compat_bool, Proper, respectful, fdec in |- *; intros. generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder. Qed. @@ -143,7 +143,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}. Proof. - intros. + intros. exists (filter (fdec Pdec) s). intro H; assert (compat_bool E.eq (fdec Pdec)); auto. intuition. @@ -160,29 +160,29 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition for_all : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. - Proof. - intros. + Proof. + intros. generalize (for_all_1 (s:=s) (f:=fdec Pdec)) (for_all_2 (s:=s) (f:=fdec Pdec)). case (for_all (fdec Pdec) s); unfold For_all in |- *; [ left | right ]; intros. assert (compat_bool E.eq (fdec Pdec)); auto. generalize (H0 H3 (refl_equal _) _ H2). - unfold fdec in |- *. + unfold fdec in |- *. case (Pdec x); intuition. inversion H4. - intuition. + intuition. absurd (false = true); [ auto with bool | apply H; auto ]. intro. - unfold fdec in |- *. + unfold fdec in |- *. case (Pdec x); intuition. Qed. Definition exists_ : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}. - Proof. - intros. + Proof. + intros. generalize (exists_1 (s:=s) (f:=fdec Pdec)) (exists_2 (s:=s) (f:=fdec Pdec)). case (exists_ (fdec Pdec) s); unfold Exists in |- *; [ left | right ]; @@ -190,14 +190,14 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. elim H0; auto; intros. exists x; intuition. generalize H4. - unfold fdec in |- *. + unfold fdec in |- *. case (Pdec x); intuition. inversion H2. - intuition. - elim H2; intros. + intuition. + elim H2; intros. absurd (false = true); [ auto with bool | apply H; auto ]. exists x; intuition. - unfold fdec in |- *. + unfold fdec in |- *. case (Pdec x); intuition. Qed. @@ -217,7 +217,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. intros s1 s2; simpl in |- *. intros; assert (compat_bool E.eq (fdec Pdec)); auto. intros; assert (compat_bool E.eq (fun x => negb (fdec Pdec x))). - generalize H2; unfold compat_bool in |- *; intuition; + generalize H2; unfold compat_bool, Proper, respectful in |- *; intuition; apply (f_equal negb); auto. intuition. generalize H4; unfold For_all, Equal in |- *; intuition. @@ -228,12 +228,12 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. inversion H9. generalize H; unfold For_all, Equal in |- *; intuition. elim (H0 x); intros. - cut ((fun x => negb (fdec Pdec x)) x = true). + cut ((fun x => negb (fdec Pdec x)) x = true). unfold fdec in |- *; case (Pdec x); intuition. change ((fun x => negb (fdec Pdec x)) x = true) in |- *. apply (filter_2 (s:=s) (x:=x)); auto. set (b := fdec Pdec x) in *; generalize (refl_equal b); - pattern b at -1 in |- *; case b; unfold b in |- *; + pattern b at -1 in |- *; case b; unfold b in |- *; [ left | right ]. elim (H4 x); intros _ B; apply B; auto with set. elim (H x); intros _ B; apply B; auto with set. @@ -242,16 +242,16 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B; auto. eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; auto. - Qed. + Qed. - Definition choose_aux: forall s : t, + Definition choose_aux: forall s : t, { x : elt | M.choose s = Some x } + { M.choose s = None }. Proof. intros. destruct (M.choose s); [left | right]; auto. exists e; auto. Qed. - + Definition choose : forall s : t, {x : elt | In x s} + {Empty s}. Proof. intros; destruct (choose_aux s) as [(x,Hx)|H]. @@ -259,12 +259,12 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. right; apply choose_2; auto. Defined. - Lemma choose_ok1 : - forall s x, M.choose s = Some x <-> exists H:In x s, + Lemma choose_ok1 : + forall s x, M.choose s = Some x <-> exists H:In x s, choose s = inleft _ (exist (fun x => In x s) x H). Proof. intros s x. - unfold choose; split; intros. + unfold choose; split; intros. destruct (choose_aux s) as [(y,Hy)|H']; try congruence. replace x with y in * by congruence. exists (choose_1 Hy); auto. @@ -272,10 +272,10 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. destruct (choose_aux s) as [(y,Hy)|H']; congruence. Qed. - Lemma choose_ok2 : - forall s, M.choose s = None <-> exists H:Empty s, + Lemma choose_ok2 : + forall s, M.choose s = None <-> exists H:Empty s, choose s = inright _ H. - Proof. + Proof. intros s. unfold choose; split; intros. destruct (choose_aux s) as [(y,Hy)|H']; try congruence. @@ -284,8 +284,8 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. destruct (choose_aux s) as [(y,Hy)|H']; congruence. Qed. - Lemma choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with + Lemma choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with | inleft (exist x _), inleft (exist x' _) => E.eq x x' | inright _, inright _ => True | _, _ => False @@ -306,29 +306,27 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition min_elt : forall s : t, {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}. - Proof. + Proof. intros; generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)). - case (min_elt s); [ left | right ]; auto. + case (min_elt s); [ left | right ]; auto. exists e; unfold For_all in |- *; eauto. - Qed. + Qed. Definition max_elt : forall s : t, {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}. - Proof. + Proof. intros; generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)). - case (max_elt s); [ left | right ]; auto. + case (max_elt s); [ left | right ]; auto. exists e; unfold For_all in |- *; eauto. - Qed. - - Module E := E. + Qed. Definition elt := elt. Definition t := t. - Definition In := In. + Definition In := In. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Empty s := forall a : elt, ~ In a s. @@ -336,7 +334,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. forall x : elt, In x s -> P x. Definition Exists (P : elt -> Prop) (s : t) := exists x : elt, In x s /\ P x. - + Definition eq_In := In_1. Definition eq := Equal. @@ -344,10 +342,12 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition eq_refl := eq_refl. Definition eq_sym := eq_sym. Definition eq_trans := eq_trans. - Definition lt_trans := lt_trans. + Definition lt_trans := lt_trans. Definition lt_not_eq := lt_not_eq. Definition compare := compare. + Module E := E. + End DepOfNodep. @@ -386,7 +386,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Proof. intros; unfold mem in |- *; case (M.mem x s); auto. Qed. - + Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. Proof. intros s x; unfold mem in |- *; case (M.mem x s); auto. @@ -399,26 +399,26 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. if equal s s' then true else false. Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true. - Proof. + Proof. intros; unfold equal in |- *; case M.equal; intuition. - Qed. - + Qed. + Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'. - Proof. + Proof. intros s s'; unfold equal in |- *; case (M.equal s s'); intuition; inversion H. Qed. - + Definition subset (s s' : t) : bool := if subset s s' then true else false. Lemma subset_1 : forall s s' : t, Subset s s' -> subset s s' = true. - Proof. + Proof. intros; unfold subset in |- *; case M.subset; intuition. - Qed. - + Qed. + Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'. - Proof. + Proof. intros s s'; unfold subset in |- *; case (M.subset s s'); intuition; inversion H. Qed. @@ -441,34 +441,34 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. intro s; unfold choose in |- *; case (M.choose s); auto. simple destruct s0; intros; discriminate H. Qed. - - Lemma choose_3 : forall s s' x x', + + Lemma choose_3 : forall s s' x x', choose s = Some x -> choose s' = Some x' -> Equal s s' -> E.eq x x'. Proof. unfold choose; intros. generalize (M.choose_equal H1); clear H1. - destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; + destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; simpl; auto; congruence. Qed. - Definition elements (s : t) : list elt := let (l, _) := elements s in l. - + Definition elements (s : t) : list elt := let (l, _) := elements s in l. + Lemma elements_1 : forall (s : t) (x : elt), In x s -> InA E.eq x (elements s). - Proof. + Proof. intros; unfold elements in |- *; case (M.elements s); firstorder. Qed. Lemma elements_2 : forall (s : t) (x : elt), InA E.eq x (elements s) -> In x s. - Proof. + Proof. intros s x; unfold elements in |- *; case (M.elements s); firstorder. Qed. - Lemma elements_3 : forall s : t, sort E.lt (elements s). - Proof. + Lemma elements_3 : forall s : t, sort E.lt (elements s). + Proof. intros; unfold elements in |- *; case (M.elements s); firstorder. Qed. Hint Resolve elements_3. - + Lemma elements_3w : forall s : t, NoDupA E.eq (elements s). Proof. auto. Qed. @@ -478,27 +478,27 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. | inright _ => None end. - Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. + Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. Proof. intros s x; unfold min_elt in |- *; case (M.min_elt s). simple destruct s0; intros; injection H; intros; subst; intuition. intros; discriminate H. - Qed. + Qed. Lemma min_elt_2 : - forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. + forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. Proof. intros s x y; unfold min_elt in |- *; case (M.min_elt s). unfold For_all in |- *; simple destruct s0; intros; injection H; intros; subst; firstorder. intros; discriminate H. - Qed. + Qed. Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s. Proof. intros s; unfold min_elt in |- *; case (M.min_elt s); auto. simple destruct s0; intros; discriminate H. - Qed. + Qed. Definition max_elt (s : t) : option elt := match max_elt s with @@ -506,27 +506,27 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. | inright _ => None end. - Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. + Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. Proof. intros s x; unfold max_elt in |- *; case (M.max_elt s). simple destruct s0; intros; injection H; intros; subst; intuition. intros; discriminate H. - Qed. + Qed. Lemma max_elt_2 : - forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. + forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. Proof. intros s x y; unfold max_elt in |- *; case (M.max_elt s). unfold For_all in |- *; simple destruct s0; intros; injection H; intros; subst; firstorder. intros; discriminate H. - Qed. + Qed. Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s. Proof. intros s; unfold max_elt in |- *; case (M.max_elt s); auto. simple destruct s0; intros; discriminate H. - Qed. + Qed. Definition add (x : elt) (s : t) : t := let (s', _) := add x s in s'. @@ -566,70 +566,70 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Proof. intros s x y; unfold remove in |- *; case (M.remove x s); firstorder. Qed. - - Definition singleton (x : elt) : t := let (s, _) := singleton x in s. - - Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y. + + Definition singleton (x : elt) : t := let (s, _) := singleton x in s. + + Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y. Proof. intros x y; unfold singleton in |- *; case (M.singleton x); firstorder. Qed. - Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x). + Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x). Proof. intros x y; unfold singleton in |- *; case (M.singleton x); firstorder. Qed. - + Definition union (s s' : t) : t := let (s'', _) := union s s' in s''. - + Lemma union_1 : forall (s s' : t) (x : elt), In x (union s s') -> In x s \/ In x s'. - Proof. + Proof. intros s s' x; unfold union in |- *; case (M.union s s'); firstorder. Qed. - Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s'). - Proof. + Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s'). + Proof. intros s s' x; unfold union in |- *; case (M.union s s'); firstorder. Qed. Lemma union_3 : forall (s s' : t) (x : elt), In x s' -> In x (union s s'). - Proof. + Proof. intros s s' x; unfold union in |- *; case (M.union s s'); firstorder. Qed. Definition inter (s s' : t) : t := let (s'', _) := inter s s' in s''. - + Lemma inter_1 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s. - Proof. + Proof. intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder. Qed. Lemma inter_2 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s'. - Proof. + Proof. intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder. Qed. Lemma inter_3 : forall (s s' : t) (x : elt), In x s -> In x s' -> In x (inter s s'). - Proof. + Proof. intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder. Qed. Definition diff (s s' : t) : t := let (s'', _) := diff s s' in s''. - + Lemma diff_1 : forall (s s' : t) (x : elt), In x (diff s s') -> In x s. - Proof. + Proof. intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. Qed. Lemma diff_2 : forall (s s' : t) (x : elt), In x (diff s s') -> ~ In x s'. - Proof. + Proof. intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. Qed. Lemma diff_3 : forall (s s' : t) (x : elt), In x s -> ~ In x s' -> In x (diff s s'). - Proof. + Proof. intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. Qed. @@ -637,36 +637,37 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Lemma cardinal_1 : forall s, cardinal s = length (elements s). Proof. - intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *; + intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *; destruct (M.elements s); auto. Qed. - Definition fold (B : Type) (f : elt -> B -> B) (i : t) + Definition fold (B : Type) (f : elt -> B -> B) (i : t) (s : B) : B := let (fold, _) := fold f i s in fold. Lemma fold_1 : forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. - intros; unfold fold in |- *; case (M.fold f s i); unfold elements in *; + intros; unfold fold in |- *; case (M.fold f s i); unfold elements in *; destruct (M.elements s); auto. - Qed. + Qed. Definition f_dec : forall (f : elt -> bool) (x : elt), {f x = true} + {f x <> true}. Proof. intros; case (f x); auto with bool. - Defined. + Defined. Lemma compat_P_aux : forall f : elt -> bool, compat_bool E.eq f -> compat_P E.eq (fun x => f x = true). Proof. - unfold compat_bool, compat_P in |- *; intros; rewrite <- H1; firstorder. + unfold compat_bool, compat_P, Proper, respectful, impl; intros; + rewrite <- H1; firstorder. Qed. Hint Resolve compat_P_aux. - + Definition filter (f : elt -> bool) (s : t) : t := let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'. @@ -680,7 +681,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Lemma filter_2 : forall (s : t) (x : elt) (f : elt -> bool), - compat_bool E.eq f -> In x (filter f s) -> f x = true. + compat_bool E.eq f -> In x (filter f s) -> f x = true. Proof. intros s x f; unfold filter in |- *; case M.filter; intuition. generalize (i (compat_P_aux H)); firstorder. @@ -688,7 +689,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. 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). + compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). Proof. intros s x f; unfold filter in |- *; case M.filter; intuition. generalize (i (compat_P_aux H)); firstorder. @@ -697,98 +698,97 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Definition for_all (f : elt -> bool) (s : t) : bool := if for_all (P:=fun x => f x = true) (f_dec f) s then true - else false. + else false. Lemma for_all_1 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. - Proof. + Proof. intros s f; unfold for_all in |- *; case M.for_all; intuition; elim n; auto. Qed. - + Lemma for_all_2 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. - Proof. + Proof. intros s f; unfold for_all in |- *; case M.for_all; intuition; inversion H0. Qed. - + Definition exists_ (f : elt -> bool) (s : t) : bool := if exists_ (P:=fun x => f x = true) (f_dec f) s then true - else false. + else false. Lemma exists_1 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. + Proof. intros s f; unfold exists_ in |- *; case M.exists_; intuition; elim n; auto. Qed. - + Lemma exists_2 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. + Proof. intros s f; unfold exists_ in |- *; case M.exists_; intuition; inversion H0. Qed. - - Definition partition (f : elt -> bool) (s : t) : + + Definition partition (f : elt -> bool) (s : t) : t * t := let (p, _) := partition (P:=fun x => f x = true) (f_dec f) s in p. - + Lemma partition_1 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). Proof. - intros s f; unfold partition in |- *; case M.partition. - intro p; case p; clear p; intros s1 s2 H C. + intros s f; unfold partition in |- *; case M.partition. + intro p; case p; clear p; intros s1 s2 H C. generalize (H (compat_P_aux C)); clear H; intro H. simpl in |- *; unfold Equal in |- *; intuition. - apply filter_3; firstorder. - elim (H2 a); intros. - assert (In a s). + apply filter_3; firstorder. + elim (H2 a); intros. + assert (In a s). eapply filter_1; eauto. elim H3; intros; auto. absurd (f a = true). exact (H a H6). - eapply filter_2; eauto. - Qed. - + eapply filter_2; eauto. + Qed. + Lemma partition_2 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). Proof. - intros s f; unfold partition in |- *; case M.partition. - intro p; case p; clear p; intros s1 s2 H C. + intros s f; unfold partition in |- *; case M.partition. + intro p; case p; clear p; intros s1 s2 H C. generalize (H (compat_P_aux C)); clear H; intro H. assert (D : compat_bool E.eq (fun x => negb (f x))). - generalize C; unfold compat_bool in |- *; intros; apply (f_equal negb); + generalize C; unfold compat_bool, Proper, respectful; intros; apply (f_equal negb); auto. simpl in |- *; unfold Equal in |- *; intuition. apply filter_3; firstorder. - elim (H2 a); intros. - assert (In a s). + elim (H2 a); intros. + assert (In a s). eapply filter_1; eauto. elim H3; intros; auto. absurd (f a = true). intro. - generalize (filter_2 D H1). + generalize (filter_2 D H1). rewrite H7; intros H8; inversion H8. exact (H0 a H6). - Qed. + Qed. - Module E := E. Definition elt := elt. Definition t := t. - Definition In := In. + Definition In := In. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Add (x : elt) (s s' : t) := @@ -806,8 +806,10 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Definition eq_refl := eq_refl. Definition eq_sym := eq_sym. Definition eq_trans := eq_trans. - Definition lt_trans := lt_trans. + Definition lt_trans := lt_trans. Definition lt_not_eq := lt_not_eq. Definition compare := compare. + Module E := E. + End NodepOfDep. diff --git a/theories/FSets/FSetCompat.v b/theories/FSets/FSetCompat.v new file mode 100644 index 00000000..c3d614ee --- /dev/null +++ b/theories/FSets/FSetCompat.v @@ -0,0 +1,410 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool. + + Definition In : elt -> t -> Prop := M.In. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + Definition empty : t := M.empty. + Definition is_empty : t -> bool := M.is_empty. + Definition mem : elt -> t -> bool := M.mem. + Definition add : elt -> t -> t := M.add. + Definition singleton : elt -> t := M.singleton. + Definition remove : elt -> t -> t := M.remove. + Definition union : t -> t -> t := M.union. + Definition inter : t -> t -> t := M.inter. + Definition diff : t -> t -> t := M.diff. + Definition eq : t -> t -> Prop := M.eq. + Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec. + Definition equal : t -> t -> bool := M.equal. + Definition subset : t -> t -> bool := M.subset. + Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold. + Definition for_all : (elt -> bool) -> t -> bool := M.for_all. + Definition exists_ : (elt -> bool) -> t -> bool := M.exists_. + Definition filter : (elt -> bool) -> t -> t := M.filter. + Definition partition : (elt -> bool) -> t -> t * t:= M.partition. + Definition cardinal : t -> nat := M.cardinal. + Definition elements : t -> list elt := M.elements. + Definition choose : t -> option elt := M.choose. + + Module MF := MSetFacts.WFacts M. + + Definition In_1 : forall s x y, E.eq x y -> In x s -> In y s + := MF.In_1. + Definition eq_refl : forall s, eq s s + := @Equivalence_Reflexive _ _ M.eq_equiv. + Definition eq_sym : forall s s', eq s s' -> eq s' s + := @Equivalence_Symmetric _ _ M.eq_equiv. + Definition eq_trans : forall s s' s'', eq s s' -> eq s' s'' -> eq s s'' + := @Equivalence_Transitive _ _ M.eq_equiv. + Definition mem_1 : forall s x, In x s -> mem x s = true + := MF.mem_1. + Definition mem_2 : forall s x, mem x s = true -> In x s + := MF.mem_2. + Definition equal_1 : forall s s', Equal s s' -> equal s s' = true + := MF.equal_1. + Definition equal_2 : forall s s', equal s s' = true -> Equal s s' + := MF.equal_2. + Definition subset_1 : forall s s', Subset s s' -> subset s s' = true + := MF.subset_1. + Definition subset_2 : forall s s', subset s s' = true -> Subset s s' + := MF.subset_2. + Definition empty_1 : Empty empty := MF.empty_1. + Definition is_empty_1 : forall s, Empty s -> is_empty s = true + := MF.is_empty_1. + Definition is_empty_2 : forall s, is_empty s = true -> Empty s + := MF.is_empty_2. + Definition add_1 : forall s x y, E.eq x y -> In y (add x s) + := MF.add_1. + Definition add_2 : forall s x y, In y s -> In y (add x s) + := MF.add_2. + Definition add_3 : forall s x y, ~ E.eq x y -> In y (add x s) -> In y s + := MF.add_3. + Definition remove_1 : forall s x y, E.eq x y -> ~ In y (remove x s) + := MF.remove_1. + Definition remove_2 : forall s x y, ~ E.eq x y -> In y s -> In y (remove x s) + := MF.remove_2. + Definition remove_3 : forall s x y, In y (remove x s) -> In y s + := MF.remove_3. + Definition union_1 : forall s s' x, In x (union s s') -> In x s \/ In x s' + := MF.union_1. + Definition union_2 : forall s s' x, In x s -> In x (union s s') + := MF.union_2. + Definition union_3 : forall s s' x, In x s' -> In x (union s s') + := MF.union_3. + Definition inter_1 : forall s s' x, In x (inter s s') -> In x s + := MF.inter_1. + Definition inter_2 : forall s s' x, In x (inter s s') -> In x s' + := MF.inter_2. + Definition inter_3 : forall s s' x, In x s -> In x s' -> In x (inter s s') + := MF.inter_3. + Definition diff_1 : forall s s' x, In x (diff s s') -> In x s + := MF.diff_1. + Definition diff_2 : forall s s' x, In x (diff s s') -> ~ In x s' + := MF.diff_2. + Definition diff_3 : forall s s' x, In x s -> ~ In x s' -> In x (diff s s') + := MF.diff_3. + Definition singleton_1 : forall x y, In y (singleton x) -> E.eq x y + := MF.singleton_1. + Definition singleton_2 : forall x y, E.eq x y -> In y (singleton x) + := MF.singleton_2. + Definition fold_1 : forall s (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i + := MF.fold_1. + Definition cardinal_1 : forall s, cardinal s = length (elements s) + := MF.cardinal_1. + Definition filter_1 : forall s x f, compat_bool E.eq f -> + In x (filter f s) -> In x s + := MF.filter_1. + Definition filter_2 : forall s x f, compat_bool E.eq f -> + In x (filter f s) -> f x = true + := MF.filter_2. + Definition filter_3 : forall s x f, compat_bool E.eq f -> + In x s -> f x = true -> In x (filter f s) + := MF.filter_3. + Definition for_all_1 : forall s f, compat_bool E.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true + := MF.for_all_1. + Definition for_all_2 : forall s f, compat_bool E.eq f -> + for_all f s = true -> For_all (fun x => f x = true) s + := MF.for_all_2. + Definition exists_1 : forall s f, compat_bool E.eq f -> + Exists (fun x => f x = true) s -> exists_ f s = true + := MF.exists_1. + Definition exists_2 : forall s f, compat_bool E.eq f -> + exists_ f s = true -> Exists (fun x => f x = true) s + := MF.exists_2. + Definition partition_1 : forall s f, compat_bool E.eq f -> + Equal (fst (partition f s)) (filter f s) + := MF.partition_1. + Definition partition_2 : forall s f, compat_bool E.eq f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) + := MF.partition_2. + Definition choose_1 : forall s x, choose s = Some x -> In x s + := MF.choose_1. + Definition choose_2 : forall s, choose s = None -> Empty s + := MF.choose_2. + Definition elements_1 : forall s x, In x s -> InA E.eq x (elements s) + := MF.elements_1. + Definition elements_2 : forall s x, InA E.eq x (elements s) -> In x s + := MF.elements_2. + Definition elements_3w : forall s, NoDupA E.eq (elements s) + := MF.elements_3w. + +End Backport_WSets. + + +(** * From new Sets to new ones *) + +Module Backport_Sets + (E:OrderedType.OrderedType) + (M:MSetInterface.Sets with Definition E.t := E.t + with Definition E.eq := E.eq + with Definition E.lt := E.lt) + <: FSetInterface.S with Module E:=E. + + Include Backport_WSets E M. + + Implicit Type s : t. + Implicit Type x y : elt. + + Definition lt : t -> t -> Prop := M.lt. + Definition min_elt : t -> option elt := M.min_elt. + Definition max_elt : t -> option elt := M.max_elt. + Definition min_elt_1 : forall s x, min_elt s = Some x -> In x s + := M.min_elt_spec1. + Definition min_elt_2 : forall s x y, + min_elt s = Some x -> In y s -> ~ E.lt y x + := M.min_elt_spec2. + Definition min_elt_3 : forall s, min_elt s = None -> Empty s + := M.min_elt_spec3. + Definition max_elt_1 : forall s x, max_elt s = Some x -> In x s + := M.max_elt_spec1. + Definition max_elt_2 : forall s x y, + max_elt s = Some x -> In y s -> ~ E.lt x y + := M.max_elt_spec2. + Definition max_elt_3 : forall s, max_elt s = None -> Empty s + := M.max_elt_spec3. + Definition elements_3 : forall s, sort E.lt (elements s) + := M.elements_spec2. + Definition choose_3 : forall s s' x y, + choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y + := M.choose_spec3. + Definition lt_trans : forall s s' s'', lt s s' -> lt s' s'' -> lt s s'' + := @StrictOrder_Transitive _ _ M.lt_strorder. + Lemma lt_not_eq : forall s s', lt s s' -> ~ eq s s'. + Proof. + unfold lt, eq. intros s s' Hlt Heq. rewrite Heq in Hlt. + apply (StrictOrder_Irreflexive s'); auto. + Qed. + Definition compare : forall s s', Compare lt eq s s'. + Proof. + intros s s'; destruct (CompSpec2Type (M.compare_spec s s')); + [ apply EQ | apply LT | apply GT ]; auto. + Defined. + + Module E := E. + +End Backport_Sets. + + +(** * From old Weak Sets to new ones. *) + +Module Update_WSets + (E:Equalities.DecidableType) + (M:FSetInterface.WS with Definition E.t := E.t + with Definition E.eq := E.eq) + <: MSetInterface.WSetsOn E. + + Definition elt := E.t. + Definition t := M.t. + + Implicit Type s : t. + Implicit Type x y : elt. + Implicit Type f : elt -> bool. + + Definition In : elt -> t -> Prop := M.In. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + Definition empty : t := M.empty. + Definition is_empty : t -> bool := M.is_empty. + Definition mem : elt -> t -> bool := M.mem. + Definition add : elt -> t -> t := M.add. + Definition singleton : elt -> t := M.singleton. + Definition remove : elt -> t -> t := M.remove. + Definition union : t -> t -> t := M.union. + Definition inter : t -> t -> t := M.inter. + Definition diff : t -> t -> t := M.diff. + Definition eq : t -> t -> Prop := M.eq. + Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec. + Definition equal : t -> t -> bool := M.equal. + Definition subset : t -> t -> bool := M.subset. + Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold. + Definition for_all : (elt -> bool) -> t -> bool := M.for_all. + Definition exists_ : (elt -> bool) -> t -> bool := M.exists_. + Definition filter : (elt -> bool) -> t -> t := M.filter. + Definition partition : (elt -> bool) -> t -> t * t:= M.partition. + Definition cardinal : t -> nat := M.cardinal. + Definition elements : t -> list elt := M.elements. + Definition choose : t -> option elt := M.choose. + + Module MF := FSetFacts.WFacts M. + + Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In. + Proof. intros x x' Hx s s' Hs. subst. apply MF.In_eq_iff; auto. Qed. + + Instance eq_equiv : Equivalence eq. + + Section Spec. + Variable s s': t. + Variable x y : elt. + + Lemma mem_spec : mem x s = true <-> In x s. + Proof. intros; symmetry; apply MF.mem_iff. Qed. + + Lemma equal_spec : equal s s' = true <-> Equal s s'. + Proof. intros; symmetry; apply MF.equal_iff. Qed. + + Lemma subset_spec : subset s s' = true <-> Subset s s'. + Proof. intros; symmetry; apply MF.subset_iff. Qed. + + Definition empty_spec : Empty empty := M.empty_1. + + Lemma is_empty_spec : is_empty s = true <-> Empty s. + Proof. intros; symmetry; apply MF.is_empty_iff. Qed. + + Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s. + Proof. intros. rewrite MF.add_iff. intuition. Qed. + + Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. + Proof. intros. rewrite MF.remove_iff. intuition. Qed. + + Lemma singleton_spec : In y (singleton x) <-> E.eq y x. + Proof. intros; rewrite MF.singleton_iff. intuition. Qed. + + Definition union_spec : In x (union s s') <-> In x s \/ In x s' + := @MF.union_iff s s' x. + Definition inter_spec : In x (inter s s') <-> In x s /\ In x s' + := @MF.inter_iff s s' x. + Definition diff_spec : In x (diff s s') <-> In x s /\ ~In x s' + := @MF.diff_iff s s' x. + Definition fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i + := @M.fold_1 s. + Definition cardinal_spec : cardinal s = length (elements s) + := @M.cardinal_1 s. + + Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s. + Proof. intros; symmetry; apply MF.elements_iff. Qed. + + Definition elements_spec2w : NoDupA E.eq (elements s) + := @M.elements_3w s. + Definition choose_spec1 : choose s = Some x -> In x s + := @M.choose_1 s x. + Definition choose_spec2 : choose s = None -> Empty s + := @M.choose_2 s. + Definition filter_spec : forall f, Proper (E.eq==>Logic.eq) f -> + (In x (filter f s) <-> In x s /\ f x = true) + := @MF.filter_iff s x. + Definition partition_spec1 : forall f, Proper (E.eq==>Logic.eq) f -> + Equal (fst (partition f s)) (filter f s) + := @M.partition_1 s. + Definition partition_spec2 : forall f, Proper (E.eq==>Logic.eq) f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) + := @M.partition_2 s. + + Lemma for_all_spec : forall f, Proper (E.eq==>Logic.eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. intros; symmetry; apply MF.for_all_iff; auto. Qed. + + Lemma exists_spec : forall f, Proper (E.eq==>Logic.eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. intros; symmetry; apply MF.exists_iff; auto. Qed. + + End Spec. + +End Update_WSets. + + +(** * From old Sets to new ones. *) + +Module Update_Sets + (E:Orders.OrderedType) + (M:FSetInterface.S with Definition E.t := E.t + with Definition E.eq := E.eq + with Definition E.lt := E.lt) + <: MSetInterface.Sets with Module E:=E. + + Include Update_WSets E M. + + Implicit Type s : t. + Implicit Type x y : elt. + + Definition lt : t -> t -> Prop := M.lt. + Definition min_elt : t -> option elt := M.min_elt. + Definition max_elt : t -> option elt := M.max_elt. + Definition min_elt_spec1 : forall s x, min_elt s = Some x -> In x s + := M.min_elt_1. + Definition min_elt_spec2 : forall s x y, + min_elt s = Some x -> In y s -> ~ E.lt y x + := M.min_elt_2. + Definition min_elt_spec3 : forall s, min_elt s = None -> Empty s + := M.min_elt_3. + Definition max_elt_spec1 : forall s x, max_elt s = Some x -> In x s + := M.max_elt_1. + Definition max_elt_spec2 : forall s x y, + max_elt s = Some x -> In y s -> ~ E.lt x y + := M.max_elt_2. + Definition max_elt_spec3 : forall s, max_elt s = None -> Empty s + := M.max_elt_3. + Definition elements_spec2 : forall s, sort E.lt (elements s) + := M.elements_3. + Definition choose_spec3 : forall s s' x y, + choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y + := M.choose_3. + + Instance lt_strorder : StrictOrder lt. + Proof. + split. + intros x Hx. apply (M.lt_not_eq Hx); auto with *. + exact M.lt_trans. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + intros s s' Hs u u' Hu H. + assert (H0 : lt s' u). + destruct (M.compare s' u) as [H'|H'|H']; auto. + elim (M.lt_not_eq H). transitivity s'; auto with *. + elim (M.lt_not_eq (M.lt_trans H H')); auto. + destruct (M.compare s' u') as [H'|H'|H']; auto. + elim (M.lt_not_eq H). + transitivity u'; auto with *. transitivity s'; auto with *. + elim (M.lt_not_eq (M.lt_trans H' H0)); auto with *. + Qed. + + Definition compare s s' := + match M.compare s s' with + | EQ _ => Eq + | LT _ => Lt + | GT _ => Gt + end. + + Lemma compare_spec : forall s s', CompSpec eq lt s s' (compare s s'). + Proof. intros; unfold compare; destruct M.compare; auto. Qed. + + Module E := E. + +End Update_Sets. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index f84d8f58..b7d6382e 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetDecide.v 13199 2010-06-25 22:36:22Z letouzey $ *) +(* $Id$ *) (**************************************************************) (* FSetDecide.v *) @@ -148,35 +148,35 @@ the above form: XXX: This tactic and the similar subsequent ones should have been defined using [autorewrite]. However, dealing - with multiples rewrite sites and side-conditions is - done more cleverly with the following explicit + with multiples rewrite sites and side-conditions is + done more cleverly with the following explicit analysis of goals. *) - Ltac or_not_l_iff P Q tac := - (rewrite (or_not_l_iff_1 P Q) by tac) || + Ltac or_not_l_iff P Q tac := + (rewrite (or_not_l_iff_1 P Q) by tac) || (rewrite (or_not_l_iff_2 P Q) by tac). - Ltac or_not_r_iff P Q tac := - (rewrite (or_not_r_iff_1 P Q) by tac) || + Ltac or_not_r_iff P Q tac := + (rewrite (or_not_r_iff_1 P Q) by tac) || (rewrite (or_not_r_iff_2 P Q) by tac). - Ltac or_not_l_iff_in P Q H tac := - (rewrite (or_not_l_iff_1 P Q) in H by tac) || + Ltac or_not_l_iff_in P Q H tac := + (rewrite (or_not_l_iff_1 P Q) in H by tac) || (rewrite (or_not_l_iff_2 P Q) in H by tac). - Ltac or_not_r_iff_in P Q H tac := - (rewrite (or_not_r_iff_1 P Q) in H by tac) || + Ltac or_not_r_iff_in P Q H tac := + (rewrite (or_not_r_iff_1 P Q) in H by tac) || (rewrite (or_not_r_iff_2 P Q) in H by tac). Tactic Notation "push" "not" "using" ident(db) := - let dec := solve_decidable using db in + let dec := solve_decidable using db in unfold not, iff; repeat ( match goal with | |- context [True -> False] => rewrite not_true_iff | |- context [False -> False] => rewrite not_false_iff | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec - | |- context [(?P -> False) -> (?Q -> False)] => + | |- context [(?P -> False) -> (?Q -> False)] => rewrite (contrapositive P Q) by dec | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec @@ -192,23 +192,23 @@ the above form: Tactic Notation "push" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in + let dec := solve_decidable using db in unfold not, iff in * |-; repeat ( match goal with | H: context [True -> False] |- _ => rewrite not_true_iff in H | H: context [False -> False] |- _ => rewrite not_false_iff in H - | H: context [(?P -> False) -> False] |- _ => + | H: context [(?P -> False) -> False] |- _ => rewrite (not_not_iff P) in H by dec | H: context [(?P -> False) -> (?Q -> False)] |- _ => rewrite (contrapositive P Q) in H by dec | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec - | H: context [(?P -> False) -> ?Q] |- _ => + | H: context [(?P -> False) -> ?Q] |- _ => rewrite (imp_not_l P Q) in H by dec | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H - | H: context [(?P -> ?Q) -> False] |- _ => + | H: context [(?P -> ?Q) -> False] |- _ => rewrite (not_imp_iff P Q) in H by dec end); fold any not. @@ -253,7 +253,7 @@ the above form: the hypotheses and goal together. *) Tactic Notation "pull" "not" "using" ident(db) := - let dec := solve_decidable using db in + let dec := solve_decidable using db in unfold not, iff; repeat ( match goal with @@ -269,7 +269,7 @@ the above form: rewrite <- (not_or_iff P Q) | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec - | |- context [(?Q -> False) /\ ?P] => + | |- context [(?Q -> False) /\ ?P] => rewrite <- (not_imp_rev_iff P Q) by dec end); fold any not. @@ -279,7 +279,7 @@ the above form: Tactic Notation "pull" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in + let dec := solve_decidable using db in unfold not, iff in * |-; repeat ( match goal with @@ -294,8 +294,8 @@ the above form: | H: context [(?P -> False) -> ?Q] |- _ => rewrite (imp_not_l P Q) in H by dec | H: context [(?P -> False) /\ (?Q -> False)] |- _ => - rewrite <- (not_or_iff P Q) in H - | H: context [?P -> ?Q -> False] |- _ => + rewrite <- (not_or_iff P Q) in H + | H: context [?P -> ?Q -> False] |- _ => rewrite <- (not_and_iff P Q) in H | H: context [?P /\ (?Q -> False)] |- _ => rewrite <- (not_imp_iff P Q) in H by dec @@ -673,13 +673,13 @@ the above form: Ltac fsetdec := (** We first unfold any occurrences of [iff]. *) unfold iff in *; - (** We remove dependencies to logical hypothesis. This way, - later "clear" will work nicely (see bug #2136) *) - no_logical_interdep; (** We fold occurrences of [not] because it is better for [intros] to leave us with a goal of [~ P] than a goal of [False]. *) fold any not; intros; + (** We remove dependencies to logical hypothesis. This way, + later "clear" will work nicely (see bug #2136) *) + no_logical_interdep; (** Now we decompose conjunctions, which will allow the [discard_nonFSet] and [assert_decidability] tactics to do a much better job. *) diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index 80ab2b2c..ec0c6a55 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -6,15 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetEqProperties.v 11720 2008-12-28 07:12:15Z letouzey $ *) +(* $Id$ *) (** * Finite sets library *) -(** This module proves many properties of finite sets that - are consequences of the axiomatization in [FsetInterface] - Contrary to the functor in [FsetProperties] it uses +(** This module proves many properties of finite sets that + are consequences of the axiomatization in [FsetInterface] + Contrary to the functor in [FsetProperties] it uses sets operations instead of predicates over sets, i.e. - [mem x s=true] instead of [In x s], + [mem x s=true] instead of [In x s], [equal s s'=true] instead of [Equal s s'], etc. *) Require Import FSetProperties Zerob Sumbool Omega DecidableTypeEx. @@ -26,59 +26,59 @@ Import M. Definition Add := MP.Add. -Section BasicProperties. +Section BasicProperties. -(** Some old specifications written with boolean equalities. *) +(** Some old specifications written with boolean equalities. *) Variable s s' s'': t. Variable x y z : elt. -Lemma mem_eq: +Lemma mem_eq: E.eq x y -> mem x s=mem y s. -Proof. +Proof. intro H; rewrite H; auto. Qed. -Lemma equal_mem_1: +Lemma equal_mem_1: (forall a, mem a s=mem a s') -> equal s s'=true. -Proof. +Proof. intros; apply equal_1; unfold Equal; intros. do 2 rewrite mem_iff; rewrite H; tauto. Qed. -Lemma equal_mem_2: +Lemma equal_mem_2: equal s s'=true -> forall a, mem a s=mem a s'. -Proof. +Proof. intros; rewrite (equal_2 H); auto. Qed. -Lemma subset_mem_1: +Lemma subset_mem_1: (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. -Proof. +Proof. intros; apply subset_1; unfold Subset; intros a. do 2 rewrite mem_iff; auto. Qed. -Lemma subset_mem_2: +Lemma subset_mem_2: subset s s'=true -> forall a, mem a s=true -> mem a s'=true. -Proof. +Proof. intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. Qed. - + Lemma empty_mem: mem x empty=false. -Proof. +Proof. rewrite <- not_mem_iff; auto with set. Qed. Lemma is_empty_equal_empty: is_empty s = equal s empty. -Proof. +Proof. apply bool_1; split; intros. auto with set. rewrite <- is_empty_iff; auto with set. Qed. - + Lemma choose_mem_1: choose s=Some x -> mem x s=true. -Proof. +Proof. auto with set. Qed. @@ -90,44 +90,44 @@ Qed. Lemma add_mem_1: mem x (add x s)=true. Proof. auto with set. -Qed. - +Qed. + Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. -Proof. +Proof. apply add_neq_b. Qed. Lemma remove_mem_1: mem x (remove x s)=false. -Proof. +Proof. rewrite <- not_mem_iff; auto with set. -Qed. - +Qed. + Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. -Proof. +Proof. apply remove_neq_b. Qed. -Lemma singleton_equal_add: +Lemma singleton_equal_add: equal (singleton x) (add x empty)=true. Proof. rewrite (singleton_equal_add x); auto with set. -Qed. +Qed. -Lemma union_mem: +Lemma union_mem: mem x (union s s')=mem x s || mem x s'. -Proof. +Proof. apply union_b. Qed. -Lemma inter_mem: +Lemma inter_mem: mem x (inter s s')=mem x s && mem x s'. -Proof. +Proof. apply inter_b. Qed. -Lemma diff_mem: +Lemma diff_mem: mem x (diff s s')=mem x s && negb (mem x s'). -Proof. +Proof. apply diff_b. Qed. @@ -143,7 +143,7 @@ Proof. intros; rewrite not_mem_iff; auto. Qed. -(** Properties of [equal] *) +(** Properties of [equal] *) Lemma equal_refl: equal s s=true. Proof. @@ -155,19 +155,19 @@ Proof. intros; apply bool_1; do 2 rewrite <- equal_iff; intuition. Qed. -Lemma equal_trans: +Lemma equal_trans: equal s s'=true -> equal s' s''=true -> equal s s''=true. Proof. intros; rewrite (equal_2 H); auto. Qed. -Lemma equal_equal: +Lemma equal_equal: equal s s'=true -> equal s s''=equal s' s''. Proof. intros; rewrite (equal_2 H); auto. Qed. -Lemma equal_cardinal: +Lemma equal_cardinal: equal s s'=true -> cardinal s=cardinal s'. Proof. auto with set. @@ -175,25 +175,25 @@ Qed. (* Properties of [subset] *) -Lemma subset_refl: subset s s=true. +Lemma subset_refl: subset s s=true. Proof. auto with set. Qed. -Lemma subset_antisym: +Lemma subset_antisym: subset s s'=true -> subset s' s=true -> equal s s'=true. Proof. auto with set. Qed. -Lemma subset_trans: +Lemma subset_trans: subset s s'=true -> subset s' s''=true -> subset s s''=true. Proof. do 3 rewrite <- subset_iff; intros. apply subset_trans with s'; auto. Qed. -Lemma subset_equal: +Lemma subset_equal: equal s s'=true -> subset s s'=true. Proof. auto with set. @@ -201,7 +201,7 @@ Qed. (** Properties of [choose] *) -Lemma choose_mem_3: +Lemma choose_mem_3: is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. Proof. intros. @@ -221,13 +221,13 @@ Qed. (** Properties of [add] *) -Lemma add_mem_3: +Lemma add_mem_3: mem y s=true -> mem y (add x s)=true. Proof. auto with set. Qed. -Lemma add_equal: +Lemma add_equal: mem x s=true -> equal (add x s) s=true. Proof. auto with set. @@ -235,26 +235,26 @@ Qed. (** Properties of [remove] *) -Lemma remove_mem_3: +Lemma remove_mem_3: mem y (remove x s)=true -> mem y s=true. Proof. rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. Qed. -Lemma remove_equal: +Lemma remove_equal: mem x s=false -> equal (remove x s) s=true. Proof. intros; apply equal_1; apply remove_equal. rewrite not_mem_iff; auto. Qed. -Lemma add_remove: +Lemma add_remove: mem x s=true -> equal (add x (remove x s)) s=true. Proof. intros; apply equal_1; apply add_remove; auto with set. Qed. -Lemma remove_add: +Lemma remove_add: mem x s=false -> equal (remove x (add x s)) s=true. Proof. intros; apply equal_1; apply remove_add; auto. @@ -297,37 +297,37 @@ Proof. auto with set. Qed. -Lemma union_subset_equal: +Lemma union_subset_equal: subset s s'=true -> equal (union s s') s'=true. Proof. auto with set. Qed. -Lemma union_equal_1: +Lemma union_equal_1: equal s s'=true-> equal (union s s'') (union s' s'')=true. Proof. auto with set. Qed. -Lemma union_equal_2: +Lemma union_equal_2: equal s' s''=true-> equal (union s s') (union s s'')=true. Proof. auto with set. Qed. -Lemma union_assoc: +Lemma union_assoc: equal (union (union s s') s'') (union s (union s' s''))=true. Proof. auto with set. Qed. -Lemma add_union_singleton: +Lemma add_union_singleton: equal (add x s) (union (singleton x) s)=true. Proof. auto with set. Qed. -Lemma union_add: +Lemma union_add: equal (union (add x s) s') (add x (union s s'))=true. Proof. auto with set. @@ -346,62 +346,62 @@ auto with set. Qed. Lemma union_subset_3: - subset s s''=true -> subset s' s''=true -> + subset s s''=true -> subset s' s''=true -> subset (union s s') s''=true. Proof. intros; apply subset_1; apply union_subset_3; auto with set. Qed. -(** Properties of [inter] *) +(** Properties of [inter] *) Lemma inter_sym: equal (inter s s') (inter s' s)=true. Proof. auto with set. Qed. -Lemma inter_subset_equal: +Lemma inter_subset_equal: subset s s'=true -> equal (inter s s') s=true. Proof. auto with set. Qed. -Lemma inter_equal_1: +Lemma inter_equal_1: equal s s'=true -> equal (inter s s'') (inter s' s'')=true. Proof. auto with set. Qed. -Lemma inter_equal_2: +Lemma inter_equal_2: equal s' s''=true -> equal (inter s s') (inter s s'')=true. Proof. auto with set. Qed. -Lemma inter_assoc: +Lemma inter_assoc: equal (inter (inter s s') s'') (inter s (inter s' s''))=true. Proof. auto with set. Qed. -Lemma union_inter_1: +Lemma union_inter_1: equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. Proof. auto with set. Qed. -Lemma union_inter_2: +Lemma union_inter_2: equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. Proof. auto with set. Qed. -Lemma inter_add_1: mem x s'=true -> +Lemma inter_add_1: mem x s'=true -> equal (inter (add x s) s') (add x (inter s s'))=true. Proof. auto with set. Qed. -Lemma inter_add_2: mem x s'=false -> +Lemma inter_add_2: mem x s'=false -> equal (inter (add x s) s') (inter s s')=true. Proof. intros; apply equal_1; apply inter_add_2. @@ -421,7 +421,7 @@ auto with set. Qed. Lemma inter_subset_3: - subset s'' s=true -> subset s'' s'=true -> + subset s'' s=true -> subset s'' s'=true -> subset s'' (inter s s')=true. Proof. intros; apply subset_1; apply inter_subset_3; auto with set. @@ -440,19 +440,19 @@ Proof. auto with set. Qed. -Lemma remove_inter_singleton: +Lemma remove_inter_singleton: equal (remove x s) (diff s (singleton x))=true. Proof. auto with set. Qed. Lemma diff_inter_empty: - equal (inter (diff s s') (inter s s')) empty=true. + equal (inter (diff s s') (inter s s')) empty=true. Proof. auto with set. Qed. -Lemma diff_inter_all: +Lemma diff_inter_all: equal (union (diff s s') (inter s s')) s=true. Proof. auto with set. @@ -462,7 +462,7 @@ End BasicProperties. Hint Immediate empty_mem is_empty_equal_empty add_mem_1 remove_mem_1 singleton_equal_add union_mem inter_mem - diff_mem equal_sym add_remove remove_add : set. + diff_mem equal_sym add_remove remove_add : set. Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal subset_refl subset_equal subset_antisym @@ -472,8 +472,8 @@ Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 (** General recursion principle *) Lemma set_rec: forall (P:t->Type), - (forall s s', equal s s'=true -> P s -> P s') -> - (forall s x, mem x s=false -> P s -> P (add x s)) -> + (forall s s', equal s s'=true -> P s -> P s') -> + (forall s x, mem x s=false -> P s -> P (add x s)) -> P empty -> forall s, P s. Proof. intros. @@ -493,51 +493,51 @@ intros; do 2 rewrite mem_iff. destruct (mem x s); destruct (mem x s'); intuition. Qed. -Section Fold. +Section Fold. Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). Variables (i:A). Variables (s s':t)(x:elt). - + Lemma fold_empty: (fold f empty i) = i. -Proof. +Proof. apply fold_empty; auto. Qed. -Lemma fold_equal: +Lemma fold_equal: equal s s'=true -> eqA (fold f s i) (fold f s' i). -Proof. +Proof. intros; apply fold_equal with (eqA:=eqA); auto with set. Qed. - -Lemma fold_add: + +Lemma fold_add: mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). -Proof. +Proof. intros; apply fold_add with (eqA:=eqA); auto. rewrite not_mem_iff; auto. Qed. -Lemma add_fold: +Lemma add_fold: mem x s=true -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply add_fold with (eqA:=eqA); auto with set. Qed. -Lemma remove_fold_1: +Lemma remove_fold_1: mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). Proof. intros; apply remove_fold_1 with (eqA:=eqA); auto with set. Qed. -Lemma remove_fold_2: +Lemma remove_fold_2: mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros; apply remove_fold_2 with (eqA:=eqA); auto. rewrite not_mem_iff; auto. Qed. -Lemma fold_union: - (forall x, mem x s && mem x s'=false) -> +Lemma fold_union: + (forall x, mem x s && mem x s'=false) -> eqA (fold f (union s s') i) (fold f s (fold f s' i)). Proof. intros; apply fold_union with (eqA:=eqA); auto. @@ -548,40 +548,40 @@ End Fold. (** Properties of [cardinal] *) -Lemma add_cardinal_1: +Lemma add_cardinal_1: forall s x, mem x s=true -> cardinal (add x s)=cardinal s. Proof. auto with set. Qed. -Lemma add_cardinal_2: +Lemma add_cardinal_2: forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). Proof. intros; apply add_cardinal_2; auto. rewrite not_mem_iff; auto. Qed. -Lemma remove_cardinal_1: +Lemma remove_cardinal_1: forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. Proof. intros; apply remove_cardinal_1; auto with set. Qed. -Lemma remove_cardinal_2: +Lemma remove_cardinal_2: forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. Proof. intros; apply Equal_cardinal; apply equal_2; auto with set. Qed. -Lemma union_cardinal: - forall s s', (forall x, mem x s && mem x s'=false) -> +Lemma union_cardinal: + forall s s', (forall x, mem x s && mem x s'=false) -> cardinal (union s s')=cardinal s+cardinal s'. Proof. intros; apply union_cardinal; auto; intros. rewrite exclusive_set; auto. Qed. -Lemma subset_cardinal: +Lemma subset_cardinal: forall s s', subset s s'=true -> cardinal s<=cardinal s'. Proof. intros; apply subset_cardinal; auto with set. @@ -592,24 +592,24 @@ Section Bool. (** Properties of [filter] *) Variable f:elt->bool. -Variable Comp: compat_bool E.eq f. +Variable Comp: Proper (E.eq==>Logic.eq) f. -Let Comp' : compat_bool E.eq (fun x =>negb (f x)). +Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)). Proof. -unfold compat_bool in *; intros; f_equal; auto. +repeat red; intros; f_equal; auto. Qed. Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. -Proof. +Proof. intros; apply filter_b; auto. Qed. -Lemma for_all_filter: +Lemma for_all_filter: forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). -Proof. +Proof. intros; apply bool_1; split; intros. apply is_empty_1. -unfold Empty; intros. +unfold Empty; intros. rewrite filter_iff; auto. red; destruct 1. rewrite <- (@for_all_iff s f) in H; auto. @@ -621,10 +621,10 @@ rewrite filter_iff; auto. destruct (f x); auto. Qed. -Lemma exists_filter : +Lemma exists_filter : forall s, exists_ f s=negb (is_empty (filter f s)). -Proof. -intros; apply bool_1; split; intros. +Proof. +intros; apply bool_1; split; intros. destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). apply bool_6. red; intros; apply (@is_empty_2 _ H0 a); auto with set. @@ -636,28 +636,28 @@ intros _ H0. rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate. Qed. -Lemma partition_filter_1: +Lemma partition_filter_1: forall s, equal (fst (partition f s)) (filter f s)=true. -Proof. +Proof. auto with set. Qed. -Lemma partition_filter_2: +Lemma partition_filter_2: forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. -Proof. +Proof. auto with set. Qed. -Lemma filter_add_1 : forall s x, f x = true -> - filter f (add x s) [=] add x (filter f s). +Lemma filter_add_1 : forall s x, f x = true -> + filter f (add x s) [=] add x (filter f s). Proof. red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. intuition. rewrite <- H; apply Comp; auto. Qed. -Lemma filter_add_2 : forall s x, f x = false -> - filter f (add x s) [=] filter f s. +Lemma filter_add_2 : forall s x, f x = false -> + filter f (add x s) [=] filter f s. Proof. red; intros; do 2 (rewrite filter_iff; auto); set_iff. intuition. @@ -665,18 +665,18 @@ assert (f x = f a) by (apply Comp; auto). rewrite H in H1; rewrite H2 in H1; discriminate. Qed. -Lemma add_filter_1 : forall s s' x, +Lemma add_filter_1 : forall s s' x, f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). Proof. unfold Add, MP.Add; intros. repeat rewrite filter_iff; auto. rewrite H0; clear H0. -assert (E.eq x y -> f y = true) by +assert (E.eq x y -> f y = true) by (intro H0; rewrite <- (Comp _ _ H0); auto). tauto. Qed. -Lemma add_filter_2 : forall s s' x, +Lemma add_filter_2 : forall s s' x, f x=false -> (Add x s s') -> filter f s [=] filter f s'. Proof. unfold Add, MP.Add, Equal; intros. @@ -686,7 +686,7 @@ assert (f a = true -> ~E.eq x a). intros H0 H1. rewrite (Comp _ _ H1) in H. rewrite H in H0; discriminate. -tauto. +tauto. Qed. Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) -> @@ -695,7 +695,7 @@ Proof. clear Comp' Comp f. intros. assert (compat_bool E.eq (fun x => orb (f x) (g x))). - unfold compat_bool; intros. + unfold compat_bool, Proper, respectful; intros. rewrite (H x y H1); rewrite (H0 x y H1); auto. unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. assert (f a || g a = true <-> f a = true \/ g a = true). @@ -711,7 +711,7 @@ Qed. (** Properties of [for_all] *) -Lemma for_all_mem_1: forall s, +Lemma for_all_mem_1: forall s, (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. Proof. intros. @@ -724,8 +724,8 @@ generalize (H a); case (mem a s);intros;auto. rewrite H0;auto. Qed. -Lemma for_all_mem_2: forall s, - (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. +Lemma for_all_mem_2: forall s, + (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. Proof. intros. rewrite for_all_filter in H; auto. @@ -734,10 +734,10 @@ generalize (equal_mem_2 _ _ H x). rewrite filter_b; auto. rewrite empty_mem. rewrite H0; simpl;intros. -replace true with (negb false);auto;apply negb_sym;auto. +rewrite <- negb_false_iff; auto. Qed. -Lemma for_all_mem_3: +Lemma for_all_mem_3: forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. Proof. intros. @@ -752,7 +752,7 @@ rewrite H0. simpl;auto. Qed. -Lemma for_all_mem_4: +Lemma for_all_mem_4: forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. Proof. intros. @@ -762,12 +762,12 @@ exists x. rewrite filter_b in H1; auto. elim (andb_prop _ _ H1). split;auto. -replace false with (negb true);auto;apply negb_sym;auto. +rewrite <- negb_true_iff; auto. Qed. (** Properties of [exists] *) -Lemma for_all_exists: +Lemma for_all_exists: forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). Proof. intros. @@ -785,49 +785,49 @@ Variable Comp: compat_bool E.eq f. Let Comp' : compat_bool E.eq (fun x =>negb (f x)). Proof. -unfold compat_bool in *; intros; f_equal; auto. +unfold compat_bool, Proper, respectful in *; intros; f_equal; auto. Qed. -Lemma exists_mem_1: +Lemma exists_mem_1: forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. Proof. intros. rewrite for_all_exists; auto. rewrite for_all_mem_1;auto with bool. -intros;generalize (H x H0);intros. -symmetry;apply negb_sym;simpl;auto. +intros;generalize (H x H0);intros. +rewrite negb_true_iff; auto. Qed. -Lemma exists_mem_2: - forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. +Lemma exists_mem_2: + forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. Proof. intros. rewrite for_all_exists in H; auto. -replace false with (negb true);auto;apply negb_sym;symmetry. -rewrite (for_all_mem_2 (fun x => negb (f x)) Comp' s);simpl;auto. -replace true with (negb false);auto;apply negb_sym;auto. +rewrite negb_false_iff in H. +rewrite <- negb_true_iff. +apply for_all_mem_2 with (2:=H); auto. Qed. -Lemma exists_mem_3: +Lemma exists_mem_3: forall s x, mem x s=true -> f x=true -> exists_ f s=true. Proof. intros. rewrite for_all_exists; auto. -symmetry;apply negb_sym;simpl. +rewrite negb_true_iff. apply for_all_mem_3 with x;auto. -rewrite H0;auto. +rewrite negb_false_iff; auto. Qed. -Lemma exists_mem_4: +Lemma exists_mem_4: forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. Proof. intros. rewrite for_all_exists in H; auto. -elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros. +rewrite negb_true_iff in H. +elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros;auto. elim p;intros. exists x;split;auto. -replace true with (negb false);auto;apply negb_sym;auto. -replace false with (negb true);auto;apply negb_sym;auto. +rewrite <-negb_false_iff; auto. Qed. End Bool'. @@ -836,21 +836,21 @@ Section Sum. (** Adding a valuation function on all elements of a set. *) -Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. -Notation compat_opL := (compat_op E.eq (@Logic.eq _)). -Notation transposeL := (transpose (@Logic.eq _)). +Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. +Notation compat_opL := (compat_op E.eq Logic.eq). +Notation transposeL := (transpose Logic.eq). -Lemma sum_plus : - forall f g, compat_nat E.eq f -> compat_nat E.eq g -> +Lemma sum_plus : + forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. Proof. unfold sum. intros f g Hf Hg. -assert (fc : compat_opL (fun x:elt =>plus (f x))). auto. +assert (fc : compat_opL (fun x:elt =>plus (f x))). red; auto. assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros; omega. -assert (gc : compat_opL (fun x:elt => plus (g x))). auto. +assert (gc : compat_opL (fun x:elt => plus (g x))). red; auto. assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega. -assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). auto. +assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). repeat red; auto. assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega. assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). intros s;pattern s; apply set_rec. @@ -863,14 +863,14 @@ rewrite H0;simpl;omega. do 3 rewrite fold_empty;auto. Qed. -Lemma sum_filter : forall f, (compat_bool E.eq f) -> +Lemma sum_filter : forall f, (compat_bool E.eq f) -> forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). Proof. unfold sum; intros f Hf. assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). -assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). - red; intros. - rewrite (Hf x x' H); auto. +assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). + repeat red; intros. + rewrite (Hf _ _ H); auto. assert (ct : transposeL (fun x => plus (if f x then 1 else 0))). red; intros; omega. intros s;pattern s; apply set_rec. @@ -891,12 +891,12 @@ unfold Empty; intros. rewrite filter_iff; auto; set_iff; tauto. Qed. -Lemma fold_compat : +Lemma fold_compat : forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f g:elt->A->A), - (compat_op E.eq eqA f) -> (transpose eqA f) -> - (compat_op E.eq eqA g) -> (transpose eqA g) -> - forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> + (compat_op E.eq eqA f) -> (transpose eqA f) -> + (compat_op E.eq eqA g) -> (transpose eqA g) -> + forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> (eqA (fold f s i) (fold g s i)). Proof. intros A eqA st f g fc ft gc gt i. @@ -912,17 +912,18 @@ transitivity (f x (fold f s0 i)). apply fold_add with (eqA:=eqA); auto with set. transitivity (g x (fold f s0 i)); auto with set. transitivity (g x (fold g s0 i)); auto with set. +apply gc; auto with *. symmetry; apply fold_add with (eqA:=eqA); auto. do 2 rewrite fold_empty; reflexivity. Qed. -Lemma sum_compat : - forall f g, compat_nat E.eq f -> compat_nat E.eq g -> +Lemma sum_compat : + forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. intros. -unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto. -red; intros; omega. -red; intros; omega. +unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto with *. +intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. +intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. Qed. End Sum. diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v index 674caaac..b750edfc 100644 --- a/theories/FSets/FSetFacts.v +++ b/theories/FSets/FSetFacts.v @@ -6,13 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetFacts.v 12187 2009-06-13 19:36:59Z msozeau $ *) +(* $Id$ *) (** * Finite sets library *) (** This functor derives additional facts from [FSetInterface.S]. These - facts are mainly the specifications of [FSetInterface.S] written using - different styles: equivalence and boolean equalities. + facts are mainly the specifications of [FSetInterface.S] written using + different styles: equivalence and boolean equalities. Moreover, we prove that [E.Eq] and [Equal] are setoid equalities. *) @@ -30,7 +30,7 @@ Definition eqb x y := if eq_dec x y then true else false. (** * Specifications written using equivalences *) -Section IffSpec. +Section IffSpec. Variable s s' s'' : t. Variable x y z : elt. @@ -50,12 +50,12 @@ rewrite mem_iff; destruct (mem x s); intuition. Qed. Lemma equal_iff : s[=]s' <-> equal s s' = true. -Proof. +Proof. split; [apply equal_1|apply equal_2]. Qed. Lemma subset_iff : s[<=]s' <-> subset s s' = true. -Proof. +Proof. split; [apply subset_1|apply subset_2]. Qed. @@ -64,8 +64,8 @@ Proof. intuition; apply (empty_1 H). Qed. -Lemma is_empty_iff : Empty s <-> is_empty s = true. -Proof. +Lemma is_empty_iff : Empty s <-> is_empty s = true. +Proof. split; [apply is_empty_1|apply is_empty_2]. Qed. @@ -75,7 +75,7 @@ split; [apply singleton_1|apply singleton_2]. Qed. Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. -Proof. +Proof. split; [ | destruct 1; [apply add_1|apply add_2]]; auto. destruct (eq_dec x y) as [E|E]; auto. intro H; right; exact (add_3 E H). @@ -116,8 +116,8 @@ Qed. Variable f : elt->bool. Lemma filter_iff : compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true). -Proof. -split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. +Proof. +split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. Qed. Lemma for_all_iff : compat_bool E.eq f -> @@ -125,7 +125,7 @@ Lemma for_all_iff : compat_bool E.eq f -> Proof. split; [apply for_all_1 | apply for_all_2]; auto. Qed. - + Lemma exists_iff : compat_bool E.eq f -> (Exists (fun x => f x = true) s <-> exists_ f s = true). Proof. @@ -133,17 +133,17 @@ split; [apply exists_1 | apply exists_2]; auto. Qed. Lemma elements_iff : In x s <-> InA E.eq x (elements s). -Proof. +Proof. split; [apply elements_1 | apply elements_2]. Qed. End IffSpec. (** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) - -Ltac set_iff := + +Ltac set_iff := repeat (progress ( - rewrite add_iff || rewrite remove_iff || rewrite singleton_iff + rewrite add_iff || rewrite remove_iff || rewrite singleton_iff || rewrite union_iff || rewrite inter_iff || rewrite diff_iff || rewrite empty_iff)). @@ -154,7 +154,7 @@ Variable s s' s'' : t. Variable x y z : elt. Lemma mem_b : E.eq x y -> mem x s = mem y s. -Proof. +Proof. intros. generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). destruct (mem x s); destruct (mem y s); intuition. @@ -191,7 +191,7 @@ destruct (mem y s); destruct (mem y (remove x s)); intuition. Qed. Lemma singleton_b : mem y (singleton x) = eqb x y. -Proof. +Proof. generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. Qed. @@ -236,7 +236,7 @@ Qed. Variable f : elt->bool. Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x. -Proof. +Proof. intros. generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. @@ -264,7 +264,7 @@ rewrite H2. rewrite InA_alt; eauto. Qed. -Lemma exists_b : compat_bool E.eq f -> +Lemma exists_b : compat_bool E.eq f -> exists_ f s = existsb f (elements s). Proof. intros. @@ -291,39 +291,27 @@ End BoolSpec. (** * [E.eq] and [Equal] are setoid equalities *) -Definition E_ST : Equivalence E.eq. +Instance E_ST : Equivalence E.eq. Proof. constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. Qed. -Definition Equal_ST : Equivalence Equal. -Proof. +Instance Equal_ST : Equivalence Equal. +Proof. constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans]. Qed. -Add Relation elt E.eq - reflexivity proved by E.eq_refl - symmetry proved by E.eq_sym - transitivity proved by E.eq_trans - as EltSetoid. - -Add Relation t Equal - reflexivity proved by eq_refl - symmetry proved by eq_sym - transitivity proved by eq_trans - as EqualSetoid. - -Add Morphism In with signature E.eq ==> Equal ==> iff as In_m. +Instance In_m : Proper (E.eq ==> Equal ==> iff) In. Proof. unfold Equal; intros x y H s s' H0. rewrite (In_eq_iff s H); auto. Qed. -Add Morphism is_empty : is_empty_m. +Instance is_empty_m : Proper (Equal==> Logic.eq) is_empty. Proof. unfold Equal; intros s s' H. generalize (is_empty_iff s)(is_empty_iff s'). -destruct (is_empty s); destruct (is_empty s'); +destruct (is_empty s); destruct (is_empty s'); unfold Empty; auto; intros. symmetry. rewrite <- H1; intros a Ha. @@ -336,12 +324,12 @@ destruct H1 as (_,H1). exact (H1 (refl_equal true) _ Ha). Qed. -Add Morphism Empty with signature Equal ==> iff as Empty_m. +Instance Empty_m : Proper (Equal ==> iff) Empty. Proof. -intros; do 2 rewrite is_empty_iff; rewrite H; intuition. +repeat red; intros; do 2 rewrite is_empty_iff; rewrite H; intuition. Qed. -Add Morphism mem : mem_m. +Instance mem_m : Proper (E.eq ==> Equal ==> Logic.eq) mem. Proof. unfold Equal; intros x y H s s' H0. generalize (H0 x); clear H0; rewrite (In_eq_iff s' H). @@ -349,7 +337,7 @@ generalize (mem_iff s x)(mem_iff s' y). destruct (mem x s); destruct (mem y s'); intuition. Qed. -Add Morphism singleton : singleton_m. +Instance singleton_m : Proper (E.eq ==> Equal) singleton. Proof. unfold Equal; intros x y H a. do 2 rewrite singleton_iff; split; intros. @@ -357,51 +345,51 @@ apply E.eq_trans with x; auto. apply E.eq_trans with y; auto. Qed. -Add Morphism add : add_m. +Instance add_m : Proper (E.eq==>Equal==>Equal) add. Proof. unfold Equal; intros x y H s s' H0 a. do 2 rewrite add_iff; rewrite H; rewrite H0; intuition. Qed. -Add Morphism remove : remove_m. +Instance remove_m : Proper (E.eq==>Equal==>Equal) remove. Proof. unfold Equal; intros x y H s s' H0 a. do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition. Qed. -Add Morphism union : union_m. +Instance union_m : Proper (Equal==>Equal==>Equal) union. Proof. unfold Equal; intros s s' H s'' s''' H0 a. do 2 rewrite union_iff; rewrite H; rewrite H0; intuition. Qed. -Add Morphism inter : inter_m. +Instance inter_m : Proper (Equal==>Equal==>Equal) inter. Proof. unfold Equal; intros s s' H s'' s''' H0 a. do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition. Qed. -Add Morphism diff : diff_m. +Instance diff_m : Proper (Equal==>Equal==>Equal) diff. Proof. unfold Equal; intros s s' H s'' s''' H0 a. do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition. Qed. -Add Morphism Subset with signature Equal ==> Equal ==> iff as Subset_m. -Proof. +Instance Subset_m : Proper (Equal==>Equal==>iff) Subset. +Proof. unfold Equal, Subset; firstorder. Qed. -Add Morphism subset : subset_m. +Instance subset_m : Proper (Equal ==> Equal ==> Logic.eq) subset. Proof. intros s s' H s'' s''' H0. -generalize (subset_iff s s'') (subset_iff s' s'''). +generalize (subset_iff s s'') (subset_iff s' s'''). destruct (subset s s''); destruct (subset s' s'''); auto; intros. rewrite H in H1; rewrite H0 in H1; intuition. rewrite H in H1; rewrite H0 in H1; intuition. Qed. -Add Morphism equal : equal_m. +Instance equal_m : Proper (Equal ==> Equal ==> Logic.eq) equal. Proof. intros s s' H s'' s''' H0. generalize (equal_iff s s'') (equal_iff s' s'''). @@ -424,7 +412,7 @@ Add Relation t Subset transitivity proved by Subset_trans as SubsetSetoid. -Instance In_s_m : Morphisms.Morphism (E.eq ==> Subset ++> Basics.impl) In | 1. +Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> Basics.impl) In | 1. Proof. simpl_relation. eauto with set. Qed. @@ -467,7 +455,7 @@ Qed. (* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism without additional hypothesis on [f]. For instance: *) -Lemma filter_equal : forall f, compat_bool E.eq f -> +Lemma filter_equal : forall f, compat_bool E.eq f -> forall s s', s[=]s' -> filter f s [=] filter f s'. Proof. unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. @@ -478,10 +466,10 @@ Lemma filter_ext : forall f f', compat_bool E.eq f -> (forall x, f x = f' x) -> Proof. intros f f' Hf Hff' s s' Hss' x. do 2 (rewrite filter_iff; auto). rewrite Hff', Hss'; intuition. -red; intros; rewrite <- 2 Hff'; auto. +repeat red; intros; rewrite <- 2 Hff'; auto. Qed. -Lemma filter_subset : forall f, compat_bool E.eq f -> +Lemma filter_subset : forall f, compat_bool E.eq f -> forall s s', s[<=]s' -> filter f s [<=] filter f s'. Proof. unfold Subset; intros; rewrite filter_iff in *; intuition. diff --git a/theories/FSets/FSetFullAVL.v b/theories/FSets/FSetFullAVL.v deleted file mode 100644 index a2d8e681..00000000 --- a/theories/FSets/FSetFullAVL.v +++ /dev/null @@ -1,1133 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop := - | RBLeaf : avl Leaf - | RBNode : forall x l r h, avl l -> avl r -> - -(2) <= height l - height r <= 2 -> - h = max (height l) (height r) + 1 -> - avl (Node l x r h). - -(** * Automation and dedicated tactics *) - -Hint Constructors avl. - -(** A tactic for cleaning hypothesis after use of functional induction. *) - -Ltac clearf := - match goal with - | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf - | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf - | _ => idtac - end. - -(** Tactics about [avl] *) - -Lemma height_non_negative : forall s : tree, avl s -> height s >= 0. -Proof. - induction s; simpl; intros; auto with zarith. - inv avl; intuition; omega_max. -Qed. -Implicit Arguments height_non_negative. - -(** When [H:avl r], typing [avl_nn H] or [avl_nn r] adds [height r>=0] *) - -Ltac avl_nn_hyp H := - let nz := fresh "nz" in assert (nz := height_non_negative H). - -Ltac avl_nn h := - let t := type of h in - match type of t with - | Prop => avl_nn_hyp h - | _ => match goal with H : avl h |- _ => avl_nn_hyp H end - end. - -(* Repeat the previous tactic. - Drawback: need to clear the [avl _] hyps ... Thank you Ltac *) - -Ltac avl_nns := - match goal with - | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns - | _ => idtac - end. - -(** Results about [height] *) - -Lemma height_0 : forall s, avl s -> height s = 0 -> s = Leaf. -Proof. - destruct 1; intuition; simpl in *. - avl_nns; simpl in *; elimtype False; omega_max. -Qed. - -(** * Results about [avl] *) - -Lemma avl_node : - forall x l r, avl l -> avl r -> - -(2) <= height l - height r <= 2 -> - avl (Node l x r (max (height l) (height r) + 1)). -Proof. - intros; auto. -Qed. -Hint Resolve avl_node. - - -(** empty *) - -Lemma empty_avl : avl empty. -Proof. - auto. -Qed. - -(** singleton *) - -Lemma singleton_avl : forall x : elt, avl (singleton x). -Proof. - unfold singleton; intro. - constructor; auto; try red; simpl; omega_max. -Qed. - -(** create *) - -Lemma create_avl : - forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - avl (create l x r). -Proof. - unfold create; auto. -Qed. - -Lemma create_height : - forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - height (create l x r) = max (height l) (height r) + 1. -Proof. - unfold create; auto. -Qed. - -(** bal *) - -Lemma bal_avl : forall l x r, avl l -> avl r -> - -(3) <= height l - height r <= 3 -> avl (bal l x r). -Proof. - intros l x r; functional induction bal l x r; intros; clearf; - inv avl; simpl in *; - match goal with |- avl (assert_false _ _ _) => avl_nns - | _ => repeat apply create_avl; simpl in *; auto - end; omega_max. -Qed. - -Lemma bal_height_1 : forall l x r, avl l -> avl r -> - -(3) <= height l - height r <= 3 -> - 0 <= height (bal l x r) - max (height l) (height r) <= 1. -Proof. - intros l x r; functional induction bal l x r; intros; clearf; - inv avl; avl_nns; simpl in *; omega_max. -Qed. - -Lemma bal_height_2 : - forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - height (bal l x r) == max (height l) (height r) +1. -Proof. - intros l x r; functional induction bal l x r; intros; clearf; - inv avl; simpl in *; omega_max. -Qed. - -Ltac omega_bal := match goal with - | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?r ] => - generalize (bal_height_1 x H H') (bal_height_2 x H H'); - omega_max - end. - -(** add *) - -Lemma add_avl_1 : forall s x, avl s -> - avl (add x s) /\ 0 <= height (add x s) - height s <= 1. -Proof. - intros s x; functional induction (add x s); subst;intros; inv avl; simpl in *. - intuition; try constructor; simpl; auto; try omega_max. - (* LT *) - destruct IHt; auto. - split. - apply bal_avl; auto; omega_max. - omega_bal. - (* EQ *) - intuition; omega_max. - (* GT *) - destruct IHt; auto. - split. - apply bal_avl; auto; omega_max. - omega_bal. -Qed. - -Lemma add_avl : forall s x, avl s -> avl (add x s). -Proof. - intros; destruct (add_avl_1 x H); auto. -Qed. -Hint Resolve add_avl. - -(** join *) - -Lemma join_avl_1 : forall l x r, avl l -> avl r -> avl (join l x r) /\ - 0<= height (join l x r) - max (height l) (height r) <= 1. -Proof. - join_tac. - - split; simpl; auto. - destruct (add_avl_1 x H0). - avl_nns; omega_max. - set (l:=Node ll lx lr lh) in *. - split; auto. - destruct (add_avl_1 x H). - simpl (height Leaf). - avl_nns; omega_max. - - inversion_clear H. - assert (height (Node rl rx rr rh) = rh); auto. - set (r := Node rl rx rr rh) in *; clearbody r. - destruct (Hlr x r H2 H0); clear Hrl Hlr. - set (j := join lr x r) in *; clearbody j. - simpl. - assert (-(3) <= height ll - height j <= 3) by omega_max. - split. - apply bal_avl; auto. - omega_bal. - - inversion_clear H0. - assert (height (Node ll lx lr lh) = lh); auto. - set (l := Node ll lx lr lh) in *; clearbody l. - destruct (Hrl H H1); clear Hrl Hlr. - set (j := join l x rl) in *; clearbody j. - simpl. - assert (-(3) <= height j - height rr <= 3) by omega_max. - split. - apply bal_avl; auto. - omega_bal. - - clear Hrl Hlr. - assert (height (Node ll lx lr lh) = lh); auto. - assert (height (Node rl rx rr rh) = rh); auto. - set (l := Node ll lx lr lh) in *; clearbody l. - set (r := Node rl rx rr rh) in *; clearbody r. - assert (-(2) <= height l - height r <= 2) by omega_max. - split. - apply create_avl; auto. - rewrite create_height; auto; omega_max. -Qed. - -Lemma join_avl : forall l x r, avl l -> avl r -> avl (join l x r). -Proof. - intros; destruct (join_avl_1 x H H0); auto. -Qed. -Hint Resolve join_avl. - -(** remove_min *) - -Lemma remove_min_avl_1 : forall l x r h, avl (Node l x r h) -> - avl (remove_min l x r)#1 /\ - 0 <= height (Node l x r h) - height (remove_min l x r)#1 <= 1. -Proof. - intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros. - inv avl; simpl in *; split; auto. - avl_nns; omega_max. - inversion_clear H. - rewrite e0 in IHp;simpl in IHp;destruct (IHp _x); auto. - split; simpl in *. - apply bal_avl; auto; omega_max. - omega_bal. -Qed. - -Lemma remove_min_avl : forall l x r h, avl (Node l x r h) -> - avl (remove_min l x r)#1. -Proof. - intros; destruct (remove_min_avl_1 H); auto. -Qed. - -(** merge *) - -Lemma merge_avl_1 : forall s1 s2, avl s1 -> avl s2 -> - -(2) <= height s1 - height s2 <= 2 -> - avl (merge s1 s2) /\ - 0<= height (merge s1 s2) - max (height s1) (height s2) <=1. -Proof. - intros s1 s2; functional induction (merge s1 s2); intros; - try factornode _x _x0 _x1 _x2 as s1. - simpl; split; auto; avl_nns; omega_max. - simpl; split; auto; avl_nns; simpl in *; omega_max. - generalize (remove_min_avl_1 H0). - rewrite e1; destruct 1. - split. - apply bal_avl; auto. - simpl; omega_max. - simpl in *; omega_bal. -Qed. - -Lemma merge_avl : forall s1 s2, avl s1 -> avl s2 -> - -(2) <= height s1 - height s2 <= 2 -> avl (merge s1 s2). -Proof. - intros; destruct (merge_avl_1 H H0 H1); auto. -Qed. - - -(** remove *) - -Lemma remove_avl_1 : forall s x, avl s -> - avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1. -Proof. - intros s x; functional induction (remove x s); intros. - intuition; omega_max. - (* LT *) - inv avl. - destruct (IHt H0). - split. - apply bal_avl; auto. - omega_max. - omega_bal. - (* EQ *) - inv avl. - generalize (merge_avl_1 H0 H1 H2). - intuition omega_max. - (* GT *) - inv avl. - destruct (IHt H1). - split. - apply bal_avl; auto. - omega_max. - omega_bal. -Qed. - -Lemma remove_avl : forall s x, avl s -> avl (remove x s). -Proof. - intros; destruct (remove_avl_1 x H); auto. -Qed. -Hint Resolve remove_avl. - -(** concat *) - -Lemma concat_avl : forall s1 s2, avl s1 -> avl s2 -> avl (concat s1 s2). -Proof. - intros s1 s2; functional induction (concat s1 s2); auto. - intros; apply join_avl; auto. - generalize (remove_min_avl H0); rewrite e1; simpl; auto. -Qed. -Hint Resolve concat_avl. - -(** split *) - -Lemma split_avl : forall s x, avl s -> - avl (split x s)#l /\ avl (split x s)#r. -Proof. - intros s x; functional induction (split x s); simpl; auto. - rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. - simpl; inversion_clear 1; auto. - rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. -Qed. - -(** inter *) - -Lemma inter_avl : forall s1 s2, avl s1 -> avl s2 -> avl (inter s1 s2). -Proof. - intros s1 s2; functional induction inter s1 s2; auto; intros A1 A2; - generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; - inv avl; auto. -Qed. - -(** diff *) - -Lemma diff_avl : forall s1 s2, avl s1 -> avl s2 -> avl (diff s1 s2). -Proof. - intros s1 s2; functional induction diff s1 s2; auto; intros A1 A2; - generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; - inv avl; auto. -Qed. - -(** union *) - -Lemma union_avl : forall s1 s2, avl s1 -> avl s2 -> avl (union s1 s2). -Proof. - intros s1 s2; functional induction union s1 s2; auto; intros A1 A2; - generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; - inv avl; auto. -Qed. - -(** filter *) - -Lemma filter_acc_avl : forall f s acc, avl s -> avl acc -> - avl (filter_acc f acc s). -Proof. - induction s; simpl; auto. - intros. - inv avl. - destruct (f t); auto. -Qed. -Hint Resolve filter_acc_avl. - -Lemma filter_avl : forall f s, avl s -> avl (filter f s). -Proof. - unfold filter; intros; apply filter_acc_avl; auto. -Qed. - -(** partition *) - -Lemma partition_acc_avl_1 : forall f s acc, avl s -> - avl acc#1 -> avl (partition_acc f acc s)#1. -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. - inv avl. - apply IHs2; auto. - apply IHs1; auto. - destruct (f t); simpl; auto. -Qed. - -Lemma partition_acc_avl_2 : forall f s acc, avl s -> - avl acc#2 -> avl (partition_acc f acc s)#2. -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. - inv avl. - apply IHs2; auto. - apply IHs1; auto. - destruct (f t); simpl; auto. -Qed. - -Lemma partition_avl_1 : forall f s, avl s -> avl (partition f s)#1. -Proof. - unfold partition; intros; apply partition_acc_avl_1; auto. -Qed. - -Lemma partition_avl_2 : forall f s, avl s -> avl (partition f s)#2. -Proof. - unfold partition; intros; apply partition_acc_avl_2; auto. -Qed. - -End AvlProofs. - - -Module OcamlOps (Import I:Int)(X:OrderedType). -Module Import AvlProofs := AvlProofs I X. -Import Raw. -Import Raw.Proofs. -Import II. -Open Local Scope pair_scope. -Open Local Scope nat_scope. - -(** Properties of cardinal *) - -Lemma bal_cardinal : forall l x r, - cardinal (bal l x r) = S (cardinal l + cardinal r). -Proof. - intros l x r; functional induction bal l x r; intros; clearf; - simpl; auto with arith; romega with *. -Qed. - -Lemma add_cardinal : forall x s, - cardinal (add x s) <= S (cardinal s). -Proof. - intros; functional induction add x s; simpl; auto with arith; - rewrite bal_cardinal; romega with *. -Qed. - -Lemma join_cardinal : forall l x r, - cardinal (join l x r) <= S (cardinal l + cardinal r). -Proof. - join_tac; auto with arith. - simpl; apply add_cardinal. - simpl; destruct X.compare; simpl; auto with arith. - generalize (bal_cardinal (add x ll) lx lr) (add_cardinal x ll); - romega with *. - generalize (bal_cardinal ll lx (add x lr)) (add_cardinal x lr); - romega with *. - generalize (bal_cardinal ll lx (join lr x (Node rl rx rr rh))) - (Hlr x (Node rl rx rr rh)); simpl; romega with *. - simpl S in *; generalize (bal_cardinal (join (Node ll lx lr lh) x rl) rx rr). - romega with *. -Qed. - -Lemma split_cardinal_1 : forall x s, - (cardinal (split x s)#l <= cardinal s)%nat. -Proof. - intros x s; functional induction split x s; simpl; auto. - rewrite e1 in IHt; simpl in *. - romega with *. - romega with *. - rewrite e1 in IHt; simpl in *. - generalize (@join_cardinal l y rl); romega with *. -Qed. - -Lemma split_cardinal_2 : forall x s, - (cardinal (split x s)#r <= cardinal s)%nat. -Proof. - intros x s; functional induction split x s; simpl; auto. - rewrite e1 in IHt; simpl in *. - generalize (@join_cardinal rl y r); romega with *. - romega with *. - rewrite e1 in IHt; simpl in *; romega with *. -Qed. - -(** * [ocaml_union], an union faithful to the original ocaml code *) - -Definition cardinal2 (s:t*t) := (cardinal s#1 + cardinal s#2)%nat. - -Ltac ocaml_union_tac := - intros; unfold cardinal2; simpl fst in *; simpl snd in *; - match goal with H: split ?x ?s = _ |- _ => - generalize (split_cardinal_1 x s) (split_cardinal_2 x s); - rewrite H; simpl; romega with * - end. - -Import Logic. (* Unhide eq, otherwise Function complains. *) - -Function ocaml_union (s : t * t) { measure cardinal2 s } : t := - match s with - | (Leaf, Leaf) => s#2 - | (Leaf, Node _ _ _ _) => s#2 - | (Node _ _ _ _, Leaf) => s#1 - | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) => - if ge_lt_dec h1 h2 then - if eq_dec h2 1%I then add x2 s#1 else - let (l2',_,r2') := split x1 s#2 in - join (ocaml_union (l1,l2')) x1 (ocaml_union (r1,r2')) - else - if eq_dec h1 1%I then add x1 s#2 else - let (l1',_,r1') := split x2 s#1 in - join (ocaml_union (l1',l2)) x2 (ocaml_union (r1',r2)) - end. -Proof. -abstract ocaml_union_tac. -abstract ocaml_union_tac. -abstract ocaml_union_tac. -abstract ocaml_union_tac. -Defined. - -Lemma ocaml_union_in : forall s y, - bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> - (In y (ocaml_union s) <-> In y s#1 \/ In y s#2). -Proof. - intros s; functional induction ocaml_union s; intros y B1 A1 B2 A2; - simpl fst in *; simpl snd in *; try clear e0 e1. - intuition_in. - intuition_in. - intuition_in. - (* add x2 s#1 *) - inv avl. - rewrite (height_0 H); [ | avl_nn l2; omega_max]. - rewrite (height_0 H0); [ | avl_nn r2; omega_max]. - rewrite add_in; intuition_in. - (* join (union (l1,l2')) x1 (union (r1,r2')) *) - generalize - (split_avl x1 A2) (split_bst x1 B2) - (split_in_1 x1 y B2) (split_in_2 x1 y B2). - rewrite e2; simpl. - destruct 1; destruct 1; inv avl; inv bst. - rewrite join_in, IHt, IHt0; auto. - do 2 (intro Eq; rewrite Eq; clear Eq). - case (X.compare y x1); intuition_in. - (* add x1 s#2 *) - inv avl. - rewrite (height_0 H3); [ | avl_nn l1; omega_max]. - rewrite (height_0 H4); [ | avl_nn r1; omega_max]. - rewrite add_in; auto; intuition_in. - (* join (union (l1',l2)) x1 (union (r1',r2)) *) - generalize - (split_avl x2 A1) (split_bst x2 B1) - (split_in_1 x2 y B1) (split_in_2 x2 y B1). - rewrite e2; simpl. - destruct 1; destruct 1; inv avl; inv bst. - rewrite join_in, IHt, IHt0; auto. - do 2 (intro Eq; rewrite Eq; clear Eq). - case (X.compare y x2); intuition_in. -Qed. - -Lemma ocaml_union_bst : forall s, - bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> bst (ocaml_union s). -Proof. - intros s; functional induction ocaml_union s; intros B1 A1 B2 A2; - simpl fst in *; simpl snd in *; try clear e0 e1; - try apply add_bst; auto. - (* join (union (l1,l2')) x1 (union (r1,r2')) *) - clear _x _x0; factornode l2 x2 r2 h2 as s2. - generalize (split_avl x1 A2) (split_bst x1 B2) - (@split_in_1 s2 x1)(@split_in_2 s2 x1). - rewrite e2; simpl. - destruct 1; destruct 1; intros. - inv bst; inv avl. - apply join_bst; auto. - intro y; rewrite ocaml_union_in, H3; intuition_in. - intro y; rewrite ocaml_union_in, H4; intuition_in. - (* join (union (l1',l2)) x1 (union (r1',r2)) *) - clear _x _x0; factornode l1 x1 r1 h1 as s1. - generalize (split_avl x2 A1) (split_bst x2 B1) - (@split_in_1 s1 x2)(@split_in_2 s1 x2). - rewrite e2; simpl. - destruct 1; destruct 1; intros. - inv bst; inv avl. - apply join_bst; auto. - intro y; rewrite ocaml_union_in, H3; intuition_in. - intro y; rewrite ocaml_union_in, H4; intuition_in. -Qed. - -Lemma ocaml_union_avl : forall s, - avl s#1 -> avl s#2 -> avl (ocaml_union s). -Proof. - intros s; functional induction ocaml_union s; - simpl fst in *; simpl snd in *; auto. - intros A1 A2; generalize (split_avl x1 A2); rewrite e2; simpl. - inv avl; destruct 1; auto. - intros A1 A2; generalize (split_avl x2 A1); rewrite e2; simpl. - inv avl; destruct 1; auto. -Qed. - -Lemma ocaml_union_alt : forall s, bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> - Equal (ocaml_union s) (union s#1 s#2). -Proof. - red; intros; rewrite ocaml_union_in, union_in; simpl; intuition. -Qed. - - -(** * [ocaml_subset], a subset faithful to the original ocaml code *) - -Function ocaml_subset (s:t*t) { measure cardinal2 s } : bool := - match s with - | (Leaf, _) => true - | (Node _ _ _ _, Leaf) => false - | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) => - match X.compare x1 x2 with - | EQ _ => ocaml_subset (l1,l2) && ocaml_subset (r1,r2) - | LT _ => ocaml_subset (Node l1 x1 Leaf 0%I, l2) && ocaml_subset (r1,s#2) - | GT _ => ocaml_subset (Node Leaf x1 r1 0%I, r2) && ocaml_subset (l1,s#2) - end - end. - -Proof. - intros; unfold cardinal2; simpl; abstract romega with *. - intros; unfold cardinal2; simpl; abstract romega with *. - intros; unfold cardinal2; simpl; abstract romega with *. - intros; unfold cardinal2; simpl; abstract romega with *. - intros; unfold cardinal2; simpl; abstract romega with *. - intros; unfold cardinal2; simpl; abstract romega with *. -Defined. - -Lemma ocaml_subset_12 : forall s, - bst s#1 -> bst s#2 -> - (ocaml_subset s = true <-> Subset s#1 s#2). -Proof. - intros s; functional induction ocaml_subset s; simpl; - intros B1 B2; try clear e0. - intuition. - red; auto; inversion 1. - split; intros; try discriminate. - assert (H': In _x0 Leaf) by auto; inversion H'. - (**) - simpl in *; inv bst. - rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0. - unfold Subset; intuition_in. - assert (X.eq a x2) by order; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - (**) - simpl in *; inv bst. - rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0. - unfold Subset; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - (**) - simpl in *; inv bst. - rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0. - unfold Subset; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. -Qed. - -Lemma ocaml_subset_alt : forall s, bst s#1 -> bst s#2 -> - ocaml_subset s = subset s#1 s#2. -Proof. - intros. - generalize (ocaml_subset_12 H H0); rewrite <-subset_12 by auto. - destruct ocaml_subset; destruct subset; intuition. -Qed. - - - -(** [ocaml_compare], a compare faithful to the original ocaml code *) - -(** termination of [compare_aux] *) - -Fixpoint cardinal_e e := match e with - | End => 0 - | More _ s r => S (cardinal s + cardinal_e r) - end. - -Lemma cons_cardinal_e : forall s e, - cardinal_e (cons s e) = cardinal s + cardinal_e e. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1; simpl; rewrite <- plus_n_Sm; auto with arith. -Qed. - -Definition cardinal_e_2 e := cardinal_e e#1 + cardinal_e e#2. - -Function ocaml_compare_aux - (e:enumeration*enumeration) { measure cardinal_e_2 e } : comparison := - match e with - | (End,End) => Eq - | (End,More _ _ _) => Lt - | (More _ _ _, End) => Gt - | (More x1 r1 e1, More x2 r2 e2) => - match X.compare x1 x2 with - | EQ _ => ocaml_compare_aux (cons r1 e1, cons r2 e2) - | LT _ => Lt - | GT _ => Gt - end - end. - -Proof. -intros; unfold cardinal_e_2; simpl; -abstract (do 2 rewrite cons_cardinal_e; romega with *). -Defined. - -Definition ocaml_compare s1 s2 := - ocaml_compare_aux (cons s1 End, cons s2 End). - -Lemma ocaml_compare_aux_Cmp : forall e, - Cmp (ocaml_compare_aux e) (flatten_e e#1) (flatten_e e#2). -Proof. - intros e; functional induction ocaml_compare_aux e; simpl; intros; - auto; try discriminate. - apply L.eq_refl. - simpl in *. - apply cons_Cmp; auto. - rewrite <- 2 cons_1; auto. -Qed. - -Lemma ocaml_compare_Cmp : forall s1 s2, - Cmp (ocaml_compare s1 s2) (elements s1) (elements s2). -Proof. - unfold ocaml_compare; intros. - assert (H1:=cons_1 s1 End). - assert (H2:=cons_1 s2 End). - simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2. - apply (@ocaml_compare_aux_Cmp (cons s1 End, cons s2 End)). -Qed. - -Lemma ocaml_compare_alt : forall s1 s2, bst s1 -> bst s2 -> - ocaml_compare s1 s2 = compare s1 s2. -Proof. - intros s1 s2 B1 B2. - generalize (ocaml_compare_Cmp s1 s2)(compare_Cmp s1 s2). - unfold Cmp. - destruct ocaml_compare; destruct compare; auto; intros; elimtype False. - elim (lt_not_eq B1 B2 H0); auto. - elim (lt_not_eq B2 B1 H0); auto. - apply eq_sym; auto. - elim (lt_not_eq B1 B2 H); auto. - elim (lt_not_eq B1 B1). - red; eapply L.lt_trans; eauto. - apply eq_refl. - elim (lt_not_eq B2 B1 H); auto. - apply eq_sym; auto. - elim (lt_not_eq B1 B2 H0); auto. - elim (lt_not_eq B1 B1). - red; eapply L.lt_trans; eauto. - apply eq_refl. -Qed. - - -(** * Equality test *) - -Definition ocaml_equal s1 s2 : bool := - match ocaml_compare s1 s2 with - | Eq => true - | _ => false - end. - -Lemma ocaml_equal_1 : forall s1 s2, bst s1 -> bst s2 -> - Equal s1 s2 -> ocaml_equal s1 s2 = true. -Proof. -unfold ocaml_equal; intros s1 s2 B1 B2 E. -generalize (ocaml_compare_Cmp s1 s2). -destruct (ocaml_compare s1 s2); auto; intros. -elim (lt_not_eq B1 B2 H E); auto. -elim (lt_not_eq B2 B1 H (eq_sym E)); auto. -Qed. - -Lemma ocaml_equal_2 : forall s1 s2, - ocaml_equal s1 s2 = true -> Equal s1 s2. -Proof. -unfold ocaml_equal; intros s1 s2 E. -generalize (ocaml_compare_Cmp s1 s2); - destruct ocaml_compare; auto; discriminate. -Qed. - -Lemma ocaml_equal_alt : forall s1 s2, bst s1 -> bst s2 -> - ocaml_equal s1 s2 = equal s1 s2. -Proof. -intros; unfold ocaml_equal, equal; rewrite ocaml_compare_alt; auto. -Qed. - -End OcamlOps. - - - -(** * Encapsulation - - We can implement [S] with balanced binary search trees. - When compared to [FSetAVL], we maintain here two invariants - (bst and avl) instead of only bst, which is enough for fulfilling - the FSet interface. - - This encapsulation propose the non-structural variants - [ocaml_union], [ocaml_subset], [ocaml_compare], [ocaml_equal]. -*) - -Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. - - Module E := X. - Module Import OcamlOps := OcamlOps I X. - Import AvlProofs. - Import Raw. - Import Raw.Proofs. - - Record bbst := Bbst {this :> Raw.t; is_bst : bst this; is_avl : avl this}. - Definition t := bbst. - Definition elt := E.t. - - Definition In (x : elt) (s : t) : Prop := In x s. - Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'. - Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'. - Definition Empty (s:t) : Prop := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) (s:t) : Prop := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) (s:t) : Prop := exists x, In x s /\ P x. - - Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. - Proof. intro s; exact (@In_1 s). Qed. - - Definition mem (x:elt)(s:t) : bool := mem x s. - - Definition empty : t := Bbst empty_bst empty_avl. - Definition is_empty (s:t) : bool := is_empty s. - Definition singleton (x:elt) : t := - Bbst (singleton_bst x) (singleton_avl x). - Definition add (x:elt)(s:t) : t := - Bbst (add_bst x (is_bst s)) (add_avl x (is_avl s)). - Definition remove (x:elt)(s:t) : t := - Bbst (remove_bst x (is_bst s)) (remove_avl x (is_avl s)). - Definition inter (s s':t) : t := - Bbst (inter_bst (is_bst s) (is_bst s')) - (inter_avl (is_avl s) (is_avl s')). - Definition union (s s':t) : t := - Bbst (union_bst (is_bst s) (is_bst s')) - (union_avl (is_avl s) (is_avl s')). - Definition ocaml_union (s s':t) : t := - Bbst (@ocaml_union_bst (s.(this),s'.(this)) - (is_bst s) (is_avl s) (is_bst s') (is_avl s')) - (@ocaml_union_avl (s.(this),s'.(this)) (is_avl s) (is_avl s')). - Definition diff (s s':t) : t := - Bbst (diff_bst (is_bst s) (is_bst s')) - (diff_avl (is_avl s) (is_avl s')). - Definition elements (s:t) : list elt := elements s. - Definition min_elt (s:t) : option elt := min_elt s. - Definition max_elt (s:t) : option elt := max_elt s. - Definition choose (s:t) : option elt := choose s. - Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := fold f s. - Definition cardinal (s:t) : nat := cardinal s. - Definition filter (f : elt -> bool) (s:t) : t := - Bbst (filter_bst f (is_bst s)) (filter_avl f (is_avl s)). - Definition for_all (f : elt -> bool) (s:t) : bool := for_all f s. - Definition exists_ (f : elt -> bool) (s:t) : bool := exists_ f s. - Definition partition (f : elt -> bool) (s:t) : t * t := - let p := partition f s in - (@Bbst (fst p) (partition_bst_1 f (is_bst s)) - (partition_avl_1 f (is_avl s)), - @Bbst (snd p) (partition_bst_2 f (is_bst s)) - (partition_avl_2 f (is_avl s))). - - Definition equal (s s':t) : bool := equal s s'. - Definition ocaml_equal (s s':t) : bool := ocaml_equal s s'. - Definition subset (s s':t) : bool := subset s s'. - Definition ocaml_subset (s s':t) : bool := - ocaml_subset (s.(this),s'.(this)). - - Definition eq (s s':t) : Prop := Equal s s'. - Definition lt (s s':t) : Prop := lt s s'. - - Definition compare (s s':t) : Compare lt eq s s'. - Proof. - intros (s,b,a) (s',b',a'). - generalize (compare_Cmp s s'). - destruct Raw.compare; intros; [apply EQ|apply LT|apply GT]; red; auto. - change (Raw.Equal s s'); auto. - Defined. - - Definition ocaml_compare (s s':t) : Compare lt eq s s'. - Proof. - intros (s,b,a) (s',b',a'). - generalize (ocaml_compare_Cmp s s'). - destruct ocaml_compare; intros; [apply EQ|apply LT|apply GT]; red; auto. - change (Raw.Equal s s'); auto. - Defined. - - Definition eq_dec (s s':t) : { eq s s' } + { ~ eq s s' }. - Proof. - intros (s,b,a) (s',b',a'); unfold eq; simpl. - case_eq (Raw.equal s s'); intro H; [left|right]. - apply equal_2; auto. - intro H'; rewrite equal_1 in H; auto; discriminate. - Defined. - - (* specs *) - Section Specs. - Variable s s' s'': t. - Variable x y : elt. - - Hint Resolve is_bst is_avl. - - Lemma mem_1 : In x s -> mem x s = true. - Proof. exact (mem_1 (is_bst s)). Qed. - Lemma mem_2 : mem x s = true -> In x s. - Proof. exact (@mem_2 s x). Qed. - - Lemma equal_1 : Equal s s' -> equal s s' = true. - Proof. exact (equal_1 (is_bst s) (is_bst s')). Qed. - Lemma equal_2 : equal s s' = true -> Equal s s'. - Proof. exact (@equal_2 s s'). Qed. - - Lemma ocaml_equal_alt : ocaml_equal s s' = equal s s'. - Proof. - destruct s; destruct s'; unfold ocaml_equal, equal; simpl. - apply ocaml_equal_alt; auto. - Qed. - - Lemma ocaml_equal_1 : Equal s s' -> ocaml_equal s s' = true. - Proof. exact (ocaml_equal_1 (is_bst s) (is_bst s')). Qed. - Lemma ocaml_equal_2 : ocaml_equal s s' = true -> Equal s s'. - Proof. exact (@ocaml_equal_2 s s'). Qed. - - Ltac wrap t H := unfold t, In; simpl; rewrite H; auto; intuition. - - Lemma subset_1 : Subset s s' -> subset s s' = true. - Proof. wrap subset subset_12. Qed. - Lemma subset_2 : subset s s' = true -> Subset s s'. - Proof. wrap subset subset_12. Qed. - - Lemma ocaml_subset_alt : ocaml_subset s s' = subset s s'. - Proof. - destruct s; destruct s'; unfold ocaml_subset, subset; simpl. - rewrite ocaml_subset_alt; auto. - Qed. - - Lemma ocaml_subset_1 : Subset s s' -> ocaml_subset s s' = true. - Proof. wrap ocaml_subset ocaml_subset_12; simpl; auto. Qed. - Lemma ocaml_subset_2 : ocaml_subset s s' = true -> Subset s s'. - Proof. wrap ocaml_subset ocaml_subset_12; simpl; auto. Qed. - - Lemma empty_1 : Empty empty. - Proof. exact empty_1. Qed. - - Lemma is_empty_1 : Empty s -> is_empty s = true. - Proof. exact (@is_empty_1 s). Qed. - Lemma is_empty_2 : is_empty s = true -> Empty s. - Proof. exact (@is_empty_2 s). Qed. - - Lemma add_1 : E.eq x y -> In y (add x s). - Proof. wrap add add_in. Qed. - Lemma add_2 : In y s -> In y (add x s). - Proof. wrap add add_in. Qed. - Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. - Proof. wrap add add_in. elim H; auto. Qed. - - Lemma remove_1 : E.eq x y -> ~ In y (remove x s). - Proof. wrap remove remove_in. Qed. - Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). - Proof. wrap remove remove_in. Qed. - Lemma remove_3 : In y (remove x s) -> In y s. - Proof. wrap remove remove_in. Qed. - - Lemma singleton_1 : In y (singleton x) -> E.eq x y. - Proof. exact (@singleton_1 x y). Qed. - Lemma singleton_2 : E.eq x y -> In y (singleton x). - Proof. exact (@singleton_2 x y). Qed. - - Lemma union_1 : In x (union s s') -> In x s \/ In x s'. - Proof. wrap union union_in. Qed. - Lemma union_2 : In x s -> In x (union s s'). - Proof. wrap union union_in. Qed. - Lemma union_3 : In x s' -> In x (union s s'). - Proof. wrap union union_in. Qed. - - Lemma ocaml_union_alt : Equal (ocaml_union s s') (union s s'). - Proof. - unfold ocaml_union, union, Equal, In. - destruct s as (s0,b,a); destruct s' as (s0',b',a'); simpl. - exact (@ocaml_union_alt (s0,s0') b a b' a'). - Qed. - - Lemma ocaml_union_1 : In x (ocaml_union s s') -> In x s \/ In x s'. - Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed. - Lemma ocaml_union_2 : In x s -> In x (ocaml_union s s'). - Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed. - Lemma ocaml_union_3 : In x s' -> In x (ocaml_union s s'). - Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed. - - Lemma inter_1 : In x (inter s s') -> In x s. - Proof. wrap inter inter_in. Qed. - Lemma inter_2 : In x (inter s s') -> In x s'. - Proof. wrap inter inter_in. Qed. - Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). - Proof. wrap inter inter_in. Qed. - - Lemma diff_1 : In x (diff s s') -> In x s. - Proof. wrap diff diff_in. Qed. - Lemma diff_2 : In x (diff s s') -> ~ In x s'. - Proof. wrap diff diff_in. Qed. - Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - Proof. wrap diff diff_in. Qed. - - Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. - unfold fold, elements; intros; apply fold_1; auto. - Qed. - - Lemma cardinal_1 : cardinal s = length (elements s). - Proof. - unfold cardinal, elements; intros; apply elements_cardinal; auto. - Qed. - - Section Filter. - Variable f : elt -> bool. - - Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Proof. intro. wrap filter filter_in. Qed. - Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Proof. intro. wrap filter filter_in. Qed. - Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. intro. wrap filter filter_in. Qed. - - Lemma for_all_1 : compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. - Proof. exact (@for_all_1 f s). Qed. - Lemma for_all_2 : compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. - Proof. exact (@for_all_2 f s). Qed. - - Lemma exists_1 : compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. exact (@exists_1 f s). Qed. - Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. exact (@exists_2 f s). Qed. - - Lemma partition_1 : compat_bool E.eq f -> - Equal (fst (partition f s)) (filter f s). - Proof. - unfold partition, filter, Equal, In; simpl ;intros H a. - rewrite partition_in_1, filter_in; intuition. - Qed. - - Lemma partition_2 : compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - unfold partition, filter, Equal, In; simpl ;intros H a. - rewrite partition_in_2, filter_in; intuition. - rewrite H2; auto. - destruct (f a); auto. - red; intros; f_equal. - rewrite (H _ _ H0); auto. - Qed. - - End Filter. - - Lemma elements_1 : In x s -> InA E.eq x (elements s). - Proof. wrap elements elements_in. Qed. - Lemma elements_2 : InA E.eq x (elements s) -> In x s. - Proof. wrap elements elements_in. Qed. - Lemma elements_3 : sort E.lt (elements s). - Proof. exact (elements_sort (is_bst s)). Qed. - Lemma elements_3w : NoDupA E.eq (elements s). - Proof. exact (elements_nodup (is_bst s)). Qed. - - Lemma min_elt_1 : min_elt s = Some x -> In x s. - Proof. exact (@min_elt_1 s x). Qed. - Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. - Proof. exact (@min_elt_2 s x y (is_bst s)). Qed. - Lemma min_elt_3 : min_elt s = None -> Empty s. - Proof. exact (@min_elt_3 s). Qed. - - Lemma max_elt_1 : max_elt s = Some x -> In x s. - Proof. exact (@max_elt_1 s x). Qed. - Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. - Proof. exact (@max_elt_2 s x y (is_bst s)). Qed. - Lemma max_elt_3 : max_elt s = None -> Empty s. - Proof. exact (@max_elt_3 s). Qed. - - Lemma choose_1 : choose s = Some x -> In x s. - Proof. exact (@choose_1 s x). Qed. - Lemma choose_2 : choose s = None -> Empty s. - Proof. exact (@choose_2 s). Qed. - Lemma choose_3 : choose s = Some x -> choose s' = Some y -> - Equal s s' -> E.eq x y. - Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed. - - Lemma eq_refl : eq s s. - Proof. exact (eq_refl s). Qed. - Lemma eq_sym : eq s s' -> eq s' s. - Proof. exact (@eq_sym s s'). Qed. - Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''. - Proof. exact (@eq_trans s s' s''). Qed. - - Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''. - Proof. exact (@lt_trans s s' s''). Qed. - Lemma lt_not_eq : lt s s' -> ~eq s s'. - Proof. exact (@lt_not_eq _ _ (is_bst s) (is_bst s')). Qed. - - End Specs. -End IntMake. - -(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) - -Module Make (X: OrderedType) <: S with Module E := X - :=IntMake(Z_as_Int)(X). - diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index 79eea34e..8aede552 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -6,17 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetInterface.v 11701 2008-12-18 11:49:12Z letouzey $ *) +(* $Id$ *) (** * Finite set library *) -(** Set interfaces, inspired by the one of Ocaml. When compared with - Ocaml, the main differences are: +(** Set interfaces, inspired by the one of Ocaml. When compared with + Ocaml, the main differences are: - the lack of [iter] function, useless since Coq is purely functional - the use of [option] types instead of [Not_found] exceptions - - the use of [nat] instead of [int] for the [cardinal] function + - the use of [nat] instead of [int] for the [cardinal] function - Several variants of the set interfaces are available: + Several variants of the set interfaces are available: - [WSfun] : functorial signature for weak sets, non-dependent style - [WS] : self-contained version of [WSfun] - [Sfun] : functorial signature for ordered sets, non-dependent style @@ -24,7 +24,7 @@ - [Sdep] : analog of [S] written using dependent style If unsure, [S] is probably what you're looking for: other signatures - are subsets of it, apart from [Sdep] which is isomorphic to [S] (see + are subsets of it, apart from [Sdep] which is isomorphic to [S] (see [FSetBridge]). *) @@ -34,14 +34,14 @@ Unset Strict Implicit. (** * Non-dependent signatures - The following signatures presents sets as purely informative + The following signatures presents sets as purely informative programs together with axioms *) (** ** Functorial signature for weak sets - Weak sets are sets without ordering on base elements, only + Weak sets are sets without ordering on base elements, only a decidable equality. *) Module Type WSfun (E : DecidableType). @@ -57,7 +57,7 @@ Module Type WSfun (E : DecidableType). Definition Empty s := forall a : elt, ~ In a s. Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). @@ -137,7 +137,7 @@ Module Type WSfun (E : DecidableType). the set is empty. Which element is chosen is unspecified. Equal sets could return different elements. *) - Section Spec. + Section Spec. Variable s s' s'': t. Variable x y : elt. @@ -146,15 +146,15 @@ Module Type WSfun (E : DecidableType). Parameter In_1 : E.eq x y -> In x s -> In y s. (** Specification of [eq] *) - Parameter eq_refl : eq s s. + Parameter eq_refl : eq s s. Parameter eq_sym : eq s s' -> eq s' s. Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''. (** Specification of [mem] *) Parameter mem_1 : In x s -> mem x s = true. - Parameter mem_2 : mem x s = true -> In x s. - - (** Specification of [equal] *) + Parameter mem_2 : mem x s = true -> In x s. + + (** Specification of [equal] *) Parameter equal_1 : Equal s s' -> equal s s' = true. Parameter equal_2 : equal s s' = true -> Equal s s'. @@ -166,13 +166,13 @@ Module Type WSfun (E : DecidableType). Parameter empty_1 : Empty empty. (** Specification of [is_empty] *) - Parameter is_empty_1 : Empty s -> is_empty s = true. + Parameter is_empty_1 : Empty s -> is_empty s = true. Parameter is_empty_2 : is_empty s = true -> Empty s. - + (** Specification of [add] *) Parameter add_1 : E.eq x y -> In y (add x s). Parameter add_2 : In y s -> In y (add x s). - Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. + Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. (** Specification of [remove] *) Parameter remove_1 : E.eq x y -> ~ In y (remove x s). @@ -180,12 +180,12 @@ Module Type WSfun (E : DecidableType). Parameter remove_3 : In y (remove x s) -> In y s. (** Specification of [singleton] *) - Parameter singleton_1 : In y (singleton x) -> E.eq x y. - Parameter singleton_2 : E.eq x y -> In y (singleton x). + Parameter singleton_1 : In y (singleton x) -> E.eq x y. + Parameter singleton_2 : E.eq x y -> In y (singleton x). (** Specification of [union] *) Parameter union_1 : In x (union s s') -> In x s \/ In x s'. - Parameter union_2 : In x s -> In x (union s s'). + Parameter union_2 : In x s -> In x (union s s'). Parameter union_3 : In x s' -> In x (union s s'). (** Specification of [inter] *) @@ -194,24 +194,24 @@ Module Type WSfun (E : DecidableType). Parameter inter_3 : In x s -> In x s' -> In x (inter s s'). (** Specification of [diff] *) - Parameter diff_1 : In x (diff s s') -> In x s. + Parameter diff_1 : In x (diff s s') -> In x s. Parameter diff_2 : In x (diff s s') -> ~ In x s'. Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - - (** Specification of [fold] *) + + (** Specification of [fold] *) Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. - (** Specification of [cardinal] *) + (** Specification of [cardinal] *) Parameter cardinal_1 : cardinal s = length (elements s). Section Filter. - + Variable f : elt -> bool. (** Specification of [filter] *) - Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. + Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. Parameter filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). @@ -243,7 +243,7 @@ Module Type WSfun (E : DecidableType). (** Specification of [elements] *) Parameter elements_1 : In x s -> InA E.eq x (elements s). Parameter elements_2 : InA E.eq x (elements s) -> In x s. - (** When compared with ordered sets, here comes the only + (** When compared with ordered sets, here comes the only property that is really weaker: *) Parameter elements_3w : NoDupA E.eq (elements s). @@ -257,11 +257,11 @@ Module Type WSfun (E : DecidableType). is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 remove_2 singleton_2 union_1 union_2 union_3 inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 - partition_1 partition_2 elements_1 elements_3w + partition_1 partition_2 elements_1 elements_3w : set. Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 - filter_1 filter_2 for_all_2 exists_2 elements_2 + filter_1 filter_2 for_all_2 exists_2 elements_2 : set. End WSfun. @@ -270,12 +270,12 @@ End WSfun. (** ** Static signature for weak sets - Similar to the functorial signature [SW], except that the + Similar to the functorial signature [SW], except that the module [E] of base elements is incorporated in the signature. *) Module Type WS. Declare Module E : DecidableType. - Include Type WSfun E. + Include WSfun E. End WS. @@ -286,7 +286,7 @@ End WS. and some stronger specifications for other functions. *) Module Type Sfun (E : OrderedType). - Include Type WSfun E. + Include WSfun E. Parameter lt : t -> t -> Prop. Parameter compare : forall s s' : t, Compare lt eq s s'. @@ -295,48 +295,48 @@ Module Type Sfun (E : OrderedType). Parameter min_elt : t -> option elt. (** Return the smallest element of the given set - (with respect to the [E.compare] ordering), + (with respect to the [E.compare] ordering), or [None] if the set is empty. *) Parameter max_elt : t -> option elt. (** Same as [min_elt], but returns the largest element of the given set. *) - Section Spec. + Section Spec. Variable s s' s'' : t. Variable x y : elt. - + (** Specification of [lt] *) Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''. Parameter lt_not_eq : lt s s' -> ~ eq s s'. (** Additional specification of [elements] *) - Parameter elements_3 : sort E.lt (elements s). + Parameter elements_3 : sort E.lt (elements s). (** Remark: since [fold] is specified via [elements], this stronger - specification of [elements] has an indirect impact on [fold], + specification of [elements] has an indirect impact on [fold], which can now be proved to receive elements in increasing order. *) (** Specification of [min_elt] *) - Parameter min_elt_1 : min_elt s = Some x -> In x s. - Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. + Parameter min_elt_1 : min_elt s = Some x -> In x s. + Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. Parameter min_elt_3 : min_elt s = None -> Empty s. - (** Specification of [max_elt] *) - Parameter max_elt_1 : max_elt s = Some x -> In x s. - Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. + (** Specification of [max_elt] *) + Parameter max_elt_1 : max_elt s = Some x -> In x s. + Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. Parameter max_elt_3 : max_elt s = None -> Empty s. (** Additional specification of [choose] *) - Parameter choose_3 : choose s = Some x -> choose s' = Some y -> + Parameter choose_3 : choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. End Spec. Hint Resolve elements_3 : set. - Hint Immediate + Hint Immediate min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3 : set. End Sfun. @@ -344,12 +344,12 @@ End Sfun. (** ** Static signature for sets on ordered elements - Similar to the functorial signature [Sfun], except that the + Similar to the functorial signature [Sfun], except that the module [E] of base elements is incorporated in the signature. *) Module Type S. Declare Module E : OrderedType. - Include Type Sfun E. + Include Sfun E. End S. @@ -411,7 +411,7 @@ Module Type Sdep. Parameter singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. - + Parameter remove : forall (x : elt) (s : t), @@ -433,7 +433,7 @@ Module Type Sdep. {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. Parameter equal : forall s s' : t, {s[=]s'} + {~ s[=]s'}. - + Parameter subset : forall s s' : t, {Subset s s'} + {~ Subset s s'}. Parameter @@ -447,7 +447,7 @@ Module Type Sdep. forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. - + Parameter exists_ : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) @@ -474,7 +474,7 @@ Module Type Sdep. Parameter fold : forall (A : Type) (f : elt -> A -> A) (s : t) (i : A), - {r : A | let (l,_) := elements s in + {r : A | let (l,_) := elements s in r = fold_left (fun a e => f e a) l i}. Parameter @@ -494,10 +494,10 @@ Module Type Sdep. Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}. - (** The [choose_3] specification of [S] cannot be packed + (** The [choose_3] specification of [S] cannot be packed in the dependent version of [choose], so we leave it separate. *) - Parameter choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with + Parameter choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with | inleft (exist x _), inleft (exist x' _) => E.eq x x' | inright _, inright _ => True | _, _ => False diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v index b009e109..f83259c4 100644 --- a/theories/FSets/FSetList.v +++ b/theories/FSets/FSetList.v @@ -6,1271 +6,24 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetList.v 11866 2009-01-28 19:10:15Z letouzey $ *) +(* $Id$ *) (** * Finite sets library *) -(** This file proposes an implementation of the non-dependant +(** This file proposes an implementation of the non-dependant interface [FSetInterface.S] using strictly ordered list. *) Require Export FSetInterface. Set Implicit Arguments. Unset Strict Implicit. -(** * Functions over lists +(** This is just a compatibility layer, the real implementation + is now in [MSetList] *) - First, we provide sets as lists which are not necessarily sorted. - The specs are proved under the additional condition of being sorted. - And the functions returning sets are proved to preserve this invariant. *) - -Module Raw (X: OrderedType). - - Module MX := OrderedTypeFacts X. - Import MX. - - Definition elt := X.t. - Definition t := list elt. - - Definition empty : t := nil. - - Definition is_empty (l : t) : bool := if l then true else false. - - (** ** The set operations. *) - - Fixpoint mem (x : elt) (s : t) {struct s} : bool := - match s with - | nil => false - | y :: l => - match X.compare x y with - | LT _ => false - | EQ _ => true - | GT _ => mem x l - end - end. - - Fixpoint add (x : elt) (s : t) {struct s} : t := - match s with - | nil => x :: nil - | y :: l => - match X.compare x y with - | LT _ => x :: s - | EQ _ => s - | GT _ => y :: add x l - end - end. - - Definition singleton (x : elt) : t := x :: nil. - - Fixpoint remove (x : elt) (s : t) {struct s} : t := - match s with - | nil => nil - | y :: l => - match X.compare x y with - | LT _ => s - | EQ _ => l - | GT _ => y :: remove x l - end - end. - - Fixpoint union (s : t) : t -> t := - match s with - | nil => fun s' => s' - | x :: l => - (fix union_aux (s' : t) : t := - match s' with - | nil => s - | x' :: l' => - match X.compare x x' with - | LT _ => x :: union l s' - | EQ _ => x :: union l l' - | GT _ => x' :: union_aux l' - end - end) - end. - - Fixpoint inter (s : t) : t -> t := - match s with - | nil => fun _ => nil - | x :: l => - (fix inter_aux (s' : t) : t := - match s' with - | nil => nil - | x' :: l' => - match X.compare x x' with - | LT _ => inter l s' - | EQ _ => x :: inter l l' - | GT _ => inter_aux l' - end - end) - end. - - Fixpoint diff (s : t) : t -> t := - match s with - | nil => fun _ => nil - | x :: l => - (fix diff_aux (s' : t) : t := - match s' with - | nil => s - | x' :: l' => - match X.compare x x' with - | LT _ => x :: diff l s' - | EQ _ => diff l l' - | GT _ => diff_aux l' - end - end) - end. - - Fixpoint equal (s : t) : t -> bool := - fun s' : t => - match s, s' with - | nil, nil => true - | x :: l, x' :: l' => - match X.compare x x' with - | EQ _ => equal l l' - | _ => false - end - | _, _ => false - end. - - Fixpoint subset (s s' : t) {struct s'} : bool := - match s, s' with - | nil, _ => true - | x :: l, x' :: l' => - match X.compare x x' with - | LT _ => false - | EQ _ => subset l l' - | GT _ => subset s l' - end - | _, _ => false - end. - - Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : - B -> B := fun i => match s with - | nil => i - | x :: l => fold f l (f x i) - end. - - Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t := - match s with - | nil => nil - | x :: l => if f x then x :: filter f l else filter f l - end. - - Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool := - match s with - | nil => true - | x :: l => if f x then for_all f l else false - end. - - Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool := - match s with - | nil => false - | x :: l => if f x then true else exists_ f l - end. - - Fixpoint partition (f : elt -> bool) (s : t) {struct s} : - t * t := - match s with - | nil => (nil, nil) - | x :: l => - let (s1, s2) := partition f l in - if f x then (x :: s1, s2) else (s1, x :: s2) - end. - - Definition cardinal (s : t) : nat := length s. - - Definition elements (x : t) : list elt := x. - - Definition min_elt (s : t) : option elt := - match s with - | nil => None - | x :: _ => Some x - end. - - Fixpoint max_elt (s : t) : option elt := - match s with - | nil => None - | x :: nil => Some x - | _ :: l => max_elt l - end. - - Definition choose := min_elt. - - (** ** Proofs of set operation specifications. *) - - Section ForNotations. - - Notation Sort := (sort X.lt). - Notation Inf := (lelistA X.lt). - Notation In := (InA X.eq). - - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x. - - Lemma mem_1 : - forall (s : t) (Hs : Sort s) (x : elt), In x s -> mem x s = true. - Proof. - simple induction s; intros. - inversion H. - inversion_clear Hs. - inversion_clear H0. - simpl; elim_comp; trivial. - simpl; elim_comp_gt x a; auto. - apply Sort_Inf_In with l; trivial. - Qed. - - Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. - Proof. - simple induction s. - intros; inversion H. - intros a l Hrec x. - simpl. - case (X.compare x a); intros; try discriminate; auto. - Qed. - - Lemma add_Inf : - forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); intuition; inversion H0; - intuition. - Qed. - Hint Resolve add_Inf. - - Lemma add_sort : forall (s : t) (Hs : Sort s) (x : elt), Sort (add x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; - auto. - Qed. - - Lemma add_1 : - forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> In y (add x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); inversion_clear Hs; auto. - constructor; apply X.eq_trans with x; auto. - Qed. - - Lemma add_2 : - forall (s : t) (Hs : Sort s) (x y : elt), In y s -> In y (add x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); intuition. - inversion_clear Hs; inversion_clear H0; auto. - Qed. - - Lemma add_3 : - forall (s : t) (Hs : Sort s) (x y : elt), - ~ X.eq x y -> In y (add x s) -> In y s. - Proof. - simple induction s. - simpl; inversion_clear 3; auto; order. - simpl; intros a l Hrec Hs x y; case (X.compare x a); intros; - inversion_clear H0; inversion_clear Hs; auto. - order. - constructor 2; apply Hrec with x; auto. - Qed. - - Lemma remove_Inf : - forall (s : t) (Hs : Sort s) (x a : elt), Inf a s -> Inf a (remove x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); intuition; inversion_clear H0; auto. - inversion_clear Hs; apply Inf_lt with a; auto. - Qed. - Hint Resolve remove_Inf. - - Lemma remove_sort : - forall (s : t) (Hs : Sort s) (x : elt), Sort (remove x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; auto. - Qed. - - Lemma remove_1 : - forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> ~ In y (remove x s). - Proof. - simple induction s. - simpl; red; intros; inversion H0. - simpl; intros; case (X.compare x a); intuition; inversion_clear Hs. - inversion_clear H1. - order. - generalize (Sort_Inf_In H2 H3 H4); order. - generalize (Sort_Inf_In H2 H3 H1); order. - inversion_clear H1. - order. - apply (H H2 _ _ H0 H4). - Qed. - - Lemma remove_2 : - forall (s : t) (Hs : Sort s) (x y : elt), - ~ X.eq x y -> In y s -> In y (remove x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; - inversion_clear H1; auto. - destruct H0; apply X.eq_trans with a; auto. - Qed. - - Lemma remove_3 : - forall (s : t) (Hs : Sort s) (x y : elt), In y (remove x s) -> In y s. - Proof. - simple induction s. - simpl; intuition. - simpl; intros a l Hrec Hs x y; case (X.compare x a); intuition. - inversion_clear Hs; inversion_clear H; auto. - constructor 2; apply Hrec with x; auto. - Qed. - - Lemma singleton_sort : forall x : elt, Sort (singleton x). - Proof. - unfold singleton; simpl; auto. - Qed. - - Lemma singleton_1 : forall x y : elt, In y (singleton x) -> X.eq x y. - Proof. - unfold singleton; simpl; intuition. - inversion_clear H; auto; inversion H0. - Qed. - - Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x). - Proof. - unfold singleton; simpl; auto. - Qed. - - Ltac DoubleInd := - simple induction s; - [ simpl; auto; try solve [ intros; inversion H ] - | intros x l Hrec; simple induction s'; - [ simpl; auto; try solve [ intros; inversion H ] - | intros x' l' Hrec' Hs Hs'; inversion Hs; inversion Hs'; subst; - simpl ] ]. - - Lemma union_Inf : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt), - Inf a s -> Inf a s' -> Inf a (union s s'). - Proof. - DoubleInd. - intros i His His'; inversion_clear His; inversion_clear His'. - case (X.compare x x'); auto. - Qed. - Hint Resolve union_Inf. - - Lemma union_sort : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (union s s'). - Proof. - DoubleInd; case (X.compare x x'); intuition; constructor; auto. - apply Inf_eq with x'; trivial; apply union_Inf; trivial; apply Inf_eq with x; auto. - change (Inf x' (union (x :: l) l')); auto. - Qed. - - Lemma union_1 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x (union s s') -> In x s \/ In x s'. - Proof. - DoubleInd; case (X.compare x x'); intuition; inversion_clear H; intuition. - elim (Hrec (x' :: l') H1 Hs' x0); intuition. - elim (Hrec l' H1 H5 x0); intuition. - elim (H0 x0); intuition. - Qed. - - Lemma union_2 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x s -> In x (union s s'). - Proof. - DoubleInd. - intros i Hi; case (X.compare x x'); intuition; inversion_clear Hi; auto. - Qed. - - Lemma union_3 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x s' -> In x (union s s'). - Proof. - DoubleInd. - intros i Hi; case (X.compare x x'); inversion_clear Hi; intuition. - constructor; apply X.eq_trans with x'; auto. - Qed. - - Lemma inter_Inf : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt), - Inf a s -> Inf a s' -> Inf a (inter s s'). - Proof. - DoubleInd. - intros i His His'; inversion His; inversion His'; subst. - case (X.compare x x'); intuition. - apply Inf_lt with x; auto. - apply H3; auto. - apply Inf_lt with x'; auto. - Qed. - Hint Resolve inter_Inf. - - Lemma inter_sort : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (inter s s'). - Proof. - DoubleInd; case (X.compare x x'); auto. - constructor; auto. - apply Inf_eq with x'; trivial; apply inter_Inf; trivial; apply Inf_eq with x; auto. - Qed. - - Lemma inter_1 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x (inter s s') -> In x s. - Proof. - DoubleInd; case (X.compare x x'); intuition. - constructor 2; apply Hrec with (x'::l'); auto. - inversion_clear H; auto. - constructor 2; apply Hrec with l'; auto. - Qed. - - Lemma inter_2 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x (inter s s') -> In x s'. - Proof. - DoubleInd; case (X.compare x x'); intuition; inversion_clear H. - constructor 1; apply X.eq_trans with x; auto. - constructor 2; auto. - Qed. - - Lemma inter_3 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x s -> In x s' -> In x (inter s s'). - Proof. - DoubleInd. - intros i His His'; elim (X.compare x x'); intuition. - - inversion_clear His; auto. - generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) His'); order. - - inversion_clear His; auto; inversion_clear His'; auto. - constructor; apply X.eq_trans with x'; auto. - - change (In i (inter (x :: l) l')). - inversion_clear His'; auto. - generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) His); order. - Qed. - - Lemma diff_Inf : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt), - Inf a s -> Inf a s' -> Inf a (diff s s'). - Proof. - DoubleInd. - intros i His His'; inversion His; inversion His'. - case (X.compare x x'); intuition. - apply Hrec; trivial. - apply Inf_lt with x; auto. - apply Inf_lt with x'; auto. - apply H10; trivial. - apply Inf_lt with x'; auto. - Qed. - Hint Resolve diff_Inf. - - Lemma diff_sort : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (diff s s'). - Proof. - DoubleInd; case (X.compare x x'); auto. - Qed. - - Lemma diff_1 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x (diff s s') -> In x s. - Proof. - DoubleInd; case (X.compare x x'); intuition. - inversion_clear H; auto. - constructor 2; apply Hrec with (x'::l'); auto. - constructor 2; apply Hrec with l'; auto. - Qed. - - Lemma diff_2 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x (diff s s') -> ~ In x s'. - Proof. - DoubleInd. - intros; intro Abs; inversion Abs. - case (X.compare x x'); intuition. - - inversion_clear H. - generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) H3); order. - apply Hrec with (x'::l') x0; auto. - - inversion_clear H3. - generalize (Sort_Inf_In H1 H2 (diff_1 H1 H5 H)); order. - apply Hrec with l' x0; auto. - - inversion_clear H3. - generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) (diff_1 Hs H5 H)); order. - apply H0 with x0; auto. - Qed. - - Lemma diff_3 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x s -> ~ In x s' -> In x (diff s s'). - Proof. - DoubleInd. - intros i His His'; elim (X.compare x x'); intuition; inversion_clear His; auto. - elim His'; constructor; apply X.eq_trans with x; auto. - Qed. - - Lemma equal_1 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), - Equal s s' -> equal s s' = true. - Proof. - simple induction s; unfold Equal. - intro s'; case s'; auto. - simpl; intuition. - elim (H e); intros; assert (A : In e nil); auto; inversion A. - intros x l Hrec s'. - case s'. - intros; elim (H x); intros; assert (A : In x nil); auto; inversion A. - intros x' l' Hs Hs'; inversion Hs; inversion Hs'; subst. - simpl; case (X.compare x); intros; auto. - - elim (H x); intros. - assert (A : In x (x' :: l')); auto; inversion_clear A. - order. - generalize (Sort_Inf_In H5 H6 H4); order. - - apply Hrec; intuition; elim (H a); intros. - assert (A : In a (x' :: l')); auto; inversion_clear A; auto. - generalize (Sort_Inf_In H1 H2 H0); order. - assert (A : In a (x :: l)); auto; inversion_clear A; auto. - generalize (Sort_Inf_In H5 H6 H0); order. - - elim (H x'); intros. - assert (A : In x' (x :: l)); auto; inversion_clear A. - order. - generalize (Sort_Inf_In H1 H2 H4); order. - Qed. - - Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'. - Proof. - simple induction s; unfold Equal. - intro s'; case s'; intros. - intuition. - simpl in H; discriminate H. - intros x l Hrec s'. - case s'. - intros; simpl in H; discriminate. - intros x' l'; simpl; case (X.compare x); intros; auto; try discriminate. - elim (Hrec l' H a); intuition; inversion_clear H2; auto. - constructor; apply X.eq_trans with x; auto. - constructor; apply X.eq_trans with x'; auto. - Qed. - - Lemma subset_1 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), - Subset s s' -> subset s s' = true. - Proof. - intros s s'; generalize s' s; clear s s'. - simple induction s'; unfold Subset. - intro s; case s; auto. - intros; elim (H e); intros; assert (A : In e nil); auto; inversion A. - intros x' l' Hrec s; case s. - simpl; auto. - intros x l Hs Hs'; inversion Hs; inversion Hs'; subst. - simpl; case (X.compare x); intros; auto. - - assert (A : In x (x' :: l')); auto; inversion_clear A. - order. - generalize (Sort_Inf_In H5 H6 H0); order. - - apply Hrec; intuition. - assert (A : In a (x' :: l')); auto; inversion_clear A; auto. - generalize (Sort_Inf_In H1 H2 H0); order. - - apply Hrec; intuition. - assert (A : In a (x' :: l')); auto; inversion_clear A; auto. - inversion_clear H0. - order. - generalize (Sort_Inf_In H1 H2 H4); order. - Qed. - - Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'. - Proof. - intros s s'; generalize s' s; clear s s'. - simple induction s'; unfold Subset. - intro s; case s; auto. - simpl; intros; discriminate H. - intros x' l' Hrec s; case s. - intros; inversion H0. - intros x l; simpl; case (X.compare x); intros; auto. - discriminate H. - inversion_clear H0. - constructor; apply X.eq_trans with x; auto. - constructor 2; apply Hrec with l; auto. - constructor 2; apply Hrec with (x::l); auto. - Qed. - - Lemma empty_sort : Sort empty. - Proof. - unfold empty; constructor. - Qed. - - Lemma empty_1 : Empty empty. - Proof. - unfold Empty, empty; intuition; inversion H. - Qed. - - Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true. - Proof. - unfold Empty; intro s; case s; simpl; intuition. - elim (H e); auto. - Qed. - - Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. - Proof. - unfold Empty; intro s; case s; simpl; intuition; - inversion H0. - Qed. - - Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s). - Proof. - unfold elements; auto. - Qed. - - Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s. - Proof. - unfold elements; auto. - Qed. - - Lemma elements_3 : forall (s : t) (Hs : Sort s), Sort (elements s). - Proof. - unfold elements; auto. - Qed. - - Lemma elements_3w : forall (s : t) (Hs : Sort s), NoDupA X.eq (elements s). - Proof. - unfold elements; auto. - Qed. - - Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. - Proof. - intro s; case s; simpl; intros; inversion H; auto. - Qed. - - Lemma min_elt_2 : - forall (s : t) (Hs : Sort s) (x y : elt), - min_elt s = Some x -> In y s -> ~ X.lt y x. - Proof. - simple induction s; simpl. - intros; inversion H. - intros a l; case l; intros; inversion H0; inversion_clear H1; subst. - order. - inversion H2. - order. - inversion_clear Hs. - inversion_clear H3. - generalize (H H1 e y (refl_equal (Some e)) H2); order. - Qed. - - Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s. - Proof. - unfold Empty; intro s; case s; simpl; intuition; - inversion H; inversion H0. - Qed. - - Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. - Proof. - simple induction s; simpl. - intros; inversion H. - intros x l; case l; simpl. - intuition. - inversion H0; auto. - intros. - constructor 2; apply (H _ H0). - Qed. - - Lemma max_elt_2 : - forall (s : t) (Hs : Sort s) (x y : elt), - max_elt s = Some x -> In y s -> ~ X.lt x y. - Proof. - simple induction s; simpl. - intros; inversion H. - intros x l; case l; simpl. - intuition. - inversion H0; subst. - inversion_clear H1. - order. - inversion H3. - intros; inversion_clear Hs; inversion_clear H3; inversion_clear H1. - assert (In e (e::l0)) by auto. - generalize (H H2 x0 e H0 H1); order. - generalize (H H2 x0 y H0 H3); order. - Qed. - - Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s. - Proof. - unfold Empty; simple induction s; simpl. - red; intros; inversion H0. - intros x l; case l; simpl; intros. - inversion H0. - elim (H H0 e); auto. - Qed. - - Definition choose_1 : - forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_1. - - Definition choose_2 : forall s : t, choose s = None -> Empty s := min_elt_3. - - Lemma choose_3: forall s s', Sort s -> Sort s' -> forall x x', - choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'. - Proof. - unfold choose, Equal; intros s s' Hs Hs' x x' Hx Hx' H. - assert (~X.lt x x'). - apply min_elt_2 with s'; auto. - rewrite <-H; auto using min_elt_1. - assert (~X.lt x' x). - apply min_elt_2 with s; auto. - rewrite H; auto using min_elt_1. - destruct (X.compare x x'); intuition. - Qed. - - Lemma fold_1 : - forall (s : t) (Hs : Sort 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. - induction s. - simpl; trivial. - intros. - inversion_clear Hs. - simpl; auto. - Qed. - - Lemma cardinal_1 : - forall (s : t) (Hs : Sort s), - cardinal s = length (elements s). - Proof. - auto. - Qed. - - Lemma filter_Inf : - forall (s : t) (Hs : Sort s) (x : elt) (f : elt -> bool), - Inf x s -> Inf x (filter f s). - Proof. - simple induction s; simpl. - intuition. - intros x l Hrec Hs a f Ha; inversion_clear Hs; inversion_clear Ha. - case (f x). - constructor; auto. - apply Hrec; auto. - apply Inf_lt with x; auto. - Qed. - - Lemma filter_sort : - forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (filter f s). - Proof. - simple induction s; simpl. - auto. - intros x l Hrec Hs f; inversion_clear Hs. - case (f x); auto. - constructor; auto. - apply filter_Inf; auto. - Qed. - - Lemma filter_1 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x (filter f s) -> In x s. - Proof. - simple induction s; simpl. - intros; inversion H0. - intros x l Hrec a f Hf. - case (f x); simpl. - inversion_clear 1. - constructor; auto. - constructor 2; apply (Hrec a f Hf); trivial. - constructor 2; apply (Hrec a f Hf); trivial. - Qed. - - Lemma filter_2 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x (filter f s) -> f x = true. - Proof. - simple induction s; simpl. - intros; inversion H0. - intros x l Hrec a f Hf. - generalize (Hf x); case (f x); simpl; auto. - inversion_clear 2; auto. - symmetry; auto. - Qed. - - Lemma filter_3 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. - simple induction s; simpl. - intros; inversion H0. - intros x l Hrec a f Hf. - generalize (Hf x); case (f x); simpl. - inversion_clear 2; auto. - inversion_clear 2; auto. - rewrite <- (H a (X.eq_sym H1)); intros; discriminate. - Qed. - - Lemma for_all_1 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Proof. - simple induction s; simpl; auto; unfold For_all. - intros x l Hrec f Hf. - generalize (Hf x); case (f x); simpl. - auto. - intros; rewrite (H x); auto. - Qed. - - Lemma for_all_2 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - Proof. - simple induction s; simpl; auto; unfold For_all. - intros; inversion H1. - intros x l Hrec f Hf. - intros A a; intros. - assert (f x = true). - generalize A; case (f x); auto. - rewrite H0 in A; simpl in A. - inversion_clear H; auto. - rewrite (Hf a x); auto. - Qed. - - Lemma exists_1 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. - simple induction s; simpl; auto; unfold Exists. - intros. - elim H0; intuition. - inversion H2. - intros x l Hrec f Hf. - generalize (Hf x); case (f x); simpl. - auto. - destruct 2 as [a (A1,A2)]. - inversion_clear A1. - rewrite <- (H a (X.eq_sym H0)) in A2; discriminate. - apply Hrec; auto. - exists a; auto. - Qed. - - Lemma exists_2 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. - simple induction s; simpl; auto; unfold Exists. - intros; discriminate. - intros x l Hrec f Hf. - case_eq (f x); intros. - exists x; auto. - destruct (Hrec f Hf H0) as [a (A1,A2)]. - exists a; auto. - Qed. - - Lemma partition_Inf_1 : - forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt), - Inf x s -> Inf x (fst (partition f s)). - Proof. - simple induction s; simpl. - intuition. - intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha. - generalize (Hrec H f a). - case (f x); case (partition f l); simpl. - auto. - intros; apply H2; apply Inf_lt with x; auto. - Qed. - - Lemma partition_Inf_2 : - forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt), - Inf x s -> Inf x (snd (partition f s)). - Proof. - simple induction s; simpl. - intuition. - intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha. - generalize (Hrec H f a). - case (f x); case (partition f l); simpl. - intros; apply H2; apply Inf_lt with x; auto. - auto. - Qed. - - Lemma partition_sort_1 : - forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (fst (partition f s)). - Proof. - simple induction s; simpl. - auto. - intros x l Hrec Hs f; inversion_clear Hs. - generalize (Hrec H f); generalize (partition_Inf_1 H f). - case (f x); case (partition f l); simpl; auto. - Qed. - - Lemma partition_sort_2 : - forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (snd (partition f s)). - Proof. - simple induction s; simpl. - auto. - intros x l Hrec Hs f; inversion_clear Hs. - generalize (Hrec H f); generalize (partition_Inf_2 H f). - case (f x); case (partition f l); simpl; auto. - Qed. - - Lemma partition_1 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> Equal (fst (partition f s)) (filter f s). - Proof. - simple induction s; simpl; auto; unfold Equal. - split; auto. - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - destruct (partition f l) as [s1 s2]; simpl; intros. - case (f x); simpl; auto. - split; inversion_clear 1; auto. - constructor 2; rewrite <- H; auto. - constructor 2; rewrite H; auto. - Qed. - - Lemma partition_2 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - simple induction s; simpl; auto; unfold Equal. - split; auto. - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - destruct (partition f l) as [s1 s2]; simpl; intros. - case (f x); simpl; auto. - split; inversion_clear 1; auto. - constructor 2; rewrite <- H; auto. - constructor 2; rewrite H; auto. - Qed. - - Definition eq : t -> t -> Prop := Equal. - - Lemma eq_refl : forall s : t, eq s s. - Proof. - unfold eq, Equal; intuition. - Qed. - - Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s. - Proof. - unfold eq, Equal; intros; destruct (H a); intuition. - Qed. - - Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. - Proof. - unfold eq, Equal; intros; destruct (H a); destruct (H0 a); intuition. - Qed. - - Inductive lt : t -> t -> Prop := - | lt_nil : forall (x : elt) (s : t), lt nil (x :: s) - | lt_cons_lt : - forall (x y : elt) (s s' : t), X.lt x y -> lt (x :: s) (y :: s') - | lt_cons_eq : - forall (x y : elt) (s s' : t), - X.eq x y -> lt s s' -> lt (x :: s) (y :: s'). - Hint Constructors lt. - - Lemma lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''. - Proof. - intros s s' s'' H; generalize s''; clear s''; elim H. - intros x l s'' H'; inversion_clear H'; auto. - intros x x' l l' E s'' H'; inversion_clear H'; auto. - constructor; apply X.lt_trans with x'; auto. - constructor; apply lt_eq with x'; auto. - intros. - inversion_clear H3. - constructor; apply eq_lt with y; auto. - constructor 3; auto; apply X.eq_trans with y; auto. - Qed. - - Lemma lt_not_eq : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), lt s s' -> ~ eq s s'. - Proof. - unfold eq, Equal. - intros s s' Hs Hs' H; generalize Hs Hs'; clear Hs Hs'; elim H; intros; intro. - elim (H0 x); intros. - assert (X : In x nil); auto; inversion X. - inversion_clear Hs; inversion_clear Hs'. - elim (H1 x); intros. - assert (X : In x (y :: s'0)); auto; inversion_clear X. - order. - generalize (Sort_Inf_In H4 H5 H8); order. - inversion_clear Hs; inversion_clear Hs'. - elim H2; auto; split; intros. - generalize (Sort_Inf_In H4 H5 H8); intros. - elim (H3 a); intros. - assert (X : In a (y :: s'0)); auto; inversion_clear X; auto. - order. - generalize (Sort_Inf_In H6 H7 H8); intros. - elim (H3 a); intros. - assert (X : In a (x :: s0)); auto; inversion_clear X; auto. - order. - Qed. - - Definition compare : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Compare lt eq s s'. - Proof. - simple induction s. - intros; case s'. - constructor 2; apply eq_refl. - constructor 1; auto. - intros a l Hrec s'; case s'. - constructor 3; auto. - intros a' l' Hs Hs'. - case (X.compare a a'); [ constructor 1 | idtac | constructor 3 ]; auto. - elim (Hrec l'); - [ constructor 1 - | constructor 2 - | constructor 3 - | inversion Hs - | inversion Hs' ]; auto. - generalize e; unfold eq, Equal; intuition; inversion_clear H. - constructor; apply X.eq_trans with a; auto. - destruct (e1 a0); auto. - constructor; apply X.eq_trans with a'; auto. - destruct (e1 a0); auto. - Defined. - - End ForNotations. - Hint Constructors lt. - -End Raw. - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of strictly ordered lists. *) +Require FSetCompat MSetList Orders OrdersAlt. Module Make (X: OrderedType) <: S with Module E := X. - - Module Raw := Raw X. - Module E := X. - - Record slist := {this :> Raw.t; sorted : sort E.lt this}. - Definition t := slist. - Definition elt := E.t. - - Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this). - Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'. - Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'. - Definition Empty (s:t) : Prop := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop)(s:t) : Prop := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop)(s:t) : Prop := exists x, In x s /\ P x. - - Definition mem (x : elt) (s : t) : bool := Raw.mem x s. - Definition add (x : elt)(s : t) : t := Build_slist (Raw.add_sort (sorted s) x). - Definition remove (x : elt)(s : t) : t := Build_slist (Raw.remove_sort (sorted s) x). - Definition singleton (x : elt) : t := Build_slist (Raw.singleton_sort x). - Definition union (s s' : t) : t := - Build_slist (Raw.union_sort (sorted s) (sorted s')). - Definition inter (s s' : t) : t := - Build_slist (Raw.inter_sort (sorted s) (sorted s')). - Definition diff (s s' : t) : t := - Build_slist (Raw.diff_sort (sorted s) (sorted s')). - Definition equal (s s' : t) : bool := Raw.equal s s'. - Definition subset (s s' : t) : bool := Raw.subset s s'. - Definition empty : t := Build_slist Raw.empty_sort. - Definition is_empty (s : t) : bool := Raw.is_empty s. - Definition elements (s : t) : list elt := Raw.elements s. - Definition min_elt (s : t) : option elt := Raw.min_elt s. - Definition max_elt (s : t) : option elt := Raw.max_elt s. - Definition choose (s : t) : option elt := Raw.choose s. - Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. - Definition cardinal (s : t) : nat := Raw.cardinal s. - Definition filter (f : elt -> bool) (s : t) : t := - Build_slist (Raw.filter_sort (sorted s) f). - Definition for_all (f : elt -> bool) (s : t) : bool := Raw.for_all f s. - Definition exists_ (f : elt -> bool) (s : t) : bool := Raw.exists_ f s. - Definition partition (f : elt -> bool) (s : t) : t * t := - let p := Raw.partition f s in - (Build_slist (this:=fst p) (Raw.partition_sort_1 (sorted s) f), - Build_slist (this:=snd p) (Raw.partition_sort_2 (sorted s) f)). - Definition eq (s s' : t) : Prop := Raw.eq s s'. - Definition lt (s s' : t) : Prop := Raw.lt s s'. - - Section Spec. - Variable s s' s'': t. - Variable x y : elt. - - Lemma In_1 : E.eq x y -> In x s -> In y s. - Proof. exact (fun H H' => Raw.MX.In_eq H H'). Qed. - - Lemma mem_1 : In x s -> mem x s = true. - Proof. exact (fun H => Raw.mem_1 s.(sorted) H). Qed. - Lemma mem_2 : mem x s = true -> In x s. - Proof. exact (fun H => Raw.mem_2 H). Qed. - - Lemma equal_1 : Equal s s' -> equal s s' = true. - Proof. exact (Raw.equal_1 s.(sorted) s'.(sorted)). Qed. - Lemma equal_2 : equal s s' = true -> Equal s s'. - Proof. exact (fun H => Raw.equal_2 H). Qed. - - Lemma subset_1 : Subset s s' -> subset s s' = true. - Proof. exact (Raw.subset_1 s.(sorted) s'.(sorted)). Qed. - Lemma subset_2 : subset s s' = true -> Subset s s'. - Proof. exact (fun H => Raw.subset_2 H). Qed. - - Lemma empty_1 : Empty empty. - Proof. exact Raw.empty_1. Qed. - - Lemma is_empty_1 : Empty s -> is_empty s = true. - Proof. exact (fun H => Raw.is_empty_1 H). Qed. - Lemma is_empty_2 : is_empty s = true -> Empty s. - Proof. exact (fun H => Raw.is_empty_2 H). Qed. - - Lemma add_1 : E.eq x y -> In y (add x s). - Proof. exact (fun H => Raw.add_1 s.(sorted) H). Qed. - Lemma add_2 : In y s -> In y (add x s). - Proof. exact (fun H => Raw.add_2 s.(sorted) x H). Qed. - Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. - Proof. exact (fun H => Raw.add_3 s.(sorted) H). Qed. - - Lemma remove_1 : E.eq x y -> ~ In y (remove x s). - Proof. exact (fun H => Raw.remove_1 s.(sorted) H). Qed. - Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). - Proof. exact (fun H H' => Raw.remove_2 s.(sorted) H H'). Qed. - Lemma remove_3 : In y (remove x s) -> In y s. - Proof. exact (fun H => Raw.remove_3 s.(sorted) H). Qed. - - Lemma singleton_1 : In y (singleton x) -> E.eq x y. - Proof. exact (fun H => Raw.singleton_1 H). Qed. - Lemma singleton_2 : E.eq x y -> In y (singleton x). - Proof. exact (fun H => Raw.singleton_2 H). Qed. - - Lemma union_1 : In x (union s s') -> In x s \/ In x s'. - Proof. exact (fun H => Raw.union_1 s.(sorted) s'.(sorted) H). Qed. - Lemma union_2 : In x s -> In x (union s s'). - Proof. exact (fun H => Raw.union_2 s.(sorted) s'.(sorted) H). Qed. - Lemma union_3 : In x s' -> In x (union s s'). - Proof. exact (fun H => Raw.union_3 s.(sorted) s'.(sorted) H). Qed. - - Lemma inter_1 : In x (inter s s') -> In x s. - Proof. exact (fun H => Raw.inter_1 s.(sorted) s'.(sorted) H). Qed. - Lemma inter_2 : In x (inter s s') -> In x s'. - Proof. exact (fun H => Raw.inter_2 s.(sorted) s'.(sorted) H). Qed. - Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). - Proof. exact (fun H => Raw.inter_3 s.(sorted) s'.(sorted) H). Qed. - - Lemma diff_1 : In x (diff s s') -> In x s. - Proof. exact (fun H => Raw.diff_1 s.(sorted) s'.(sorted) H). Qed. - Lemma diff_2 : In x (diff s s') -> ~ In x s'. - Proof. exact (fun H => Raw.diff_2 s.(sorted) s'.(sorted) H). Qed. - Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - Proof. exact (fun H => Raw.diff_3 s.(sorted) s'.(sorted) H). Qed. - - Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. exact (Raw.fold_1 s.(sorted)). Qed. - - Lemma cardinal_1 : cardinal s = length (elements s). - Proof. exact (Raw.cardinal_1 s.(sorted)). Qed. - - Section Filter. - - Variable f : elt -> bool. - - Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Proof. exact (@Raw.filter_1 s x f). Qed. - Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Proof. exact (@Raw.filter_2 s x f). Qed. - Lemma filter_3 : - compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. exact (@Raw.filter_3 s x f). Qed. - - Lemma for_all_1 : - compat_bool E.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Proof. exact (@Raw.for_all_1 s f). Qed. - Lemma for_all_2 : - compat_bool E.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - Proof. exact (@Raw.for_all_2 s f). Qed. - - Lemma exists_1 : - compat_bool E.eq f -> - Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. exact (@Raw.exists_1 s f). Qed. - Lemma exists_2 : - compat_bool E.eq f -> - exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. exact (@Raw.exists_2 s f). Qed. - - Lemma partition_1 : - compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). - Proof. exact (@Raw.partition_1 s f). Qed. - Lemma partition_2 : - compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. exact (@Raw.partition_2 s f). Qed. - - End Filter. - - Lemma elements_1 : In x s -> InA E.eq x (elements s). - Proof. exact (fun H => Raw.elements_1 H). Qed. - Lemma elements_2 : InA E.eq x (elements s) -> In x s. - Proof. exact (fun H => Raw.elements_2 H). Qed. - Lemma elements_3 : sort E.lt (elements s). - Proof. exact (Raw.elements_3 s.(sorted)). Qed. - Lemma elements_3w : NoDupA E.eq (elements s). - Proof. exact (Raw.elements_3w s.(sorted)). Qed. - - Lemma min_elt_1 : min_elt s = Some x -> In x s. - Proof. exact (fun H => Raw.min_elt_1 H). Qed. - Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. - Proof. exact (fun H => Raw.min_elt_2 s.(sorted) H). Qed. - Lemma min_elt_3 : min_elt s = None -> Empty s. - Proof. exact (fun H => Raw.min_elt_3 H). Qed. - - Lemma max_elt_1 : max_elt s = Some x -> In x s. - Proof. exact (fun H => Raw.max_elt_1 H). Qed. - Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. - Proof. exact (fun H => Raw.max_elt_2 s.(sorted) H). Qed. - Lemma max_elt_3 : max_elt s = None -> Empty s. - Proof. exact (fun H => Raw.max_elt_3 H). Qed. - - Lemma choose_1 : choose s = Some x -> In x s. - Proof. exact (fun H => Raw.choose_1 H). Qed. - Lemma choose_2 : choose s = None -> Empty s. - Proof. exact (fun H => Raw.choose_2 H). Qed. - Lemma choose_3 : choose s = Some x -> choose s' = Some y -> - Equal s s' -> E.eq x y. - Proof. exact (@Raw.choose_3 _ _ s.(sorted) s'.(sorted) x y). Qed. - - Lemma eq_refl : eq s s. - Proof. exact (Raw.eq_refl s). Qed. - Lemma eq_sym : eq s s' -> eq s' s. - Proof. exact (@Raw.eq_sym s s'). Qed. - Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''. - Proof. exact (@Raw.eq_trans s s' s''). Qed. - - Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''. - Proof. exact (@Raw.lt_trans s s' s''). Qed. - Lemma lt_not_eq : lt s s' -> ~ eq s s'. - Proof. exact (Raw.lt_not_eq s.(sorted) s'.(sorted)). Qed. - - Definition compare : Compare lt eq s s'. - Proof. - elim (Raw.compare s.(sorted) s'.(sorted)); - [ constructor 1 | constructor 2 | constructor 3 ]; - auto. - Defined. - - Definition eq_dec : { eq s s' } + { ~ eq s s' }. - Proof. - change eq with Equal. - case_eq (equal s s'); intro H; [left | right]. - apply equal_2; auto. - intro H'; rewrite equal_1 in H; auto; discriminate. - Defined. - - End Spec. - + Module X' := OrdersAlt.Update_OT X. + Module MSet := MSetList.Make X'. + Include FSetCompat.Backport_Sets X MSet. End Make. diff --git a/theories/FSets/FSetPositive.v b/theories/FSets/FSetPositive.v new file mode 100644 index 00000000..e5d55ac5 --- /dev/null +++ b/theories/FSets/FSetPositive.v @@ -0,0 +1,1173 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool -> tree -> tree. + + Scheme tree_ind := Induction for tree Sort Prop. + + Definition t := tree. + + Definition empty := Leaf. + + Fixpoint is_empty (m : t) : bool := + match m with + | Leaf => true + | Node l b r => negb b &&& is_empty l &&& is_empty r + end. + + Fixpoint mem (i : positive) (m : t) : bool := + match m with + | Leaf => false + | Node l o r => + match i with + | 1 => o + | i~0 => mem i l + | i~1 => mem i r + end + end. + + Fixpoint add (i : positive) (m : t) : t := + match m with + | Leaf => + match i with + | 1 => Node Leaf true Leaf + | i~0 => Node (add i Leaf) false Leaf + | i~1 => Node Leaf false (add i Leaf) + end + | Node l o r => + match i with + | 1 => Node l true r + | i~0 => Node (add i l) o r + | i~1 => Node l o (add i r) + end + end. + + Definition singleton i := add i empty. + + (** helper function to avoid creating empty trees that are not leaves *) + + Definition node l (b: bool) r := + 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 := + match m with + | Leaf => Leaf + | Node l o r => + match i with + | 1 => node l false r + | i~0 => node (remove i l) o r + | i~1 => node l o (remove i r) + end + end. + + Fixpoint union (m m': t) := + match m with + | Leaf => m' + | Node l o r => + match m' with + | Leaf => m + | Node l' o' r' => Node (union l l') (o||o') (union r r') + end + end. + + Fixpoint inter (m m': t) := + match m with + | Leaf => Leaf + | Node l o r => + match m' with + | Leaf => Leaf + | Node l' o' r' => node (inter l l') (o&&o') (inter r r') + end + end. + + Fixpoint diff (m m': t) := + match m with + | Leaf => Leaf + | Node l o r => + match m' with + | Leaf => m + | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r') + end + end. + + Fixpoint equal (m m': t): bool := + match m with + | Leaf => is_empty m' + | Node l o r => + match m' with + | Leaf => is_empty m + | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r' + end + end. + + Fixpoint subset (m m': t): bool := + match m with + | Leaf => true + | Node l o r => + match m' with + | Leaf => is_empty m + | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r' + end + end. + + (** reverses [y] and concatenate it with [x] *) + + Fixpoint rev_append y x := + match y with + | 1 => x + | y~1 => rev_append y x~1 + | y~0 => rev_append y x~0 + end. + Infix "@" := rev_append (at level 60). + Definition rev x := x@1. + + Section Fold. + + Variables B : Type. + Variable f : positive -> B -> B. + + (** the additional argument, [i], records the current path, in + reverse order (this should be more efficient: we reverse this argument + only at present nodes only, rather than at each node of the tree). + we also use this convention in all functions below + *) + + Fixpoint xfold (m : t) (v : B) (i : positive) := + match m with + | Leaf => v + | Node l true r => + xfold r (f (rev i) (xfold l v i~0)) i~1 + | Node l false r => + xfold r (xfold l v i~0) i~1 + end. + Definition fold m i := xfold m i 1. + + End Fold. + + Section Quantifiers. + + Variable f : positive -> bool. + + Fixpoint xforall (m : t) (i : positive) := + match m with + | Leaf => true + | Node l o r => + (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0 + end. + Definition for_all m := xforall m 1. + + Fixpoint xexists (m : t) (i : positive) := + match m with + | Leaf => false + | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0 + end. + Definition exists_ m := xexists m 1. + + Fixpoint xfilter (m : t) (i : positive) := + 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) := + match m with + | Leaf => (Leaf,Leaf) + | Node l o r => + let (lt,lf) := xpartition l i~0 in + let (rt,rf) := xpartition r i~1 in + if o then + let fi := f (rev i) in + (node lt fi rt, node lf (negb fi) rf) + else + (node lt false rt, node lf false rf) + end. + Definition partition m := xpartition m 1. + + End Quantifiers. + + (** uses [a] to accumulate values rather than doing a lot of concatenations *) + + Fixpoint xelements (m : t) (i : positive) (a: list positive) := + match m with + | Leaf => a + | Node l false r => xelements l i~0 (xelements r i~1 a) + | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a) + end. + + Definition elements (m : t) := xelements m 1 nil. + + Fixpoint cardinal (m : t) : nat := + match m with + | Leaf => O + | Node l false r => (cardinal l + cardinal r)%nat + | Node l true r => S (cardinal l + cardinal r) + end. + + Definition omap (f: elt -> elt) x := + match x with + | None => None + | Some i => Some (f i) + end. + + (** would it be more efficient to use a path like in the above functions ? *) + + Fixpoint choose (m: t) := + match m with + | Leaf => None + | Node l o r => if o then Some 1 else + match choose l with + | None => omap xI (choose r) + | Some i => Some i~0 + end + end. + + Fixpoint min_elt (m: t) := + match m with + | Leaf => None + | Node l o r => + match min_elt l with + | None => if o then Some 1 else omap xI (min_elt r) + | Some i => Some i~0 + end + end. + + Fixpoint max_elt (m: t) := + match m with + | Leaf => None + | Node l o r => + match max_elt r with + | None => if o then Some 1 else omap xO (max_elt l) + | Some i => Some i~1 + end + end. + + (** lexicographic product, defined using a notation to keep things lazy *) + + Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end. + + Definition compare_bool a b := + match a,b with + | false, true => Lt + | true, false => Gt + | _,_ => Eq + end. + + Fixpoint compare_fun (m m': t): comparison := + match m,m' with + | Leaf,_ => if is_empty m' then Eq else Lt + | _,Leaf => if is_empty m then Eq else Gt + | Node l o r,Node l' o' r' => + lex (compare_bool o o') (lex (compare_fun l l') (compare_fun r r')) + end. + + + Definition In i t := mem i t = true. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + + Definition eq := Equal. + Definition lt m m' := compare_fun m m' = Lt. + + (** Specification of [In] *) + + Lemma In_1: forall s x y, E.eq x y -> In x s -> In y s. + Proof. intros s x y ->. trivial. Qed. + + (** Specification of [eq] *) + + Lemma eq_refl: forall s, eq s s. + Proof. unfold eq, Equal. reflexivity. Qed. + + Lemma eq_sym: forall s s', eq s s' -> eq s' s. + Proof. unfold eq, Equal. intros. symmetry. trivial. Qed. + + Lemma eq_trans: forall s s' s'', eq s s' -> eq s' s'' -> eq s s''. + Proof. unfold eq, Equal. intros ? ? ? H ? ?. rewrite H. trivial. Qed. + + (** Specification of [mem] *) + + Lemma mem_1: forall s x, In x s -> mem x s = true. + Proof. unfold In. trivial. Qed. + + Lemma mem_2: forall s x, mem x s = true -> In x s. + Proof. unfold In. trivial. Qed. + + (** Additional lemmas for mem *) + + Lemma mem_Leaf: forall x, mem x Leaf = false. + Proof. destruct x; trivial. Qed. + + (** Specification of [empty] *) + + Lemma empty_1 : Empty empty. + Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed. + + (** Specification of node *) + + Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r). + Proof. + intros x l o r. + case o; trivial. + destruct l; trivial. + destruct r; trivial. + symmetry. destruct x. + apply mem_Leaf. + apply mem_Leaf. + reflexivity. + Qed. + Local Opaque node. + + (** Specification of [is_empty] *) + + Lemma is_empty_spec: forall s, Empty s <-> is_empty s = true. + Proof. + unfold Empty, In. + induction s as [|l IHl o r IHr]; simpl. + setoid_rewrite mem_Leaf. firstorder. + rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear IHl IHr. + destruct o; simpl; split. + intro H. elim (H 1). reflexivity. + intuition discriminate. + intro H. split. split. reflexivity. + intro a. apply (H a~0). + intro a. apply (H a~1). + intros H [a|a|]; apply H || intro; discriminate. + Qed. + + Lemma is_empty_1: forall s, Empty s -> is_empty s = true. + Proof. intro. rewrite is_empty_spec. trivial. Qed. + + Lemma is_empty_2: forall s, is_empty s = true -> Empty s. + Proof. intro. rewrite is_empty_spec. trivial. Qed. + + (** Specification of [subset] *) + + Lemma subset_Leaf_s: forall s, Leaf [<=] s. + Proof. intros s i Hi. elim (empty_1 Hi). Qed. + + Lemma subset_spec: forall s s', s [<=] s' <-> subset s s' = true. + Proof. + induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl. + split; intros. reflexivity. apply subset_Leaf_s. + + split; intros. reflexivity. apply subset_Leaf_s. + + rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- 2is_empty_spec. + destruct o; simpl. + split. + intro H. elim (@empty_1 1). apply H. reflexivity. + intuition discriminate. + split; intro H. + split. split. reflexivity. + unfold Empty. intros a H1. apply (@empty_1 (a~0)). apply H. assumption. + unfold Empty. intros a H1. apply (@empty_1 (a~1)). apply H. assumption. + destruct H as [[_ Hl] Hr]. + intros [i|i|] Hi. + elim (Hr i Hi). + elim (Hl i Hi). + discriminate. + + rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear. + destruct o; simpl. + split; intro H. + split. split. + destruct o'; trivial. + specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity. + intros i Hi. apply (H i~0). apply Hi. + intros i Hi. apply (H i~1). apply Hi. + destruct H as [[Ho' Hl] Hr]. rewrite Ho'. + intros i Hi. destruct i. + apply (Hr i). assumption. + apply (Hl i). assumption. + assumption. + split; intros. + split. split. reflexivity. + intros i Hi. apply (H i~0). apply Hi. + intros i Hi. apply (H i~1). apply Hi. + intros i Hi. destruct i; destruct H as [[H Hl] Hr]. + apply (Hr i). assumption. + apply (Hl i). assumption. + discriminate Hi. + Qed. + + + Lemma subset_1: forall s s', Subset s s' -> subset s s' = true. + Proof. intros s s'. apply -> subset_spec; trivial. Qed. + + Lemma subset_2: forall s s', subset s s' = true -> Subset s s'. + Proof. intros s s'. apply <- subset_spec; trivial. Qed. + + (** Specification of [equal] (via subset) *) + + Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s. + Proof. + induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial. + destruct o. reflexivity. rewrite andb_comm. reflexivity. + rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true. + rewrite 7andb_true_iff, eqb_true_iff. + rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst. + destruct o'; reflexivity. + destruct o'; reflexivity. + destruct o; auto. destruct o'; trivial. + Qed. + + Lemma equal_spec: forall s s', Equal s s' <-> equal s s' = true. + Proof. + intros. rewrite equal_subset. rewrite andb_true_iff. + rewrite <- 2subset_spec. unfold Equal, Subset. firstorder. + Qed. + + Lemma equal_1: forall s s', Equal s s' -> equal s s' = true. + Proof. intros s s'. apply -> equal_spec; trivial. Qed. + + Lemma equal_2: forall s s', equal s s' = true -> Equal s s'. + Proof. intros s s'. apply <- equal_spec; trivial. Qed. + + Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. + Proof. + unfold eq. + intros. case_eq (equal s s'); intro H. + left. apply equal_2, H. + right. abstract (intro H'; rewrite (equal_1 H') in H; discriminate). + Defined. + + (** (Specified) definition of [compare] *) + + Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' -> + lex u v = CompOpp (lex u' v'). + Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed. + + Lemma compare_bool_inv: forall b b', + compare_bool b b' = CompOpp (compare_bool b' b). + Proof. intros [|] [|]; reflexivity. Qed. + + Lemma compare_inv: forall s s', compare_fun s s' = CompOpp (compare_fun s' s). + Proof. + induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial. + unfold compare_fun. case is_empty; reflexivity. + unfold compare_fun. case is_empty; reflexivity. + simpl. rewrite compare_bool_inv. + case compare_bool; simpl; trivial; apply lex_Opp; auto. + Qed. + + Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq. + Proof. intros u v; destruct u; intuition discriminate. Qed. + + Lemma compare_bool_Eq: forall b1 b2, + compare_bool b1 b2 = Eq <-> eqb b1 b2 = true. + Proof. intros [|] [|]; intuition discriminate. Qed. + + Lemma compare_equal: forall s s', compare_fun s s' = Eq <-> equal s s' = true. + Proof. + induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']. + simpl. tauto. + unfold compare_fun, equal. case is_empty; intuition discriminate. + unfold compare_fun, equal. case is_empty; intuition discriminate. + simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff. + rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr. + rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity. + Qed. + + + Lemma compare_gt: forall s s', compare_fun s s' = Gt -> lt s' s. + Proof. + unfold lt. intros s s'. rewrite compare_inv. + case compare_fun; trivial; intros; discriminate. + Qed. + + Lemma compare_eq: forall s s', compare_fun s s' = Eq -> eq s s'. + Proof. + unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial. + Qed. + + Lemma compare : forall s s' : t, Compare lt eq s s'. + Proof. + intros. case_eq (compare_fun s s'); intro H. + apply EQ. apply compare_eq, H. + apply LT. assumption. + apply GT. apply compare_gt, H. + Defined. + + Section lt_spec. + + Inductive ct: comparison -> comparison -> comparison -> Prop := + | ct_xxx: forall x, ct x x x + | ct_xex: forall x, ct x Eq x + | ct_exx: forall x, ct Eq x x + | ct_glx: forall x, ct Gt Lt x + | ct_lgx: forall x, ct Lt Gt x. + + Lemma ct_cxe: forall x, ct (CompOpp x) x Eq. + Proof. destruct x; constructor. Qed. + + Lemma ct_xce: forall x, ct x (CompOpp x) Eq. + Proof. destruct x; constructor. Qed. + + Lemma ct_lxl: forall x, ct Lt x Lt. + Proof. destruct x; constructor. Qed. + + Lemma ct_gxg: forall x, ct Gt x Gt. + Proof. destruct x; constructor. Qed. + + Lemma ct_xll: forall x, ct x Lt Lt. + Proof. destruct x; constructor. Qed. + + Lemma ct_xgg: forall x, ct x Gt Gt. + Proof. destruct x; constructor. Qed. + + Local Hint Constructors ct: ct. + Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct. + Ltac ct := trivial with ct. + + Lemma ct_lex: forall u v w u' v' w', + ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w'). + Proof. + intros u v w u' v' w' H H'. + inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct. + Qed. + + Lemma ct_compare_bool: + forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c). + Proof. + intros [|] [|] [|]; constructor. + Qed. + + Lemma compare_x_Leaf: forall s, + compare_fun s Leaf = if is_empty s then Eq else Gt. + Proof. + intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity. + Qed. + + Lemma compare_empty_x: forall a, is_empty a = true -> + forall b, compare_fun a b = if is_empty b then Eq else Lt. + Proof. + induction a as [|l IHl o r IHr]; trivial. + destruct o. intro; discriminate. + simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff. + intros [Hl Hr]. + destruct b as [|l' [|] r']; simpl compare_fun; trivial. + rewrite Hl, Hr. trivial. + rewrite (IHl Hl), (IHr Hr). simpl. + case (is_empty l'); case (is_empty r'); trivial. + Qed. + + Lemma compare_x_empty: forall a, is_empty a = true -> + forall b, compare_fun b a = if is_empty b then Eq else Gt. + Proof. + setoid_rewrite <- compare_x_Leaf. + intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity. + Qed. + + Lemma ct_compare_fun: + forall a b c, ct (compare_fun a b) (compare_fun b c) (compare_fun a c). + Proof. + induction a as [|l IHl o r IHr]; intros s' s''. + destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct. + rewrite compare_inv. ct. + unfold compare_fun at 1. case_eq (is_empty (Node l' o' r')); intro H'. + rewrite (compare_empty_x _ H'). ct. + unfold compare_fun at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''. + rewrite (compare_x_empty _ H''), H'. ct. + ct. + + destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']. + ct. + unfold compare_fun at 2. rewrite compare_x_Leaf. + case_eq (is_empty (Node l o r)); intro H. + rewrite (compare_empty_x _ H). ct. + case_eq (is_empty (Node l'' o'' r'')); intro H''. + rewrite (compare_x_empty _ H''), H. ct. + ct. + + rewrite 2 compare_x_Leaf. + case_eq (is_empty (Node l o r)); intro H. + rewrite compare_inv, (compare_x_empty _ H). ct. + case_eq (is_empty (Node l' o' r')); intro H'. + rewrite (compare_x_empty _ H'), H. ct. + ct. + + simpl compare_fun. apply ct_lex. apply ct_compare_bool. + apply ct_lex; trivial. + Qed. + + End lt_spec. + + Lemma lt_trans: forall s s' s'', lt s s' -> lt s' s'' -> lt s s''. + Proof. + unfold lt. intros a b c. assert (H := ct_compare_fun a b c). + inversion_clear H; trivial; intros; discriminate. + Qed. + + Lemma lt_not_eq: forall s s', lt s s' -> ~ eq s s'. + Proof. + unfold lt, eq. intros s s' H H'. + rewrite equal_spec, <- compare_equal in H'. congruence. + Qed. + + (** Specification of [add] *) + + Lemma add_spec: forall x y s, In y (add x s) <-> x=y \/ In y s. + Proof. + unfold In. induction x; intros [y|y|] [|l o r]; simpl mem; + try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence. + Qed. + + Lemma add_1: forall s x y, x = y -> In y (add x s). + Proof. intros. apply <- add_spec. left. assumption. Qed. + + Lemma add_2: forall s x y, In y s -> In y (add x s). + Proof. intros. apply <- add_spec. right. assumption. Qed. + + Lemma add_3: forall s x y, x<>y -> In y (add x s) -> In y s. + Proof. + intros s x y H. rewrite add_spec. intros [->|?]; trivial. elim H; trivial. + Qed. + + (** Specification of [remove] *) + + Lemma remove_spec: forall x y s, In y (remove x s) <-> x<>y /\ In y s. + Proof. + unfold In. + induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node; + simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; + intuition congruence. + Qed. + + Lemma remove_1: forall s x y, x=y -> ~ In y (remove x s). + Proof. intros. rewrite remove_spec. tauto. Qed. + + Lemma remove_2: forall s x y, x<>y -> In y s -> In y (remove x s). + Proof. intros. rewrite remove_spec. split; assumption. Qed. + + Lemma remove_3: forall s x y, In y (remove x s) -> In y s. + Proof. intros s x y. rewrite remove_spec. tauto. Qed. + + (** Specification of [singleton] *) + + Lemma singleton_1: forall x y, In y (singleton x) -> x=y. + Proof. + unfold singleton. intros x y. rewrite add_spec. + unfold In. rewrite mem_Leaf. intuition discriminate. + Qed. + + Lemma singleton_2: forall x y, x = y -> In y (singleton x). + Proof. + unfold singleton. intros. apply add_1. assumption. + Qed. + + (** Specification of [union] *) + + Lemma union_spec: forall x s s', In x (union s s') <-> In x s \/ In x s'. + Proof. + unfold In. + induction x; destruct s; destruct s'; simpl union; simpl mem; + try (rewrite IHx; clear IHx); try intuition congruence. + apply orb_true_iff. + Qed. + + Lemma union_1: forall s s' x, In x (union s s') -> In x s \/ In x s'. + Proof. intros. apply -> union_spec. assumption. Qed. + + Lemma union_2: forall s s' x, In x s -> In x (union s s'). + Proof. intros. apply <- union_spec. left. assumption. Qed. + + Lemma union_3: forall s s' x, In x s' -> In x (union s s'). + Proof. intros. apply <- union_spec. right. assumption. Qed. + + (** Specification of [inter] *) + + Lemma inter_spec: forall x s s', In x (inter s s') <-> In x s /\ In x s'. + Proof. + unfold In. + induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node; + simpl mem; try (rewrite IHx; clear IHx); try intuition congruence. + apply andb_true_iff. + Qed. + + Lemma inter_1: forall s s' x, In x (inter s s') -> In x s. + Proof. intros s s' x. rewrite inter_spec. tauto. Qed. + + Lemma inter_2: forall s s' x, In x (inter s s') -> In x s'. + Proof. intros s s' x. rewrite inter_spec. tauto. Qed. + + Lemma inter_3: forall s s' x, In x s -> In x s' -> In x (inter s s'). + Proof. intros. rewrite inter_spec. split; assumption. Qed. + + (** Specification of [diff] *) + + Lemma diff_spec: forall x s s', In x (diff s s') <-> In x s /\ ~ In x s'. + Proof. + unfold In. + induction x; destruct s; destruct s' as [|l' o' r']; simpl diff; + rewrite ?mem_node; simpl mem; + try (rewrite IHx; clear IHx); try intuition congruence. + rewrite andb_true_iff. destruct o'; intuition discriminate. + Qed. + + Lemma diff_1: forall s s' x, In x (diff s s') -> In x s. + Proof. intros s s' x. rewrite diff_spec. tauto. Qed. + + Lemma diff_2: forall s s' x, In x (diff s s') -> ~ In x s'. + Proof. intros s s' x. rewrite diff_spec. tauto. Qed. + + Lemma diff_3: forall s s' x, In x s -> ~ In x s' -> In x (diff s s'). + Proof. intros. rewrite diff_spec. split; assumption. Qed. + + (** Specification of [fold] *) + + Lemma fold_1: forall s (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + Proof. + unfold fold, elements. intros s A i f. revert s i. + set (f' := fun a e => f e a). + assert (H: forall s i j acc, + fold_left f' acc (xfold f s i j) = + fold_left f' (xelements s j acc) i). + + induction s as [|l IHl o r IHr]; intros; trivial. + destruct o; simpl xelements; simpl xfold. + rewrite IHr, <- IHl. reflexivity. + rewrite IHr. apply IHl. + + intros. exact (H s i 1 nil). + Qed. + + (** Specification of [cardinal] *) + + Lemma cardinal_1: forall s, cardinal s = length (elements s). + Proof. + unfold elements. + assert (H: forall s j acc, + (cardinal s + length acc)%nat = length (xelements s j acc)). + + induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b. + rewrite <- IHl. simpl. rewrite <- IHr. + rewrite <- plus_n_Sm, Plus.plus_assoc. reflexivity. + rewrite <- IHl, <- IHr. rewrite Plus.plus_assoc. reflexivity. + + intros. rewrite <- H. simpl. rewrite Plus.plus_comm. reflexivity. + Qed. + + (** Specification of [filter] *) + + Lemma xfilter_spec: forall f s x i, + In x (xfilter f s i) <-> In x s /\ f (i@x) = true. + Proof. + intro f. unfold In. + induction s as [|l IHl o r IHr]; intros x i; simpl xfilter. + rewrite mem_Leaf. intuition discriminate. + rewrite mem_node. destruct x; simpl. + rewrite IHr. reflexivity. + rewrite IHl. reflexivity. + rewrite <- andb_lazy_alt. apply andb_true_iff. + Qed. + + Lemma filter_1 : forall s x f, compat_bool 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 -> + 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 -> + f x = true -> In x (filter f s). + Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. + + + (** Specification of [for_all] *) + + Lemma xforall_spec: forall f s i, + xforall f s i = true <-> For_all (fun x => f (i@x) = true) s. + Proof. + unfold For_all, In. intro f. + induction s as [|l IHl o r IHr]; intros i; simpl. + setoid_rewrite mem_Leaf. intuition discriminate. + rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff. + rewrite IHl, IHr. clear IHl IHr. + split. + intros [[Hi Hr] Hl] x. destruct x; simpl; intro H. + apply Hr, H. + apply Hl, H. + rewrite H in Hi. assumption. + intro H; intuition. + specialize (H 1). destruct o. apply H. reflexivity. reflexivity. + apply H. assumption. + apply H. assumption. + Qed. + + Lemma for_all_1 : forall s f, compat_bool E.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true. + Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed. + + Lemma for_all_2 : forall s f, compat_bool E.eq f -> + for_all f s = true -> For_all (fun x => f x = true) s. + Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed. + + + (** Specification of [exists] *) + + Lemma xexists_spec: forall f s i, + xexists f s i = true <-> Exists (fun x => f (i@x) = true) s. + Proof. + unfold Exists, In. intro f. + induction s as [|l IHl o r IHr]; intros i; simpl. + setoid_rewrite mem_Leaf. firstorder. + rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff. + rewrite IHl, IHr. clear IHl IHr. + split. + intros [[Hi|[x Hr]]|[x Hl]]. + exists 1. exact Hi. + exists x~1. exact Hr. + exists x~0. exact Hl. + intros [[x|x|] H]; eauto. + Qed. + + Lemma exists_1 : forall s f, compat_bool 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 -> + exists_ f s = true -> Exists (fun x => f x = true) s. + Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed. + + + (** Specification of [partition] *) + + Lemma partition_filter : forall s f, + partition f s = (filter f s, filter (fun x => negb (f x)) s). + Proof. + unfold partition, filter. intros s f. generalize 1 as j. + induction s as [|l IHl o r IHr]; intro j. + reflexivity. + destruct o; simpl; rewrite IHl, IHr; reflexivity. + Qed. + + Lemma partition_1 : forall s f, compat_bool 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 -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. intros. rewrite partition_filter. apply eq_refl. Qed. + + + (** Specification of [elements] *) + + Notation InL := (InA E.eq). + + Lemma xelements_spec: forall s j acc y, + InL y (xelements s j acc) + <-> + InL y acc \/ exists x, y=(j@x) /\ mem x s = true. + Proof. + induction s as [|l IHl o r IHr]; simpl. + intros. split; intro H. + left. assumption. + destruct H as [H|[x [Hx Hx']]]. assumption. elim (empty_1 Hx'). + + intros j acc y. case o. + rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split. + intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto. + right. exists x~1. auto. + right. exists x~0. auto. + intros [H|[x [-> H]]]. + eauto. + destruct x. + left. right. right. exists x; auto. + right. exists x; auto. + left. left. reflexivity. + + rewrite IHl, IHr. clear IHl IHr. split. + intros [[H|[x [-> H]]]|[x [-> H]]]. + eauto. + right. exists x~1. auto. + right. exists x~0. auto. + intros [H|[x [-> H]]]. + eauto. + destruct x. + left. right. exists x; auto. + right. exists x; auto. + discriminate. + Qed. + + Lemma elements_1: forall s x, In x s -> InL x (elements s). + Proof. + unfold elements, In. intros. + rewrite xelements_spec. right. exists x. auto. + Qed. + + Lemma elements_2: forall s x, InL x (elements s) -> In x s. + Proof. + unfold elements, In. intros s x H. + rewrite xelements_spec in H. destruct H as [H|[y [H H']]]. + inversion_clear H. + rewrite H. assumption. + Qed. + + Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y). + Proof. induction j; intros; simpl; auto. Qed. + + Lemma elements_3: forall s, sort E.lt (elements s). + Proof. + unfold elements. + assert (H: forall s j acc, + sort E.lt acc -> + (forall x y, In x s -> InL y acc -> E.lt (j@x) y) -> + sort E.lt (xelements s j acc)). + + induction s as [|l IHl o r IHr]; simpl; trivial. + intros j acc Hacc Hsacc. destruct o. + apply IHl. constructor. + apply IHr. apply Hacc. + intros x y Hx Hy. apply Hsacc; assumption. + case_eq (xelements r j~1 acc). constructor. + intros z q H. constructor. + assert (H': InL z (xelements r j~1 acc)). + rewrite H. constructor. reflexivity. + clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]]. + apply (Hsacc 1 z); trivial. reflexivity. + simpl. apply lt_rev_append. exact I. + intros x y Hx Hy. inversion_clear Hy. + rewrite H. simpl. apply lt_rev_append. exact I. + rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]]. + apply Hsacc; assumption. + simpl. apply lt_rev_append. exact I. + + apply IHl. apply IHr. apply Hacc. + intros x y Hx Hy. apply Hsacc; assumption. + intros x y Hx Hy. rewrite xelements_spec in Hy. + destruct Hy as [Hy|[z [-> Hy]]]. + apply Hsacc; assumption. + simpl. apply lt_rev_append. exact I. + + intros. apply H. constructor. + intros x y _ H'. inversion H'. + Qed. + + Lemma elements_3w: forall s, NoDupA E.eq (elements s). + Proof. + intro. apply SortA_NoDupA with E.lt. + constructor. + intro. apply E.eq_refl. + intro. apply E.eq_sym. + intro. apply E.eq_trans. + constructor. + intros x H. apply E.lt_not_eq in H. apply H. reflexivity. + intro. apply E.lt_trans. + intros ? ? <- ? ? <-. reflexivity. + apply elements_3. + Qed. + + + (** Specification of [choose] *) + + Lemma choose_1: forall s x, choose s = Some x -> In x s. + Proof. + induction s as [| l IHl o r IHr]; simpl. + intros. discriminate. + destruct o. + intros x H. injection H; intros; subst. reflexivity. + revert IHl. case choose. + intros p Hp x H. injection H; intros; subst; clear H. apply Hp. + reflexivity. + intros _ x. revert IHr. case choose. + intros p Hp H. injection H; intros; subst; clear H. apply Hp. + reflexivity. + intros. discriminate. + Qed. + + Lemma choose_2: forall s, choose s = None -> Empty s. + Proof. + unfold Empty, In. intros s H. + induction s as [|l IHl o r IHr]. + intro. apply empty_1. + destruct o. + discriminate. + simpl in H. destruct (choose l). + discriminate. + destruct (choose r). + discriminate. + intros [a|a|]. + apply IHr. reflexivity. + apply IHl. reflexivity. + discriminate. + Qed. + + Lemma choose_empty: forall s, is_empty s = true -> choose s = None. + Proof. + intros s Hs. case_eq (choose s); trivial. + intros p Hp. apply choose_1 in Hp. apply is_empty_2 in Hs. elim (Hs _ Hp). + Qed. + + Lemma choose_3': forall s s', Equal s s' -> choose s = choose s'. + Proof. + setoid_rewrite equal_spec. + induction s as [|l IHl o r IHr]. + intros. symmetry. apply choose_empty. assumption. + + destruct s' as [|l' o' r']. + generalize (Node l o r) as s. simpl. intros. apply choose_empty. + rewrite <- equal_spec in H. apply eq_sym in H. rewrite equal_spec in H. + assumption. + + simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff. + intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity. + Qed. + + Lemma choose_3: forall s s' x y, + choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. + Proof. intros s s' x y Hx Hy H. apply choose_3' in H. congruence. Qed. + + + (** Specification of [min_elt] *) + + Lemma min_elt_1: forall s x, min_elt s = Some x -> In x s. + Proof. + unfold In. + induction s as [| l IHl o r IHr]; simpl. + intros. discriminate. + intros x. destruct (min_elt l); intros. + injection H. intros <-. apply IHl. reflexivity. + destruct o; simpl. + injection H. intros <-. reflexivity. + destruct (min_elt r); simpl in *. + injection H. intros <-. apply IHr. reflexivity. + discriminate. + Qed. + + Lemma min_elt_3: forall s, min_elt s = None -> Empty s. + Proof. + unfold Empty, In. intros s H. + induction s as [|l IHl o r IHr]. + intro. apply empty_1. + intros [a|a|]. + apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial. + case min_elt; intros; try discriminate. destruct o; discriminate. + apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial. + intro; discriminate. + revert H. clear. simpl. case min_elt; intros; try discriminate. + destruct o; discriminate. + Qed. + + Lemma min_elt_2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x. + Proof. + unfold In. + induction s as [|l IHl o r IHr]; intros x y H H'. + discriminate. + simpl in H. case_eq (min_elt l). + intros p Hp. rewrite Hp in H. injection H; intros <-. + destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial. + intro Hp; rewrite Hp in H. apply min_elt_3 in Hp. + destruct o. + injection H. intros <- Hl. clear H. + destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). + + destruct (min_elt r). + injection H. intros <-. clear H. + destruct y as [z|z|]. + apply (IHr p z); trivial. + elim (Hp _ H'). + discriminate. + discriminate. + Qed. + + + (** Specification of [max_elt] *) + + Lemma max_elt_1: forall s x, max_elt s = Some x -> In x s. + Proof. + unfold In. + induction s as [| l IHl o r IHr]; simpl. + intros. discriminate. + intros x. destruct (max_elt r); intros. + injection H. intros <-. apply IHr. reflexivity. + destruct o; simpl. + injection H. intros <-. reflexivity. + destruct (max_elt l); simpl in *. + injection H. intros <-. apply IHl. reflexivity. + discriminate. + Qed. + + Lemma max_elt_3: forall s, max_elt s = None -> Empty s. + Proof. + unfold Empty, In. intros s H. + induction s as [|l IHl o r IHr]. + intro. apply empty_1. + intros [a|a|]. + apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial. + intro; discriminate. + apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial. + case max_elt; intros; try discriminate. destruct o; discriminate. + revert H. clear. simpl. case max_elt; intros; try discriminate. + destruct o; discriminate. + Qed. + + Lemma max_elt_2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y. + Proof. + unfold In. + induction s as [|l IHl o r IHr]; intros x y H H'. + discriminate. + simpl in H. case_eq (max_elt r). + intros p Hp. rewrite Hp in H. injection H; intros <-. + destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial. + intro Hp; rewrite Hp in H. apply max_elt_3 in Hp. + destruct o. + injection H. intros <- Hl. clear H. + destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). + + destruct (max_elt l). + injection H. intros <-. clear H. + destruct y as [z|z|]. + elim (Hp _ H'). + apply (IHl p z); trivial. + discriminate. + discriminate. + Qed. + +End PositiveSet. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 8dc7fbd9..84c26dac 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -6,14 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetProperties.v 11720 2008-12-28 07:12:15Z letouzey $ *) +(* $Id$ *) (** * Finite sets library *) (** This functor derives additional properties from [FSetInterface.S]. - Contrary to the functor in [FSetEqProperties] it uses + Contrary to the functor in [FSetEqProperties] it uses predicates over sets instead of sets operations, i.e. - [In x s] instead of [mem x s=true], + [In x s] instead of [mem x s=true], [Equal s s'] instead of [equal s s'=true], etc. *) Require Export FSetInterface. @@ -21,7 +21,7 @@ Require Import DecidableTypeEx FSetFacts FSetDecide. Set Implicit Arguments. Unset Strict Implicit. -Hint Unfold transpose compat_op. +Hint Unfold transpose compat_op Proper respectful. Hint Extern 1 (Equivalence _) => constructor; congruence. (** First, a functor for Weak Sets in functorial version. *) @@ -47,7 +47,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). fsetdec. fsetdec. Qed. - + Ltac expAdd := repeat rewrite Add_Equal. Section BasicProperties. @@ -64,7 +64,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. Proof. fsetdec. Qed. - Lemma subset_refl : s[<=]s. + Lemma subset_refl : s[<=]s. Proof. fsetdec. Qed. Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. @@ -84,7 +84,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. Proof. fsetdec. Qed. - + Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. Proof. fsetdec. Qed. @@ -93,7 +93,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. Proof. fsetdec. Qed. - + Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. Proof. intuition fsetdec. Qed. @@ -105,7 +105,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma add_equal : In x s -> add x s [=] s. Proof. fsetdec. Qed. - + Lemma add_add : add x (add x' s) [=] add x' (add x s). Proof. fsetdec. Qed. @@ -149,11 +149,11 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma union_add : union (add x s) s' [=] add x (union s s'). Proof. fsetdec. Qed. - Lemma union_remove_add_1 : + Lemma union_remove_add_1 : union (remove x s) (add x s') [=] union (add x s) (remove x s'). Proof. fsetdec. Qed. - Lemma union_remove_add_2 : In x s -> + Lemma union_remove_add_2 : In x s -> union (remove x s) (add x s') [=] union s s'. Proof. fsetdec. Qed. @@ -167,10 +167,10 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. fsetdec. Qed. Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. - Proof. fsetdec. Qed. + Proof. fsetdec. Qed. Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. - Proof. fsetdec. Qed. + Proof. fsetdec. Qed. Lemma empty_union_1 : Empty s -> union s s' [=] s'. Proof. fsetdec. Qed. @@ -178,7 +178,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma empty_union_2 : Empty s -> union s' s [=] s'. Proof. fsetdec. Qed. - Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). + Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). Proof. fsetdec. Qed. Lemma inter_sym : inter s s' [=] inter s' s. @@ -224,7 +224,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. Proof. fsetdec. Qed. - Lemma empty_diff_1 : Empty s -> Empty (diff s s'). + Lemma empty_diff_1 : Empty s -> Empty (diff s s'). Proof. fsetdec. Qed. Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. @@ -240,7 +240,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). remove x s [=] diff s (singleton x). Proof. fsetdec. Qed. - Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. + Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. Proof. fsetdec. Qed. Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. @@ -249,19 +249,19 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma Add_add : Add x s (add x s). Proof. expAdd; fsetdec. Qed. - Lemma Add_remove : In x s -> Add x (remove x s) s. + Lemma Add_remove : In x s -> Add x (remove x s) s. Proof. expAdd; fsetdec. Qed. Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). - Proof. expAdd; fsetdec. Qed. + Proof. expAdd; fsetdec. Qed. Lemma inter_Add : In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). - Proof. expAdd; fsetdec. Qed. + Proof. expAdd; fsetdec. Qed. Lemma union_Equal : In x s'' -> Add x s s' -> union s s'' [=] union s' s''. - Proof. expAdd; fsetdec. Qed. + Proof. expAdd; fsetdec. Qed. Lemma inter_Add_2 : ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. @@ -270,16 +270,16 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). End BasicProperties. Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. - Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym - subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 + Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym + subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal - remove_equal singleton_equal_add union_subset_equal union_equal_1 - union_equal_2 union_assoc add_union_singleton union_add union_subset_1 + remove_equal singleton_equal_add union_subset_equal union_equal_1 + union_equal_2 union_assoc add_union_singleton union_add union_subset_1 union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2 inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2 - empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 - empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union - inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal + empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 + empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union + inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove Equal_remove add_add : set. @@ -358,9 +358,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' -> P s' a -> P s'' (f x a)). intros; eapply Pstep; eauto. - rewrite elements_iff, <- InA_rev; auto. + rewrite elements_iff, <- InA_rev; auto with *. assert (Hdup : NoDup l) by - (unfold l; eauto using elements_3w, NoDupA_rev). + (unfold l; eauto using elements_3w, NoDupA_rev with *). assert (Hsame : forall x, In x s <-> InA x l) by (unfold l; intros; rewrite elements_iff, InA_rev; intuition). clear Pstep; clearbody l; revert s Hsame; induction l. @@ -429,7 +429,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). do 2 rewrite fold_1, <- fold_left_rev_right. set (l:=rev (elements s)). assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by - (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto). + (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with *). clearbody l; clear Rstep s. induction l; simpl; auto. Qed. @@ -481,8 +481,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). fold f s i = fold_right f i l. Proof. intros; exists (rev (elements s)); split. - apply NoDupA_rev; auto with set. - exact E.eq_trans. + apply NoDupA_rev; auto with *. split; intros. rewrite elements_iff; do 2 rewrite InA_alt. split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. @@ -504,7 +503,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). generalize H H2; clear H H2; case l; simpl; intros. reflexivity. elim (H e). - elim (H2 e); intuition. + elim (H2 e); intuition. Qed. Lemma fold_2 : @@ -514,17 +513,16 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). transpose eqA f -> ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). Proof. - intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); + intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. - apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto. - eauto. + apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto with *. rewrite <- Hl1; auto. - intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; + intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; rewrite (H2 a); intuition. Qed. - (** In fact, [fold] on empty sets is more than equivalent to + (** In fact, [fold] on empty sets is more than equivalent to the initial element, it is Leibniz-equal to it. *) Lemma fold_1b : @@ -541,26 +539,27 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). - Lemma fold_commutes : forall i s x, + Lemma fold_commutes : forall i s x, eqA (fold f s (f x i)) (f x (fold f s i)). Proof. intros. apply fold_rel with (R:=fun u v => eqA u (f x v)); intros. reflexivity. - transitivity (f x0 (f x b)); auto. + transitivity (f x0 (f x b)); auto. apply Comp; auto with *. Qed. (** ** Fold is a morphism *) - Lemma fold_init : forall i i' s, eqA i i' -> + Lemma fold_init : forall i i' s, eqA i i' -> eqA (fold f s i) (fold f s i'). Proof. intros. apply fold_rel with (R:=eqA); auto. + intros; apply Comp; auto with *. Qed. - Lemma fold_equal : + Lemma fold_equal : forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). - Proof. + Proof. intros i s; pattern s; apply set_induction; clear s; intros. transitivity i. apply fold_1; auto. @@ -576,23 +575,23 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). (** ** Fold and other set operators *) Lemma fold_empty : forall i, fold f empty i = i. - Proof. + Proof. intros i; apply fold_1b; auto with set. Qed. - Lemma fold_add : forall i s x, ~In x s -> + Lemma fold_add : forall i s x, ~In x s -> eqA (fold f (add x s) i) (f x (fold f s i)). - Proof. + Proof. intros; apply fold_2 with (eqA := eqA); auto with set. Qed. - Lemma add_fold : forall i s x, In x s -> + Lemma add_fold : forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply fold_equal; auto with set. Qed. - Lemma remove_fold_1: forall i s x, In x s -> + Lemma remove_fold_1: forall i s x, In x s -> eqA (f x (fold f (remove x s) i)) (fold f s i). Proof. intros. @@ -600,7 +599,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_2 with (eqA:=eqA); auto with set. Qed. - Lemma remove_fold_2: forall i s x, ~In x s -> + Lemma remove_fold_2: forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros. @@ -620,7 +619,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). symmetry; apply fold_1; auto. rename s'0 into s''. destruct (In_dec x s'). - (* In x s' *) + (* In x s' *) transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. apply fold_init; auto. apply fold_2 with (eqA:=eqA); auto with set. @@ -646,7 +645,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). symmetry; apply fold_2 with (eqA:=eqA); auto. Qed. - Lemma fold_diff_inter : forall i s s', + Lemma fold_diff_inter : forall i s s', eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). Proof. intros. @@ -659,7 +658,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_1; auto with set. Qed. - Lemma fold_union: forall i s s', + Lemma fold_union: forall i s s', (forall x, ~(In x s/\In x s')) -> eqA (fold f (union s s') i) (fold f s (fold f s' i)). Proof. @@ -696,9 +695,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma cardinal_0 : forall s, exists l : list elt, NoDupA E.eq l /\ - (forall x : elt, In x s <-> InA E.eq x l) /\ + (forall x : elt, In x s <-> InA E.eq x l) /\ cardinal s = length l. - Proof. + Proof. intros; exists (elements s); intuition; apply cardinal_1. Qed. @@ -724,32 +723,32 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). destruct (elements s); intuition; discriminate. Qed. - Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. + Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. Proof. - intros; rewrite cardinal_Empty; auto. + intros; rewrite cardinal_Empty; auto. Qed. Hint Resolve cardinal_inv_1. - + Lemma cardinal_inv_2 : forall s n, cardinal s = S n -> { x : elt | In x s }. - Proof. + Proof. intros; rewrite M.cardinal_1 in H. generalize (elements_2 (s:=s)). - destruct (elements s); try discriminate. + destruct (elements s); try discriminate. exists e; auto. Qed. Lemma cardinal_inv_2b : forall s, cardinal s <> 0 -> { x : elt | In x s }. Proof. - intro; generalize (@cardinal_inv_2 s); destruct cardinal; + intro; generalize (@cardinal_inv_2 s); destruct cardinal; [intuition|eauto]. Qed. (** ** Cardinal is a morphism *) Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. - Proof. + Proof. symmetry. remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. induction n; intros. @@ -794,8 +793,8 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_diff_inter with (eqA:=@Logic.eq nat); auto. Qed. - Lemma union_cardinal: - forall s s', (forall x, ~(In x s/\In x s')) -> + Lemma union_cardinal: + forall s s', (forall x, ~(In x s/\In x s')) -> cardinal (union s s')=cardinal s+cardinal s'. Proof. intros; do 3 rewrite cardinal_fold. @@ -803,7 +802,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_union; auto. Qed. - Lemma subset_cardinal : + Lemma subset_cardinal : forall s s', s[<=]s' -> cardinal s <= cardinal s' . Proof. intros. @@ -812,9 +811,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). rewrite (inter_subset_equal H); auto with arith. Qed. - Lemma subset_cardinal_lt : + Lemma subset_cardinal_lt : forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'. - Proof. + Proof. intros. rewrite <- (diff_inter_cardinal s' s). rewrite (inter_sym s' s). @@ -826,7 +825,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). intros _. change (0 + cardinal s < S n + cardinal s). apply Plus.plus_lt_le_compat; auto with arith. - Qed. + Qed. Theorem union_inter_cardinal : forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . @@ -837,7 +836,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_union_inter with (eqA:=@Logic.eq nat); auto. Qed. - Lemma union_cardinal_inter : + Lemma union_cardinal_inter : forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s'). Proof. intros. @@ -846,17 +845,17 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). auto with arith. Qed. - Lemma union_cardinal_le : + Lemma union_cardinal_le : forall s s', cardinal (union s s') <= cardinal s + cardinal s'. Proof. intros; generalize (union_inter_cardinal s s'). intros; rewrite <- H; auto with arith. Qed. - Lemma add_cardinal_1 : + Lemma add_cardinal_1 : forall s x, In x s -> cardinal (add x s) = cardinal s. Proof. - auto with set. + auto with set. Qed. Lemma add_cardinal_2 : @@ -877,9 +876,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply remove_fold_1 with (eqA:=@Logic.eq nat); auto. Qed. - Lemma remove_cardinal_2 : + Lemma remove_cardinal_2 : forall s x, ~In x s -> cardinal (remove x s) = cardinal s. - Proof. + Proof. auto with set. Qed. @@ -910,7 +909,7 @@ Module OrdProperties (M:S). Lemma sort_equivlistA_eqlistA : forall l l' : list elt, sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'. Proof. - apply SortA_equivlistA_eqlistA; eauto. + apply SortA_equivlistA_eqlistA; eauto with *. Qed. Definition gtb x y := match E.compare x y with GT _ => true | _ => false end. @@ -929,7 +928,7 @@ Module OrdProperties (M:S). intros; unfold leb, gtb; destruct (E.compare x y); intuition; try discriminate; ME.order. Qed. - Lemma gtb_compat : forall x, compat_bool E.eq (gtb x). + Lemma gtb_compat : forall x, Proper (E.eq==>Logic.eq) (gtb x). Proof. red; intros x a b H. generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto. @@ -943,89 +942,88 @@ Module OrdProperties (M:S). rewrite <- H1; auto. Qed. - Lemma leb_compat : forall x, compat_bool E.eq (leb x). + Lemma leb_compat : forall x, Proper (E.eq==>Logic.eq) (leb x). Proof. red; intros x a b H; unfold leb. f_equal; apply gtb_compat; auto. Qed. Hint Resolve gtb_compat leb_compat. - Lemma elements_split : forall x s, + Lemma elements_split : forall x s, elements s = elements_lt x s ++ elements_ge x s. Proof. unfold elements_lt, elements_ge, leb; intros. - eapply (@filter_split _ E.eq); eauto with set. ME.order. ME.order. ME.order. + eapply (@filter_split _ E.eq _ E.lt); auto with *. intros. rewrite gtb_1 in H. assert (~E.lt y x). - unfold gtb in *; destruct (E.compare x y); intuition; try discriminate; ME.order. + unfold gtb in *; destruct (E.compare x y); intuition; + try discriminate; ME.order. ME.order. Qed. - Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> - eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). + Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> + eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). Proof. intros; unfold elements_ge, elements_lt. apply sort_equivlistA_eqlistA; auto with set. - apply (@SortA_app _ E.eq); auto. - apply (@filter_sort _ E.eq); auto with set; eauto with set. + apply (@SortA_app _ E.eq); auto with *. + apply (@filter_sort _ E.eq); auto with *. constructor; auto. - apply (@filter_sort _ E.eq); auto with set; eauto with set. - rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with set). + apply (@filter_sort _ E.eq); auto with *. + rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with *). intros. - rewrite filter_InA in H1; auto; destruct H1. + rewrite filter_InA in H1; auto with *; destruct H1. rewrite leb_1 in H2. rewrite <- elements_iff in H1. assert (~E.eq x y). contradict H; rewrite H; auto. ME.order. intros. - rewrite filter_InA in H1; auto; destruct H1. + rewrite filter_InA in H1; auto with *; destruct H1. rewrite gtb_1 in H3. inversion_clear H2. ME.order. - rewrite filter_InA in H4; auto; destruct H4. + rewrite filter_InA in H4; auto with *; destruct H4. rewrite leb_1 in H4. ME.order. red; intros a. - rewrite InA_app_iff; rewrite InA_cons. - do 2 (rewrite filter_InA; auto). - do 2 rewrite <- elements_iff. - rewrite leb_1; rewrite gtb_1. - rewrite (H0 a); intuition. + rewrite InA_app_iff, InA_cons, !filter_InA, <-elements_iff, + leb_1, gtb_1, (H0 a) by auto with *. + intuition. destruct (E.compare a x); intuition. - right; right; split; auto. + right; right; split; auto with *. ME.order. Qed. Definition Above x s := forall y, In y s -> E.lt y x. Definition Below x s := forall y, In y s -> E.lt x y. - Lemma elements_Add_Above : forall s s' x, - Above x s -> Add x s s' -> + Lemma elements_Add_Above : forall s s' x, + Above x s -> Add x s s' -> eqlistA E.eq (elements s') (elements s ++ x::nil). Proof. intros. - apply sort_equivlistA_eqlistA; auto with set. - apply (@SortA_app _ E.eq); auto with set. + apply sort_equivlistA_eqlistA; auto with *. + apply (@SortA_app _ E.eq); auto with *. intros. inversion_clear H2. rewrite <- elements_iff in H1. apply ME.lt_eq with x; auto. inversion H3. red; intros a. - rewrite InA_app_iff; rewrite InA_cons; rewrite InA_nil. + rewrite InA_app_iff, InA_cons, InA_nil by auto with *. do 2 rewrite <- elements_iff; rewrite (H0 a); intuition. Qed. - Lemma elements_Add_Below : forall s s' x, - Below x s -> Add x s s' -> + Lemma elements_Add_Below : forall s s' x, + Below x s -> Add x s s' -> eqlistA E.eq (elements s') (x::elements s). Proof. intros. - apply sort_equivlistA_eqlistA; auto with set. + apply sort_equivlistA_eqlistA; auto with *. change (sort E.lt ((x::nil) ++ elements s)). - apply (@SortA_app _ E.eq); auto with set. + apply (@SortA_app _ E.eq); auto with *. intros. inversion_clear H1. rewrite <- elements_iff in H2. @@ -1036,7 +1034,7 @@ Module OrdProperties (M:S). do 2 rewrite <- elements_iff; rewrite (H0 a); intuition. Qed. - (** Two other induction principles on sets: we can be more restrictive + (** Two other induction principles on sets: we can be more restrictive on the element we add at each step. *) Lemma set_induction_max : @@ -1117,15 +1115,15 @@ Module OrdProperties (M:S). apply elements_Add_Below; auto. Qed. - (** The following results have already been proved earlier, + (** The following results have already been proved earlier, but we can now prove them with one hypothesis less: no need for [(transpose eqA f)]. *) - Section FoldOpt. + Section FoldOpt. Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f). - Lemma fold_equal : + Lemma fold_equal : forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). Proof. intros; do 2 rewrite M.fold_1. @@ -1136,13 +1134,13 @@ Module OrdProperties (M:S). red; intro a; do 2 rewrite <- elements_iff; auto. Qed. - Lemma add_fold : forall i s x, In x s -> + Lemma add_fold : forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply fold_equal; auto with set. Qed. - Lemma remove_fold_2: forall i s x, ~In x s -> + Lemma remove_fold_2: forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros. @@ -1153,16 +1151,16 @@ Module OrdProperties (M:S). (** An alternative version of [choose_3] *) - Lemma choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with + Lemma choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with | Some x, Some x' => E.eq x x' | None, None => True | _, _ => False end. Proof. - intros s s' H; + intros s s' H; generalize (@choose_1 s)(@choose_2 s) - (@choose_1 s')(@choose_2 s')(@choose_3 s s'); + (@choose_1 s')(@choose_2 s')(@choose_3 s s'); destruct (choose s); destruct (choose s'); simpl; intuition. apply H5 with e; rewrite <-H; auto. apply H5 with e; rewrite H; auto. diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v index 56a66261..01138270 100644 --- a/theories/FSets/FSetToFiniteSet.v +++ b/theories/FSets/FSetToFiniteSet.v @@ -6,24 +6,21 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre - * Institution: LRI, CNRS UMR 8623 - Université Paris Sud - * 91405 Orsay, France *) +(* $Id$ *) -(* $Id: FSetToFiniteSet.v 11735 2009-01-02 17:22:31Z herbelin $ *) +(** * Finite sets library : conversion to old [Finite_sets] *) Require Import Ensembles Finite_sets. Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx. -(** * Going from [FSets] with usual Leibniz equality +(** * Going from [FSets] with usual Leibniz equality to the good old [Ensembles] and [Finite_sets] theory. *) Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). Module MP:= WProperties_fun U M. Import M MP FM Ensembles Finite_sets. - Definition mkEns : M.t -> Ensemble M.elt := + Definition mkEns : M.t -> Ensemble M.elt := fun s x => M.In x s. Notation " !! " := mkEns. @@ -115,11 +112,11 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). Proof. intro s; pattern s; apply set_induction; clear s; intros. intros; replace (!!s) with (Empty_set elt); auto with sets. - symmetry; apply Extensionality_Ensembles. + symmetry; apply Extensionality_Ensembles. apply Empty_Empty_set; auto. replace (!!s') with (Add _ (!!s) x). constructor 2; auto. - symmetry; apply Extensionality_Ensembles. + symmetry; apply Extensionality_Ensembles. apply Add_Add; auto. Qed. @@ -128,18 +125,18 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). intro s; pattern s; apply set_induction; clear s; intros. intros; replace (!!s) with (Empty_set elt); auto with sets. rewrite cardinal_1; auto with sets. - symmetry; apply Extensionality_Ensembles. + symmetry; apply Extensionality_Ensembles. apply Empty_Empty_set; auto. replace (!!s') with (Add _ (!!s) x). - rewrite (cardinal_2 H0 H1); auto with sets. - symmetry; apply Extensionality_Ensembles. + rewrite (cardinal_2 H0 H1); auto with sets. + symmetry; apply Extensionality_Ensembles. apply Add_Add; auto. Qed. - (** we can even build a function from Finite Ensemble to FSet + (** we can even build a function from Finite Ensemble to FSet ... at least in Prop. *) - Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> + Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> exists s:M.t, !!s === e. Proof. induction 1. @@ -147,7 +144,7 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). apply empty_Empty_Set. destruct IHFinite as (s,Hs). exists (M.add x s). - apply Extensionality_Ensembles in Hs. + apply Extensionality_Ensembles in Hs. rewrite <- Hs. apply add_Add. Qed. diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v index 309016ce..711cbd9a 100644 --- a/theories/FSets/FSetWeakList.v +++ b/theories/FSets/FSetWeakList.v @@ -6,952 +6,25 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetWeakList.v 11866 2009-01-28 19:10:15Z letouzey $ *) +(* $Id$ *) (** * Finite sets library *) -(** This file proposes an implementation of the non-dependant - interface [FSetWeakInterface.S] using lists without redundancy. *) +(** This file proposes an implementation of the non-dependant + interface [FSetInterface.WS] using lists without redundancy. *) Require Import FSetInterface. Set Implicit Arguments. Unset Strict Implicit. -(** * Functions over lists +(** This is just a compatibility layer, the real implementation + is now in [MSetWeakList] *) - First, we provide sets as lists which are (morally) without redundancy. - The specs are proved under the additional condition of no redundancy. - And the functions returning sets are proved to preserve this invariant. *) - -Module Raw (X: DecidableType). - - Definition elt := X.t. - Definition t := list elt. - - Definition empty : t := nil. - - Definition is_empty (l : t) : bool := if l then true else false. - - (** ** The set operations. *) - - Fixpoint mem (x : elt) (s : t) {struct s} : bool := - match s with - | nil => false - | y :: l => - if X.eq_dec x y then true else mem x l - end. - - Fixpoint add (x : elt) (s : t) {struct s} : t := - match s with - | nil => x :: nil - | y :: l => - if X.eq_dec x y then s else y :: add x l - end. - - Definition singleton (x : elt) : t := x :: nil. - - Fixpoint remove (x : elt) (s : t) {struct s} : t := - match s with - | nil => nil - | y :: l => - if X.eq_dec x y then l else y :: remove x l - end. - - Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : - B -> B := fun i => match s with - | nil => i - | x :: l => fold f l (f x i) - end. - - Definition union (s : t) : t -> t := fold add s. - - Definition diff (s s' : t) : t := fold remove s' s. - - Definition inter (s s': t) : t := - fold (fun x s => if mem x s' then add x s else s) s nil. - - Definition subset (s s' : t) : bool := is_empty (diff s s'). - - Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s). - - Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t := - match s with - | nil => nil - | x :: l => if f x then x :: filter f l else filter f l - end. - - Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool := - match s with - | nil => true - | x :: l => if f x then for_all f l else false - end. - - Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool := - match s with - | nil => false - | x :: l => if f x then true else exists_ f l - end. - - Fixpoint partition (f : elt -> bool) (s : t) {struct s} : - t * t := - match s with - | nil => (nil, nil) - | x :: l => - let (s1, s2) := partition f l in - if f x then (x :: s1, s2) else (s1, x :: s2) - end. - - Definition cardinal (s : t) : nat := length s. - - Definition elements (s : t) : list elt := s. - - Definition choose (s : t) : option elt := - match s with - | nil => None - | x::_ => Some x - end. - - (** ** Proofs of set operation specifications. *) - Section ForNotations. - Notation NoDup := (NoDupA X.eq). - Notation In := (InA X.eq). - - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Lemma In_eq : - forall (s : t) (x y : elt), X.eq x y -> In x s -> In y s. - Proof. - intros s x y; setoid_rewrite InA_alt; firstorder eauto. - Qed. - Hint Immediate In_eq. - - Lemma mem_1 : - forall (s : t)(x : elt), In x s -> mem x s = true. - Proof. - induction s; intros. - inversion H. - simpl; destruct (X.eq_dec x a); trivial. - inversion_clear H; auto. - Qed. - - Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. - Proof. - induction s. - intros; inversion H. - intros x; simpl. - destruct (X.eq_dec x a); firstorder; discriminate. - Qed. - - Lemma add_1 : - forall (s : t) (Hs : NoDup s) (x y : elt), X.eq x y -> In y (add x s). - Proof. - induction s. - simpl; intuition. - simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs; - firstorder. - eauto. - Qed. - - Lemma add_2 : - forall (s : t) (Hs : NoDup s) (x y : elt), In y s -> In y (add x s). - Proof. - induction s. - simpl; intuition. - simpl; intros; case (X.eq_dec x a); intuition. - inversion_clear Hs; eauto; inversion_clear H; intuition. - Qed. - - Lemma add_3 : - forall (s : t) (Hs : NoDup s) (x y : elt), - ~ X.eq x y -> In y (add x s) -> In y s. - Proof. - induction s. - simpl; intuition. - inversion_clear H0; firstorder; absurd (X.eq x y); auto. - simpl; intros Hs x y; case (X.eq_dec x a); intros; - inversion_clear H0; inversion_clear Hs; firstorder; - absurd (X.eq x y); auto. - Qed. - - Lemma add_unique : - forall (s : t) (Hs : NoDup s)(x:elt), NoDup (add x s). - Proof. - induction s. - simpl; intuition. - constructor; auto. - intro H0; inversion H0. - intros. - inversion_clear Hs. - simpl. - destruct (X.eq_dec x a). - constructor; auto. - constructor; auto. - intro H1; apply H. - eapply add_3; eauto. - Qed. - - Lemma remove_1 : - forall (s : t) (Hs : NoDup s) (x y : elt), X.eq x y -> ~ In y (remove x s). - Proof. - simple induction s. - simpl; red; intros; inversion H0. - simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs. - elim H2. - apply In_eq with y; eauto. - inversion_clear H1; eauto. - Qed. - - Lemma remove_2 : - forall (s : t) (Hs : NoDup s) (x y : elt), - ~ X.eq x y -> In y s -> In y (remove x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs; - inversion_clear H1; auto. - absurd (X.eq x y); eauto. - Qed. - - Lemma remove_3 : - forall (s : t) (Hs : NoDup s) (x y : elt), In y (remove x s) -> In y s. - Proof. - simple induction s. - simpl; intuition. - simpl; intros a l Hrec Hs x y; case (X.eq_dec x a); intuition. - inversion_clear Hs; inversion_clear H; firstorder. - Qed. - - Lemma remove_unique : - forall (s : t) (Hs : NoDup s) (x : elt), NoDup (remove x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs; - auto. - constructor; auto. - intro H2; elim H0. - eapply remove_3; eauto. - Qed. - - Lemma singleton_unique : forall x : elt, NoDup (singleton x). - Proof. - unfold singleton; simpl; constructor; auto; intro H; inversion H. - Qed. - - Lemma singleton_1 : forall x y : elt, In y (singleton x) -> X.eq x y. - Proof. - unfold singleton; simpl; intuition. - inversion_clear H; auto; inversion H0. - Qed. - - Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x). - Proof. - unfold singleton; simpl; intuition. - Qed. - - Lemma empty_unique : NoDup empty. - Proof. - unfold empty; constructor. - Qed. - - Lemma empty_1 : Empty empty. - Proof. - unfold Empty, empty; intuition; inversion H. - Qed. - - Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true. - Proof. - unfold Empty; intro s; case s; simpl; intuition. - elim (H e); auto. - Qed. - - Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. - Proof. - unfold Empty; intro s; case s; simpl; intuition; - inversion H0. - Qed. - - Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s). - Proof. - unfold elements; auto. - Qed. - - Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s. - Proof. - unfold elements; auto. - Qed. - - Lemma elements_3w : forall (s : t) (Hs : NoDup s), NoDup (elements s). - Proof. - unfold elements; auto. - Qed. - - Lemma fold_1 : - forall (s : t) (Hs : NoDup 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. - induction s; simpl; auto; intros. - inversion_clear Hs; auto. - Qed. - - Lemma union_unique : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (union s s'). - Proof. - unfold union; induction s; simpl; auto; intros. - inversion_clear Hs. - apply IHs; auto. - apply add_unique; auto. - Qed. - - Lemma union_1 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (union s s') -> In x s \/ In x s'. - Proof. - unfold union; induction s; simpl; auto; intros. - inversion_clear Hs. - destruct (X.eq_dec x a). - left; auto. - destruct (IHs (add a s') H1 (add_unique Hs' a) x); intuition. - right; eapply add_3; eauto. - Qed. - - Lemma union_0 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x s \/ In x s' -> In x (union s s'). - Proof. - unfold union; induction s; simpl; auto; intros. - inversion_clear H; auto. - inversion_clear H0. - inversion_clear Hs. - apply IHs; auto. - apply add_unique; auto. - destruct H. - inversion_clear H; auto. - right; apply add_1; auto. - right; apply add_2; auto. - Qed. - - Lemma union_2 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x s -> In x (union s s'). - Proof. - intros; apply union_0; auto. - Qed. - - Lemma union_3 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x s' -> In x (union s s'). - Proof. - intros; apply union_0; auto. - Qed. - - Lemma inter_unique : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (inter s s'). - Proof. - unfold inter; intros s. - set (acc := nil (A:=elt)). - assert (NoDup acc) by (unfold acc; auto). - clearbody acc; generalize H; clear H; generalize acc; clear acc. - induction s; simpl; auto; intros. - inversion_clear Hs. - apply IHs; auto. - destruct (mem a s'); intros; auto. - apply add_unique; auto. - Qed. - - Lemma inter_0 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (inter s s') -> In x s /\ In x s'. - Proof. - unfold inter; intros. - set (acc := nil (A:=elt)) in *. - assert (NoDup acc) by (unfold acc; auto). - cut ((In x s /\ In x s') \/ In x acc). - destruct 1; auto. - inversion H1. - clearbody acc. - generalize H0 H Hs' Hs; clear H0 H Hs Hs'. - generalize acc x s'; clear acc x s'. - induction s; simpl; auto; intros. - inversion_clear Hs. - case_eq (mem a s'); intros H3; rewrite H3 in H; simpl in H. - destruct (IHs _ _ _ (add_unique H0 a) H); auto. - left; intuition. - destruct (X.eq_dec x a); auto. - left; intuition. - apply In_eq with a; eauto. - apply mem_2; auto. - right; eapply add_3; eauto. - destruct (IHs _ _ _ H0 H); auto. - left; intuition. - Qed. - - Lemma inter_1 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (inter s s') -> In x s. - Proof. - intros; cut (In x s /\ In x s'); [ intuition | apply inter_0; auto ]. - Qed. - - Lemma inter_2 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (inter s s') -> In x s'. - Proof. - intros; cut (In x s /\ In x s'); [ intuition | apply inter_0; auto ]. - Qed. - - Lemma inter_3 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x s -> In x s' -> In x (inter s s'). - Proof. - intros s s' Hs Hs' x. - cut (((In x s /\ In x s')\/ In x (nil (A:=elt))) -> In x (inter s s')). - intuition. - unfold inter. - set (acc := nil (A:=elt)) in *. - assert (NoDup acc) by (unfold acc; auto). - clearbody acc. - generalize H Hs' Hs; clear H Hs Hs'. - generalize acc x s'; clear acc x s'. - induction s; simpl; auto; intros. - destruct H0; auto. - destruct H0; inversion H0. - inversion_clear Hs. - case_eq (mem a s'); intros H3; apply IHs; auto. - apply add_unique; auto. - destruct H0. - destruct H0. - inversion_clear H0. - right; apply add_1; auto. - left; auto. - right; apply add_2; auto. - destruct H0; auto. - destruct H0. - inversion_clear H0; auto. - absurd (In x s'); auto. - red; intros. - rewrite (mem_1 (In_eq H5 H0)) in H3. - discriminate. - Qed. - - Lemma diff_unique : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (diff s s'). - Proof. - unfold diff; intros s s' Hs; generalize s Hs; clear Hs s. - induction s'; simpl; auto; intros. - inversion_clear Hs'. - apply IHs'; auto. - apply remove_unique; auto. - Qed. - - Lemma diff_0 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (diff s s') -> In x s /\ ~ In x s'. - Proof. - unfold diff; intros s s' Hs; generalize s Hs; clear Hs s. - induction s'; simpl; auto; intros. - inversion_clear Hs'. - split; auto; intro H1; inversion H1. - inversion_clear Hs'. - destruct (IHs' (remove a s) (remove_unique Hs a) H1 x H). - split. - eapply remove_3; eauto. - red; intros. - inversion_clear H4; auto. - destruct (remove_1 Hs (X.eq_sym H5) H2). - Qed. - - Lemma diff_1 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (diff s s') -> In x s. - Proof. - intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. - Qed. - - Lemma diff_2 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (diff s s') -> ~ In x s'. - Proof. - intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. - Qed. - - Lemma diff_3 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x s -> ~ In x s' -> In x (diff s s'). - Proof. - unfold diff; intros s s' Hs; generalize s Hs; clear Hs s. - induction s'; simpl; auto; intros. - inversion_clear Hs'. - apply IHs'; auto. - apply remove_unique; auto. - apply remove_2; auto. - Qed. - - Lemma subset_1 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), - Subset s s' -> subset s s' = true. - Proof. - unfold subset, Subset; intros. - apply is_empty_1. - unfold Empty; intros. - intro. - destruct (diff_2 Hs Hs' H0). - apply H. - eapply diff_1; eauto. - Qed. - - Lemma subset_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'), - subset s s' = true -> Subset s s'. - Proof. - unfold subset, Subset; intros. - generalize (is_empty_2 H); clear H; unfold Empty; intros. - generalize (@mem_1 s' a) (@mem_2 s' a); destruct (mem a s'). - intuition. - intros. - destruct (H a). - apply diff_3; intuition. - Qed. - - Lemma equal_1 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), - Equal s s' -> equal s s' = true. - Proof. - unfold Equal, equal; intros. - apply andb_true_intro; split; apply subset_1; firstorder. - Qed. - - Lemma equal_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'), - equal s s' = true -> Equal s s'. - Proof. - unfold Equal, equal; intros. - destruct (andb_prop _ _ H); clear H. - split; apply subset_2; auto. - Qed. - - Definition choose_1 : - forall (s : t) (x : elt), choose s = Some x -> In x s. - Proof. - destruct s; simpl; intros; inversion H; auto. - Qed. - - Definition choose_2 : forall s : t, choose s = None -> Empty s. - Proof. - destruct s; simpl; intros. - intros x H0; inversion H0. - inversion H. - Qed. - - Lemma cardinal_1 : - forall (s : t) (Hs : NoDup s), cardinal s = length (elements s). - Proof. - auto. - Qed. - - Lemma filter_1 : - forall (s : t) (x : elt) (f : elt -> bool), - In x (filter f s) -> In x s. - Proof. - simple induction s; simpl. - intros; inversion H. - intros x l Hrec a f. - case (f x); simpl. - inversion_clear 1. - constructor; auto. - constructor 2; apply (Hrec a f); trivial. - constructor 2; apply (Hrec a f); trivial. - Qed. - - Lemma filter_2 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x (filter f s) -> f x = true. - Proof. - simple induction s; simpl. - intros; inversion H0. - intros x l Hrec a f Hf. - generalize (Hf x); case (f x); simpl; auto. - inversion_clear 2; auto. - symmetry; auto. - Qed. - - Lemma filter_3 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. - simple induction s; simpl. - intros; inversion H0. - intros x l Hrec a f Hf. - generalize (Hf x); case (f x); simpl. - inversion_clear 2; auto. - inversion_clear 2; auto. - rewrite <- (H a (X.eq_sym H1)); intros; discriminate. - Qed. - - Lemma filter_unique : - forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (filter f s). - Proof. - simple induction s; simpl. - auto. - intros x l Hrec Hs f; inversion_clear Hs. - case (f x); auto. - constructor; auto. - intro H1; apply H. - eapply filter_1; eauto. - Qed. - - - Lemma for_all_1 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Proof. - simple induction s; simpl; auto; unfold For_all. - intros x l Hrec f Hf. - generalize (Hf x); case (f x); simpl. - auto. - intros; rewrite (H x); auto. - Qed. - - Lemma for_all_2 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - Proof. - simple induction s; simpl; auto; unfold For_all. - intros; inversion H1. - intros x l Hrec f Hf. - intros A a; intros. - assert (f x = true). - generalize A; case (f x); auto. - rewrite H0 in A; simpl in A. - inversion_clear H; auto. - rewrite (Hf a x); auto. - Qed. - - Lemma exists_1 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. - simple induction s; simpl; auto; unfold Exists. - intros. - elim H0; intuition. - inversion H2. - intros x l Hrec f Hf. - generalize (Hf x); case (f x); simpl. - auto. - destruct 2 as [a (A1,A2)]. - inversion_clear A1. - rewrite <- (H a (X.eq_sym H0)) in A2; discriminate. - apply Hrec; auto. - exists a; auto. - Qed. - - Lemma exists_2 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. - simple induction s; simpl; auto; unfold Exists. - intros; discriminate. - intros x l Hrec f Hf. - case_eq (f x); intros. - exists x; auto. - destruct (Hrec f Hf H0) as [a (A1,A2)]. - exists a; auto. - Qed. - - Lemma partition_1 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> Equal (fst (partition f s)) (filter f s). - Proof. - simple induction s; simpl; auto; unfold Equal. - firstorder. - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - case (partition f l); intros s1 s2; simpl; intros. - case (f x); simpl; firstorder; inversion H0; intros; firstorder. - Qed. - - Lemma partition_2 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - simple induction s; simpl; auto; unfold Equal. - firstorder. - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - case (partition f l); intros s1 s2; simpl; intros. - case (f x); simpl; firstorder; inversion H0; intros; firstorder. - Qed. - - Lemma partition_aux_1 : - forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), - In x (fst (partition f s)) -> In x s. - Proof. - induction s; simpl; auto; intros. - inversion_clear Hs. - generalize (IHs H1 f x). - destruct (f a); destruct (partition f s); simpl in *; auto. - inversion_clear H; auto. - Qed. - - Lemma partition_aux_2 : - forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), - In x (snd (partition f s)) -> In x s. - Proof. - induction s; simpl; auto; intros. - inversion_clear Hs. - generalize (IHs H1 f x). - destruct (f a); destruct (partition f s); simpl in *; auto. - inversion_clear H; auto. - Qed. - - Lemma partition_unique_1 : - forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (fst (partition f s)). - Proof. - simple induction s; simpl. - auto. - intros x l Hrec Hs f; inversion_clear Hs. - generalize (@partition_aux_1 _ H0 f x). - generalize (Hrec H0 f). - case (f x); case (partition f l); simpl; auto. - Qed. - - Lemma partition_unique_2 : - forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (snd (partition f s)). - Proof. - simple induction s; simpl. - auto. - intros x l Hrec Hs f; inversion_clear Hs. - generalize (@partition_aux_2 _ H0 f x). - generalize (Hrec H0 f). - case (f x); case (partition f l); simpl; auto. - Qed. - - Definition eq : t -> t -> Prop := Equal. - - Lemma eq_refl : forall s, eq s s. - Proof. firstorder. Qed. - - Lemma eq_sym : forall s s', eq s s' -> eq s' s. - Proof. firstorder. Qed. - - Lemma eq_trans : - forall s s' s'', eq s s' -> eq s' s'' -> eq s s''. - Proof. firstorder. Qed. - - Definition eq_dec : forall (s s':t)(Hs:NoDup s)(Hs':NoDup s'), - { eq s s' }+{ ~eq s s' }. - Proof. - intros. - change eq with Equal. - case_eq (equal s s'); intro H; [left | right]. - apply equal_2; auto. - intro H'; rewrite equal_1 in H; auto; discriminate. - Defined. - - End ForNotations. -End Raw. - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of lists without redundancy. *) +Require Equalities FSetCompat MSetWeakList. Module Make (X: DecidableType) <: WS with Module E := X. - - Module Raw := Raw X. Module E := X. - - Record slist := {this :> Raw.t; unique : NoDupA E.eq this}. - Definition t := slist. - Definition elt := E.t. - - Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this). - Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'. - Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'. - Definition Empty (s:t) : Prop := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) (s : t) : Prop := - forall x : elt, In x s -> P x. - Definition Exists (P : elt -> Prop) (s : t) : Prop := exists x : elt, In x s /\ P x. - - Definition mem (x : elt) (s : t) : bool := Raw.mem x s. - Definition add (x : elt)(s : t) : t := Build_slist (Raw.add_unique (unique s) x). - Definition remove (x : elt)(s : t) : t := Build_slist (Raw.remove_unique (unique s) x). - Definition singleton (x : elt) : t := Build_slist (Raw.singleton_unique x). - Definition union (s s' : t) : t := - Build_slist (Raw.union_unique (unique s) (unique s')). - Definition inter (s s' : t) : t := - Build_slist (Raw.inter_unique (unique s) (unique s')). - Definition diff (s s' : t) : t := - Build_slist (Raw.diff_unique (unique s) (unique s')). - Definition equal (s s' : t) : bool := Raw.equal s s'. - Definition subset (s s' : t) : bool := Raw.subset s s'. - Definition empty : t := Build_slist Raw.empty_unique. - Definition is_empty (s : t) : bool := Raw.is_empty s. - Definition elements (s : t) : list elt := Raw.elements s. - Definition choose (s:t) : option elt := Raw.choose s. - Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. - Definition cardinal (s : t) : nat := Raw.cardinal s. - Definition filter (f : elt -> bool) (s : t) : t := - Build_slist (Raw.filter_unique (unique s) f). - Definition for_all (f : elt -> bool) (s : t) : bool := Raw.for_all f s. - Definition exists_ (f : elt -> bool) (s : t) : bool := Raw.exists_ f s. - Definition partition (f : elt -> bool) (s : t) : t * t := - let p := Raw.partition f s in - (Build_slist (this:=fst p) (Raw.partition_unique_1 (unique s) f), - Build_slist (this:=snd p) (Raw.partition_unique_2 (unique s) f)). - - Section Spec. - Variable s s' : t. - Variable x y : elt. - - Lemma In_1 : E.eq x y -> In x s -> In y s. - Proof. exact (fun H H' => Raw.In_eq H H'). Qed. - - Lemma mem_1 : In x s -> mem x s = true. - Proof. exact (fun H => Raw.mem_1 H). Qed. - Lemma mem_2 : mem x s = true -> In x s. - Proof. exact (fun H => Raw.mem_2 H). Qed. - - Lemma equal_1 : Equal s s' -> equal s s' = true. - Proof. exact (Raw.equal_1 s.(unique) s'.(unique)). Qed. - Lemma equal_2 : equal s s' = true -> Equal s s'. - Proof. exact (Raw.equal_2 s.(unique) s'.(unique)). Qed. - - Lemma subset_1 : Subset s s' -> subset s s' = true. - Proof. exact (Raw.subset_1 s.(unique) s'.(unique)). Qed. - Lemma subset_2 : subset s s' = true -> Subset s s'. - Proof. exact (Raw.subset_2 s.(unique) s'.(unique)). Qed. - - Lemma empty_1 : Empty empty. - Proof. exact Raw.empty_1. Qed. - - Lemma is_empty_1 : Empty s -> is_empty s = true. - Proof. exact (fun H => Raw.is_empty_1 H). Qed. - Lemma is_empty_2 : is_empty s = true -> Empty s. - Proof. exact (fun H => Raw.is_empty_2 H). Qed. - - Lemma add_1 : E.eq x y -> In y (add x s). - Proof. exact (fun H => Raw.add_1 s.(unique) H). Qed. - Lemma add_2 : In y s -> In y (add x s). - Proof. exact (fun H => Raw.add_2 s.(unique) x H). Qed. - Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. - Proof. exact (fun H => Raw.add_3 s.(unique) H). Qed. - - Lemma remove_1 : E.eq x y -> ~ In y (remove x s). - Proof. exact (fun H => Raw.remove_1 s.(unique) H). Qed. - Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). - Proof. exact (fun H H' => Raw.remove_2 s.(unique) H H'). Qed. - Lemma remove_3 : In y (remove x s) -> In y s. - Proof. exact (fun H => Raw.remove_3 s.(unique) H). Qed. - - Lemma singleton_1 : In y (singleton x) -> E.eq x y. - Proof. exact (fun H => Raw.singleton_1 H). Qed. - Lemma singleton_2 : E.eq x y -> In y (singleton x). - Proof. exact (fun H => Raw.singleton_2 H). Qed. - - Lemma union_1 : In x (union s s') -> In x s \/ In x s'. - Proof. exact (fun H => Raw.union_1 s.(unique) s'.(unique) H). Qed. - Lemma union_2 : In x s -> In x (union s s'). - Proof. exact (fun H => Raw.union_2 s.(unique) s'.(unique) H). Qed. - Lemma union_3 : In x s' -> In x (union s s'). - Proof. exact (fun H => Raw.union_3 s.(unique) s'.(unique) H). Qed. - - Lemma inter_1 : In x (inter s s') -> In x s. - Proof. exact (fun H => Raw.inter_1 s.(unique) s'.(unique) H). Qed. - Lemma inter_2 : In x (inter s s') -> In x s'. - Proof. exact (fun H => Raw.inter_2 s.(unique) s'.(unique) H). Qed. - Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). - Proof. exact (fun H => Raw.inter_3 s.(unique) s'.(unique) H). Qed. - - Lemma diff_1 : In x (diff s s') -> In x s. - Proof. exact (fun H => Raw.diff_1 s.(unique) s'.(unique) H). Qed. - Lemma diff_2 : In x (diff s s') -> ~ In x s'. - Proof. exact (fun H => Raw.diff_2 s.(unique) s'.(unique) H). Qed. - Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - Proof. exact (fun H => Raw.diff_3 s.(unique) s'.(unique) H). Qed. - - Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. exact (Raw.fold_1 s.(unique)). Qed. - - Lemma cardinal_1 : cardinal s = length (elements s). - Proof. exact (Raw.cardinal_1 s.(unique)). Qed. - - Section Filter. - - Variable f : elt -> bool. - - Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Proof. exact (fun H => @Raw.filter_1 s x f). Qed. - Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Proof. exact (@Raw.filter_2 s x f). Qed. - Lemma filter_3 : - compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. exact (@Raw.filter_3 s x f). Qed. - - Lemma for_all_1 : - compat_bool E.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Proof. exact (@Raw.for_all_1 s f). Qed. - Lemma for_all_2 : - compat_bool E.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - Proof. exact (@Raw.for_all_2 s f). Qed. - - Lemma exists_1 : - compat_bool E.eq f -> - Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. exact (@Raw.exists_1 s f). Qed. - Lemma exists_2 : - compat_bool E.eq f -> - exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. exact (@Raw.exists_2 s f). Qed. - - Lemma partition_1 : - compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). - Proof. exact (@Raw.partition_1 s f). Qed. - Lemma partition_2 : - compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. exact (@Raw.partition_2 s f). Qed. - - End Filter. - - Lemma elements_1 : In x s -> InA E.eq x (elements s). - Proof. exact (fun H => Raw.elements_1 H). Qed. - Lemma elements_2 : InA E.eq x (elements s) -> In x s. - Proof. exact (fun H => Raw.elements_2 H). Qed. - Lemma elements_3w : NoDupA E.eq (elements s). - Proof. exact (Raw.elements_3w s.(unique)). Qed. - - Lemma choose_1 : choose s = Some x -> In x s. - Proof. exact (fun H => Raw.choose_1 H). Qed. - Lemma choose_2 : choose s = None -> Empty s. - Proof. exact (fun H => Raw.choose_2 H). Qed. - - End Spec. - - Definition eq : t -> t -> Prop := Equal. - - Lemma eq_refl : forall s, eq s s. - Proof. firstorder. Qed. - - Lemma eq_sym : forall s s', eq s s' -> eq s' s. - Proof. firstorder. Qed. - - Lemma eq_trans : - forall s s' s'', eq s s' -> eq s' s'' -> eq s s''. - Proof. firstorder. Qed. - - Definition eq_dec : forall (s s':t), - { eq s s' }+{ ~eq s s' }. - Proof. - intros s s'; exact (Raw.eq_dec s.(unique) s'.(unique)). - Defined. - + Module X' := Equalities.Update_DT X. + Module MSet := MSetWeakList.Make X'. + Include FSetCompat.Backport_WSets X MSet. End Make. diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v index a73c1da7..62a95734 100644 --- a/theories/FSets/FSets.v +++ b/theories/FSets/FSets.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSets.v 10699 2008-03-19 20:56:43Z letouzey $ *) +(* $Id$ *) Require Export OrderedType. Require Export OrderedTypeEx. @@ -21,4 +21,5 @@ Require Export FSetProperties. Require Export FSetEqProperties. Require Export FSetWeakList. Require Export FSetList. +Require Export FSetPositive. Require Export FSetAVL. \ No newline at end of file diff --git a/theories/FSets/OrderedType.v b/theories/FSets/OrderedType.v deleted file mode 100644 index fadd27dd..00000000 --- a/theories/FSets/OrderedType.v +++ /dev/null @@ -1,587 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* X -> Prop) (x y : X) : Type := - | LT : lt x y -> Compare lt eq x y - | EQ : eq x y -> Compare lt eq x y - | GT : lt y x -> Compare lt eq x y. - -Module Type MiniOrderedType. - - Parameter Inline t : Type. - - Parameter Inline eq : t -> t -> Prop. - Parameter Inline lt : t -> t -> Prop. - - Axiom eq_refl : forall x : t, eq x x. - Axiom eq_sym : forall x y : t, eq x y -> eq y x. - Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - - Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - - Parameter compare : forall x y : t, Compare lt eq x y. - - Hint Immediate eq_sym. - Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. - -End MiniOrderedType. - -Module Type OrderedType. - Include Type MiniOrderedType. - - (** A [eq_dec] can be deduced from [compare] below. But adding this - redundant field allows to see an OrderedType as a DecidableType. *) - Parameter eq_dec : forall x y, { eq x y } + { ~ eq x y }. - -End OrderedType. - -Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. - Include O. - - Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. - Proof. - intros; elim (compare x y); intro H; [ right | left | right ]; auto. - assert (~ eq y x); auto. - Defined. - -End MOT_to_OT. - -(** * Ordered types properties *) - -(** Additional properties that can be derived from signature - [OrderedType]. *) - -Module OrderedTypeFacts (Import O: OrderedType). - - Lemma lt_antirefl : forall x, ~ lt x x. - Proof. - intros; intro; absurd (eq x x); auto. - Qed. - - Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. - Proof. - intros; destruct (compare x z); auto. - elim (lt_not_eq H); apply eq_trans with z; auto. - elim (lt_not_eq (lt_trans l 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. - elim (lt_not_eq H0); apply eq_trans with x; auto. - elim (lt_not_eq (lt_trans H0 l)); auto. - Qed. - - Lemma le_eq : forall x y z, ~lt x y -> eq y z -> ~lt x z. - Proof. - intros; intro; destruct H; apply lt_eq with z; auto. - Qed. - - Lemma eq_le : forall x y z, eq x y -> ~lt y z -> ~lt x z. - Proof. - intros; intro; destruct H0; apply eq_lt with x; auto. - Qed. - - Lemma neq_eq : forall x y z, ~eq x y -> eq y z -> ~eq x z. - Proof. - intros; intro; destruct H; apply eq_trans with z; auto. - Qed. - - Lemma eq_neq : forall x y z, eq x y -> ~eq y z -> ~eq x z. - Proof. - intros; intro; destruct H0; apply eq_trans with x; auto. - Qed. - - Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq. - - Lemma le_lt_trans : forall x y z, ~lt y x -> lt y z -> lt x z. - Proof. - intros; destruct (compare y x); auto. - elim (H l). - apply eq_lt with y; auto. - apply lt_trans with y; auto. - Qed. - - Lemma lt_le_trans : forall x y z, lt x y -> ~lt z y -> lt x z. - Proof. - intros; destruct (compare z y); auto. - elim (H0 l). - apply lt_eq with y; auto. - apply lt_trans with y; auto. - Qed. - - Lemma le_neq : forall x y, ~lt x y -> ~eq x y -> lt y x. - Proof. - intros; destruct (compare x y); intuition. - Qed. - - Lemma neq_sym : forall x y, ~eq x y -> ~eq y x. - Proof. - intuition. - Qed. - -(* TODO concernant la tactique order: - * propagate_lt n'est sans doute pas complet - * un propagate_le - * exploiter les hypotheses negatives restant a la fin - * faire que ca marche meme quand une hypothese depend d'un eq ou lt. -*) - -Ltac abstraction := match goal with - (* First, some obvious simplifications *) - | H : False |- _ => elim H - | H : lt ?x ?x |- _ => elim (lt_antirefl H) - | H : ~eq ?x ?x |- _ => elim (H (eq_refl x)) - | H : eq ?x ?x |- _ => clear H; abstraction - | H : ~lt ?x ?x |- _ => clear H; abstraction - | |- eq ?x ?x => exact (eq_refl x) - | |- lt ?x ?x => elimtype False; abstraction - | |- ~ _ => intro; abstraction - | H1: ~lt ?x ?y, H2: ~eq ?x ?y |- _ => - generalize (le_neq H1 H2); clear H1 H2; intro; abstraction - | H1: ~lt ?x ?y, H2: ~eq ?y ?x |- _ => - generalize (le_neq H1 (neq_sym H2)); clear H1 H2; intro; abstraction - (* Then, we generalize all interesting facts *) - | H : ~eq ?x ?y |- _ => revert H; abstraction - | H : ~lt ?x ?y |- _ => revert H; abstraction - | H : lt ?x ?y |- _ => revert H; abstraction - | H : eq ?x ?y |- _ => revert H; abstraction - | _ => idtac -end. - -Ltac do_eq a b EQ := match goal with - | |- lt ?x ?y -> _ => let H := fresh "H" in - (intro H; - (generalize (eq_lt (eq_sym EQ) H); clear H; intro H) || - (generalize (lt_eq H EQ); clear H; intro H) || - idtac); - do_eq a b EQ - | |- ~lt ?x ?y -> _ => let H := fresh "H" in - (intro H; - (generalize (eq_le (eq_sym EQ) H); clear H; intro H) || - (generalize (le_eq H EQ); clear H; intro H) || - idtac); - do_eq a b EQ - | |- eq ?x ?y -> _ => let H := fresh "H" in - (intro H; - (generalize (eq_trans (eq_sym EQ) H); clear H; intro H) || - (generalize (eq_trans H EQ); clear H; intro H) || - idtac); - do_eq a b EQ - | |- ~eq ?x ?y -> _ => let H := fresh "H" in - (intro H; - (generalize (eq_neq (eq_sym EQ) H); clear H; intro H) || - (generalize (neq_eq H EQ); clear H; intro H) || - idtac); - do_eq a b EQ - | |- lt a ?y => apply eq_lt with b; [exact EQ|] - | |- lt ?y a => apply lt_eq with b; [|exact (eq_sym EQ)] - | |- eq a ?y => apply eq_trans with b; [exact EQ|] - | |- eq ?y a => apply eq_trans with b; [|exact (eq_sym EQ)] - | _ => idtac - end. - -Ltac propagate_eq := abstraction; clear; match goal with - (* the abstraction tactic leaves equality facts in head position...*) - | |- eq ?a ?b -> _ => - let EQ := fresh "EQ" in (intro EQ; do_eq a b EQ; clear EQ); - propagate_eq - | _ => idtac -end. - -Ltac do_lt x y LT := match goal with - (* LT *) - | |- lt x y -> _ => intros _; do_lt x y LT - | |- lt y ?z -> _ => let H := fresh "H" in - (intro H; generalize (lt_trans LT H); intro); do_lt x y LT - | |- lt ?z x -> _ => let H := fresh "H" in - (intro H; generalize (lt_trans H LT); intro); do_lt x y LT - | |- lt _ _ -> _ => intro; do_lt x y LT - (* GE *) - | |- ~lt y x -> _ => intros _; do_lt x y LT - | |- ~lt x ?z -> _ => let H := fresh "H" in - (intro H; generalize (le_lt_trans H LT); intro); do_lt x y LT - | |- ~lt ?z y -> _ => let H := fresh "H" in - (intro H; generalize (lt_le_trans LT H); intro); do_lt x y LT - | |- ~lt _ _ -> _ => intro; do_lt x y LT - | _ => idtac - end. - -Definition hide_lt := lt. - -Ltac propagate_lt := abstraction; match goal with - (* when no [=] remains, the abstraction tactic leaves [<] facts first. *) - | |- lt ?x ?y -> _ => - let LT := fresh "LT" in (intro LT; do_lt x y LT; - change (hide_lt x y) in LT); - propagate_lt - | _ => unfold hide_lt in * -end. - -Ltac order := - intros; - propagate_eq; - propagate_lt; - auto; - propagate_lt; - eauto. - -Ltac false_order := elimtype False; order. - - Lemma gt_not_eq : forall x y, lt y x -> ~ eq x y. - Proof. - order. - Qed. - - Lemma eq_not_lt : forall x y : t, eq x y -> ~ lt x y. - Proof. - order. - Qed. - - Hint Resolve gt_not_eq eq_not_lt. - - Lemma eq_not_gt : forall x y : t, eq x y -> ~ lt y x. - Proof. - order. - Qed. - - Lemma lt_not_gt : forall x y : t, lt x y -> ~ lt y x. - Proof. - order. - Qed. - - Hint Resolve eq_not_gt lt_antirefl lt_not_gt. - - Lemma elim_compare_eq : - forall x y : t, - eq x y -> exists H : eq x y, compare x y = EQ _ H. - Proof. - intros; case (compare x y); intros H'; try solve [false_order]. - exists H'; auto. - Qed. - - Lemma elim_compare_lt : - forall x y : t, - lt x y -> exists H : lt x y, compare x y = LT _ H. - Proof. - intros; case (compare x y); intros H'; try solve [false_order]. - exists H'; auto. - Qed. - - Lemma elim_compare_gt : - forall x y : t, - lt y x -> exists H : lt y x, compare x y = GT _ H. - Proof. - intros; case (compare x y); intros H'; try solve [false_order]. - exists H'; auto. - Qed. - - Ltac elim_comp := - match goal with - | |- ?e => match e with - | context ctx [ compare ?a ?b ] => - let H := fresh in - (destruct (compare a b) as [H|H|H]; - try solve [ intros; false_order]) - end - end. - - Ltac elim_comp_eq x y := - elim (elim_compare_eq (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - - Ltac elim_comp_lt x y := - elim (elim_compare_lt (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - - Ltac elim_comp_gt x y := - elim (elim_compare_gt (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - - (** For compatibility reasons *) - Definition eq_dec := eq_dec. - - Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. - Proof. - intros; elim (compare x y); [ left | right | right ]; auto. - Defined. - - Definition eqb x y : bool := if eq_dec x y then true else false. - - Lemma eqb_alt : - forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. - Proof. - unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto. - Qed. - -(* Specialization of resuts about lists modulo. *) - -Section ForNotations. - -Notation In:=(InA eq). -Notation Inf:=(lelistA lt). -Notation Sort:=(sort lt). -Notation NoDup:=(NoDupA eq). - -Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. -Proof. exact (InA_eqA eq_sym eq_trans). Qed. - -Lemma ListIn_In : forall l x, List.In x l -> In x l. -Proof. exact (In_InA eq_refl). Qed. - -Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l. -Proof. exact (InfA_ltA lt_trans). Qed. - -Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l. -Proof. exact (InfA_eqA eq_lt). 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_refl eq_sym lt_trans lt_eq eq_lt). Qed. - -Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l. -Proof. exact (@In_InfA t lt). Qed. - -Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l. -Proof. exact (InA_InfA eq_refl (ltA:=lt)). Qed. - -Lemma Inf_alt : - forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)). -Proof. exact (InfA_alt eq_refl eq_sym lt_trans lt_eq eq_lt). Qed. - -Lemma Sort_NoDup : forall l, Sort l -> NoDup l. -Proof. exact (SortA_NoDupA eq_refl eq_sym lt_trans lt_not_eq lt_eq eq_lt) . Qed. - -End ForNotations. - -Hint Resolve ListIn_In Sort_NoDup Inf_lt. -Hint Immediate In_eq Inf_lt. - -End OrderedTypeFacts. - -Module KeyOrderedType(O:OrderedType). - Import O. - Module MO:=OrderedTypeFacts(O). - Import MO. - - Section Elt. - Variable elt : Type. - Notation key:=t. - - Definition eqk (p p':key*elt) := eq (fst p) (fst p'). - Definition eqke (p p':key*elt) := - eq (fst p) (fst p') /\ (snd p) = (snd p'). - Definition ltk (p p':key*elt) := lt (fst p) (fst p'). - - Hint Unfold eqk eqke ltk. - Hint Extern 2 (eqke ?a ?b) => split. - - (* eqke is stricter than eqk *) - - Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. - Proof. - unfold eqk, eqke; intuition. - Qed. - - (* ltk ignore the second components *) - - Lemma ltk_right_r : forall x k e e', ltk x (k,e) -> ltk x (k,e'). - Proof. auto. Qed. - - Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. - Proof. auto. Qed. - Hint Immediate ltk_right_r ltk_right_l. - - (* eqk, eqke are equalities, ltk is a strict order *) - - Lemma eqk_refl : forall e, eqk e e. - Proof. auto. Qed. - - Lemma eqke_refl : forall e, eqke e e. - Proof. auto. Qed. - - Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. - Proof. auto. Qed. - - Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. - Proof. unfold eqke; intuition. Qed. - - Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. - Proof. eauto. Qed. - - Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. - Proof. - unfold eqke; intuition; [ eauto | congruence ]. - Qed. - - Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''. - Proof. eauto. Qed. - - Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. - Proof. unfold eqk, ltk; auto. Qed. - - Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. - Proof. - unfold eqke, ltk; intuition; simpl in *; subst. - exact (lt_not_eq H H1). - Qed. - - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. - Hint Immediate eqk_sym eqke_sym. - - (* Additionnal facts *) - - Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. - Proof. - unfold eqk, ltk; simpl; auto. - Qed. - - Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''. - Proof. eauto. Qed. - - Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''. - Proof. - intros (k,e) (k',e') (k'',e''). - unfold ltk, eqk; simpl; eauto. - Qed. - Hint Resolve eqk_not_ltk. - Hint Immediate ltk_eqk eqk_ltk. - - Lemma InA_eqke_eqk : - forall x m, InA eqke x m -> InA eqk x m. - Proof. - unfold eqke; induction 1; intuition. - Qed. - Hint Resolve InA_eqke_eqk. - - Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). - Definition In k m := exists e:elt, MapsTo k e m. - Notation Sort := (sort ltk). - Notation Inf := (lelistA ltk). - - Hint Unfold MapsTo In. - - (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) - - Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. - Proof. - firstorder. - exists x; auto. - induction H. - destruct y. - exists e; auto. - destruct IHInA as [e H0]. - exists e; auto. - Qed. - - Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. - Proof. - intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto. - Qed. - - Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. - Proof. - destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. - Qed. - - Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. - Proof. exact (InfA_eqA eqk_ltk). Qed. - - Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. - Proof. exact (InfA_ltA ltk_trans). Qed. - - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. - - Lemma Sort_Inf_In : - forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. - Proof. - exact (SortA_InfA_InA eqk_refl eqk_sym ltk_trans ltk_eqk eqk_ltk). - Qed. - - Lemma Sort_Inf_NotIn : - forall l k e, Sort l -> Inf (k,e) l -> ~In k l. - Proof. - intros; red; intros. - destruct H1 as [e' H2]. - elim (@ltk_not_eqk (k,e) (k,e')). - eapply Sort_Inf_In; eauto. - red; simpl; auto. - Qed. - - Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. - Proof. - exact (SortA_NoDupA eqk_refl eqk_sym ltk_trans ltk_not_eqk ltk_eqk eqk_ltk). - Qed. - - Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. - Proof. - inversion 1; intros; eapply Sort_Inf_In; eauto. - Qed. - - Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> - ltk e e' \/ eqk e e'. - Proof. - inversion_clear 2; auto. - left; apply Sort_In_cons_1 with l; auto. - Qed. - - Lemma Sort_In_cons_3 : - forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. - Proof. - inversion_clear 1; red; intros. - destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)). - Qed. - - Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. - Proof. - inversion 1. - inversion_clear H0; eauto. - destruct H1; simpl in *; intuition. - Qed. - - Lemma In_inv_2 : forall k k' e e' l, - InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. - Proof. - inversion_clear 1; compute in H0; intuition. - Qed. - - Lemma In_inv_3 : forall x x' l, - InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. - Proof. - inversion_clear 1; compute in H0; intuition. - Qed. - - End Elt. - - Hint Unfold eqk eqke ltk. - Hint Extern 2 (eqke ?a ?b) => split. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. - Hint Immediate eqk_sym eqke_sym. - Hint Resolve eqk_not_ltk. - Hint Immediate ltk_eqk eqk_ltk. - Hint Resolve InA_eqke_eqk. - Hint Unfold MapsTo In. - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. - Hint Resolve Sort_Inf_NotIn. - Hint Resolve In_inv_2 In_inv_3. - -End KeyOrderedType. - - diff --git a/theories/FSets/OrderedTypeAlt.v b/theories/FSets/OrderedTypeAlt.v deleted file mode 100644 index 9d179995..00000000 --- a/theories/FSets/OrderedTypeAlt.v +++ /dev/null @@ -1,128 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> comparison. - - Infix "?=" := compare (at level 70, no associativity). - - Parameter compare_sym : - forall x y, (y?=x) = CompOpp (x?=y). - Parameter compare_trans : - forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. - -End OrderedTypeAlt. - -(** From this new presentation to the original one. *) - -Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType. - Import O. - - Definition t := t. - - Definition eq x y := (x?=y) = Eq. - Definition lt x y := (x?=y) = Lt. - - Lemma eq_refl : forall x, eq x x. - Proof. - intro x. - unfold eq. - assert (H:=compare_sym x x). - destruct (x ?= x); simpl in *; try discriminate; auto. - Qed. - - Lemma eq_sym : forall x y, eq x y -> eq y x. - Proof. - unfold eq; intros. - rewrite compare_sym. - rewrite H; simpl; auto. - Qed. - - Definition eq_trans := (compare_trans Eq). - - Definition lt_trans := (compare_trans Lt). - - Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. - Proof. - unfold eq, lt; intros. - rewrite H; discriminate. - Qed. - - Definition compare : forall x y, Compare lt eq x y. - Proof. - intros. - case_eq (x ?= y); intros. - apply EQ; auto. - apply LT; auto. - apply GT; red. - rewrite compare_sym; rewrite H; auto. - Defined. - - Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. - Proof. - intros; unfold eq. - case (x ?= y); [ left | right | right ]; auto; discriminate. - Defined. - -End OrderedType_from_Alt. - -(** From the original presentation to this alternative one. *) - -Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt. - Import O. - Module MO:=OrderedTypeFacts(O). - Import MO. - - Definition t := t. - - Definition compare x y := match compare x y with - | LT _ => Lt - | EQ _ => Eq - | GT _ => Gt - end. - - Infix "?=" := compare (at level 70, no associativity). - - Lemma compare_sym : - forall x y, (y?=x) = CompOpp (x?=y). - Proof. - intros x y; unfold compare. - destruct O.compare; elim_comp; simpl; auto. - Qed. - - Lemma compare_trans : - forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. - Proof. - intros c x y z. - destruct c; unfold compare; - do 2 (destruct O.compare; intros; try discriminate); - elim_comp; auto. - Qed. - -End OrderedType_to_Alt. - - diff --git a/theories/FSets/OrderedTypeEx.v b/theories/FSets/OrderedTypeEx.v deleted file mode 100644 index 03e3ab83..00000000 --- a/theories/FSets/OrderedTypeEx.v +++ /dev/null @@ -1,269 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> Prop. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Parameter compare : forall x y : t, Compare lt eq x y. - Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }. -End UsualOrderedType. - -(** a [UsualOrderedType] is in particular an [OrderedType]. *) - -Module UOT_to_OT (U:UsualOrderedType) <: OrderedType := U. - -(** [nat] is an ordered type with respect to the usual order on natural numbers. *) - -Module Nat_as_OT <: UsualOrderedType. - - Definition t := nat. - - Definition eq := @eq nat. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - - Definition lt := lt. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. unfold lt in |- *; intros; apply lt_trans with y; auto. Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. unfold lt, eq in |- *; intros; omega. Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - Proof. - intros; case (lt_eq_lt_dec x y). - simple destruct 1; intro. - constructor 1; auto. - constructor 2; auto. - intro; constructor 3; auto. - Defined. - - Definition eq_dec := eq_nat_dec. - -End Nat_as_OT. - - -(** [Z] is an ordered type with respect to the usual order on integers. *) - -Open Local Scope Z_scope. - -Module Z_as_OT <: UsualOrderedType. - - Definition t := Z. - Definition eq := @eq Z. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - - Definition lt (x y:Z) := (x y x ~ x=y. - Proof. intros; omega. Qed. - - Definition compare : forall x y, Compare lt eq x y. - Proof. - intros x y; case_eq (x ?= y); intros. - apply EQ; unfold eq; apply Zcompare_Eq_eq; auto. - apply LT; unfold lt, Zlt; auto. - apply GT; unfold lt, Zlt; rewrite <- Zcompare_Gt_Lt_antisym; auto. - Defined. - - Definition eq_dec := Z_eq_dec. - -End Z_as_OT. - -(** [positive] is an ordered type with respect to the usual order on natural numbers. *) - -Open Local Scope positive_scope. - -Module Positive_as_OT <: UsualOrderedType. - Definition t:=positive. - Definition eq:=@eq positive. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - - Definition lt p q:= (p ?= q) Eq = Lt. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. - unfold lt; intros x y z. - change ((Zpos x < Zpos y)%Z -> (Zpos y < Zpos z)%Z -> (Zpos x < Zpos z)%Z). - omega. - Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros; intro. - rewrite H0 in H. - unfold lt in H. - rewrite Pcompare_refl in H; discriminate. - Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - Proof. - intros x y. - case_eq ((x ?= y) Eq); intros. - apply EQ; apply Pcompare_Eq_eq; auto. - apply LT; unfold lt; auto. - apply GT; unfold lt. - replace Eq with (CompOpp Eq); auto. - rewrite <- Pcompare_antisym; rewrite H; auto. - Defined. - - Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. - Proof. - intros; unfold eq; decide equality. - Defined. - -End Positive_as_OT. - - -(** [N] is an ordered type with respect to the usual order on natural numbers. *) - -Open Local Scope positive_scope. - -Module N_as_OT <: UsualOrderedType. - Definition t:=N. - Definition eq:=@eq N. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - - Definition lt p q:= Nleb q p = false. - - Definition lt_trans := Nltb_trans. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros; intro. - rewrite H0 in H. - unfold lt in H. - rewrite Nleb_refl in H; discriminate. - Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - Proof. - intros x y. - case_eq ((x ?= y)%N); intros. - apply EQ; apply Ncompare_Eq_eq; auto. - apply LT; unfold lt; auto. - generalize (Nleb_Nle y x). - unfold Nle; rewrite <- Ncompare_antisym. - destruct (x ?= y)%N; simpl; try discriminate. - clear H; intros H. - destruct (Nleb y x); intuition. - apply GT; unfold lt. - generalize (Nleb_Nle x y). - unfold Nle; destruct (x ?= y)%N; simpl; try discriminate. - destruct (Nleb x y); intuition. - Defined. - - Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. - Proof. - intros. unfold eq. decide equality. apply Positive_as_OT.eq_dec. - Defined. - -End N_as_OT. - - -(** From two ordered types, we can build a new OrderedType - over their cartesian product, using the lexicographic order. *) - -Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. - Module MO1:=OrderedTypeFacts(O1). - Module MO2:=OrderedTypeFacts(O2). - - Definition t := prod O1.t O2.t. - - Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y). - - Definition lt x y := - O1.lt (fst x) (fst y) \/ - (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)). - - Lemma eq_refl : forall x : t, eq x x. - Proof. - intros (x1,x2); red; simpl; auto. - Qed. - - Lemma eq_sym : forall x y : t, eq x y -> eq y x. - Proof. - intros (x1,x2) (y1,y2); unfold eq; simpl; intuition. - Qed. - - Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - Proof. - intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto. - Qed. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. - intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition. - left; eauto. - left; eapply MO1.lt_eq; eauto. - left; eapply MO1.eq_lt; eauto. - right; split; eauto. - Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros (x1,x2) (y1,y2); unfold eq, lt; simpl; intuition. - apply (O1.lt_not_eq H0 H1). - apply (O2.lt_not_eq H3 H2). - Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - intros (x1,x2) (y1,y2). - destruct (O1.compare x1 y1). - apply LT; unfold lt; auto. - destruct (O2.compare x2 y2). - apply LT; unfold lt; auto. - apply EQ; unfold eq; auto. - apply GT; unfold lt; auto. - apply GT; unfold lt; auto. - Defined. - - Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. - Proof. - intros; elim (compare x y); intro H; [ right | left | right ]; auto. - auto using lt_not_eq. - assert (~ eq y x); auto using lt_not_eq, eq_sym. - Defined. - -End PairOrderedType. - diff --git a/theories/FSets/vo.itarget b/theories/FSets/vo.itarget new file mode 100644 index 00000000..0e7c11fb --- /dev/null +++ b/theories/FSets/vo.itarget @@ -0,0 +1,21 @@ +FMapAVL.vo +FMapFacts.vo +FMapFullAVL.vo +FMapInterface.vo +FMapList.vo +FMapPositive.vo +FMaps.vo +FMapWeakList.vo +FSetCompat.vo +FSetAVL.vo +FSetPositive.vo +FSetBridge.vo +FSetDecide.vo +FSetEqProperties.vo +FSetFacts.vo +FSetInterface.vo +FSetList.vo +FSetProperties.vo +FSets.vo +FSetToFiniteSet.vo +FSetWeakList.vo diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 0163c01c..6040f58b 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -6,12 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Datatypes.v 11735 2009-01-02 17:22:31Z herbelin $ i*) +(*i $Id$ i*) Set Implicit Arguments. Require Import Notations. Require Import Logic. +Declare ML Module "nat_syntax_plugin". + (** [unit] is a singleton datatype with sole inhabitant [tt] *) @@ -72,6 +74,16 @@ Hint Resolve andb_true_intro: bool. Inductive eq_true : bool -> Prop := is_eq_true : eq_true true. +Hint Constructors eq_true : eq_true. + +(** Another way of interpreting booleans as propositions *) + +Definition is_true b := b = true. + +(** [is_true] can be activated as a coercion by + (Local) Coercion is_true : bool >-> Prop. +*) + (** Additional rewriting lemmas about [eq_true] *) Lemma eq_true_ind_r : @@ -94,7 +106,7 @@ Defined. (** [nat] is the datatype of natural numbers built from [O] and successor [S]; note that the constructor name is the letter O. - Numbers in [nat] can be denoted using a decimal notation; + Numbers in [nat] can be denoted using a decimal notation; e.g. [3%nat] abbreviates [S (S (S O))] *) Inductive nat : Set := @@ -114,8 +126,8 @@ Inductive Empty_set : Set :=. sole inhabitant is denoted [refl_identity A a] *) Inductive identity (A:Type) (a:A) : A -> Type := - refl_identity : identity (A:=A) a a. -Hint Resolve refl_identity: core. + identity_refl : identity a a. +Hint Resolve identity_refl: core. Implicit Arguments identity_ind [A]. Implicit Arguments identity_rec [A]. @@ -162,7 +174,7 @@ Section projections. Definition snd (p:A * B) := match p with | (x, y) => y end. -End projections. +End projections. Hint Resolve pair inl inr: core. @@ -177,13 +189,13 @@ Lemma injective_projections : fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2. Proof. destruct p1; destruct p2; simpl in |- *; intros Hfst Hsnd. - rewrite Hfst; rewrite Hsnd; reflexivity. + rewrite Hfst; rewrite Hsnd; reflexivity. Qed. -Definition prod_uncurry (A B C:Type) (f:prod A B -> C) +Definition prod_uncurry (A B C:Type) (f:prod A B -> C) (x:A) (y:B) : C := f (pair x y). -Definition prod_curry (A B C:Type) (f:A -> B -> C) +Definition prod_curry (A B C:Type) (f:A -> B -> C) (p:prod A B) : C := match p with | pair x y => f x y end. @@ -202,11 +214,84 @@ Definition CompOpp (r:comparison) := | Gt => Lt end. +Lemma CompOpp_involutive : forall c, CompOpp (CompOpp c) = c. +Proof. + destruct c; reflexivity. +Qed. + +Lemma CompOpp_inj : forall c c', CompOpp c = CompOpp c' -> c = c'. +Proof. + destruct c; destruct c'; auto; discriminate. +Qed. + +Lemma CompOpp_iff : forall c c', CompOpp c = c' <-> c = CompOpp c'. +Proof. + split; intros; apply CompOpp_inj; rewrite CompOpp_involutive; auto. +Qed. + +(** The [CompSpec] inductive will be used to relate a [compare] function + (returning a comparison answer) and some equality and order predicates. + Interest: [CompSpec] behave nicely with [case] and [destruct]. *) + +Inductive CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop := + | CompEq : eq x y -> CompSpec eq lt x y Eq + | CompLt : lt x y -> CompSpec eq lt x y Lt + | CompGt : lt y x -> CompSpec eq lt x y Gt. +Hint Constructors CompSpec. + +(** For having clean interfaces after extraction, [CompSpec] is declared + in Prop. For some situations, it is nonetheless useful to have a + version in Type. Interestingly, these two versions are equivalent. +*) + +Inductive CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type := + | CompEqT : eq x y -> CompSpecT eq lt x y Eq + | CompLtT : lt x y -> CompSpecT eq lt x y Lt + | CompGtT : lt y x -> CompSpecT eq lt x y Gt. +Hint Constructors CompSpecT. + +Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c, + CompSpec eq lt x y c -> CompSpecT eq lt x y c. +Proof. + destruct c; intros H; constructor; inversion_clear H; auto. +Defined. + (** Identity *) Definition ID := forall A:Type, A -> A. Definition id : ID := fun A x => x. +(** Polymorphic lists and some operations *) + +Inductive list (A : Type) : Type := + | nil : list A + | cons : A -> list A -> list A. + +Implicit Arguments nil [A]. +Infix "::" := cons (at level 60, right associativity) : list_scope. +Delimit Scope list_scope with list. +Bind Scope list_scope with list. + +Local Open Scope list_scope. + +Definition length (A : Type) : list A -> nat := + fix length l := + match l with + | nil => O + | _ :: l' => S (length l') + end. + +(** Concatenation of two lists *) + +Definition app (A : Type) : list A -> list A -> list A := + fix app l m := + match l with + | nil => m + | a :: l1 => a :: app l1 m + end. + +Infix "++" := app (right associativity, at level 60) : list_scope. + (* begin hide *) (* Compatibility *) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index ae79744f..4fca1d1d 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Logic.v 11735 2009-01-02 17:22:31Z herbelin $ i*) +(*i $Id$ i*) Set Implicit Arguments. @@ -112,6 +112,16 @@ Proof. intros; tauto. Qed. +Theorem and_comm : forall A B : Prop, A /\ B <-> B /\ A. +Proof. +intros; tauto. +Qed. + +Theorem and_assoc : forall A B C : Prop, (A /\ B) /\ C <-> A /\ B /\ C. +Proof. +intros; tauto. +Qed. + Theorem or_cancel_l : forall A B C : Prop, (B -> ~ A) -> (C -> ~ A) -> ((A \/ B <-> A \/ C) <-> (B <-> C)). Proof. @@ -124,6 +134,16 @@ Proof. intros; tauto. Qed. +Theorem or_comm : forall A B : Prop, (A \/ B) <-> (B \/ A). +Proof. +intros; tauto. +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, @@ -243,7 +263,7 @@ End universal_quantification. [A] which is true of [x] is also true of [y] *) Inductive eq (A:Type) (x:A) : A -> Prop := - refl_equal : x = x :>A + eq_refl : x = x :>A where "x = y :> A" := (@eq A x y) : type_scope. @@ -251,11 +271,13 @@ Notation "x = y" := (x = y :>_) : type_scope. Notation "x <> y :> T" := (~ x = y :>T) : type_scope. Notation "x <> y" := (x <> y :>_) : type_scope. +Implicit Arguments eq [ [A] ]. + Implicit Arguments eq_ind [A]. Implicit Arguments eq_rec [A]. Implicit Arguments eq_rect [A]. -Hint Resolve I conj or_introl or_intror refl_equal: core. +Hint Resolve I conj or_introl or_intror eq_refl: core. Hint Resolve ex_intro ex_intro2: core. Section Logic_lemmas. @@ -271,17 +293,17 @@ Section Logic_lemmas. Variable f : A -> B. Variables x y z : A. - Theorem sym_eq : x = y -> y = x. + Theorem eq_sym : x = y -> y = x. Proof. destruct 1; trivial. Defined. - Opaque sym_eq. + Opaque eq_sym. - Theorem trans_eq : x = y -> y = z -> x = z. + Theorem eq_trans : x = y -> y = z -> x = z. Proof. destruct 2; trivial. Defined. - Opaque trans_eq. + Opaque eq_trans. Theorem f_equal : x = y -> f x = f y. Proof. @@ -289,30 +311,26 @@ Section Logic_lemmas. Defined. Opaque f_equal. - Theorem sym_not_eq : x <> y -> y <> x. + Theorem not_eq_sym : x <> y -> y <> x. Proof. red in |- *; intros h1 h2; apply h1; destruct h2; trivial. Qed. - Definition sym_equal := sym_eq. - Definition sym_not_equal := sym_not_eq. - Definition trans_equal := trans_eq. - End equality. 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 sym_eq with (1 := H0); assumption. + intros A x P H y H0; elim eq_sym with (1 := H0); assumption. Defined. Definition eq_rec_r : forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y = x -> P y. - intros A x P H y H0; elim sym_eq with (1 := H0); assumption. + intros A x P H y H0; elim eq_sym with (1 := H0); assumption. Defined. Definition eq_rect_r : forall (A:Type) (x:A) (P:A -> Type), P x -> forall y:A, y = x -> P y. - intros A x P H y H0; elim sym_eq with (1 := H0); assumption. + intros A x P H y H0; elim eq_sym with (1 := H0); assumption. Defined. End Logic_lemmas. @@ -349,7 +367,18 @@ Proof. destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity. Qed. -Hint Immediate sym_eq sym_not_eq: core. +(* Aliases *) + +Notation sym_eq := eq_sym (only parsing). +Notation trans_eq := eq_trans (only parsing). +Notation sym_not_eq := not_eq_sym (only parsing). + +Notation refl_equal := eq_refl (only parsing). +Notation sym_equal := eq_sym (only parsing). +Notation trans_equal := eq_trans (only parsing). +Notation sym_not_equal := not_eq_sym (only parsing). + +Hint Immediate eq_sym not_eq_sym: core. (** Basic definitions about relations and properties *) @@ -411,7 +440,7 @@ intros A x y z H1 H2. rewrite <- H2; exact H1. Qed. Declare Left Step eq_stepl. -Declare Right Step trans_eq. +Declare Right Step eq_trans. Lemma iff_stepl : forall A B C : Prop, (A <-> B) -> (A <-> C) -> (C <-> B). Proof. diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index c4e5f6c7..1333f354 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Logic_Type.v 10840 2008-04-23 21:29:34Z herbelin $ i*) +(*i $Id$ i*) (** This module defines type constructors for types in [Type] ([Datatypes.v] and [Logic.v] defined them for types in [Set]) *) @@ -28,23 +28,23 @@ Section identity_is_a_congruence. Variable f : A -> B. Variables x y z : A. - - Lemma sym_id : identity x y -> identity y x. + + Lemma identity_sym : identity x y -> identity y x. Proof. destruct 1; trivial. Defined. - Lemma trans_id : identity x y -> identity y z -> identity x z. + Lemma identity_trans : identity x y -> identity y z -> identity x z. Proof. destruct 2; trivial. Defined. - Lemma congr_id : identity x y -> identity (f x) (f y). + Lemma identity_congr : identity x y -> identity (f x) (f y). Proof. destruct 1; trivial. Defined. - Lemma sym_not_id : notT (identity x y) -> notT (identity y x). + Lemma not_identity_sym : notT (identity x y) -> notT (identity y x). Proof. red in |- *; intros H H'; apply H; destruct H'; trivial. Qed. @@ -53,17 +53,22 @@ End identity_is_a_congruence. Definition identity_ind_r : forall (A:Type) (a:A) (P:A -> Prop), P a -> forall y:A, identity y a -> P y. - intros A x P H y H0; case sym_id with (1 := H0); trivial. + intros A x P H y H0; case identity_sym with (1 := H0); trivial. Defined. Definition identity_rec_r : forall (A:Type) (a:A) (P:A -> Set), P a -> forall y:A, identity y a -> P y. - intros A x P H y H0; case sym_id with (1 := H0); trivial. + intros A x P H y H0; case identity_sym with (1 := H0); trivial. Defined. Definition identity_rect_r : forall (A:Type) (a:A) (P:A -> Type), P a -> forall y:A, identity y a -> P y. - intros A x P H y H0; case sym_id with (1 := H0); trivial. + intros A x P H y H0; case identity_sym with (1 := H0); trivial. Defined. -Hint Immediate sym_id sym_not_id: core v62. +Hint Immediate identity_sym not_identity_sym: core v62. + +Notation refl_id := identity_refl (only parsing). +Notation sym_id := identity_sym (only parsing). +Notation trans_id := identity_trans (only parsing). +Notation sym_not_id := not_identity_sym (only parsing). diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index 5f18edcd..0c628298 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Notations.v 12271 2009-08-11 10:29:45Z herbelin $ i*) +(*i $Id$ i*) (** These are the notations whose level and associativity are imposed by Coq *) diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 43b1f634..12a8f7a4 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Peano.v 11735 2009-01-02 17:22:31Z herbelin $ i*) +(*i $Id$ i*) (** The type [nat] of Peano natural numbers (built from [O] and [S]) is defined in [Datatypes.v] *) @@ -77,8 +77,7 @@ Definition IsSucc (n:nat) : Prop := Theorem O_S : forall n:nat, 0 <> S n. Proof. - unfold not; intros n H. - inversion H. + discriminate. Qed. Hint Resolve O_S: core. @@ -90,7 +89,7 @@ Hint Resolve n_Sn: core. (** Addition *) -Fixpoint plus (n m:nat) {struct n} : nat := +Fixpoint plus (n m:nat) : nat := match n with | O => m | S p => S (p + m) @@ -130,7 +129,7 @@ Notation plus_succ_r_reverse := plus_n_Sm (only parsing). (** Multiplication *) -Fixpoint mult (n m:nat) {struct n} : nat := +Fixpoint mult (n m:nat) : nat := match n with | O => 0 | S p => m + p * m @@ -161,7 +160,7 @@ Notation mult_succ_r_reverse := mult_n_Sm (only parsing). (** Truncated subtraction: [m-n] is [0] if [n>=m] *) -Fixpoint minus (n m:nat) {struct n} : nat := +Fixpoint minus (n m:nat) : nat := match n, m with | O, _ => n | S k, O => n diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 6492c948..685c7247 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Prelude.v 10064 2007-08-08 15:32:36Z msozeau $ i*) +(*i $Id$ i*) Require Export Notations. Require Export Logic. @@ -15,3 +15,12 @@ Require Export Specif. Require Export Peano. Require Export Coq.Init.Wf. Require Export Coq.Init.Tactics. +(* Initially available plugins + (+ nat_syntax_plugin loaded in Datatypes) *) +Declare ML Module "extraction_plugin". +Declare ML Module "cc_plugin". +Declare ML Module "ground_plugin". +Declare ML Module "dp_plugin". +Declare ML Module "recdef_plugin". +Declare ML Module "subtac_plugin". +Declare ML Module "xml_plugin". diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index c0f5c42a..7141f26c 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Specif.v 10923 2008-05-12 18:25:06Z herbelin $ i*) +(*i $Id$ i*) (** Basic specifications : sets that may contain logical information *) @@ -18,9 +18,9 @@ Require Import Logic. (** Subsets and Sigma-types *) -(** [(sig A P)], or more suggestively [{x:A | P x}], denotes the subset +(** [(sig A P)], or more suggestively [{x:A | P x}], denotes the subset of elements of the type [A] which satisfy the predicate [P]. - Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset + Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset of elements of the type [A] which satisfy both [P] and [Q]. *) Inductive sig (A:Type) (P:A -> Prop) : Type := @@ -29,7 +29,7 @@ Inductive sig (A:Type) (P:A -> Prop) : Type := Inductive sig2 (A:Type) (P Q:A -> Prop) : Type := exist2 : forall x:A, P x -> Q x -> sig2 P Q. -(** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. +(** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. Similarly for [(sigT2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *) Inductive sigT (A:Type) (P:A -> Type) : Type := @@ -123,7 +123,7 @@ Coercion sig_of_sigT : sigT >-> sig. Inductive sumbool (A B:Prop) : Set := | left : A -> {A} + {B} - | right : B -> {A} + {B} + | right : B -> {A} + {B} where "{ A } + { B }" := (sumbool A B) : type_scope. Add Printing If sumbool. @@ -133,7 +133,7 @@ Add Printing If sumbool. Inductive sumor (A:Type) (B:Prop) : Type := | inleft : A -> A + {B} - | inright : B -> A + {B} + | inright : B -> A + {B} where "A + { B }" := (sumor A B) : type_scope. Add Printing If sumor. @@ -148,50 +148,57 @@ Section Choice_lemmas. Variables R1 R2 : S -> Prop. Lemma Choice : - (forall x:S, sig (fun y:S' => R x y)) -> - sig (fun f:S -> S' => forall z:S, R z (f z)). + (forall x:S, {y:S' | R x y}) -> {f:S -> S' | forall z:S, R z (f z)}. Proof. intro H. - exists (fun z:S => match H z with - | exist y _ => y - end). + exists (fun z => proj1_sig (H z)). intro z; destruct (H z); trivial. Qed. Lemma Choice2 : - (forall x:S, sigT (fun y:S' => R' x y)) -> - sigT (fun f:S -> S' => forall z:S, R' z (f z)). + (forall x:S, {y:S' & R' x y}) -> {f:S -> S' & forall z:S, R' z (f z)}. Proof. intro H. - exists (fun z:S => match H z with - | existT y _ => y - end). + exists (fun z => projT1 (H z)). intro z; destruct (H z); trivial. Qed. Lemma bool_choice : (forall x:S, {R1 x} + {R2 x}) -> - sig - (fun f:S -> bool => - forall x:S, f x = true /\ R1 x \/ f x = false /\ R2 x). + {f:S -> bool | forall x:S, f x = true /\ R1 x \/ f x = false /\ R2 x}. Proof. intro H. - exists - (fun z:S => match H z with - | left _ => true - | right _ => false - end). + exists (fun z:S => if H z then true else false). intro z; destruct (H z); auto. Qed. End Choice_lemmas. - (** A result of type [(Exc A)] is either a normal value of type [A] or +Section Dependent_choice_lemmas. + + Variables X : Set. + Variable R : X -> X -> Prop. + + Lemma dependent_choice : + (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. + set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end). + exists f. + split. reflexivity. + induction n; simpl; apply proj2_sig. + Qed. + +End Dependent_choice_lemmas. + + + (** A result of type [(Exc A)] is either a normal value of type [A] or an [error] : [Inductive Exc [A:Type] : Type := value : A->(Exc A) | error : (Exc A)]. - It is implemented using the option type. *) + It is implemented using the option type. *) Definition Exc := option. Definition value := Some. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 48b4568d..3e860fd4 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -6,45 +6,52 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Tactics.v 13198 2010-06-25 22:36:20Z letouzey $ i*) +(*i $Id$ i*) Require Import Notations. Require Import Logic. +Require Import Specif. (** * Useful tactics *) -(** A tactic for proof by contradiction. With contradict H, +(** Ex falso quodlibet : a tactic for proving False instead of the current goal. + This is just a nicer name for tactics such as [elimtype False] + and other [cut False]. *) + +Ltac exfalso := elimtype False. + +(** A tactic for proof by contradiction. With contradict H, - H:~A |- B gives |- A - H:~A |- ~B gives H: B |- A - H: A |- B gives |- ~A - H: A |- ~B gives H: B |- ~A - H:False leads to a resolved subgoal. - Moreover, negations may be in unfolded forms, + Moreover, negations may be in unfolded forms, and A or B may live in Type *) Ltac contradict H := let save tac H := let x:=fresh in intro x; tac H; rename x into H - in - let negpos H := case H; clear H - in + in + let negpos H := case H; clear H + in let negneg H := save negpos H in - let pospos H := - let A := type of H in (elimtype False; revert H; try fold (~A)) + let pospos H := + let A := type of H in (exfalso; revert H; try fold (~A)) in let posneg H := save pospos H - in - let neg H := match goal with + in + let neg H := match goal with | |- (~_) => negneg H | |- (_->False) => negneg H | |- _ => negpos H - end in - let pos H := match goal with + end in + let pos H := match goal with | |- (~_) => posneg H | |- (_->False) => posneg H | |- _ => pospos H end in - match type of H with + match type of H with | (~_) => neg H | (_->False) => neg H | _ => (elim H;fail) || pos H @@ -52,20 +59,20 @@ Ltac contradict H := (* Transforming a negative goal [ H:~A |- ~B ] into a positive one [ B |- A ]*) -Ltac swap H := +Ltac swap H := idtac "swap is OBSOLETE: use contradict instead."; intro; apply H; clear H. (* To contradict an hypothesis without copying its type. *) -Ltac absurd_hyp H := +Ltac absurd_hyp H := idtac "absurd_hyp is OBSOLETE: use contradict instead."; - let T := type of H in + let T := type of H in absurd T. (* A useful complement to contradict. Here H:A while G allows to conclude ~A *) -Ltac false_hyp H G := +Ltac false_hyp H G := let T := type of H in absurd T; [ apply G | assumption ]. (* A case with no loss of information. *) @@ -76,13 +83,21 @@ Ltac case_eq x := generalize (refl_equal x); pattern x at -1; case x. Tactic Notation "destruct_with_eqn" constr(x) := destruct x as []_eqn. -Tactic Notation "destruct_with_eqn" ident(n) := +Tactic Notation "destruct_with_eqn" ident(n) := try intros until n; destruct n as []_eqn. Tactic Notation "destruct_with_eqn" ":" ident(H) constr(x) := destruct x as []_eqn:H. -Tactic Notation "destruct_with_eqn" ":" ident(H) ident(n) := +Tactic Notation "destruct_with_eqn" ":" ident(H) ident(n) := try intros until n; destruct n as []_eqn:H. +(** Break every hypothesis of a certain type *) + +Ltac destruct_all t := + match goal with + | x : t |- _ => destruct x; destruct_all t + | _ => idtac + end. + (* Rewriting in all hypothesis several times everywhere *) Tactic Notation "rewrite_all" constr(eq) := repeat rewrite eq in *. @@ -148,7 +163,7 @@ bapply lemma ltac:(fun H => destruct H as [_ H]; apply H in J). (** An experimental tactic simpler than auto that is useful for ending proofs "in one step" *) - + Ltac easy := let rec use_hyp H := match type of H with @@ -167,14 +182,42 @@ Ltac easy := solve [reflexivity | symmetry; trivial] || contradiction || (split; do_atom) - with do_ccl := trivial; repeat do_intro; do_atom in + with do_ccl := trivial with eq_true; repeat do_intro; do_atom in (use_hyps; do_ccl) || fail "Cannot solve this goal". Tactic Notation "now" tactic(t) := t; easy. (** A tactic to document or check what is proved at some point of a script *) + Ltac now_show c := change c. +(** Support for rewriting decidability statements *) + +Set Implicit Arguments. + +Lemma decide_left : forall (C:Prop) (decide:{C}+{~C}), + C -> forall P:{C}+{~C}->Prop, (forall H:C, P (left _ H)) -> P decide. +Proof. +intros; destruct decide. apply H0. contradiction. +Qed. + +Lemma decide_right : forall (C:Prop) (decide:{C}+{~C}), + ~C -> forall P:{C}+{~C}->Prop, (forall H:~C, P (right _ H)) -> P decide. +Proof. +intros; destruct decide. contradiction. apply H0. +Qed. + +Tactic Notation "decide" constr(lemma) "with" constr(H) := + let try_to_merge_hyps H := + try (clear H; intro H) || + (let H' := fresh H "bis" in intro H'; try clear H') || + (let H' := fresh in intro H'; try clear H') in + match type of H with + | ~ ?C => apply (decide_right lemma H); try_to_merge_hyps H + | ?C -> False => apply (decide_right lemma H); try_to_merge_hyps H + | _ => apply (decide_left lemma H); try_to_merge_hyps H + end. + (** Clear an hypothesis and its dependencies *) Tactic Notation "clear" "dependent" hyp(h) := diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index d3f8f1ab..3209860f 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Wf.v 11251 2008-07-24 08:28:40Z herbelin $ i*) +(*i $Id$ i*) (** * This module proves the validity of - well-founded recursion (also known as course of values) @@ -65,14 +65,14 @@ Section Well_founded. exact (fun P:A -> Prop => well_founded_induction_type P). Defined. -(** Well-founded fixpoints *) +(** Well-founded fixpoints *) Section FixPoint. Variable P : A -> Type. Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x. - Fixpoint Fix_F (x:A) (a:Acc x) {struct a} : P x := + Fixpoint Fix_F (x:A) (a:Acc x) : P x := F (fun (y:A) (h:R y x) => Fix_F (Acc_inv a h)). Scheme Acc_inv_dep := Induction for Acc Sort Prop. @@ -80,13 +80,13 @@ Section Well_founded. Lemma Fix_F_eq : forall (x:A) (r:Acc x), F (fun (y:A) (p:R y x) => Fix_F (x:=y) (Acc_inv r p)) = Fix_F (x:=x) r. - Proof. + Proof. destruct r using Acc_inv_dep; auto. Qed. Definition Fix (x:A) := Fix_F (Rwf x). - (** Proof that [well_founded_induction] satisfies the fixpoint equation. + (** Proof that [well_founded_induction] satisfies the fixpoint equation. It requires an extra property of the functional *) Hypothesis @@ -111,7 +111,7 @@ Section Well_founded. End FixPoint. -End Well_founded. +End Well_founded. (** Well-founded fixpoints over pairs *) @@ -120,7 +120,7 @@ Section Well_founded_2. Variables A B : Type. Variable R : A * B -> A * B -> Prop. - Variable P : A -> B -> Type. + Variable P : A -> B -> Type. Section FixPoint_2. @@ -129,8 +129,7 @@ Section Well_founded_2. forall (x:A) (x':B), (forall (y:A) (y':B), R (y, y') (x, x') -> P y y') -> P x x'. - Fixpoint Fix_F_2 (x:A) (x':B) (a:Acc R (x, x')) {struct a} : - P x x' := + Fixpoint Fix_F_2 (x:A) (x':B) (a:Acc R (x, x')) : P x x' := F (fun (y:A) (y':B) (h:R (y, y') (x, x')) => Fix_F_2 (x:=y) (x':=y') (Acc_inv a (y,y') h)). diff --git a/theories/Init/vo.itarget b/theories/Init/vo.itarget new file mode 100644 index 00000000..f53d55e7 --- /dev/null +++ b/theories/Init/vo.itarget @@ -0,0 +1,9 @@ +Datatypes.vo +Logic_Type.vo +Logic.vo +Notations.vo +Peano.vo +Prelude.vo +Specif.vo +Tactics.vo +Wf.vo diff --git a/theories/Lists/List.v b/theories/Lists/List.v index c015854e..f42dc7fa 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: List.v 12446 2009-10-29 21:43:06Z glondu $ i*) +(*i $Id$ i*) Require Import Le Gt Minus Min Bool. @@ -17,78 +17,47 @@ Set Implicit Arguments. (** * Basics: definition of polymorphic lists and some operations *) (******************************************************************) -(** ** Definitions *) +(** The definition of [list] is now in [Init/Datatypes], + as well as the definitions of [length] and [app] *) + +Open Scope list_scope. Section Lists. Variable A : Type. - Inductive list : Type := - | nil : list - | cons : A -> list -> list. - - Infix "::" := cons (at level 60, right associativity) : list_scope. + (** Head and tail *) - Open Scope list_scope. + Definition hd (default:A) (l:list A) := + match l with + | nil => default + | x :: _ => x + end. - (** Head and tail *) - Definition head (l:list) := + Definition hd_error (l:list A) := match l with | nil => error | x :: _ => value x end. - Definition hd (default:A) (l:list) := - match l with - | nil => default - | x :: _ => x - end. - - Definition tail (l:list) : list := + Definition tl (l:list A) := match l with | nil => nil | a :: m => m end. - (** Length of lists *) - Fixpoint length (l:list) : nat := - match l with - | nil => 0 - | _ :: m => S (length m) - end. - (** The [In] predicate *) - Fixpoint In (a:A) (l:list) {struct l} : Prop := + Fixpoint In (a:A) (l:list A) : Prop := match l with | nil => False | b :: m => b = a \/ In a m end. - - (** Concatenation of two lists *) - Fixpoint app (l m:list) {struct l} : list := - match l with - | nil => m - | a :: l1 => a :: app l1 m - end. - - Infix "++" := app (right associativity, at level 60) : list_scope. - End Lists. -(** Exporting list notations and tactics *) - -Implicit Arguments nil [A]. -Infix "::" := cons (at level 60, right associativity) : list_scope. -Infix "++" := app (right associativity, at level 60) : list_scope. - -Open Scope list_scope. - -Delimit Scope list_scope with list. - -Bind Scope list_scope with list. - -Arguments Scope list [type_scope]. +(* Keep these notations local to prevent conflicting notations *) +Local Notation "[ ]" := nil : list_scope. +Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) : list_scope. (** ** Facts about lists *) @@ -100,164 +69,172 @@ Section Facts. (** *** Genereric facts *) (** Discrimination *) - Theorem nil_cons : forall (x:A) (l:list A), nil <> x :: l. - Proof. + Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l. + Proof. intros; discriminate. Qed. (** Destruction *) - Theorem destruct_list : forall l : list A, {x:A & {tl:list A | l = x::tl}}+{l = nil}. + Theorem destruct_list : forall l : list A, {x:A & {tl:list A | l = x::tl}}+{l = []}. Proof. - induction l as [|a tl]. + induction l as [|a tail]. right; reflexivity. - left; exists a; exists tl; reflexivity. + left; exists a, tail; reflexivity. Qed. - + (** *** Head and tail *) - - Theorem head_nil : head (@nil A) = None. + + Theorem hd_error_nil : hd_error (@nil A) = None. Proof. simpl; reflexivity. Qed. - Theorem head_cons : forall (l : list A) (x : A), head (x::l) = Some x. + Theorem hd_error_cons : forall (l : list A) (x : A), hd_error (x::l) = Some x. Proof. intros; simpl; reflexivity. Qed. (************************) - (** *** Facts about [In] *) + (** *** Facts about [In] *) (************************) (** Characterization of [In] *) - + Theorem in_eq : forall (a:A) (l:list A), In a (a :: l). - Proof. - simpl in |- *; auto. + Proof. + simpl; auto. Qed. - + Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l). - Proof. - simpl in |- *; auto. + Proof. + simpl; auto. Qed. - Theorem in_nil : forall a:A, ~ In a nil. + Theorem in_nil : forall a:A, ~ In a []. Proof. - unfold not in |- *; intros a H; inversion_clear H. + unfold not; intros a H; inversion_clear H. Qed. - Lemma In_split : forall x (l:list A), In x l -> exists l1, exists l2, l = l1++x::l2. + Theorem in_split : forall x (l:list A), In x l -> exists l1, exists l2, l = l1++x::l2. Proof. induction l; simpl; destruct 1. subst a; auto. - exists (@nil A); exists l; auto. + exists [], l; auto. destruct (IHl H) as (l1,(l2,H0)). - exists (a::l1); exists l2; simpl; f_equal; auto. + exists (a::l1), l2; simpl; f_equal; auto. Qed. (** Inversion *) - Theorem in_inv : forall (a b:A) (l:list A), In b (a :: l) -> a = b \/ In b l. + Lemma in_inv : forall (a b:A) (l:list A), In b (a :: l) -> a = b \/ In b l. Proof. intros a b l H; inversion_clear H; auto. Qed. (** Decidability of [In] *) - Theorem In_dec : + Theorem in_dec : (forall x y:A, {x = y} + {x <> y}) -> forall (a:A) (l:list A), {In a l} + {~ In a l}. Proof. intro H; induction l as [| a0 l IHl]. right; apply in_nil. - destruct (H a0 a); simpl in |- *; auto. - destruct IHl; simpl in |- *; auto. - right; unfold not in |- *; intros [Hc1| Hc2]; auto. + destruct (H a0 a); simpl; auto. + destruct IHl; simpl; auto. + right; unfold not; intros [Hc1| Hc2]; auto. Defined. - (*************************) + (**************************) (** *** Facts about [app] *) - (*************************) + (**************************) (** Discrimination *) - Theorem app_cons_not_nil : forall (x y:list A) (a:A), nil <> x ++ a :: y. + Theorem app_cons_not_nil : forall (x y:list A) (a:A), [] <> x ++ a :: y. Proof. - unfold not in |- *. - destruct x as [| a l]; simpl in |- *; intros. + unfold not. + destruct x as [| a l]; simpl; intros. discriminate H. discriminate H. Qed. (** Concat with [nil] *) + Theorem app_nil_l : forall l:list A, [] ++ l = l. + Proof. + reflexivity. + Qed. - Theorem app_nil_end : forall l:list A, l = l ++ nil. - Proof. - induction l; simpl in |- *; auto. - rewrite <- IHl; auto. + Theorem app_nil_r : forall l:list A, l ++ [] = l. + Proof. + induction l; simpl; f_equal; auto. Qed. + (* begin hide *) + (* Deprecated *) + Theorem app_nil_end : forall (l:list A), l = l ++ []. + Proof. symmetry; apply app_nil_r. Qed. + (* end hide *) + (** [app] is associative *) - Theorem app_ass : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n. - Proof. - intros. induction l; simpl in |- *; auto. - now_show (a :: (l ++ m) ++ n = a :: l ++ m ++ n). - rewrite <- IHl; auto. + Theorem app_assoc : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n. + Proof. + intros l m n; induction l; simpl; f_equal; auto. Qed. - Hint Resolve app_ass. - Theorem ass_app : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n. - Proof. - auto using app_ass. + (* begin hide *) + (* Deprecated *) + Theorem app_assoc_reverse : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n. + Proof. + auto using app_assoc. Qed. + Hint Resolve app_assoc_reverse. + (* end hide *) - (** [app] commutes with [cons] *) + (** [app] commutes with [cons] *) Theorem app_comm_cons : forall (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y. Proof. auto. Qed. + (** Facts deduced from the result of a concatenation *) - - (** Facts deduced from the result of a concatenation *) - - Theorem app_eq_nil : forall l l':list A, l ++ l' = nil -> l = nil /\ l' = nil. + Theorem app_eq_nil : forall l l':list A, l ++ l' = [] -> l = [] /\ l' = []. Proof. - destruct l as [| x l]; destruct l' as [| y l']; simpl in |- *; auto. + destruct l as [| x l]; destruct l' as [| y l']; simpl; auto. intro; discriminate. intros H; discriminate H. Qed. Theorem app_eq_unit : forall (x y:list A) (a:A), - x ++ y = a :: nil -> x = nil /\ y = a :: nil \/ x = a :: nil /\ y = nil. + x ++ y = [a] -> x = [] /\ y = [a] \/ x = [a] /\ y = []. Proof. destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ]; - simpl in |- *. + simpl. intros a H; discriminate H. left; split; auto. right; split; auto. generalize H. - generalize (app_nil_end l); intros E. - rewrite <- E; auto. + generalize (app_nil_r l); intros E. + rewrite -> E; auto. intros. injection H. intro. - cut (nil = l ++ a0 :: l0); auto. + cut ([] = l ++ a0 :: l0); auto. intro. generalize (app_cons_not_nil _ _ _ H1); intro. elim H2. Qed. Lemma app_inj_tail : - forall (x y:list A) (a b:A), x ++ a :: nil = y ++ b :: nil -> x = y /\ a = b. + forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] -> x = y /\ a = b. Proof. induction x as [| x l IHl]; - [ destruct y as [| a l] | destruct y as [| a l0] ]; - simpl in |- *; auto. + [ destruct y as [| a l] | destruct y as [| a l0] ]; + simpl; auto. intros a b H. injection H. auto. @@ -266,12 +243,12 @@ Section Facts. generalize (app_cons_not_nil _ _ _ H0); destruct 1. intros a b H. injection H; intros. - cut (nil = l ++ a :: nil); auto. + 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). + destruct (IHl l0 a0 b H0). split; auto. rewrite <- H1; rewrite <- H2; reflexivity. Qed. @@ -285,9 +262,9 @@ Section Facts. Qed. Lemma in_app_or : forall (l m:list A) (a:A), In a (l ++ m) -> In a l \/ In a m. - Proof. + Proof. intros l m a. - elim l; simpl in |- *; auto. + elim l; simpl; auto. intros a0 y H H0. now_show ((a0 = a \/ In a y) \/ In a m). elim H0; auto. @@ -297,9 +274,9 @@ Section Facts. Qed. Lemma in_or_app : forall (l m:list A) (a:A), In a l \/ In a m -> In a (l ++ m). - Proof. + Proof. intros l m a. - elim l; simpl in |- *; intro H. + elim l; simpl; intro H. now_show (In a m). elim H; auto; intro H0. now_show (In a m). @@ -311,18 +288,23 @@ Section Facts. now_show (H = a \/ In a (y ++ m)). elim H2; auto. Qed. - + + Lemma in_app_iff : forall l l' (a:A), In a (l++l') <-> In a l \/ In a l'. + Proof. + split; auto using in_app_or, in_or_app. + Qed. + Lemma app_inv_head: - forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2. + forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2. Proof. induction l; simpl; auto; injection 1; auto. Qed. - + Lemma app_inv_tail: - forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2. + forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2. Proof. intros l l1 l2; revert l1 l2 l. - induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2]; + induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2]; simpl; auto; intros l H. absurd (length (x2 :: l2 ++ l) <= length l). simpl; rewrite app_length; auto with arith. @@ -335,10 +317,10 @@ Section Facts. End Facts. -Hint Resolve app_nil_end ass_app app_ass: datatypes v62. +Hint Resolve app_assoc app_assoc_reverse: datatypes v62. Hint Resolve app_comm_cons app_cons_not_nil: datatypes v62. Hint Immediate app_eq_nil: datatypes v62. -Hint Resolve app_eq_unit app_inj_tail: datatypes v62. +Hint Resolve app_eq_unit app_inj_tail: datatypes v62. Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes v62. @@ -359,7 +341,7 @@ Section Elts. match n, l with | O, x :: l' => x | O, other => default - | S m, nil => default + | S m, [] => default | S m, x :: t => nth m t default end. @@ -367,26 +349,26 @@ Section Elts. match n, l with | O, x :: l' => true | O, other => false - | S m, nil => false + | S m, [] => false | S m, x :: t => nth_ok m t default end. Lemma nth_in_or_default : forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}. (* Realizer nth_ok. Program_all. *) - Proof. + Proof. intros n l d; generalize n; induction l; intro n0. right; case n0; trivial. - case n0; simpl in |- *. + case n0; simpl. auto. - intro n1; elim (IHl n1); auto. + intro n1; elim (IHl n1); auto. Qed. Lemma nth_S_cons : forall (n:nat) (l:list A) (d a:A), In (nth n l d) l -> In (nth (S n) (a :: l) d) (a :: l). - Proof. - simpl in |- *; auto. + Proof. + simpl; auto. Qed. Fixpoint nth_error (l:list A) (n:nat) {struct n} : Exc A := @@ -402,13 +384,19 @@ Section Elts. | None => default end. + Lemma nth_default_eq : + forall n l (d:A), nth_default d l n = nth n l d. + Proof. + unfold nth_default; induction n; intros [ | ] ?; simpl; auto. + Qed. + Lemma nth_In : forall (n:nat) (l:list A) (d:A), n < length l -> In (nth n l d) l. Proof. - unfold lt in |- *; induction n as [| n hn]; simpl in |- *. - destruct l; simpl in |- *; [ inversion 2 | auto ]. - destruct l as [| a l hl]; simpl in |- *. + 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. Qed. @@ -420,7 +408,7 @@ Section Elts. apply IHl; auto with arith. Qed. - Lemma nth_indep : + 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. @@ -428,7 +416,7 @@ Section Elts. destruct n; simpl; auto with arith. Qed. - Lemma app_nth1 : + Lemma app_nth1 : forall l l' d n, n < length l -> nth n (l++l') d = nth n l d. Proof. induction l. @@ -439,7 +427,7 @@ Section Elts. intros; rewrite IHl; auto with arith. Qed. - Lemma app_nth2 : + 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. @@ -461,53 +449,49 @@ Section Elts. (** ** Remove *) (*****************) - Section Remove. + Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}. - Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}. - - Fixpoint remove (x : A) (l : list A){struct l} : list A := - match l with - | nil => nil - | y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl) - end. - - Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l). - Proof. - induction l as [|x l]; auto. - intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx]. - apply IHl. - unfold not; intro HF; simpl in HF; destruct HF; auto. - apply (IHl y); assumption. - Qed. - - End Remove. + Fixpoint remove (x : A) (l : list A) : list A := + match l with + | [] => [] + | y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl) + end. + + Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l). + Proof. + induction l as [|x l]; auto. + intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx]. + apply IHl. + unfold not; intro HF; simpl in HF; destruct HF; auto. + apply (IHl y); assumption. + Qed. (******************************) (** ** Last element of a list *) (******************************) - (** [last l d] returns the last element of the list [l], + (** [last l d] returns the last element of the list [l], or the default value [d] if [l] is empty. *) - Fixpoint last (l:list A) (d:A) {struct l} : A := - match l with - | nil => d - | a :: nil => a + Fixpoint last (l:list A) (d:A) : A := + match l with + | [] => d + | [a] => a | a :: l => last l d end. (** [removelast l] remove the last element of [l] *) - Fixpoint removelast (l:list A) {struct l} : list A := - match l with - | nil => nil - | a :: nil => nil + Fixpoint removelast (l:list A) : list A := + match l with + | [] => [] + | [a] => [] | a :: l => a :: removelast l end. - - Lemma app_removelast_last : - forall l d, l<>nil -> l = removelast l ++ (last l d :: nil). + + Lemma app_removelast_last : + forall l d, l <> [] -> l = removelast l ++ [last l d]. Proof. induction l. destruct 1; auto. @@ -515,27 +499,27 @@ Section Elts. destruct l; auto. pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate. Qed. - - Lemma exists_last : - forall l, l<>nil -> { l' : (list A) & { a : A | l = l'++a::nil}}. - Proof. + + Lemma exists_last : + forall l, l <> [] -> { l' : (list A) & { a : A | l = l' ++ [a]}}. + Proof. induction l. destruct 1; auto. intros _. destruct l. - exists (@nil A); exists a; auto. + exists [], a; auto. destruct IHl as [l' (a',H)]; try discriminate. rewrite H. - exists (a::l'); exists a'; auto. + exists (a::l'), a'; auto. Qed. - Lemma removelast_app : - forall l l', l' <> nil -> removelast (l++l') = l ++ removelast l'. + Lemma removelast_app : + forall l l', l' <> [] -> removelast (l++l') = l ++ removelast l'. Proof. induction l. simpl; auto. simpl; intros. - assert (l++l' <> nil). + assert (l++l' <> []). destruct l. simpl; auto. simpl; discriminate. @@ -543,32 +527,30 @@ Section Elts. destruct (l++l'); [elim H0; auto|f_equal; auto]. Qed. - + (****************************************) (** ** Counting occurences of a element *) (****************************************) - Hypotheses eqA_dec : forall x y : A, {x = y}+{x <> y}. - - Fixpoint count_occ (l : list A) (x : A){struct l} : nat := - match l with - | nil => 0 - | y :: tl => - let n := count_occ tl x in - if eqA_dec y x then S n else n + Fixpoint count_occ (l : list A) (x : A) : nat := + match l with + | [] => 0 + | y :: tl => + let n := count_occ tl x in + if eq_dec y x then S n else n end. - + (** Compatibility of count_occ with operations on list *) Theorem count_occ_In : forall (l : list A) (x : A), In x l <-> count_occ l x > 0. Proof. induction l as [|y l]. simpl; intros; split; [destruct 1 | apply gt_irrefl]. - simpl. intro x; destruct (eqA_dec y x) as [Heq|Hneq]. - rewrite Heq; intuition. + simpl. intro x; destruct (eq_dec y x) as [Heq|Hneq]. + rewrite Heq; intuition. pose (IHl x). intuition. Qed. - - Theorem count_occ_inv_nil : forall (l : list A), (forall x:A, count_occ l x = 0) <-> l = nil. + + Theorem count_occ_inv_nil : forall (l : list A), (forall x:A, count_occ l x = 0) <-> l = []. Proof. split. (* Case -> *) @@ -578,14 +560,14 @@ Section Elts. elim (O_S (count_occ l x)). apply sym_eq. generalize (H x). - simpl. destruct (eqA_dec x x) as [|HF]. + simpl. destruct (eq_dec x x) as [|HF]. trivial. elim HF; reflexivity. (* Case <- *) intro H; rewrite H; simpl; reflexivity. Qed. - - Lemma count_occ_nil : forall (x : A), count_occ nil x = 0. + + Lemma count_occ_nil : forall (x : A), count_occ [] x = 0. Proof. intro x; simpl; reflexivity. Qed. @@ -593,13 +575,13 @@ Section Elts. Lemma count_occ_cons_eq : forall (l : list A) (x y : A), x = y -> count_occ (x::l) y = S (count_occ l y). Proof. intros l x y H; simpl. - destruct (eqA_dec x y); [reflexivity | contradiction]. + destruct (eq_dec x y); [reflexivity | contradiction]. Qed. - + Lemma count_occ_cons_neq : forall (l : list A) (x y : A), x <> y -> count_occ (x::l) y = count_occ l y. Proof. intros l x y H; simpl. - destruct (eqA_dec x y); [contradiction | reflexivity]. + destruct (eq_dec x y); [contradiction | reflexivity]. Qed. End Elts. @@ -620,38 +602,38 @@ Section ListOps. Fixpoint rev (l:list A) : list A := match l with - | nil => nil - | x :: l' => rev l' ++ x :: nil + | [] => [] + | x :: l' => rev l' ++ [x] end. - Lemma distr_rev : forall x y:list A, rev (x ++ y) = rev y ++ rev x. + Lemma rev_app_distr : forall x y:list A, rev (x ++ y) = rev y ++ rev x. Proof. induction x as [| a l IHl]. destruct y as [| a l]. - simpl in |- *. + simpl. auto. - simpl in |- *. - apply app_nil_end; auto. + simpl. + rewrite app_nil_r; auto. intro y. - simpl in |- *. + simpl. rewrite (IHl y). - apply (app_ass (rev y) (rev l) (a :: nil)). + rewrite app_assoc; trivial. Qed. - Remark rev_unit : forall (l:list A) (a:A), rev (l ++ a :: nil) = a :: rev l. + Remark rev_unit : forall (l:list A) (a:A), rev (l ++ [a]) = a :: rev l. Proof. intros. - apply (distr_rev l (a :: nil)); simpl in |- *; auto. + apply (rev_app_distr l [a]); simpl; auto. Qed. Lemma rev_involutive : forall l:list A, rev (rev l) = l. Proof. induction l as [| a l IHl]. - simpl in |- *; auto. + simpl; auto. - simpl in |- *. + simpl. rewrite (rev_unit (rev l) a). rewrite IHl; auto. Qed. @@ -659,7 +641,7 @@ Section ListOps. (** Compatibility with other operations *) - Lemma In_rev : forall l x, In x l <-> In x (rev l). + Lemma in_rev : forall l x, In x l <-> In x (rev l). Proof. induction l. simpl; intuition. @@ -681,7 +663,7 @@ Section ListOps. elim (length l); simpl; auto. Qed. - Lemma rev_nth : forall l d n, n < length l -> + Lemma rev_nth : forall l d n, n < length l -> nth n (rev l) d = nth (length l - S n) l d. Proof. induction l. @@ -704,309 +686,77 @@ Section ListOps. Qed. - (** An alternative tail-recursive definition for reverse *) + (** An alternative tail-recursive definition for reverse *) - Fixpoint rev_append (l l': list A) {struct l} : list A := - match l with - | nil => l' + Fixpoint rev_append (l l': list A) : list A := + match l with + | [] => l' | a::l => rev_append l (a::l') end. - Definition rev' l : list A := rev_append l nil. - - Notation rev_acc := rev_append (only parsing). + Definition rev' l : list A := rev_append l []. - Lemma rev_append_rev : forall l l', rev_acc l l' = rev l ++ l'. + Lemma rev_append_rev : forall l l', rev_append l l' = rev l ++ l'. Proof. induction l; simpl; auto; intros. - rewrite <- ass_app; firstorder. + rewrite <- app_assoc; firstorder. Qed. - Notation rev_acc_rev := rev_append_rev (only parsing). - - Lemma rev_alt : forall l, rev l = rev_append l nil. + Lemma rev_alt : forall l, rev l = rev_append l []. Proof. intros; rewrite rev_append_rev. - apply app_nil_end. + rewrite app_nil_r; trivial. Qed. (*********************************************) (** Reverse Induction Principle on Lists *) (*********************************************) - + Section Reverse_Induction. - - Unset Implicit Arguments. - + Lemma rev_list_ind : forall P:list A-> Prop, - P nil -> + P [] -> (forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) -> forall l:list A, P (rev l). Proof. induction l; auto. Qed. - Set Implicit Arguments. - + Theorem rev_ind : forall P:list A -> Prop, - P nil -> - (forall (x:A) (l:list A), P l -> P (l ++ x :: nil)) -> forall l:list A, P l. + P [] -> + (forall (x:A) (l:list A), P l -> P (l ++ [x])) -> forall l:list A, P l. Proof. intros. generalize (rev_involutive l). intros E; rewrite <- E. apply (rev_list_ind P). auto. - - simpl in |- *. + + simpl. intros. apply (H0 a (rev l0)). auto. Qed. - - End Reverse_Induction. - - - - (***********************************) - (** ** Lists modulo permutation *) - (***********************************) - - Section Permutation. - - Inductive Permutation : list A -> list A -> Prop := - | perm_nil: Permutation nil nil - | perm_skip: forall (x:A) (l l':list A), Permutation l l' -> Permutation (cons x l) (cons x l') - | perm_swap: forall (x y:A) (l:list A), Permutation (cons y (cons x l)) (cons x (cons y l)) - | perm_trans: forall (l l' l'':list A), Permutation l l' -> Permutation l' l'' -> Permutation l l''. - - Hint Constructors Permutation. - - (** Some facts about [Permutation] *) - - Theorem Permutation_nil : forall (l : list A), Permutation nil l -> l = nil. - Proof. - intros l HF. - set (m:=@nil A) in HF; assert (m = nil); [reflexivity|idtac]; clearbody m. - induction HF; try elim (nil_cons (sym_eq H)); auto. - Qed. - - Theorem Permutation_nil_cons : forall (l : list A) (x : A), ~ Permutation nil (x::l). - Proof. - unfold not; intros l x HF. - elim (@nil_cons A x l). apply sym_eq. exact (Permutation_nil HF). - Qed. - - (** Permutation over lists is a equivalence relation *) - - Theorem Permutation_refl : forall l : list A, Permutation l l. - Proof. - induction l; constructor. exact IHl. - Qed. - - Theorem Permutation_sym : forall l l' : list A, Permutation l l' -> Permutation l' l. - Proof. - intros l l' Hperm; induction Hperm; auto. - apply perm_trans with (l':=l'); assumption. - Qed. - - Theorem Permutation_trans : forall l l' l'' : list A, Permutation l l' -> Permutation l' l'' -> Permutation l l''. - Proof. - exact perm_trans. - Qed. - - Hint Resolve Permutation_refl Permutation_sym Permutation_trans. - - (** Compatibility with others operations on lists *) - - Theorem Permutation_in : forall (l l' : list A) (x : A), Permutation l l' -> In x l -> In x l'. - Proof. - intros l l' x Hperm; induction Hperm; simpl; tauto. - Qed. - - Lemma Permutation_app_tail : forall (l l' tl : list A), Permutation l l' -> Permutation (l++tl) (l'++tl). - Proof. - intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto. - eapply Permutation_trans with (l':=l'++tl); trivial. - Qed. - - Lemma Permutation_app_head : forall (l tl tl' : list A), Permutation tl tl' -> Permutation (l++tl) (l++tl'). - Proof. - intros l tl tl' Hperm; induction l; [trivial | repeat rewrite <- app_comm_cons; constructor; assumption]. - Qed. - - Theorem Permutation_app : forall (l m l' m' : list A), Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m'). - Proof. - intros l m l' m' Hpermll' Hpermmm'; induction Hpermll' as [|x l l'|x y l|l l' l'']; repeat rewrite <- app_comm_cons; auto. - apply Permutation_trans with (l' := (x :: y :: l ++ m)); - [idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial. - apply Permutation_trans with (l' := (l' ++ m')); try assumption. - apply Permutation_app_tail; assumption. - Qed. - - Theorem Permutation_app_swap : forall (l l' : list A), Permutation (l++l') (l'++l). - Proof. - induction l as [|x l]. - simpl; intro l'; rewrite <- app_nil_end; trivial. - induction l' as [|y l']. - simpl; rewrite <- app_nil_end; trivial. - simpl; apply Permutation_trans with (l' := x :: y :: l' ++ l). - constructor; rewrite app_comm_cons; apply IHl. - apply Permutation_trans with (l' := y :: x :: l' ++ l); constructor. - apply Permutation_trans with (l' := x :: l ++ l'); auto. - Qed. - - Theorem Permutation_cons_app : forall (l l1 l2:list A) a, - Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2). - Proof. - intros l l1; revert l. - induction l1. - simpl. - intros; apply perm_skip; auto. - simpl; intros. - apply perm_trans with (a0::a::l1++l2). - apply perm_skip; auto. - apply perm_trans with (a::a0::l1++l2). - apply perm_swap; auto. - apply perm_skip; auto. - Qed. - Hint Resolve Permutation_cons_app. - - Theorem Permutation_length : forall (l l' : list A), Permutation l l' -> length l = length l'. - Proof. - intros l l' Hperm; induction Hperm; simpl; auto. - apply trans_eq with (y:= (length l')); trivial. - Qed. - - Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). - Proof. - induction l as [| x l]; simpl; trivial. - apply Permutation_trans with (l' := (x::nil)++rev l). - simpl; auto. - apply Permutation_app_swap. - Qed. - - Theorem Permutation_ind_bis : - forall P : list A -> list A -> Prop, - P (@nil A) (@nil A) -> - (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) -> - (forall x y l l', Permutation l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) -> - (forall l l' l'', Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') -> - forall l l', Permutation l l' -> P l l'. - Proof. - intros P Hnil Hskip Hswap Htrans. - induction 1; auto. - apply Htrans with (x::y::l); auto. - apply Hswap; auto. - induction l; auto. - apply Hskip; auto. - apply Hskip; auto. - induction l; auto. - eauto. - Qed. - - Ltac break_list l x l' H := - destruct l as [|x l']; simpl in *; - injection H; intros; subst; clear H. - - Theorem Permutation_app_inv : forall (l1 l2 l3 l4:list A) a, - Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4). - Proof. - set (P:=fun 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. - apply perm_trans with (l3'++c::l4); auto. - apply perm_trans with (l1'++a::l2); auto using Permutation_cons_app. - apply perm_skip. - apply (IH a l1' l2 l3' l4); auto. - (* 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. - apply perm_trans with (c::l3''++b::l4); auto. - break_list l1' c l1'' H1. - auto. - apply perm_trans with (b::l1''++c::l2); auto. - break_list l3' d l3'' H; break_list l1' e l1'' H1. - auto. - apply perm_trans with (e::a::l1''++l2); auto. - apply perm_trans with (e::l1''++a::l2); auto. - apply perm_trans with (d::a::l3''++l4); auto. - apply perm_trans with (d::l3''++a::l4); auto. - apply perm_trans with (e::d::l1''++l2); auto. - apply perm_skip; apply perm_skip. - apply (IH a l1'' l2 l3'' l4); auto. - (*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). - Qed. - - Theorem Permutation_cons_inv : - forall l l' a, Permutation (a::l) (a::l') -> Permutation l l'. - Proof. - intros; exact (Permutation_app_inv (@nil _) l (@nil _) l' a H). - Qed. - - Theorem Permutation_cons_app_inv : - forall l l1 l2 a, Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2). - Proof. - intros; exact (Permutation_app_inv (@nil _) l l1 l2 a H). - Qed. - - Theorem Permutation_app_inv_l : - forall l l1 l2, Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2. - Proof. - induction l; simpl; auto. - intros. - apply IHl. - apply Permutation_cons_inv with a; auto. - Qed. - - Theorem Permutation_app_inv_r : - forall l l1 l2, Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2. - Proof. - induction l. - intros l1 l2; do 2 rewrite <- app_nil_end; auto. - intros. - apply IHl. - apply Permutation_app_inv with a; auto. - Qed. - - End Permutation. + End Reverse_Induction. (***********************************) (** ** Decidable equality on lists *) (***********************************) - Hypotheses eqA_dec : forall (x y : A), {x = y}+{x <> y}. + Hypothesis eq_dec : forall (x y : A), {x = y}+{x <> y}. Lemma list_eq_dec : forall l l':list A, {l = l'} + {l <> l'}. Proof. induction l as [| x l IHl]; destruct l' as [| y l']. left; trivial. - right; apply nil_cons. + right; apply nil_cons. right; unfold not; intro HF; apply (nil_cons (sym_eq HF)). - destruct (eqA_dec x y) as [xeqy|xneqy]; destruct (IHl l') as [leql'|lneql']; + destruct (eq_dec x y) as [xeqy|xneqy]; destruct (IHl l') as [leql'|lneql']; try (right; unfold not; intro HF; injection HF; intros; contradiction). rewrite xeqy; rewrite leql'; left; trivial. Qed. @@ -1026,21 +776,19 @@ End ListOps. Section Map. Variables A 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) end. - + Lemma in_map : forall (l:list A) (x:A), In x l -> In (f x) (map l). - Proof. - induction l as [| a l IHl]; simpl in |- *; - [ auto - | destruct 1; [ left; apply f_equal with (f := f); assumption | auto ] ]. + Proof. + induction l; firstorder (subst; auto). Qed. - + Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l. Proof. induction l; firstorder (subst; auto). @@ -1051,45 +799,48 @@ Section Map. induction l; simpl; auto. Qed. - Lemma map_nth : forall l d n, + Lemma map_nth : forall l d n, nth n (map l) (f d) = f (nth n l d). Proof. induction l; simpl map; destruct n; firstorder. Qed. - - Lemma map_app : forall l l', + + Lemma map_nth_error : forall n l d, + nth_error l n = Some d -> nth_error (map l) n = Some (f d). + Proof. + induction n; intros [ | ] ? Heq; simpl in *; inversion Heq; auto. + Qed. + + Lemma map_app : forall l l', map (l++l') = (map l)++(map l'). - Proof. + Proof. induction l; simpl; auto. intros; rewrite IHl; auto. Qed. - + Lemma map_rev : forall l, map (rev l) = rev (map l). - Proof. + Proof. induction l; simpl; auto. rewrite map_app. rewrite IHl; auto. Qed. - Hint Constructors Permutation. - - Lemma Permutation_map : - forall l l', Permutation l l' -> Permutation (map l) (map l'). - Proof. - induction 1; simpl; auto; eauto. + Lemma map_eq_nil : forall l, map l = [] -> l = []. + Proof. + destruct l; simpl; reflexivity || discriminate. Qed. (** [flat_map] *) Definition flat_map (f:A -> list B) := - fix flat_map (l:list A) {struct l} : list B := + fix flat_map (l:list A) : list B := match l with | nil => nil | cons x t => (f x)++(flat_map t) end. - + 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). + In y (flat_map f l) <-> exists x, In x l /\ In y (f x). Proof. induction l; simpl; split; intros. contradiction. @@ -1105,16 +856,22 @@ Section Map. exists x; auto. Qed. -End Map. +End Map. + +Lemma map_id : forall (A :Type) (l : list A), + map (fun x => x) l = l. +Proof. + induction l; simpl; auto; rewrite IHl; auto. +Qed. -Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l, +Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l, map g (map f l) = map (fun x => g (f x)) l. Proof. induction l; simpl; auto. rewrite IHl; auto. Qed. -Lemma map_ext : +Lemma map_ext : forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l. Proof. induction l; simpl; auto. @@ -1129,17 +886,17 @@ Qed. Section Fold_Left_Recursor. Variables A B : Type. Variable f : A -> B -> A. - - Fixpoint fold_left (l:list B) (a0:A) {struct l} : A := + + Fixpoint fold_left (l:list B) (a0:A) : A := match l with | nil => a0 | cons b t => fold_left t (f a0 b) end. - - Lemma fold_left_app : forall (l l':list B)(i:A), + + Lemma fold_left_app : forall (l l':list B)(i:A), fold_left (l++l') i = fold_left l' (fold_left l i). Proof. - induction l. + induction l. simpl; auto. intros. simpl. @@ -1148,7 +905,7 @@ Section Fold_Left_Recursor. End Fold_Left_Recursor. -Lemma fold_left_length : +Lemma fold_left_length : forall (A:Type)(l:list A), fold_left (fun x _ => S x) l 0 = length l. Proof. intro A. @@ -1168,7 +925,7 @@ Section Fold_Right_Recursor. Variables A B : Type. Variable f : B -> A -> A. Variable a0 : A. - + Fixpoint fold_right (l:list B) : A := match l with | nil => a0 @@ -1177,7 +934,7 @@ Section Fold_Right_Recursor. End Fold_Right_Recursor. - Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i, + Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i, fold_right f i (l++l') = fold_right f (fold_right f i l') l. Proof. induction l. @@ -1186,7 +943,7 @@ End Fold_Right_Recursor. f_equal; auto. Qed. - Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i, + Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i, fold_right f i (rev l) = fold_left (fun x y => f y x) l i. Proof. induction l. @@ -1204,10 +961,10 @@ End Fold_Right_Recursor. Proof. destruct l as [| a l]. reflexivity. - simpl in |- *. + simpl. rewrite <- H0. generalize a0 a. - induction l as [| a3 l IHl]; simpl in |- *. + induction l as [| a3 l IHl]; simpl. trivial. intros. rewrite H. @@ -1223,7 +980,7 @@ End Fold_Right_Recursor. (** [(list_power x y)] is [y^x], or the set of sequences of elts of [y] indexed by elts of [x], sorted in lexicographic order. *) - Fixpoint list_power (A B:Type)(l:list A) (l':list B) {struct l} : + Fixpoint list_power (A B:Type)(l:list A) (l':list B) : list (list (A * B)) := match l with | nil => cons nil nil @@ -1237,20 +994,20 @@ End Fold_Right_Recursor. (** ** Boolean operations over lists *) (*************************************) - Section Bool. + Section Bool. Variable A : Type. Variable f : A -> bool. - (** find whether a boolean function can be satisfied by an + (** find whether a boolean function can be satisfied by an elements of the list. *) - Fixpoint existsb (l:list A) {struct l}: bool := - match l with + Fixpoint existsb (l:list A) : bool := + match l with | nil => false | a::l => f a || existsb l end. - Lemma existsb_exists : + Lemma existsb_exists : forall l, existsb l = true <-> exists x, In x l /\ f x = true. Proof. induction l; simpl; intuition. @@ -1269,20 +1026,28 @@ End Fold_Right_Recursor. inversion 1. simpl; intros. destruct (orb_false_elim _ _ H0); clear H0; auto. - destruct n ; auto. + destruct n ; auto. rewrite IHl; auto with arith. Qed. - (** find whether a boolean function is satisfied by + Lemma existsb_app : forall l1 l2, + existsb (l1++l2) = existsb l1 || existsb l2. + Proof. + induction l1; intros l2; simpl. + solve[auto]. + case (f a); simpl; solve[auto]. + Qed. + + (** find whether a boolean function is satisfied by all the elements of a list. *) - Fixpoint forallb (l:list A) {struct l} : bool := - match l with + Fixpoint forallb (l:list A) : bool := + match l with | nil => true | a::l => f a && forallb l end. - Lemma forallb_forall : + Lemma forallb_forall : forall l, forallb l = true <-> (forall x, In x l -> f x = true). Proof. induction l; simpl; intuition. @@ -1291,13 +1056,20 @@ End Fold_Right_Recursor. destruct (andb_prop _ _ H1); auto. assert (forallb l = true). apply H0; intuition. - rewrite H1; auto. + rewrite H1; auto. Qed. + Lemma forallb_app : + forall l1 l2, forallb (l1++l2) = forallb l1 && forallb l2. + Proof. + induction l1; simpl. + solve[auto]. + case (f a); simpl; solve[auto]. + Qed. (** [filter] *) - Fixpoint filter (l:list A) : list A := - match l with + Fixpoint filter (l:list A) : list A := + match l with | nil => nil | x :: l => if f x then x::(filter l) else filter l end. @@ -1320,10 +1092,10 @@ End Fold_Right_Recursor. (** [partition] *) - Fixpoint partition (l:list A) {struct l} : list A * list A := + Fixpoint partition (l:list A) : list A * list A := match l with | nil => (nil, nil) - | x :: tl => let (g,d) := partition tl in + | x :: tl => let (g,d) := partition tl in if f x then (x::g,d) else (g,x::d) end. @@ -1338,17 +1110,17 @@ End Fold_Right_Recursor. Section ListPairs. Variables A B : Type. - + (** [split] derives two lists from a list of pairs *) - Fixpoint split (l:list (A*B)) { struct l }: list A * list B := + 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) end. - Lemma in_split_l : forall (l:list (A*B))(p:A*B), - In p l -> In (fst p) (fst (split l)). + Lemma in_split_l : forall (l:list (A*B))(p:A*B), + In p l -> In (fst p) (fst (split l)). Proof. induction l; simpl; intros; auto. destruct p; destruct a; destruct (split l); simpl in *. @@ -1357,8 +1129,8 @@ End Fold_Right_Recursor. right; apply (IHl (a0,b) H). Qed. - Lemma in_split_r : forall (l:list (A*B))(p:A*B), - In p l -> In (snd p) (snd (split l)). + Lemma in_split_r : forall (l:list (A*B))(p:A*B), + In p l -> In (snd p) (snd (split l)). Proof. induction l; simpl; intros; auto. destruct p; destruct a; destruct (split l); simpl in *. @@ -1367,7 +1139,7 @@ End Fold_Right_Recursor. right; apply (IHl (a0,b) H). Qed. - Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B), + Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B), nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)). Proof. induction l. @@ -1379,40 +1151,40 @@ End Fold_Right_Recursor. Qed. Lemma split_length_l : forall (l:list (A*B)), - length (fst (split l)) = length l. + length (fst (split l)) = length l. Proof. induction l; simpl; auto. destruct a; destruct (split l); simpl; auto. Qed. Lemma split_length_r : forall (l:list (A*B)), - length (snd (split l)) = length l. + length (snd (split l)) = length l. Proof. induction l; simpl; auto. destruct a; destruct (split l); simpl; auto. Qed. - (** [combine] is the opposite of [split]. - Lists given to [combine] are meant to be of same length. + (** [combine] is the opposite of [split]. + Lists given to [combine] are meant to be of same length. If not, [combine] stops on the shorter list *) - Fixpoint combine (l : list A) (l' : list B){struct l} : list (A*B) := + Fixpoint combine (l : list A) (l' : list B) : list (A*B) := match l,l' with | x::tl, y::tl' => (x,y)::(combine tl tl') | _, _ => nil end. - Lemma split_combine : forall (l: list (A*B)), + Lemma split_combine : forall (l: list (A*B)), let (l1,l2) := split l in combine l1 l2 = l. Proof. induction l. simpl; auto. - destruct a; simpl. + destruct a; simpl. destruct (split l); simpl in *. f_equal; auto. Qed. - Lemma combine_split : forall (l:list A)(l':list B), length l = length l' -> + Lemma combine_split : forall (l:list A)(l':list B), length l = length l' -> split (combine l l') = (l,l'). Proof. induction l; destruct l'; simpl; intros; auto; try discriminate. @@ -1420,19 +1192,19 @@ End Fold_Right_Recursor. rewrite IHl; auto. Qed. - Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B), + Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B), In (x,y) (combine l l') -> In x l. Proof. induction l. simpl; auto. destruct l'; simpl; auto; intros. - contradiction. + contradiction. destruct H. injection H; auto. right; apply IHl with l' y; auto. Qed. - Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B), + Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B), In (x,y) (combine l l') -> In y l'. Proof. induction l. @@ -1443,7 +1215,7 @@ End Fold_Right_Recursor. right; apply IHl with x; auto. Qed. - Lemma combine_length : forall (l:list A)(l':list B), + Lemma combine_length : forall (l:list A)(l':list B), length (combine l l') = min (length l) (length l'). Proof. induction l. @@ -1451,8 +1223,8 @@ End Fold_Right_Recursor. destruct l'; simpl; auto. Qed. - Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B), - length l = length l' -> + Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B), + length l = length l' -> nth n (combine l l') (x,y) = (nth n l x, nth n l' y). Proof. induction l; destruct l'; intros; try discriminate. @@ -1461,10 +1233,10 @@ End Fold_Right_Recursor. Qed. (** [list_prod] has the same signature as [combine], but unlike - [combine], it adds every possible pairs, not only those at the + [combine], it adds every possible pairs, not only those at the same position. *) - Fixpoint list_prod (l:list A) (l':list B) {struct l} : + Fixpoint list_prod (l:list A) (l':list B) : list (A * B) := match l with | nil => nil @@ -1474,25 +1246,25 @@ End Fold_Right_Recursor. Lemma in_prod_aux : forall (x:A) (y:B) (l:list B), In y l -> In (x, y) (map (fun y0:B => (x, y0)) l). - Proof. + Proof. induction l; - [ simpl in |- *; auto - | simpl in |- *; destruct 1 as [H1| ]; + [ simpl; auto + | simpl; destruct 1 as [H1| ]; [ left; rewrite H1; trivial | right; auto ] ]. Qed. Lemma in_prod : forall (l:list A) (l':list B) (x:A) (y:B), In x l -> In y l' -> In (x, y) (list_prod l l'). - Proof. + Proof. induction l; - [ simpl in |- *; tauto - | simpl in |- *; intros; apply in_or_app; destruct H; + [ simpl; tauto + | simpl; intros; apply in_or_app; destruct H; [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ]. Qed. - Lemma in_prod_iff : - forall (l:list A)(l':list B)(x:A)(y:B), + Lemma in_prod_iff : + forall (l:list A)(l':list B)(x:A)(y:B), In (x,y) (list_prod l l') <-> In x l /\ In y l'. Proof. split; [ | intros; apply in_prod; intuition ]. @@ -1503,9 +1275,9 @@ End Fold_Right_Recursor. destruct (H1 H0) as (z,(H2,H3)); clear H0 H1. injection H2; clear H2; intros; subst; intuition. intuition. - Qed. + Qed. - Lemma prod_length : forall (l:list A)(l':list B), + Lemma prod_length : forall (l:list A)(l':list B), length (list_prod l l') = (length l) * (length l'). Proof. induction l; simpl; auto. @@ -1520,9 +1292,9 @@ End Fold_Right_Recursor. -(***************************************) -(** * Miscelenous operations on lists *) -(***************************************) +(*****************************************) +(** * Miscellaneous operations on lists *) +(*****************************************) @@ -1539,34 +1311,34 @@ Section length_order. Variables l m n : list A. Lemma lel_refl : lel l l. - Proof. - unfold lel in |- *; auto with arith. + Proof. + unfold lel; auto with arith. Qed. Lemma lel_trans : lel l m -> lel m n -> lel l n. - Proof. - unfold lel in |- *; intros. + Proof. + unfold lel; intros. now_show (length l <= length n). apply le_trans with (length m); auto with arith. Qed. Lemma lel_cons_cons : lel l m -> lel (a :: l) (b :: m). - Proof. - unfold lel in |- *; simpl in |- *; auto with arith. + Proof. + unfold lel; simpl; auto with arith. Qed. Lemma lel_cons : lel l m -> lel l (b :: m). - Proof. - unfold lel in |- *; simpl in |- *; auto with arith. + Proof. + unfold lel; simpl; auto with arith. Qed. Lemma lel_tail : lel (a :: l) (b :: m) -> lel l m. - Proof. - unfold lel in |- *; simpl in |- *; auto with arith. + Proof. + unfold lel; simpl; auto with arith. Qed. Lemma lel_nil : forall l':list A, lel l' nil -> nil = l'. - Proof. + Proof. intro l'; elim l'; auto with arith. intros a' y H H0. now_show (nil = a' :: y). @@ -1588,40 +1360,40 @@ Section SetIncl. Definition incl (l m:list A) := forall a:A, In a l -> In a m. Hint Unfold incl. - + Lemma incl_refl : forall l:list A, incl l l. - Proof. + Proof. auto. Qed. Hint Resolve incl_refl. - + Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m). - Proof. + Proof. auto with datatypes. Qed. Hint Immediate incl_tl. Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n. - Proof. + Proof. auto. Qed. - + Lemma incl_appl : forall l m n:list A, incl l n -> incl l (n ++ m). - Proof. + Proof. auto with datatypes. Qed. Hint Immediate incl_appl. - + Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n). - Proof. + Proof. auto with datatypes. Qed. Hint Immediate incl_appr. - + Lemma incl_cons : forall (a:A) (l m:list A), In a m -> incl l m -> incl (a :: l) m. - Proof. - unfold incl in |- *; simpl in |- *; intros a l m H H0 a0 H1. + Proof. + unfold incl; simpl; intros a l m H H0 a0 H1. now_show (In a0 m). elim H1. now_show (a = a0 -> In a0 m). @@ -1632,15 +1404,15 @@ Section SetIncl. auto. Qed. Hint Resolve incl_cons. - + Lemma incl_app : forall l m n:list A, incl l n -> incl m n -> incl (l ++ m) n. - Proof. - unfold incl in |- *; simpl in |- *; intros l m n H H0 a H1. + Proof. + unfold incl; simpl; intros l m n H H0 a H1. now_show (In a n). elim (in_app_or _ _ _ H1); auto. Qed. Hint Resolve incl_app. - + End SetIncl. Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons @@ -1655,24 +1427,24 @@ Section Cutting. Variable A : Type. - Fixpoint firstn (n:nat)(l:list A) {struct n} : list A := - match n with - | 0 => nil - | S n => match l with - | nil => nil + Fixpoint firstn (n:nat)(l:list A) : list A := + match n with + | 0 => nil + | S n => match l with + | nil => nil | a::l => a::(firstn n l) end end. - - Fixpoint skipn (n:nat)(l:list A) { struct n } : list A := - match n with - | 0 => l - | S n => match l with - | nil => nil + + Fixpoint skipn (n:nat)(l:list A) : list A := + match n with + | 0 => l + | S n => match l with + | nil => nil | a::l => skipn n l end end. - + Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l. Proof. induction n. @@ -1686,7 +1458,7 @@ Section Cutting. induction n; destruct l; simpl; auto. Qed. - Lemma removelast_firstn : forall n l, n < length l -> + Lemma removelast_firstn : forall n l, n < length l -> removelast (firstn (S n) l) = firstn n l. Proof. induction n; destruct l. @@ -1699,13 +1471,13 @@ Section Cutting. change (firstn (S n) (a::l)) with (a::firstn n l). rewrite removelast_app. rewrite IHn; auto with arith. - + clear IHn; destruct l; simpl in *; try discriminate. inversion_clear H. inversion_clear H0. Qed. - Lemma firstn_removelast : forall n l, n < length l -> + Lemma firstn_removelast : forall n l, n < length l -> firstn n (removelast l) = firstn n l. Proof. induction n; destruct l. @@ -1730,10 +1502,10 @@ End Cutting. Section ReDun. Variable A : Type. - - Inductive NoDup : list A -> Prop := - | NoDup_nil : NoDup nil - | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l). + + Inductive NoDup : list A -> Prop := + | 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'). Proof. @@ -1758,34 +1530,6 @@ Section ReDun. destruct (IHl _ _ H1); auto. Qed. - Lemma NoDup_Permutation : forall l l', - NoDup l -> NoDup l' -> (forall x, 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). - Qed. - End ReDun. @@ -1795,21 +1539,21 @@ End ReDun. Section NatSeq. - (** [seq] computes the sequence of [len] contiguous integers + (** [seq] computes the sequence of [len] contiguous integers that starts at [start]. For instance, [seq 2 3] is [2::3::4::nil]. *) - - Fixpoint seq (start len:nat) {struct len} : list nat := - match len with + + Fixpoint seq (start len:nat) : list nat := + match len with | 0 => nil | S len => start :: seq (S start) len - end. - + end. + Lemma seq_length : forall len start, length (seq start len) = len. Proof. induction len; simpl; auto. Qed. - - Lemma seq_nth : forall len start n d, + + Lemma seq_nth : forall len start n d, n < len -> nth n (seq start len) d = start+n. Proof. induction len; intros. @@ -1822,7 +1566,7 @@ Section NatSeq. Lemma seq_shift : forall len start, map S (seq start len) = seq (S start) len. - Proof. + Proof. induction len; simpl; auto. intros. rewrite IHlen. @@ -1832,11 +1576,172 @@ Section NatSeq. End NatSeq. +(** * 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. + +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. + +Lemma Exists_nil : forall A (P:A->Prop), Exists P nil <-> False. +Proof. split; inversion 1. Qed. + +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. + + +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). +Hint Constructors Forall. - (** * Exporting hints and tactics *) +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. + +Lemma Forall_inv : forall A P (a:A) l, Forall P (a :: l) -> P a. +Proof. +intros; inversion H; trivial. +Defined. + +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. + +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. +(** [Forall2]: stating that elements of two lists are pairwise related. *) -Hint Rewrite +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 : forall A B (R:A->B->Prop), Forall2 R [] []. +Proof. exact Forall2_nil. Qed. + +Theorem Forall2_app_inv_l : forall A B (R:A->B->Prop) l1 l2 l', + Forall2 R (l1 ++ l2) l' -> + exists l1', exists 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_inv_r : forall A B (R:A->B->Prop) l1' l2' l, + Forall2 R l (l1' ++ l2') -> + exists l1, exists 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. + +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. + +(** [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. + +(** [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. + +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. + + +(** [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 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. + +(** * Inversion of predicates over lists based on head symbol *) + +Ltac is_list_constr c := + match c with + | nil => idtac + | (_::_) => idtac + | _ => fail + end. + +Ltac invlist f := + match goal with + | H:f ?l |- _ => is_list_constr l; inversion_clear H; invlist f + | H:f _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f + | H:f _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f + | H:f _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f + | H:f _ _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f + | _ => idtac + end. + + + +(** * Exporting hints and tactics *) + + +Hint Rewrite rev_involutive (* rev (rev l) = l *) rev_unit (* rev (l ++ a :: nil) = a :: rev l *) map_nth (* nth n (map f l) (f d) = f (nth n l d) *) @@ -1844,11 +1749,36 @@ Hint Rewrite seq_length (* length (seq start len) = len *) app_length (* length (l ++ l') = length l + length l' *) rev_length (* length (rev l) = length l *) - : list. - -Hint Rewrite <- - app_nil_end (* l = l ++ nil *) + app_nil_r (* l ++ nil = l *) : list. Ltac simpl_list := autorewrite with list. Ltac ssimpl_list := autorewrite with list using simpl. + +(* begin hide *) +(* Compatibility notations after the migration of [list] to [Datatypes] *) +Notation list := list (only parsing). +Notation list_rect := list_rect (only parsing). +Notation list_rec := list_rec (only parsing). +Notation list_ind := list_ind (only parsing). +Notation nil := nil (only parsing). +Notation cons := cons (only parsing). +Notation length := length (only parsing). +Notation app := app (only parsing). +(* Compatibility Names *) +Notation tail := tl (only parsing). +Notation head := hd_error (only parsing). +Notation head_nil := hd_error_nil (only parsing). +Notation head_cons := hd_error_cons (only parsing). +Notation ass_app := app_assoc (only parsing). +Notation app_ass := app_assoc_reverse (only parsing). +Notation In_split := in_split (only parsing). +Notation In_rev := in_rev (only parsing). +Notation In_dec := in_dec (only parsing). +Notation distr_rev := rev_app_distr (only parsing). +Notation rev_acc := rev_append (only parsing). +Notation rev_acc_rev := rev_append_rev (only parsing). +Notation AllS := Forall (only parsing). (* was formerly in TheoryList *) + +Hint Resolve app_nil_end : datatypes v62. +(* end hide *) diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index 021a64c1..20c9e7e8 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ListSet.v 10616 2008-03-04 17:33:35Z letouzey $ i*) +(*i $Id$ i*) (** A Library for finite sets, implemented as lists *) @@ -27,7 +27,7 @@ Section first_definitions. Definition empty_set : set := nil. - Fixpoint set_add (a:A) (x:set) {struct x} : set := + Fixpoint set_add (a:A) (x:set) : set := match x with | nil => a :: nil | a1 :: x1 => @@ -38,7 +38,7 @@ Section first_definitions. end. - Fixpoint set_mem (a:A) (x:set) {struct x} : bool := + Fixpoint set_mem (a:A) (x:set) : bool := match x with | nil => false | a1 :: x1 => @@ -47,9 +47,9 @@ Section first_definitions. | right _ => set_mem a x1 end end. - + (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing *) - Fixpoint set_remove (a:A) (x:set) {struct x} : set := + Fixpoint set_remove (a:A) (x:set) : set := match x with | nil => empty_set | a1 :: x1 => @@ -67,20 +67,20 @@ Section first_definitions. if set_mem a1 y then a1 :: set_inter x1 y else set_inter x1 y end. - Fixpoint set_union (x y:set) {struct y} : set := + Fixpoint set_union (x y:set) : set := match y with | nil => x | a1 :: y1 => set_add a1 (set_union x y1) end. - + (** returns the set of all els of [x] that does not belong to [y] *) - Fixpoint set_diff (x y:set) {struct x} : set := + Fixpoint set_diff (x y:set) : set := match x with | nil => nil | a1 :: x1 => if set_mem a1 y then set_diff x1 y else set_add a1 (set_diff x1 y) end. - + Definition set_In : A -> set -> Prop := In (A:=A). @@ -123,7 +123,7 @@ Section first_definitions. case H3; auto. Qed. - + Lemma set_mem_correct1 : forall (a:A) (x:set), set_mem a x = true -> set_In a x. Proof. @@ -191,11 +191,11 @@ Section first_definitions. Lemma set_add_intro : forall (a b:A) (x:set), a = b \/ set_In a x -> set_In a (set_add b x). - + Proof. intros a b x [H1| H2]; auto with datatypes. Qed. - + Lemma set_add_elim : forall (a b:A) (x:set), set_In a (set_add b x) -> a = b \/ set_In a x. @@ -225,7 +225,7 @@ Section first_definitions. simple induction x; simpl in |- *. discriminate. intros; elim (Aeq_dec a a0); intros; discriminate. - Qed. + Qed. Lemma set_union_intro1 : @@ -289,7 +289,7 @@ Section first_definitions. elim (set_mem a y); simpl in |- *; intros. auto with datatypes. absurd (set_In a y); auto with datatypes. - elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ]. + elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ]. Qed. Lemma set_inter_elim1 : @@ -324,7 +324,7 @@ Section first_definitions. set_In a (set_inter x y) -> set_In a x /\ set_In a y. Proof. eauto with datatypes. - Qed. + Qed. Lemma set_diff_intro : forall (a:A) (x y:set), @@ -354,7 +354,7 @@ Section first_definitions. forall (a:A) (x y:set), set_In a (set_diff x y) -> ~ set_In a y. intros a x y; elim x; simpl in |- *. intros; contradiction. - intros a0 l Hrec. + intros a0 l Hrec. apply set_mem_ind2; auto. intros H1 H2; case (set_add_elim _ _ _ H2); intros; auto. rewrite H; trivial. @@ -373,24 +373,23 @@ End first_definitions. Section other_definitions. - Variables A B : Type. - - Definition set_prod : set A -> set B -> set (A * B) := - list_prod (A:=A) (B:=B). + Definition set_prod : forall {A B:Type}, set A -> set B -> set (A * B) := + list_prod. (** [B^A], set of applications from [A] to [B] *) - Definition set_power : set A -> set B -> set (set (A * B)) := - list_power (A:=A) (B:=B). + Definition set_power : forall {A B:Type}, set A -> set B -> set (set (A * B)) := + list_power. - Definition set_map : (A -> B) -> set A -> set B := map (A:=A) (B:=B). - - Definition set_fold_left : (B -> A -> B) -> set A -> B -> B := + Definition set_fold_left {A B:Type} : (B -> A -> B) -> set A -> B -> B := fold_left (A:=B) (B:=A). - Definition set_fold_right (f:A -> B -> B) (x:set A) + Definition set_fold_right {A B:Type} (f:A -> B -> B) (x:set A) (b:B) : B := fold_right f b x. - + Definition set_map {A B:Type} (Aeq_dec : forall x y:B, {x = y} + {x <> y}) + (f : A -> B) (x : set A) : set B := + set_fold_right (fun a => set_add Aeq_dec (f a)) x (empty_set B). + End other_definitions. Unset Implicit Arguments. diff --git a/theories/Lists/ListTactics.v b/theories/Lists/ListTactics.v index 515ed138..0a21a9e2 100644 --- a/theories/Lists/ListTactics.v +++ b/theories/Lists/ListTactics.v @@ -6,40 +6,44 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ListTactics.v 9427 2006-12-11 18:46:35Z bgregoir $ i*) +(*i $Id$ i*) Require Import BinPos. Require Import List. Ltac list_fold_right fcons fnil l := match l with - | (cons ?x ?tl) => fcons x ltac:(list_fold_right fcons fnil tl) + | ?x :: ?tl => fcons x ltac:(list_fold_right fcons fnil tl) | nil => fnil end. +(* A variant of list_fold_right, to prevent the match of list_fold_right + from catching errors raised by fcons. *) Ltac lazy_list_fold_right fcons fnil l := - match l with - | (cons ?x ?tl) => - let cont := lazy_list_fold_right fcons fnil in - fcons x cont tl - | nil => fnil - end. + let f := + match l with + | ?x :: ?tl => + fun _ => + fcons x ltac:(fun _ => lazy_list_fold_right fcons fnil tl) + | nil => fun _ => fnil() + end in + f(). Ltac list_fold_left fcons fnil l := match l with - | (cons ?x ?tl) => list_fold_left fcons ltac:(fcons x fnil) tl + | ?x :: ?tl => list_fold_left fcons ltac:(fcons x fnil) tl | nil => fnil end. Ltac list_iter f l := match l with - | (cons ?x ?tl) => f x; list_iter f tl + | ?x :: ?tl => f x; list_iter f tl | nil => idtac end. Ltac list_iter_gen seq f l := match l with - | (cons ?x ?tl) => + | ?x :: ?tl => let t1 _ := f x in let t2 _ := list_iter_gen seq f tl in seq t1 t2 @@ -48,30 +52,30 @@ Ltac list_iter_gen seq f l := Ltac AddFvTail a l := match l with - | nil => constr:(cons a l) - | (cons a _) => l - | (cons ?x ?l) => let l' := AddFvTail a l in constr:(cons x l') + | nil => constr:(a::nil) + | a :: _ => l + | ?x :: ?l => let l' := AddFvTail a l in constr:(x::l') end. Ltac Find_at a l := let rec find n l := match l with - | nil => fail 100 "anomaly: Find_at" - | (cons a _) => eval compute in n - | (cons _ ?l) => find (Psucc n) l + | nil => fail 100 "anomaly: Find_at" + | a :: _ => eval compute in n + | _ :: ?l => find (Psucc n) l end in find 1%positive l. Ltac check_is_list t := match t with - | cons _ ?l => check_is_list l - | nil => idtac - | _ => fail 100 "anomaly: failed to build a canonical list" + | _ :: ?l => check_is_list l + | nil => idtac + | _ => fail 100 "anomaly: failed to build a canonical list" end. Ltac check_fv l := check_is_list l; - match type of l with + match type of l with | list _ => idtac - | _ => fail 100 "anomaly: built an ill-typed list" + | _ => fail 100 "anomaly: built an ill-typed list" end. diff --git a/theories/Lists/MonoList.v b/theories/Lists/MonoList.v deleted file mode 100644 index aa2b74dd..00000000 --- a/theories/Lists/MonoList.v +++ /dev/null @@ -1,269 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* list -> list. - -Fixpoint app (l m:list) {struct l} : list := - match l return list with - | nil => m - | cons a l1 => cons a (app l1 m) - end. - - -Lemma app_nil_end : forall l:list, l = app l nil. -Proof. - intro l; elim l; simpl in |- *; auto. - simple induction 1; auto. -Qed. -Hint Resolve app_nil_end: list v62. - -Lemma app_ass : forall l m n:list, app (app l m) n = app l (app m n). -Proof. - intros l m n; elim l; simpl in |- *; auto with list. - simple induction 1; auto with list. -Qed. -Hint Resolve app_ass: list v62. - -Lemma ass_app : forall l m n:list, app l (app m n) = app (app l m) n. -Proof. - auto with list. -Qed. -Hint Resolve ass_app: list v62. - -Definition tail (l:list) : list := - match l return list with - | cons _ m => m - | _ => nil - end. - - -Lemma nil_cons : forall (a:A) (m:list), nil <> cons a m. - intros; discriminate. -Qed. - -(****************************************) -(* Length of lists *) -(****************************************) - -Fixpoint length (l:list) : nat := - match l return nat with - | cons _ m => S (length m) - | _ => 0 - end. - -(******************************) -(* Length order of lists *) -(******************************) - -Section length_order. -Definition lel (l m:list) := length l <= length m. - -Hint Unfold lel: list. - -Variables a b : A. -Variables l m n : list. - -Lemma lel_refl : lel l l. -Proof. - unfold lel in |- *; auto with list. -Qed. - -Lemma lel_trans : lel l m -> lel m n -> lel l n. -Proof. - unfold lel in |- *; intros. - apply le_trans with (length m); auto with list. -Qed. - -Lemma lel_cons_cons : lel l m -> lel (cons a l) (cons b m). -Proof. - unfold lel in |- *; simpl in |- *; auto with list arith. -Qed. - -Lemma lel_cons : lel l m -> lel l (cons b m). -Proof. - unfold lel in |- *; simpl in |- *; auto with list arith. -Qed. - -Lemma lel_tail : lel (cons a l) (cons b m) -> lel l m. -Proof. - unfold lel in |- *; simpl in |- *; auto with list arith. -Qed. - -Lemma lel_nil : forall l':list, lel l' nil -> nil = l'. -Proof. - intro l'; elim l'; auto with list arith. - intros a' y H H0. - (* nil=(cons a' y) - ============================ - H0 : (lel (cons a' y) nil) - H : (lel y nil)->(nil=y) - y : list - a' : A - l' : list *) - absurd (S (length y) <= 0); auto with list arith. -Qed. -End length_order. - -Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons: list - v62. - -Fixpoint In (a:A) (l:list) {struct l} : Prop := - match l with - | nil => False - | cons b m => b = a \/ In a m - end. - -Lemma in_eq : forall (a:A) (l:list), In a (cons a l). -Proof. - simpl in |- *; auto with list. -Qed. -Hint Resolve in_eq: list v62. - -Lemma in_cons : forall (a b:A) (l:list), In b l -> In b (cons a l). -Proof. - simpl in |- *; auto with list. -Qed. -Hint Resolve in_cons: list v62. - -Lemma in_app_or : forall (l m:list) (a:A), In a (app l m) -> In a l \/ In a m. -Proof. - intros l m a. - elim l; simpl in |- *; auto with list. - intros a0 y H H0. - (* ((a0=a)\/(In a y))\/(In a m) - ============================ - H0 : (a0=a)\/(In a (app y m)) - H : (In a (app y m))->((In a y)\/(In a m)) - y : list - a0 : A - a : A - m : list - l : list *) - elim H0; auto with list. - intro H1. - (* ((a0=a)\/(In a y))\/(In a m) - ============================ - H1 : (In a (app y m)) *) - elim (H H1); auto with list. -Qed. -Hint Immediate in_app_or: list v62. - -Lemma in_or_app : forall (l m:list) (a:A), In a l \/ In a m -> In a (app l m). -Proof. - intros l m a. - elim l; simpl in |- *; intro H. - (* 1 (In a m) - ============================ - H : False\/(In a m) - a : A - m : list - l : list *) - elim H; auto with list; intro H0. - (* (In a m) - ============================ - H0 : False *) - elim H0. (* subProof completed *) - intros y H0 H1. - (* 2 (H=a)\/(In a (app y m)) - ============================ - H1 : ((H=a)\/(In a y))\/(In a m) - H0 : ((In a y)\/(In a m))->(In a (app y m)) - y : list *) - elim H1; auto 4 with list. - intro H2. - (* (H=a)\/(In a (app y m)) - ============================ - H2 : (H=a)\/(In a y) *) - elim H2; auto with list. -Qed. -Hint Resolve in_or_app: list v62. - -Definition incl (l m:list) := forall a:A, In a l -> In a m. - -Hint Unfold incl: list v62. - -Lemma incl_refl : forall l:list, incl l l. -Proof. - auto with list. -Qed. -Hint Resolve incl_refl: list v62. - -Lemma incl_tl : forall (a:A) (l m:list), incl l m -> incl l (cons a m). -Proof. - auto with list. -Qed. -Hint Immediate incl_tl: list v62. - -Lemma incl_tran : forall l m n:list, incl l m -> incl m n -> incl l n. -Proof. - auto with list. -Qed. - -Lemma incl_appl : forall l m n:list, incl l n -> incl l (app n m). -Proof. - auto with list. -Qed. -Hint Immediate incl_appl: list v62. - -Lemma incl_appr : forall l m n:list, incl l n -> incl l (app m n). -Proof. - auto with list. -Qed. -Hint Immediate incl_appr: list v62. - -Lemma incl_cons : - forall (a:A) (l m:list), In a m -> incl l m -> incl (cons a l) m. -Proof. - unfold incl in |- *; simpl in |- *; intros a l m H H0 a0 H1. - (* (In a0 m) - ============================ - H1 : (a=a0)\/(In a0 l) - a0 : A - H0 : (a:A)(In a l)->(In a m) - H : (In a m) - m : list - l : list - a : A *) - elim H1. - (* 1 (a=a0)->(In a0 m) *) - elim H1; auto with list; intro H2. - (* (a=a0)->(In a0 m) - ============================ - H2 : a=a0 *) - elim H2; auto with list. (* solves subgoal *) - (* 2 (In a0 l)->(In a0 m) *) - auto with list. -Qed. -Hint Resolve incl_cons: list v62. - -Lemma incl_app : forall l m n:list, incl l n -> incl m n -> incl (app l m) n. -Proof. - unfold incl in |- *; simpl in |- *; intros l m n H H0 a H1. - (* (In a n) - ============================ - H1 : (In a (app l m)) - a : A - H0 : (a:A)(In a m)->(In a n) - H : (a:A)(In a l)->(In a n) - n : list - m : list - l : list *) - elim (in_app_or l m a); auto with list. -Qed. -Hint Resolve incl_app: list v62. \ No newline at end of file diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index 2592abb5..d42e71e5 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -6,23 +6,23 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: SetoidList.v 11800 2009-01-18 18:34:15Z msozeau $ *) +(* $Id$ *) Require Export List. Require Export Sorting. -Require Export Setoid. +Require Export Setoid Basics Morphisms. Set Implicit Arguments. Unset Strict Implicit. -(** * Logical relations over lists with respect to a setoid equality - or ordering. *) +(** * Logical relations over lists with respect to a setoid equality + or ordering. *) -(** This can be seen as a complement of predicate [lelistA] and [sort] +(** This can be seen as a complement of predicate [lelistA] and [sort] found in [Sorting]. *) Section Type_with_equality. Variable A : Type. -Variable eqA : A -> A -> Prop. +Variable eqA : A -> A -> Prop. (** Being in a list modulo an equality relation over type [A]. *) @@ -32,27 +32,28 @@ Inductive InA (x : A) : list A -> Prop := Hint Constructors InA. +(** TODO: it would be nice to have a generic definition instead + of the previous one. Having [InA = Exists eqA] raises too + many compatibility issues. For now, we only state the equivalence: *) + +Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l. +Proof. split; induction 1; auto. Qed. + Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l. Proof. - intuition. - inversion H; auto. + intuition. invlist InA; auto. Qed. Lemma InA_nil : forall x, InA x nil <-> False. Proof. - intuition. - inversion H. + intuition. invlist InA. Qed. (** An alternative definition of [InA]. *) Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l. -Proof. - induction l; intuition. - inversion H. - firstorder. - inversion H1; firstorder. - firstorder; subst; auto. +Proof. + intros; rewrite InA_altdef, Exists_exists; firstorder. Qed. (** A list without redundancy modulo the equality over [A]. *) @@ -63,8 +64,22 @@ Inductive NoDupA : list A -> Prop := Hint Constructors NoDupA. +(** An alternative definition of [NoDupA] based on [ForallOrdPairs] *) + +Lemma NoDupA_altdef : forall l, + NoDupA l <-> ForallOrdPairs (complement eqA) l. +Proof. + split; induction 1; constructor; auto. + rewrite Forall_forall. intros b Hb. + intro Eq; elim H. rewrite InA_alt. exists b; auto. + rewrite InA_alt; intros (a' & Haa' & Ha'). + rewrite Forall_forall in H. exact (H a' Ha' Haa'). +Qed. + + (** lists with same elements modulo [eqA] *) +Definition inclA l l' := forall x, InA x l -> InA x l'. Definition equivlistA l l' := forall x, InA x l <-> InA x l'. (** lists with same elements modulo [eqA] at the same place *) @@ -76,48 +91,78 @@ Inductive eqlistA : list A -> list A -> Prop := Hint Constructors eqlistA. -(** Compatibility of a boolean function with respect to an equality. *) +(** We could also have written [eqlistA = Forall2 eqA]. *) -Definition compat_bool (f : A->bool) := forall x y, eqA x y -> f x = f y. +Lemma eqlistA_altdef : forall l l', eqlistA l l' <-> Forall2 eqA l l'. +Proof. split; induction 1; auto. Qed. -(** Compatibility of a function upon natural numbers. *) +(** Results concerning lists modulo [eqA] *) -Definition compat_nat (f : A->nat) := forall x y, eqA x y -> f x = f y. +Hypothesis eqA_equiv : Equivalence eqA. -(** Compatibility of a predicate with respect to an equality. *) +Hint Resolve (@Equivalence_Reflexive _ _ eqA_equiv). +Hint Resolve (@Equivalence_Transitive _ _ eqA_equiv). +Hint Immediate (@Equivalence_Symmetric _ _ eqA_equiv). -Definition compat_P (P : A->Prop) := forall x y, eqA x y -> P x -> P y. +Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA. -(** Results concerning lists modulo [eqA] *) +(** First, the two notions [equivlistA] and [eqlistA] are indeed equivlances *) -Hypothesis eqA_refl : forall x, eqA x x. -Hypothesis eqA_sym : forall x y, eqA x y -> eqA y x. -Hypothesis eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z. +Global Instance equivlist_equiv : Equivalence equivlistA. +Proof. + firstorder. +Qed. + +Global Instance eqlistA_equiv : Equivalence eqlistA. +Proof. + constructor; red. + induction x; auto. + induction 1; auto. + intros x y z H; revert z; induction H; auto. + inversion 1; subst; auto. invlist eqlistA; eauto with *. +Qed. + +(** Moreover, [eqlistA] implies [equivlistA]. A reverse result + will be proved later for sorted list without duplicates. *) + +Global Instance eqlistA_equivlistA : subrelation eqlistA equivlistA. +Proof. + intros x x' H. induction H. + intuition. + red; intros. + rewrite 2 InA_cons. + rewrite (IHeqlistA x0), H; intuition. +Qed. + +(** InA is compatible with eqA (for its first arg) and with + equivlistA (and hence eqlistA) for its second arg *) + +Global Instance InA_compat : Proper (eqA==>equivlistA==>iff) InA. +Proof. + intros x x' Hxx' l l' Hll'. rewrite (Hll' x). + rewrite 2 InA_alt; firstorder. +Qed. -Hint Resolve eqA_refl eqA_trans. -Hint Immediate eqA_sym. +(** For compatibility, an immediate consequence of [InA_compat] *) Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. -Proof. - intros s x y. - do 2 rewrite InA_alt. - intros H (z,(U,V)). - exists z; split; eauto. +Proof. + intros l x y H H'. rewrite <- H; auto. Qed. Hint Immediate InA_eqA. Lemma In_InA : forall l x, In x l -> InA x l. Proof. - simple induction l; simpl in |- *; intuition. - subst; auto. + simple induction l; simpl; intuition. + subst; auto. Qed. Hint Resolve In_InA. -Lemma InA_split : forall l x, InA x l -> - exists l1, exists y, exists l2, +Lemma InA_split : forall l x, InA x l -> + exists l1, exists y, exists l2, eqA x y /\ l = l1++y::l2. Proof. -induction l; inversion_clear 1. +induction l; intros; inv. exists (@nil A); exists a; exists l; auto. destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))). exists (a::l1); exists y; exists l2; auto. @@ -128,7 +173,7 @@ Lemma InA_app : forall l1 l2 x, InA x (l1 ++ l2) -> InA x l1 \/ InA x l2. Proof. induction l1; simpl in *; intuition. - inversion_clear H; auto. + inv; auto. elim (IHl1 l2 x H0); auto. Qed. @@ -144,7 +189,7 @@ Proof. apply in_or_app; auto. Qed. -Lemma InA_rev : forall p m, +Lemma InA_rev : forall p m, InA p (rev m) <-> InA p m. Proof. intros; do 2 rewrite InA_alt. @@ -153,107 +198,16 @@ Proof. rewrite <- In_rev; auto. Qed. -(** Results concerning lists modulo [eqA] and [ltA] *) - -Variable ltA : A -> A -> Prop. -Hypothesis ltA_trans : forall x y z, ltA x y -> ltA y z -> ltA x z. -Hypothesis ltA_not_eqA : forall x y, ltA x y -> ~ eqA x y. -Hypothesis ltA_eqA : forall x y z, ltA x y -> eqA y z -> ltA x z. -Hypothesis eqA_ltA : forall x y z, eqA x y -> ltA y z -> ltA x z. - -Hint Resolve ltA_trans. -Hint Immediate ltA_eqA eqA_ltA. - -Notation InfA:=(lelistA ltA). -Notation SortA:=(sort ltA). - -Hint Constructors lelistA sort. - -Lemma InfA_ltA : - forall l x y, ltA x y -> InfA y l -> InfA x l. -Proof. - destruct l; constructor; inversion_clear H0; - eapply ltA_trans; eauto. -Qed. - -Lemma InfA_eqA : - forall l x y, eqA x y -> InfA y l -> InfA x l. -Proof. - intro s; case s; constructor; inversion_clear H0; eauto. -Qed. -Hint Immediate InfA_ltA InfA_eqA. - -Lemma SortA_InfA_InA : - forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. -Proof. - simple induction l. - intros; inversion H1. - intros. - inversion_clear H0; inversion_clear H1; inversion_clear H2. - eapply ltA_eqA; eauto. - eauto. -Qed. - -Lemma In_InfA : - forall l x, (forall y, In y l -> ltA x y) -> InfA x l. -Proof. - simple induction l; simpl in |- *; intros; constructor; auto. -Qed. - -Lemma InA_InfA : - forall l x, (forall y, InA y l -> ltA x y) -> InfA x l. -Proof. - simple induction l; simpl in |- *; intros; constructor; auto. -Qed. - -(* In fact, this may be used as an alternative definition for InfA: *) - -Lemma InfA_alt : - forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)). -Proof. -split. -intros; eapply SortA_InfA_InA; eauto. -apply InA_InfA. -Qed. - -Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2). -Proof. - induction l1; simpl; auto. - inversion_clear 1; auto. -Qed. - -Lemma SortA_app : - forall l1 l2, SortA l1 -> SortA l2 -> - (forall x y, InA x l1 -> InA y l2 -> ltA x y) -> - SortA (l1 ++ l2). -Proof. - induction l1; simpl in *; intuition. - inversion_clear H. - constructor; auto. - apply InfA_app; auto. - destruct l2; auto. -Qed. Section NoDupA. -Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l. -Proof. - simple induction l; auto. - intros x l' H H0. - inversion_clear H0. - constructor; auto. - intro. - assert (ltA x x) by (eapply SortA_InfA_InA; eauto). - elim (ltA_not_eqA H3); auto. -Qed. - -Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> - (forall x, InA x l -> InA x l' -> False) -> +Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> + (forall x, InA x l -> InA x l' -> False) -> NoDupA (l++l'). Proof. induction l; simpl; auto; intros. -inversion_clear H. +inv. constructor. rewrite InA_alt; intros (y,(H4,H5)). destruct (in_app_or _ _ _ H5). @@ -274,35 +228,36 @@ Proof. induction l. simpl; auto. simpl; intros. -inversion_clear H. +inv. apply NoDupA_app; auto. constructor; auto. -intro H2; inversion H2. +intro; inv. intros x. rewrite InA_alt. intros (x1,(H2,H3)). -inversion_clear 1. +intro; inv. destruct H0. -apply InA_eqA with x1; eauto. +rewrite <- H4, H2. apply In_InA. rewrite In_rev; auto. -inversion H4. Qed. Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l'). Proof. - induction l; simpl in *; inversion_clear 1; auto. + induction l; simpl in *; intros; inv; auto. constructor; eauto. contradict H0. - rewrite InA_app_iff in *; rewrite InA_cons; intuition. + rewrite InA_app_iff in *. + rewrite InA_cons. + intuition. Qed. Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l'). Proof. - induction l; simpl in *; inversion_clear 1; auto. + induction l; simpl in *; intros; inv; auto. constructor; eauto. assert (H2:=IHl _ _ H1). - inversion_clear H2. + inv. rewrite InA_cons. red; destruct 1. apply H0. @@ -314,287 +269,130 @@ Proof. eapply NoDupA_split; eauto. Qed. -End NoDupA. - -(** Some results about [eqlistA] *) - -Section EqlistA. - -Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'. -Proof. -induction 1; auto; simpl; congruence. -Qed. - -Lemma eqlistA_app : forall l1 l1' l2 l2', - eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2'). -Proof. -intros l1 l1' l2 l2' H; revert l2 l2'; induction H; simpl; auto. -Qed. - -Lemma eqlistA_rev_app : forall l1 l1', - eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' -> - eqlistA ((rev l1)++l2) ((rev l1')++l2'). -Proof. -induction 1; auto. -simpl; intros. -do 2 rewrite app_ass; simpl; auto. -Qed. - -Lemma eqlistA_rev : forall l1 l1', - eqlistA l1 l1' -> eqlistA (rev l1) (rev l1'). -Proof. -intros. -rewrite (app_nil_end (rev l1)). -rewrite (app_nil_end (rev l1')). -apply eqlistA_rev_app; auto. -Qed. - -Lemma SortA_equivlistA_eqlistA : forall l l', - SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'. -Proof. -induction l; destruct l'; simpl; intros; auto. -destruct (H1 a); assert (H4 : InA a nil) by auto; inversion H4. -destruct (H1 a); assert (H4 : InA a nil) by auto; inversion H4. -inversion_clear H; inversion_clear H0. -assert (forall y, InA y l -> ltA a y). -intros; eapply SortA_InfA_InA with (l:=l); eauto. -assert (forall y, InA y l' -> ltA a0 y). -intros; eapply SortA_InfA_InA with (l:=l'); eauto. -clear H3 H4. -assert (eqA a a0). - destruct (H1 a). - destruct (H1 a0). - assert (InA a (a0::l')) by auto. - inversion_clear H8; auto. - assert (InA a0 (a::l)) by auto. - inversion_clear H8; auto. - elim (@ltA_not_eqA a a); auto. - apply ltA_trans with a0; auto. -constructor; auto. -apply IHl; auto. -split; intros. -destruct (H1 x). -assert (H8 : InA x (a0::l')) by auto; inversion_clear H8; auto. -elim (@ltA_not_eqA a x); eauto. -destruct (H1 x). -assert (H8 : InA x (a::l)) by auto; inversion_clear H8; auto. -elim (@ltA_not_eqA a0 x); eauto. -Qed. - -End EqlistA. - -(** A few things about [filter] *) - -Section Filter. - -Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l). +Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y -> + NoDupA (x::l) -> NoDupA (l1++y::l2) -> + equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2). Proof. -induction l; simpl; auto. -inversion_clear 1; auto. -destruct (f a); auto. -constructor; auto. -apply In_InfA; auto. -intros. -rewrite filter_In in H; destruct H. -eapply SortA_InfA_InA; eauto. + intros; intro a. + generalize (H2 a). + rewrite !InA_app_iff, !InA_cons. + inv. + assert (SW:=NoDupA_swap H1). inv. + rewrite InA_app_iff in H0. + split; intros. + assert (~eqA a x) by (contradict H3; rewrite <- H3; auto). + assert (~eqA a y) by (rewrite <- H; auto). + tauto. + assert (OR : eqA a x \/ InA a l) by intuition. clear H6. + destruct OR as [EQN|INA]; auto. + elim H0. + rewrite <-H,<-EQN; auto. Qed. -Lemma filter_InA : forall f, (compat_bool f) -> - forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true. -Proof. -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. - rewrite (H _ _ H0); auto. -destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition. - rewrite <- (H _ _ H0); auto. -Qed. +End NoDupA. -Lemma filter_split : - forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> - forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l. -Proof. -induction l; simpl; intros; auto. -inversion_clear H0. -pattern l at 1; rewrite IHl; auto. -case_eq (f a); simpl; intros; auto. -assert (forall e, In e l -> f e = false). - intros. - assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)). - case_eq (f e); simpl; intros; auto. - elim (@ltA_not_eqA e e); auto. - apply ltA_trans with a; eauto. -replace (List.filter f l) with (@nil A); auto. -generalize H3; clear; induction l; simpl; auto. -case_eq (f a); auto; intros. -rewrite H3 in H; auto; try discriminate. -Qed. -End Filter. Section Fold. Variable B:Type. Variable eqB:B->B->Prop. - -(** Compatibility of a two-argument function with respect to two equalities. *) -Definition compat_op (f : A -> B -> B) := - forall (x x' : A) (y y' : B), eqA x x' -> eqB y y' -> eqB (f x y) (f x' y'). - -(** Two-argument functions that allow to reorder their arguments. *) -Definition transpose (f : A -> B -> B) := - forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). - -(** A version of transpose with restriction on where it should hold *) -Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) := - forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)). - Variable st:Equivalence eqB. Variable f:A->B->B. Variable i:B. -Variable Comp:compat_op f. +Variable Comp:Proper (eqA==>eqB==>eqB) f. -Lemma fold_right_eqlistA : - forall s s', eqlistA s s' -> +Lemma fold_right_eqlistA : + forall s s', eqlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). Proof. -induction 1; simpl; auto. -reflexivity. -Qed. - -Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y -> - NoDupA (x::l) -> NoDupA (l1++y::l2) -> - equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2). -Proof. - intros; intro a. - generalize (H2 a). - repeat rewrite InA_app_iff. - do 2 rewrite InA_cons. - inversion_clear H0. - assert (SW:=NoDupA_swap H1). - inversion_clear SW. - rewrite InA_app_iff in H0. - split; intros. - assert (~eqA a x). - contradict H3; apply InA_eqA with a; auto. - assert (~eqA a y). - contradict H8; eauto. - intuition. - assert (eqA a x \/ InA a l) by intuition. - destruct H8; auto. - elim H0. - destruct H7; [left|right]; eapply InA_eqA; eauto. +induction 1; simpl; auto with relations. +apply Comp; auto. Qed. -(** [ForallList2] : specifies that a certain binary predicate should - always hold when inspecting two different elements of the list. *) - -Inductive ForallList2 (R : A -> A -> Prop) : list A -> Prop := - | ForallNil : ForallList2 R nil - | ForallCons : forall a l, - (forall b, In b l -> R a b) -> - ForallList2 R l -> ForallList2 R (a::l). -Hint Constructors ForallList2. +(** Fold with restricted [transpose] hypothesis. *) -(** [NoDupA] can be written in terms of [ForallList2] *) - -Lemma ForallList2_NoDupA : forall l, - ForallList2 (fun a b => ~eqA a b) l <-> NoDupA l. -Proof. - induction l; split; intros; auto. - inversion_clear H. constructor; [ | rewrite <- IHl; auto ]. - rewrite InA_alt; intros (a',(Haa',Ha')). - exact (H0 a' Ha' Haa'). - inversion_clear H. constructor; [ | rewrite IHl; auto ]. - intros b Hb. - contradict H0. - rewrite InA_alt; exists b; auto. -Qed. +Section Fold_With_Restriction. +Variable R : A -> A -> Prop. +Hypothesis R_sym : Symmetric R. +Hypothesis R_compat : Proper (eqA==>eqA==>iff) R. -Lemma ForallList2_impl : forall (R R':A->A->Prop), - (forall a b, R a b -> R' a b) -> - forall l, ForallList2 R l -> ForallList2 R' l. -Proof. - induction 2; auto. -Qed. -(** The following definition is easier to use than [ForallList2]. *) +(* -Definition ForallList2_alt (R:A->A->Prop) l := - forall a b, InA a l -> InA b l -> ~eqA a b -> R a b. +(** [ForallOrdPairs R] is compatible with [equivlistA] over the + lists without duplicates, as long as the relation [R] + is symmetric and compatible with [eqA]. To prove this fact, + we use an auxiliary notion: "forall distinct pairs, ...". +*) -Section Restriction. -Variable R : A -> A -> Prop. +Definition ForallNeqPairs := + ForallPairs (fun a b => ~eqA a b -> R a b). -(** [ForallList2] and [ForallList2_alt] are related, but no completely +(** [ForallOrdPairs] and [ForallNeqPairs] are related, but not completely equivalent. For proving one implication, we need to know that the list has no duplicated elements... *) -Lemma ForallList2_equiv1 : forall l, NoDupA l -> - ForallList2_alt R l -> ForallList2 R l. +Lemma ForallNeqPairs_ForallOrdPairs : forall l, NoDupA l -> + ForallNeqPairs l -> ForallOrdPairs R l. Proof. induction l; auto. - constructor. intros b Hb. - inversion_clear H. - apply H0; auto. - contradict H1. - apply InA_eqA with b; auto. + constructor. inv. + rewrite Forall_forall; intros b Hb. + apply H0; simpl; auto. + contradict H1; rewrite H1; auto. apply IHl. - inversion_clear H; auto. + inv; auto. intros b c Hb Hc Hneq. - apply H0; auto. + apply H0; simpl; auto. Qed. (** ... and for proving the other implication, we need to be able - to reverse and adapt relation [R] modulo [eqA]. *) - -Hypothesis R_sym : forall a b, R a b -> R b a. -Hypothesis R_compat : forall a, compat_P (R a). + to reverse relation [R]. *) -Lemma ForallList2_equiv2 : forall l, - ForallList2 R l -> ForallList2_alt R l. +Lemma ForallOrdPairs_ForallNeqPairs : forall l, + ForallOrdPairs R l -> ForallNeqPairs l. Proof. - induction l. - intros _. red. intros a b Ha. inversion Ha. - inversion_clear 1 as [|? ? H_R Hl]. - intros b c Hb Hc Hneq. - inversion_clear Hb; inversion_clear Hc. - (* b,c = a : impossible *) - elim Hneq; eauto. - (* b = a, c in l *) - rewrite InA_alt in H0; destruct H0 as (d,(Hcd,Hd)). - apply R_compat with d; auto. - apply R_sym; apply R_compat with a; auto. - (* b in l, c = a *) - rewrite InA_alt in H; destruct H as (d,(Hcd,Hd)). - apply R_compat with a; auto. - apply R_sym; apply R_compat with d; auto. - (* b,c in l *) - apply (IHl Hl); auto. + intros l Hl x y Hx Hy N. + destruct (ForallOrdPairs_In Hl x y Hx Hy) as [H|[H|H]]. + subst; elim N; auto. + assumption. + apply R_sym; assumption. Qed. -Lemma ForallList2_equiv : forall l, NoDupA l -> - (ForallList2 R l <-> ForallList2_alt R l). -Proof. -split; [apply ForallList2_equiv2|apply ForallList2_equiv1]; auto. -Qed. +*) + +(** Compatibility of [ForallOrdPairs] with respect to [inclA]. *) -Lemma ForallList2_equivlistA : forall l l', NoDupA l' -> - equivlistA l l' -> ForallList2 R l -> ForallList2 R l'. +Lemma ForallOrdPairs_inclA : forall l l', + NoDupA l' -> inclA l' l -> ForallOrdPairs R l -> ForallOrdPairs R l'. Proof. -intros. -apply ForallList2_equiv1; auto. -intros a b Ha Hb Hneq. -red in H0; rewrite <- H0 in Ha,Hb. -revert a b Ha Hb Hneq. -change (ForallList2_alt R l). -apply ForallList2_equiv2; auto. +induction l' as [|x l' IH]. +constructor. +intros ND Incl FOP. apply FOP_cons; inv; unfold inclA in *; auto. +rewrite Forall_forall; intros y Hy. +assert (Ix : InA x (x::l')) by (rewrite InA_cons; auto). + apply Incl in Ix. rewrite InA_alt in Ix. destruct Ix as (x' & Hxx' & Hx'). +assert (Iy : InA y (x::l')) by (apply In_InA; simpl; auto). + apply Incl in Iy. rewrite InA_alt in Iy. destruct Iy as (y' & Hyy' & Hy'). +rewrite Hxx', Hyy'. +destruct (ForallOrdPairs_In FOP x' y' Hx' Hy') as [E|[?|?]]; auto. +absurd (InA x l'); auto. rewrite Hxx', E, <- Hyy'; auto. Qed. + +(** Two-argument functions that allow to reorder their arguments. *) +Definition transpose (f : A -> B -> B) := + forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). + +(** A version of transpose with restriction on where it should hold *) +Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) := + forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)). + Variable TraR :transpose_restr R f. Lemma fold_right_commutes_restr : - forall s1 s2 x, ForallList2 R (s1++x::s2) -> + forall s1 s2 x, ForallOrdPairs R (s1++x::s2) -> eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). Proof. induction s1; simpl; auto; intros. @@ -602,15 +400,15 @@ reflexivity. transitivity (f a (f x (fold_right f i (s1++s2)))). apply Comp; auto. apply IHs1. -inversion_clear H; auto. +invlist ForallOrdPairs; auto. apply TraR. -inversion_clear H. -apply H0. +invlist ForallOrdPairs; auto. +rewrite Forall_forall in H0; apply H0. apply in_or_app; simpl; auto. Qed. Lemma fold_right_equivlistA_restr : - forall s s', NoDupA s -> NoDupA s' -> ForallList2 R s -> + forall s s', NoDupA s -> NoDupA s' -> ForallOrdPairs R s -> equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). Proof. simple induction s. @@ -618,35 +416,35 @@ Proof. intros; reflexivity. unfold equivlistA; intros. destruct (H2 a). - assert (X : InA a nil); auto; inversion X. + assert (InA a nil) by auto; inv. intros x l Hrec s' N N' F E; simpl in *. - assert (InA x s'). - rewrite <- (E x); auto. + 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 i (s1++s2))). apply Comp; auto. apply Hrec; auto. - inversion_clear N; auto. + inv; auto. eapply NoDupA_split; eauto. - inversion_clear F; auto. + invlist ForallOrdPairs; auto. eapply equivlistA_NoDupA_split; eauto. transitivity (f y (fold_right f i (s1++s2))). apply Comp; auto. reflexivity. symmetry; apply fold_right_commutes_restr. - apply ForallList2_equivlistA with (x::l); auto. + apply ForallOrdPairs_inclA with (x::l); auto. + red; intros; rewrite E; auto. Qed. Lemma fold_right_add_restr : - forall s' s x, NoDupA s -> NoDupA s' -> ForallList2 R s' -> ~ InA x s -> + forall s' s x, NoDupA s -> NoDupA s' -> ForallOrdPairs R s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). Proof. intros; apply (@fold_right_equivlistA_restr s' (x::s)); auto. Qed. -End Restriction. +End Fold_With_Restriction. -(** we know state similar results, but without restriction on transpose. *) +(** we now state similar results, but without restriction on transpose. *) Variable Tra :transpose f. @@ -656,6 +454,7 @@ Proof. induction s1; simpl; auto; intros. reflexivity. transitivity (f a (f x (fold_right f i (s1++s2)))); auto. +apply Comp; auto. Qed. Lemma fold_right_equivlistA : @@ -663,8 +462,8 @@ Lemma fold_right_equivlistA : equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). Proof. intros; apply fold_right_equivlistA_restr with (R:=fun _ _ => True); - try red; auto. -apply ForallList2_equiv1; try red; auto. + repeat red; auto. +apply ForallPairs_ForallOrdPairs; try red; auto. Qed. Lemma fold_right_add : @@ -674,6 +473,8 @@ Proof. intros; apply (@fold_right_equivlistA s' (x::s)); auto. Qed. +End Fold. + Section Remove. Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. @@ -682,15 +483,15 @@ Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }. Proof. induction l. right; auto. -red; inversion 1. +intro; inv. destruct (eqA_dec x a). left; auto. destruct IHl. left; auto. -right; red; inversion_clear 1; contradiction. -Qed. +right; intro; inv; contradiction. +Defined. -Fixpoint removeA (x : A) (l : list A){struct l} : list A := +Fixpoint removeA (x : A) (l : list A) : list A := match l with | nil => nil | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl) @@ -708,21 +509,21 @@ Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y. Proof. induction l; simpl; auto. split. -inversion_clear 1. -destruct 1; inversion_clear H. +intro; inv. +destruct 1; inv. intros. destruct (eqA_dec x a); simpl; auto. rewrite IHl; split; destruct 1; split; auto. -inversion_clear H; auto. -destruct H0; apply eqA_trans with a; auto. +inv; auto. +destruct H0; transitivity a; auto. split. -inversion_clear 1. +intro; inv. split; auto. contradict n. -apply eqA_trans with y; auto. +transitivity y; auto. rewrite (IHl x y) in H0; destruct H0; auto. -destruct 1; inversion_clear H; auto. -constructor 2; rewrite IHl; auto. +destruct 1; inv; auto. +right; rewrite IHl; auto. Qed. Lemma removeA_NoDupA : @@ -730,17 +531,17 @@ Lemma removeA_NoDupA : Proof. simple induction s; simpl; intros. auto. -inversion_clear H0. -destruct (eqA_dec x a); simpl; auto. +inv. +destruct (eqA_dec x a); simpl; auto. constructor; auto. rewrite removeA_InA. intuition. -Qed. +Qed. -Lemma removeA_equivlistA : forall l l' x, +Lemma removeA_equivlistA : forall l l' x, ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l'). -Proof. -unfold equivlistA; intros. +Proof. +unfold equivlistA; intros. rewrite removeA_InA. split; intros. rewrite <- H0; split; auto. @@ -748,64 +549,306 @@ contradict H. apply InA_eqA with x0; auto. rewrite <- (H0 x0) in H1. destruct H1. -inversion_clear H1; auto. +inv; auto. elim H2; auto. Qed. End Remove. -End Fold. + +(** Results concerning lists modulo [eqA] and [ltA] *) + +Variable ltA : A -> A -> Prop. +Hypothesis ltA_strorder : StrictOrder ltA. +Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA. + +Hint Resolve (@StrictOrder_Transitive _ _ ltA_strorder). + +Notation InfA:=(lelistA ltA). +Notation SortA:=(sort ltA). + +Hint Constructors lelistA sort. + +Lemma InfA_ltA : + forall l x y, ltA x y -> InfA y l -> InfA x l. +Proof. + destruct l; constructor. inv; eauto. +Qed. + +Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA. +Proof. + intros x x' Hxx' l l' Hll'. + inversion_clear Hll'. + intuition. + split; intro; inv; constructor. + rewrite <- Hxx', <- H; auto. + rewrite Hxx', H; auto. +Qed. + +(** For compatibility, can be deduced from [InfA_compat] *) +Lemma InfA_eqA : + forall l x y, eqA x y -> InfA y l -> InfA x l. +Proof. + intros l x y H; rewrite H; auto. +Qed. +Hint Immediate InfA_ltA InfA_eqA. + +Lemma SortA_InfA_InA : + forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. +Proof. + simple induction l. + intros. inv. + intros. inv. + setoid_replace x with a; auto. + eauto. +Qed. + +Lemma In_InfA : + forall l x, (forall y, In y l -> ltA x y) -> InfA x l. +Proof. + simple induction l; simpl; intros; constructor; auto. +Qed. + +Lemma InA_InfA : + forall l x, (forall y, InA y l -> ltA x y) -> InfA x l. +Proof. + simple induction l; simpl; intros; constructor; auto. +Qed. + +(* In fact, this may be used as an alternative definition for InfA: *) + +Lemma InfA_alt : + forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)). +Proof. +split. +intros; eapply SortA_InfA_InA; eauto. +apply InA_InfA. +Qed. + +Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2). +Proof. + induction l1; simpl; auto. + intros; inv; auto. +Qed. + +Lemma SortA_app : + forall l1 l2, SortA l1 -> SortA l2 -> + (forall x y, InA x l1 -> InA y l2 -> ltA x y) -> + SortA (l1 ++ l2). +Proof. + induction l1; simpl in *; intuition. + inv. + constructor; auto. + apply InfA_app; auto. + destruct l2; auto. +Qed. + +Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l. +Proof. + simple induction l; auto. + intros x l' H H0. + inv. + constructor; auto. + intro. + apply (StrictOrder_Irreflexive x). + eapply SortA_InfA_InA; eauto. +Qed. + + +(** Some results about [eqlistA] *) + +Section EqlistA. + +Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'. +Proof. +induction 1; auto; simpl; congruence. +Qed. + +Global Instance app_eqlistA_compat : + Proper (eqlistA==>eqlistA==>eqlistA) (@app A). +Proof. + repeat red; induction 1; simpl; auto. +Qed. + +(** For compatibility, can be deduced from app_eqlistA_compat **) +Lemma eqlistA_app : forall l1 l1' l2 l2', + eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2'). +Proof. +intros l1 l1' l2 l2' H H'; rewrite H, H'; reflexivity. +Qed. + +Lemma eqlistA_rev_app : forall l1 l1', + eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' -> + eqlistA ((rev l1)++l2) ((rev l1')++l2'). +Proof. +induction 1; auto. +simpl; intros. +do 2 rewrite app_ass; simpl; auto. +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)). +apply eqlistA_rev_app; auto. +Qed. + +Lemma eqlistA_rev : forall l1 l1', + eqlistA l1 l1' -> eqlistA (rev l1) (rev l1'). +Proof. +apply rev_eqlistA_compat. +Qed. + +Lemma SortA_equivlistA_eqlistA : forall l l', + SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'. +Proof. +induction l; destruct l'; simpl; intros; auto. +destruct (H1 a); assert (InA a nil) by auto; inv. +destruct (H1 a); assert (InA a nil) by auto; inv. +inv. +assert (forall y, InA y l -> ltA a y). +intros; eapply SortA_InfA_InA with (l:=l); eauto. +assert (forall y, InA y l' -> ltA a0 y). +intros; eapply SortA_InfA_InA with (l:=l'); eauto. +clear H3 H4. +assert (eqA a a0). + destruct (H1 a). + destruct (H1 a0). + assert (InA a (a0::l')) by auto. inv; auto. + assert (InA a0 (a::l)) by auto. inv; auto. + elim (StrictOrder_Irreflexive a); eauto. +constructor; auto. +apply IHl; auto. +split; intros. +destruct (H1 x). +assert (InA x (a0::l')) by auto. inv; auto. +rewrite H9,<-H3 in H4. elim (StrictOrder_Irreflexive a); eauto. +destruct (H1 x). +assert (InA x (a::l)) by auto. inv; auto. +rewrite H9,H3 in H4. elim (StrictOrder_Irreflexive a0); eauto. +Qed. + +End EqlistA. + +(** A few things about [filter] *) + +Section Filter. + +Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l). +Proof. +induction l; simpl; auto. +intros; inv; auto. +destruct (f a); auto. +constructor; auto. +apply In_InfA; auto. +intros. +rewrite filter_In in H; destruct H. +eapply SortA_InfA_InA; eauto. +Qed. + +Implicit Arguments eq [ [A] ]. + +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. +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. + rewrite (H _ _ H0); auto. +destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition. + rewrite <- (H _ _ H0); auto. +Qed. + +Lemma filter_split : + forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> + forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l. +Proof. +induction l; simpl; intros; auto. +inv. +rewrite IHl at 1; auto. +case_eq (f a); simpl; intros; auto. +assert (forall e, In e l -> f e = false). + intros. + assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)). + case_eq (f e); simpl; intros; auto. + elim (StrictOrder_Irreflexive e). + transitivity a; auto. +replace (List.filter f l) with (@nil A); auto. +generalize H3; clear; induction l; simpl; auto. +case_eq (f a); auto; intros. +rewrite H3 in H; auto; try discriminate. +Qed. + +End Filter. End Type_with_equality. -Hint Unfold compat_bool compat_nat compat_P. -Hint Constructors InA NoDupA sort lelistA eqlistA. -Section Find. -Variable A B : Type. -Variable eqA : A -> A -> Prop. -Hypothesis eqA_sym : forall x y, eqA x y -> eqA y x. -Hypothesis eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z. +Hint Constructors InA eqlistA NoDupA sort lelistA. + +Section Find. + +Variable A B : Type. +Variable eqA : A -> A -> Prop. +Hypothesis eqA_equiv : Equivalence eqA. Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. -Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B := - match l with - | nil => None +Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B := + match l with + | nil => None | (a,b)::l => if f a then Some b else findA f l end. -Lemma findA_NoDupA : - forall l a b, - NoDupA (fun p p' => eqA (fst p) (fst p')) l -> +Lemma findA_NoDupA : + forall l a b, + NoDupA (fun p p' => eqA (fst p) (fst p')) l -> (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <-> findA (fun a' => if eqA_dec a a' then true else false) l = Some b). Proof. -induction l; simpl; intros. +set (eqk := fun p p' : A*B => eqA (fst p) (fst p')). +set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p'). +induction l; intros; simpl. split; intros; try discriminate. -inversion H0. +invlist InA. destruct a as (a',b'); rename a0 into a. -inversion_clear H. +invlist NoDupA. split; intros. -inversion_clear H. -simpl in *; destruct H2; subst b'. +invlist InA. +compute in H2; destruct H2. subst b'. destruct (eqA_dec a a'); intuition. destruct (eqA_dec a a'); simpl. -destruct H0. -generalize e H2 eqA_trans eqA_sym; clear. +contradict H0. +revert e H2; clear - eqA_equiv. induction l. -inversion 2. -inversion_clear 2; intros; auto. +intros; invlist InA. +intros; invlist InA; auto. destruct a0. compute in H; destruct H. subst b. -constructor 1; auto. -simpl. -apply eqA_trans with a; auto. +left; auto. +compute. +transitivity a; auto. symmetry; auto. rewrite <- IHl; auto. destruct (eqA_dec a a'); simpl in *. -inversion H; clear H; intros; subst b'; auto. -constructor 2. -rewrite IHl; auto. +left; split; simpl; congruence. +right. rewrite IHl; auto. Qed. -End Find. +End Find. + + +(** Compatibility aliases. [Proper] is rather to be used directly now.*) + +Definition compat_bool {A} (eqA:A->A->Prop)(f:A->bool) := + Proper (eqA==>Logic.eq) f. + +Definition compat_nat {A} (eqA:A->A->Prop)(f:A->nat) := + Proper (eqA==>Logic.eq) f. + +Definition compat_P {A} (eqA:A->A->Prop)(P:A->Prop) := + Proper (eqA==>impl) P. + +Definition compat_op {A B} (eqA:A->A->Prop)(eqB:B->B->Prop)(f:A->B->B) := + Proper (eqA==>eqB==>eqB) f. + diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index bdbe0ecc..d906cfa4 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -11,8 +11,8 @@ Require Import Streams. (** * Memoization *) -(** Successive outputs of a given function [f] are stored in - a stream in order to avoid duplicated computations. *) +(** Successive outputs of a given function [f] are stored in + a stream in order to avoid duplicated computations. *) Section MemoFunction. @@ -24,8 +24,8 @@ CoFixpoint memo_make (n:nat) : Stream A := Cons (f n) (memo_make (S n)). Definition memo_list := memo_make 0. Fixpoint memo_get (n:nat) (l:Stream A) : A := - match n with - | O => hd l + match n with + | O => hd l | S n1 => memo_get n1 (tl l) end. @@ -49,7 +49,7 @@ Variable g: A -> A. Hypothesis Hg_correct: forall n, f (S n) = g (f n). CoFixpoint imemo_make (fn:A) : Stream A := - let fn1 := g fn in + let fn1 := g fn in Cons fn1 (imemo_make fn1). Definition imemo_list := let f0 := f 0 in @@ -68,7 +68,7 @@ Qed. End MemoFunction. -(** For a dependent function, the previous solution is +(** For a dependent function, the previous solution is reused thanks to a temporarly hiding of the dependency in a "container" [memo_val]. *) @@ -80,7 +80,7 @@ Variable f: forall n, A n. Inductive memo_val: Type := memo_mval: forall n, A n -> memo_val. -Fixpoint is_eq (n m : nat) {struct n}: {n = m} + {True} := +Fixpoint is_eq (n m : nat) : {n = m} + {True} := match n, m return {n = m} + {True} with | 0, 0 =>left True (refl_equal 0) | 0, S m1 => right (0 = S m1) I @@ -88,7 +88,7 @@ Fixpoint is_eq (n m : nat) {struct n}: {n = m} + {True} := | S n1, S m1 => match is_eq n1 m1 with | left H => left True (f_equal S H) - | right _ => right (S n1 = S m1) I + | right _ => right (S n1 = S m1) I end end. @@ -97,7 +97,7 @@ match v with | memo_mval m x => match is_eq n m with | left H => - match H in (@eq _ _ y) return (A y -> A n) with + match H in (eq _ y) return (A y -> A n) with | refl_equal => fun v1 : A n => v1 end | right _ => fun _ : A m => f n @@ -134,7 +134,7 @@ Variable g: forall n, A n -> A (S n). Hypothesis Hg_correct: forall n, f (S n) = g n (f n). -Let mg v := match v with +Let mg v := match v with memo_mval n1 v1 => memo_mval (S n1) (g n1 v1) end. Definition dimemo_list := imemo_list _ mf mg. @@ -166,13 +166,13 @@ End DependentMemoFunction. Require Import ZArith. Open Scope Z_scope. -Fixpoint tfact (n: nat) := - match n with - | O => 1 - | S n1 => Z_of_nat n * tfact n1 +Fixpoint tfact (n: nat) := + match n with + | O => 1 + | S n1 => Z_of_nat n * tfact n1 end. -Definition lfact_list := +Definition lfact_list := dimemo_list _ tfact (fun n z => (Z_of_nat (S n) * z)). Definition lfact n := dmemo_get _ tfact n lfact_list. @@ -183,18 +183,18 @@ intros n; unfold lfact, lfact_list. rewrite dimemo_get_correct; auto. Qed. -Fixpoint nop p := +Fixpoint nop p := match p with - | xH => 0 - | xI p1 => nop p1 - | xO p1 => nop p1 + | xH => 0 + | xI p1 => nop p1 + | xO p1 => nop p1 end. -Fixpoint test z := +Fixpoint test z := match z with - | Z0 => 0 - | Zpos p1 => nop p1 - | Zneg p1 => nop p1 + | Z0 => 0 + | Zpos p1 => nop p1 + | Zneg p1 => nop p1 end. Time Eval vm_compute in test (lfact 2000). @@ -202,4 +202,4 @@ Time Eval vm_compute in test (lfact 2000). Time Eval vm_compute in test (lfact 1500). Time Eval vm_compute in (lfact 1500). *) - + diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 49990502..3fa053b7 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Streams.v 9967 2007-07-11 15:25:03Z roconnor $ i*) +(*i $Id$ i*) Set Implicit Arguments. @@ -29,7 +29,7 @@ Definition tl (x:Stream) := match x with end. -Fixpoint Str_nth_tl (n:nat) (s:Stream) {struct n} : Stream := +Fixpoint Str_nth_tl (n:nat) (s:Stream) : Stream := match n with | O => s | S m => Str_nth_tl m (tl s) @@ -41,7 +41,7 @@ Definition Str_nth (n:nat) (s:Stream) : A := hd (Str_nth_tl n s). Lemma unfold_Stream : forall x:Stream, x = match x with | Cons a s => Cons a s - end. + end. Proof. intro x. case x. @@ -223,7 +223,7 @@ Variable f: A -> B -> C. CoFixpoint zipWith (a:Stream A) (b:Stream B) : Stream C := Cons (f (hd a) (hd b)) (zipWith (tl a) (tl b)). -Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B), +Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B), Str_nth_tl n (zipWith a b)= zipWith (Str_nth_tl n a) (Str_nth_tl n b). Proof. induction n. diff --git a/theories/Lists/TheoryList.v b/theories/Lists/TheoryList.v index 2bfb70fe..7ed9c519 100644 --- a/theories/Lists/TheoryList.v +++ b/theories/Lists/TheoryList.v @@ -6,12 +6,16 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: TheoryList.v 8866 2006-05-28 16:21:04Z herbelin $ i*) +(*i $Id$ i*) (** Some programs and results about lists following CAML Manual *) Require Export List. Set Implicit Arguments. + +Local Notation "[ ]" := nil (at level 0). +Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) (at level 0). + Section Lists. Variable A : Type. @@ -23,11 +27,13 @@ Variable A : Type. Definition Isnil (l:list A) : Prop := nil = l. Lemma Isnil_nil : Isnil nil. +Proof. red in |- *; auto. Qed. Hint Resolve Isnil_nil. Lemma not_Isnil_cons : forall (a:A) (l:list A), ~ Isnil (a :: l). +Proof. unfold Isnil in |- *. intros; discriminate. Qed. @@ -35,6 +41,7 @@ Qed. Hint Resolve Isnil_nil not_Isnil_cons. Lemma Isnil_dec : forall l:list A, {Isnil l} + {~ Isnil l}. +Proof. intro l; case l; auto. (* Realizer (fun l => match l with @@ -50,6 +57,7 @@ Qed. Lemma Uncons : forall l:list A, {a : A & {m : list A | a :: m = l}} + {Isnil l}. +Proof. intro l; case l. auto. intros a m; intros; left; exists a; exists m; reflexivity. @@ -67,6 +75,7 @@ Qed. Lemma Hd : forall l:list A, {a : A | exists m : list A, a :: m = l} + {Isnil l}. +Proof. intro l; case l. auto. intros a m; intros; left; exists a; exists m; reflexivity. @@ -81,6 +90,7 @@ Qed. Lemma Tl : forall l:list A, {m : list A | (exists a : A, a :: m = l) \/ Isnil l /\ Isnil m}. +Proof. intro l; case l. exists (nil (A:=A)); auto. intros a m; intros; exists m; left; exists a; reflexivity. @@ -97,7 +107,7 @@ Qed. (****************************************) (* length is defined in List *) -Fixpoint Length_l (l:list A) (n:nat) {struct l} : nat := +Fixpoint Length_l (l:list A) (n:nat) : nat := match l with | nil => n | _ :: m => Length_l m (S n) @@ -105,6 +115,7 @@ Fixpoint Length_l (l:list A) (n:nat) {struct l} : nat := (* A tail recursive version *) Lemma Length_l_pf : forall (l:list A) (n:nat), {m : nat | n + length l = m}. +Proof. induction l as [| a m lrec]. intro n; exists n; simpl in |- *; auto. intro n; elim (lrec (S n)); simpl in |- *; intros. @@ -115,6 +126,7 @@ Realizer Length_l. Qed. Lemma Length : forall l:list A, {m : nat | length l = m}. +Proof. intro l. apply (Length_l_pf l 0). (* Realizer (fun l -> Length_l_pf l O). @@ -139,14 +151,9 @@ elim l; intros; elim H; auto. Qed. -Inductive AllS (P:A -> Prop) : list A -> Prop := - | allS_nil : AllS P nil - | allS_cons : forall (a:A) (l:list A), P a -> AllS P l -> AllS P (a :: l). -Hint Resolve allS_nil allS_cons. - Hypothesis eqA_dec : forall a b:A, {a = b} + {a <> b}. -Fixpoint mem (a:A) (l:list A) {struct l} : bool := +Fixpoint mem (a:A) (l:list A) : bool := match l with | nil => false | b :: m => if eqA_dec a b then true else mem a m @@ -154,7 +161,7 @@ Fixpoint mem (a:A) (l:list A) {struct l} : bool := Hint Unfold In. Lemma Mem : forall (a:A) (l:list A), {In a l} + {AllS (fun b:A => b <> a) l}. -intros a l. +Proof. induction l. auto. elim (eqA_dec a a0). @@ -188,20 +195,23 @@ Hint Resolve fst_nth_O fst_nth_S. Lemma fst_nth_nth : forall (l:list A) (n:nat) (a:A), fst_nth_spec l n a -> nth_spec l n a. +Proof. induction 1; auto. Qed. Hint Immediate fst_nth_nth. Lemma nth_lt_O : forall (l:list A) (n:nat) (a:A), nth_spec l n a -> 0 < n. +Proof. induction 1; auto. Qed. Lemma nth_le_length : forall (l:list A) (n:nat) (a:A), nth_spec l n a -> n <= length l. +Proof. induction 1; simpl in |- *; auto with arith. Qed. -Fixpoint Nth_func (l:list A) (n:nat) {struct l} : Exc A := +Fixpoint Nth_func (l:list A) (n:nat) : Exc A := match l, n with | a :: _, S O => value a | _ :: l', S (S p) => Nth_func l' (S p) @@ -211,6 +221,7 @@ Fixpoint Nth_func (l:list A) (n:nat) {struct l} : Exc A := Lemma Nth : forall (l:list A) (n:nat), {a : A | nth_spec l n a} + {n = 0 \/ length l < n}. +Proof. induction l as [| a l IHl]. intro n; case n; simpl in |- *; auto with arith. intro n; destruct n as [| [| n1]]; simpl in |- *; auto. @@ -227,6 +238,7 @@ Qed. Lemma Item : forall (l:list A) (n:nat), {a : A | nth_spec l (S n) a} + {length l <= n}. +Proof. intros l n; case (Nth l (S n)); intro. case s; intro a; left; exists a; auto. right; case o; intro. @@ -237,7 +249,7 @@ Qed. Require Import Minus. Require Import DecBool. -Fixpoint index_p (a:A) (l:list A) {struct l} : nat -> Exc nat := +Fixpoint index_p (a:A) (l:list A) : nat -> Exc nat := match l with | nil => fun p => error | b :: m => fun p => ifdec (eqA_dec a b) (value p) (index_p a m (S p)) @@ -246,6 +258,7 @@ Fixpoint index_p (a:A) (l:list A) {struct l} : nat -> Exc nat := Lemma Index_p : forall (a:A) (l:list A) (p:nat), {n : nat | fst_nth_spec l (S n - p) a} + {AllS (fun b:A => a <> b) l}. +Proof. induction l as [| b m irec]. auto. intro p. @@ -264,6 +277,7 @@ Lemma Index : forall (a:A) (l:list A), {n : nat | fst_nth_spec l n a} + {AllS (fun b:A => a <> b) l}. +Proof. intros a l; case (Index_p a l 1); auto. intros [n P]; left; exists n; auto. rewrite (minus_n_O n); trivial. @@ -287,20 +301,24 @@ Definition InR_inv (l:list A) := end. Lemma InR_INV : forall l:list A, InR l -> InR_inv l. +Proof. induction 1; simpl in |- *; auto. Qed. Lemma InR_cons_inv : forall (a:A) (l:list A), InR (a :: l) -> R a \/ InR l. +Proof. intros a l H; exact (InR_INV H). Qed. Lemma InR_or_app : forall l m:list A, InR l \/ InR m -> InR (l ++ m). +Proof. intros l m [| ]. induction 1; simpl in |- *; auto. intro. induction l; simpl in |- *; auto. Qed. Lemma InR_app_or : forall l m:list A, InR (l ++ m) -> InR l \/ InR m. +Proof. intros l m; elim l; simpl in |- *; auto. intros b l' Hrec IAc; elim (InR_cons_inv IAc); auto. intros; elim Hrec; auto. @@ -315,6 +333,7 @@ Fixpoint find (l:list A) : Exc A := end. Lemma Find : forall l:list A, {a : A | In a l & R a} + {AllS P l}. +Proof. induction l as [| a m [[b H1 H2]| H]]; auto. left; exists b; auto. destruct (RS_dec a). @@ -342,6 +361,7 @@ Fixpoint try_find (l:list A) : Exc B := Lemma Try_find : forall l:list A, {c : B | exists2 a : A, In a l & T a c} + {AllS P l}. +Proof. induction l as [| a m [[b H1]| H]]. auto. left; exists b; destruct H1 as [a' H2 H3]; exists a'; auto. @@ -349,7 +369,7 @@ destruct (TS_dec a) as [[c H1]| ]. left; exists c. exists a; auto. auto. -(* +(* Realizer try_find. *) Qed. @@ -359,7 +379,7 @@ End Find_sec. Section Assoc_sec. Variable B : Type. -Fixpoint assoc (a:A) (l:list (A * B)) {struct l} : +Fixpoint assoc (a:A) (l:list (A * B)) : Exc B := match l with | nil => error @@ -383,6 +403,7 @@ Hint Resolve allS_assoc_nil allS_assoc_cons. Lemma Assoc : forall (a:A) (l:list (A * B)), B + {AllS_assoc (fun a':A => a <> a') l}. +Proof. induction l as [| [a' b] m assrec]. auto. destruct (eqA_dec a a'). left; exact b. @@ -398,6 +419,5 @@ End Assoc_sec. End Lists. -Hint Resolve Isnil_nil not_Isnil_cons in_hd in_tl in_cons allS_nil allS_cons: - datatypes. +Hint Resolve Isnil_nil not_Isnil_cons in_hd in_tl in_cons : datatypes. Hint Immediate fst_nth_nth: datatypes. diff --git a/theories/Lists/intro.tex b/theories/Lists/intro.tex index c45f8803..0051e2c2 100755 --- a/theories/Lists/intro.tex +++ b/theories/Lists/intro.tex @@ -21,7 +21,4 @@ This library includes the following files: coinductive type. Basic facts are stated and proved. The streams are also polymorphic. -\item {\tt MonoList.v} THIS OLD LIBRARY IS HERE ONLY FOR COMPATIBILITY - WITH OLDER VERSIONS OF COQ. THE USER SHOULD USE {\tt List.v} INSTEAD. - \end{itemize} diff --git a/theories/Lists/vo.itarget b/theories/Lists/vo.itarget new file mode 100644 index 00000000..d2a31367 --- /dev/null +++ b/theories/Lists/vo.itarget @@ -0,0 +1,7 @@ +ListSet.vo +ListTactics.vo +List.vo +SetoidList.vo +StreamMemo.vo +Streams.vo +TheoryList.vo diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index 9eaef07a..5b2f5063 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Berardi.v 8122 2006-03-04 19:26:40Z herbelin $ i*) +(*i $Id$ i*) (** This file formalizes Berardi's paradox which says that in the calculus of constructions, excluded middle (EM) and axiom of @@ -67,10 +67,10 @@ Section Retracts. Variables A B : Prop. -Record retract : Prop := +Record retract : Prop := {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}. -Record retract_cond : Prop := +Record retract_cond : Prop := {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}. @@ -94,7 +94,7 @@ Proof. intros A B. destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf]. exists f0 g0; trivial. - exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; + exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; destruct hf; auto. Qed. diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 3d434b37..b2c4a049 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Dependent choice -> Countable choice + References: [[Bell]] John L. Bell, Choice principles in intuitionistic set theory, @@ -81,7 +86,7 @@ unpublished. [[Bell93]] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic Type Theories, Mathematical Logic Quarterly, volume 39, 1993. -[Carlstrm05] Jesper Carlstrm, Interpreting descriptions in +[[Carlström05]] Jesper Carlström, Interpreting descriptions in intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005. *) @@ -116,6 +121,20 @@ Definition FunctionalChoice_on := (forall x : A, exists y : B, R x y) -> (exists f : A->B, forall x : A, R x (f x)). +(** DC_fun *) + +Definition FunctionalDependentChoice_on := + forall (R:A->A->Prop), + (forall x, exists y, R x y) -> forall x0, + (exists f : nat -> A, f 0 = x0 /\ forall n, R (f n) (f (S n))). + +(** ACw_fun *) + +Definition FunctionalCountableChoice_on := + forall (R:nat->A->Prop), + (forall n, exists y, R n y) -> + (exists f : nat -> A, forall n, R n (f n)). + (** AC! or Functional Relation Reification (known as Axiom of Unique Choice in topos theory; also called principle of definite description *) @@ -126,7 +145,7 @@ Definition FunctionalRelReification_on := (** ID_epsilon (constructive version of indefinite description; combined with proof-irrelevance, it may be connected to - Carlstrm's type theory with a constructive indefinite description + Carlström's type theory with a constructive indefinite description operator) *) Definition ConstructiveIndefiniteDescription_on := @@ -134,7 +153,7 @@ Definition ConstructiveIndefiniteDescription_on := (exists x, P x) -> { x:A | P x }. (** ID_iota (constructive version of definite description; combined - with proof-irrelevance, it may be connected to Carlstrm's and + with proof-irrelevance, it may be connected to Carlström's and Stenlund's type theory with a constructive definite description operator) *) @@ -146,16 +165,16 @@ Definition ConstructiveDefiniteDescription_on := (** GAC_rel *) -Definition GuardedRelationalChoice_on := +Definition GuardedRelationalChoice_on := forall P : A->Prop, forall R : A->B->Prop, (forall x : A, P x -> exists y : B, R x y) -> - (exists R' : A->B->Prop, + (exists R' : A->B->Prop, subrelation R' R /\ forall x, P x -> exists! y, R' x y). (** GAC_fun *) -Definition GuardedFunctionalChoice_on := - forall P : A->Prop, forall R : A->B->Prop, +Definition GuardedFunctionalChoice_on := + forall P : A->Prop, forall R : A->B->Prop, inhabited B -> (forall x : A, P x -> exists y : B, R x y) -> (exists f : A->B, forall x, P x -> R x (f x)). @@ -163,34 +182,34 @@ Definition GuardedFunctionalChoice_on := (** GFR_fun *) Definition GuardedFunctionalRelReification_on := - forall P : A->Prop, forall R : A->B->Prop, + forall P : A->Prop, forall R : A->B->Prop, inhabited B -> (forall x : A, P x -> exists! y : B, R x y) -> (exists f : A->B, forall x : A, P x -> R x (f x)). (** OAC_rel *) -Definition OmniscientRelationalChoice_on := +Definition OmniscientRelationalChoice_on := forall R : A->B->Prop, - exists R' : A->B->Prop, + exists R' : A->B->Prop, subrelation R' R /\ forall x : A, (exists y : B, R x y) -> exists! y, R' x y. (** OAC_fun *) -Definition OmniscientFunctionalChoice_on := - forall R : A->B->Prop, +Definition OmniscientFunctionalChoice_on := + forall R : A->B->Prop, inhabited B -> exists f : A->B, forall x : A, (exists y : B, R x y) -> R x (f x). (** D_epsilon *) -Definition EpsilonStatement_on := +Definition EpsilonStatement_on := forall P:A->Prop, inhabited A -> { x:A | (exists x, P x) -> P x }. (** D_iota *) -Definition IotaStatement_on := +Definition IotaStatement_on := forall P:A->Prop, inhabited A -> { x:A | (exists! x, P x) -> P x }. @@ -202,12 +221,16 @@ Notation RelationalChoice := (forall A B, RelationalChoice_on A B). Notation FunctionalChoice := (forall A B, FunctionalChoice_on A B). +Definition FunctionalDependentChoice := + (forall A, FunctionalDependentChoice_on A). +Definition FunctionalCountableChoice := + (forall A, FunctionalCountableChoice_on A). Notation FunctionalChoiceOnInhabitedSet := (forall A B, inhabited B -> FunctionalChoice_on A B). Notation FunctionalRelReification := (forall A B, FunctionalRelReification_on A B). -Notation GuardedRelationalChoice := +Notation GuardedRelationalChoice := (forall A B, GuardedRelationalChoice_on A B). Notation GuardedFunctionalChoice := (forall A B, GuardedFunctionalChoice_on A B). @@ -219,14 +242,14 @@ Notation OmniscientRelationalChoice := Notation OmniscientFunctionalChoice := (forall A B, OmniscientFunctionalChoice_on A B). -Notation ConstructiveDefiniteDescription := +Notation ConstructiveDefiniteDescription := (forall A, ConstructiveDefiniteDescription_on A). -Notation ConstructiveIndefiniteDescription := +Notation ConstructiveIndefiniteDescription := (forall A, ConstructiveIndefiniteDescription_on A). -Notation IotaStatement := +Notation IotaStatement := (forall A, IotaStatement_on A). -Notation EpsilonStatement := +Notation EpsilonStatement := (forall A, EpsilonStatement_on A). (** Subclassical schemes *) @@ -235,7 +258,7 @@ Definition ProofIrrelevance := forall (A:Prop) (a1 a2:A), a1 = a2. Definition IndependenceOfGeneralPremises := - forall (A:Type) (P:A -> Prop) (Q:Prop), + forall (A:Type) (P:A -> Prop) (Q:Prop), inhabited A -> (Q -> exists x, P x) -> exists x, Q -> P x. @@ -270,7 +293,7 @@ Proof. apply HR'R; assumption. Qed. -Lemma funct_choice_imp_rel_choice : +Lemma funct_choice_imp_rel_choice : forall A B, FunctionalChoice_on A B -> RelationalChoice_on A B. Proof. intros A B FunCh R H. @@ -283,7 +306,7 @@ Proof. trivial. Qed. -Lemma funct_choice_imp_description : +Lemma funct_choice_imp_description : forall A B, FunctionalChoice_on A B -> FunctionalRelReification_on A B. Proof. intros A B FunCh R H. @@ -297,7 +320,7 @@ Proof. Qed. Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr : - forall A B, FunctionalChoice_on A B <-> + forall A B, FunctionalChoice_on A B <-> RelationalChoice_on A B /\ FunctionalRelReification_on A B. Proof. intros A B; split. @@ -312,7 +335,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 independance of general premises or subset types (themselves derivable from subtypes thanks to proof- irrelevance) *) @@ -341,12 +364,12 @@ 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, inhabited B -> RelationalChoice_on A B -> IndependenceOfGeneralPremises -> GuardedRelationalChoice_on A B. Proof. intros A B Inh AC_rel IndPrem P R H. destruct (AC_rel (fun x y => P x -> R x y)) as (R',(HR'R,H0)). - intro x. apply IndPrem. exact Inh. intro Hx. + intro x. apply IndPrem. exact Inh. intro Hx. apply H; assumption. exists (fun x y => P x /\ R' x y). firstorder. @@ -385,7 +408,7 @@ Qed. (** ** AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker *) (** AC_fun + IGP = GAC_fun *) - + Lemma guarded_fun_choice_imp_indep_of_general_premises : GuardedFunctionalChoice -> IndependenceOfGeneralPremises. Proof. @@ -446,7 +469,7 @@ Proof. Qed. Lemma fun_choice_and_small_drinker_imp_omniscient_fun_choice : - FunctionalChoiceOnInhabitedSet -> SmallDrinker'sParadox + FunctionalChoiceOnInhabitedSet -> SmallDrinker'sParadox -> OmniscientFunctionalChoice. Proof. intros AC_fun Drinker A B R Inh. @@ -456,10 +479,10 @@ Proof. Qed. Corollary fun_choice_and_small_drinker_iff_omniscient_fun_choice : - FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox + FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox <-> OmniscientFunctionalChoice. Proof. - auto decomp using + auto decomp using omniscient_fun_choice_imp_small_drinker, omniscient_fun_choice_imp_fun_choice, fun_choice_and_small_drinker_imp_omniscient_fun_choice. @@ -510,7 +533,7 @@ Lemma constructive_indefinite_description_and_small_drinker_imp_epsilon : SmallDrinker'sParadox -> ConstructiveIndefiniteDescription -> EpsilonStatement. Proof. - intros Drinkers D_epsilon A P Inh; + intros Drinkers D_epsilon A P Inh; apply D_epsilon; apply Drinkers; assumption. Qed. @@ -542,7 +565,7 @@ Qed. We show instead that functional relation reification and the functional form of the axiom of choice are equivalent on decidable - relation with [nat] as codomain + relation with [nat] as codomain *) Require Import Wf_nat. @@ -552,10 +575,10 @@ Definition FunctionalChoice_on_rel (A B:Type) (R:A->B->Prop) := (forall x:A, exists y : B, R x y) -> exists f : A -> B, (forall x:A, R x (f x)). -Lemma classical_denumerable_description_imp_fun_choice : - forall A:Type, - FunctionalRelReification_on A nat -> - forall R:A->nat->Prop, +Lemma classical_denumerable_description_imp_fun_choice : + forall A:Type, + FunctionalRelReification_on A nat -> + forall R:A->nat->Prop, (forall x y, decidable (R x y)) -> FunctionalChoice_on_rel R. Proof. intros A Descr. @@ -563,7 +586,7 @@ Proof. set (R':= fun x y => R x y /\ forall y', R x y' -> y <= y'). destruct (Descr R') as (f,Hf). intro x. - apply (dec_inh_nat_subset_has_unique_least_element (R x)). + apply (dec_inh_nat_subset_has_unique_least_element (R x)). apply Rdec. apply (H x). exists f. @@ -582,12 +605,12 @@ Definition DependentFunctionalChoice_on (A:Type) (B:A -> Type) := (forall x:A, exists y : B x, R x y) -> (exists f : (forall x:A, B x), forall x:A, R x (f x)). -Notation DependentFunctionalChoice := +Notation DependentFunctionalChoice := (forall A (B:A->Type), DependentFunctionalChoice_on B). (** The easy part *) -Theorem dep_non_dep_functional_choice : +Theorem dep_non_dep_functional_choice : DependentFunctionalChoice -> FunctionalChoice. Proof. intros AC_depfun A B R H. @@ -606,12 +629,12 @@ Scheme eq_indd := Induction for eq Sort Prop. Definition proj1_inf (A B:Prop) (p : A/\B) := let (a,b) := p in a. -Theorem non_dep_dep_functional_choice : +Theorem non_dep_dep_functional_choice : FunctionalChoice -> DependentFunctionalChoice. Proof. intros AC_fun A B R H. - pose (B' := { x:A & B x }). - pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). + pose (B' := { x:A & B x }). + pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). destruct (AC_fun A B' R') as (f,Hf). intros x. destruct (H x) as (y,Hy). exists (existT (fun x => B x) x y). split; trivial. @@ -633,7 +656,7 @@ Notation DependentFunctionalRelReification := (** The easy part *) -Theorem dep_non_dep_functional_rel_reification : +Theorem dep_non_dep_functional_rel_reification : DependentFunctionalRelReification -> FunctionalRelReification. Proof. intros DepFunReify A B R H. @@ -646,12 +669,12 @@ Qed. conjunction projections and dependent elimination of conjunction and equality *) -Theorem non_dep_dep_functional_rel_reification : +Theorem non_dep_dep_functional_rel_reification : FunctionalRelReification -> DependentFunctionalRelReification. Proof. intros AC_fun A B R H. - pose (B' := { x:A & B x }). - pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). + pose (B' := { x:A & B x }). + pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). destruct (AC_fun A B' R') as (f,Hf). intros x. destruct (H x) as (y,(Hy,Huni)). exists (existT (fun x => B x) x y). repeat split; trivial. @@ -665,7 +688,7 @@ Proof. destruct Heq using eq_indd; trivial. Qed. -Corollary dep_iff_non_dep_functional_rel_reification : +Corollary dep_iff_non_dep_functional_rel_reification : FunctionalRelReification <-> DependentFunctionalRelReification. Proof. auto decomp using @@ -764,7 +787,7 @@ be applied on the same Type universes on both sides of the first We adapt the proof to show that constructive definite description transports excluded-middle from [Prop] to [Set]. - [[ChicliPottierSimpson02]] Laurent Chicli, Loc Pottier, Carlos + [[ChicliPottierSimpson02]] Laurent Chicli, Loïc Pottier, Carlos Simpson, Mathematical Quotients and Quotient Types in Coq, Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646, Springer Verlag. *) @@ -786,14 +809,51 @@ Proof. intros [|] [|] H1 H2; simpl in *; reflexivity || contradiction. left; trivial. right; trivial. -Qed. +Qed. Corollary fun_reification_descr_computational_excluded_middle_in_prop_context : FunctionalRelReification -> - (forall P:Prop, P \/ ~ P) -> + (forall P:Prop, P \/ ~ P) -> forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C. Proof. intros FunReify EM C; auto decomp 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. + +Theorem functional_choice_imp_functional_dependent_choice : + FunctionalChoice -> FunctionalDependentChoice. +Proof. + intros FunChoice A R HRfun x0. + apply FunChoice in HRfun as (g,Rg). + set (f:=fix f n := match n with 0 => x0 | S n' => g (f n') end). + exists f; firstorder. +Qed. + +Theorem functional_dependent_choice_imp_functional_countable_choice : + FunctionalDependentChoice -> FunctionalCountableChoice. +Proof. + intros H A R H0. + set (R' (p q:nat*A) := fst q = S (fst p) /\ R (fst p) (snd q)). + destruct (H0 0) as (y0,Hy0). + destruct H with (R:=R') (x0:=(0,y0)) as (f,(Hf0,HfS)). + intro x; destruct (H0 (fst x)) as (y,Hy). + exists (S (fst x),y). + red. auto. + assert (Heq:forall n, fst (f n) = n). + induction n. + rewrite Hf0; reflexivity. + specialize HfS with n; destruct HfS as (->,_); congruence. + exists (fun n => snd (f (S n))). + intro n'. specialize HfS with n'. + destruct HfS as (_,HR). + rewrite Heq in HR. + assumption. +Qed. diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v index 523c9245..1c2b97ce 100644 --- a/theories/Logic/Classical.v +++ b/theories/Logic/Classical.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id$ i*) (** Classical Logic *) diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v index f9b59a6a..b0301994 100644 --- a/theories/Logic/ClassicalChoice.v +++ b/theories/Logic/ClassicalChoice.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalChoice.v 10170 2007-10-03 14:41:25Z herbelin $ i*) +(*i $Id$ i*) (** This file provides classical logic and functional choice; this especially provides both indefinite descriptions and choice functions diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v index 31c41120..2b9df6d9 100644 --- a/theories/Logic/ClassicalDescription.v +++ b/theories/Logic/ClassicalDescription.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalDescription.v 11481 2008-10-20 19:23:51Z herbelin $ i*) +(*i $Id$ i*) (** This file provides classical logic and definite description, which is equivalent to providing classical logic and Church's iota operator *) @@ -30,12 +30,12 @@ Axiom constructive_definite_description : Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}. Proof. -apply - (constructive_definite_descr_excluded_middle +apply + (constructive_definite_descr_excluded_middle constructive_definite_description classic). Qed. -Theorem classical_definite_description : +Theorem classical_definite_description : forall (A : Type) (P : A->Prop), inhabited A -> { x : A | (exists! x : A, P x) -> P x }. Proof. @@ -54,7 +54,7 @@ Qed. Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A := proj1_sig (classical_definite_description P i). -Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : +Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : (exists! x:A, P x) -> P (iota i P) := proj2_sig (classical_definite_description P i). diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v index 2a4de511..cee55dc8 100644 --- a/theories/Logic/ClassicalEpsilon.v +++ b/theories/Logic/ClassicalEpsilon.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Prop), + forall (A : Type) (P : A->Prop), (exists x, P x) -> { x : A | P x }. Lemma constructive_definite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists! x, P x) -> { x : A | P x }. Proof. intros; apply constructive_indefinite_description; firstorder. @@ -34,18 +35,18 @@ Qed. Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}. Proof. - apply - (constructive_definite_descr_excluded_middle + apply + (constructive_definite_descr_excluded_middle constructive_definite_description classic). Qed. -Theorem classical_indefinite_description : +Theorem classical_indefinite_description : forall (A : Type) (P : A->Prop), inhabited A -> { x : A | (exists x, P x) -> P x }. Proof. intros A P i. destruct (excluded_middle_informative (exists x, P x)) as [Hex|HnonP]. - apply constructive_indefinite_description + apply constructive_indefinite_description with (P:= fun x => (exists x, P x) -> P x). destruct Hex as (x,Hx). exists x; intros _; exact Hx. @@ -60,7 +61,7 @@ Defined. Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A := proj1_sig (classical_indefinite_description P i). -Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : +Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : (exists x, P x) -> P (epsilon i P) := proj2_sig (classical_indefinite_description P i). @@ -74,9 +75,9 @@ Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : (** A proof that if [P] is inhabited, [epsilon a P] does not depend on the actual proof that the domain of [P] is inhabited - (proof idea kindly provided by Pierre Castran) *) + (proof idea kindly provided by Pierre Castéran) *) -Lemma epsilon_inh_irrelevance : +Lemma epsilon_inh_irrelevance : forall (A:Type) (i j : inhabited A) (P:A->Prop), (exists x, P x) -> epsilon i P = epsilon j P. Proof. diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index db92696b..b22a3a87 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalFacts.v 11481 2008-10-20 19:23:51Z herbelin $ i*) +(*i $Id$ i*) (** Some facts and definitions about classical logic @@ -31,7 +31,7 @@ Table of contents: 3.1. Weak excluded middle -3.2. Gdel-Dummett axiom and right distributivity of implication over +3.2. Gödel-Dummett axiom and right distributivity of implication over disjunction 3 3. Independence of general premises and drinker's paradox @@ -111,7 +111,7 @@ Qed. (** We successively show that: [prop_extensionality] - implies equality of [A] and [A->A] for inhabited [A], which + implies equality of [A] and [A->A] for inhabited [A], which implies the existence of a (trivial) retract from [A->A] to [A] (just take the identity), which implies the existence of a fixpoint operator in [A] @@ -128,7 +128,7 @@ Proof. apply (Ext (A -> A) A); split; [ exact (fun _ => a) | exact (fun _ _ => a) ]. Qed. -Record retract (A B:Prop) : Prop := +Record retract (A B:Prop) : Prop := {f1 : A -> B; f2 : B -> A; f1_o_f2 : forall x:B, f1 (f2 x) = x}. Lemma prop_ext_retract_A_A_imp_A : @@ -140,7 +140,7 @@ Proof. reflexivity. Qed. -Record has_fixpoint (A:Prop) : Prop := +Record has_fixpoint (A:Prop) : Prop := {F : (A -> A) -> A; Fix : forall f:A -> A, F f = f (F f)}. Lemma ext_prop_fixpoint : @@ -224,7 +224,7 @@ End Proof_irrelevance_gen. *) Section Proof_irrelevance_Prop_Ext_CC. - + Definition BoolP := forall C:Prop, C -> C -> C. Definition TrueP : BoolP := fun C c1 c2 => c1. Definition FalseP : BoolP := fun C c1 c2 => c2. @@ -233,10 +233,10 @@ Section Proof_irrelevance_Prop_Ext_CC. c1 = BoolP_elim C c1 c2 TrueP := refl_equal c1. Definition BoolP_elim_redr (C:Prop) (c1 c2:C) : c2 = BoolP_elim C c1 c2 FalseP := refl_equal c2. - + Definition BoolP_dep_induction := forall P:BoolP -> Prop, P TrueP -> P FalseP -> forall b:BoolP, P b. - + Lemma ext_prop_dep_proof_irrel_cc : prop_extensionality -> BoolP_dep_induction -> proof_irrelevance. Proof. @@ -248,7 +248,7 @@ End Proof_irrelevance_Prop_Ext_CC. (** Remark: [prop_extensionality] can be replaced in lemma [ext_prop_dep_proof_irrel_gen] by the weakest property - [provable_prop_extensionality]. + [provable_prop_extensionality]. *) (************************************************************************) @@ -260,7 +260,7 @@ End Proof_irrelevance_Prop_Ext_CC. *) Section Proof_irrelevance_CIC. - + Inductive boolP : Prop := | trueP : boolP | falseP : boolP. @@ -269,7 +269,7 @@ Section Proof_irrelevance_CIC. Definition boolP_elim_redr (C:Prop) (c1 c2:C) : c2 = boolP_ind C c1 c2 falseP := refl_equal c2. Scheme boolP_indd := Induction for boolP Sort Prop. - + Lemma ext_prop_dep_proof_irrel_cic : prop_extensionality -> proof_irrelevance. Proof. exact (fun pe => @@ -290,7 +290,7 @@ End Proof_irrelevance_CIC. cannot be refined. [[Berardi90]] Stefano Berardi, "Type dependence and constructive - mathematics", Ph. D. thesis, Dipartimento Matematica, Universit di + mathematics", Ph. D. thesis, Dipartimento Matematica, Università di Torino, 1990. *) @@ -316,7 +316,7 @@ End Proof_irrelevance_CIC. Require Import Hurkens. Section Proof_irrelevance_EM_CC. - + Variable or : Prop -> Prop -> Prop. Variable or_introl : forall A B:Prop, A -> or A B. Variable or_intror : forall A B:Prop, B -> or A B. @@ -334,11 +334,11 @@ Section Proof_irrelevance_EM_CC. forall (A B:Prop) (P:or A B -> Prop), (forall a:A, P (or_introl A B a)) -> (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b. - + Hypothesis em : forall A:Prop, or A (~ A). Variable B : Prop. Variables b1 b2 : B. - + (** [p2b] and [b2p] form a retract if [~b1=b2] *) Definition p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A). @@ -392,13 +392,13 @@ End Proof_irrelevance_EM_CC. Section Proof_irrelevance_CCI. Hypothesis em : forall A:Prop, A \/ ~ A. - - Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C) + + Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C) (a:A) : f a = or_ind f g (or_introl B a) := refl_equal (f a). - Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C) + Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C) (b:B) : g b = or_ind f g (or_intror A b) := refl_equal (g b). Scheme or_indd := Induction for or Sort Prop. - + Theorem proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), b1 = b2. Proof. exact (proof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl @@ -417,7 +417,7 @@ End Proof_irrelevance_CCI. (** We show the following increasing in the strength of axioms: - weak excluded-middle - - right distributivity of implication over disjunction and Gdel-Dummett axiom + - right distributivity of implication over disjunction and Gödel-Dummett axiom - independence of general premises and drinker's paradox - excluded-middle *) @@ -436,20 +436,20 @@ Definition weak_excluded_middle := (** The interest in the equivalent variant [weak_generalized_excluded_middle] is that it holds even in logic - without a primitive [False] connective (like Gdel-Dummett axiom) *) + without a primitive [False] connective (like Gödel-Dummett axiom) *) -Definition weak_generalized_excluded_middle := +Definition weak_generalized_excluded_middle := forall A B:Prop, ((A -> B) -> B) \/ (A -> B). -(** ** Gdel-Dummett axiom *) +(** ** Gödel-Dummett axiom *) -(** [(A->B) \/ (B->A)] is studied in [[Dummett59]] and is based on [[Gdel33]]. +(** [(A->B) \/ (B->A)] is studied in [[Dummett59]] and is based on [[Gödel33]]. [[Dummett59]] Michael A. E. Dummett. "A Propositional Calculus with a Denumerable Matrix", In the Journal of Symbolic Logic, Vol 24 No. 2(1959), pp 97-103. - [[Gdel33]] Kurt Gdel. "Zum intuitionistischen Aussagenkalkl", + [[Gödel33]] Kurt Gödel. "Zum intuitionistischen Aussagenkalkül", Ergeb. Math. Koll. 4 (1933), pp. 34-38. *) @@ -473,7 +473,7 @@ Lemma Godel_Dummett_iff_right_distr_implication_over_disjunction : Proof. split. intros GD A B C HCAB. - destruct (GD B A) as [HBA|HAB]; [left|right]; intro HC; + destruct (GD B A) as [HBA|HAB]; [left|right]; intro HC; destruct (HCAB HC) as [HA|HB]; [ | apply HBA | apply HAB | ]; assumption. intros Distr A B. destruct (Distr A B (A\/B)) as [HABA|HABB]. @@ -484,7 +484,7 @@ Qed. (** [(A->B) \/ (B->A)] is stronger than the weak excluded middle *) -Lemma Godel_Dummett_weak_excluded_middle : +Lemma Godel_Dummett_weak_excluded_middle : GodelDummett -> weak_excluded_middle. Proof. intros GD A. destruct (GD (~A) A) as [HnotAA|HAnotA]. @@ -500,13 +500,13 @@ Qed. It is a generalization to predicate logic of the right distributivity of implication over disjunction (hence of - Gdel-Dummett axiom) whose own constructive form (obtained by a + Gödel-Dummett axiom) whose own constructive form (obtained by a restricting the third formula to be negative) is called Kreisel-Putnam principle [[KreiselPutnam57]]. [[KreiselPutnam57]], Georg Kreisel and Hilary Putnam. "Eine - Unableitsbarkeitsbeweismethode fr den intuitionistischen - Aussagenkalkl". Archiv fr Mathematische Logik und + Unableitsbarkeitsbeweismethode für den intuitionistischen + Aussagenkalkül". Archiv für Mathematische Logik und Graundlagenforschung, 3:74- 78, 1957. [[Troelstra73]], Anne Troelstra, editor. Metamathematical @@ -539,10 +539,10 @@ Qed. (** Independence of general premises is equivalent to the drinker's paradox *) Definition DrinkerParadox := - forall (A:Type) (P:A -> Prop), + forall (A:Type) (P:A -> Prop), inhabited A -> exists x, (exists x, P x) -> P x. -Lemma independence_general_premises_drinker : +Lemma independence_general_premises_drinker : IndependenceOfGeneralPremises <-> DrinkerParadox. Proof. split. @@ -551,14 +551,14 @@ Proof. exists x; intro HQ; apply (Hx (H HQ)). Qed. -(** Independence of general premises is weaker than (generalized) +(** Independence of general premises is weaker than (generalized) excluded middle Remark: generalized excluded middle is preferred here to avoid relying on the "ex falso quodlibet" property (i.e. [False -> forall A, A]) *) -Definition generalized_excluded_middle := +Definition generalized_excluded_middle := forall A B:Prop, A \/ (A -> B). Lemma excluded_middle_independence_general_premises : @@ -569,4 +569,4 @@ Proof. exists x; intro; exact Hx. exists x0; exact Hnot. Qed. - + diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v index bb846aa6..f99d65eb 100644 --- a/theories/Logic/ClassicalUniqueChoice.v +++ b/theories/Logic/ClassicalUniqueChoice.v @@ -1,3 +1,4 @@ +(* -*- 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 : ((forall P:Prop, {P} + {~ P}) -> False) -> False. +Theorem classic_set_in_prop_context : + forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C. Proof. -intro HnotEM. +intros C HnotEM. set (R := fun A b => A /\ true = b \/ ~ A /\ false = b). assert (H : exists f : Prop -> bool, (forall A:Prop, R A (f A))). apply unique_choice. @@ -80,4 +82,12 @@ destruct (f P). discriminate. assumption. Qed. - + +Corollary not_not_classic_set : + ((forall P:Prop, {P} + {~ P}) -> False) -> False. +Proof. +apply classic_set_in_prop_context. +Qed. + +(* Compatibility *) +Notation classic_set := not_not_classic_set (only parsing). diff --git a/theories/Logic/Classical_Pred_Set.v b/theories/Logic/Classical_Pred_Set.v index 2a5f03ec..0b0c329b 100644 --- a/theories/Logic/Classical_Pred_Set.v +++ b/theories/Logic/Classical_Pred_Set.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical_Pred_Set.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id$ i*) (** This file is obsolete, use Classical_Pred_Type.v via Classical.v instead *) diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v index 56ebf967..b30308af 100644 --- a/theories/Logic/Classical_Pred_Type.v +++ b/theories/Logic/Classical_Pred_Type.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical_Pred_Type.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id$ i*) (** Classical Predicate Logic on Type *) @@ -44,7 +44,7 @@ Proof. (* Intuitionistic *) unfold not in |- *; intros P notex n abs. apply notex. exists n; trivial. -Qed. +Qed. Lemma not_ex_not_all : forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n. diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index ce3e84a7..df732959 100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical_Prop.v 8892 2006-06-04 17:59:53Z herbelin $ i*) +(*i $Id$ i*) (** Classical Propositional Logic *) @@ -22,7 +22,7 @@ unfold not in |- *; intros; elim (classic p); auto. intro NP; elim (H NP). Qed. -(** Peirce's law states [forall P Q:Prop, ((P -> Q) -> P) -> P]. +(** Peirce's law states [forall P Q:Prop, ((P -> Q) -> P) -> P]. Thanks to [forall P, False -> P], it is equivalent to the following form *) @@ -95,11 +95,11 @@ Proof proof_irrelevance_cci classic. (* classical_left transforms |- A \/ B into ~B |- A *) (* classical_right transforms |- A \/ B into ~A |- B *) -Ltac classical_right := match goal with +Ltac classical_right := match goal with | _:_ |-?X1 \/ _ => (elim (classic X1);intro;[left;trivial|right]) end. -Ltac classical_left := match goal with +Ltac classical_left := match goal with | _:_ |- _ \/?X1 => (elim (classic X1);intro;[right;trivial|left]) end. @@ -107,7 +107,7 @@ Require Export EqdepFacts. Module Eq_rect_eq. -Lemma eq_rect_eq : +Lemma eq_rect_eq : forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. Proof. intros; rewrite proof_irrelevance with (p1:=h) (p2:=refl_equal p); reflexivity. diff --git a/theories/Logic/Classical_Type.v b/theories/Logic/Classical_Type.v index 9b1f4e19..3b91afd0 100644 --- a/theories/Logic/Classical_Type.v +++ b/theories/Logic/Classical_Type.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical_Type.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id$ i*) (** This file is obsolete, use Classical.v instead *) diff --git a/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v index ff70c9fb..6d22b1a9 100644 --- a/theories/Logic/ConstructiveEpsilon.v +++ b/theories/Logic/ConstructiveEpsilon.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* (~ P -> False) -> P. Proof. -unfold decidable; tauto. +unfold decidable; tauto. Qed. Theorem dec_True : decidable True. @@ -29,27 +29,27 @@ Qed. Theorem dec_or : forall A B:Prop, decidable A -> decidable B -> decidable (A \/ B). Proof. -unfold decidable; tauto. +unfold decidable; tauto. Qed. Theorem dec_and : forall A B:Prop, decidable A -> decidable B -> decidable (A /\ B). Proof. -unfold decidable; tauto. +unfold decidable; tauto. Qed. Theorem dec_not : forall A:Prop, decidable A -> decidable (~ A). Proof. -unfold decidable; tauto. +unfold decidable; tauto. Qed. Theorem dec_imp : forall A B:Prop, decidable A -> decidable B -> decidable (A -> B). Proof. -unfold decidable; tauto. +unfold decidable; tauto. Qed. -Theorem dec_iff : +Theorem dec_iff : forall A B:Prop, decidable A -> decidable B -> decidable (A<->B). Proof. unfold decidable; tauto. @@ -67,7 +67,7 @@ Qed. Theorem not_and : forall A B:Prop, decidable A -> ~ (A /\ B) -> ~ A \/ ~ B. Proof. -unfold decidable; tauto. +unfold decidable; tauto. Qed. Theorem not_imp : forall A B:Prop, decidable A -> ~ (A -> B) -> A /\ ~ B. @@ -80,16 +80,16 @@ Proof. unfold decidable; tauto. Qed. -Theorem not_iff : - forall A B:Prop, decidable A -> decidable B -> +Theorem not_iff : + forall A B:Prop, decidable A -> decidable B -> ~ (A <-> B) -> (A /\ ~ B) \/ (~ A /\ B). Proof. unfold decidable; tauto. Qed. -(** Results formulated with iff, used in FSetDecide. - Negation are expanded since it is unclear whether setoid rewrite - will always perform conversion. *) +(** Results formulated with iff, used in FSetDecide. + Negation are expanded since it is unclear whether setoid rewrite + will always perform conversion. *) (** We begin with lemmas that, when read from left to right, can be understood as ways to eliminate uses of [not]. *) diff --git a/theories/Logic/DecidableType.v b/theories/Logic/DecidableType.v deleted file mode 100644 index a65e2c52..00000000 --- a/theories/Logic/DecidableType.v +++ /dev/null @@ -1,173 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t -> Prop. - - Axiom eq_refl : forall x : t, eq x x. - Axiom eq_sym : forall x y : t, eq x y -> eq y x. - Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - - Hint Immediate eq_sym. - Hint Resolve eq_refl eq_trans. - -End EqualityType. - -(** * Types with decidable Equalities (but no ordering) *) - -Module Type DecidableType. - - Parameter Inline t : Type. - - Parameter Inline eq : t -> t -> Prop. - - Axiom eq_refl : forall x : t, eq x x. - Axiom eq_sym : forall x y : t, eq x y -> eq y x. - Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - - Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }. - - Hint Immediate eq_sym. - Hint Resolve eq_refl eq_trans. - -End DecidableType. - -(** * Additional notions about keys and datas used in FMap *) - -Module KeyDecidableType(D:DecidableType). - Import D. - - Section Elt. - Variable elt : Type. - Notation key:=t. - - Definition eqk (p p':key*elt) := eq (fst p) (fst p'). - Definition eqke (p p':key*elt) := - eq (fst p) (fst p') /\ (snd p) = (snd p'). - - Hint Unfold eqk eqke. - Hint Extern 2 (eqke ?a ?b) => split. - - (* eqke is stricter than eqk *) - - Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. - Proof. - unfold eqk, eqke; intuition. - Qed. - - (* eqk, eqke are equalities *) - - Lemma eqk_refl : forall e, eqk e e. - Proof. auto. Qed. - - Lemma eqke_refl : forall e, eqke e e. - Proof. auto. Qed. - - Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. - Proof. auto. Qed. - - Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. - Proof. unfold eqke; intuition. Qed. - - Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. - Proof. eauto. Qed. - - Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. - Proof. - unfold eqke; intuition; [ eauto | congruence ]. - Qed. - - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Immediate eqk_sym eqke_sym. - - Lemma InA_eqke_eqk : - forall x m, InA eqke x m -> InA eqk x m. - Proof. - 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; apply eqk_trans; auto. - Qed. - - Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). - Definition In k m := exists e:elt, MapsTo k e m. - - Hint Unfold MapsTo In. - - (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) - - Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. - Proof. - firstorder. - exists x; auto. - induction H. - destruct y. - exists e; auto. - destruct IHInA as [e H0]. - exists e; auto. - Qed. - - Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. - Proof. - intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto. - Qed. - - Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. - Proof. - destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. - Qed. - - Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. - Proof. - inversion 1. - inversion_clear H0; eauto. - destruct H1; simpl in *; intuition. - Qed. - - Lemma In_inv_2 : forall k k' e e' l, - InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. - Proof. - inversion_clear 1; compute in H0; intuition. - Qed. - - Lemma In_inv_3 : forall x x' l, - InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. - Proof. - inversion_clear 1; compute in H0; intuition. - Qed. - - End Elt. - - Hint Unfold eqk eqke. - Hint Extern 2 (eqke ?a ?b) => split. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Immediate eqk_sym eqke_sym. - Hint Resolve InA_eqke_eqk. - Hint Unfold MapsTo In. - Hint Resolve In_inv_2 In_inv_3. - -End KeyDecidableType. - - - - - diff --git a/theories/Logic/DecidableTypeEx.v b/theories/Logic/DecidableTypeEx.v deleted file mode 100644 index 9c59c519..00000000 --- a/theories/Logic/DecidableTypeEx.v +++ /dev/null @@ -1,109 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* y }. -End MiniDecidableType. - -Module Make_UDT (M:MiniDecidableType) <: UsualDecidableType. - Definition t:=M.t. - Definition eq := @eq t. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - Definition eq_dec := M.eq_dec. -End Make_UDT. - -(** An OrderedType can now directly be seen as a DecidableType *) - -Module OT_as_DT (O:OrderedType) <: DecidableType := O. - -(** (Usual) Decidable Type for [nat], [positive], [N], [Z] *) - -Module Nat_as_DT <: UsualDecidableType := Nat_as_OT. -Module Positive_as_DT <: UsualDecidableType := Positive_as_OT. -Module N_as_DT <: UsualDecidableType := N_as_OT. -Module Z_as_DT <: UsualDecidableType := Z_as_OT. - -(** From two decidable types, we can build a new DecidableType - over their cartesian product. *) - -Module PairDecidableType(D1 D2:DecidableType) <: DecidableType. - - Definition t := prod D1.t D2.t. - - Definition eq x y := D1.eq (fst x) (fst y) /\ D2.eq (snd x) (snd y). - - Lemma eq_refl : forall x : t, eq x x. - Proof. - intros (x1,x2); red; simpl; auto. - Qed. - - Lemma eq_sym : forall x y : t, eq x y -> eq y x. - Proof. - intros (x1,x2) (y1,y2); unfold eq; simpl; intuition. - Qed. - - Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - Proof. - intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto. - Qed. - - Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. - Proof. - intros (x1,x2) (y1,y2); unfold eq; simpl. - destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); intuition. - Defined. - -End PairDecidableType. - -(** Similarly for pairs of UsualDecidableType *) - -Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. - Definition t := prod D1.t D2.t. - Definition eq := @eq t. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. - Proof. - intros (x1,x2) (y1,y2); - destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); - unfold eq, D1.eq, D2.eq in *; simpl; - (left; f_equal; auto; fail) || - (right; intro H; injection H; auto). - Defined. - -End PairUsualDecidableType. diff --git a/theories/Logic/Description.v b/theories/Logic/Description.v index 962f2a2a..a8a56ae7 100644 --- a/theories/Logic/Description.v +++ b/theories/Logic/Description.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Description.v 10170 2007-10-03 14:41:25Z herbelin $ i*) +(*i $Id$ i*) (** This file provides a constructive form of definite description; it allows to build functions from the proof of their existence in any @@ -17,5 +17,5 @@ Require Import ChoiceFacts. Set Implicit Arguments. Axiom constructive_definite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists! x, P x) -> { x : A | P x }. diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index b935a676..18f3181b 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Diaconescu.v 11481 2008-10-20 19:23:51Z herbelin $ i*) +(*i $Id$ i*) (** Diaconescu showed that the Axiom of Choice entails Excluded-Middle in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show @@ -59,7 +59,7 @@ Definition PredicateExtensionality := Require Import ClassicalFacts. Variable pred_extensionality : PredicateExtensionality. - + Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B. Proof. intros A B H. @@ -99,11 +99,11 @@ Lemma AC_bool_subset_to_bool : (exists b : bool, P b) -> exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')). Proof. - destruct (guarded_rel_choice _ _ + destruct (guarded_rel_choice _ _ (fun Q:bool -> Prop => exists y : _, Q y) (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)). exact (fun _ H => H). - exists R; intros P HP. + exists R; intros P HP. destruct (HR P HP) as (y,(Hy,Huni)). exists y; firstorder. Qed. @@ -190,7 +190,7 @@ Lemma projT1_injective : a1=a2 -> a1'=a2'. Proof. intro Heq ; unfold a1', a2', A'. rewrite Heq. - replace (or_introl (a2=a2) (refl_equal a2)) + replace (or_introl (a2=a2) (refl_equal a2)) with (or_intror (a2=a2) (refl_equal a2)). reflexivity. apply proof_irrelevance. @@ -210,10 +210,10 @@ Qed. Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2. Proof. - destruct - (rel_choice A' bool + destruct + (rel_choice A' bool (fun x y => projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false)) - as (R,(HRsub,HR)). + as (R,(HRsub,HR)). apply decide. destruct (HR a1') as (b1,(Ha1'b1,_Huni1)). destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)]. @@ -235,18 +235,18 @@ Declare Implicit Tactic auto. Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2. Proof. - assert (decide: forall x:A, x=a1 \/ x=a2 -> + assert (decide: forall x:A, x=a1 \/ x=a2 -> exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false). intros a [Ha1|Ha2]; [exists true | exists false]; auto. - assert (guarded_rel_choice := - rel_choice_and_proof_irrel_imp_guarded_rel_choice - rel_choice + assert (guarded_rel_choice := + rel_choice_and_proof_irrel_imp_guarded_rel_choice + rel_choice proof_irrelevance). - destruct - (guarded_rel_choice A bool + destruct + (guarded_rel_choice A bool (fun x => x=a1 \/ x=a2) (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false)) - as (R,(HRsub,HR)). + as (R,(HRsub,HR)). apply decide. destruct (HR a1) as (b1,(Ha1b1,_Huni1)). left; reflexivity. destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)]. @@ -273,8 +273,8 @@ Section ExtensionalEpsilon_imp_EM. Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A. -Hypothesis epsilon_spec : - forall (A:Type) (i:inhabited A) (P:A->Prop), +Hypothesis epsilon_spec : + forall (A:Type) (i:inhabited A) (P:A->Prop), (exists x, P x) -> P (epsilon A i P). Hypothesis epsilon_extensionality : @@ -288,9 +288,9 @@ Proof. intro P. pose (B := fun y => y=false \/ P). pose (C := fun y => y=true \/ P). - assert (B (eps B)) as [Hfalse|HP] + assert (B (eps B)) as [Hfalse|HP] by (apply epsilon_spec; exists false; left; reflexivity). - assert (C (eps C)) as [Htrue|HP] + assert (C (eps C)) as [Htrue|HP] by (apply epsilon_spec; exists true; left; reflexivity). right; intro HP. assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption). diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v index 65d4d853..d433be94 100644 --- a/theories/Logic/Epsilon.v +++ b/theories/Logic/Epsilon.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Epsilon.v 10170 2007-10-03 14:41:25Z herbelin $ i*) +(*i $Id$ i*) (** This file provides indefinite description under the form of Hilbert's epsilon operator; it does not assume classical logic. *) @@ -17,12 +17,12 @@ Set Implicit Arguments. (** Hilbert's epsilon: operator and specification in one statement *) -Axiom epsilon_statement : +Axiom epsilon_statement : forall (A : Type) (P : A->Prop), inhabited A -> { x : A | (exists x, P x) -> P x }. Lemma constructive_indefinite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists x, P x) -> { x : A | P x }. Proof. apply epsilon_imp_constructive_indefinite_description. @@ -45,7 +45,7 @@ Proof. Qed. Lemma constructive_definite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists! x, P x) -> { x : A | P x }. Proof. apply iota_imp_constructive_definite_description. @@ -57,7 +57,7 @@ Qed. Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A := proj1_sig (epsilon_statement P i). -Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : +Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : (exists x, P x) -> P (epsilon i P) := proj2_sig (epsilon_statement P i). @@ -66,7 +66,7 @@ Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A := proj1_sig (iota_statement P i). -Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : +Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : (exists! x:A, P x) -> P (iota i P) := proj2_sig (iota_statement P i). diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v index 2fe9d1a6..5c6b4e89 100644 --- a/theories/Logic/Eqdep.v +++ b/theories/Logic/Eqdep.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Type. @@ -119,7 +120,7 @@ Lemma equiv_eqex_eqdep : forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q), existT P p x = existT P q y <-> eq_dep p x q y. Proof. - split. + split. (* -> *) apply eq_sigT_eq_dep. (* <- *) @@ -142,27 +143,27 @@ Hint Immediate eq_dep_sym: core. (** * Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K *) Section Equivalences. - + Variable U:Type. - + (** Invariance by Substitution of Reflexive Equality Proofs *) - - Definition Eq_rect_eq := + + Definition Eq_rect_eq := forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. - + (** Injectivity of Dependent Equality *) - - Definition Eq_dep_eq := + + Definition Eq_dep_eq := forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y. - + (** Uniqueness of Identity Proofs (UIP) *) - - Definition UIP_ := + + Definition UIP_ := forall (x y:U) (p1 p2:x = y), p1 = p2. - + (** Uniqueness of Reflexive Identity Proofs *) - Definition UIP_refl_ := + Definition UIP_refl_ := forall (x:U) (p:x = x), p = refl_equal x. (** Streicher's axiom K *) @@ -198,7 +199,7 @@ Section Equivalences. elim p1 using eq_indd. apply eq_dep_intro. Qed. - + (** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *) Lemma UIP__UIP_refl : UIP_ -> UIP_refl_. @@ -216,7 +217,7 @@ Section Equivalences. (** We finally recover from K the Invariance by Substitution of Reflexive Equality Proofs *) - + Lemma Streicher_K__eq_rect_eq : Streicher_K_ -> Eq_rect_eq. Proof. intro Streicher_K; red; intros. @@ -233,20 +234,20 @@ Section Equivalences. Typically, [eq_rect_eq] allows to prove 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]. + in [Set]. *) End Equivalences. 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. Proof. intro eq_dep_eq; red; intros. @@ -260,7 +261,7 @@ End Corollaries. Notation Inj_dep_pairS := Inj_dep_pair. Notation Inj_dep_pairT := Inj_dep_pair. Notation eq_dep_eq__inj_pairT2 := eq_dep_eq__inj_pair2. - + (************************************************************************) (** * Definition of the functor that builds properties of dependent equalities assuming axiom eq_rect_eq *) @@ -274,11 +275,11 @@ Module Type EqdepElimination. End EqdepElimination. Module EqdepTheory (M:EqdepElimination). - + Section Axioms. - + Variable U:Type. - + (** Invariance by Substitution of Reflexive Equality Proofs *) Lemma eq_rect_eq : diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 0281916e..fc1c4a97 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Eqdep_dec.v 10144 2007-09-26 15:12:17Z vsiles $ i*) +(*i $Id$ i*) (** We prove that there is only one proof of [x=x], i.e [refl_equal x]. This holds if the equality upon the set of [x] is decidable. @@ -38,7 +38,7 @@ Set Implicit Arguments. Section EqdepDec. Variable A : Type. - + Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' := eq_ind _ (fun a => a = y') eq2 _ eq1. @@ -49,7 +49,7 @@ Section EqdepDec. Qed. Variable eq_dec : forall x y:A, x = y \/ x <> y. - + Variable x : A. Let nu (y:A) (u:x = y) : x = y := @@ -63,13 +63,13 @@ Section EqdepDec. unfold nu in |- *. case (eq_dec x y); intros. reflexivity. - + case n; trivial. Qed. Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (refl_equal x)) v. - + Remark nu_left_inv : forall (y:A) (u:x = y), nu_inv (nu u) = u. Proof. @@ -88,7 +88,7 @@ Section EqdepDec. reflexivity. Qed. - Theorem K_dec : + Theorem K_dec : forall P:x = x -> Prop, P (refl_equal x) -> forall p:x = x, P p. Proof. intros. @@ -118,10 +118,10 @@ Section EqdepDec. case (eq_dec x x). intro e. elim e using K_dec; trivial. - + intros. case n; trivial. - + case H. reflexivity. Qed. @@ -165,6 +165,12 @@ Theorem eq_dep_eq_dec : forall (P:A->Type) (p:A) (x y:P p), eq_dep A P p x p y -> x = y. Proof (fun A eq_dec => eq_rect_eq__eq_dep_eq A (eq_rect_eq_dec eq_dec)). +Theorem UIP_dec : + forall (A:Type), + (forall x y:A, {x = y} + {x <> y}) -> + forall (x y:A) (p1 p2:x = y), p1 = p2. +Proof (fun A eq_dec => eq_dep_eq__UIP A (eq_dep_eq_dec eq_dec)). + Unset Implicit Arguments. (************************************************************************) @@ -173,13 +179,13 @@ Unset Implicit Arguments. (** The signature of decidable sets in [Type] *) Module Type DecidableType. - + Parameter U:Type. Axiom eq_dec : forall x y:U, {x = y} + {x <> y}. End DecidableType. -(** The module [DecidableEqDep] collects equality properties for decidable +(** The module [DecidableEqDep] collects equality properties for decidable set in [Type] *) Module DecidableEqDep (M:DecidableType). @@ -247,7 +253,7 @@ Module Type DecidableSet. End DecidableSet. -(** The module [DecidableEqDepSet] collects equality properties for decidable +(** The module [DecidableEqDepSet] collects equality properties for decidable set in [Set] *) Module DecidableEqDepSet (M:DecidableSet). @@ -307,11 +313,11 @@ End DecidableEqDepSet. (** From decidability to inj_pair2 **) Lemma inj_pair2_eq_dec : forall A:Type, (forall x y:A, {x=y}+{x<>y}) -> ( forall (P:A -> Type) (p:A) (x y:P p), existT P p x = existT P p y -> x = y ). -Proof. +Proof. intros A eq_dec. apply eq_dep_eq__inj_pair2. apply eq_rect_eq__eq_dep_eq. - unfold Eq_rect_eq. + unfold Eq_rect_eq. apply eq_rect_eq_dec. apply eq_dec. Qed. diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v index 0dc82907..1678a287 100644 --- a/theories/Logic/FunctionalExtensionality.v +++ b/theories/Logic/FunctionalExtensionality.v @@ -6,14 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: FunctionalExtensionality.v 11686 2008-12-16 12:57:26Z msozeau $ i*) +(*i $Id$ i*) (** This module states the axiom of (dependent) functional extensionality and (dependent) eta-expansion. It introduces a tactic [extensionality] to apply the axiom of extensionality to an equality goal. *) (** The converse of functional extensionality. *) -Lemma equal_f : forall {A B : Type} {f g : A -> B}, +Lemma equal_f : forall {A B : Type} {f g : A -> B}, f = g -> forall x, f x = g x. Proof. intros. @@ -23,11 +23,11 @@ Qed. (** Statements of functional extensionality for simple and dependent functions. *) -Axiom functional_extensionality_dep : forall {A} {B : A -> Type}, - forall (f g : forall x : A, B x), +Axiom functional_extensionality_dep : forall {A} {B : A -> Type}, + forall (f g : forall x : A, B x), (forall x, f x = g x) -> f = g. -Lemma functional_extensionality {A B} (f g : A -> B) : +Lemma functional_extensionality {A B} (f g : A -> B) : (forall x, f x = g x) -> f = g. Proof. intros ; eauto using @functional_extensionality_dep. @@ -37,8 +37,8 @@ Qed. Tactic Notation "extensionality" ident(x) := match goal with - [ |- ?X = ?Y ] => - (apply (@functional_extensionality _ _ X Y) || + [ |- ?X = ?Y ] => + (apply (@functional_extensionality _ _ X Y) || apply (@functional_extensionality_dep _ _ X Y)) ; intro x end. @@ -51,8 +51,8 @@ Proof. extensionality x. reflexivity. Qed. - + Lemma eta_expansion {A B} (f : A -> B) : f = fun x => f x. Proof. - intros A B f. apply (eta_expansion_dep f). + apply (eta_expansion_dep f). Qed. diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index 46a57432..71c9af50 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -19,7 +19,7 @@ and Applications (TLCA'95), 1995. - [Geuvers] "Inconsistency of Classical Logic in Type Theory", 2001 - (see www.cs.kun.nl/~herman/note.ps.gz). + (see http://www.cs.kun.nl/~herman/note.ps.gz). *) Section Paradox. diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v index 740b889a..3651c1b2 100644 --- a/theories/Logic/IndefiniteDescription.v +++ b/theories/Logic/IndefiniteDescription.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: IndefiniteDescription.v 10170 2007-10-03 14:41:25Z herbelin $ i*) +(*i $Id$ i*) (** This file provides a constructive form of indefinite description that allows to build choice functions; this is weaker than Hilbert's @@ -19,11 +19,11 @@ Require Import ChoiceFacts. Set Implicit Arguments. Axiom constructive_indefinite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists x, P x) -> { x : A | P x }. Lemma constructive_definite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists! x, P x) -> { x : A | P x }. Proof. intros; apply constructive_indefinite_description; firstorder. diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index c3573ac3..fc4555a4 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: JMeq.v 9849 2007-05-22 20:40:04Z herbelin $ i*) +(*i $Id$ i*) (** John Major's Equality as proposed by Conor McBride @@ -28,44 +28,61 @@ Set Elimination Schemes. Hint Resolve JMeq_refl. -Lemma sym_JMeq : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x. +Lemma JMeq_sym : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x. +Proof. destruct 1; trivial. Qed. -Hint Immediate sym_JMeq. +Hint Immediate JMeq_sym. -Lemma trans_JMeq : +Lemma JMeq_trans : forall (A B C:Type) (x:A) (y:B) (z:C), JMeq x y -> JMeq y z -> JMeq x z. -destruct 1; trivial. +Proof. +destruct 2; trivial. Qed. Axiom JMeq_eq : forall (A:Type) (x y:A), JMeq x y -> x = y. -Lemma JMeq_ind : forall (A:Type) (x y:A) (P:A -> Prop), P x -> JMeq x y -> P y. -intros A x y P H H'; case JMeq_eq with (1 := H'); trivial. +Lemma JMeq_ind : forall (A:Type) (x:A) (P:A -> Prop), + P x -> forall y, JMeq x y -> P y. +Proof. +intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. Qed. -Lemma JMeq_rec : forall (A:Type) (x y:A) (P:A -> Set), P x -> JMeq x y -> P y. -intros A x y P H H'; case JMeq_eq with (1 := H'); trivial. +Lemma JMeq_rec : forall (A:Type) (x:A) (P:A -> Set), + P x -> forall y, JMeq x y -> P y. +Proof. +intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. Qed. -Lemma JMeq_rect : forall (A:Type) (x y:A) (P:A->Type), P x -> JMeq x y -> P y. -intros A x y P H H'; case JMeq_eq with (1 := H'); trivial. +Lemma JMeq_rect : forall (A:Type) (x:A) (P:A->Type), + P x -> forall y, JMeq x y -> P y. +Proof. +intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. +Qed. + +Lemma JMeq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), + P x -> forall y, JMeq y x -> P y. +Proof. +intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. Qed. -Lemma JMeq_ind_r : - forall (A:Type) (x y:A) (P:A -> Prop), P y -> JMeq x y -> P x. -intros A x y P H H'; case JMeq_eq with (1 := sym_JMeq H'); trivial. +Lemma JMeq_rec_r : forall (A:Type) (x:A) (P:A -> Set), + P x -> forall y, JMeq y x -> P y. +Proof. +intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. Qed. -Lemma JMeq_rec_r : - forall (A:Type) (x y:A) (P:A -> Set), P y -> JMeq x y -> P x. -intros A x y P H H'; case JMeq_eq with (1 := sym_JMeq H'); trivial. +Lemma JMeq_rect_r : forall (A:Type) (x:A) (P:A -> Type), + P x -> forall y, JMeq y x -> P y. +Proof. +intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. Qed. -Lemma JMeq_rect_r : - forall (A:Type) (x y:A) (P:A -> Type), P y -> JMeq x y -> P x. -intros A x y P H H'; case JMeq_eq with (1 := sym_JMeq H'); trivial. +Lemma JMeq_congr : + forall (A:Type) (x:A) (B:Type) (f:A->B) (y:A), JMeq x y -> f x = f y. +Proof. +intros A x B f y H; case JMeq_eq with (1 := H); trivial. Qed. (** [JMeq] is equivalent to [eq_dep Type (fun X => X)] *) @@ -107,3 +124,21 @@ intro H. assert (true=false) by (destruct H; reflexivity). discriminate. Qed. + +(** However, when the dependencies are equal, [JMeq (P p) x (P q) y] + is as strong as [eq_dep U P p x q y] (this uses [JMeq_eq]) *) + +Lemma JMeq_eq_dep : + forall U (P:U->Prop) p q (x:P p) (y:P q), + p = q -> JMeq x y -> eq_dep U P p x q y. +Proof. +intros. +destruct H. +apply JMeq_eq in H0 as ->. +reflexivity. +Qed. + + +(* Compatibility *) +Notation sym_JMeq := JMeq_sym (only parsing). +Notation trans_JMeq := JMeq_trans (only parsing). diff --git a/theories/Logic/ProofIrrelevanceFacts.v b/theories/Logic/ProofIrrelevanceFacts.v index dd3178eb..4c48d95c 100644 --- a/theories/Logic/ProofIrrelevanceFacts.v +++ b/theories/Logic/ProofIrrelevanceFacts.v @@ -21,8 +21,8 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance). (** Proof-irrelevance implies uniqueness of reflexivity proofs *) Module Eq_rect_eq. - Lemma eq_rect_eq : - forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), + Lemma eq_rect_eq : + forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. Proof. intros; rewrite M.proof_irrelevance with (p1:=h) (p2:=refl_equal p). diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v index ec168f09..49fa1222 100644 --- a/theories/Logic/RelationalChoice.v +++ b/theories/Logic/RelationalChoice.v @@ -6,12 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RelationalChoice.v 8892 2006-06-04 17:59:53Z herbelin $ i*) +(*i $Id$ i*) (** This file axiomatizes the relational form of the axiom of choice *) Axiom relational_choice : forall (A B : Type) (R : A->B->Prop), (forall x : A, exists y : B, R x y) -> - exists R' : A->B->Prop, + exists R' : A->B->Prop, subrelation R' R /\ forall x : A, exists! y : B, R' x y. diff --git a/theories/Logic/vo.itarget b/theories/Logic/vo.itarget new file mode 100644 index 00000000..46046897 --- /dev/null +++ b/theories/Logic/vo.itarget @@ -0,0 +1,28 @@ +Berardi.vo +ChoiceFacts.vo +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 +Decidable.vo +Description.vo +Diaconescu.vo +Epsilon.vo +Eqdep_dec.vo +EqdepFacts.vo +Eqdep.vo +FunctionalExtensionality.vo +Hurkens.vo +IndefiniteDescription.vo +JMeq.vo +ProofIrrelevanceFacts.vo +ProofIrrelevance.vo +RelationalChoice.vo +SetIsType.vo diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v new file mode 100644 index 00000000..c41df7c2 --- /dev/null +++ b/theories/MSets/MSetAVL.v @@ -0,0 +1,1842 @@ +(* -*- coding: utf-8 -*- *) +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* X.t -> tree -> int -> tree. + +Definition t := tree. + +(** ** Basic functions on trees: height and cardinal *) + +Definition height (s : t) : int := + match s with + | Leaf => 0 + | Node _ _ _ h => h + end. + +Fixpoint cardinal (s : t) : nat := + match s with + | Leaf => 0%nat + | Node l _ r _ => S (cardinal l + cardinal r) + end. + +(** ** Empty Set *) + +Definition empty := Leaf. + +(** ** Emptyness test *) + +Definition is_empty s := + match s with Leaf => true | _ => false end. + +(** ** Appartness *) + +(** The [mem] function is deciding appartness. It exploits the + binary search tree invariant to achieve logarithmic complexity. *) + +Fixpoint mem x s := + match s with + | Leaf => false + | Node l y r _ => match X.compare x y with + | Lt => mem x l + | Eq => true + | Gt => mem x r + end + end. + +(** ** Singleton set *) + +Definition singleton x := Node Leaf x Leaf 1. + +(** ** Helper functions *) + +(** [create l x r] creates a node, assuming [l] and [r] + to be balanced and [|height l - height r| <= 2]. *) + +Definition create l x r := + Node l x r (max (height l) (height r) + 1). + +(** [bal l x r] acts as [create], but performs one step of + rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) + +Definition assert_false := create. + +Definition bal l x r := + let hl := height l in + let hr := height r in + if gt_le_dec hl (hr+2) then + match l with + | Leaf => assert_false l x r + | Node ll lx lr _ => + if ge_lt_dec (height ll) (height lr) then + create ll lx (create lr x r) + else + match lr with + | Leaf => assert_false l x r + | Node lrl lrx lrr _ => + create (create ll lx lrl) lrx (create lrr x r) + end + end + else + if gt_le_dec hr (hl+2) then + match r with + | Leaf => assert_false l x r + | Node rl rx rr _ => + if ge_lt_dec (height rr) (height rl) then + create (create l x rl) rx rr + else + match rl with + | Leaf => assert_false l x r + | Node rll rlx rlr _ => + create (create l x rll) rlx (create rlr rx rr) + end + end + else + create l x r. + +(** ** Insertion *) + +Fixpoint add x s := match s with + | Leaf => Node Leaf x Leaf 1 + | Node l y r h => + match X.compare x y with + | Lt => bal (add x l) y r + | Eq => Node l y r h + | Gt => bal l y (add x r) + end + end. + +(** ** Join + + Same as [bal] but does not assume anything regarding heights + of [l] and [r]. +*) + +Fixpoint join l : elt -> t -> t := + match l with + | Leaf => add + | Node ll lx lr lh => fun x => + fix join_aux (r:t) : t := match r with + | Leaf => add x l + | Node rl rx rr rh => + if gt_le_dec lh (rh+2) then bal ll lx (join lr x r) + else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr + else create l x r + end + end. + +(** ** Extraction of minimum element + + Morally, [remove_min] is to be applied to a non-empty tree + [t = Node l x r h]. Since we can't deal here with [assert false] + for [t=Leaf], we pre-unpack [t] (and forget about [h]). +*) + +Fixpoint remove_min l x r : t*elt := + match l with + | Leaf => (r,x) + | Node ll lx lr lh => + let (l',m) := remove_min ll lx lr in (bal l' x r, m) + end. + +(** ** Merging two trees + + [merge t1 t2] builds the union of [t1] and [t2] assuming all elements + of [t1] to be smaller than all elements of [t2], and + [|height t1 - height t2| <= 2]. +*) + +Definition merge s1 s2 := match s1,s2 with + | Leaf, _ => s2 + | _, Leaf => s1 + | _, Node l2 x2 r2 h2 => + let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2' +end. + +(** ** Deletion *) + +Fixpoint remove x s := match s with + | Leaf => Leaf + | Node l y r h => + match X.compare x y with + | Lt => bal (remove x l) y r + | Eq => merge l r + | Gt => bal l y (remove x r) + end + end. + +(** ** Minimum element *) + +Fixpoint min_elt s := match s with + | Leaf => None + | Node Leaf y _ _ => Some y + | Node l _ _ _ => min_elt l +end. + +(** ** Maximum element *) + +Fixpoint max_elt s := match s with + | Leaf => None + | Node _ y Leaf _ => Some y + | Node _ _ r _ => max_elt r +end. + +(** ** Any element *) + +Definition choose := min_elt. + +(** ** Concatenation + + Same as [merge] but does not assume anything about heights. +*) + +Definition concat s1 s2 := + match s1, s2 with + | Leaf, _ => s2 + | _, Leaf => s1 + | _, Node l2 x2 r2 _ => + let (s2',m) := remove_min l2 x2 r2 in + join s1 m s2' + end. + +(** ** Splitting + + [split x s] returns a triple [(l, present, r)] where + - [l] is the set of elements of [s] that are [< x] + - [r] is the set of elements of [s] that are [> x] + - [present] is [true] if and only if [s] contains [x]. +*) + +Record triple := mktriple { t_left:t; t_in:bool; t_right:t }. +Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). + +Fixpoint split x s : triple := match s with + | Leaf => << Leaf, false, Leaf >> + | Node l y r h => + match X.compare x y with + | Lt => let (ll,b,rl) := split x l in << ll, b, join rl y r >> + | Eq => << l, true, r >> + | Gt => let (rl,b,rr) := split x r in << join l y rl, b, rr >> + end + end. + +(** ** Intersection *) + +Fixpoint inter s1 s2 := match s1, s2 with + | Leaf, _ => Leaf + | _, Leaf => Leaf + | Node l1 x1 r1 h1, _ => + let (l2',pres,r2') := split x1 s2 in + if pres then join (inter l1 l2') x1 (inter r1 r2') + else concat (inter l1 l2') (inter r1 r2') + end. + +(** ** Difference *) + +Fixpoint diff s1 s2 := match s1, s2 with + | Leaf, _ => Leaf + | _, Leaf => s1 + | Node l1 x1 r1 h1, _ => + let (l2',pres,r2') := split x1 s2 in + if pres then concat (diff l1 l2') (diff r1 r2') + else join (diff l1 l2') x1 (diff r1 r2') +end. + +(** ** Union *) + +(** In ocaml, heights of [s1] and [s2] are compared each time in order + to recursively perform the split on the smaller set. + Unfortunately, this leads to a non-structural algorithm. The + following code is a simplification of the ocaml version: no + comparison of heights. It might be slightly slower, but + experimentally all the tests I've made in ocaml have shown this + potential slowdown to be non-significant. Anyway, the exact code + of ocaml has also been formalized thanks to Function+measure, see + [ocaml_union] in [MSetFullAVL]. +*) + +Fixpoint union s1 s2 := + match s1, s2 with + | Leaf, _ => s2 + | _, Leaf => s1 + | Node l1 x1 r1 h1, _ => + let (l2',_,r2') := split x1 s2 in + join (union l1 l2') x1 (union r1 r2') + end. + +(** ** Elements *) + +(** [elements_tree_aux acc t] catenates the elements of [t] in infix + order to the list [acc] *) + +Fixpoint elements_aux (acc : list X.t) (s : t) : list X.t := + match s with + | Leaf => acc + | Node l x r _ => elements_aux (x :: elements_aux acc r) l + end. + +(** then [elements] is an instanciation with an empty [acc] *) + +Definition elements := elements_aux nil. + +(** ** Filter *) + +Fixpoint filter_acc (f:elt->bool) acc s := match s with + | Leaf => acc + | Node l x r h => + filter_acc f (filter_acc f (if f x then add x acc else acc) l) r + end. + +Definition filter f := filter_acc f Leaf. + + +(** ** Partition *) + +Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t := + match s with + | Leaf => acc + | Node l x r _ => + let (acct,accf) := acc in + partition_acc f + (partition_acc f + (if f x then (add x acct, accf) else (acct, add x accf)) l) r + end. + +Definition partition f := partition_acc f (Leaf,Leaf). + +(** ** [for_all] and [exists] *) + +Fixpoint for_all (f:elt->bool) s := match s with + | Leaf => true + | Node l x r _ => f x &&& for_all f l &&& for_all f r +end. + +Fixpoint exists_ (f:elt->bool) s := match s with + | Leaf => false + | Node l x r _ => f x ||| exists_ f l ||| exists_ f r +end. + +(** ** Fold *) + +Fixpoint fold (A : Type) (f : elt -> A -> A)(s : t) : A -> A := + fun a => match s with + | Leaf => a + | Node l x r _ => fold f r (f x (fold f l a)) + end. +Implicit Arguments fold [A]. + + +(** ** Subset *) + +(** In ocaml, recursive calls are made on "half-trees" such as + (Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these + non-structural calls, we propose here two specialized functions for + these situations. This version should be almost as efficient as + the one of ocaml (closures as arguments may slow things a bit), + it is simply less compact. The exact ocaml version has also been + formalized (thanks to Function+measure), see [ocaml_subset] in + [MSetFullAVL]. + *) + +Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool := + match s2 with + | Leaf => false + | Node l2 x2 r2 h2 => + match X.compare x1 x2 with + | Eq => subset_l1 l2 + | Lt => subsetl subset_l1 x1 l2 + | Gt => mem x1 r2 &&& subset_l1 s2 + end + end. + +Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool := + match s2 with + | Leaf => false + | Node l2 x2 r2 h2 => + match X.compare x1 x2 with + | Eq => subset_r1 r2 + | Lt => mem x1 l2 &&& subset_r1 s2 + | Gt => subsetr subset_r1 x1 r2 + end + end. + +Fixpoint subset s1 s2 : bool := match s1, s2 with + | Leaf, _ => true + | Node _ _ _ _, Leaf => false + | Node l1 x1 r1 h1, Node l2 x2 r2 h2 => + match X.compare x1 x2 with + | Eq => subset l1 l2 &&& subset r1 r2 + | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2 + | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2 + end + end. + +(** ** A new comparison algorithm suggested by Xavier Leroy + + Transformation in C.P.S. suggested by Benjamin Grégoire. + The original ocaml code (with non-structural recursive calls) + has also been formalized (thanks to Function+measure), see + [ocaml_compare] in [MSetFullAVL]. The following code with + continuations computes dramatically faster in Coq, and + should be almost as efficient after extraction. +*) + +(** Enumeration of the elements of a tree *) + +Inductive enumeration := + | End : enumeration + | More : elt -> t -> enumeration -> enumeration. + + +(** [cons t e] adds the elements of tree [t] on the head of + enumeration [e]. *) + +Fixpoint cons s e : enumeration := + match s with + | Leaf => e + | Node l x r h => cons l (More x r e) + end. + +(** One step of comparison of elements *) + +Definition compare_more x1 (cont:enumeration->comparison) e2 := + match e2 with + | End => Gt + | More x2 r2 e2 => + match X.compare x1 x2 with + | Eq => cont (cons r2 e2) + | Lt => Lt + | Gt => Gt + end + end. + +(** Comparison of left tree, middle element, then right tree *) + +Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := + match s1 with + | Leaf => cont e2 + | Node l1 x1 r1 _ => + compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2 + end. + +(** Initial continuation *) + +Definition compare_end e2 := + match e2 with End => Eq | _ => Lt end. + +(** The complete comparison *) + +Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End). + +(** ** Equality test *) + +Definition equal s1 s2 : bool := + match compare s1 s2 with + | Eq => true + | _ => false + end. + +End Ops. + + + +(** * MakeRaw + + Functor of pure functions + a posteriori proofs of invariant + preservation *) + +Module MakeRaw (Import I:Int)(X:OrderedType) <: RawSets X. +Include Ops I X. + +(** * Invariants *) + +(** ** Occurrence in a tree *) + +Inductive InT (x : elt) : tree -> Prop := + | IsRoot : forall l r h y, X.eq x y -> InT x (Node l y r h) + | InLeft : forall l r h y, InT x l -> InT x (Node l y r h) + | InRight : forall l r h y, InT x r -> InT x (Node l y r h). + +Definition In := InT. + +(** ** Some shortcuts *) + +Definition Equal s s' := forall a : elt, InT a s <-> InT a s'. +Definition Subset s s' := forall a : elt, InT a s -> InT a s'. +Definition Empty s := forall a : elt, ~ InT a s. +Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x. +Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x. + +(** ** Binary search trees *) + +(** [lt_tree x s]: all elements in [s] are smaller than [x] + (resp. greater for [gt_tree]) *) + +Definition lt_tree x s := forall y, InT y s -> X.lt y x. +Definition gt_tree x s := forall y, InT y s -> X.lt x y. + +(** [bst t] : [t] is a binary search tree *) + +Inductive bst : tree -> Prop := + | BSLeaf : bst Leaf + | BSNode : forall x l r h, bst l -> bst r -> + lt_tree x l -> gt_tree x r -> bst (Node l x r h). + +(** [bst] is the (decidable) invariant our trees will have to satisfy. *) + +Definition IsOk := bst. + +Class Ok (s:t) : Prop := ok : bst s. + +Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }. + +Fixpoint ltb_tree x s := + match s with + | Leaf => true + | Node l y r _ => + match X.compare x y with + | Gt => ltb_tree x l && ltb_tree x r + | _ => false + end + end. + +Fixpoint gtb_tree x s := + match s with + | Leaf => true + | Node l y r _ => + match X.compare x y with + | Lt => gtb_tree x l && gtb_tree x r + | _ => false + end + end. + +Fixpoint isok s := + match s with + | Leaf => true + | Node l x r _ => isok l && isok r && ltb_tree x l && gtb_tree x r + end. + + +(** * Correctness proofs *) + +Module Import MX := OrderedTypeFacts X. + +(** * Automation and dedicated tactics *) + +Scheme tree_ind := Induction for tree Sort Prop. + +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. +Local Hint Unfold Ok. + +Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h) + "as" ident(s) := + set (s:=Node l x r h) in *; clearbody s; clear l x r h. + +(** Automatic treatment of [Ok] hypothesis *) + +Ltac inv_ok := match goal with + | H:Ok (Node _ _ _ _) |- _ => inversion_clear H; inv_ok + | H:Ok Leaf |- _ => clear H; inv_ok + | H:bst ?x |- _ => change (Ok x) in H; inv_ok + | _ => idtac +end. + +(** A tactic to repeat [inversion_clear] on all hyps of the + form [(f (Node _ _ _ _))] *) + +Ltac is_tree_constr c := + match c with + | Leaf => idtac + | Node _ _ _ _ => idtac + | _ => fail + end. + +Ltac invtree f := + match goal with + | H:f ?s |- _ => is_tree_constr s; inversion_clear H; invtree f + | H:f _ ?s |- _ => is_tree_constr s; inversion_clear H; invtree f + | H:f _ _ ?s |- _ => is_tree_constr s; inversion_clear H; invtree f + | _ => idtac + end. + +Ltac inv := inv_ok; invtree InT. + +Ltac intuition_in := repeat progress (intuition; inv). + +(** Helper tactic concerning order of elements. *) + +Ltac order := match goal with + | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order + | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order + | _ => MX.order +end. + + +(** [isok] is indeed a decision procedure for [Ok] *) + +Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true. +Proof. + induction s as [|l IHl y r IHr h]; simpl. + unfold lt_tree; intuition_in. + elim_compare x y. + split; intros; try discriminate. assert (X.lt y x) by auto. order. + split; intros; try discriminate. assert (X.lt y x) by auto. order. + rewrite !andb_true_iff, <-IHl, <-IHr. + unfold lt_tree; intuition_in; order. +Qed. + +Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true. +Proof. + induction s as [|l IHl y r IHr h]; simpl. + unfold gt_tree; intuition_in. + elim_compare x y. + split; intros; try discriminate. assert (X.lt x y) by auto. order. + rewrite !andb_true_iff, <-IHl, <-IHr. + unfold gt_tree; intuition_in; order. + split; intros; try discriminate. assert (X.lt x y) by auto. order. +Qed. + +Lemma isok_iff : forall s, Ok s <-> isok s = true. +Proof. + induction s as [|l IHl y r IHr h]; simpl. + intuition_in. + rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff. + intuition_in. +Qed. + +Instance isok_Ok s : isok s = true -> Ok s | 10. +Proof. intros; apply <- isok_iff; auto. Qed. + + +(** * Basic results about [In], [lt_tree], [gt_tree], [height] *) + +(** [In] is compatible with [X.eq] *) + +Lemma In_1 : + forall s x y, X.eq x y -> InT x s -> InT y s. +Proof. + induction s; simpl; intuition_in; eauto. +Qed. +Local Hint Immediate In_1. + +Instance In_compat : Proper (X.eq==>eq==>iff) InT. +Proof. +apply proper_sym_impl_iff_2; auto with *. +repeat red; intros; subst. apply In_1 with x; auto. +Qed. + +Lemma In_node_iff : + forall l x r h y, + InT y (Node l x r h) <-> InT y l \/ X.eq y x \/ InT y r. +Proof. + intuition_in. +Qed. + +(** Results about [lt_tree] and [gt_tree] *) + +Lemma lt_leaf : forall x : elt, lt_tree x Leaf. +Proof. + red; inversion 1. +Qed. + +Lemma gt_leaf : forall x : elt, gt_tree x Leaf. +Proof. + red; inversion 1. +Qed. + +Lemma lt_tree_node : + forall (x y : elt) (l r : tree) (h : int), + lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h). +Proof. + unfold lt_tree; intuition_in; order. +Qed. + +Lemma gt_tree_node : + forall (x y : elt) (l r : tree) (h : int), + gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h). +Proof. + unfold gt_tree; intuition_in; order. +Qed. + +Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. + +Lemma lt_tree_not_in : + forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t. +Proof. + intros; intro; order. +Qed. + +Lemma lt_tree_trans : + forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t. +Proof. + eauto. +Qed. + +Lemma gt_tree_not_in : + forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t. +Proof. + intros; intro; order. +Qed. + +Lemma gt_tree_trans : + forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t. +Proof. + eauto. +Qed. + +Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. + +(** * Inductions principles for some of the set operators *) + +Functional Scheme bal_ind := Induction for bal Sort Prop. +Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. +Functional Scheme merge_ind := Induction for merge Sort Prop. +Functional Scheme min_elt_ind := Induction for min_elt Sort Prop. +Functional Scheme max_elt_ind := Induction for max_elt Sort Prop. +Functional Scheme concat_ind := Induction for concat Sort Prop. +Functional Scheme inter_ind := Induction for inter Sort Prop. +Functional Scheme diff_ind := Induction for diff Sort Prop. +Functional Scheme union_ind := Induction for union Sort Prop. + +Ltac induct s x := + induction s as [|l IHl x' r IHr h]; simpl; intros; + [|elim_compare x x'; intros; inv]. + + +(** * Notations and helper lemma about pairs and triples *) + +Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. +Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. +Notation "t #l" := (t_left t) (at level 9, format "t '#l'") : pair_scope. +Notation "t #b" := (t_in t) (at level 9, format "t '#b'") : pair_scope. +Notation "t #r" := (t_right t) (at level 9, format "t '#r'") : pair_scope. + +Open Local Scope pair_scope. + + +(** * Empty set *) + +Lemma empty_spec : Empty empty. +Proof. + intro; intro. + inversion H. +Qed. + +Instance empty_ok : Ok empty. +Proof. + auto. +Qed. + +(** * Emptyness test *) + +Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s. +Proof. + destruct s as [|r x l h]; simpl; auto. + split; auto. red; red; intros; inv. + split; auto. try discriminate. intro H; elim (H x); auto. +Qed. + +(** * Appartness *) + +Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s. +Proof. + split. + induct s x; auto; try discriminate. + induct s x; intuition_in; order. +Qed. + + +(** * Singleton set *) + +Lemma singleton_spec : forall x y, InT y (singleton x) <-> X.eq y x. +Proof. + unfold singleton; intuition_in. +Qed. + +Instance singleton_ok x : Ok (singleton x). +Proof. + unfold singleton; auto. +Qed. + + + +(** * Helper functions *) + +Lemma create_spec : + forall l x r y, InT y (create l x r) <-> X.eq y x \/ InT y l \/ InT y r. +Proof. + unfold create; split; [ inversion_clear 1 | ]; intuition. +Qed. + +Instance create_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : + Ok (create l x r). +Proof. + unfold create; auto. +Qed. + +Lemma bal_spec : forall l x r y, + InT y (bal l x r) <-> X.eq y x \/ InT y l \/ InT y r. +Proof. + intros l x r; functional induction bal l x r; intros; try clear e0; + rewrite !create_spec; intuition_in. +Qed. + +Instance bal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : + Ok (bal l x r). +Proof. + functional induction bal l x r; intros; + inv; repeat apply create_ok; auto; unfold create; + (apply lt_tree_node || apply gt_tree_node); auto; + (eapply lt_tree_trans || eapply gt_tree_trans); eauto. +Qed. + + +(** * Insertion *) + +Lemma add_spec' : forall s x y, + InT y (add x s) <-> X.eq y x \/ InT y s. +Proof. + induct s x; try rewrite ?bal_spec, ?IHl, ?IHr; intuition_in. + setoid_replace y with x'; eauto. +Qed. + +Lemma add_spec : forall s x y `{Ok s}, + InT y (add x s) <-> X.eq y x \/ InT y s. +Proof. intros; apply add_spec'. Qed. + +Instance add_ok s x `(Ok s) : Ok (add x s). +Proof. + induct s x; auto; apply bal_ok; auto; + intros y; rewrite add_spec'; intuition; order. +Qed. + + +Open Scope Int_scope. + +(** * Join *) + +(* Function/Functional Scheme can't deal with internal fix. + Let's do its job by hand: *) + +Ltac join_tac := + intro l; induction l as [| ll _ lx lr Hlr lh]; + [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join; + [ | destruct (gt_le_dec lh (rh+2)); + [ match goal with |- context b [ bal ?a ?b ?c] => + replace (bal a b c) + with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto] + end + | destruct (gt_le_dec rh (lh+2)); + [ match goal with |- context b [ bal ?a ?b ?c] => + replace (bal a b c) + with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto] + end + | ] ] ] ]; intros. + +Lemma join_spec : forall l x r y, + InT y (join l x r) <-> X.eq y x \/ InT y l \/ InT y r. +Proof. + join_tac. + simpl. + rewrite add_spec'; intuition_in. + rewrite add_spec'; intuition_in. + rewrite bal_spec, Hlr; clear Hlr Hrl; intuition_in. + rewrite bal_spec, Hrl; clear Hlr Hrl; intuition_in. + apply create_spec. +Qed. + +Instance join_ok : forall l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r), + Ok (join l x r). +Proof. + join_tac; auto with *; inv; apply bal_ok; auto; + clear Hrl Hlr z; intro; intros; rewrite join_spec in *. + intuition; [ setoid_replace y with x | ]; eauto. + intuition; [ setoid_replace y with x | ]; eauto. +Qed. + + +(** * Extraction of minimum element *) + +Lemma remove_min_spec : forall l x r h y, + InT y (Node l x r h) <-> + X.eq y (remove_min l x r)#2 \/ InT y (remove_min l x r)#1. +Proof. + intros l x r; functional induction (remove_min l x r); simpl in *; intros. + intuition_in. + rewrite bal_spec, In_node_iff, IHp, e0; simpl; intuition. +Qed. + +Instance remove_min_ok l x r : forall h `(Ok (Node l x r h)), + Ok (remove_min l x r)#1. +Proof. + functional induction (remove_min l x r); simpl; intros. + inv; auto. + assert (O : Ok (Node ll lx lr _x)) by (inv; auto). + assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto). + specialize IHp with (1:=O); rewrite e0 in IHp; auto; simpl in *. + apply bal_ok; auto. + inv; auto. + intro y; specialize (L y). + rewrite remove_min_spec, e0 in L; simpl in L; intuition. + inv; auto. +Qed. + +Lemma remove_min_gt_tree : forall l x r h `{Ok (Node l x r h)}, + gt_tree (remove_min l x r)#2 (remove_min l x r)#1. +Proof. + intros l x r; functional induction (remove_min l x r); simpl; intros. + inv; auto. + assert (O : Ok (Node ll lx lr _x)) by (inv; auto). + assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto). + specialize IHp with (1:=O); rewrite e0 in IHp; simpl in IHp. + intro y; rewrite bal_spec; intuition; + specialize (L m); rewrite remove_min_spec, e0 in L; simpl in L; + [setoid_replace y with x|inv]; eauto. +Qed. +Local Hint Resolve remove_min_gt_tree. + + + +(** * Merging two trees *) + +Lemma merge_spec : forall s1 s2 y, + InT y (merge s1 s2) <-> InT y s1 \/ InT y s2. +Proof. + intros s1 s2; functional induction (merge s1 s2); intros; + try factornode _x _x0 _x1 _x2 as s1. + intuition_in. + intuition_in. + rewrite bal_spec, remove_min_spec, e1; simpl; intuition. +Qed. + +Instance merge_ok s1 s2 : forall `(Ok s1, Ok s2) + `(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2), + Ok (merge s1 s2). +Proof. + functional induction (merge s1 s2); intros; auto; + try factornode _x _x0 _x1 _x2 as s1. + apply bal_ok; auto. + change s2' with ((s2',m)#1); rewrite <-e1; eauto with *. + intros y Hy. + apply H1; auto. + rewrite remove_min_spec, e1; simpl; auto. + change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto. +Qed. + + + +(** * Deletion *) + +Lemma remove_spec : forall s x y `{Ok s}, + (InT y (remove x s) <-> InT y s /\ ~ X.eq y x). +Proof. + induct s x. + intuition_in. + rewrite merge_spec; intuition; [order|order|intuition_in]. + elim H6; eauto. + rewrite bal_spec, IHl; clear IHl IHr; intuition; [order|order|intuition_in]. + rewrite bal_spec, IHr; clear IHl IHr; intuition; [order|order|intuition_in]. +Qed. + +Instance remove_ok s x `(Ok s) : Ok (remove x s). +Proof. + induct s x. + auto. + (* EQ *) + apply merge_ok; eauto. + (* LT *) + apply bal_ok; auto. + intro z; rewrite remove_spec; auto; destruct 1; eauto. + (* GT *) + apply bal_ok; auto. + intro z; rewrite remove_spec; auto; destruct 1; eauto. +Qed. + + +(** * Minimum element *) + +Lemma min_elt_spec1 : forall s x, min_elt s = Some x -> InT x s. +Proof. + intro s; functional induction (min_elt s); auto; inversion 1; auto. +Qed. + +Lemma min_elt_spec2 : forall s x y `{Ok s}, + min_elt s = Some x -> InT y s -> ~ X.lt y x. +Proof. + intro s; functional induction (min_elt s); + try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. + discriminate. + intros x y0 U V W. + inversion V; clear V; subst. + inv; order. + intros; inv; auto. + assert (X.lt x y) by (apply H4; apply min_elt_spec1; auto). + order. + assert (X.lt x1 y) by auto. + assert (~X.lt x1 x) by auto. + order. +Qed. + +Lemma min_elt_spec3 : forall s, min_elt s = None -> Empty s. +Proof. + intro s; functional induction (min_elt s). + red; red; inversion 2. + inversion 1. + intro H0. + destruct (IHo H0 _x2); auto. +Qed. + + + +(** * Maximum element *) + +Lemma max_elt_spec1 : forall s x, max_elt s = Some x -> InT x s. +Proof. + intro s; functional induction (max_elt s); auto; inversion 1; auto. +Qed. + +Lemma max_elt_spec2 : forall s x y `{Ok s}, + max_elt s = Some x -> InT y s -> ~ X.lt x y. +Proof. + intro s; functional induction (max_elt s); + try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. + discriminate. + intros x y0 U V W. + inversion V; clear V; subst. + inv; order. + intros; inv; auto. + assert (X.lt y x1) by auto. + assert (~ X.lt x x1) by auto. + order. + assert (X.lt y x) by (apply H5; apply max_elt_spec1; auto). + order. +Qed. + +Lemma max_elt_spec3 : forall s, max_elt s = None -> Empty s. +Proof. + intro s; functional induction (max_elt s). + red; auto. + inversion 1. + intros H0; destruct (IHo H0 _x2); auto. +Qed. + + + +(** * Any element *) + +Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s. +Proof. + exact min_elt_spec1. +Qed. + +Lemma choose_spec2 : forall s, choose s = None -> Empty s. +Proof. + exact min_elt_spec3. +Qed. + +Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'}, + choose s = Some x -> choose s' = Some x' -> + Equal s s' -> X.eq x x'. +Proof. + unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H. + assert (~X.lt x x'). + apply min_elt_spec2 with s'; auto. + rewrite <-H; auto using min_elt_spec1. + assert (~X.lt x' x). + apply min_elt_spec2 with s; auto. + rewrite H; auto using min_elt_spec1. + elim_compare x x'; intuition. +Qed. + + +(** * Concatenation *) + +Lemma concat_spec : forall s1 s2 y, + InT y (concat s1 s2) <-> InT y s1 \/ InT y s2. +Proof. + intros s1 s2; functional induction (concat s1 s2); intros; + try factornode _x _x0 _x1 _x2 as s1. + intuition_in. + intuition_in. + rewrite join_spec, remove_min_spec, e1; simpl; intuition. +Qed. + +Instance concat_ok s1 s2 : forall `(Ok s1, Ok s2) + `(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2), + Ok (concat s1 s2). +Proof. + functional induction (concat s1 s2); intros; auto; + try factornode _x _x0 _x1 _x2 as s1. + apply join_ok; auto. + change (Ok (s2',m)#1); rewrite <-e1; eauto with *. + intros y Hy. + apply H1; auto. + rewrite remove_min_spec, e1; simpl; auto. + change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto. +Qed. + + + +(** * Splitting *) + +Lemma split_spec1 : forall s x y `{Ok s}, + (InT y (split x s)#l <-> InT y s /\ X.lt y x). +Proof. + induct s x. + intuition_in. + intuition_in; order. + specialize (IHl x y). + destruct (split x l); simpl in *. rewrite IHl; intuition_in; order. + specialize (IHr x y). + destruct (split x r); simpl in *. rewrite join_spec, IHr; intuition_in; order. +Qed. + +Lemma split_spec2 : forall s x y `{Ok s}, + (InT y (split x s)#r <-> InT y s /\ X.lt x y). +Proof. + induct s x. + intuition_in. + intuition_in; order. + specialize (IHl x y). + destruct (split x l); simpl in *. rewrite join_spec, IHl; intuition_in; order. + specialize (IHr x y). + destruct (split x r); simpl in *. rewrite IHr; intuition_in; order. +Qed. + +Lemma split_spec3 : forall s x `{Ok s}, + ((split x s)#b = true <-> InT x s). +Proof. + induct s x. + intuition_in; try discriminate. + intuition. + specialize (IHl x). + destruct (split x l); simpl in *. rewrite IHl; intuition_in; order. + specialize (IHr x). + destruct (split x r); simpl in *. rewrite IHr; intuition_in; order. +Qed. + +Lemma split_ok : forall s x `{Ok s}, Ok (split x s)#l /\ Ok (split x s)#r. +Proof. + induct s x; simpl; auto. + specialize (IHl x). + generalize (fun y => @split_spec2 _ x y H1). + destruct (split x l); simpl in *; intuition. apply join_ok; auto. + intros y; rewrite H; intuition. + specialize (IHr x). + generalize (fun y => @split_spec1 _ x y H2). + destruct (split x r); simpl in *; intuition. apply join_ok; auto. + intros y; rewrite H; intuition. +Qed. + +Instance split_ok1 s x `(Ok s) : Ok (split x s)#l. +Proof. intros; destruct (@split_ok s x); auto. Qed. + +Instance split_ok2 s x `(Ok s) : Ok (split x s)#r. +Proof. intros; destruct (@split_ok s x); auto. Qed. + + +(** * Intersection *) + +Ltac destruct_split := match goal with + | H : split ?x ?s = << ?u, ?v, ?w >> |- _ => + assert ((split x s)#l = u) by (rewrite H; auto); + assert ((split x s)#b = v) by (rewrite H; auto); + assert ((split x s)#r = w) by (rewrite H; auto); + clear H; subst u w + end. + +Lemma inter_spec_ok : forall s1 s2 `{Ok s1, Ok s2}, + Ok (inter s1 s2) /\ (forall y, InT y (inter s1 s2) <-> InT y s1 /\ InT y s2). +Proof. + intros s1 s2; functional induction inter s1 s2; intros B1 B2; + [intuition_in|intuition_in | | ]; + factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv; + destruct IHt0 as (IHo1,IHi1), IHt1 as (IHo2,IHi2); auto with *; + split; intros. + (* Ok join *) + apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition. + (* InT join *) + rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in. + setoid_replace y with x1; auto. rewrite <- split_spec3; auto. + (* Ok concat *) + apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2; intuition; order. + (* InT concat *) + rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto. + intuition_in. + absurd (InT x1 s2). + rewrite <- split_spec3; auto; congruence. + setoid_replace x1 with y; auto. +Qed. + +Lemma inter_spec : forall s1 s2 y `{Ok s1, Ok s2}, + (InT y (inter s1 s2) <-> InT y s1 /\ InT y s2). +Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed. + +Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2). +Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed. + + +(** * Difference *) + +Lemma diff_spec_ok : forall s1 s2 `{Ok s1, Ok s2}, + Ok (diff s1 s2) /\ (forall y, InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2). +Proof. + intros s1 s2; functional induction diff s1 s2; intros B1 B2; + [intuition_in|intuition_in | | ]; + factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv; + destruct IHt0 as (IHb1,IHi1), IHt1 as (IHb2,IHi2); auto with *; + split; intros. + (* Ok concat *) + apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order. + (* InT concat *) + rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in. + absurd (InT x1 s2). + setoid_replace x1 with y; auto. + rewrite <- split_spec3; auto; congruence. + (* Ok join *) + apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition. + (* InT join *) + rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *. + intuition_in. + absurd (InT x1 s2); auto. + rewrite <- split_spec3; auto; congruence. + setoid_replace x1 with y; auto. +Qed. + +Lemma diff_spec : forall s1 s2 y `{Ok s1, Ok s2}, + (InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2). +Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed. + +Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2). +Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed. + + +(** * Union *) + +Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2}, + (InT y (union s1 s2) <-> InT y s1 \/ InT y s2). +Proof. + intros s1 s2; functional induction union s1 s2; intros y B1 B2. + intuition_in. + intuition_in. + factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv. + rewrite join_spec, IHt0, IHt1, split_spec1, split_spec2; auto with *. + elim_compare y x1; intuition_in. +Qed. + +Instance union_ok s1 s2 : forall `(Ok s1, Ok s2), Ok (union s1 s2). +Proof. + functional induction union s1 s2; intros B1 B2; auto. + factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv. + apply join_ok; auto with *. + intro y; rewrite union_spec, split_spec1; intuition_in. + intro y; rewrite union_spec, split_spec2; intuition_in. +Qed. + + +(** * Elements *) + +Lemma elements_spec1' : forall s acc x, + InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc. +Proof. + induction s as [ | l Hl x r Hr h ]; simpl; auto. + intuition. + inversion H0. + intros. + rewrite Hl. + destruct (Hr acc x0); clear Hl Hr. + intuition; inversion_clear H3; intuition. +Qed. + +Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s. +Proof. + intros; generalize (elements_spec1' s nil x); intuition. + inversion_clear H0. +Qed. + +Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc -> + (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) -> + sort X.lt (elements_aux acc s). +Proof. + induction s as [ | l Hl y r Hr h]; simpl; intuition. + inv. + apply Hl; auto. + constructor. + apply Hr; auto. + eapply InA_InfA; eauto with *. + intros. + destruct (elements_spec1' r acc y0); intuition. + intros. + inversion_clear H. + order. + destruct (elements_spec1' r acc x); intuition eauto. +Qed. + +Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s). +Proof. + intros; unfold elements; apply elements_spec2'; auto. + intros; inversion H0. +Qed. +Local Hint Resolve elements_spec2. + +Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s). +Proof. + intros. eapply SortA_NoDupA; eauto with *. +Qed. + +Lemma elements_aux_cardinal : + forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s). +Proof. + simple induction s; simpl in |- *; intuition. + rewrite <- H. + simpl in |- *. + rewrite <- H0; omega. +Qed. + +Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s). +Proof. + exact (fun s => elements_aux_cardinal s nil). +Qed. + +Definition cardinal_spec (s:t)(Hs:Ok s) := elements_cardinal s. + +Lemma elements_app : + forall s acc, elements_aux acc s = elements s ++ acc. +Proof. + induction s; simpl; intros; auto. + rewrite IHs1, IHs2. + unfold elements; simpl. + rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto. +Qed. + +Lemma elements_node : + forall l x r h acc, + elements l ++ x :: elements r ++ acc = + elements (Node l x r h) ++ acc. +Proof. + unfold elements; simpl; intros; auto. + rewrite !elements_app, <- !app_nil_end, !app_ass; auto. +Qed. + + +(** * Filter *) + +Lemma filter_spec' : forall s x acc f, + Proper (X.eq==>eq) f -> + (InT x (filter_acc f acc s) <-> InT x acc \/ InT x s /\ f x = true). +Proof. + induction s; simpl; intros. + intuition_in. + rewrite IHs2, IHs1 by (destruct (f t0); auto). + case_eq (f t0); intros. + rewrite add_spec'; auto. + intuition_in. + rewrite (H _ _ H2). + intuition. + intuition_in. + rewrite (H _ _ H2) in H3. + rewrite H0 in H3; discriminate. +Qed. + +Instance filter_ok' : forall s acc f `(Ok s, Ok acc), + Ok (filter_acc f acc s). +Proof. + induction s; simpl; auto. + intros. inv. + destruct (f t0); auto with *. +Qed. + +Lemma filter_spec : forall s x f, + Proper (X.eq==>eq) f -> + (InT x (filter f s) <-> InT x s /\ f x = true). +Proof. + unfold filter; intros; rewrite filter_spec'; intuition_in. +Qed. + +Instance filter_ok s f `(Ok s) : Ok (filter f s). +Proof. + unfold filter; intros; apply filter_ok'; auto. +Qed. + + +(** * Partition *) + +Lemma partition_spec1' : forall s acc f, + Proper (X.eq==>eq) f -> forall x : elt, + InT x (partition_acc f acc s)#1 <-> + InT x acc#1 \/ InT x s /\ f x = true. +Proof. + induction s; simpl; intros. + intuition_in. + destruct acc as [acct accf]; simpl in *. + rewrite IHs2 by + (destruct (f t0); auto; apply partition_acc_avl_1; simpl; auto). + rewrite IHs1 by (destruct (f t0); simpl; auto). + case_eq (f t0); simpl; intros. + rewrite add_spec'; auto. + intuition_in. + rewrite (H _ _ H2). + intuition. + intuition_in. + rewrite (H _ _ H2) in H3. + rewrite H0 in H3; discriminate. +Qed. + +Lemma partition_spec2' : forall s acc f, + Proper (X.eq==>eq) f -> forall x : elt, + InT x (partition_acc f acc s)#2 <-> + InT x acc#2 \/ InT x s /\ f x = false. +Proof. + induction s; simpl; intros. + intuition_in. + destruct acc as [acct accf]; simpl in *. + rewrite IHs2 by + (destruct (f t0); auto; apply partition_acc_avl_2; simpl; auto). + rewrite IHs1 by (destruct (f t0); simpl; auto). + case_eq (f t0); simpl; intros. + intuition. + intuition_in. + rewrite (H _ _ H2) in H3. + rewrite H0 in H3; discriminate. + rewrite add_spec'; auto. + intuition_in. + rewrite (H _ _ H2). + intuition. +Qed. + +Lemma partition_spec1 : forall s f, + Proper (X.eq==>eq) f -> + Equal (partition f s)#1 (filter f s). +Proof. + unfold partition; intros s f P x. + rewrite partition_spec1', filter_spec; simpl; intuition_in. +Qed. + +Lemma partition_spec2 : forall s f, + Proper (X.eq==>eq) f -> + Equal (partition f s)#2 (filter (fun x => negb (f x)) s). +Proof. + unfold partition; intros s f P x. + rewrite partition_spec2', filter_spec; simpl; intuition_in. + rewrite H1; auto. + right; split; auto. + rewrite negb_true_iff in H1; auto. + intros u v H; rewrite H; auto. +Qed. + +Instance partition_ok1' : forall s acc f `(Ok s, Ok acc#1), + Ok (partition_acc f acc s)#1. +Proof. + induction s; simpl; auto. + destruct acc as [acct accf]; simpl in *. + intros. inv. + destruct (f t0); auto. + apply IHs2; simpl; auto. + apply IHs1; simpl; auto with *. +Qed. + +Instance partition_ok2' : forall s acc f `(Ok s, Ok acc#2), + Ok (partition_acc f acc s)#2. +Proof. + induction s; simpl; auto. + destruct acc as [acct accf]; simpl in *. + intros. inv. + destruct (f t0); auto. + apply IHs2; simpl; auto. + apply IHs1; simpl; auto with *. +Qed. + +Instance partition_ok1 s f `(Ok s) : Ok (partition f s)#1. +Proof. apply partition_ok1'; auto. Qed. + +Instance partition_ok2 s f `(Ok s) : Ok (partition f s)#2. +Proof. apply partition_ok2'; auto. Qed. + + + +(** * [for_all] and [exists] *) + +Lemma for_all_spec : forall s f, Proper (X.eq==>eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). +Proof. + split. + induction s; simpl; auto; intros; red; intros; inv. + destruct (andb_prop _ _ H0); auto. + destruct (andb_prop _ _ H1); eauto. + apply IHs1; auto. + destruct (andb_prop _ _ H0); auto. + destruct (andb_prop _ _ H1); auto. + apply IHs2; auto. + destruct (andb_prop _ _ H0); auto. + (* <- *) + induction s; simpl; auto. + intros. red in H0. + rewrite IHs1; try red; auto. + rewrite IHs2; try red; auto. + generalize (H0 t0). + destruct (f t0); simpl; auto. +Qed. + +Lemma exists_spec : forall s f, Proper (X.eq==>eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). +Proof. + split. + induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *. + discriminate. + destruct (orb_true_elim _ _ H0) as [H1|H1]. + destruct (orb_true_elim _ _ H1) as [H2|H2]. + exists t0; auto. + destruct (IHs1 H2); auto; exists x; intuition. + destruct (IHs2 H1); auto; exists x; intuition. + (* <- *) + induction s; simpl; destruct 1 as (x,(U,V)); inv; rewrite <- ?orb_lazy_alt. + rewrite (H _ _ (MX.eq_sym H0)); rewrite V; auto. + apply orb_true_intro; left. + apply orb_true_intro; right; apply IHs1; auto; exists x; auto. + apply orb_true_intro; right; apply IHs2; auto; exists x; auto. +Qed. + + +(** * Fold *) + +Lemma fold_spec' : + forall (A : Type) (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt), + fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i). +Proof. + induction s as [|l IHl x r IHr h]; simpl; intros; auto. + rewrite IHl. + simpl. unfold flip at 2. + apply IHr. +Qed. + +Lemma fold_spec : + forall (s:t) (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. +Proof. + unfold elements. + induction s as [|l IHl x r IHr h]; simpl; intros; auto. + rewrite fold_spec'. + rewrite IHr. + simpl; auto. +Qed. + + +(** * Subset *) + +Lemma subsetl_spec : forall subset_l1 l1 x1 h1 s2 + `{Ok (Node l1 x1 Leaf h1), Ok s2}, + (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) -> + (subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ). +Proof. + induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. + unfold Subset; intuition; try discriminate. + assert (H': InT x1 Leaf) by auto; inversion H'. + specialize (IHl2 H). + specialize (IHr2 H). + inv. + elim_compare x1 x2. + + rewrite H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite IHl2 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. + rewrite mem_spec; auto. + assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order. +Qed. + + +Lemma subsetr_spec : forall subset_r1 r1 x1 h1 s2, + bst (Node Leaf x1 r1 h1) -> bst s2 -> + (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> + (subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2). +Proof. + induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. + unfold Subset; intuition; try discriminate. + assert (H': InT x1 Leaf) by auto; inversion H'. + specialize (IHl2 H). + specialize (IHr2 H). + inv. + elim_compare x1 x2. + + rewrite H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. + rewrite mem_spec; auto. + assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite IHr2 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. +Qed. + +Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2}, + (subset s1 s2 = true <-> Subset s1 s2). +Proof. + induction s1 as [|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros. + unfold Subset; intuition_in. + destruct s2 as [|l2 x2 r2 h2]; simpl; intros. + unfold Subset; intuition_in; try discriminate. + assert (H': InT x1 Leaf) by auto; inversion H'. + inv. + elim_compare x1 x2. + + rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto. + rewrite (@subsetl_spec (subset l1) l1 x1 h1) by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto. + rewrite (@subsetr_spec (subset r1) r1 x1 h1) by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. +Qed. + + +(** * Comparison *) + +(** ** Relations [eq] and [lt] over trees *) + +Module L := MakeListOrdering X. + +Definition eq := Equal. +Instance eq_equiv : Equivalence eq. +Proof. firstorder. Qed. + +Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s'). +Proof. + unfold eq, Equal, L.eq; intros. + setoid_rewrite elements_spec1; firstorder. +Qed. + +Definition lt (s1 s2 : t) : Prop := + exists s1', exists s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2' + /\ L.lt (elements s1') (elements s2'). + +Instance lt_strorder : StrictOrder lt. +Proof. + split. + intros s (s1 & s2 & B1 & B2 & E1 & E2 & L). + assert (eqlistA X.eq (elements s1) (elements s2)). + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. + rewrite <- eq_Leq. transitivity s; auto. symmetry; auto. + rewrite H in L. + apply (StrictOrder_Irreflexive (elements s2)); auto. + intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12) + (s2'' & s3' & B2' & B3 & E2' & E3 & L23). + exists s1', s3'; do 4 (split; trivial). + assert (eqlistA X.eq (elements s2') (elements s2'')). + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. + rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto. + transitivity (elements s2'); auto. + rewrite H; auto. +Qed. + +Instance lt_compat : Proper (eq==>eq==>iff) lt. +Proof. + intros s1 s2 E12 s3 s4 E34. split. + intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. transitivity s1; auto. symmetry; auto. + split; auto. transitivity s3; auto. symmetry; auto. + intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. transitivity s2; auto. + split; auto. transitivity s4; auto. +Qed. + + +(** * Proof of the comparison algorithm *) + +(** [flatten_e e] returns the list of elements of [e] i.e. the list + of elements actually compared *) + +Fixpoint flatten_e (e : enumeration) : list elt := match e with + | End => nil + | More x t r => x :: elements t ++ flatten_e r + end. + +Lemma flatten_e_elements : + forall l x r h e, + elements l ++ flatten_e (More x r e) = elements (Node l x r h) ++ flatten_e e. +Proof. + intros; simpl; apply elements_node. +Qed. + +Lemma cons_1 : forall s e, + flatten_e (cons s e) = elements s ++ flatten_e e. +Proof. + induction s; simpl; auto; intros. + rewrite IHs1; apply flatten_e_elements. +Qed. + +(** Correctness of this comparison *) + +Definition Cmp c x y := CompSpec L.eq L.lt x y c. + +Local Hint Unfold Cmp flip. + +Lemma compare_end_Cmp : + forall e2, Cmp (compare_end e2) nil (flatten_e e2). +Proof. + destruct e2; simpl; constructor; auto. reflexivity. +Qed. + +Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, + Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> + Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) + (flatten_e (More x2 r2 e2)). +Proof. + simpl; intros; elim_compare x1 x2; simpl; auto. +Qed. + +Lemma compare_cont_Cmp : forall s1 cont e2 l, + (forall e, Cmp (cont e) l (flatten_e e)) -> + Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2). +Proof. + induction s1 as [|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto. + rewrite <- elements_node; simpl. + apply Hl1; auto. clear e2. intros [|x2 r2 e2]. + simpl; auto. + apply compare_more_Cmp. + rewrite <- cons_1; auto. +Qed. + +Lemma compare_Cmp : forall s1 s2, + Cmp (compare s1 s2) (elements s1) (elements s2). +Proof. + intros; unfold compare. + rewrite (app_nil_end (elements s1)). + replace (elements s2) with (flatten_e (cons s2 End)) by + (rewrite cons_1; simpl; rewrite <- app_nil_end; auto). + apply compare_cont_Cmp; auto. + intros. + apply compare_end_Cmp; auto. +Qed. + +Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2}, + CompSpec eq lt s1 s2 (compare s1 s2). +Proof. + intros. + destruct (compare_Cmp s1 s2); constructor. + rewrite eq_Leq; auto. + intros; exists s1, s2; repeat split; auto. + intros; exists s2, s1; repeat split; auto. +Qed. + + +(** * Equality test *) + +Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2}, + equal s1 s2 = true <-> eq s1 s2. +Proof. +unfold equal; intros s1 s2 B1 B2. +destruct (@compare_spec s1 s2 B1 B2) as [H|H|H]; + split; intros H'; auto; try discriminate. +rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto. +rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto. +Qed. + +End MakeRaw. + + + +(** * Encapsulation + + Now, in order to really provide a functor implementing [S], we + need to encapsulate everything into a type of binary search trees. + They also happen to be well-balanced, but this has no influence + on the correctness of operations, so we won't state this here, + see [MSetFullAVL] if you need more than just the MSet interface. +*) + +Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. + Module Raw := MakeRaw I X. + Include Raw2Sets X Raw. +End IntMake. + +(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) + +Module Make (X: OrderedType) <: S with Module E := X + :=IntMake(Z_as_Int)(X). diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v new file mode 100644 index 00000000..07c9955a --- /dev/null +++ b/theories/MSets/MSetDecide.v @@ -0,0 +1,880 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ... -> Pk -> P +>> + where [P]'s are defined by the grammar: +<< + +P ::= +| Q +| Empty F +| Subset F F' +| Equal F F' + +Q ::= +| E.eq X X' +| In X F +| Q /\ Q' +| Q \/ Q' +| Q -> Q' +| Q <-> Q' +| ~ Q +| True +| False + +F ::= +| S +| empty +| singleton X +| add X F +| remove X F +| union F F' +| inter F F' +| diff F F' + +X ::= x1 | ... | xm +S ::= s1 | ... | sn + +>> + +The tactic will also work on some goals that vary slightly from +the above form: +- The variables and hypotheses may be mixed in any order and may + have already been introduced into the context. Moreover, + there may be additional, unrelated hypotheses mixed in (these + will be ignored). +- A conjunction of hypotheses will be handled as easily as + separate hypotheses, i.e., [P1 /\ P2 -> P] can be solved iff + [P1 -> P2 -> P] can be solved. +- [fsetdec] should solve any goal if the MSet-related hypotheses + are contradictory. +- [fsetdec] will first perform any necessary zeta and beta + reductions and will invoke [subst] to eliminate any Coq + equalities between finite sets or their elements. +- If [E.eq] is convertible with Coq's equality, it will not + matter which one is used in the hypotheses or conclusion. +- The tactic can solve goals where the finite sets or set + elements are expressed by Coq terms that are more complicated + than variables. However, non-local definitions are not + expanded, and Coq equalities between non-variable terms are + not used. For example, this goal will be solved: +<< + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g (g x2)) -> + In x1 s1 -> + In (g (g x2)) (f s2) +>> + This one will not be solved: +<< + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g x2) -> + In x1 s1 -> + g x2 = g (g x2) -> + In (g (g x2)) (f s2) +>> +*) + + (** * Facts and Tactics for Propositional Logic + These lemmas and tactics are in a module so that they do + not affect the namespace if you import the enclosing + module [Decide]. *) + Module MSetLogicalFacts. + Require Export Decidable. + Require Export Setoid. + + (** ** Lemmas and Tactics About Decidable Propositions *) + + (** ** Propositional Equivalences Involving Negation + These are all written with the unfolded form of + negation, since I am not sure if setoid rewriting will + always perform conversion. *) + + (** ** Tactics for Negations *) + + Tactic Notation "fold" "any" "not" := + repeat ( + match goal with + | H: context [?P -> False] |- _ => + fold (~ P) in H + | |- context [?P -> False] => + fold (~ P) + end). + + (** [push not using db] will pushes all negations to the + leaves of propositions in the goal, using the lemmas in + [db] to assist in checking the decidability of the + propositions involved. If [using db] is omitted, then + [core] will be used. Additional versions are provided + to manipulate the hypotheses or the hypotheses and goal + together. + + XXX: This tactic and the similar subsequent ones should + have been defined using [autorewrite]. However, dealing + with multiples rewrite sites and side-conditions is + done more cleverly with the following explicit + analysis of goals. *) + + Ltac or_not_l_iff P Q tac := + (rewrite (or_not_l_iff_1 P Q) by tac) || + (rewrite (or_not_l_iff_2 P Q) by tac). + + Ltac or_not_r_iff P Q tac := + (rewrite (or_not_r_iff_1 P Q) by tac) || + (rewrite (or_not_r_iff_2 P Q) by tac). + + Ltac or_not_l_iff_in P Q H tac := + (rewrite (or_not_l_iff_1 P Q) in H by tac) || + (rewrite (or_not_l_iff_2 P Q) in H by tac). + + Ltac or_not_r_iff_in P Q H tac := + (rewrite (or_not_r_iff_1 P Q) in H by tac) || + (rewrite (or_not_r_iff_2 P Q) in H by tac). + + Tactic Notation "push" "not" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff; + repeat ( + match goal with + | |- context [True -> False] => rewrite not_true_iff + | |- context [False -> False] => rewrite not_false_iff + | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec + | |- context [(?P -> False) -> (?Q -> False)] => + rewrite (contrapositive P Q) by dec + | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec + | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec + | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec + | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q) + | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q) + | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec + end); + fold any not. + + Tactic Notation "push" "not" := + push not using core. + + Tactic Notation + "push" "not" "in" "*" "|-" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff in * |-; + repeat ( + match goal with + | H: context [True -> False] |- _ => rewrite not_true_iff in H + | H: context [False -> False] |- _ => rewrite not_false_iff in H + | H: context [(?P -> False) -> False] |- _ => + rewrite (not_not_iff P) in H by dec + | H: context [(?P -> False) -> (?Q -> False)] |- _ => + rewrite (contrapositive P Q) in H by dec + | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec + | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec + | H: context [(?P -> False) -> ?Q] |- _ => + rewrite (imp_not_l P Q) in H by dec + | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H + | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H + | H: context [(?P -> ?Q) -> False] |- _ => + rewrite (not_imp_iff P Q) in H by dec + end); + fold any not. + + Tactic Notation "push" "not" "in" "*" "|-" := + push not in * |- using core. + + Tactic Notation "push" "not" "in" "*" "using" ident(db) := + push not using db; push not in * |- using db. + Tactic Notation "push" "not" "in" "*" := + push not in * using core. + + (** A simple test case to see how this works. *) + Lemma test_push : forall P Q R : Prop, + decidable P -> + decidable Q -> + (~ True) -> + (~ False) -> + (~ ~ P) -> + (~ (P /\ Q) -> ~ R) -> + ((P /\ Q) \/ ~ R) -> + (~ (P /\ Q) \/ R) -> + (R \/ ~ (P /\ Q)) -> + (~ R \/ (P /\ Q)) -> + (~ P -> R) -> + (~ ((R -> P) \/ (Q -> R))) -> + (~ (P /\ R)) -> + (~ (P -> R)) -> + True. + Proof. + intros. push not in *. + (* note that ~(R->P) remains (since R isnt decidable) *) + tauto. + Qed. + + (** [pull not using db] will pull as many negations as + possible toward the top of the propositions in the goal, + using the lemmas in [db] to assist in checking the + decidability of the propositions involved. If [using + db] is omitted, then [core] will be used. Additional + versions are provided to manipulate the hypotheses or + the hypotheses and goal together. *) + + Tactic Notation "pull" "not" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff; + repeat ( + match goal with + | |- context [True -> False] => rewrite not_true_iff + | |- context [False -> False] => rewrite not_false_iff + | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec + | |- context [(?P -> False) -> (?Q -> False)] => + rewrite (contrapositive P Q) by dec + | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec + | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec + | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec + | |- context [(?P -> False) /\ (?Q -> False)] => + rewrite <- (not_or_iff P Q) + | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) + | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec + | |- context [(?Q -> False) /\ ?P] => + rewrite <- (not_imp_rev_iff P Q) by dec + end); + fold any not. + + Tactic Notation "pull" "not" := + pull not using core. + + Tactic Notation + "pull" "not" "in" "*" "|-" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff in * |-; + repeat ( + match goal with + | H: context [True -> False] |- _ => rewrite not_true_iff in H + | H: context [False -> False] |- _ => rewrite not_false_iff in H + | H: context [(?P -> False) -> False] |- _ => + rewrite (not_not_iff P) in H by dec + | H: context [(?P -> False) -> (?Q -> False)] |- _ => + rewrite (contrapositive P Q) in H by dec + | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec + | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec + | H: context [(?P -> False) -> ?Q] |- _ => + rewrite (imp_not_l P Q) in H by dec + | H: context [(?P -> False) /\ (?Q -> False)] |- _ => + rewrite <- (not_or_iff P Q) in H + | H: context [?P -> ?Q -> False] |- _ => + rewrite <- (not_and_iff P Q) in H + | H: context [?P /\ (?Q -> False)] |- _ => + rewrite <- (not_imp_iff P Q) in H by dec + | H: context [(?Q -> False) /\ ?P] |- _ => + rewrite <- (not_imp_rev_iff P Q) in H by dec + end); + fold any not. + + Tactic Notation "pull" "not" "in" "*" "|-" := + pull not in * |- using core. + + Tactic Notation "pull" "not" "in" "*" "using" ident(db) := + pull not using db; pull not in * |- using db. + Tactic Notation "pull" "not" "in" "*" := + pull not in * using core. + + (** A simple test case to see how this works. *) + Lemma test_pull : forall P Q R : Prop, + decidable P -> + decidable Q -> + (~ True) -> + (~ False) -> + (~ ~ P) -> + (~ (P /\ Q) -> ~ R) -> + ((P /\ Q) \/ ~ R) -> + (~ (P /\ Q) \/ R) -> + (R \/ ~ (P /\ Q)) -> + (~ R \/ (P /\ Q)) -> + (~ P -> R) -> + (~ (R -> P) /\ ~ (Q -> R)) -> + (~ P \/ ~ R) -> + (P /\ ~ R) -> + (~ R /\ P) -> + True. + Proof. + intros. pull not in *. tauto. + Qed. + + End MSetLogicalFacts. + Import MSetLogicalFacts. + + (** * Auxiliary Tactics + Again, these lemmas and tactics are in a module so that + they do not affect the namespace if you import the + enclosing module [Decide]. *) + Module MSetDecideAuxiliary. + + (** ** Generic Tactics + We begin by defining a few generic, useful tactics. *) + + (** remove logical hypothesis inter-dependencies (fix #2136). *) + + Ltac no_logical_interdep := + match goal with + | H : ?P |- _ => + match type of P with + | Prop => + match goal with H' : context [ H ] |- _ => clear dependent H' end + | _ => fail + end; no_logical_interdep + | _ => idtac + end. + + (** [if t then t1 else t2] executes [t] and, if it does not + fail, then [t1] will be applied to all subgoals + produced. If [t] fails, then [t2] is executed. *) + Tactic Notation + "if" tactic(t) + "then" tactic(t1) + "else" tactic(t2) := + first [ t; first [ t1 | fail 2 ] | t2 ]. + + (** [prop P holds by t] succeeds (but does not modify the + goal or context) if the proposition [P] can be proved by + [t] in the current context. Otherwise, the tactic + fails. *) + Tactic Notation "prop" constr(P) "holds" "by" tactic(t) := + let H := fresh in + assert P as H by t; + clear H. + + (** This tactic acts just like [assert ... by ...] but will + fail if the context already contains the proposition. *) + Tactic Notation "assert" "new" constr(e) "by" tactic(t) := + match goal with + | H: e |- _ => fail 1 + | _ => assert e by t + end. + + (** [subst++] is similar to [subst] except that + - it never fails (as [subst] does on recursive + equations), + - it substitutes locally defined variable for their + definitions, + - it performs beta reductions everywhere, which may + arise after substituting a locally defined function + for its definition. + *) + Tactic Notation "subst" "++" := + repeat ( + match goal with + | x : _ |- _ => subst x + end); + cbv zeta beta in *. + + (** [decompose records] calls [decompose record H] on every + relevant hypothesis [H]. *) + Tactic Notation "decompose" "records" := + repeat ( + match goal with + | H: _ |- _ => progress (decompose record H); clear H + end). + + (** ** Discarding Irrelevant Hypotheses + We will want to clear the context of any + non-MSet-related hypotheses in order to increase the + speed of the tactic. To do this, we will need to be + able to decide which are relevant. We do this by making + a simple inductive definition classifying the + propositions of interest. *) + + Inductive MSet_elt_Prop : Prop -> Prop := + | eq_Prop : forall (S : Type) (x y : S), + MSet_elt_Prop (x = y) + | eq_elt_prop : forall x y, + MSet_elt_Prop (E.eq x y) + | In_elt_prop : forall x s, + MSet_elt_Prop (In x s) + | True_elt_prop : + MSet_elt_Prop True + | False_elt_prop : + MSet_elt_Prop False + | conj_elt_prop : forall P Q, + MSet_elt_Prop P -> + MSet_elt_Prop Q -> + MSet_elt_Prop (P /\ Q) + | disj_elt_prop : forall P Q, + MSet_elt_Prop P -> + MSet_elt_Prop Q -> + MSet_elt_Prop (P \/ Q) + | impl_elt_prop : forall P Q, + MSet_elt_Prop P -> + MSet_elt_Prop Q -> + MSet_elt_Prop (P -> Q) + | not_elt_prop : forall P, + MSet_elt_Prop P -> + MSet_elt_Prop (~ P). + + Inductive MSet_Prop : Prop -> Prop := + | elt_MSet_Prop : forall P, + MSet_elt_Prop P -> + MSet_Prop P + | Empty_MSet_Prop : forall s, + MSet_Prop (Empty s) + | Subset_MSet_Prop : forall s1 s2, + MSet_Prop (Subset s1 s2) + | Equal_MSet_Prop : forall s1 s2, + MSet_Prop (Equal s1 s2). + + (** Here is the tactic that will throw away hypotheses that + are not useful (for the intended scope of the [fsetdec] + tactic). *) + Hint Constructors MSet_elt_Prop MSet_Prop : MSet_Prop. + Ltac discard_nonMSet := + decompose records; + repeat ( + match goal with + | H : ?P |- _ => + if prop (MSet_Prop P) holds by + (auto 100 with MSet_Prop) + then fail + else clear H + end). + + (** ** Turning Set Operators into Propositional Connectives + The lemmas from [MSetFacts] will be used to break down + set operations into propositional formulas built over + the predicates [In] and [E.eq] applied only to + variables. We are going to use them with [autorewrite]. + *) + + Hint Rewrite + F.empty_iff F.singleton_iff F.add_iff F.remove_iff + F.union_iff F.inter_iff F.diff_iff + : set_simpl. + + (** ** Decidability of MSet Propositions *) + + (** [In] is decidable. *) + Lemma dec_In : forall x s, + decidable (In x s). + Proof. + red; intros; generalize (F.mem_iff s x); case (mem x s); intuition. + Qed. + + (** [E.eq] is decidable. *) + Lemma dec_eq : forall (x y : E.t), + decidable (E.eq x y). + Proof. + red; intros x y; destruct (E.eq_dec x y); auto. + Qed. + + (** The hint database [MSet_decidability] will be given to + the [push_neg] tactic from the module [Negation]. *) + Hint Resolve dec_In dec_eq : MSet_decidability. + + (** ** Normalizing Propositions About Equality + We have to deal with the fact that [E.eq] may be + convertible with Coq's equality. Thus, we will find the + following tactics useful to replace one form with the + other everywhere. *) + + (** The next tactic, [Logic_eq_to_E_eq], mentions the term + [E.t]; thus, we must ensure that [E.t] is used in favor + of any other convertible but syntactically distinct + term. *) + Ltac change_to_E_t := + repeat ( + match goal with + | H : ?T |- _ => + progress (change T with E.t in H); + repeat ( + match goal with + | J : _ |- _ => progress (change T with E.t in J) + | |- _ => progress (change T with E.t) + end ) + | H : forall x : ?T, _ |- _ => + progress (change T with E.t in H); + repeat ( + match goal with + | J : _ |- _ => progress (change T with E.t in J) + | |- _ => progress (change T with E.t) + end ) + end). + + (** These two tactics take us from Coq's built-in equality + to [E.eq] (and vice versa) when possible. *) + + Ltac Logic_eq_to_E_eq := + repeat ( + match goal with + | H: _ |- _ => + progress (change (@Logic.eq E.t) with E.eq in H) + | |- _ => + progress (change (@Logic.eq E.t) with E.eq) + end). + + Ltac E_eq_to_Logic_eq := + repeat ( + match goal with + | H: _ |- _ => + progress (change E.eq with (@Logic.eq E.t) in H) + | |- _ => + progress (change E.eq with (@Logic.eq E.t)) + end). + + (** This tactic works like the built-in tactic [subst], but + at the level of set element equality (which may not be + the convertible with Coq's equality). *) + Ltac substMSet := + repeat ( + match goal with + | H: E.eq ?x ?y |- _ => rewrite H in *; clear H + end). + + (** ** Considering Decidability of Base Propositions + This tactic adds assertions about the decidability of + [E.eq] and [In] to the context. This is necessary for + the completeness of the [fsetdec] tactic. However, in + order to minimize the cost of proof search, we should be + careful to not add more than we need. Once negations + have been pushed to the leaves of the propositions, we + only need to worry about decidability for those base + propositions that appear in a negated form. *) + Ltac assert_decidability := + (** We actually don't want these rules to fire if the + syntactic context in the patterns below is trivially + empty, but we'll just do some clean-up at the + afterward. *) + repeat ( + match goal with + | H: context [~ E.eq ?x ?y] |- _ => + assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) + | H: context [~ In ?x ?s] |- _ => + assert new (In x s \/ ~ In x s) by (apply dec_In) + | |- context [~ E.eq ?x ?y] => + assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) + | |- context [~ In ?x ?s] => + assert new (In x s \/ ~ In x s) by (apply dec_In) + end); + (** Now we eliminate the useless facts we added (because + they would likely be very harmful to performance). *) + repeat ( + match goal with + | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H + end). + + (** ** Handling [Empty], [Subset], and [Equal] + This tactic instantiates universally quantified + hypotheses (which arise from the unfolding of [Empty], + [Subset], and [Equal]) for each of the set element + expressions that is involved in some membership or + equality fact. Then it throws away those hypotheses, + which should no longer be needed. *) + Ltac inst_MSet_hypotheses := + repeat ( + match goal with + | H : forall a : E.t, _, + _ : context [ In ?x _ ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ In ?x _ ] => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _, + _ : context [ E.eq ?x _ ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ E.eq ?x _ ] => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _, + _ : context [ E.eq _ ?x ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ E.eq _ ?x ] => + let P := type of (H x) in + assert new P by (exact (H x)) + end); + repeat ( + match goal with + | H : forall a : E.t, _ |- _ => + clear H + end). + + (** ** The Core [fsetdec] Auxiliary Tactics *) + + (** Here is the crux of the proof search. Recursion through + [intuition]! (This will terminate if I correctly + understand the behavior of [intuition].) *) + Ltac fsetdec_rec := + try (match goal with + | H: E.eq ?x ?x -> False |- _ => destruct H + end); + (reflexivity || + contradiction || + (progress substMSet; intuition fsetdec_rec)). + + (** If we add [unfold Empty, Subset, Equal in *; intros;] to + the beginning of this tactic, it will satisfy the same + specification as the [fsetdec] tactic; however, it will + be much slower than necessary without the pre-processing + done by the wrapper tactic [fsetdec]. *) + Ltac fsetdec_body := + inst_MSet_hypotheses; + autorewrite with set_simpl in *; + push not in * using MSet_decidability; + substMSet; + assert_decidability; + auto using (@Equivalence_Reflexive _ _ E.eq_equiv); + (intuition fsetdec_rec) || + fail 1 + "because the goal is beyond the scope of this tactic". + + End MSetDecideAuxiliary. + Import MSetDecideAuxiliary. + + (** * The [fsetdec] Tactic + Here is the top-level tactic (the only one intended for + clients of this library). It's specification is given at + the top of the file. *) + Ltac fsetdec := + (** We first unfold any occurrences of [iff]. *) + unfold iff in *; + (** We fold occurrences of [not] because it is better for + [intros] to leave us with a goal of [~ P] than a goal of + [False]. *) + fold any not; intros; + (** We remove dependencies to logical hypothesis. This way, + later "clear" will work nicely (see bug #2136) *) + no_logical_interdep; + (** Now we decompose conjunctions, which will allow the + [discard_nonMSet] and [assert_decidability] tactics to + do a much better job. *) + decompose records; + discard_nonMSet; + (** We unfold these defined propositions on finite sets. If + our goal was one of them, then have one more item to + introduce now. *) + unfold Empty, Subset, Equal in *; intros; + (** We now want to get rid of all uses of [=] in favor of + [E.eq]. However, the best way to eliminate a [=] is in + the context is with [subst], so we will try that first. + In fact, we may as well convert uses of [E.eq] into [=] + when possible before we do [subst] so that we can even + more mileage out of it. Then we will convert all + remaining uses of [=] back to [E.eq] when possible. We + use [change_to_E_t] to ensure that we have a canonical + name for set elements, so that [Logic_eq_to_E_eq] will + work properly. *) + change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq; + (** The next optimization is to swap a negated goal with a + negated hypothesis when possible. Any swap will improve + performance by eliminating the total number of + negations, but we will get the maximum benefit if we + swap the goal with a hypotheses mentioning the same set + element, so we try that first. If we reach the fourth + branch below, we attempt any swap. However, to maintain + completeness of this tactic, we can only perform such a + swap with a decidable proposition; hence, we first test + whether the hypothesis is an [MSet_elt_Prop], noting + that any [MSet_elt_Prop] is decidable. *) + pull not using MSet_decidability; + unfold not in *; + match goal with + | H: (In ?x ?r) -> False |- (In ?x ?s) -> False => + contradict H; fsetdec_body + | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False => + contradict H; fsetdec_body + | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => + contradict H; fsetdec_body + | H: ?P -> False |- ?Q -> False => + if prop (MSet_elt_Prop P) holds by + (auto 100 with MSet_Prop) + then (contradict H; fsetdec_body) + else fsetdec_body + | |- _ => + fsetdec_body + end. + + (** * Examples *) + + Module MSetDecideTestCases. + + Lemma test_eq_trans_1 : forall x y z s, + E.eq x y -> + ~ ~ E.eq z y -> + In x s -> + In z s. + Proof. fsetdec. Qed. + + Lemma test_eq_trans_2 : forall x y z r s, + In x (singleton y) -> + ~ In z r -> + ~ ~ In z (add y r) -> + In x s -> + In z s. + Proof. fsetdec. Qed. + + Lemma test_eq_neq_trans_1 : forall w x y z s, + E.eq x w -> + ~ ~ E.eq x y -> + ~ E.eq y z -> + In w s -> + In w (remove z s). + Proof. fsetdec. Qed. + + Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s, + In x (singleton w) -> + ~ In x r1 -> + In x (add y r1) -> + In y r2 -> + In y (remove z r2) -> + In w s -> + In w (remove z s). + Proof. fsetdec. Qed. + + Lemma test_In_singleton : forall x, + In x (singleton x). + Proof. fsetdec. Qed. + + Lemma test_add_In : forall x y s, + In x (add y s) -> + ~ E.eq x y -> + In x s. + Proof. fsetdec. Qed. + + Lemma test_Subset_add_remove : forall x s, + s [<=] (add x (remove x s)). + Proof. fsetdec. Qed. + + Lemma test_eq_disjunction : forall w x y z, + In w (add x (add y (singleton z))) -> + E.eq w x \/ E.eq w y \/ E.eq w z. + Proof. fsetdec. Qed. + + Lemma test_not_In_disj : forall x y s1 s2 s3 s4, + ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> + ~ (In x s1 \/ In x s4 \/ E.eq y x). + Proof. fsetdec. Qed. + + Lemma test_not_In_conj : forall x y s1 s2 s3 s4, + ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> + ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x. + Proof. fsetdec. Qed. + + Lemma test_iff_conj : forall a x s s', + (In a s' <-> E.eq x a \/ In a s) -> + (In a s' <-> In a (add x s)). + Proof. fsetdec. Qed. + + Lemma test_set_ops_1 : forall x q r s, + (singleton x) [<=] s -> + Empty (union q r) -> + Empty (inter (diff s q) (diff s r)) -> + ~ In x s. + Proof. fsetdec. Qed. + + Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4, + Empty s1 -> + In x2 (add x1 s1) -> + In x3 s2 -> + ~ In x3 (remove x2 s2) -> + ~ In x4 s3 -> + In x4 (add x3 s3) -> + In x1 s4 -> + Subset (add x4 s4) s4. + Proof. fsetdec. Qed. + + Lemma test_too_complex : forall x y z r s, + E.eq x y -> + (In x (singleton y) -> r [<=] s) -> + In z r -> + In z s. + Proof. + (** [fsetdec] is not intended to solve this directly. *) + intros until s; intros Heq H Hr; lapply H; fsetdec. + Qed. + + Lemma function_test_1 : + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g (g x2)) -> + In x1 s1 -> + In (g (g x2)) (f s2). + Proof. fsetdec. Qed. + + Lemma function_test_2 : + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g x2) -> + In x1 s1 -> + g x2 = g (g x2) -> + In (g (g x2)) (f s2). + Proof. + (** [fsetdec] is not intended to solve this directly. *) + intros until 3. intros g_eq. rewrite <- g_eq. fsetdec. + Qed. + + Lemma test_baydemir : + forall (f : t -> t), + forall (s : t), + forall (x y : elt), + In x (add y (f s)) -> + ~ E.eq x y -> + In x (f s). + Proof. + fsetdec. + Qed. + + End MSetDecideTestCases. + +End WDecideOn. + +Require Import MSetInterface. + +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [Decide] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WDecide]. *) + +Module WDecide (M:WSets) := WDecideOn M.E M. +Module Decide := WDecide. diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v new file mode 100644 index 00000000..fe6c3c79 --- /dev/null +++ b/theories/MSets/MSetEqProperties.v @@ -0,0 +1,936 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mem x s=mem y s. +Proof. +intro H; rewrite H; auto. +Qed. + +Lemma equal_mem_1: + (forall a, mem a s=mem a s') -> equal s s'=true. +Proof. +intros; apply equal_1; unfold Equal; intros. +do 2 rewrite mem_iff; rewrite H; tauto. +Qed. + +Lemma equal_mem_2: + equal s s'=true -> forall a, mem a s=mem a s'. +Proof. +intros; rewrite (equal_2 H); auto. +Qed. + +Lemma subset_mem_1: + (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. +Proof. +intros; apply subset_1; unfold Subset; intros a. +do 2 rewrite mem_iff; auto. +Qed. + +Lemma subset_mem_2: + subset s s'=true -> forall a, mem a s=true -> mem a s'=true. +Proof. +intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. +Qed. + +Lemma empty_mem: mem x empty=false. +Proof. +rewrite <- not_mem_iff; auto with set. +Qed. + +Lemma is_empty_equal_empty: is_empty s = equal s empty. +Proof. +apply bool_1; split; intros. +auto with set. +rewrite <- is_empty_iff; auto with set. +Qed. + +Lemma choose_mem_1: choose s=Some x -> mem x s=true. +Proof. +auto with set. +Qed. + +Lemma choose_mem_2: choose s=None -> is_empty s=true. +Proof. +auto with set. +Qed. + +Lemma add_mem_1: mem x (add x s)=true. +Proof. +auto with set relations. +Qed. + +Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. +Proof. +apply add_neq_b. +Qed. + +Lemma remove_mem_1: mem x (remove x s)=false. +Proof. +rewrite <- not_mem_iff; auto with set relations. +Qed. + +Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. +Proof. +apply remove_neq_b. +Qed. + +Lemma singleton_equal_add: + equal (singleton x) (add x empty)=true. +Proof. +rewrite (singleton_equal_add x); auto with set. +Qed. + +Lemma union_mem: + mem x (union s s')=mem x s || mem x s'. +Proof. +apply union_b. +Qed. + +Lemma inter_mem: + mem x (inter s s')=mem x s && mem x s'. +Proof. +apply inter_b. +Qed. + +Lemma diff_mem: + mem x (diff s s')=mem x s && negb (mem x s'). +Proof. +apply diff_b. +Qed. + +(** properties of [mem] *) + +Lemma mem_3 : ~In x s -> mem x s=false. +Proof. +intros; rewrite <- not_mem_iff; auto. +Qed. + +Lemma mem_4 : mem x s=false -> ~In x s. +Proof. +intros; rewrite not_mem_iff; auto. +Qed. + +(** Properties of [equal] *) + +Lemma equal_refl: equal s s=true. +Proof. +auto with set. +Qed. + +Lemma equal_sym: equal s s'=equal s' s. +Proof. +intros; apply bool_1; do 2 rewrite <- equal_iff; intuition. +Qed. + +Lemma equal_trans: + equal s s'=true -> equal s' s''=true -> equal s s''=true. +Proof. +intros; rewrite (equal_2 H); auto. +Qed. + +Lemma equal_equal: + equal s s'=true -> equal s s''=equal s' s''. +Proof. +intros; rewrite (equal_2 H); auto. +Qed. + +Lemma equal_cardinal: + equal s s'=true -> cardinal s=cardinal s'. +Proof. +auto with set. +Qed. + +(* Properties of [subset] *) + +Lemma subset_refl: subset s s=true. +Proof. +auto with set. +Qed. + +Lemma subset_antisym: + subset s s'=true -> subset s' s=true -> equal s s'=true. +Proof. +auto with set. +Qed. + +Lemma subset_trans: + subset s s'=true -> subset s' s''=true -> subset s s''=true. +Proof. +do 3 rewrite <- subset_iff; intros. +apply subset_trans with s'; auto. +Qed. + +Lemma subset_equal: + equal s s'=true -> subset s s'=true. +Proof. +auto with set. +Qed. + +(** Properties of [choose] *) + +Lemma choose_mem_3: + is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. +Proof. +intros. +generalize (@choose_1 s) (@choose_2 s). +destruct (choose s);intros. +exists e;auto with set. +generalize (H1 (refl_equal None)); clear H1. +intros; rewrite (is_empty_1 H1) in H; discriminate. +Qed. + +Lemma choose_mem_4: choose empty=None. +Proof. +generalize (@choose_1 empty). +case (@choose empty);intros;auto. +elim (@empty_1 e); auto. +Qed. + +(** Properties of [add] *) + +Lemma add_mem_3: + mem y s=true -> mem y (add x s)=true. +Proof. +auto with set. +Qed. + +Lemma add_equal: + mem x s=true -> equal (add x s) s=true. +Proof. +auto with set. +Qed. + +(** Properties of [remove] *) + +Lemma remove_mem_3: + mem y (remove x s)=true -> mem y s=true. +Proof. +rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. +Qed. + +Lemma remove_equal: + mem x s=false -> equal (remove x s) s=true. +Proof. +intros; apply equal_1; apply remove_equal. +rewrite not_mem_iff; auto. +Qed. + +Lemma add_remove: + mem x s=true -> equal (add x (remove x s)) s=true. +Proof. +intros; apply equal_1; apply add_remove; auto with set. +Qed. + +Lemma remove_add: + mem x s=false -> equal (remove x (add x s)) s=true. +Proof. +intros; apply equal_1; apply remove_add; auto. +rewrite not_mem_iff; auto. +Qed. + +(** Properties of [is_empty] *) + +Lemma is_empty_cardinal: is_empty s = zerob (cardinal s). +Proof. +intros; apply bool_1; split; intros. +rewrite MP.cardinal_1; simpl; auto with set. +assert (cardinal s = 0) by (apply zerob_true_elim; auto). +auto with set. +Qed. + +(** Properties of [singleton] *) + +Lemma singleton_mem_1: mem x (singleton x)=true. +Proof. +auto with set relations. +Qed. + +Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. +Proof. +intros; rewrite singleton_b. +unfold eqb; destruct (E.eq_dec x y); intuition. +Qed. + +Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. +Proof. +intros; apply singleton_1; auto with set. +Qed. + +(** Properties of [union] *) + +Lemma union_sym: + equal (union s s') (union s' s)=true. +Proof. +auto with set. +Qed. + +Lemma union_subset_equal: + subset s s'=true -> equal (union s s') s'=true. +Proof. +auto with set. +Qed. + +Lemma union_equal_1: + equal s s'=true-> equal (union s s'') (union s' s'')=true. +Proof. +auto with set. +Qed. + +Lemma union_equal_2: + equal s' s''=true-> equal (union s s') (union s s'')=true. +Proof. +auto with set. +Qed. + +Lemma union_assoc: + equal (union (union s s') s'') (union s (union s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma add_union_singleton: + equal (add x s) (union (singleton x) s)=true. +Proof. +auto with set. +Qed. + +Lemma union_add: + equal (union (add x s) s') (add x (union s s'))=true. +Proof. +auto with set. +Qed. + +(* caracterisation of [union] via [subset] *) + +Lemma union_subset_1: subset s (union s s')=true. +Proof. +auto with set. +Qed. + +Lemma union_subset_2: subset s' (union s s')=true. +Proof. +auto with set. +Qed. + +Lemma union_subset_3: + subset s s''=true -> subset s' s''=true -> + subset (union s s') s''=true. +Proof. +intros; apply subset_1; apply union_subset_3; auto with set. +Qed. + +(** Properties of [inter] *) + +Lemma inter_sym: equal (inter s s') (inter s' s)=true. +Proof. +auto with set. +Qed. + +Lemma inter_subset_equal: + subset s s'=true -> equal (inter s s') s=true. +Proof. +auto with set. +Qed. + +Lemma inter_equal_1: + equal s s'=true -> equal (inter s s'') (inter s' s'')=true. +Proof. +auto with set. +Qed. + +Lemma inter_equal_2: + equal s' s''=true -> equal (inter s s') (inter s s'')=true. +Proof. +auto with set. +Qed. + +Lemma inter_assoc: + equal (inter (inter s s') s'') (inter s (inter s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma union_inter_1: + equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma union_inter_2: + equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma inter_add_1: mem x s'=true -> + equal (inter (add x s) s') (add x (inter s s'))=true. +Proof. +auto with set. +Qed. + +Lemma inter_add_2: mem x s'=false -> + equal (inter (add x s) s') (inter s s')=true. +Proof. +intros; apply equal_1; apply inter_add_2. +rewrite not_mem_iff; auto. +Qed. + +(* caracterisation of [union] via [subset] *) + +Lemma inter_subset_1: subset (inter s s') s=true. +Proof. +auto with set. +Qed. + +Lemma inter_subset_2: subset (inter s s') s'=true. +Proof. +auto with set. +Qed. + +Lemma inter_subset_3: + subset s'' s=true -> subset s'' s'=true -> + subset s'' (inter s s')=true. +Proof. +intros; apply subset_1; apply inter_subset_3; auto with set. +Qed. + +(** Properties of [diff] *) + +Lemma diff_subset: subset (diff s s') s=true. +Proof. +auto with set. +Qed. + +Lemma diff_subset_equal: + subset s s'=true -> equal (diff s s') empty=true. +Proof. +auto with set. +Qed. + +Lemma remove_inter_singleton: + equal (remove x s) (diff s (singleton x))=true. +Proof. +auto with set. +Qed. + +Lemma diff_inter_empty: + equal (inter (diff s s') (inter s s')) empty=true. +Proof. +auto with set. +Qed. + +Lemma diff_inter_all: + equal (union (diff s s') (inter s s')) s=true. +Proof. +auto with set. +Qed. + +End BasicProperties. + +Hint Immediate empty_mem is_empty_equal_empty add_mem_1 + remove_mem_1 singleton_equal_add union_mem inter_mem + diff_mem equal_sym add_remove remove_add : set. +Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 + choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal + subset_refl subset_equal subset_antisym + add_mem_3 add_equal remove_mem_3 remove_equal : set. + + +(** General recursion principle *) + +Lemma set_rec: forall (P:t->Type), + (forall s s', equal s s'=true -> P s -> P s') -> + (forall s x, mem x s=false -> P s -> P (add x s)) -> + P empty -> forall s, P s. +Proof. +intros. +apply set_induction; auto; intros. +apply X with empty; auto with set. +apply X with (add x s0); auto with set. +apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto. +apply X0; auto with set; apply mem_3; auto. +Qed. + +(** Properties of [fold] *) + +Lemma exclusive_set : forall s s' x, + ~(In x s/\In x s') <-> mem x s && mem x s'=false. +Proof. +intros; do 2 rewrite mem_iff. +destruct (mem x s); destruct (mem x s'); intuition. +Qed. + +Section Fold. +Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). +Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f). +Variables (i:A). +Variables (s s':t)(x:elt). + +Lemma fold_empty: (fold f empty i) = i. +Proof. +apply fold_empty; auto. +Qed. + +Lemma fold_equal: + equal s s'=true -> eqA (fold f s i) (fold f s' i). +Proof. +intros; apply fold_equal with (eqA:=eqA); auto with set. +Qed. + +Lemma fold_add: + mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). +Proof. +intros; apply fold_add with (eqA:=eqA); auto. +rewrite not_mem_iff; auto. +Qed. + +Lemma add_fold: + mem x s=true -> eqA (fold f (add x s) i) (fold f s i). +Proof. +intros; apply add_fold with (eqA:=eqA); auto with set. +Qed. + +Lemma remove_fold_1: + mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). +Proof. +intros; apply remove_fold_1 with (eqA:=eqA); auto with set. +Qed. + +Lemma remove_fold_2: + mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). +Proof. +intros; apply remove_fold_2 with (eqA:=eqA); auto. +rewrite not_mem_iff; auto. +Qed. + +Lemma fold_union: + (forall x, mem x s && mem x s'=false) -> + eqA (fold f (union s s') i) (fold f s (fold f s' i)). +Proof. +intros; apply fold_union with (eqA:=eqA); auto. +intros; rewrite exclusive_set; auto. +Qed. + +End Fold. + +(** Properties of [cardinal] *) + +Lemma add_cardinal_1: + forall s x, mem x s=true -> cardinal (add x s)=cardinal s. +Proof. +auto with set. +Qed. + +Lemma add_cardinal_2: + forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). +Proof. +intros; apply add_cardinal_2; auto. +rewrite not_mem_iff; auto. +Qed. + +Lemma remove_cardinal_1: + forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. +Proof. +intros; apply remove_cardinal_1; auto with set. +Qed. + +Lemma remove_cardinal_2: + forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. +Proof. +intros; apply Equal_cardinal; apply equal_2; auto with set. +Qed. + +Lemma union_cardinal: + forall s s', (forall x, mem x s && mem x s'=false) -> + cardinal (union s s')=cardinal s+cardinal s'. +Proof. +intros; apply union_cardinal; auto; intros. +rewrite exclusive_set; auto. +Qed. + +Lemma subset_cardinal: + forall s s', subset s s'=true -> cardinal s<=cardinal s'. +Proof. +intros; apply subset_cardinal; auto with set. +Qed. + +Section Bool. + +(** Properties of [filter] *) + +Variable f:elt->bool. +Variable Comp: Proper (E.eq==>Logic.eq) f. + +Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)). +Proof. +repeat red; intros; f_equal; auto. +Qed. + +Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. +Proof. +intros; apply filter_b; auto. +Qed. + +Lemma for_all_filter: + forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). +Proof. +intros; apply bool_1; split; intros. +apply is_empty_1. +unfold Empty; intros. +rewrite filter_iff; auto. +red; destruct 1. +rewrite <- (@for_all_iff s f) in H; auto. +rewrite (H a H0) in H1; discriminate. +apply for_all_1; auto; red; intros. +revert H; rewrite <- is_empty_iff. +unfold Empty; intro H; generalize (H x); clear H. +rewrite filter_iff; auto. +destruct (f x); auto. +Qed. + +Lemma exists_filter : + forall s, exists_ f s=negb (is_empty (filter f s)). +Proof. +intros; apply bool_1; split; intros. +destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). +apply bool_6. +red; intros; apply (@is_empty_2 _ H0 a); auto with set. +generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)). +destruct (choose (filter f s)). +intros H0 _; apply exists_1; auto. +exists e; generalize (H0 e); rewrite filter_iff; auto. +intros _ H0. +rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate. +Qed. + +Lemma partition_filter_1: + forall s, equal (fst (partition f s)) (filter f s)=true. +Proof. +auto with set. +Qed. + +Lemma partition_filter_2: + forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. +Proof. +auto with set. +Qed. + +Lemma filter_add_1 : forall s x, f x = true -> + filter f (add x s) [=] add x (filter f s). +Proof. +red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. +intuition. +rewrite <- H; apply Comp; auto with relations. +Qed. + +Lemma filter_add_2 : forall s x, f x = false -> + filter f (add x s) [=] filter f s. +Proof. +red; intros; do 2 (rewrite filter_iff; auto); set_iff. +intuition. +assert (f x = f a) by (apply Comp; auto). +rewrite H in H1; rewrite H2 in H1; discriminate. +Qed. + +Lemma add_filter_1 : forall s s' x, + f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). +Proof. +unfold Add, MP.Add; intros. +repeat rewrite filter_iff; auto. +rewrite H0; clear H0. +intuition. +setoid_replace y with x; auto with relations. +Qed. + +Lemma add_filter_2 : forall s s' x, + f x=false -> (Add x s s') -> filter f s [=] filter f s'. +Proof. +unfold Add, MP.Add, Equal; intros. +repeat rewrite filter_iff; auto. +rewrite H0; clear H0. +intuition. +setoid_replace x with a in H; auto. congruence. +Qed. + +Lemma union_filter: forall f g, + Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> + forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s. +Proof. +clear Comp' Comp f. +intros. +assert (Proper (E.eq==>Logic.eq) (fun x => orb (f x) (g x))). + repeat red; intros. + rewrite (H x y H1); rewrite (H0 x y H1); auto. +unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. +assert (f a || g a = true <-> f a = true \/ g a = true). + split; auto with bool. + intro H3; destruct (orb_prop _ _ H3); auto. +tauto. +Qed. + +Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s'). +Proof. +unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto. +Qed. + +(** Properties of [for_all] *) + +Lemma for_all_mem_1: forall s, + (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. +Proof. +intros. +rewrite for_all_filter; auto. +rewrite is_empty_equal_empty. +apply equal_mem_1;intros. +rewrite filter_b; auto. +rewrite empty_mem. +generalize (H a); case (mem a s);intros;auto. +rewrite H0;auto. +Qed. + +Lemma for_all_mem_2: forall s, + (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. +Proof. +intros. +rewrite for_all_filter in H; auto. +rewrite is_empty_equal_empty in H. +generalize (equal_mem_2 _ _ H x). +rewrite filter_b; auto. +rewrite empty_mem. +rewrite H0; simpl;intros. +rewrite <- negb_false_iff; auto. +Qed. + +Lemma for_all_mem_3: + forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. +Proof. +intros. +apply (bool_eq_ind (for_all f s));intros;auto. +rewrite for_all_filter in H1; auto. +rewrite is_empty_equal_empty in H1. +generalize (equal_mem_2 _ _ H1 x). +rewrite filter_b; auto. +rewrite empty_mem. +rewrite H. +rewrite H0. +simpl;auto. +Qed. + +Lemma for_all_mem_4: + forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. +Proof. +intros. +rewrite for_all_filter in H; auto. +destruct (choose_mem_3 _ H) as (x,(H0,H1));intros. +exists x. +rewrite filter_b in H1; auto. +elim (andb_prop _ _ H1). +split;auto. +rewrite <- negb_true_iff; auto. +Qed. + +(** Properties of [exists] *) + +Lemma for_all_exists: + forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). +Proof. +intros. +rewrite for_all_b; auto. +rewrite exists_b; auto. +induction (elements s); simpl; auto. +destruct (f a); simpl; auto. +Qed. + +End Bool. +Section Bool'. + +Variable f:elt->bool. +Variable Comp: Proper (E.eq==>Logic.eq) f. + +Let Comp' : Proper (E.eq==>Logic.eq) (fun x => negb (f x)). +Proof. +repeat red; intros; f_equal; auto. +Qed. + +Lemma exists_mem_1: + forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. +Proof. +intros. +rewrite for_all_exists; auto. +rewrite for_all_mem_1;auto with bool. +intros;generalize (H x H0);intros. +rewrite negb_true_iff; auto. +Qed. + +Lemma exists_mem_2: + forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. +Proof. +intros. +rewrite for_all_exists in H; auto. +rewrite negb_false_iff in H. +rewrite <- negb_true_iff. +apply for_all_mem_2 with (2:=H); auto. +Qed. + +Lemma exists_mem_3: + forall s x, mem x s=true -> f x=true -> exists_ f s=true. +Proof. +intros. +rewrite for_all_exists; auto. +rewrite negb_true_iff. +apply for_all_mem_3 with x;auto. +rewrite negb_false_iff; auto. +Qed. + +Lemma exists_mem_4: + forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. +Proof. +intros. +rewrite for_all_exists in H; auto. +rewrite negb_true_iff in H. +elim (@for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros;auto. +elim p;intros. +exists x;split;auto. +rewrite <-negb_false_iff; auto. +Qed. + +End Bool'. + +Section Sum. + +(** Adding a valuation function on all elements of a set. *) + +Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. +Notation compat_opL := (Proper (E.eq==>Logic.eq==>Logic.eq)). +Notation transposeL := (transpose Logic.eq). + +Lemma sum_plus : + forall f g, + Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> + forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. +Proof. +unfold sum. +intros f g Hf Hg. +assert (fc : compat_opL (fun x:elt =>plus (f x))) by + (repeat red; intros; rewrite Hf; auto). +assert (ft : transposeL (fun x:elt =>plus (f x))) by (red; intros; omega). +assert (gc : compat_opL (fun x:elt => plus (g x))) by + (repeat red; intros; rewrite Hg; auto). +assert (gt : transposeL (fun x:elt =>plus (g x))) by (red; intros; omega). +assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))) by + (repeat red; intros; rewrite Hf,Hg; auto). +assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))) by (red; intros; omega). +intros s;pattern s; apply set_rec. +intros. +rewrite <- (fold_equal _ _ _ _ fc ft 0 _ _ H). +rewrite <- (fold_equal _ _ _ _ gc gt 0 _ _ H). +rewrite <- (fold_equal _ _ _ _ fgc fgt 0 _ _ H); auto. +intros; do 3 (rewrite fold_add; auto with *). +do 3 rewrite fold_empty;auto. +Qed. + +Lemma sum_filter : forall f : elt -> bool, Proper (E.eq==>Logic.eq) f -> + forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). +Proof. +unfold sum; intros f Hf. +assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). +assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))) by + (repeat red; intros; rewrite Hf; auto). +assert (ct : transposeL (fun x => plus (if f x then 1 else 0))) by + (red; intros; omega). +intros s;pattern s; apply set_rec. +intros. +change elt with E.t. +rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H). +apply equal_2 in H; rewrite <- H, <-H0; auto. +intros; rewrite (fold_add _ _ st _ cc ct); auto. +generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) . +assert (~ In x (filter f s0)). + intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H. +case (f x); simpl; intros. +rewrite (MP.cardinal_2 H1 (H2 (refl_equal true) (MP.Add_add s0 x))); auto. +rewrite <- (MP.Equal_cardinal (H3 (refl_equal false) (MP.Add_add s0 x))); auto. +intros; rewrite fold_empty;auto. +rewrite MP.cardinal_1; auto. +unfold Empty; intros. +rewrite filter_iff; auto; set_iff; tauto. +Qed. + +Lemma fold_compat : + forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f g:elt->A->A), + Proper (E.eq==>eqA==>eqA) f -> transpose eqA f -> + Proper (E.eq==>eqA==>eqA) g -> transpose eqA g -> + forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> + (eqA (fold f s i) (fold g s i)). +Proof. +intros A eqA st f g fc ft gc gt i. +intro s; pattern s; apply set_rec; intros. +transitivity (fold f s0 i). +apply fold_equal with (eqA:=eqA); auto. +rewrite equal_sym; auto. +transitivity (fold g s0 i). +apply H0; intros; apply H1; auto with set. +elim (equal_2 H x); auto with set; intros. +apply fold_equal with (eqA:=eqA); auto with set. +transitivity (f x (fold f s0 i)). +apply fold_add with (eqA:=eqA); auto with set. +transitivity (g x (fold f s0 i)); auto with set relations. +transitivity (g x (fold g s0 i)); auto with set relations. +apply gc; auto with set relations. +symmetry; apply fold_add with (eqA:=eqA); auto. +do 2 rewrite fold_empty; reflexivity. +Qed. + +Lemma sum_compat : + forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> + forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. +intros. +unfold sum; apply (@fold_compat _ (@Logic.eq nat)); + repeat red; auto with *. +Qed. + +End Sum. + +End WEqPropertiesOn. + +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [EqProperties] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WEqProperties]. *) + +Module WEqProperties (M:WSets) := WEqPropertiesOn M.E M. +Module EqProperties := WEqProperties. diff --git a/theories/MSets/MSetFacts.v b/theories/MSets/MSetFacts.v new file mode 100644 index 00000000..6d38b696 --- /dev/null +++ b/theories/MSets/MSetFacts.v @@ -0,0 +1,528 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* In x s -> In y s. +Proof. intros E; rewrite E; auto. Qed. + +Lemma mem_1 : In x s -> mem x s = true. +Proof. intros; apply <- mem_spec; auto. Qed. +Lemma mem_2 : mem x s = true -> In x s. +Proof. intros; apply -> mem_spec; auto. Qed. + +Lemma equal_1 : Equal s s' -> equal s s' = true. +Proof. intros; apply <- equal_spec; auto. Qed. +Lemma equal_2 : equal s s' = true -> Equal s s'. +Proof. intros; apply -> equal_spec; auto. Qed. + +Lemma subset_1 : Subset s s' -> subset s s' = true. +Proof. intros; apply <- subset_spec; auto. Qed. +Lemma subset_2 : subset s s' = true -> Subset s s'. +Proof. intros; apply -> subset_spec; auto. Qed. + +Lemma is_empty_1 : Empty s -> is_empty s = true. +Proof. intros; apply <- is_empty_spec; auto. Qed. +Lemma is_empty_2 : is_empty s = true -> Empty s. +Proof. intros; apply -> is_empty_spec; auto. Qed. + +Lemma add_1 : E.eq x y -> In y (add x s). +Proof. intros; apply <- add_spec. auto with relations. Qed. +Lemma add_2 : In y s -> In y (add x s). +Proof. intros; apply <- add_spec; auto. Qed. +Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. +Proof. rewrite add_spec. intros H [H'|H']; auto. elim H; auto with relations. Qed. + +Lemma remove_1 : E.eq x y -> ~ In y (remove x s). +Proof. intros; rewrite remove_spec; intuition. Qed. +Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). +Proof. intros; apply <- remove_spec; auto with relations. Qed. +Lemma remove_3 : In y (remove x s) -> In y s. +Proof. rewrite remove_spec; intuition. Qed. + +Lemma singleton_1 : In y (singleton x) -> E.eq x y. +Proof. rewrite singleton_spec; auto with relations. Qed. +Lemma singleton_2 : E.eq x y -> In y (singleton x). +Proof. rewrite singleton_spec; auto with relations. Qed. + +Lemma union_1 : In x (union s s') -> In x s \/ In x s'. +Proof. rewrite union_spec; auto. Qed. +Lemma union_2 : In x s -> In x (union s s'). +Proof. rewrite union_spec; auto. Qed. +Lemma union_3 : In x s' -> In x (union s s'). +Proof. rewrite union_spec; auto. Qed. + +Lemma inter_1 : In x (inter s s') -> In x s. +Proof. rewrite inter_spec; intuition. Qed. +Lemma inter_2 : In x (inter s s') -> In x s'. +Proof. rewrite inter_spec; intuition. Qed. +Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). +Proof. rewrite inter_spec; intuition. Qed. + +Lemma diff_1 : In x (diff s s') -> In x s. +Proof. rewrite diff_spec; intuition. Qed. +Lemma diff_2 : In x (diff s s') -> ~ In x s'. +Proof. rewrite diff_spec; intuition. Qed. +Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). +Proof. rewrite diff_spec; auto. Qed. + +Variable f : elt -> bool. +Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). + +Lemma filter_1 : compatb f -> In x (filter f s) -> In x s. +Proof. intros P; rewrite filter_spec; intuition. Qed. +Lemma filter_2 : compatb f -> In x (filter f s) -> f x = true. +Proof. intros P; rewrite filter_spec; intuition. Qed. +Lemma filter_3 : compatb f -> In x s -> f x = true -> In x (filter f s). +Proof. intros P; rewrite filter_spec; intuition. Qed. + +Lemma for_all_1 : compatb f -> + For_all (fun x => f x = true) s -> for_all f s = true. +Proof. intros; apply <- for_all_spec; auto. Qed. +Lemma for_all_2 : compatb f -> + for_all f s = true -> For_all (fun x => f x = true) s. +Proof. intros; apply -> for_all_spec; auto. Qed. + +Lemma exists_1 : compatb f -> + Exists (fun x => f x = true) s -> exists_ f s = true. +Proof. intros; apply <- exists_spec; auto. Qed. + +Lemma exists_2 : compatb f -> + exists_ f s = true -> Exists (fun x => f x = true) s. +Proof. intros; apply -> exists_spec; auto. Qed. + +Lemma elements_1 : In x s -> InA E.eq x (elements s). +Proof. intros; apply <- elements_spec1; auto. Qed. +Lemma elements_2 : InA E.eq x (elements s) -> In x s. +Proof. intros; apply -> elements_spec1; auto. Qed. + +End ImplSpec. + +Notation empty_1 := empty_spec (only parsing). +Notation fold_1 := fold_spec (only parsing). +Notation cardinal_1 := cardinal_spec (only parsing). +Notation partition_1 := partition_spec1 (only parsing). +Notation partition_2 := partition_spec2 (only parsing). +Notation choose_1 := choose_spec1 (only parsing). +Notation choose_2 := choose_spec2 (only parsing). +Notation elements_3w := elements_spec2w (only parsing). + +Hint Resolve mem_1 equal_1 subset_1 empty_1 + is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 + remove_2 singleton_2 union_1 union_2 union_3 + inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 + partition_1 partition_2 elements_1 elements_3w + : set. +Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 + remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 + filter_1 filter_2 for_all_2 exists_2 elements_2 + : set. + + +(** * Specifications written using equivalences : + this is now provided by the default interface. *) + +Section IffSpec. +Variable s s' s'' : t. +Variable x y z : elt. + +Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s). +Proof. +intros E; rewrite E; intuition. +Qed. + +Lemma mem_iff : In x s <-> mem x s = true. +Proof. apply iff_sym, mem_spec. Qed. + +Lemma not_mem_iff : ~In x s <-> mem x s = false. +Proof. +rewrite <-mem_spec; destruct (mem x s); intuition. +Qed. + +Lemma equal_iff : s[=]s' <-> equal s s' = true. +Proof. apply iff_sym, equal_spec. Qed. + +Lemma subset_iff : s[<=]s' <-> subset s s' = true. +Proof. apply iff_sym, subset_spec. Qed. + +Lemma empty_iff : In x empty <-> False. +Proof. intuition; apply (empty_spec H). Qed. + +Lemma is_empty_iff : Empty s <-> is_empty s = true. +Proof. apply iff_sym, is_empty_spec. Qed. + +Lemma singleton_iff : In y (singleton x) <-> E.eq x y. +Proof. rewrite singleton_spec; intuition. Qed. + +Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. +Proof. rewrite add_spec; intuition. Qed. + +Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s) <-> In y s). +Proof. rewrite add_spec; intuition. elim H; auto with relations. Qed. + +Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y. +Proof. rewrite remove_spec; intuition. Qed. + +Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s). +Proof. rewrite remove_spec; intuition. Qed. + +Variable f : elt -> bool. + +Lemma for_all_iff : Proper (E.eq==>Logic.eq) f -> + (For_all (fun x => f x = true) s <-> for_all f s = true). +Proof. intros; apply iff_sym, for_all_spec; auto. Qed. + +Lemma exists_iff : Proper (E.eq==>Logic.eq) f -> + (Exists (fun x => f x = true) s <-> exists_ f s = true). +Proof. intros; apply iff_sym, exists_spec; auto. Qed. + +Lemma elements_iff : In x s <-> InA E.eq x (elements s). +Proof. apply iff_sym, elements_spec1. Qed. + +End IffSpec. + +Notation union_iff := union_spec (only parsing). +Notation inter_iff := inter_spec (only parsing). +Notation diff_iff := diff_spec (only parsing). +Notation filter_iff := filter_spec (only parsing). + +(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) + +Ltac set_iff := + repeat (progress ( + rewrite add_iff || rewrite remove_iff || rewrite singleton_iff + || rewrite union_iff || rewrite inter_iff || rewrite diff_iff + || rewrite empty_iff)). + +(** * Specifications written using boolean predicates *) + +Section BoolSpec. +Variable s s' s'' : t. +Variable x y z : elt. + +Lemma mem_b : E.eq x y -> mem x s = mem y s. +Proof. +intros. +generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). +destruct (mem x s); destruct (mem y s); intuition. +Qed. + +Lemma empty_b : mem y empty = false. +Proof. +generalize (empty_iff y)(mem_iff empty y). +destruct (mem y empty); intuition. +Qed. + +Lemma add_b : mem y (add x s) = eqb x y || mem y s. +Proof. +generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb. +destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition. +Qed. + +Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s. +Proof. +intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H). +destruct (mem y s); destruct (mem y (add x s)); intuition. +Qed. + +Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y). +Proof. +generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb. +destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition. +Qed. + +Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s. +Proof. +intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H). +destruct (mem y s); destruct (mem y (remove x s)); intuition. +Qed. + +Lemma singleton_b : mem y (singleton x) = eqb x y. +Proof. +generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. +destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. +Qed. + +Lemma union_b : mem x (union s s') = mem x s || mem x s'. +Proof. +generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x). +destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition. +Qed. + +Lemma inter_b : mem x (inter s s') = mem x s && mem x s'. +Proof. +generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x). +destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition. +Qed. + +Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s'). +Proof. +generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x). +destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition. +Qed. + +Lemma elements_b : mem x s = existsb (eqb x) (elements s). +Proof. +generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)). +rewrite InA_alt. +destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros. +symmetry. +rewrite H1. +destruct H0 as (H0,_). +destruct H0 as (a,(Ha1,Ha2)); [ intuition |]. +exists a; intuition. +unfold eqb; destruct (eq_dec x a); auto. +rewrite <- H. +rewrite H0. +destruct H1 as (H1,_). +destruct H1 as (a,(Ha1,Ha2)); [intuition|]. +exists a; intuition. +unfold eqb in *; destruct (eq_dec x a); auto; discriminate. +Qed. + +Variable f : elt->bool. + +Lemma filter_b : Proper (E.eq==>Logic.eq) f -> mem x (filter f s) = mem x s && f x. +Proof. +intros. +generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). +destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. +Qed. + +Lemma for_all_b : Proper (E.eq==>Logic.eq) f -> + for_all f s = forallb f (elements s). +Proof. +intros. +generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s). +unfold For_all. +destruct (forallb f (elements s)); destruct (for_all f s); auto; intros. +rewrite <- H1; intros. +destruct H0 as (H0,_). +rewrite (H2 x0) in H3. +rewrite (InA_alt E.eq x0 (elements s)) in H3. +destruct H3 as (a,(Ha1,Ha2)). +rewrite (H _ _ Ha1). +apply H0; auto. +symmetry. +rewrite H0; intros. +destruct H1 as (_,H1). +apply H1; auto. +rewrite H2. +rewrite InA_alt. exists x0; split; auto with relations. +Qed. + +Lemma exists_b : Proper (E.eq==>Logic.eq) f -> + exists_ f s = existsb f (elements s). +Proof. +intros. +generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s). +unfold Exists. +destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. +rewrite <- H1; intros. +destruct H0 as (H0,_). +destruct H0 as (a,(Ha1,Ha2)); auto. +exists a; split; auto. +rewrite H2; rewrite InA_alt; exists a; auto with relations. +symmetry. +rewrite H0. +destruct H1 as (_,H1). +destruct H1 as (a,(Ha1,Ha2)); auto. +rewrite (H2 a) in Ha1. +rewrite (InA_alt E.eq a (elements s)) in Ha1. +destruct Ha1 as (b,(Hb1,Hb2)). +exists b; auto. +rewrite <- (H _ _ Hb1); auto. +Qed. + +End BoolSpec. + +(** * Declarations of morphisms with respects to [E.eq] and [Equal] *) + +Instance In_m : Proper (E.eq==>Equal==>iff) In. +Proof. +unfold Equal; intros x y H s s' H0. +rewrite (In_eq_iff s H); auto. +Qed. + +Instance Empty_m : Proper (Equal==>iff) Empty. +Proof. +repeat red; unfold Empty; intros s s' E. +setoid_rewrite E; auto. +Qed. + +Instance is_empty_m : Proper (Equal==>Logic.eq) is_empty. +Proof. +intros s s' H. +generalize (is_empty_iff s). rewrite H at 1. rewrite is_empty_iff. +destruct (is_empty s); destruct (is_empty s'); intuition. +Qed. + +Instance mem_m : Proper (E.eq==>Equal==>Logic.eq) mem. +Proof. +intros x x' Hx s s' Hs. +generalize (mem_iff s x). rewrite Hs, Hx at 1; rewrite mem_iff. +destruct (mem x s), (mem x' s'); intuition. +Qed. + +Instance singleton_m : Proper (E.eq==>Equal) singleton. +Proof. +intros x y H a. rewrite !singleton_iff, H; intuition. +Qed. + +Instance add_m : Proper (E.eq==>Equal==>Equal) add. +Proof. +intros x x' Hx s s' Hs a. rewrite !add_iff, Hx, Hs; intuition. +Qed. + +Instance remove_m : Proper (E.eq==>Equal==>Equal) remove. +Proof. +intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx, Hs; intuition. +Qed. + +Instance union_m : Proper (Equal==>Equal==>Equal) union. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition. +Qed. + +Instance inter_m : Proper (Equal==>Equal==>Equal) inter. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition. +Qed. + +Instance diff_m : Proper (Equal==>Equal==>Equal) diff. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition. +Qed. + +Instance Subset_m : Proper (Equal==>Equal==>iff) Subset. +Proof. +unfold Equal, Subset; firstorder. +Qed. + +Instance subset_m : Proper (Equal==>Equal==>Logic.eq) subset. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2. +generalize (subset_iff s1 s2). rewrite Hs1, Hs2 at 1. rewrite subset_iff. +destruct (subset s1 s2); destruct (subset s1' s2'); intuition. +Qed. + +Instance equal_m : Proper (Equal==>Equal==>Logic.eq) equal. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2. +generalize (equal_iff s1 s2). rewrite Hs1,Hs2 at 1. rewrite equal_iff. +destruct (equal s1 s2); destruct (equal s1' s2'); intuition. +Qed. + +Instance SubsetSetoid : PreOrder Subset. (* reflexive + transitive *) +Proof. firstorder. Qed. + +Definition Subset_refl := @PreOrder_Reflexive _ _ SubsetSetoid. +Definition Subset_trans := @PreOrder_Transitive _ _ SubsetSetoid. + +Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> impl) In | 1. +Proof. + simpl_relation. eauto with set. +Qed. + +Instance Empty_s_m : Proper (Subset-->impl) Empty. +Proof. firstorder. Qed. + +Instance add_s_m : Proper (E.eq==>Subset++>Subset) add. +Proof. +intros x x' Hx s s' Hs a. rewrite !add_iff, Hx; intuition. +Qed. + +Instance remove_s_m : Proper (E.eq==>Subset++>Subset) remove. +Proof. +intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx; intuition. +Qed. + +Instance union_s_m : Proper (Subset++>Subset++>Subset) union. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition. +Qed. + +Instance inter_s_m : Proper (Subset++>Subset++>Subset) inter. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition. +Qed. + +Instance diff_s_m : Proper (Subset++>Subset-->Subset) diff. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition. +Qed. + + +(* [fold], [filter], [for_all], [exists_] and [partition] requires + some knowledge on [f] in order to be known as morphisms. *) + +Generalizable Variables f. + +Instance filter_equal : forall `(Proper _ (E.eq==>Logic.eq) f), + Proper (Equal==>Equal) (filter f). +Proof. +intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition. +Qed. + +Instance filter_subset : forall `(Proper _ (E.eq==>Logic.eq) f), + Proper (Subset==>Subset) (filter f). +Proof. +intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition. +Qed. + +Lemma filter_ext : forall f f', Proper (E.eq==>Logic.eq) f -> (forall x, f x = f' x) -> + forall s s', s[=]s' -> filter f s [=] filter f' s'. +Proof. +intros f f' Hf Hff' s s' Hss' x. rewrite 2 filter_iff; auto. +rewrite Hff', Hss'; intuition. +red; red; intros; rewrite <- 2 Hff'; auto. +Qed. + +(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid + structures on [list elt] and [option elt]. *) + +(* Later: +Add Morphism cardinal ; cardinal_m. +*) + +End WFactsOn. + +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [Facts] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WFacts]. *) + +Module WFacts (M:WSets) := WFactsOn M.E M. +Module Facts := WFacts. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v new file mode 100644 index 00000000..194cb904 --- /dev/null +++ b/theories/MSets/MSetInterface.v @@ -0,0 +1,732 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool. + (** Test whether a set is empty or not. *) + + Parameter mem : elt -> t -> bool. + (** [mem x s] tests whether [x] belongs to the set [s]. *) + + Parameter add : elt -> t -> t. + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + + Parameter singleton : elt -> t. + (** [singleton x] returns the one-element set containing only [x]. *) + + Parameter remove : elt -> t -> t. + (** [remove x s] returns a set containing all elements of [s], + except [x]. If [x] was not in [s], [s] is returned unchanged. *) + + Parameter union : t -> t -> t. + (** Set union. *) + + Parameter inter : t -> t -> t. + (** Set intersection. *) + + Parameter diff : t -> t -> t. + (** Set difference. *) + + Parameter equal : t -> t -> bool. + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + + Parameter subset : t -> t -> bool. + (** [subset s1 s2] tests whether the set [s1] is a subset of + the set [s2]. *) + + Parameter fold : forall A : Type, (elt -> A -> A) -> t -> A -> A. + (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], + where [x1 ... xN] are the elements of [s]. + The order in which elements of [s] are presented to [f] is + unspecified. *) + + Parameter for_all : (elt -> bool) -> t -> bool. + (** [for_all p s] checks if all elements of the set + satisfy the predicate [p]. *) + + Parameter exists_ : (elt -> bool) -> t -> bool. + (** [exists p s] checks if at least one element of + the set satisfies the predicate [p]. *) + + Parameter filter : (elt -> bool) -> t -> t. + (** [filter p s] returns the set of all elements in [s] + that satisfy predicate [p]. *) + + Parameter partition : (elt -> bool) -> t -> t * t. + (** [partition p s] returns a pair of sets [(s1, s2)], where + [s1] is the set of all the elements of [s] that satisfy the + predicate [p], and [s2] is the set of all the elements of + [s] that do not satisfy [p]. *) + + Parameter cardinal : t -> nat. + (** Return the number of elements of a set. *) + + Parameter elements : t -> list elt. + (** Return the list of all elements of the given set, in any order. *) + + Parameter choose : t -> option elt. + (** Return one element of the given set, or [None] if + the set is empty. Which element is chosen is unspecified. + Equal sets could return different elements. *) + +End HasWOps. + +Module Type WOps (E : DecidableType). + Definition elt := E.t. + Parameter t : Type. (** the abstract type of sets *) + Include HasWOps. +End WOps. + + +(** ** Functorial signature for weak sets + + Weak sets are sets without ordering on base elements, only + a decidable equality. *) + +Module Type WSetsOn (E : DecidableType). + (** First, we ask for all the functions *) + Include WOps E. + + (** Logical predicates *) + Parameter In : elt -> t -> Prop. + Declare Instance In_compat : Proper (E.eq==>eq==>iff) In. + + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + + Definition eq : t -> t -> Prop := Equal. + Include IsEq. (** [eq] is obviously an equivalence, for subtyping only *) + Include HasEqDec. + + (** Specifications of set operators *) + + Section Spec. + Variable s s': t. + Variable x y : elt. + Variable f : elt -> bool. + Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). + + Parameter mem_spec : mem x s = true <-> In x s. + Parameter equal_spec : equal s s' = true <-> s[=]s'. + Parameter subset_spec : subset s s' = true <-> s[<=]s'. + Parameter empty_spec : Empty empty. + Parameter is_empty_spec : is_empty s = true <-> Empty s. + Parameter add_spec : In y (add x s) <-> E.eq y x \/ In y s. + Parameter remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. + Parameter singleton_spec : In y (singleton x) <-> E.eq y x. + Parameter union_spec : In x (union s s') <-> In x s \/ In x s'. + Parameter inter_spec : In x (inter s s') <-> In x s /\ In x s'. + Parameter diff_spec : In x (diff s s') <-> In x s /\ ~In x s'. + Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. + Parameter cardinal_spec : cardinal s = length (elements s). + Parameter filter_spec : compatb f -> + (In x (filter f s) <-> In x s /\ f x = true). + Parameter for_all_spec : compatb f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Parameter exists_spec : compatb f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Parameter partition_spec1 : compatb f -> + fst (partition f s) [=] filter f s. + Parameter partition_spec2 : compatb f -> + snd (partition f s) [=] filter (fun x => negb (f x)) s. + Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s. + (** When compared with ordered sets, here comes the only + property that is really weaker: *) + Parameter elements_spec2w : NoDupA E.eq (elements s). + Parameter choose_spec1 : choose s = Some x -> In x s. + Parameter choose_spec2 : choose s = None -> Empty s. + + End Spec. + +End WSetsOn. + +(** ** Static signature for weak sets + + Similar to the functorial signature [WSetsOn], except that the + module [E] of base elements is incorporated in the signature. *) + +Module Type WSets. + Declare Module E : DecidableType. + Include WSetsOn E. +End WSets. + +(** ** Functorial signature for sets on ordered elements + + Based on [WSetsOn], plus ordering on sets and [min_elt] and [max_elt] + and some stronger specifications for other functions. *) + +Module Type HasOrdOps (Import T:TypElt). + + Parameter compare : t -> t -> comparison. + (** Total ordering between sets. Can be used as the ordering function + for doing sets of sets. *) + + Parameter min_elt : t -> option elt. + (** Return the smallest element of the given set + (with respect to the [E.compare] ordering), + or [None] if the set is empty. *) + + Parameter max_elt : t -> option elt. + (** Same as [min_elt], but returns the largest element of the + given set. *) + +End HasOrdOps. + +Module Type Ops (E : OrderedType) := WOps E <+ HasOrdOps. + + +Module Type SetsOn (E : OrderedType). + Include WSetsOn E <+ HasOrdOps <+ HasLt <+ IsStrOrder. + + Section Spec. + Variable s s': t. + Variable x y : elt. + + Parameter compare_spec : CompSpec eq lt s s' (compare s s'). + + (** Additional specification of [elements] *) + Parameter elements_spec2 : sort E.lt (elements s). + + (** Remark: since [fold] is specified via [elements], this stronger + specification of [elements] has an indirect impact on [fold], + which can now be proved to receive elements in increasing order. + *) + + Parameter min_elt_spec1 : min_elt s = Some x -> In x s. + Parameter min_elt_spec2 : min_elt s = Some x -> In y s -> ~ E.lt y x. + Parameter min_elt_spec3 : min_elt s = None -> Empty s. + + Parameter max_elt_spec1 : max_elt s = Some x -> In x s. + Parameter max_elt_spec2 : max_elt s = Some x -> In y s -> ~ E.lt x y. + Parameter max_elt_spec3 : max_elt s = None -> Empty s. + + (** Additional specification of [choose] *) + Parameter choose_spec3 : choose s = Some x -> choose s' = Some y -> + Equal s s' -> E.eq x y. + + End Spec. + +End SetsOn. + + +(** ** Static signature for sets on ordered elements + + Similar to the functorial signature [SetsOn], except that the + module [E] of base elements is incorporated in the signature. *) + +Module Type Sets. + Declare Module E : OrderedType. + Include SetsOn E. +End Sets. + +Module Type S := Sets. + + +(** ** Some subtyping tests +<< +WSetsOn ---> WSets + | | + | | + V V +SetsOn ---> Sets + +Module S_WS (M : Sets) <: WSets := M. +Module Sfun_WSfun (E:OrderedType)(M : SetsOn E) <: WSetsOn E := M. +Module S_Sfun (M : Sets) <: SetsOn M.E := M. +Module WS_WSfun (M : WSets) <: WSetsOn M.E := M. +>> +*) + + + +(** ** Signatures for set representations with ill-formed values. + + Motivation: + + For many implementation of finite sets (AVL trees, sorted + lists, lists without duplicates), we use the same two-layer + approach: + + - A first module deals with the datatype (eg. list or tree) without + any restriction on the values we consider. In this module (named + "Raw" in the past), some results are stated under the assumption + that some invariant (e.g. sortedness) holds for the input sets. We + also prove that this invariant is preserved by set operators. + + - A second module implements the exact Sets interface by + using a subtype, for instance [{ l : list A | sorted l }]. + This module is a mere wrapper around the first Raw module. + + With the interfaces below, we give some respectability to + the "Raw" modules. This allows the interested users to directly + access them via the interfaces. Even better, we can build once + and for all a functor doing the transition between Raw and usual Sets. + + Description: + + The type [t] of sets may contain ill-formed values on which our + set operators may give wrong answers. In particular, [mem] + may not see a element in a ill-formed set (think for instance of a + unsorted list being given to an optimized [mem] that stops + its search as soon as a strictly larger element is encountered). + + Unlike optimized operators, the [In] predicate is supposed to + always be correct, even on ill-formed sets. Same for [Equal] and + other logical predicates. + + A predicate parameter [Ok] is used to discriminate between + well-formed and ill-formed values. Some lemmas hold only on sets + validating [Ok]. This predicate [Ok] is required to be + preserved by set operators. Moreover, a boolean function [isok] + should exist for identifying (at least some of) the well-formed sets. + +*) + + +Module Type WRawSets (E : DecidableType). + (** First, we ask for all the functions *) + Include WOps E. + + (** Is a set well-formed or ill-formed ? *) + + Parameter IsOk : t -> Prop. + Class Ok (s:t) : Prop := ok : IsOk s. + + (** In order to be able to validate (at least some) particular sets as + well-formed, we ask for a boolean function for (semi-)deciding + predicate [Ok]. If [Ok] isn't decidable, [isok] may be the + always-false function. *) + Parameter isok : t -> bool. + Declare Instance isok_Ok s `(isok s = true) : Ok s | 10. + + (** Logical predicates *) + Parameter In : elt -> t -> Prop. + Declare Instance In_compat : Proper (E.eq==>eq==>iff) In. + + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + + Definition eq : t -> t -> Prop := Equal. + Declare Instance eq_equiv : Equivalence eq. + + (** First, all operations are compatible with the well-formed predicate. *) + + Declare Instance empty_ok : Ok empty. + Declare Instance add_ok s x `(Ok s) : Ok (add x s). + Declare Instance remove_ok s x `(Ok s) : Ok (remove x s). + Declare Instance singleton_ok x : Ok (singleton x). + Declare Instance union_ok s s' `(Ok s, Ok s') : Ok (union s s'). + Declare Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s'). + Declare Instance diff_ok s s' `(Ok s, Ok s') : Ok (diff s s'). + Declare Instance filter_ok s f `(Ok s) : Ok (filter f s). + Declare Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)). + Declare Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)). + + (** Now, the specifications, with constraints on the input sets. *) + + Section Spec. + Variable s s': t. + Variable x y : elt. + Variable f : elt -> bool. + Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). + + Parameter mem_spec : forall `{Ok s}, mem x s = true <-> In x s. + Parameter equal_spec : forall `{Ok s, Ok s'}, + equal s s' = true <-> s[=]s'. + Parameter subset_spec : forall `{Ok s, Ok s'}, + subset s s' = true <-> s[<=]s'. + Parameter empty_spec : Empty empty. + Parameter is_empty_spec : is_empty s = true <-> Empty s. + Parameter add_spec : forall `{Ok s}, + In y (add x s) <-> E.eq y x \/ In y s. + Parameter remove_spec : forall `{Ok s}, + In y (remove x s) <-> In y s /\ ~E.eq y x. + Parameter singleton_spec : In y (singleton x) <-> E.eq y x. + Parameter union_spec : forall `{Ok s, Ok s'}, + In x (union s s') <-> In x s \/ In x s'. + Parameter inter_spec : forall `{Ok s, Ok s'}, + In x (inter s s') <-> In x s /\ In x s'. + Parameter diff_spec : forall `{Ok s, Ok s'}, + In x (diff s s') <-> In x s /\ ~In x s'. + Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. + Parameter cardinal_spec : forall `{Ok s}, + cardinal s = length (elements s). + Parameter filter_spec : compatb f -> + (In x (filter f s) <-> In x s /\ f x = true). + Parameter for_all_spec : compatb f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Parameter exists_spec : compatb f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Parameter partition_spec1 : compatb f -> + fst (partition f s) [=] filter f s. + Parameter partition_spec2 : compatb f -> + snd (partition f s) [=] filter (fun x => negb (f x)) s. + Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s. + Parameter elements_spec2w : forall `{Ok s}, NoDupA E.eq (elements s). + Parameter choose_spec1 : choose s = Some x -> In x s. + Parameter choose_spec2 : choose s = None -> Empty s. + + End Spec. + +End WRawSets. + +(** From weak raw sets to weak usual sets *) + +Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. + + (** We avoid creating induction principles for the Record *) + Local Unset Elimination Schemes. + Local Unset Case Analysis Schemes. + + Definition elt := E.t. + + Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. + Definition t := t_. + Implicit Arguments Mkt [ [is_ok] ]. + Hint Resolve is_ok : typeclass_instances. + + Definition In (x : elt)(s : t) := M.In x s.(this). + Definition Equal (s s' : t) := forall a : elt, In a s <-> In a s'. + Definition Subset (s s' : t) := forall a : elt, In a s -> In a s'. + Definition Empty (s : t) := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop)(s : t) := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop)(s : t) := exists x, In x s /\ P x. + + Definition mem (x : elt)(s : t) := M.mem x s. + Definition add (x : elt)(s : t) : t := Mkt (M.add x s). + Definition remove (x : elt)(s : t) : t := Mkt (M.remove x s). + Definition singleton (x : elt) : t := Mkt (M.singleton x). + Definition union (s s' : t) : t := Mkt (M.union s s'). + Definition inter (s s' : t) : t := Mkt (M.inter s s'). + Definition diff (s s' : t) : t := Mkt (M.diff s s'). + Definition equal (s s' : t) := M.equal s s'. + Definition subset (s s' : t) := M.subset s s'. + Definition empty : t := Mkt M.empty. + Definition is_empty (s : t) := M.is_empty s. + Definition elements (s : t) : list elt := M.elements s. + Definition choose (s : t) : option elt := M.choose s. + Definition fold (A : Type)(f : elt -> A -> A)(s : t) : A -> A := M.fold f s. + Definition cardinal (s : t) := M.cardinal s. + Definition filter (f : elt -> bool)(s : t) : t := Mkt (M.filter f s). + Definition for_all (f : elt -> bool)(s : t) := M.for_all f s. + Definition exists_ (f : elt -> bool)(s : t) := M.exists_ f s. + Definition partition (f : elt -> bool)(s : t) : t * t := + let p := M.partition f s in (Mkt (fst p), Mkt (snd p)). + + Instance In_compat : Proper (E.eq==>eq==>iff) In. + Proof. repeat red. intros; apply M.In_compat; congruence. Qed. + + Definition eq : t -> t -> Prop := Equal. + + Instance eq_equiv : Equivalence eq. + Proof. firstorder. Qed. + + Definition eq_dec : forall (s s':t), { eq s s' }+{ ~eq s s' }. + Proof. + intros (s,Hs) (s',Hs'). + change ({M.Equal s s'}+{~M.Equal s s'}). + destruct (M.equal s s') as [ ]_eqn:H; [left|right]; + rewrite <- M.equal_spec; congruence. + Defined. + + + Section Spec. + Variable s s' : t. + Variable x y : elt. + Variable f : elt -> bool. + Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). + + Lemma mem_spec : mem x s = true <-> In x s. + Proof. exact (@M.mem_spec _ _ _). Qed. + Lemma equal_spec : equal s s' = true <-> Equal s s'. + Proof. exact (@M.equal_spec _ _ _ _). Qed. + Lemma subset_spec : subset s s' = true <-> Subset s s'. + Proof. exact (@M.subset_spec _ _ _ _). Qed. + Lemma empty_spec : Empty empty. + Proof. exact M.empty_spec. Qed. + Lemma is_empty_spec : is_empty s = true <-> Empty s. + Proof. exact (@M.is_empty_spec _). Qed. + Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s. + Proof. exact (@M.add_spec _ _ _ _). Qed. + Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. + Proof. exact (@M.remove_spec _ _ _ _). Qed. + Lemma singleton_spec : In y (singleton x) <-> E.eq y x. + Proof. exact (@M.singleton_spec _ _). Qed. + Lemma union_spec : In x (union s s') <-> In x s \/ In x s'. + Proof. exact (@M.union_spec _ _ _ _ _). Qed. + Lemma inter_spec : In x (inter s s') <-> In x s /\ In x s'. + Proof. exact (@M.inter_spec _ _ _ _ _). Qed. + Lemma diff_spec : In x (diff s s') <-> In x s /\ ~In x s'. + Proof. exact (@M.diff_spec _ _ _ _ _). Qed. + Lemma fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + Proof. exact (@M.fold_spec _). Qed. + Lemma cardinal_spec : cardinal s = length (elements s). + Proof. exact (@M.cardinal_spec s _). Qed. + Lemma filter_spec : compatb f -> + (In x (filter f s) <-> In x s /\ f x = true). + Proof. exact (@M.filter_spec _ _ _). Qed. + Lemma for_all_spec : compatb f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. exact (@M.for_all_spec _ _). Qed. + Lemma exists_spec : compatb f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. exact (@M.exists_spec _ _). Qed. + Lemma partition_spec1 : compatb f -> Equal (fst (partition f s)) (filter f s). + Proof. exact (@M.partition_spec1 _ _). Qed. + Lemma partition_spec2 : compatb f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. exact (@M.partition_spec2 _ _). Qed. + Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s. + Proof. exact (@M.elements_spec1 _ _). Qed. + Lemma elements_spec2w : NoDupA E.eq (elements s). + Proof. exact (@M.elements_spec2w _ _). Qed. + Lemma choose_spec1 : choose s = Some x -> In x s. + Proof. exact (@M.choose_spec1 _ _). Qed. + Lemma choose_spec2 : choose s = None -> Empty s. + Proof. exact (@M.choose_spec2 _). Qed. + + End Spec. + +End WRaw2SetsOn. + +Module WRaw2Sets (D:DecidableType)(M:WRawSets D) <: WSets with Module E := D. + Module E := D. + Include WRaw2SetsOn D M. +End WRaw2Sets. + +(** Same approach for ordered sets *) + +Module Type RawSets (E : OrderedType). + Include WRawSets E <+ HasOrdOps <+ HasLt <+ IsStrOrder. + + Section Spec. + Variable s s': t. + Variable x y : elt. + + (** Specification of [compare] *) + Parameter compare_spec : forall `{Ok s, Ok s'}, CompSpec eq lt s s' (compare s s'). + + (** Additional specification of [elements] *) + Parameter elements_spec2 : forall `{Ok s}, sort E.lt (elements s). + + (** Specification of [min_elt] *) + Parameter min_elt_spec1 : min_elt s = Some x -> In x s. + Parameter min_elt_spec2 : forall `{Ok s}, min_elt s = Some x -> In y s -> ~ E.lt y x. + Parameter min_elt_spec3 : min_elt s = None -> Empty s. + + (** Specification of [max_elt] *) + Parameter max_elt_spec1 : max_elt s = Some x -> In x s. + Parameter max_elt_spec2 : forall `{Ok s}, max_elt s = Some x -> In y s -> ~ E.lt x y. + Parameter max_elt_spec3 : max_elt s = None -> Empty s. + + (** Additional specification of [choose] *) + Parameter choose_spec3 : forall `{Ok s, Ok s'}, + choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. + + End Spec. + +End RawSets. + +(** From Raw to usual sets *) + +Module Raw2SetsOn (O:OrderedType)(M:RawSets O) <: SetsOn O. + Include WRaw2SetsOn O M. + + Definition compare (s s':t) := M.compare s s'. + Definition min_elt (s:t) : option elt := M.min_elt s. + Definition max_elt (s:t) : option elt := M.max_elt s. + Definition lt (s s':t) := M.lt s s'. + + (** Specification of [lt] *) + Instance lt_strorder : StrictOrder lt. + Proof. constructor ; unfold lt; red. + unfold complement. red. intros. apply (irreflexivity H). + intros. transitivity y; auto. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + repeat red. unfold eq, lt. + intros (s1,p1) (s2,p2) E (s1',p1') (s2',p2') E'; simpl. + change (M.eq s1 s2) in E. + change (M.eq s1' s2') in E'. + rewrite E,E'; intuition. + Qed. + + Section Spec. + Variable s s' s'' : t. + Variable x y : elt. + + Lemma compare_spec : CompSpec eq lt s s' (compare s s'). + Proof. unfold compare; destruct (@M.compare_spec s s' _ _); auto. Qed. + + (** Additional specification of [elements] *) + Lemma elements_spec2 : sort O.lt (elements s). + Proof. exact (@M.elements_spec2 _ _). Qed. + + (** Specification of [min_elt] *) + Lemma min_elt_spec1 : min_elt s = Some x -> In x s. + Proof. exact (@M.min_elt_spec1 _ _). Qed. + Lemma min_elt_spec2 : min_elt s = Some x -> In y s -> ~ O.lt y x. + Proof. exact (@M.min_elt_spec2 _ _ _ _). Qed. + Lemma min_elt_spec3 : min_elt s = None -> Empty s. + Proof. exact (@M.min_elt_spec3 _). Qed. + + (** Specification of [max_elt] *) + Lemma max_elt_spec1 : max_elt s = Some x -> In x s. + Proof. exact (@M.max_elt_spec1 _ _). Qed. + Lemma max_elt_spec2 : max_elt s = Some x -> In y s -> ~ O.lt x y. + Proof. exact (@M.max_elt_spec2 _ _ _ _). Qed. + Lemma max_elt_spec3 : max_elt s = None -> Empty s. + Proof. exact (@M.max_elt_spec3 _). Qed. + + (** Additional specification of [choose] *) + Lemma choose_spec3 : + choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y. + Proof. exact (@M.choose_spec3 _ _ _ _ _ _). Qed. + + End Spec. + +End Raw2SetsOn. + +Module Raw2Sets (O:OrderedType)(M:RawSets O) <: Sets with Module E := O. + Module E := O. + Include Raw2SetsOn O M. +End Raw2Sets. + + +(** We provide an ordering for sets-as-sorted-lists *) + +Module MakeListOrdering (O:OrderedType). + Module MO:=OrderedTypeFacts O. + + Local Notation t := (list O.t). + Local Notation In := (InA O.eq). + + Definition eq s s' := forall x, In x s <-> In x s'. + + Instance eq_equiv : Equivalence eq. + + Inductive lt_list : t -> t -> Prop := + | lt_nil : forall x s, lt_list nil (x :: s) + | lt_cons_lt : forall x y s s', + O.lt x y -> lt_list (x :: s) (y :: s') + | lt_cons_eq : forall x y s s', + O.eq x y -> lt_list s s' -> lt_list (x :: s) (y :: s'). + Hint Constructors lt_list. + + Definition lt := lt_list. + Hint Unfold lt. + + Instance lt_strorder : StrictOrder lt. + Proof. + split. + (* irreflexive *) + assert (forall s s', s=s' -> ~lt s s'). + red; induction 2. + discriminate. + inversion H; subst. + apply (StrictOrder_Irreflexive y); auto. + inversion H; subst; auto. + intros s Hs; exact (H s s (eq_refl s) Hs). + (* transitive *) + intros s s' s'' H; generalize s''; clear s''; elim H. + intros x l s'' H'; inversion_clear H'; auto. + intros x x' l l' E s'' H'; inversion_clear H'; auto. + constructor 2. transitivity x'; auto. + constructor 2. rewrite <- H0; auto. + intros. + inversion_clear H3. + constructor 2. rewrite H0; auto. + constructor 3; auto. transitivity y; auto. unfold lt in *; auto. + Qed. + + Instance lt_compat' : + Proper (eqlistA O.eq==>eqlistA O.eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + intros s1 s1' E1 s2 s2' E2 H. + revert s1' E1 s2' E2. + induction H; intros; inversion_clear E1; inversion_clear E2. + constructor 1. + constructor 2. MO.order. + constructor 3. MO.order. unfold lt in *; auto. + Qed. + + Lemma eq_cons : + forall l1 l2 x y, + O.eq x y -> eq l1 l2 -> eq (x :: l1) (y :: l2). + Proof. + unfold eq; intros l1 l2 x y Exy E12 z. + split; inversion_clear 1. + left; MO.order. right; rewrite <- E12; auto. + left; MO.order. right; rewrite E12; auto. + Qed. + Hint Resolve eq_cons. + + Lemma cons_CompSpec : forall c x1 x2 l1 l2, O.eq x1 x2 -> + CompSpec eq lt l1 l2 c -> CompSpec eq lt (x1::l1) (x2::l2) c. + Proof. + destruct c; simpl; inversion_clear 2; auto with relations. + Qed. + Hint Resolve cons_CompSpec. + +End MakeListOrdering. diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v new file mode 100644 index 00000000..48af7e6a --- /dev/null +++ b/theories/MSets/MSetList.v @@ -0,0 +1,899 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* false + | y :: l => + match X.compare x y with + | Lt => false + | Eq => true + | Gt => mem x l + end + end. + + Fixpoint add x s := + match s with + | nil => x :: nil + | y :: l => + match X.compare x y with + | Lt => x :: s + | Eq => s + | Gt => y :: add x l + end + end. + + Definition singleton (x : elt) := x :: nil. + + Fixpoint remove x s := + match s with + | nil => nil + | y :: l => + match X.compare x y with + | Lt => s + | Eq => l + | Gt => y :: remove x l + end + end. + + Fixpoint union (s : t) : t -> t := + match s with + | nil => fun s' => s' + | x :: l => + (fix union_aux (s' : t) : t := + match s' with + | nil => s + | x' :: l' => + match X.compare x x' with + | Lt => x :: union l s' + | Eq => x :: union l l' + | Gt => x' :: union_aux l' + end + end) + end. + + Fixpoint inter (s : t) : t -> t := + match s with + | nil => fun _ => nil + | x :: l => + (fix inter_aux (s' : t) : t := + match s' with + | nil => nil + | x' :: l' => + match X.compare x x' with + | Lt => inter l s' + | Eq => x :: inter l l' + | Gt => inter_aux l' + end + end) + end. + + Fixpoint diff (s : t) : t -> t := + match s with + | nil => fun _ => nil + | x :: l => + (fix diff_aux (s' : t) : t := + match s' with + | nil => s + | x' :: l' => + match X.compare x x' with + | Lt => x :: diff l s' + | Eq => diff l l' + | Gt => diff_aux l' + end + end) + end. + + Fixpoint equal (s : t) : t -> bool := + fun s' : t => + match s, s' with + | nil, nil => true + | x :: l, x' :: l' => + match X.compare x x' with + | Eq => equal l l' + | _ => false + end + | _, _ => false + end. + + Fixpoint subset s s' := + match s, s' with + | nil, _ => true + | x :: l, x' :: l' => + match X.compare x x' with + | Lt => false + | Eq => subset l l' + | Gt => subset s l' + end + | _, _ => false + end. + + Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B := + fold_left (flip f) s i. + + Fixpoint filter (f : elt -> bool) (s : t) : t := + match s with + | nil => nil + | x :: l => if f x then x :: filter f l else filter f l + end. + + Fixpoint for_all (f : elt -> bool) (s : t) : bool := + match s with + | nil => true + | x :: l => if f x then for_all f l else false + end. + + Fixpoint exists_ (f : elt -> bool) (s : t) : bool := + match s with + | nil => false + | x :: l => if f x then true else exists_ f l + end. + + Fixpoint partition (f : elt -> bool) (s : t) : t * t := + match s with + | nil => (nil, nil) + | x :: l => + let (s1, s2) := partition f l in + if f x then (x :: s1, s2) else (s1, x :: s2) + end. + + Definition cardinal (s : t) : nat := length s. + + Definition elements (x : t) : list elt := x. + + Definition min_elt (s : t) : option elt := + match s with + | nil => None + | x :: _ => Some x + end. + + Fixpoint max_elt (s : t) : option elt := + match s with + | nil => None + | x :: nil => Some x + | _ :: l => max_elt l + end. + + Definition choose := min_elt. + + Fixpoint compare s s' := + match s, s' with + | nil, nil => Eq + | nil, _ => Lt + | _, nil => Gt + | x::s, x'::s' => + match X.compare x x' with + | Eq => compare s s' + | Lt => Lt + | Gt => Gt + end + end. + +End Ops. + +Module MakeRaw (X: OrderedType) <: RawSets X. + Module Import MX := OrderedTypeFacts X. + Module Import ML := OrderedTypeLists X. + + Include Ops X. + + (** ** Proofs of set operation specifications. *) + + Section ForNotations. + + Definition inf x l := + match l with + | nil => true + | y::_ => match X.compare x y with Lt => true | _ => false end + end. + + Fixpoint isok l := + match l with + | nil => true + | x::l => inf x l && isok l + end. + + Notation Sort l := (isok l = true). + Notation Inf := (lelistA X.lt). + Notation In := (InA X.eq). + + (* 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). + + Definition IsOk s := Sort s. + + Class Ok (s:t) : Prop := ok : Sort s. + + Hint Resolve @ok. + Hint Unfold Ok. + + Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }. + + Lemma inf_iff : forall x l, Inf x l <-> inf x l = true. + Proof. + intros x l; split; intro H. + (* -> *) + destruct H; simpl in *. + reflexivity. + rewrite <- compare_lt_iff in H; rewrite H; reflexivity. + (* <- *) + destruct l as [|y ys]; simpl in *. + constructor; fail. + revert H; case_eq (X.compare x y); try discriminate; []. + intros Ha _. + rewrite compare_lt_iff in Ha. + constructor; assumption. + Qed. + + Lemma isok_iff : forall l, sort X.lt l <-> Ok l. + Proof. + intro l; split; intro H. + (* -> *) + elim H. + constructor; fail. + intros y ys Ha Hb Hc. + change (inf y ys && isok ys = true). + rewrite inf_iff in Hc. + rewrite andb_true_iff; tauto. + (* <- *) + induction l as [|x xs]. + constructor. + change (inf x xs && isok xs = true) in H. + rewrite andb_true_iff, <- inf_iff in H. + destruct H; constructor; tauto. + Qed. + + Hint Extern 1 (Ok _) => rewrite <- isok_iff. + + Ltac inv_ok := match goal with + | H:sort X.lt (_ :: _) |- _ => inversion_clear H; inv_ok + | H:sort X.lt nil |- _ => clear H; inv_ok + | H:sort X.lt ?l |- _ => change (Ok l) in H; inv_ok + | H:Ok _ |- _ => rewrite <- isok_iff in H; inv_ok + | |- Ok _ => rewrite <- isok_iff + | _ => idtac + end. + + Ltac inv := invlist InA; inv_ok; invlist lelistA. + Ltac constructors := repeat constructor. + + Ltac sort_inf_in := match goal with + | H:Inf ?x ?l, H':In ?y ?l |- _ => + cut (X.lt x y); [ intro | apply Sort_Inf_In with l; auto] + | _ => fail + end. + + Global Instance isok_Ok s `(isok s = true) : Ok s | 10. + Proof. + intros. assumption. + Qed. + + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x. + + Lemma mem_spec : + forall (s : t) (x : elt) (Hs : Ok s), mem x s = true <-> In x s. + Proof. + induction s; intros x Hs; inv; simpl. + intuition. discriminate. inv. + elim_compare x a; rewrite InA_cons; intuition; try order. + discriminate. + sort_inf_in. order. + rewrite <- IHs; auto. + rewrite IHs; auto. + Qed. + + Lemma add_inf : + forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s). + Proof. + simple induction s; simpl. + intuition. + intros; elim_compare x a; inv; intuition. + Qed. + Hint Resolve add_inf. + + Global Instance add_ok s x : forall `(Ok s), Ok (add x s). + Proof. + repeat rewrite <- isok_iff; revert s x. + simple induction s; simpl. + intuition. + intros; elim_compare x a; inv; auto. + Qed. + + Lemma add_spec : + forall (s : t) (x y : elt) (Hs : Ok s), + In y (add x s) <-> X.eq y x \/ In y s. + Proof. + induction s; simpl; intros. + intuition. inv; auto. + elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition. + left; order. + Qed. + + Lemma remove_inf : + forall (s : t) (x a : elt) (Hs : Ok s), Inf a s -> Inf a (remove x s). + Proof. + induction s; simpl. + intuition. + intros; elim_compare x a; inv; auto. + apply Inf_lt with a; auto. + Qed. + Hint Resolve remove_inf. + + Global Instance remove_ok s x : forall `(Ok s), Ok (remove x s). + Proof. + repeat rewrite <- isok_iff; revert s x. + induction s; simpl. + intuition. + intros; elim_compare x a; inv; auto. + Qed. + + Lemma remove_spec : + forall (s : t) (x y : elt) (Hs : Ok s), + In y (remove x s) <-> In y s /\ ~X.eq y x. + Proof. + induction s; simpl; intros. + intuition; inv; auto. + elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition; + try sort_inf_in; try order. + Qed. + + Global Instance singleton_ok x : Ok (singleton x). + Proof. + unfold singleton; simpl; auto. + Qed. + + Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x. + Proof. + unfold singleton; simpl; split; intros; inv; auto. + Qed. + + Ltac induction2 := + simple induction s; + [ simpl; auto; try solve [ intros; inv ] + | intros x l Hrec; simple induction s'; + [ simpl; auto; try solve [ intros; inv ] + | intros x' l' Hrec'; simpl; elim_compare x x'; intros; inv; auto ]]. + + Lemma union_inf : + forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'), + Inf a s -> Inf a s' -> Inf a (union s s'). + Proof. + induction2. + Qed. + Hint Resolve union_inf. + + 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. + change (Inf x' (union (x :: l) l')); auto. + Qed. + + Lemma union_spec : + forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), + In x (union s s') <-> In x s \/ In x s'. + Proof. + induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto. + left; order. + Qed. + + Lemma inter_inf : + forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'), + Inf a s -> Inf a s' -> Inf a (inter s s'). + Proof. + induction2. + apply Inf_lt with x; auto. + apply Hrec'; auto. + apply Inf_lt with x'; auto. + Qed. + Hint Resolve inter_inf. + + Global Instance inter_ok s s' : forall `(Ok s, Ok s'), Ok (inter s s'). + Proof. + repeat rewrite <- isok_iff; revert s s'. + induction2. + constructors; auto. + apply Inf_eq with x'; auto; apply inter_inf; auto; apply Inf_eq with x; auto. + Qed. + + Lemma inter_spec : + forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), + In x (inter s s') <-> In x s /\ In x s'. + Proof. + induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto; + try sort_inf_in; try order. + left; order. + Qed. + + Lemma diff_inf : + forall (s s' : t) (Hs : Ok s) (Hs' : Ok s') (a : elt), + Inf a s -> Inf a s' -> Inf a (diff s s'). + Proof. + intros s s'; repeat rewrite <- isok_iff; revert s s'. + induction2. + apply Hrec; trivial. + apply Inf_lt with x; auto. + apply Inf_lt with x'; auto. + apply Hrec'; auto. + apply Inf_lt with x'; auto. + Qed. + Hint Resolve diff_inf. + + Global Instance diff_ok s s' : forall `(Ok s, Ok s'), Ok (diff s s'). + Proof. + repeat rewrite <- isok_iff; revert s s'. + induction2. + Qed. + + Lemma diff_spec : + forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), + In x (diff s s') <-> In x s /\ ~In x s'. + Proof. + induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto; + try sort_inf_in; try order. + right; intuition; inv; auto. + Qed. + + Lemma equal_spec : + forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'), + equal s s' = true <-> Equal s s'. + Proof. + induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl. + intuition. + split; intros H. discriminate. assert (In x' nil) by (rewrite H; auto). inv. + split; intros H. discriminate. assert (In x nil) by (rewrite <-H; auto). inv. + inv. + elim_compare x x' as C; try discriminate. + (* x=x' *) + rewrite IH; auto. + split; intros E y; specialize (E y). + rewrite !InA_cons, E, C; intuition. + rewrite !InA_cons, C in E. intuition; try sort_inf_in; order. + (* xx' *) + split; intros E. discriminate. + assert (In x' (x::s)) by (rewrite E; auto). + inv; try sort_inf_in; order. + Qed. + + Lemma subset_spec : + forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'), + subset s s' = true <-> Subset s s'. + Proof. + intros s s'; revert s. + induction s' as [ | x' s' IH]; intros [ | x s] Hs Hs'; simpl; auto. + split; try red; intros; auto. + split; intros H. discriminate. assert (In x nil) by (apply H; auto). inv. + split; try red; intros; auto. inv. + inv. elim_compare x x' as C. + (* x=x' *) + rewrite IH; auto. + split; intros S y; specialize (S y). + rewrite !InA_cons, C. intuition. + rewrite !InA_cons, C in S. intuition; try sort_inf_in; order. + (* xx' *) + rewrite IH; auto. + split; intros S y; specialize (S y). + rewrite !InA_cons. intuition. + rewrite !InA_cons in S. rewrite !InA_cons. intuition; try sort_inf_in; order. + Qed. + + Global Instance empty_ok : Ok empty. + Proof. + constructors. + Qed. + + Lemma empty_spec : Empty empty. + Proof. + unfold Empty, empty; intuition; inv. + Qed. + + Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s. + Proof. + intros [ | x s]; simpl. + split; auto. intros _ x H. inv. + split. discriminate. intros H. elim (H x); auto. + Qed. + + Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s. + Proof. + intuition. + Qed. + + Lemma elements_spec2 : forall (s : t) (Hs : Ok s), sort X.lt (elements s). + Proof. + intro s; repeat rewrite <- isok_iff; auto. + Qed. + + Lemma elements_spec2w : forall (s : t) (Hs : Ok s), NoDupA X.eq (elements s). + Proof. + intro s; repeat rewrite <- isok_iff; auto. + Qed. + + Lemma min_elt_spec1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. + Proof. + destruct s; simpl; inversion 1; auto. + Qed. + + Lemma min_elt_spec2 : + forall (s : t) (x y : elt) (Hs : Ok s), + min_elt s = Some x -> In y s -> ~ X.lt y x. + Proof. + induction s as [ | x s IH]; simpl; inversion 2; subst. + intros; inv; try sort_inf_in; order. + Qed. + + Lemma min_elt_spec3 : forall s : t, min_elt s = None -> Empty s. + Proof. + destruct s; simpl; red; intuition. inv. discriminate. + Qed. + + Lemma max_elt_spec1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. + Proof. + induction s as [ | x s IH]. inversion 1. + destruct s as [ | y s]. simpl. inversion 1; subst; auto. + right; apply IH; auto. + Qed. + + Lemma max_elt_spec2 : + forall (s : t) (x y : elt) (Hs : Ok s), + max_elt s = Some x -> In y s -> ~ X.lt x y. + Proof. + induction s as [ | a s IH]. inversion 2. + destruct s as [ | b s]. inversion 2; subst. intros; inv; order. + intros. inv; auto. + assert (~X.lt x b) by (apply IH; auto). + assert (X.lt a b) by auto. + order. + Qed. + + Lemma max_elt_spec3 : forall s : t, max_elt s = None -> Empty s. + Proof. + induction s as [ | a s IH]. red; intuition; inv. + destruct s as [ | b s]. inversion 1. + intros; elim IH with b; auto. + Qed. + + Definition choose_spec1 : + forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_spec1. + + Definition choose_spec2 : + forall s : t, choose s = None -> Empty s := min_elt_spec3. + + Lemma choose_spec3: forall s s' x x', Ok s -> Ok s' -> + choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'. + Proof. + unfold choose; intros s s' x x' Hs Hs' Hx Hx' H. + assert (~X.lt x x'). + apply min_elt_spec2 with s'; auto. + rewrite <-H; auto using min_elt_spec1. + assert (~X.lt x' x). + apply min_elt_spec2 with s; auto. + rewrite H; auto using min_elt_spec1. + order. + Qed. + + Lemma fold_spec : + forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. + Proof. + reflexivity. + Qed. + + Lemma cardinal_spec : + forall (s : t) (Hs : Ok s), + cardinal s = length (elements s). + Proof. + auto. + Qed. + + Lemma filter_inf : + forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s), + Inf x s -> Inf x (filter f s). + Proof. + simple induction s; simpl. + intuition. + intros x l Hrec a f Hs Ha; inv. + case (f x); auto. + apply Hrec; auto. + apply Inf_lt with x; auto. + Qed. + + Global Instance filter_ok s f : forall `(Ok s), Ok (filter f s). + Proof. + repeat rewrite <- isok_iff; revert s f. + simple induction s; simpl. + auto. + intros x l Hrec f Hs; inv. + case (f x); auto. + constructors; auto. + apply filter_inf; auto. + Qed. + + Lemma filter_spec : + forall (s : t) (x : elt) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (In x (filter f s) <-> In x s /\ f x = true). + Proof. + induction s; simpl; intros. + split; intuition; inv. + destruct (f a) as [ ]_eqn:F; rewrite !InA_cons, ?IHs; intuition. + setoid_replace x with a; auto. + setoid_replace a with x in F; auto; congruence. + Qed. + + Lemma for_all_spec : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. + unfold For_all; induction s; simpl; intros. + split; intros; auto. inv. + destruct (f a) as [ ]_eqn:F. + rewrite IHs; auto. firstorder. inv; auto. + setoid_replace x with a; auto. + split; intros H'. discriminate. + rewrite H' in F; auto. + Qed. + + Lemma exists_spec : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. + unfold Exists; induction s; simpl; intros. + firstorder. discriminate. inv. + destruct (f a) as [ ]_eqn:F. + firstorder. + rewrite IHs; auto. + firstorder. + inv. + setoid_replace a with x in F; auto; congruence. + exists x; auto. + Qed. + + Lemma partition_inf1 : + forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s), + Inf x s -> Inf x (fst (partition f s)). + Proof. + intros s f x; repeat rewrite <- isok_iff; revert s f x. + simple induction s; simpl. + intuition. + intros x l Hrec f a Hs Ha; inv. + generalize (Hrec f a H). + case (f x); case (partition f l); simpl. + auto. + intros; apply H2; apply Inf_lt with x; auto. + Qed. + + Lemma partition_inf2 : + forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s), + Inf x s -> Inf x (snd (partition f s)). + Proof. + intros s f x; repeat rewrite <- isok_iff; revert s f x. + simple induction s; simpl. + intuition. + intros x l Hrec f a Hs Ha; inv. + generalize (Hrec f a H). + case (f x); case (partition f l); simpl. + intros; apply H2; apply Inf_lt with x; auto. + auto. + Qed. + + Global Instance partition_ok1 s f : forall `(Ok s), Ok (fst (partition f s)). + Proof. + repeat rewrite <- isok_iff; revert s f. + simple induction s; simpl. + auto. + intros x l Hrec f Hs; inv. + generalize (Hrec f H); generalize (@partition_inf1 l f x). + case (f x); case (partition f l); simpl; auto. + Qed. + + Global Instance partition_ok2 s f : forall `(Ok s), Ok (snd (partition f s)). + Proof. + repeat rewrite <- isok_iff; revert s f. + simple induction s; simpl. + auto. + intros x l Hrec f Hs; inv. + generalize (Hrec f H); generalize (@partition_inf2 l f x). + case (f x); case (partition f l); simpl; auto. + Qed. + + Lemma partition_spec1 : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> Equal (fst (partition f s)) (filter f s). + Proof. + simple induction s; simpl; auto; unfold Equal. + split; auto. + intros x l Hrec f Hf. + generalize (Hrec f Hf); clear Hrec. + destruct (partition f l) as [s1 s2]; simpl; intros. + case (f x); simpl; auto. + split; inversion_clear 1; auto. + constructor 2; rewrite <- H; auto. + constructor 2; rewrite H; auto. + Qed. + + Lemma partition_spec2 : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. + simple induction s; simpl; auto; unfold Equal. + split; auto. + intros x l Hrec f Hf. + generalize (Hrec f Hf); clear Hrec. + destruct (partition f l) as [s1 s2]; simpl; intros. + case (f x); simpl; auto. + split; inversion_clear 1; auto. + constructor 2; rewrite <- H; auto. + constructor 2; rewrite H; auto. + Qed. + + End ForNotations. + + Definition In := InA X.eq. + Instance In_compat : Proper (X.eq==>eq==> iff) In. + Proof. repeat red; intros; rewrite H, H0; auto. Qed. + + Module L := MakeListOrdering X. + Definition eq := L.eq. + Definition eq_equiv := L.eq_equiv. + Definition lt l1 l2 := + exists l1', exists l2', Ok l1' /\ Ok l2' /\ + eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'. + + Instance lt_strorder : StrictOrder lt. + Proof. + split. + intros s (s1 & s2 & B1 & B2 & E1 & E2 & L). + repeat rewrite <- isok_iff in *. + assert (eqlistA X.eq s1 s2). + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *. + transitivity s; auto. symmetry; auto. + rewrite H in L. + apply (StrictOrder_Irreflexive s2); auto. + intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12) + (s2'' & s3' & B2' & B3 & E2' & E3 & L23). + exists s1', s3'. + repeat rewrite <- isok_iff in *. + do 4 (split; trivial). + assert (eqlistA X.eq s2' s2''). + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *. + transitivity s2; auto. symmetry; auto. + transitivity s2'; auto. + rewrite H; auto. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + intros s1 s2 E12 s3 s4 E34. split. + intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. transitivity s1; auto. symmetry; auto. + split; auto. transitivity s3; auto. symmetry; auto. + intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. transitivity s2; auto. + split; auto. transitivity s4; auto. + Qed. + + Lemma compare_spec_aux : forall s s', CompSpec eq L.lt s s' (compare s s'). + Proof. + induction s as [|x s IH]; intros [|x' s']; simpl; intuition. + elim_compare x x'; auto. + Qed. + + Lemma compare_spec : forall s s', Ok s -> Ok s' -> + CompSpec eq lt s s' (compare s s'). + Proof. + intros s s' Hs Hs'. + destruct (compare_spec_aux s s'); constructor; auto. + exists s, s'; repeat split; auto using @ok. + exists s', s; repeat split; auto using @ok. + Qed. + +End MakeRaw. + +(** * Encapsulation + + Now, in order to really provide a functor implementing [S], we + need to encapsulate everything into a type of strictly ordered lists. *) + +Module Make (X: OrderedType) <: S with Module E := X. + Module Raw := MakeRaw X. + Include Raw2Sets X Raw. +End Make. + +(** For this specific implementation, eq coincides with Leibniz equality *) + +Require Eqdep_dec. + +Module Type OrderedTypeWithLeibniz. + Include OrderedType. + Parameter eq_leibniz : forall x y, eq x y -> x = y. +End OrderedTypeWithLeibniz. + +Module Type SWithLeibniz. + Declare Module E : OrderedTypeWithLeibniz. + Include SetsOn E. + Parameter eq_leibniz : forall x y, eq x y -> x = y. +End SWithLeibniz. + +Module MakeWithLeibniz (X: OrderedTypeWithLeibniz) <: SWithLeibniz with Module E := X. + Module E := X. + Module Raw := MakeRaw X. + Include Raw2SetsOn X Raw. + + Lemma eq_leibniz_list : forall xs ys, eqlistA X.eq xs ys -> xs = ys. + Proof. + induction xs as [|x xs]; intros [|y ys] H; inversion H; [ | ]. + reflexivity. + f_equal. + apply X.eq_leibniz; congruence. + apply IHxs; subst; assumption. + Qed. + + Lemma eq_leibniz : forall s s', eq s s' -> s = s'. + Proof. + intros [xs Hxs] [ys Hys] Heq. + change (equivlistA X.eq xs ys) in Heq. + assert (H : eqlistA X.eq xs ys). + rewrite <- Raw.isok_iff in Hxs, Hys. + apply SortA_equivlistA_eqlistA with X.lt; auto with *. + apply eq_leibniz_list in H. + subst ys. + f_equal. + apply Eqdep_dec.eq_proofs_unicity. + intros x y; destruct (bool_dec x y); tauto. + Qed. + +End MakeWithLeibniz. diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v new file mode 100644 index 00000000..e83ac27d --- /dev/null +++ b/theories/MSets/MSetPositive.v @@ -0,0 +1,1149 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* True + | xH, _ => False + | xO p, xO q => bits_lt p q + | xO _, _ => True + | xI p, xI q => bits_lt p q + | xI _, _ => False + end. + + Definition lt:=bits_lt. + + Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x. + Proof. + induction x; simpl; auto. + Qed. + + Lemma bits_lt_trans : + forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z. + Proof. + induction x; destruct y,z; simpl; eauto; intuition. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition. + Qed. + + Instance lt_strorder : StrictOrder lt. + Proof. + split; [ exact bits_lt_antirefl | exact bits_lt_trans ]. + Qed. + + Fixpoint compare x y := + match x, y with + | x~1, y~1 => compare x y + | x~1, _ => Gt + | x~0, y~0 => compare x y + | x~0, _ => Lt + | 1, y~1 => Lt + | 1, 1 => Eq + | 1, y~0 => Gt + end. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + unfold eq, lt. + induction x; destruct y; try constructor; simpl; auto. + destruct (IHx y); subst; auto. + destruct (IHx y); subst; auto. + Qed. + +End PositiveOrderedTypeBits. + +Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. + + Module E:=PositiveOrderedTypeBits. + + Definition elt := positive. + + Inductive tree := + | Leaf : tree + | Node : tree -> bool -> tree -> tree. + + Scheme tree_ind := Induction for tree Sort Prop. + + Definition t := tree. + + Definition empty := Leaf. + + Fixpoint is_empty (m : t) : bool := + match m with + | Leaf => true + | Node l b r => negb b &&& is_empty l &&& is_empty r + end. + + Fixpoint mem (i : positive) (m : t) : bool := + match m with + | Leaf => false + | Node l o r => + match i with + | 1 => o + | i~0 => mem i l + | i~1 => mem i r + end + end. + + Fixpoint add (i : positive) (m : t) : t := + match m with + | Leaf => + match i with + | 1 => Node Leaf true Leaf + | i~0 => Node (add i Leaf) false Leaf + | i~1 => Node Leaf false (add i Leaf) + end + | Node l o r => + match i with + | 1 => Node l true r + | i~0 => Node (add i l) o r + | i~1 => Node l o (add i r) + end + end. + + Definition singleton i := add i empty. + + (** helper function to avoid creating empty trees that are not leaves *) + + Definition node l (b: bool) r := + 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 := + match m with + | Leaf => Leaf + | Node l o r => + match i with + | 1 => node l false r + | i~0 => node (remove i l) o r + | i~1 => node l o (remove i r) + end + end. + + Fixpoint union (m m': t) := + match m with + | Leaf => m' + | Node l o r => + match m' with + | Leaf => m + | Node l' o' r' => Node (union l l') (o||o') (union r r') + end + end. + + Fixpoint inter (m m': t) := + match m with + | Leaf => Leaf + | Node l o r => + match m' with + | Leaf => Leaf + | Node l' o' r' => node (inter l l') (o&&o') (inter r r') + end + end. + + Fixpoint diff (m m': t) := + match m with + | Leaf => Leaf + | Node l o r => + match m' with + | Leaf => m + | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r') + end + end. + + Fixpoint equal (m m': t): bool := + match m with + | Leaf => is_empty m' + | Node l o r => + match m' with + | Leaf => is_empty m + | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r' + end + end. + + Fixpoint subset (m m': t): bool := + match m with + | Leaf => true + | Node l o r => + match m' with + | Leaf => is_empty m + | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r' + end + end. + + (** reverses [y] and concatenate it with [x] *) + + Fixpoint rev_append y x := + match y with + | 1 => x + | y~1 => rev_append y x~1 + | y~0 => rev_append y x~0 + end. + Infix "@" := rev_append (at level 60). + Definition rev x := x@1. + + Section Fold. + + Variables B : Type. + Variable f : positive -> B -> B. + + (** the additional argument, [i], records the current path, in + reverse order (this should be more efficient: we reverse this argument + only at present nodes only, rather than at each node of the tree). + we also use this convention in all functions below + *) + + Fixpoint xfold (m : t) (v : B) (i : positive) := + match m with + | Leaf => v + | Node l true r => + xfold r (f (rev i) (xfold l v i~0)) i~1 + | Node l false r => + xfold r (xfold l v i~0) i~1 + end. + Definition fold m i := xfold m i 1. + + End Fold. + + Section Quantifiers. + + Variable f : positive -> bool. + + Fixpoint xforall (m : t) (i : positive) := + match m with + | Leaf => true + | Node l o r => + (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0 + end. + Definition for_all m := xforall m 1. + + Fixpoint xexists (m : t) (i : positive) := + match m with + | Leaf => false + | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0 + end. + Definition exists_ m := xexists m 1. + + Fixpoint xfilter (m : t) (i : positive) := + 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) := + match m with + | Leaf => (Leaf,Leaf) + | Node l o r => + let (lt,lf) := xpartition l i~0 in + let (rt,rf) := xpartition r i~1 in + if o then + let fi := f (rev i) in + (node lt fi rt, node lf (negb fi) rf) + else + (node lt false rt, node lf false rf) + end. + Definition partition m := xpartition m 1. + + End Quantifiers. + + (** uses [a] to accumulate values rather than doing a lot of concatenations *) + + Fixpoint xelements (m : t) (i : positive) (a: list positive) := + match m with + | Leaf => a + | Node l false r => xelements l i~0 (xelements r i~1 a) + | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a) + end. + + Definition elements (m : t) := xelements m 1 nil. + + Fixpoint cardinal (m : t) : nat := + match m with + | Leaf => O + | Node l false r => (cardinal l + cardinal r)%nat + | Node l true r => S (cardinal l + cardinal r) + end. + + Definition omap (f: elt -> elt) x := + match x with + | None => None + | Some i => Some (f i) + end. + + (** would it be more efficient to use a path like in the above functions ? *) + + Fixpoint choose (m: t) := + match m with + | Leaf => None + | Node l o r => if o then Some 1 else + match choose l with + | None => omap xI (choose r) + | Some i => Some i~0 + end + end. + + Fixpoint min_elt (m: t) := + match m with + | Leaf => None + | Node l o r => + match min_elt l with + | None => if o then Some 1 else omap xI (min_elt r) + | Some i => Some i~0 + end + end. + + Fixpoint max_elt (m: t) := + match m with + | Leaf => None + | Node l o r => + match max_elt r with + | None => if o then Some 1 else omap xO (max_elt l) + | Some i => Some i~1 + end + end. + + (** lexicographic product, defined using a notation to keep things lazy *) + + Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end. + + Definition compare_bool a b := + match a,b with + | false, true => Lt + | true, false => Gt + | _,_ => Eq + end. + + Fixpoint compare (m m': t): comparison := + match m,m' with + | Leaf,_ => if is_empty m' then Eq else Lt + | _,Leaf => if is_empty m then Eq else Gt + | Node l o r,Node l' o' r' => + lex (compare_bool o o') (lex (compare l l') (compare r r')) + end. + + + Definition In i t := mem i t = true. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + + Definition eq := Equal. + Definition lt m m' := compare m m' = Lt. + + (** Specification of [In] *) + + Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In. + Proof. + intros s s' Hs x x' Hx. rewrite Hs, Hx; intuition. + Qed. + + (** Specification of [eq] *) + + Local Instance eq_equiv : Equivalence eq. + Proof. firstorder. Qed. + + (** Specification of [mem] *) + + Lemma mem_spec: forall s x, mem x s = true <-> In x s. + Proof. unfold In. intuition. Qed. + + (** Additional lemmas for mem *) + + Lemma mem_Leaf: forall x, mem x Leaf = false. + Proof. destruct x; trivial. Qed. + + (** Specification of [empty] *) + + Lemma empty_spec : Empty empty. + Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed. + + (** Specification of node *) + + Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r). + Proof. + intros x l o r. + case o; trivial. + destruct l; trivial. + destruct r; trivial. + symmetry. destruct x. + apply mem_Leaf. + apply mem_Leaf. + reflexivity. + Qed. + Local Opaque node. + + (** Specification of [is_empty] *) + + Lemma is_empty_spec: forall s, is_empty s = true <-> Empty s. + Proof. + unfold Empty, In. + induction s as [|l IHl o r IHr]; simpl. + setoid_rewrite mem_Leaf. firstorder. + rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear IHl IHr. + destruct o; simpl; split. + intuition discriminate. + intro H. elim (H 1). reflexivity. + intros H [a|a|]; apply H || intro; discriminate. + intro H. split. split. reflexivity. + intro a. apply (H a~0). + intro a. apply (H a~1). + Qed. + + (** Specification of [subset] *) + + Lemma subset_Leaf_s: forall s, Leaf [<=] s. + Proof. intros s i Hi. apply empty_spec in Hi. elim Hi. Qed. + + Lemma subset_spec: forall s s', subset s s' = true <-> s [<=] s'. + Proof. + induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl. + split; intros. apply subset_Leaf_s. reflexivity. + + split; intros. apply subset_Leaf_s. reflexivity. + + rewrite <- 2andb_lazy_alt, 2andb_true_iff, 2is_empty_spec. + destruct o; simpl. + split. + intuition discriminate. + intro H. elim (@empty_spec 1). apply H. reflexivity. + split; intro H. + destruct H as [[_ Hl] Hr]. + intros [i|i|] Hi. + elim (Hr i Hi). + elim (Hl i Hi). + discriminate. + split. split. reflexivity. + unfold Empty. intros a H1. apply (@empty_spec (a~0)), H. assumption. + unfold Empty. intros a H1. apply (@empty_spec (a~1)), H. assumption. + + rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear. + destruct o; simpl. + split; intro H. + destruct H as [[Ho' Hl] Hr]. rewrite Ho'. + intros i Hi. destruct i. + apply (Hr i). assumption. + apply (Hl i). assumption. + assumption. + split. split. + destruct o'; trivial. + specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity. + intros i Hi. apply (H i~0). apply Hi. + intros i Hi. apply (H i~1). apply Hi. + split; intros. + intros i Hi. destruct i; destruct H as [[H Hl] Hr]. + apply (Hr i). assumption. + apply (Hl i). assumption. + discriminate Hi. + split. split. reflexivity. + intros i Hi. apply (H i~0). apply Hi. + intros i Hi. apply (H i~1). apply Hi. + Qed. + + (** Specification of [equal] (via subset) *) + + Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s. + Proof. + induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial. + destruct o. reflexivity. rewrite andb_comm. reflexivity. + rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true. + rewrite 7andb_true_iff, eqb_true_iff. + rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst. + destruct o'; reflexivity. + destruct o'; reflexivity. + destruct o; auto. destruct o'; trivial. + Qed. + + Lemma equal_spec: forall s s', equal s s' = true <-> Equal s s'. + Proof. + intros. rewrite equal_subset. rewrite andb_true_iff. + rewrite 2subset_spec. unfold Equal, Subset. firstorder. + Qed. + + Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. + Proof. + unfold eq. + intros. case_eq (equal s s'); intro H. + left. apply equal_spec, H. + right. rewrite <- equal_spec. congruence. + Defined. + + (** (Specified) definition of [compare] *) + + Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' -> + lex u v = CompOpp (lex u' v'). + Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed. + + Lemma compare_bool_inv: forall b b', + compare_bool b b' = CompOpp (compare_bool b' b). + Proof. intros [|] [|]; reflexivity. Qed. + + Lemma compare_inv: forall s s', compare s s' = CompOpp (compare s' s). + Proof. + induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial. + unfold compare. case is_empty; reflexivity. + unfold compare. case is_empty; reflexivity. + simpl. rewrite compare_bool_inv. + case compare_bool; simpl; trivial; apply lex_Opp; auto. + Qed. + + Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq. + Proof. intros u v; destruct u; intuition discriminate. Qed. + + Lemma compare_bool_Eq: forall b1 b2, + compare_bool b1 b2 = Eq <-> eqb b1 b2 = true. + Proof. intros [|] [|]; intuition discriminate. Qed. + + Lemma compare_equal: forall s s', compare s s' = Eq <-> equal s s' = true. + Proof. + induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']. + simpl. tauto. + unfold compare, equal. case is_empty; intuition discriminate. + unfold compare, equal. case is_empty; intuition discriminate. + simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff. + rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr. + rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity. + Qed. + + + Lemma compare_gt: forall s s', compare s s' = Gt -> lt s' s. + Proof. + unfold lt. intros s s'. rewrite compare_inv. + case compare; trivial; intros; discriminate. + Qed. + + Lemma compare_eq: forall s s', compare s s' = Eq -> eq s s'. + Proof. + unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial. + Qed. + + Lemma compare_spec : forall s s' : t, CompSpec eq lt s s' (compare s s'). + Proof. + intros. case_eq (compare s s'); intro H; constructor. + apply compare_eq, H. + assumption. + apply compare_gt, H. + Qed. + + Section lt_spec. + + Inductive ct: comparison -> comparison -> comparison -> Prop := + | ct_xxx: forall x, ct x x x + | ct_xex: forall x, ct x Eq x + | ct_exx: forall x, ct Eq x x + | ct_glx: forall x, ct Gt Lt x + | ct_lgx: forall x, ct Lt Gt x. + + Lemma ct_cxe: forall x, ct (CompOpp x) x Eq. + Proof. destruct x; constructor. Qed. + + Lemma ct_xce: forall x, ct x (CompOpp x) Eq. + Proof. destruct x; constructor. Qed. + + Lemma ct_lxl: forall x, ct Lt x Lt. + Proof. destruct x; constructor. Qed. + + Lemma ct_gxg: forall x, ct Gt x Gt. + Proof. destruct x; constructor. Qed. + + Lemma ct_xll: forall x, ct x Lt Lt. + Proof. destruct x; constructor. Qed. + + Lemma ct_xgg: forall x, ct x Gt Gt. + Proof. destruct x; constructor. Qed. + + Local Hint Constructors ct: ct. + Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct. + Ltac ct := trivial with ct. + + Lemma ct_lex: forall u v w u' v' w', + ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w'). + Proof. + intros u v w u' v' w' H H'. + inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct. + Qed. + + Lemma ct_compare_bool: + forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c). + Proof. + intros [|] [|] [|]; constructor. + Qed. + + Lemma compare_x_Leaf: forall s, + compare s Leaf = if is_empty s then Eq else Gt. + Proof. + intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity. + Qed. + + Lemma compare_empty_x: forall a, is_empty a = true -> + forall b, compare a b = if is_empty b then Eq else Lt. + Proof. + induction a as [|l IHl o r IHr]; trivial. + destruct o. intro; discriminate. + simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff. + intros [Hl Hr]. + destruct b as [|l' [|] r']; simpl compare; trivial. + rewrite Hl, Hr. trivial. + rewrite (IHl Hl), (IHr Hr). simpl. + case (is_empty l'); case (is_empty r'); trivial. + Qed. + + Lemma compare_x_empty: forall a, is_empty a = true -> + forall b, compare b a = if is_empty b then Eq else Gt. + Proof. + setoid_rewrite <- compare_x_Leaf. + intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity. + Qed. + + Lemma ct_compare: + forall a b c, ct (compare a b) (compare b c) (compare a c). + Proof. + induction a as [|l IHl o r IHr]; intros s' s''. + destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct. + rewrite compare_inv. ct. + unfold compare at 1. case_eq (is_empty (Node l' o' r')); intro H'. + rewrite (compare_empty_x _ H'). ct. + unfold compare at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''. + rewrite (compare_x_empty _ H''), H'. ct. + ct. + + destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']. + ct. + unfold compare at 2. rewrite compare_x_Leaf. + case_eq (is_empty (Node l o r)); intro H. + rewrite (compare_empty_x _ H). ct. + case_eq (is_empty (Node l'' o'' r'')); intro H''. + rewrite (compare_x_empty _ H''), H. ct. + ct. + + rewrite 2 compare_x_Leaf. + case_eq (is_empty (Node l o r)); intro H. + rewrite compare_inv, (compare_x_empty _ H). ct. + case_eq (is_empty (Node l' o' r')); intro H'. + rewrite (compare_x_empty _ H'), H. ct. + ct. + + simpl compare. apply ct_lex. apply ct_compare_bool. + apply ct_lex; trivial. + Qed. + + End lt_spec. + + Instance lt_strorder : StrictOrder lt. + Proof. + unfold lt. split. + intros x H. + assert (compare x x = Eq). + apply compare_equal, equal_spec. reflexivity. + congruence. + intros a b c. assert (H := ct_compare a b c). + inversion_clear H; trivial; intros; discriminate. + Qed. + + Local Instance compare_compat_1 : Proper (eq==>Logic.eq==>Logic.eq) compare. + Proof. + intros x x' Hx y y' Hy. subst y'. + unfold eq in *. rewrite <- equal_spec, <- compare_equal in *. + assert (C:=ct_compare x x' y). rewrite Hx in C. inversion C; auto. + Qed. + + Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare. + Proof. + intros x x' Hx y y' Hy. rewrite Hx. + rewrite compare_inv, Hy, <- compare_inv. reflexivity. + Qed. + + Local Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + intros x x' Hx y y' Hy. unfold lt. rewrite Hx, Hy. intuition. + Qed. + + (** Specification of [add] *) + + Lemma add_spec: forall s x y, In y (add x s) <-> y=x \/ In y s. + Proof. + unfold In. intros s x y; revert x y s. + induction x; intros [y|y|] [|l o r]; simpl mem; + try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence. + Qed. + + (** Specification of [remove] *) + + Lemma remove_spec: forall s x y, In y (remove x s) <-> In y s /\ y<>x. + Proof. + unfold In. intros s x y; revert x y s. + induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node; + simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; + intuition congruence. + Qed. + + (** Specification of [singleton] *) + + Lemma singleton_spec : forall x y, In y (singleton x) <-> y=x. + Proof. + unfold singleton. intros x y. rewrite add_spec. intuition. + unfold In in *. rewrite mem_Leaf in *. discriminate. + Qed. + + (** Specification of [union] *) + + Lemma union_spec: forall s s' x, In x (union s s') <-> In x s \/ In x s'. + Proof. + unfold In. intros s s' x; revert x s s'. + induction x; destruct s; destruct s'; simpl union; simpl mem; + try (rewrite IHx; clear IHx); try intuition congruence. + apply orb_true_iff. + Qed. + + (** Specification of [inter] *) + + Lemma inter_spec: forall s s' x, In x (inter s s') <-> In x s /\ In x s'. + Proof. + unfold In. intros s s' x; revert x s s'. + induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node; + simpl mem; try (rewrite IHx; clear IHx); try intuition congruence. + apply andb_true_iff. + Qed. + + (** Specification of [diff] *) + + Lemma diff_spec: forall s s' x, In x (diff s s') <-> In x s /\ ~ In x s'. + Proof. + unfold In. intros s s' x; revert x s s'. + induction x; destruct s; destruct s' as [|l' o' r']; simpl diff; + rewrite ?mem_node; simpl mem; + try (rewrite IHx; clear IHx); try intuition congruence. + rewrite andb_true_iff. destruct o'; intuition discriminate. + Qed. + + (** Specification of [fold] *) + + Lemma fold_spec: forall s (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + Proof. + unfold fold, elements. intros s A i f. revert s i. + set (f' := fun a e => f e a). + assert (H: forall s i j acc, + fold_left f' acc (xfold f s i j) = + fold_left f' (xelements s j acc) i). + + induction s as [|l IHl o r IHr]; intros; trivial. + destruct o; simpl xelements; simpl xfold. + rewrite IHr, <- IHl. reflexivity. + rewrite IHr. apply IHl. + + intros. exact (H s i 1 nil). + Qed. + + (** Specification of [cardinal] *) + + Lemma cardinal_spec: forall s, cardinal s = length (elements s). + Proof. + unfold elements. + assert (H: forall s j acc, + (cardinal s + length acc)%nat = length (xelements s j acc)). + + induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b. + rewrite <- IHl. simpl. rewrite <- IHr. + rewrite <- plus_n_Sm, Plus.plus_assoc. reflexivity. + rewrite <- IHl, <- IHr. rewrite Plus.plus_assoc. reflexivity. + + intros. rewrite <- H. simpl. rewrite Plus.plus_comm. reflexivity. + Qed. + + (** Specification of [filter] *) + + Lemma xfilter_spec: forall f s x i, + In x (xfilter f s i) <-> In x s /\ f (i@x) = true. + Proof. + intro f. unfold In. + induction s as [|l IHl o r IHr]; intros x i; simpl xfilter. + rewrite mem_Leaf. intuition discriminate. + rewrite mem_node. destruct x; simpl. + rewrite IHr. reflexivity. + rewrite IHl. reflexivity. + rewrite <- andb_lazy_alt. apply andb_true_iff. + Qed. + + Lemma filter_spec: forall s x f, compat_bool E.eq f -> + (In x (filter f s) <-> In x s /\ f x = true). + Proof. intros. apply xfilter_spec. Qed. + + (** Specification of [for_all] *) + + Lemma xforall_spec: forall f s i, + xforall f s i = true <-> For_all (fun x => f (i@x) = true) s. + Proof. + unfold For_all, In. intro f. + induction s as [|l IHl o r IHr]; intros i; simpl. + setoid_rewrite mem_Leaf. intuition discriminate. + rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff. + rewrite IHl, IHr. clear IHl IHr. + split. + intros [[Hi Hr] Hl] x. destruct x; simpl; intro H. + apply Hr, H. + apply Hl, H. + rewrite H in Hi. assumption. + intro H; intuition. + specialize (H 1). destruct o. apply H. reflexivity. reflexivity. + apply H. assumption. + apply H. assumption. + Qed. + + Lemma for_all_spec: forall s f, compat_bool E.eq f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. intros. apply xforall_spec. Qed. + + (** Specification of [exists] *) + + Lemma xexists_spec: forall f s i, + xexists f s i = true <-> Exists (fun x => f (i@x) = true) s. + Proof. + unfold Exists, In. intro f. + induction s as [|l IHl o r IHr]; intros i; simpl. + setoid_rewrite mem_Leaf. firstorder. + rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff. + rewrite IHl, IHr. clear IHl IHr. + split. + intros [[Hi|[x Hr]]|[x Hl]]. + exists 1. exact Hi. + exists x~1. exact Hr. + exists x~0. exact Hl. + intros [[x|x|] H]; eauto. + Qed. + + Lemma exists_spec : forall s f, compat_bool E.eq f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. intros. apply xexists_spec. Qed. + + + (** Specification of [partition] *) + + Lemma partition_filter : forall s f, + partition f s = (filter f s, filter (fun x => negb (f x)) s). + Proof. + unfold partition, filter. intros s f. generalize 1 as j. + induction s as [|l IHl o r IHr]; intro j. + reflexivity. + destruct o; simpl; rewrite IHl, IHr; reflexivity. + Qed. + + Lemma partition_spec1 : forall s f, compat_bool 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 -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. intros. rewrite partition_filter. reflexivity. Qed. + + + (** Specification of [elements] *) + + Notation InL := (InA E.eq). + + Lemma xelements_spec: forall s j acc y, + InL y (xelements s j acc) + <-> + InL y acc \/ exists x, y=(j@x) /\ mem x s = true. + Proof. + induction s as [|l IHl o r IHr]; simpl. + intros. split; intro H. + left. assumption. + destruct H as [H|[x [Hx Hx']]]. assumption. elim (empty_spec Hx'). + + intros j acc y. case o. + rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split. + intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto. + right. exists x~1. auto. + right. exists x~0. auto. + intros [H|[x [-> H]]]. + eauto. + destruct x. + left. right. right. exists x; auto. + right. exists x; auto. + left. left. reflexivity. + + rewrite IHl, IHr. clear IHl IHr. split. + intros [[H|[x [-> H]]]|[x [-> H]]]. + eauto. + right. exists x~1. auto. + right. exists x~0. auto. + intros [H|[x [-> H]]]. + eauto. + destruct x. + left. right. exists x; auto. + right. exists x; auto. + discriminate. + Qed. + + Lemma elements_spec1: forall s x, InL x (elements s) <-> In x s. + Proof. + unfold elements. intros. rewrite xelements_spec. + split; [ intros [A|(y & B & C)] | intros IN ]. + inversion A. simpl in *. congruence. + right. exists x. auto. + Qed. + + Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y). + Proof. induction j; intros; simpl; auto. Qed. + + Lemma elements_spec2: forall s, sort E.lt (elements s). + Proof. + unfold elements. + assert (H: forall s j acc, + sort E.lt acc -> + (forall x y, In x s -> InL y acc -> E.lt (j@x) y) -> + sort E.lt (xelements s j acc)). + + induction s as [|l IHl o r IHr]; simpl; trivial. + intros j acc Hacc Hsacc. destruct o. + apply IHl. constructor. + apply IHr. apply Hacc. + intros x y Hx Hy. apply Hsacc; assumption. + case_eq (xelements r j~1 acc). constructor. + intros z q H. constructor. + assert (H': InL z (xelements r j~1 acc)). + rewrite H. constructor. reflexivity. + clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]]. + apply (Hsacc 1 z); trivial. reflexivity. + simpl. apply lt_rev_append. exact I. + intros x y Hx Hy. inversion_clear Hy. + rewrite H. simpl. apply lt_rev_append. exact I. + rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]]. + apply Hsacc; assumption. + simpl. apply lt_rev_append. exact I. + + apply IHl. apply IHr. apply Hacc. + intros x y Hx Hy. apply Hsacc; assumption. + intros x y Hx Hy. rewrite xelements_spec in Hy. + destruct Hy as [Hy|[z [-> Hy]]]. + apply Hsacc; assumption. + simpl. apply lt_rev_append. exact I. + + intros. apply H. constructor. + intros x y _ H'. inversion H'. + Qed. + + Lemma elements_spec2w: forall s, NoDupA E.eq (elements s). + Proof. + intro. apply SortA_NoDupA with E.lt; auto with *. + apply E.eq_equiv. + apply elements_spec2. + Qed. + + + (** Specification of [choose] *) + + Lemma choose_spec1: forall s x, choose s = Some x -> In x s. + Proof. + induction s as [| l IHl o r IHr]; simpl. + intros. discriminate. + destruct o. + intros x H. injection H; intros; subst. reflexivity. + revert IHl. case choose. + intros p Hp x H. injection H; intros; subst; clear H. apply Hp. + reflexivity. + intros _ x. revert IHr. case choose. + intros p Hp H. injection H; intros; subst; clear H. apply Hp. + reflexivity. + intros. discriminate. + Qed. + + Lemma choose_spec2: forall s, choose s = None -> Empty s. + Proof. + unfold Empty, In. intros s H. + induction s as [|l IHl o r IHr]. + intro. apply empty_spec. + destruct o. + discriminate. + simpl in H. destruct (choose l). + discriminate. + destruct (choose r). + discriminate. + intros [a|a|]. + apply IHr. reflexivity. + apply IHl. reflexivity. + discriminate. + Qed. + + Lemma choose_empty: forall s, is_empty s = true -> choose s = None. + Proof. + intros s Hs. case_eq (choose s); trivial. + intros p Hp. apply choose_spec1 in Hp. apply is_empty_spec in Hs. + elim (Hs _ Hp). + Qed. + + Lemma choose_spec3': forall s s', Equal s s' -> choose s = choose s'. + Proof. + setoid_rewrite <- equal_spec. + induction s as [|l IHl o r IHr]. + intros. symmetry. apply choose_empty. assumption. + + destruct s' as [|l' o' r']. + generalize (Node l o r) as s. simpl. intros. apply choose_empty. + rewrite equal_spec in H. symmetry in H. rewrite <- equal_spec in H. + assumption. + + simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff. + intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity. + Qed. + + Lemma choose_spec3: forall s s' x y, + choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. + Proof. intros s s' x y Hx Hy H. apply choose_spec3' in H. congruence. Qed. + + + (** Specification of [min_elt] *) + + Lemma min_elt_spec1: forall s x, min_elt s = Some x -> In x s. + Proof. + unfold In. + induction s as [| l IHl o r IHr]; simpl. + intros. discriminate. + intros x. destruct (min_elt l); intros. + injection H. intros <-. apply IHl. reflexivity. + destruct o; simpl. + injection H. intros <-. reflexivity. + destruct (min_elt r); simpl in *. + injection H. intros <-. apply IHr. reflexivity. + discriminate. + Qed. + + Lemma min_elt_spec3: forall s, min_elt s = None -> Empty s. + Proof. + unfold Empty, In. intros s H. + induction s as [|l IHl o r IHr]. + intro. apply empty_spec. + intros [a|a|]. + apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial. + case min_elt; intros; try discriminate. destruct o; discriminate. + apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial. + intro; discriminate. + revert H. clear. simpl. case min_elt; intros; try discriminate. + destruct o; discriminate. + Qed. + + Lemma min_elt_spec2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x. + Proof. + unfold In. + induction s as [|l IHl o r IHr]; intros x y H H'. + discriminate. + simpl in H. case_eq (min_elt l). + intros p Hp. rewrite Hp in H. injection H; intros <-. + destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial. + intro Hp; rewrite Hp in H. apply min_elt_spec3 in Hp. + destruct o. + injection H. intros <- Hl. clear H. + destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). + + destruct (min_elt r). + injection H. intros <-. clear H. + destruct y as [z|z|]. + apply (IHr p z); trivial. + elim (Hp _ H'). + discriminate. + discriminate. + Qed. + + + (** Specification of [max_elt] *) + + Lemma max_elt_spec1: forall s x, max_elt s = Some x -> In x s. + Proof. + unfold In. + induction s as [| l IHl o r IHr]; simpl. + intros. discriminate. + intros x. destruct (max_elt r); intros. + injection H. intros <-. apply IHr. reflexivity. + destruct o; simpl. + injection H. intros <-. reflexivity. + destruct (max_elt l); simpl in *. + injection H. intros <-. apply IHl. reflexivity. + discriminate. + Qed. + + Lemma max_elt_spec3: forall s, max_elt s = None -> Empty s. + Proof. + unfold Empty, In. intros s H. + induction s as [|l IHl o r IHr]. + intro. apply empty_spec. + intros [a|a|]. + apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial. + intro; discriminate. + apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial. + case max_elt; intros; try discriminate. destruct o; discriminate. + revert H. clear. simpl. case max_elt; intros; try discriminate. + destruct o; discriminate. + Qed. + + Lemma max_elt_spec2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y. + Proof. + unfold In. + induction s as [|l IHl o r IHr]; intros x y H H'. + discriminate. + simpl in H. case_eq (max_elt r). + intros p Hp. rewrite Hp in H. injection H; intros <-. + destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial. + intro Hp; rewrite Hp in H. apply max_elt_spec3 in Hp. + destruct o. + injection H. intros <- Hl. clear H. + destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). + + destruct (max_elt l). + injection H. intros <-. clear H. + destruct y as [z|z|]. + elim (Hp _ H'). + apply (IHl p z); trivial. + discriminate. + discriminate. + Qed. + +End PositiveSet. diff --git a/theories/MSets/MSetProperties.v b/theories/MSets/MSetProperties.v new file mode 100644 index 00000000..c0038a4f --- /dev/null +++ b/theories/MSets/MSetProperties.v @@ -0,0 +1,1176 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* E.eq x y \/ In y s. + + Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s. + Proof. + unfold Add. + split; intros. + red; intros. + rewrite H; clear H. + fsetdec. + fsetdec. + Qed. + + Ltac expAdd := repeat rewrite Add_Equal. + + Section BasicProperties. + + Variable s s' s'' s1 s2 s3 : t. + Variable x x' : elt. + + Lemma equal_refl : s[=]s. + Proof. fsetdec. Qed. + + Lemma equal_sym : s[=]s' -> s'[=]s. + Proof. fsetdec. Qed. + + Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. + Proof. fsetdec. Qed. + + Lemma subset_refl : s[<=]s. + Proof. fsetdec. Qed. + + Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. + Proof. fsetdec. Qed. + + Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. + Proof. fsetdec. Qed. + + Lemma subset_equal : s[=]s' -> s[<=]s'. + Proof. fsetdec. Qed. + + Lemma subset_empty : empty[<=]s. + Proof. fsetdec. Qed. + + Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2. + Proof. fsetdec. Qed. + + Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. + Proof. fsetdec. Qed. + + Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. + Proof. fsetdec. Qed. + + Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2. + Proof. fsetdec. Qed. + + Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. + Proof. fsetdec. Qed. + + Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. + Proof. intuition fsetdec. Qed. + + Lemma empty_is_empty_1 : Empty s -> s[=]empty. + Proof. fsetdec. Qed. + + Lemma empty_is_empty_2 : s[=]empty -> Empty s. + Proof. fsetdec. Qed. + + Lemma add_equal : In x s -> add x s [=] s. + Proof. fsetdec. Qed. + + Lemma add_add : add x (add x' s) [=] add x' (add x s). + Proof. fsetdec. Qed. + + Lemma remove_equal : ~ In x s -> remove x s [=] s. + Proof. fsetdec. Qed. + + Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'. + Proof. fsetdec. Qed. + + Lemma add_remove : In x s -> add x (remove x s) [=] s. + Proof. fsetdec. Qed. + + Lemma remove_add : ~In x s -> remove x (add x s) [=] s. + Proof. fsetdec. Qed. + + Lemma singleton_equal_add : singleton x [=] add x empty. + Proof. fsetdec. Qed. + + Lemma remove_singleton_empty : + In x s -> remove x s [=] empty -> singleton x [=] s. + Proof. fsetdec. Qed. + + Lemma union_sym : union s s' [=] union s' s. + Proof. fsetdec. Qed. + + Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'. + Proof. fsetdec. Qed. + + Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''. + Proof. fsetdec. Qed. + + Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. + Proof. fsetdec. Qed. + + Lemma union_assoc : union (union s s') s'' [=] union s (union s' s''). + Proof. fsetdec. Qed. + + Lemma add_union_singleton : add x s [=] union (singleton x) s. + Proof. fsetdec. Qed. + + Lemma union_add : union (add x s) s' [=] add x (union s s'). + Proof. fsetdec. Qed. + + Lemma union_remove_add_1 : + union (remove x s) (add x s') [=] union (add x s) (remove x s'). + Proof. fsetdec. Qed. + + Lemma union_remove_add_2 : In x s -> + union (remove x s) (add x s') [=] union s s'. + Proof. fsetdec. Qed. + + Lemma union_subset_1 : s [<=] union s s'. + Proof. fsetdec. Qed. + + Lemma union_subset_2 : s' [<=] union s s'. + Proof. fsetdec. Qed. + + Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''. + Proof. fsetdec. Qed. + + Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. + Proof. fsetdec. Qed. + + Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. + Proof. fsetdec. Qed. + + Lemma empty_union_1 : Empty s -> union s s' [=] s'. + Proof. fsetdec. Qed. + + Lemma empty_union_2 : Empty s -> union s' s [=] s'. + Proof. fsetdec. Qed. + + Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). + Proof. fsetdec. Qed. + + Lemma inter_sym : inter s s' [=] inter s' s. + Proof. fsetdec. Qed. + + Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s. + Proof. fsetdec. Qed. + + Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''. + Proof. fsetdec. Qed. + + Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. + Proof. fsetdec. Qed. + + Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s''). + Proof. fsetdec. Qed. + + Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s''). + Proof. fsetdec. Qed. + + Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s''). + Proof. fsetdec. Qed. + + Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s'). + Proof. fsetdec. Qed. + + Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'. + Proof. fsetdec. Qed. + + Lemma empty_inter_1 : Empty s -> Empty (inter s s'). + Proof. fsetdec. Qed. + + Lemma empty_inter_2 : Empty s' -> Empty (inter s s'). + Proof. fsetdec. Qed. + + Lemma inter_subset_1 : inter s s' [<=] s. + Proof. fsetdec. Qed. + + Lemma inter_subset_2 : inter s s' [<=] s'. + Proof. fsetdec. Qed. + + Lemma inter_subset_3 : + s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. + Proof. fsetdec. Qed. + + Lemma empty_diff_1 : Empty s -> Empty (diff s s'). + Proof. fsetdec. Qed. + + Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. + Proof. fsetdec. Qed. + + Lemma diff_subset : diff s s' [<=] s. + Proof. fsetdec. Qed. + + Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty. + Proof. fsetdec. Qed. + + Lemma remove_diff_singleton : + remove x s [=] diff s (singleton x). + Proof. fsetdec. Qed. + + Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. + Proof. fsetdec. Qed. + + Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. + Proof. fsetdec. Qed. + + Lemma Add_add : Add x s (add x s). + Proof. expAdd; fsetdec. Qed. + + Lemma Add_remove : In x s -> Add x (remove x s) s. + Proof. expAdd; fsetdec. Qed. + + Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). + Proof. expAdd; fsetdec. Qed. + + Lemma inter_Add : + In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). + Proof. expAdd; fsetdec. Qed. + + Lemma union_Equal : + In x s'' -> Add x s s' -> union s s'' [=] union s' s''. + Proof. expAdd; fsetdec. Qed. + + Lemma inter_Add_2 : + ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. + Proof. expAdd; fsetdec. Qed. + + End BasicProperties. + + Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. + Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym + subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 + subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal + remove_equal singleton_equal_add union_subset_equal union_equal_1 + union_equal_2 union_assoc add_union_singleton union_add union_subset_1 + union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2 + inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2 + empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 + empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union + inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal + remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove + Equal_remove add_add : set. + + (** * Properties of elements *) + + Lemma elements_Empty : forall s, Empty s <-> elements s = nil. + Proof. + intros. + unfold Empty. + split; intros. + assert (forall a, ~ List.In a (elements s)). + red; intros. + apply (H a). + rewrite elements_iff. + rewrite InA_alt; exists a; auto with relations. + destruct (elements s); auto. + elim (H0 e); simpl; auto. + red; intros. + rewrite elements_iff in H0. + rewrite InA_alt in H0; destruct H0. + rewrite H in H0; destruct H0 as (_,H0); inversion H0. + Qed. + + Lemma elements_empty : elements empty = nil. + Proof. + rewrite <-elements_Empty; auto with set. + Qed. + + (** * Conversions between lists and sets *) + + Definition of_list (l : list elt) := List.fold_right add empty l. + + Definition to_list := elements. + + Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l. + Proof. + induction l; simpl; intro x. + rewrite empty_iff, InA_nil. intuition. + rewrite add_iff, InA_cons, IHl. intuition. + Qed. + + Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l. + Proof. + unfold to_list; red; intros. + rewrite <- elements_iff; apply of_list_1. + Qed. + + Lemma of_list_3 : forall s, of_list (to_list s) [=] s. + Proof. + unfold to_list; red; intros. + rewrite of_list_1; symmetry; apply elements_iff. + Qed. + + (** * Fold *) + + Section Fold. + + Notation NoDup := (NoDupA E.eq). + Notation InA := (InA E.eq). + + (** ** Induction principles for fold (contributed by S. Lescuyer) *) + + (** In the following lemma, the step hypothesis is deliberately restricted + to the precise set s we are considering. *) + + Theorem fold_rec : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), + (forall s', Empty s' -> P s' i) -> + (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' -> + P s' a -> P s'' (f x a)) -> + P s (fold f s i). + Proof. + intros A P f i s Pempty Pstep. + rewrite fold_1; unfold flip; rewrite <- fold_left_rev_right. + set (l:=rev (elements s)). + assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' -> + P s' a -> P s'' (f x a)). + intros; eapply Pstep; eauto. + rewrite elements_iff, <- InA_rev; auto with *. + assert (Hdup : NoDup l) by + (unfold l; eauto using elements_3w, NoDupA_rev with *). + assert (Hsame : forall x, In x s <-> InA x l) by + (unfold l; intros; rewrite elements_iff, InA_rev; intuition). + clear Pstep; clearbody l; revert s Hsame; induction l. + (* empty *) + intros s Hsame; simpl. + apply Pempty. intro x. rewrite Hsame, InA_nil; intuition. + (* step *) + intros s Hsame; simpl. + apply Pstep' with (of_list l); auto with relations. + inversion_clear Hdup; rewrite of_list_1; auto. + red. intros. rewrite Hsame, of_list_1, InA_cons; intuition. + apply IHl. + intros; eapply Pstep'; eauto. + inversion_clear Hdup; auto. + exact (of_list_1 l). + Qed. + + (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this + case, [P] must be compatible with equality of sets *) + + Theorem fold_rec_bis : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), + (forall s s' a, s[=]s' -> P s a -> P s' a) -> + (P empty i) -> + (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) -> + P s (fold f s i). + Proof. + intros A P f i s Pmorphism Pempty Pstep. + apply fold_rec; intros. + apply Pmorphism with empty; auto with set. + rewrite Add_Equal in H1; auto with set. + apply Pmorphism with (add x s'); auto with set. + Qed. + + Lemma fold_rec_nodep : + forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t), + P i -> (forall x a, In x s -> P a -> P (f x a)) -> + P (fold f s i). + Proof. + intros; apply fold_rec_bis with (P:=fun _ => P); auto. + Qed. + + (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : + the step hypothesis must here be applicable to any [x]. + At the same time, it looks more like an induction principle, + and hence can be easier to use. *) + + Lemma fold_rec_weak : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A), + (forall s s' a, s[=]s' -> P s a -> P s' a) -> + P empty i -> + (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) -> + forall s, P s (fold f s i). + Proof. + intros; apply fold_rec_bis; auto. + Qed. + + Lemma fold_rel : + forall (A B:Type)(R : A -> B -> Type) + (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t), + R i j -> + (forall x a b, In x s -> R a b -> R (f x a) (g x b)) -> + R (fold f s i) (fold g s j). + Proof. + intros A B R f g i j s Rempty Rstep. + do 2 (rewrite fold_1; unfold flip; rewrite <- fold_left_rev_right). + set (l:=rev (elements s)). + assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by + (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with *). + clearbody l; clear Rstep s. + induction l; simpl; auto with relations. + Qed. + + (** From the induction principle on [fold], we can deduce some general + induction principles on sets. *) + + Lemma set_induction : + forall P : t -> Type, + (forall s, Empty s -> P s) -> + (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> + forall s, P s. + Proof. + intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. + Qed. + + Lemma set_induction_bis : + forall P : t -> Type, + (forall s s', s [=] s' -> P s -> P s') -> + P empty -> + (forall x s, ~In x s -> P s -> P (add x s)) -> + forall s, P s. + Proof. + intros. + apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. + Qed. + + (** [fold] can be used to reconstruct the same initial set. *) + + Lemma fold_identity : forall s, fold add s empty [=] s. + Proof. + intros. + apply fold_rec with (P:=fun s acc => acc[=]s); auto with set. + intros. rewrite H2; rewrite Add_Equal in H1; auto with set. + Qed. + + (** ** Alternative (weaker) specifications for [fold] *) + + (** When [MSets] was first designed, the order in which Ocaml's [Set.fold] + takes the set elements was unspecified. This specification reflects + this fact: + *) + + Lemma fold_0 : + forall s (A : Type) (i : A) (f : elt -> A -> A), + exists l : list elt, + NoDup l /\ + (forall x : elt, In x s <-> InA x l) /\ + fold f s i = fold_right f i l. + Proof. + intros; exists (rev (elements s)); split. + apply NoDupA_rev; auto with *. + split; intros. + rewrite elements_iff; do 2 rewrite InA_alt. + split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. + rewrite fold_left_rev_right. + apply fold_1. + Qed. + + (** An alternate (and previous) specification for [fold] was based on + the recursive structure of a set. It is now lemmas [fold_1] and + [fold_2]. *) + + Lemma fold_1 : + forall s (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Empty s -> eqA (fold f s i) i. + Proof. + unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). + rewrite H3; clear H3. + generalize H H2; clear H H2; case l; simpl; intros. + reflexivity. + elim (H e). + elim (H2 e); intuition. + Qed. + + Lemma fold_2 : + forall s s' x (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Proper (E.eq==>eqA==>eqA) f -> + transpose eqA f -> + ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). + Proof. + intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); + destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). + rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. + apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto. + eauto with *. + rewrite <- Hl1; auto. + intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; + rewrite (H2 a); intuition. + Qed. + + (** In fact, [fold] on empty sets is more than equivalent to + the initial element, it is Leibniz-equal to it. *) + + Lemma fold_1b : + forall s (A : Type)(i : A) (f : elt -> A -> A), + Empty s -> (fold f s i) = i. + Proof. + intros. + rewrite FM.fold_1. + rewrite elements_Empty in H; rewrite H; simpl; auto. + Qed. + + Section Fold_More. + + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f). + + Lemma fold_commutes : forall i s x, + eqA (fold f s (f x i)) (f x (fold f s i)). + Proof. + intros. + apply fold_rel with (R:=fun u v => eqA u (f x v)); intros. + reflexivity. + transitivity (f x0 (f x b)); auto. + apply Comp; auto with relations. + Qed. + + (** ** Fold is a morphism *) + + Lemma fold_init : forall i i' s, eqA i i' -> + eqA (fold f s i) (fold f s i'). + Proof. + intros. apply fold_rel with (R:=eqA); auto. + intros; apply Comp; auto with relations. + Qed. + + Lemma fold_equal : + forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). + Proof. + intros i s; pattern s; apply set_induction; clear s; intros. + transitivity i. + apply fold_1; auto. + symmetry; apply fold_1; auto. + rewrite <- H0; auto. + transitivity (f x (fold f s i)). + apply fold_2 with (eqA := eqA); auto. + symmetry; apply fold_2 with (eqA := eqA); auto. + unfold Add in *; intros. + rewrite <- H2; auto. + Qed. + + (** ** Fold and other set operators *) + + Lemma fold_empty : forall i, fold f empty i = i. + Proof. + intros i; apply fold_1b; auto with set. + Qed. + + Lemma fold_add : forall i s x, ~In x s -> + eqA (fold f (add x s) i) (f x (fold f s i)). + Proof. + intros; apply fold_2 with (eqA := eqA); auto with set. + Qed. + + Lemma add_fold : forall i s x, In x s -> + eqA (fold f (add x s) i) (fold f s i). + Proof. + intros; apply fold_equal; auto with set. + Qed. + + Lemma remove_fold_1: forall i s x, In x s -> + eqA (f x (fold f (remove x s) i)) (fold f s i). + Proof. + intros. + symmetry. + apply fold_2 with (eqA:=eqA); auto with set relations. + Qed. + + Lemma remove_fold_2: forall i s x, ~In x s -> + eqA (fold f (remove x s) i) (fold f s i). + Proof. + intros. + apply fold_equal; auto with set. + Qed. + + Lemma fold_union_inter : forall i s s', + eqA (fold f (union s s') (fold f (inter s s') i)) + (fold f s (fold f s' i)). + Proof. + intros; pattern s; apply set_induction; clear s; intros. + transitivity (fold f s' (fold f (inter s s') i)). + apply fold_equal; auto with set. + transitivity (fold f s' i). + apply fold_init; auto. + apply fold_1; auto with set. + symmetry; apply fold_1; auto. + rename s'0 into s''. + destruct (In_dec x s'). + (* In x s' *) + transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. + apply fold_init; auto. + apply fold_2 with (eqA:=eqA); auto with set. + rewrite inter_iff; intuition. + transitivity (f x (fold f s (fold f s' i))). + transitivity (fold f (union s s') (f x (fold f (inter s s') i))). + apply fold_equal; auto. + apply equal_sym; apply union_Equal with x; auto with set. + transitivity (f x (fold f (union s s') (fold f (inter s s') i))). + apply fold_commutes; auto. + apply Comp; auto with relations. + symmetry; apply fold_2 with (eqA:=eqA); auto. + (* ~(In x s') *) + transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))). + apply fold_2 with (eqA:=eqA); auto with set. + transitivity (f x (fold f (union s s') (fold f (inter s s') i))). + apply Comp;auto with relations. + apply fold_init;auto. + apply fold_equal;auto. + apply equal_sym; apply inter_Add_2 with x; auto with set. + transitivity (f x (fold f s (fold f s' i))). + apply Comp; auto with relations. + symmetry; apply fold_2 with (eqA:=eqA); auto. + Qed. + + Lemma fold_diff_inter : forall i s s', + eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). + Proof. + intros. + transitivity (fold f (union (diff s s') (inter s s')) + (fold f (inter (diff s s') (inter s s')) i)). + symmetry; apply fold_union_inter; auto. + transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)). + apply fold_equal; auto with set. + apply fold_init; auto. + apply fold_1; auto with set. + Qed. + + Lemma fold_union: forall i s s', + (forall x, ~(In x s/\In x s')) -> + eqA (fold f (union s s') i) (fold f s (fold f s' i)). + Proof. + intros. + transitivity (fold f (union s s') (fold f (inter s s') i)). + apply fold_init; auto. + symmetry; apply fold_1; auto with set. + unfold Empty; intro a; generalize (H a); set_iff; tauto. + apply fold_union_inter; auto. + Qed. + + End Fold_More. + + Lemma fold_plus : + forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. + Proof. + intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto. + Qed. + + End Fold. + + (** * Cardinal *) + + (** ** Characterization of cardinal in terms of fold *) + + Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. + Proof. + intros; rewrite cardinal_1; rewrite FM.fold_1. + symmetry; apply fold_left_length; auto. + Qed. + + (** ** Old specifications for [cardinal]. *) + + Lemma cardinal_0 : + forall s, exists l : list elt, + NoDupA E.eq l /\ + (forall x : elt, In x s <-> InA E.eq x l) /\ + cardinal s = length l. + Proof. + intros; exists (elements s); intuition; apply cardinal_1. + Qed. + + Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. + Proof. + intros; rewrite cardinal_fold; apply fold_1; auto with *. + Qed. + + Lemma cardinal_2 : + forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s). + Proof. + intros; do 2 rewrite cardinal_fold. + change S with ((fun _ => S) x). + apply fold_2; auto. + split; congruence. + congruence. + Qed. + + (** ** Cardinal and (non-)emptiness *) + + Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. + Proof. + intros. + rewrite elements_Empty, FM.cardinal_1. + destruct (elements s); intuition; discriminate. + Qed. + + Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. + Proof. + intros; rewrite cardinal_Empty; auto. + Qed. + Hint Resolve cardinal_inv_1. + + Lemma cardinal_inv_2 : + forall s n, cardinal s = S n -> { x : elt | In x s }. + Proof. + intros; rewrite FM.cardinal_1 in H. + generalize (elements_2 (s:=s)). + destruct (elements s); try discriminate. + exists e; auto with relations. + Qed. + + Lemma cardinal_inv_2b : + forall s, cardinal s <> 0 -> { x : elt | In x s }. + Proof. + intro; generalize (@cardinal_inv_2 s); destruct cardinal; + [intuition|eauto]. + Qed. + + (** ** Cardinal is a morphism *) + + Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. + Proof. + symmetry. + remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. + induction n; intros. + apply cardinal_1; rewrite <- H; auto. + destruct (cardinal_inv_2 Heqn) as (x,H2). + revert Heqn. + rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); + auto with set relations. + rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); + eauto with set relations. + Qed. + + Instance cardinal_m : Proper (Equal==>Logic.eq) cardinal. + Proof. + exact Equal_cardinal. + Qed. + + Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. + + (** ** Cardinal and set operators *) + + Lemma empty_cardinal : cardinal empty = 0. + Proof. + rewrite cardinal_fold; apply fold_1; auto with *. + Qed. + + Hint Immediate empty_cardinal cardinal_1 : set. + + Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. + Proof. + intros. + rewrite (singleton_equal_add x). + replace 0 with (cardinal empty); auto with set. + apply cardinal_2 with x; auto with set. + Qed. + + Hint Resolve singleton_cardinal: set. + + Lemma diff_inter_cardinal : + forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s . + Proof. + intros; do 3 rewrite cardinal_fold. + rewrite <- fold_plus. + apply fold_diff_inter with (eqA:=@Logic.eq nat); auto with *. + congruence. + Qed. + + Lemma union_cardinal: + forall s s', (forall x, ~(In x s/\In x s')) -> + cardinal (union s s')=cardinal s+cardinal s'. + Proof. + intros; do 3 rewrite cardinal_fold. + rewrite <- fold_plus. + apply fold_union; auto. + split; congruence. + congruence. + Qed. + + Lemma subset_cardinal : + forall s s', s[<=]s' -> cardinal s <= cardinal s' . + Proof. + intros. + rewrite <- (diff_inter_cardinal s' s). + rewrite (inter_sym s' s). + rewrite (inter_subset_equal H); auto with arith. + Qed. + + Lemma subset_cardinal_lt : + forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'. + Proof. + intros. + rewrite <- (diff_inter_cardinal s' s). + rewrite (inter_sym s' s). + rewrite (inter_subset_equal H). + generalize (@cardinal_inv_1 (diff s' s)). + destruct (cardinal (diff s' s)). + intro H2; destruct (H2 (refl_equal _) x). + set_iff; auto. + intros _. + change (0 + cardinal s < S n + cardinal s). + apply Plus.plus_lt_le_compat; auto with arith. + Qed. + + Theorem union_inter_cardinal : + forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . + Proof. + intros. + do 4 rewrite cardinal_fold. + do 2 rewrite <- fold_plus. + apply fold_union_inter with (eqA:=@Logic.eq nat); auto with *. + congruence. + Qed. + + Lemma union_cardinal_inter : + forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s'). + Proof. + intros. + rewrite <- union_inter_cardinal. + rewrite Plus.plus_comm. + auto with arith. + Qed. + + Lemma union_cardinal_le : + forall s s', cardinal (union s s') <= cardinal s + cardinal s'. + Proof. + intros; generalize (union_inter_cardinal s s'). + intros; rewrite <- H; auto with arith. + Qed. + + Lemma add_cardinal_1 : + forall s x, In x s -> cardinal (add x s) = cardinal s. + Proof. + auto with set. + Qed. + + Lemma add_cardinal_2 : + forall s x, ~In x s -> cardinal (add x s) = S (cardinal s). + Proof. + intros. + do 2 rewrite cardinal_fold. + change S with ((fun _ => S) x); + apply fold_add with (eqA:=@Logic.eq nat); auto with *. + congruence. + Qed. + + Lemma remove_cardinal_1 : + forall s x, In x s -> S (cardinal (remove x s)) = cardinal s. + Proof. + intros. + do 2 rewrite cardinal_fold. + change S with ((fun _ =>S) x). + apply remove_fold_1 with (eqA:=@Logic.eq nat); auto with *. + congruence. + Qed. + + Lemma remove_cardinal_2 : + forall s x, ~In x s -> cardinal (remove x s) = cardinal s. + Proof. + auto with set. + Qed. + + Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2. + +End WPropertiesOn. + +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [Properties] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WProperties]. *) + +Module WProperties (M:WSets) := WPropertiesOn M.E M. +Module Properties := WProperties. + + +(** Now comes some properties specific to the element ordering, + invalid for Weak Sets. *) + +Module OrdProperties (M:Sets). + Module Import ME:=OrderedTypeFacts(M.E). + Module Import ML:=OrderedTypeLists(M.E). + Module Import P := Properties M. + Import FM. + Import M.E. + Import M. + + Hint Resolve elements_spec2. + Hint Immediate + min_elt_spec1 min_elt_spec2 min_elt_spec3 + max_elt_spec1 max_elt_spec2 max_elt_spec3 : set. + + (** First, a specialized version of SortA_equivlistA_eqlistA: *) + Lemma sort_equivlistA_eqlistA : forall l l' : list elt, + sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'. + Proof. + apply SortA_equivlistA_eqlistA; eauto with *. + Qed. + + Definition gtb x y := match E.compare x y with Gt => true | _ => false end. + Definition leb x := fun y => negb (gtb x y). + + Definition elements_lt x s := List.filter (gtb x) (elements s). + Definition elements_ge x s := List.filter (leb x) (elements s). + + Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x. + Proof. + intros; rewrite <- compare_gt_iff. unfold gtb. + destruct E.compare; intuition; try discriminate. + Qed. + + Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x. + Proof. + intros; rewrite <- compare_gt_iff. unfold leb, gtb. + destruct E.compare; intuition; try discriminate. + Qed. + + Instance gtb_compat x : Proper (E.eq==>Logic.eq) (gtb x). + Proof. + intros a b H. unfold gtb. rewrite H; auto. + Qed. + + Instance leb_compat x : Proper (E.eq==>Logic.eq) (leb x). + Proof. + intros a b H; unfold leb. rewrite H; auto. + Qed. + Hint Resolve gtb_compat leb_compat. + + Lemma elements_split : forall x s, + elements s = elements_lt x s ++ elements_ge x s. + Proof. + unfold elements_lt, elements_ge, leb; intros. + eapply (@filter_split _ E.eq); eauto with *. + intros. + rewrite gtb_1 in H. + assert (~E.lt y x). + unfold gtb in *; elim_compare x y; intuition; + try discriminate; order. + order. + Qed. + + Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> + eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). + Proof. + intros; unfold elements_ge, elements_lt. + apply sort_equivlistA_eqlistA; auto with set. + apply (@SortA_app _ E.eq); auto with *. + apply (@filter_sort _ E.eq); auto with *; eauto with *. + constructor; auto. + apply (@filter_sort _ E.eq); auto with *; eauto with *. + rewrite Inf_alt by (apply (@filter_sort _ E.eq); eauto with *). + intros. + rewrite filter_InA in H1; auto with *; destruct H1. + rewrite leb_1 in H2. + rewrite <- elements_iff in H1. + assert (~E.eq x y). + contradict H; rewrite H; auto. + order. + intros. + rewrite filter_InA in H1; auto with *; destruct H1. + rewrite gtb_1 in H3. + inversion_clear H2. + order. + rewrite filter_InA in H4; auto with *; destruct H4. + rewrite leb_1 in H4. + order. + red; intros a. + rewrite InA_app_iff, InA_cons, !filter_InA, <-!elements_iff, + leb_1, gtb_1, (H0 a) by (auto with *). + intuition. + elim_compare a x; intuition. + right; right; split; auto. + order. + Qed. + + Definition Above x s := forall y, In y s -> E.lt y x. + Definition Below x s := forall y, In y s -> E.lt x y. + + Lemma elements_Add_Above : forall s s' x, + Above x s -> Add x s s' -> + eqlistA E.eq (elements s') (elements s ++ x::nil). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with set. + apply (@SortA_app _ E.eq); auto with *. + intros. + invlist InA. + rewrite <- elements_iff in H1. + setoid_replace y with x; auto. + red; intros a. + rewrite InA_app_iff, InA_cons, InA_nil, <-!elements_iff, (H0 a) + by (auto with *). + intuition. + Qed. + + Lemma elements_Add_Below : forall s s' x, + Below x s -> Add x s s' -> + eqlistA E.eq (elements s') (x::elements s). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with set. + change (sort E.lt ((x::nil) ++ elements s)). + apply (@SortA_app _ E.eq); auto with *. + intros. + invlist InA. + rewrite <- elements_iff in H2. + setoid_replace x0 with x; auto. + red; intros a. + rewrite InA_cons, <- !elements_iff, (H0 a); intuition. + Qed. + + (** Two other induction principles on sets: we can be more restrictive + on the element we add at each step. *) + + Lemma set_induction_max : + forall P : t -> Type, + (forall s : t, Empty s -> P s) -> + (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') -> + forall s : t, P s. + Proof. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + case_eq (max_elt s); intros. + apply X0 with (remove e s) e; auto with set. + apply IHn. + assert (S n = S (cardinal (remove e s))). + rewrite Heqn; apply cardinal_2 with e; auto with set relations. + inversion H0; auto. + red; intros. + rewrite remove_iff in H0; destruct H0. + generalize (@max_elt_spec2 s e y H H0); order. + + assert (H0:=max_elt_spec3 H). + rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn. + Qed. + + Lemma set_induction_min : + forall P : t -> Type, + (forall s : t, Empty s -> P s) -> + (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') -> + forall s : t, P s. + Proof. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + case_eq (min_elt s); intros. + apply X0 with (remove e s) e; auto with set. + apply IHn. + assert (S n = S (cardinal (remove e s))). + rewrite Heqn; apply cardinal_2 with e; auto with set relations. + inversion H0; auto. + red; intros. + rewrite remove_iff in H0; destruct H0. + generalize (@min_elt_spec2 s e y H H0); order. + + assert (H0:=min_elt_spec3 H). + rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn. + Qed. + + (** More properties of [fold] : behavior with respect to Above/Below *) + + Lemma fold_3 : + forall s s' x (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Proper (E.eq==>eqA==>eqA) f -> + Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). + Proof. + intros. + rewrite !FM.fold_1. + unfold flip; rewrite <-!fold_left_rev_right. + change (f x (fold_right f i (rev (elements s)))) with + (fold_right f i (rev (x::nil)++rev (elements s))). + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto with *. + rewrite <- distr_rev. + apply eqlistA_rev. + apply elements_Add_Above; auto. + Qed. + + Lemma fold_4 : + forall s s' x (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Proper (E.eq==>eqA==>eqA) f -> + Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). + Proof. + intros. + rewrite !FM.fold_1. + change (eqA (fold_left (flip f) (elements s') i) + (fold_left (flip f) (x::elements s) i)). + unfold flip; rewrite <-!fold_left_rev_right. + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. + apply eqlistA_rev. + apply elements_Add_Below; auto. + Qed. + + (** The following results have already been proved earlier, + but we can now prove them with one hypothesis less: + no need for [(transpose eqA f)]. *) + + Section FoldOpt. + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f). + + Lemma fold_equal : + forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). + Proof. + intros. + rewrite !FM.fold_1. + unfold flip; rewrite <- !fold_left_rev_right. + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. + apply eqlistA_rev. + apply sort_equivlistA_eqlistA; auto with set. + red; intro a; do 2 rewrite <- elements_iff; auto. + Qed. + + Lemma add_fold : forall i s x, In x s -> + eqA (fold f (add x s) i) (fold f s i). + Proof. + intros; apply fold_equal; auto with set. + Qed. + + Lemma remove_fold_2: forall i s x, ~In x s -> + eqA (fold f (remove x s) i) (fold f s i). + Proof. + intros. + apply fold_equal; auto with set. + Qed. + + End FoldOpt. + + (** An alternative version of [choose_3] *) + + Lemma choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with + | Some x, Some x' => E.eq x x' + | None, None => True + | _, _ => False + end. + Proof. + intros s s' H; + generalize (@choose_spec1 s)(@choose_spec2 s) + (@choose_spec1 s')(@choose_spec2 s')(@choose_spec3 s s'); + destruct (choose s); destruct (choose s'); simpl; intuition. + apply H5 with e; rewrite <-H; auto. + apply H5 with e; rewrite H; auto. + Qed. + +End OrdProperties. diff --git a/theories/MSets/MSetToFiniteSet.v b/theories/MSets/MSetToFiniteSet.v new file mode 100644 index 00000000..f0b964cf --- /dev/null +++ b/theories/MSets/MSetToFiniteSet.v @@ -0,0 +1,158 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Ensemble M.elt := + fun s x => M.In x s. + + Notation " !! " := mkEns. + + Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x. + Proof. + unfold In; compute; auto with extcore. + Qed. + + Lemma Subset_Included : forall s s', s[<=]s' <-> Included _ (!!s) (!!s'). + Proof. + unfold Subset, Included, In, mkEns; intuition. + Qed. + + Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity). + + Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'. + Proof. + intros. + rewrite double_inclusion. + unfold Subset, Included, Same_set, In, mkEns; intuition. + Qed. + + Lemma empty_Empty_Set : !!M.empty === Empty_set _. + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1. + Qed. + + Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _. + Proof. + unfold Same_set, Included, mkEns, In. + split; intros. + destruct(H x H0). + inversion H0. + Qed. + + Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x . + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; try constructor; auto. + Qed. + + Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s'). + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto. + Qed. + + Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s'). + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; try constructor; auto. + Qed. + + Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x. + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; auto with sets. + inversion H0. + constructor 2; constructor. + constructor 1; auto. + Qed. + + Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x. + Proof. + unfold Same_set, Included, mkEns, In. + split; intros. + red in H; rewrite H in H0. + destruct H0. + inversion H0. + constructor 2; constructor. + constructor 1; auto. + red in H; rewrite H. + inversion H0; auto. + inversion H1; auto. + Qed. + + Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x. + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; auto with sets. + split; auto. + contradict H1. + inversion H1; auto. + Qed. + + Lemma mkEns_Finite : forall s, Finite _ (!!s). + Proof. + intro s; pattern s; apply set_induction; clear s; intros. + intros; replace (!!s) with (Empty_set elt); auto with sets. + symmetry; apply Extensionality_Ensembles. + apply Empty_Empty_set; auto. + replace (!!s') with (Add _ (!!s) x). + constructor 2; auto. + symmetry; apply Extensionality_Ensembles. + apply Add_Add; auto. + Qed. + + Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s). + Proof. + intro s; pattern s; apply set_induction; clear s; intros. + intros; replace (!!s) with (Empty_set elt); auto with sets. + rewrite MP.cardinal_1; auto with sets. + symmetry; apply Extensionality_Ensembles. + apply Empty_Empty_set; auto. + replace (!!s') with (Add _ (!!s) x). + rewrite (cardinal_2 H0 H1); auto with sets. + symmetry; apply Extensionality_Ensembles. + apply Add_Add; auto. + Qed. + + (** we can even build a function from Finite Ensemble to MSet + ... at least in Prop. *) + + Lemma Ens_to_MSet : forall e : Ensemble M.elt, Finite _ e -> + exists s:M.t, !!s === e. + Proof. + induction 1. + exists M.empty. + apply empty_Empty_Set. + destruct IHFinite as (s,Hs). + exists (M.add x s). + apply Extensionality_Ensembles in Hs. + rewrite <- Hs. + apply add_Add. + Qed. + +End WS_to_Finite_set. + + +Module S_to_Finite_set (U:UsualOrderedType)(M: SetsOn U) := + WS_to_Finite_set U M. + + diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v new file mode 100644 index 00000000..945cb2dd --- /dev/null +++ b/theories/MSets/MSetWeakList.v @@ -0,0 +1,533 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* false + | y :: l => + if X.eq_dec x y then true else mem x l + end. + + Fixpoint add (x : elt) (s : t) : t := + match s with + | nil => x :: nil + | y :: l => + if X.eq_dec x y then s else y :: add x l + end. + + Definition singleton (x : elt) : t := x :: nil. + + Fixpoint remove (x : elt) (s : t) : t := + match s with + | nil => nil + | y :: l => + if X.eq_dec x y then l else y :: remove x l + end. + + Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B := + fold_left (flip f) s i. + + Definition union (s : t) : t -> t := fold add s. + + Definition diff (s s' : t) : t := fold remove s' s. + + Definition inter (s s': t) : t := + fold (fun x s => if mem x s' then add x s else s) s nil. + + Definition subset (s s' : t) : bool := is_empty (diff s s'). + + Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s). + + Fixpoint filter (f : elt -> bool) (s : t) : t := + match s with + | nil => nil + | x :: l => if f x then x :: filter f l else filter f l + end. + + Fixpoint for_all (f : elt -> bool) (s : t) : bool := + match s with + | nil => true + | x :: l => if f x then for_all f l else false + end. + + Fixpoint exists_ (f : elt -> bool) (s : t) : bool := + match s with + | nil => false + | x :: l => if f x then true else exists_ f l + end. + + Fixpoint partition (f : elt -> bool) (s : t) : t * t := + match s with + | nil => (nil, nil) + | x :: l => + let (s1, s2) := partition f l in + if f x then (x :: s1, s2) else (s1, x :: s2) + end. + + Definition cardinal (s : t) : nat := length s. + + Definition elements (s : t) : list elt := s. + + Definition choose (s : t) : option elt := + match s with + | nil => None + | x::_ => Some x + end. + +End Ops. + +(** ** Proofs of set operation specifications. *) + +Module MakeRaw (X:DecidableType) <: WRawSets X. + Include Ops X. + + Section ForNotations. + Notation NoDup := (NoDupA X.eq). + Notation In := (InA X.eq). + + (* TODO: modify proofs in order to avoid these hints *) + Hint Resolve (@Equivalence_Reflexive _ _ X.eq_equiv). + Hint Immediate (@Equivalence_Symmetric _ _ X.eq_equiv). + Hint Resolve (@Equivalence_Transitive _ _ X.eq_equiv). + + Definition IsOk := NoDup. + + Class Ok (s:t) : Prop := ok : NoDup s. + + Hint Unfold Ok. + Hint Resolve @ok. + + Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }. + + Ltac inv_ok := match goal with + | H:Ok (_ :: _) |- _ => inversion_clear H; inv_ok + | H:Ok nil |- _ => clear H; inv_ok + | H:NoDup ?l |- _ => change (Ok l) in H; inv_ok + | _ => idtac + end. + + Ltac inv := invlist InA; inv_ok. + Ltac constructors := repeat constructor. + + Fixpoint isok l := match l with + | nil => true + | a::l => negb (mem a l) && isok l + end. + + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Lemma In_compat : Proper (X.eq==>eq==>iff) In. + Proof. + repeat red; intros. subst. rewrite H; auto. + Qed. + + Lemma mem_spec : forall s x `{Ok s}, + mem x s = true <-> In x s. + Proof. + induction s; intros. + split; intros; inv. discriminate. + simpl; destruct (X.eq_dec x a); split; intros; inv; auto. + right; rewrite <- IHs; auto. + rewrite IHs; auto. + Qed. + + Lemma isok_iff : forall l, Ok l <-> isok l = true. + Proof. + induction l. + intuition. + simpl. + rewrite andb_true_iff. + rewrite negb_true_iff. + rewrite <- IHl. + split; intros H. inv. + split; auto. + apply not_true_is_false. rewrite mem_spec; auto. + destruct H; constructors; auto. + rewrite <- mem_spec; auto; congruence. + Qed. + + Global Instance isok_Ok l : isok l = true -> Ok l | 10. + Proof. + intros. apply <- isok_iff; auto. + Qed. + + Lemma add_spec : + forall (s : t) (x y : elt) {Hs : Ok s}, + In y (add x s) <-> X.eq y x \/ In y s. + Proof. + induction s; simpl; intros. + intuition; inv; auto. + destruct X.eq_dec; inv; rewrite InA_cons, ?IHs; intuition. + left; eauto. + inv; auto. + Qed. + + Global Instance add_ok s x `(Ok s) : Ok (add x s). + Proof. + induction s. + simpl; intuition. + intros; inv. simpl. + destruct X.eq_dec; auto. + constructors; auto. + intro; inv; auto. + rewrite add_spec in *; intuition. + Qed. + + Lemma remove_spec : + forall (s : t) (x y : elt) {Hs : Ok s}, + In y (remove x s) <-> In y s /\ ~X.eq y x. + Proof. + induction s; simpl; intros. + intuition; inv; auto. + destruct X.eq_dec; 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. + Qed. + + Global Instance remove_ok s x `(Ok s) : Ok (remove x s). + Proof. + induction s; simpl; intros. + auto. + destruct X.eq_dec; inv; auto. + constructors; auto. + rewrite remove_spec; intuition. + Qed. + + Lemma singleton_ok : forall x : elt, Ok (singleton x). + Proof. + unfold singleton; simpl; constructors; auto. intro; inv. + Qed. + + Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x. + Proof. + unfold singleton; simpl; split; intros. inv; auto. left; auto. + Qed. + + Lemma empty_ok : Ok empty. + Proof. + unfold empty; constructors. + Qed. + + Lemma empty_spec : Empty empty. + Proof. + unfold Empty, empty; red; intros; inv. + Qed. + + Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s. + Proof. + unfold Empty; destruct s; simpl; split; intros; auto. + intro; inv. + discriminate. + elim (H e); auto. + Qed. + + Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s. + Proof. + unfold elements; intuition. + Qed. + + Lemma elements_spec2w : forall (s : t) {Hs : Ok s}, NoDup (elements s). + Proof. + unfold elements; auto. + Qed. + + Lemma fold_spec : + forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. + Proof. + reflexivity. + Qed. + + Global Instance union_ok : forall s s' `(Ok s, Ok s'), Ok (union s s'). + Proof. + induction s; simpl; auto; intros; inv; unfold flip; auto with *. + Qed. + + Lemma union_spec : + forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, + In x (union s s') <-> In x s \/ In x s'. + Proof. + induction s; simpl in *; unfold flip; intros; auto; inv. + intuition; inv. + rewrite IHs, add_spec, InA_cons; intuition. + Qed. + + Global Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s'). + Proof. + unfold inter, fold, flip. + set (acc := nil (A:=elt)). + assert (Hacc : Ok acc) by constructors. + clearbody acc; revert acc Hacc. + induction s; simpl; auto; intros. inv. + apply IHs; auto. + destruct (mem a s'); auto with *. + Qed. + + Lemma inter_spec : + forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, + In x (inter s s') <-> In x s /\ In x s'. + Proof. + unfold inter, fold, flip; intros. + set (acc := nil (A:=elt)) in *. + assert (Hacc : Ok acc) by constructors. + assert (IFF : (In x s /\ In x s') <-> (In x s /\ In x s') \/ In x acc). + intuition; unfold acc in *; inv. + rewrite IFF; clear IFF. clearbody acc. + revert acc Hacc x s' Hs Hs'. + induction s; simpl; intros. + intuition; inv. + inv. + case_eq (mem a s'); intros Hm. + rewrite IHs, add_spec, InA_cons; intuition. + rewrite mem_spec in Hm; auto. + left; split; auto. rewrite H1; auto. + rewrite IHs, InA_cons; intuition. + rewrite H2, <- mem_spec in H3; auto. congruence. + Qed. + + Global Instance diff_ok : forall s s' `(Ok s, Ok s'), Ok (diff s s'). + Proof. + unfold diff; intros s s'; revert s. + induction s'; simpl; unfold flip; auto; intros. inv; auto with *. + Qed. + + Lemma diff_spec : + forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, + In x (diff s s') <-> In x s /\ ~In x s'. + Proof. + unfold diff; intros s s'; revert s. + induction s'; simpl; unfold flip. + intuition; inv. + intros. inv. + rewrite IHs', remove_spec, InA_cons; intuition. + Qed. + + Lemma subset_spec : + forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'}, + subset s s' = true <-> Subset s s'. + Proof. + unfold subset, Subset; intros. + rewrite is_empty_spec. + unfold Empty; intros. + intuition. + specialize (H a). rewrite diff_spec in H; intuition. + rewrite <- (mem_spec a) in H |- *. destruct (mem a s'); intuition. + rewrite diff_spec in H0; intuition. + Qed. + + Lemma equal_spec : + forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'}, + equal s s' = true <-> Equal s s'. + Proof. + unfold Equal, equal; intros. + rewrite andb_true_iff, !subset_spec. + unfold Subset; intuition. rewrite <- H; auto. rewrite H; auto. + Qed. + + Definition choose_spec1 : + forall (s : t) (x : elt), choose s = Some x -> In x s. + Proof. + destruct s; simpl; intros; inversion H; auto. + Qed. + + Definition choose_spec2 : forall s : t, choose s = None -> Empty s. + Proof. + destruct s; simpl; intros. + intros x H0; inversion H0. + inversion H. + Qed. + + Lemma cardinal_spec : + forall (s : t) {Hs : Ok s}, cardinal s = length (elements s). + Proof. + auto. + Qed. + + Lemma filter_spec' : forall s x f, + In x (filter f s) -> In x s. + Proof. + induction s; simpl. + intuition; inv. + intros; destruct (f a); inv; intuition; right; eauto. + Qed. + + Lemma filter_spec : + forall (s : t) (x : elt) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (In x (filter f s) <-> In x s /\ f x = true). + Proof. + induction s; simpl. + intuition; inv. + intros. + destruct (f a) as [ ]_eqn:E; rewrite ?InA_cons, IHs; intuition. + setoid_replace x with a; auto. + setoid_replace a with x in E; auto. congruence. + Qed. + + Global Instance filter_ok s f `(Ok s) : Ok (filter f s). + Proof. + induction s; simpl. + auto. + intros; inv. + case (f a); auto. + constructors; auto. + contradict H0. + eapply filter_spec'; eauto. + Qed. + + Lemma for_all_spec : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. + unfold For_all; induction s; simpl. + intuition. inv. + intros; inv. + destruct (f a) as [ ]_eqn:F. + rewrite IHs; intuition. inv; auto. + setoid_replace x with a; auto. + split; intros H'; try discriminate. + intros. + rewrite <- F, <- (H' a); auto. + Qed. + + Lemma exists_spec : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. + unfold Exists; induction s; simpl. + split; [discriminate| intros (x & Hx & _); inv]. + intros. + destruct (f a) as [ ]_eqn:F. + split; auto. + exists a; auto. + rewrite IHs; firstorder. + inv. + setoid_replace a with x in F; auto; congruence. + exists x; auto. + Qed. + + Lemma partition_spec1 : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + Equal (fst (partition f s)) (filter f s). + Proof. + simple induction s; simpl; auto; unfold Equal. + firstorder. + intros x l Hrec f Hf. + generalize (Hrec f Hf); clear Hrec. + case (partition f l); intros s1 s2; simpl; intros. + case (f x); simpl; firstorder; inversion H0; intros; firstorder. + Qed. + + Lemma partition_spec2 : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. + simple induction s; simpl; auto; unfold Equal. + firstorder. + intros x l Hrec f Hf. + generalize (Hrec f Hf); clear Hrec. + case (partition f l); intros s1 s2; simpl; intros. + case (f x); simpl; firstorder; inversion H0; intros; firstorder. + Qed. + + Lemma partition_ok1' : + forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt), + In x (fst (partition f s)) -> In x s. + Proof. + induction s; simpl; auto; intros. inv. + generalize (IHs H1 f x). + destruct (f a); destruct (partition f s); simpl in *; auto. + inversion_clear H; auto. + Qed. + + Lemma partition_ok2' : + forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt), + In x (snd (partition f s)) -> In x s. + Proof. + induction s; simpl; auto; intros. inv. + generalize (IHs H1 f x). + destruct (f a); destruct (partition f s); simpl in *; auto. + inversion_clear H; auto. + Qed. + + Global Instance partition_ok1 : forall s f `(Ok s), Ok (fst (partition f s)). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec f Hs; inv. + generalize (@partition_ok1' _ _ f x). + generalize (Hrec f H0). + case (f x); case (partition f l); simpl; constructors; auto. + Qed. + + Global Instance partition_ok2 : forall s f `(Ok s), Ok (snd (partition f s)). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec f Hs; inv. + generalize (@partition_ok2' _ _ f x). + generalize (Hrec f H0). + case (f x); case (partition f l); simpl; constructors; auto. + Qed. + + End ForNotations. + + Definition In := InA X.eq. + Definition eq := Equal. + Instance eq_equiv : Equivalence eq. + +End MakeRaw. + +(** * Encapsulation + + Now, in order to really provide a functor implementing [S], we + need to encapsulate everything into a type of lists without redundancy. *) + +Module Make (X: DecidableType) <: WSets with Module E := X. + Module Raw := MakeRaw X. + Include WRaw2Sets X Raw. +End Make. + diff --git a/theories/MSets/MSets.v b/theories/MSets/MSets.v new file mode 100644 index 00000000..958e9861 --- /dev/null +++ b/theories/MSets/MSets.v @@ -0,0 +1,23 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 2*x *) -Definition Ndouble n := +Definition Ndouble n := match n with | N0 => N0 | Npos p => Npos (xO p) @@ -106,6 +106,15 @@ Definition Nmult n m := Infix "*" := Nmult : N_scope. +(** Boolean Equality *) + +Definition Neqb n m := + match n, m with + | N0, N0 => true + | Npos n, Npos m => Peqb n m + | _,_ => false + end. + (** Order *) Definition Ncompare n m := @@ -130,16 +139,24 @@ Infix ">" := Ngt : N_scope. (** Min and max *) -Definition Nmin (n n' : N) := match Ncompare n n' with +Definition Nmin (n n' : N) := match Ncompare n n' with | Lt | Eq => n | Gt => n' end. -Definition Nmax (n n' : N) := match Ncompare n n' with +Definition Nmax (n n' : N) := match Ncompare n n' with | Lt | Eq => n' | Gt => n end. +(** Decidability of equality. *) + +Definition N_eq_dec : forall n m : N, { n = m } + { n <> m }. +Proof. + decide equality. + apply positive_eq_dec. +Defined. + (** convenient induction principles *) Lemma N_ind_double : @@ -149,7 +166,7 @@ Lemma N_ind_double : (forall a, P a -> P (Ndouble_plus_one a)) -> P a. Proof. intros; elim a. trivial. - simple induction p. intros. + simple induction p. intros. apply (H1 (Npos p0)); trivial. intros; apply (H0 (Npos p0)); trivial. intros; apply (H1 N0); assumption. @@ -162,7 +179,7 @@ Lemma N_rec_double : (forall a, P a -> P (Ndouble_plus_one a)) -> P a. Proof. intros; elim a. trivial. - simple induction p. intros. + simple induction p. intros. apply (H1 (Npos p0)); trivial. intros; apply (H0 (Npos p0)); trivial. intros; apply (H1 N0); assumption. @@ -354,7 +371,16 @@ destruct p; intros Hp H. contradiction Hp; reflexivity. destruct n; destruct m; reflexivity || (try discriminate H). injection H; clear H; intro H; rewrite Pmult_reg_r with (1 := H); reflexivity. -Qed. +Qed. + +(** Properties of boolean order. *) + +Lemma Neqb_eq : forall n m, Neqb n m = true <-> n=m. +Proof. +destruct n as [|n], m as [|m]; simpl; split; auto; try discriminate. +intros; f_equal. apply (Peqb_eq n m); auto. +intros. apply (Peqb_eq n m). congruence. +Qed. (** Properties of comparison *) @@ -373,7 +399,7 @@ Qed. Theorem Ncompare_eq_correct : forall n m:N, (n ?= m) = Eq <-> n = m. Proof. -split; intros; +split; intros; [ apply Ncompare_Eq_eq; auto | subst; apply Ncompare_refl ]. Qed. @@ -383,11 +409,30 @@ destruct n; destruct m; simpl; auto. exact (Pcompare_antisym p p0 Eq). Qed. +Lemma Ngt_Nlt : forall n m, n > m -> m < n. +Proof. +unfold Ngt, Nlt; intros n m GT. +rewrite <- Ncompare_antisym, GT; reflexivity. +Qed. + Theorem Nlt_irrefl : forall n : N, ~ n < n. Proof. intro n; unfold Nlt; now rewrite Ncompare_refl. Qed. +Theorem Nlt_trans : forall n m q, n < m -> m < q -> n < q. +Proof. +destruct n; + destruct m; try discriminate; + destruct q; try discriminate; auto. +eapply Plt_trans; eauto. +Qed. + +Theorem Nlt_not_eq : forall n m, n < m -> ~ n = m. +Proof. + intros n m LT EQ. subst m. elim (Nlt_irrefl n); auto. +Qed. + Theorem Ncompare_n_Sm : forall n m : N, Ncompare n (Nsucc m) = Lt <-> Ncompare n m = Lt \/ n = m. Proof. @@ -400,6 +445,21 @@ pose proof (Pcompare_p_Sq p q) as (_,?); assert (p = q <-> Npos p = Npos q); [split; congruence | tauto]. Qed. +Lemma Nle_lteq : forall x y, x <= y <-> x < y \/ x=y. +Proof. +unfold Nle, Nlt; intros. +generalize (Ncompare_eq_correct x y). +destruct (x ?= y); intuition; discriminate. +Qed. + +Lemma Ncompare_spec : forall x y, CompSpec eq Nlt x y (Ncompare x y). +Proof. +intros. +destruct (Ncompare x y) as [ ]_eqn; constructor; auto. +apply Ncompare_Eq_eq; auto. +apply Ngt_Nlt; auto. +Qed. + (** 0 is the least natural number *) Theorem Ncompare_0 : forall n : N, Ncompare n N0 <> Lt. diff --git a/theories/NArith/BinPos.v b/theories/NArith/BinPos.v index e3293e70..a5f99cc6 100644 --- a/theories/NArith/BinPos.v +++ b/theories/NArith/BinPos.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* q~1 | 1, 1 => 1~0 end - + with Pplus_carry (x y:positive) : positive := match x, y with | p~1, q~1 => (Pplus_carry p q)~1 @@ -176,7 +179,7 @@ Fixpoint Pminus_mask (x y:positive) {struct y} : positive_mask := | 1, 1 => IsNul | 1, _ => IsNeg end - + with Pminus_mask_carry (x y:positive) {struct y} : positive_mask := match x, y with | p~1, q~1 => Pdouble_plus_one_mask (Pminus_mask_carry p q) @@ -253,23 +256,41 @@ Notation "x < y < z" := (x < y /\ y < z) : positive_scope. Notation "x < y <= z" := (x < y /\ y <= z) : positive_scope. -Definition Pmin (p p' : positive) := match Pcompare p p' Eq with - | Lt | Eq => p +Definition Pmin (p p' : positive) := match Pcompare p p' Eq with + | Lt | Eq => p | Gt => p' end. -Definition Pmax (p p' : positive) := match Pcompare p p' Eq with - | Lt | Eq => p' +Definition Pmax (p p' : positive) := match Pcompare p p' Eq with + | Lt | Eq => p' | Gt => p end. +(********************************************************************) +(** Boolean equality *) + +Fixpoint Peqb (x y : positive) {struct y} : bool := + match x, y with + | 1, 1 => true + | p~1, q~1 => Peqb p q + | p~0, q~0 => Peqb p q + | _, _ => false + end. + (**********************************************************************) -(** Miscellaneous properties of binary positive numbers *) +(** Decidability of equality on binary positive numbers *) + +Lemma positive_eq_dec : forall x y: positive, {x = y} + {x <> y}. +Proof. + decide equality. +Defined. -Lemma ZL11 : forall p:positive, p = 1 \/ p <> 1. +(* begin hide *) +Corollary ZL11 : forall p:positive, p = 1 \/ p <> 1. Proof. - intros x; case x; intros; (left; reflexivity) || (right; discriminate). + intro; edestruct positive_eq_dec; eauto. Qed. +(* end hide *) (**********************************************************************) (** Properties of successor on binary positive numbers *) @@ -371,14 +392,14 @@ Theorem Pplus_comm : forall p q:positive, p + q = q + p. Proof. induction p; destruct q; simpl; f_equal; auto. rewrite 2 Pplus_carry_spec; f_equal; auto. -Qed. +Qed. (** Permutation of [Pplus] and [Psucc] *) Theorem Pplus_succ_permute_r : forall p q:positive, p + Psucc q = Psucc (p + q). Proof. - induction p; destruct q; simpl; f_equal; + induction p; destruct q; simpl; f_equal; auto using Pplus_one_succ_r; rewrite Pplus_carry_spec; auto. Qed. @@ -423,10 +444,10 @@ Qed. Lemma Pplus_reg_r : forall p q r:positive, p + r = q + r -> p = q. Proof. intros p q r; revert p q; induction r. - intros [p|p| ] [q|q| ] H; simpl; destr_eq H; - f_equal; auto using Pplus_carry_plus; + intros [p|p| ] [q|q| ] H; simpl; destr_eq H; + f_equal; auto using Pplus_carry_plus; contradict H; auto using Pplus_carry_no_neutral. - intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; auto; + intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; auto; contradict H; auto using Pplus_no_neutral. intros p q H; apply Psucc_inj; do 2 rewrite Pplus_one_succ_r; assumption. Qed. @@ -456,11 +477,11 @@ Qed. Theorem Pplus_assoc : forall p q r:positive, p + (q + r) = p + q + r. Proof. induction p. - intros [q|q| ] [r|r| ]; simpl; f_equal; auto; - rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r, + intros [q|q| ] [r|r| ]; simpl; f_equal; auto; + rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r, ?Pplus_succ_permute_l, ?Pplus_one_succ_r; f_equal; auto. intros [q|q| ] [r|r| ]; simpl; f_equal; auto; - rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r, + rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r, ?Pplus_succ_permute_l, ?Pplus_one_succ_r; f_equal; auto. intros p r; rewrite <- 2 Pplus_one_succ_l, Pplus_succ_permute_l; auto. Qed. @@ -484,7 +505,7 @@ Lemma Pplus_xO_double_minus_one : forall p q:positive, Pdouble_minus_one (p + q) = p~0 + Pdouble_minus_one q. Proof. induction p as [p IHp| p IHp| ]; destruct q; simpl; - rewrite ?Pplus_carry_spec, ?Pdouble_minus_one_o_succ_eq_xI, + rewrite ?Pplus_carry_spec, ?Pdouble_minus_one_o_succ_eq_xI, ?Pplus_xI_double_minus_one; try reflexivity. rewrite IHp; auto. rewrite <- Psucc_o_double_minus_one_eq_xO, Pplus_one_succ_l; reflexivity. @@ -494,7 +515,7 @@ Qed. Lemma Pplus_diag : forall p:positive, p + p = p~0. Proof. - induction p as [p IHp| p IHp| ]; simpl; + induction p as [p IHp| p IHp| ]; simpl; try rewrite ?Pplus_carry_spec, ?IHp; reflexivity. Qed. @@ -525,10 +546,10 @@ Fixpoint peanoView p : PeanoView p := | p~1 => peanoView_xI p (peanoView p) end. -Definition PeanoView_iter (P:positive->Type) +Definition PeanoView_iter (P:positive->Type) (a:P 1) (f:forall p, P p -> P (Psucc p)) := (fix iter p (q:PeanoView p) : P p := - match q in PeanoView p return P p with + match q in PeanoView p return P p with | PeanoOne => a | PeanoSucc _ q => f _ (iter _ q) end). @@ -536,23 +557,23 @@ Definition PeanoView_iter (P:positive->Type) Require Import Eqdep_dec EqdepFacts. Theorem eq_dep_eq_positive : - forall (P:positive->Type) (p:positive) (x y:P p), + forall (P:positive->Type) (p:positive) (x y:P p), eq_dep positive P p x p y -> x = y. Proof. apply eq_dep_eq_dec. decide equality. Qed. -Theorem PeanoViewUnique : forall p (q q':PeanoView p), q = q'. +Theorem PeanoViewUnique : forall p (q q':PeanoView p), q = q'. Proof. - intros. + intros. induction q as [ | p q IHq ]. apply eq_dep_eq_positive. cut (1=1). pattern 1 at 1 2 5, q'. destruct q'. trivial. destruct p0; intros; discriminate. trivial. apply eq_dep_eq_positive. - cut (Psucc p=Psucc p). pattern (Psucc p) at 1 2 5, q'. destruct q'. + cut (Psucc p=Psucc p). pattern (Psucc p) at 1 2 5, q'. destruct q'. intro. destruct p; discriminate. intro. unfold p0 in H. apply Psucc_inj in H. generalize q'. rewrite H. intro. @@ -561,12 +582,12 @@ Proof. trivial. Qed. -Definition Prect (P:positive->Type) (a:P 1) (f:forall p, P p -> P (Psucc p)) +Definition Prect (P:positive->Type) (a:P 1) (f:forall p, P p -> P (Psucc p)) (p:positive) := PeanoView_iter P a f p (peanoView p). -Theorem Prect_succ : forall (P:positive->Type) (a:P 1) - (f:forall p, P p -> P (Psucc p)) (p:positive), +Theorem Prect_succ : forall (P:positive->Type) (a:P 1) + (f:forall p, P p -> P (Psucc p)) (p:positive), Prect P a f (Psucc p) = f _ (Prect P a f p). Proof. intros. @@ -575,7 +596,7 @@ Proof. trivial. Qed. -Theorem Prect_base : forall (P:positive->Type) (a:P 1) +Theorem Prect_base : forall (P:positive->Type) (a:P 1) (f:forall p, P p -> P (Psucc p)), Prect P a f 1 = a. Proof. trivial. @@ -713,6 +734,29 @@ Proof. intros [p|p| ] [q|q| ] H; destr_eq H; auto. Qed. +(*********************************************************************) +(** Properties of boolean equality *) + +Theorem Peqb_refl : forall x:positive, Peqb x x = true. +Proof. + induction x; auto. +Qed. + +Theorem Peqb_true_eq : forall x y:positive, Peqb x y = true -> x=y. +Proof. + induction x; destruct y; simpl; intros; try discriminate. + f_equal; auto. + f_equal; auto. + reflexivity. +Qed. + +Theorem Peqb_eq : forall x y : positive, Peqb x y = true <-> x=y. +Proof. + split. apply Peqb_true_eq. + intros; subst; apply Peqb_refl. +Qed. + + (**********************************************************************) (** Properties of comparison on binary positive numbers *) @@ -735,12 +779,19 @@ Qed. Theorem Pcompare_Eq_eq : forall p q:positive, (p ?= q) Eq = Eq -> p = q. Proof. - induction p; intros [q| q| ] H; simpl in *; auto; + induction p; intros [q| q| ] H; simpl in *; auto; try discriminate H; try (f_equal; auto; fail). destruct (Pcompare_not_Eq p q) as (H',_); elim H'; auto. destruct (Pcompare_not_Eq p q) as (_,H'); elim H'; auto. Qed. +Lemma Pcompare_eq_iff : forall p q:positive, (p ?= q) Eq = Eq <-> p = q. +Proof. + split. + apply Pcompare_Eq_eq. + intros; subst; apply Pcompare_refl. +Qed. + Lemma Pcompare_Gt_Lt : forall p q:positive, (p ?= q) Gt = Lt -> (p ?= q) Eq = Lt. Proof. @@ -812,7 +863,7 @@ Lemma Pcompare_antisym : forall (p q:positive) (r:comparison), CompOpp ((p ?= q) r) = (q ?= p) (CompOpp r). Proof. - induction p as [p IHp|p IHp| ]; intros [q|q| ] r; simpl; auto; + induction p as [p IHp|p IHp| ]; intros [q|q| ] r; simpl; auto; rewrite IHp; auto. Qed. @@ -840,6 +891,15 @@ Proof. symmetry; apply Pcompare_antisym. Qed. +Lemma Pcompare_spec : forall p q, CompSpec eq Plt p q ((p ?= q) Eq). +Proof. + intros. destruct ((p ?= q) Eq) as [ ]_eqn; constructor. + apply Pcompare_Eq_eq; auto. + auto. + apply ZC1; auto. +Qed. + + (** Comparison and the successor *) Lemma Pcompare_p_Sp : forall p : positive, (p ?= Psucc p) Eq = Lt. @@ -915,6 +975,14 @@ Proof. destruct (Pcompare_p_Sq n m) as (H',_); destruct (H' H); subst; auto. Qed. +Lemma Ple_lteq : forall p q, p <= q <-> p < q \/ p = q. +Proof. + unfold Ple, Plt. intros. + generalize (Pcompare_eq_iff p q). + destruct ((p ?= q) Eq); intuition; discriminate. +Qed. + + (**********************************************************************) (** Properties of subtraction on binary positive numbers *) @@ -940,14 +1008,14 @@ Qed. Theorem Pminus_mask_carry_spec : forall p q : positive, Pminus_mask_carry p q = Ppred_mask (Pminus_mask p q). Proof. - induction p as [p IHp|p IHp| ]; destruct q; simpl; + induction p as [p IHp|p IHp| ]; destruct q; simpl; try reflexivity; try rewrite IHp; destruct (Pminus_mask p q) as [|[r|r| ]|] || destruct p; auto. Qed. Theorem Pminus_succ_r : forall p q : positive, p - (Psucc q) = Ppred (p - q). Proof. - intros p q; unfold Pminus; + intros p q; unfold Pminus; rewrite Pminus_mask_succ_r, Pminus_mask_carry_spec. destruct (Pminus_mask p q) as [|[r|r| ]|]; auto. Qed. @@ -986,11 +1054,11 @@ Proof. induction p as [p IHp| p IHp| ]; simpl; try rewrite IHp; auto. Qed. -Lemma Pminus_mask_IsNeg : forall p q:positive, +Lemma Pminus_mask_IsNeg : forall p q:positive, Pminus_mask p q = IsNeg -> Pminus_mask_carry p q = IsNeg. Proof. - induction p as [p IHp|p IHp| ]; intros [q|q| ] H; simpl in *; auto; - try discriminate; unfold Pdouble_mask, Pdouble_plus_one_mask in H; + induction p as [p IHp|p IHp| ]; intros [q|q| ] H; simpl in *; auto; + try discriminate; unfold Pdouble_mask, Pdouble_plus_one_mask in H; specialize IHp with q. destruct (Pminus_mask p q); try discriminate; rewrite IHp; auto. destruct (Pminus_mask p q); simpl; auto; try discriminate. @@ -1019,9 +1087,9 @@ Lemma Pminus_mask_Gt : Pminus_mask p q = IsPos h /\ q + h = p /\ (h = 1 \/ Pminus_mask_carry p q = IsPos (Ppred h)). Proof. - induction p as [p IHp| p IHp| ]; intros [q| q| ] H; simpl in *; + induction p as [p IHp| p IHp| ]; intros [q| q| ] H; simpl in *; try discriminate H. - (* p~1, q~1 *) + (* p~1, q~1 *) destruct (IHp q H) as (r & U & V & W); exists (r~0); rewrite ?U, ?V; auto. repeat split; auto; right. destruct (ZL11 r) as [EQ|NE]; [|destruct W as [|W]; [elim NE; auto|]]. @@ -1082,10 +1150,10 @@ Qed. (** Number of digits in a number *) -Fixpoint Psize (p:positive) : nat := - match p with +Fixpoint Psize (p:positive) : nat := + match p with | 1 => S O - | p~1 => S (Psize p) + | p~1 => S (Psize p) | p~0 => S (Psize p) end. diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v index 6ece00d7..53ba50ff 100644 --- a/theories/NArith/NArith.v +++ b/theories/NArith/NArith.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: NArith.v 10751 2008-04-04 10:23:35Z herbelin $ *) +(* $Id$ *) (** Library for binary natural numbers *) diff --git a/theories/NArith/NOrderedType.v b/theories/NArith/NOrderedType.v new file mode 100644 index 00000000..c5dd395b --- /dev/null +++ b/theories/NArith/NOrderedType.v @@ -0,0 +1,60 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Logic.eq==>iff) Nlt. + Proof. repeat red; intros; subst; auto. Qed. + + Definition le_lteq := Nle_lteq. + Definition compare_spec := Ncompare_spec. + +End N_as_OT. + +(** Note that [N_as_OT] can also be seen as a [UsualOrderedType] + and a [OrderedType] (and also as a [DecidableType]). *) + + + +(** * An [order] tactic for [N] numbers *) + +Module NOrder := OTF_to_OrderTac N_as_OT. +Ltac n_order := NOrder.order. + +(** Note that [n_order] is domain-agnostic: it will not prove + [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) + diff --git a/theories/NArith/Ndec.v b/theories/NArith/Ndec.v index 5bd9a378..9540aace 100644 --- a/theories/NArith/Ndec.v +++ b/theories/NArith/Ndec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ndec.v 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id$ i*) Require Import Bool. Require Import Sumbool. @@ -19,73 +19,49 @@ Require Import Ndigits. (** A boolean equality over [N] *) -Fixpoint Peqb (p1 p2:positive) {struct p2} : bool := - match p1, p2 with - | xH, xH => true - | xO p'1, xO p'2 => Peqb p'1 p'2 - | xI p'1, xI p'2 => Peqb p'1 p'2 - | _, _ => false - end. +Notation Peqb := Peqb (only parsing). (* Now in [BinPos] *) +Notation Neqb := Neqb (only parsing). (* Now in [BinNat] *) -Lemma Peqb_correct : forall p, Peqb p p = true. -Proof. -induction p; auto. -Qed. +Notation Peqb_correct := Peqb_refl (only parsing). -Lemma Peqb_Pcompare : forall p p', Peqb p p' = true -> Pcompare p p' Eq = Eq. +Lemma Peqb_complete : forall p p', Peqb p p' = true -> p = p'. Proof. - induction p; destruct p'; simpl; intros; try discriminate; auto. + intros. now apply (Peqb_eq p p'). Qed. -Lemma Peqb_complete : forall p p', Peqb p p' = true -> p = p'. +Lemma Peqb_Pcompare : forall p p', Peqb p p' = true -> Pcompare p p' Eq = Eq. Proof. - intros. - apply Pcompare_Eq_eq. - apply Peqb_Pcompare; auto. + intros. now rewrite Pcompare_eq_iff, <- Peqb_eq. Qed. Lemma Pcompare_Peqb : forall p p', Pcompare p p' Eq = Eq -> Peqb p p' = true. -Proof. -intros; rewrite <- (Pcompare_Eq_eq _ _ H). -apply Peqb_correct. +Proof. + intros; now rewrite Peqb_eq, <- Pcompare_eq_iff. Qed. -Definition Neqb (a a':N) := - match a, a' with - | N0, N0 => true - | Npos p, Npos p' => Peqb p p' - | _, _ => false - end. - Lemma Neqb_correct : forall n, Neqb n n = true. Proof. - destruct n; trivial. - simpl; apply Peqb_correct. + intros; now rewrite Neqb_eq. Qed. Lemma Neqb_Ncompare : forall n n', Neqb n n' = true -> Ncompare n n' = Eq. Proof. - destruct n; destruct n'; simpl; intros; try discriminate; auto; apply Peqb_Pcompare; auto. + intros; now rewrite Ncompare_eq_correct, <- Neqb_eq. Qed. Lemma Ncompare_Neqb : forall n n', Ncompare n n' = Eq -> Neqb n n' = true. -Proof. -intros; rewrite <- (Ncompare_Eq_eq _ _ H). -apply Neqb_correct. +Proof. + intros; now rewrite Neqb_eq, <- Ncompare_eq_correct. Qed. Lemma Neqb_complete : forall a a', Neqb a a' = true -> a = a'. Proof. - intros. - apply Ncompare_Eq_eq. - apply Neqb_Ncompare; auto. + intros; now rewrite <- Neqb_eq. Qed. Lemma Neqb_comm : forall a a', Neqb a a' = Neqb a' a. Proof. - intros; apply bool_1; split; intros. - rewrite (Neqb_complete _ _ H); apply Neqb_correct. - rewrite (Neqb_complete _ _ H); apply Neqb_correct. + intros; apply eq_true_iff_eq. rewrite 2 Neqb_eq; auto with *. Qed. Lemma Nxor_eq_true : @@ -98,7 +74,8 @@ Lemma Nxor_eq_false : forall a a' p, Nxor a a' = Npos p -> Neqb a a' = false. Proof. intros. elim (sumbool_of_bool (Neqb a a')). intro H0. - rewrite (Neqb_complete a a' H0) in H. rewrite (Nxor_nilpotent a') in H. discriminate H. + rewrite (Neqb_complete a a' H0) in H. + rewrite (Nxor_nilpotent a') in H. discriminate H. trivial. Qed. @@ -107,7 +84,7 @@ Lemma Nodd_not_double : Nodd a -> forall a0, Neqb (Ndouble a0) a = false. Proof. intros. elim (sumbool_of_bool (Neqb (Ndouble a0) a)). intro H0. - rewrite <- (Neqb_complete _ _ H0) in H. + rewrite <- (Neqb_complete _ _ H0) in H. unfold Nodd in H. rewrite (Ndouble_bit0 a0) in H. discriminate H. trivial. @@ -128,7 +105,7 @@ Lemma Neven_not_double_plus_one : Neven a -> forall a0, Neqb (Ndouble_plus_one a0) a = false. Proof. intros. elim (sumbool_of_bool (Neqb (Ndouble_plus_one a0) a)). intro H0. - rewrite <- (Neqb_complete _ _ H0) in H. + rewrite <- (Neqb_complete _ _ H0) in H. unfold Neven in H. rewrite (Ndouble_plus_one_bit0 a0) in H. discriminate H. @@ -149,7 +126,8 @@ Lemma Nbit0_neq : forall a a', Nbit0 a = false -> Nbit0 a' = true -> Neqb a a' = false. Proof. - intros. elim (sumbool_of_bool (Neqb a a')). intro H1. rewrite (Neqb_complete _ _ H1) in H. + intros. elim (sumbool_of_bool (Neqb a a')). intro H1. + rewrite (Neqb_complete _ _ H1) in H. rewrite H in H0. discriminate H0. trivial. Qed. @@ -166,7 +144,8 @@ Lemma Ndiv2_neq : Neqb (Ndiv2 a) (Ndiv2 a') = false -> Neqb a a' = false. Proof. intros. elim (sumbool_of_bool (Neqb a a')). intro H0. - rewrite (Neqb_complete _ _ H0) in H. rewrite (Neqb_correct (Ndiv2 a')) in H. discriminate H. + rewrite (Neqb_complete _ _ H0) in H. + rewrite (Neqb_correct (Ndiv2 a')) in H. discriminate H. trivial. Qed. @@ -354,6 +333,35 @@ Proof. trivial. Qed. +(* Nleb and Ncompare *) + +(* NB: No need to prove that Nleb a b = true <-> Ncompare a b <> Gt, + this statement is in fact Nleb_Nle! *) + +Lemma Nltb_Ncompare : forall a b, + Nleb a b = false <-> Ncompare a b = Gt. +Proof. + intros. + assert (IFF : forall x:bool, x = false <-> ~ x = true) + by (destruct x; intuition). + rewrite IFF, Nleb_Nle; unfold Nle. + destruct (Ncompare a b); split; intro H; auto; + elim H; discriminate. +Qed. + +Lemma Ncompare_Gt_Nltb : forall a b, + Ncompare a b = Gt -> Nleb a b = false. +Proof. + intros; apply <- Nltb_Ncompare; auto. +Qed. + +Lemma Ncompare_Lt_Nltb : forall a b, + Ncompare a b = Lt -> Nleb b a = false. +Proof. + intros a b H. + rewrite Nltb_Ncompare, <- Ncompare_antisym, H; auto. +Qed. + (* An alternate [min] function over [N] *) Definition Nmin' (a b:N) := if Nleb a b then a else b. @@ -362,8 +370,8 @@ Lemma Nmin_Nmin' : forall a b, Nmin a b = Nmin' a b. Proof. unfold Nmin, Nmin', Nleb; intros. rewrite nat_of_Ncompare. - generalize (leb_compare (nat_of_N a) (nat_of_N b)); - destruct (nat_compare (nat_of_N a) (nat_of_N b)); + generalize (leb_compare (nat_of_N a) (nat_of_N b)); + destruct (nat_compare (nat_of_N a) (nat_of_N b)); destruct (leb (nat_of_N a) (nat_of_N b)); intuition. lapply H1; intros; discriminate. lapply H1; intros; discriminate. @@ -392,7 +400,7 @@ Qed. Lemma Nmin_le_3 : forall a b c, Nleb a (Nmin b c) = true -> Nleb a b = true. Proof. - intros; rewrite Nmin_Nmin' in *. + intros; rewrite Nmin_Nmin' in *. unfold Nmin' in *; elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H. assumption. intro H0. rewrite H0 in H. apply Nltb_leb_weak. apply Nleb_ltb_trans with (b := c); assumption. @@ -401,7 +409,7 @@ Qed. Lemma Nmin_le_4 : forall a b c, Nleb a (Nmin b c) = true -> Nleb a c = true. Proof. - intros; rewrite Nmin_Nmin' in *. + intros; rewrite Nmin_Nmin' in *. unfold Nmin' in *; elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H. apply Nleb_trans with (b := b); assumption. intro H0. rewrite H0 in H. assumption. @@ -418,7 +426,7 @@ Qed. Lemma Nmin_lt_3 : forall a b c, Nleb (Nmin b c) a = false -> Nleb b a = false. Proof. - intros; rewrite Nmin_Nmin' in *. + intros; rewrite Nmin_Nmin' in *. unfold Nmin' in *. intros. elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H. assumption. intro H0. rewrite H0 in H. apply Nltb_trans with (b := c); assumption. @@ -427,7 +435,7 @@ Qed. Lemma Nmin_lt_4 : forall a b c, Nleb (Nmin b c) a = false -> Nleb c a = false. Proof. - intros; rewrite Nmin_Nmin' in *. + intros; rewrite Nmin_Nmin' in *. unfold Nmin' in *. elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H. apply Nltb_leb_trans with (b := b); assumption. intro H0. rewrite H0 in H. assumption. diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v index fb32274e..b6c18e9b 100644 --- a/theories/NArith/Ndigits.v +++ b/theories/NArith/Ndigits.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ndigits.v 11735 2009-01-02 17:22:31Z herbelin $ i*) +(*i $Id$ i*) Require Import Bool. Require Import Bvector. @@ -17,7 +17,7 @@ Require Import BinNat. (** [xor] *) -Fixpoint Pxor (p1 p2:positive) {struct p1} : N := +Fixpoint Pxor (p1 p2:positive) : N := match p1, p2 with | xH, xH => N0 | xH, xO p2 => Npos (xI p2) @@ -27,7 +27,7 @@ Fixpoint Pxor (p1 p2:positive) {struct p1} : N := | xO p1, xI p2 => Ndouble_plus_one (Pxor p1 p2) | xI p1, xH => Npos (xO p1) | xI p1, xO p2 => Ndouble_plus_one (Pxor p1 p2) - | xI p1, xI p2 => Ndouble (Pxor p1 p2) + | xI p1, xI p2 => Ndouble (Pxor p1 p2) end. Definition Nxor (n n':N) := @@ -65,7 +65,7 @@ Proof. simpl. rewrite IHp; reflexivity. Qed. -(** Checking whether a particular bit is set on not *) +(** Checking whether a particular bit is set on not *) Fixpoint Pbit (p:positive) : nat -> bool := match p with @@ -134,13 +134,13 @@ Qed. (** End of auxilliary results *) -(** This part is aimed at proving that if two numbers produce +(** This part is aimed at proving that if two numbers produce the same stream of bits, then they are equal. *) Lemma Nbit_faithful_1 : forall a:N, eqf (Nbit N0) (Nbit a) -> N0 = a. Proof. destruct a. trivial. - induction p as [p IHp| p IHp| ]; intro H. + induction p as [p IHp| p IHp| ]; intro H. absurd (N0 = Npos p). discriminate. exact (IHp (fun n => H (S n))). absurd (N0 = Npos p). discriminate. @@ -196,7 +196,7 @@ Proof. assert (Npos p = Npos p') by exact (IHp (Npos p') H0). inversion H1. reflexivity. assumption. - intros. apply Nbit_faithful_3. intros. + intros. apply Nbit_faithful_3. intros. assert (Npos p = Npos p') by exact (IHp (Npos p') H0). inversion H1. reflexivity. assumption. @@ -257,7 +257,7 @@ Proof. generalize (fun p1 p2 => H (Npos p1) (Npos p2)); clear H; intro H. unfold xorf in *. destruct a as [|p]. simpl Nbit; rewrite false_xorb. reflexivity. - destruct a' as [|p0]. + destruct a' as [|p0]. simpl Nbit; rewrite xorb_false. reflexivity. destruct p. destruct p0; simpl Nbit in *. rewrite <- H; simpl; case (Pxor p p0); trivial. @@ -273,13 +273,13 @@ Qed. Lemma Nxor_semantics : forall a a':N, eqf (Nbit (Nxor a a')) (xorf (Nbit a) (Nbit a')). Proof. - unfold eqf. intros; generalize a, a'. induction n. + unfold eqf. intros; generalize a, a'. induction n. apply Nxor_sem_5. apply Nxor_sem_6; assumption. Qed. -(** Consequences: +(** Consequences: - only equal numbers lead to a null xor - - xor is associative + - xor is associative *) Lemma Nxor_eq : forall a a':N, Nxor a a' = N0 -> a = a'. @@ -306,7 +306,7 @@ Proof. apply eqf_sym, Nxor_semantics. Qed. -(** Checking whether a number is odd, i.e. +(** Checking whether a number is odd, i.e. if its lower bit is set. *) Definition Nbit0 (n:N) := @@ -380,8 +380,8 @@ Lemma Nneg_bit0 : forall a a':N, Nbit0 (Nxor a a') = true -> Nbit0 a = negb (Nbit0 a'). Proof. - intros. - rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, xorb_nilpotent, xorb_false. + intros. + rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, xorb_nilpotent, xorb_false. reflexivity. Qed. @@ -402,14 +402,14 @@ Lemma Nsame_bit0 : forall (a a':N) (p:positive), Nxor a a' = Npos (xO p) -> Nbit0 a = Nbit0 a'. Proof. - intros. rewrite <- (xorb_false (Nbit0 a)). + intros. rewrite <- (xorb_false (Nbit0 a)). assert (H0: Nbit0 (Npos (xO p)) = false) by reflexivity. rewrite <- H0, <- H, Nxor_bit0, <- xorb_assoc, xorb_nilpotent, false_xorb. reflexivity. Qed. (** a lexicographic order on bits, starting from the lowest bit *) -Fixpoint Nless_aux (a a':N) (p:positive) {struct p} : bool := +Fixpoint Nless_aux (a a':N) (p:positive) : bool := match p with | xO p' => Nless_aux (Ndiv2 a) (Ndiv2 a') p' | _ => andb (negb (Nbit0 a)) (Nbit0 a') @@ -430,7 +430,7 @@ Proof. assert (H1: Nbit0 (Nxor a a') = false) by (rewrite H2; reflexivity). rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1. simpl. rewrite H, H0. reflexivity. - assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). + assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2. Qed. @@ -443,7 +443,7 @@ Proof. assert (H1: Nbit0 (Nxor a a') = false) by (rewrite H2; reflexivity). rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1. simpl. rewrite H, H0. reflexivity. - assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). + assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2. Qed. @@ -496,14 +496,14 @@ Qed. Lemma N0_less_1 : forall a, Nless N0 a = true -> {p : positive | a = Npos p}. Proof. - destruct a. intros. discriminate. + destruct a. discriminate. intros. exists p. reflexivity. Qed. Lemma N0_less_2 : forall a, Nless N0 a = false -> a = N0. Proof. induction a as [|p]; intro H. trivial. - elimtype False. induction p as [|p IHp|]; discriminate || simpl; auto using IHp. + exfalso. induction p as [|p IHp|]; discriminate || simpl; auto using IHp. Qed. Lemma Nless_trans : @@ -534,7 +534,7 @@ Proof. 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. @@ -558,7 +558,7 @@ Qed. (** Number of digits in a number *) -Definition Nsize (n:N) : nat := match n with +Definition Nsize (n:N) : nat := match n with | N0 => 0%nat | Npos p => Psize p end. @@ -566,35 +566,35 @@ Definition Nsize (n:N) : nat := match n with (** conversions between N and bit vectors. *) -Fixpoint P2Bv (p:positive) : Bvector (Psize p) := - match p return Bvector (Psize p) with +Fixpoint P2Bv (p:positive) : Bvector (Psize p) := + match p return Bvector (Psize p) with | xH => Bvect_true 1%nat | xO p => Bcons false (Psize p) (P2Bv p) | xI p => Bcons true (Psize p) (P2Bv p) end. Definition N2Bv (n:N) : Bvector (Nsize n) := - match n as n0 return Bvector (Nsize n0) with + match n as n0 return Bvector (Nsize n0) with | N0 => Bnil | Npos p => P2Bv p end. -Fixpoint Bv2N (n:nat)(bv:Bvector n) {struct bv} : N := - match bv with +Fixpoint Bv2N (n:nat)(bv:Bvector n) : N := + match bv with | Vnil => N0 | Vcons false n bv => Ndouble (Bv2N n bv) - | Vcons true n bv => Ndouble_plus_one (Bv2N n bv) + | Vcons true n bv => Ndouble_plus_one (Bv2N n bv) end. Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n. -Proof. +Proof. destruct n. simpl; auto. induction p; simpl in *; auto; rewrite IHp; simpl; auto. Qed. -(** The opposite composition is not so simple: if the considered - bit vector has some zeros on its right, they will disappear during +(** The opposite composition is not so simple: if the considered + bit vector has some zeros on its right, they will disappear during the return [Bv2N] translation: *) Lemma Bv2N_Nsize : forall n (bv:Bvector n), Nsize (Bv2N n bv) <= n. @@ -603,16 +603,16 @@ induction n; intros. rewrite (V0_eq _ bv); simpl; auto. rewrite (VSn_eq _ _ bv); simpl. specialize IHn with (Vtail _ _ bv). -destruct (Vhead _ _ bv); - destruct (Bv2N n (Vtail bool n bv)); +destruct (Vhead _ _ bv); + destruct (Bv2N n (Vtail bool n bv)); simpl; auto with arith. Qed. (** In the previous lemma, we can only replace the inequality by an equality whenever the highest bit is non-null. *) -Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)), - Bsign _ bv = true <-> +Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)), + Bsign _ bv = true <-> Nsize (Bv2N _ bv) = (S n). Proof. induction n; intro. @@ -621,18 +621,18 @@ rewrite (V0_eq _ (Vtail _ _ bv)); simpl. destruct (Vhead _ _ bv); simpl; intuition; try discriminate. rewrite (VSn_eq _ _ bv); simpl. generalize (IHn (Vtail _ _ bv)); clear IHn. -destruct (Vhead _ _ bv); - destruct (Bv2N (S n) (Vtail bool (S n) bv)); +destruct (Vhead _ _ bv); + destruct (Bv2N (S n) (Vtail bool (S n) bv)); simpl; intuition; try discriminate. Qed. -(** To state nonetheless a second result about composition of - conversions, we define a conversion on a given number of bits : *) +(** To state nonetheless a second result about composition of + conversions, we define a conversion on a given number of bits : *) -Fixpoint N2Bv_gen (n:nat)(a:N) { struct n } : Bvector n := - match n return Bvector n with +Fixpoint N2Bv_gen (n:nat)(a:N) : Bvector n := + match n return Bvector n with | 0 => Bnil - | S n => match a with + | S n => match a with | N0 => Bvect_false (S n) | Npos xH => Bcons true _ (Bvect_false n) | Npos (xO p) => Bcons false _ (N2Bv_gen n (Npos p)) @@ -649,10 +649,10 @@ auto. induction p; simpl; intros; auto; congruence. Qed. -(** In fact, if [k] is large enough, [N2Bv_gen k a] contains all digits of +(** In fact, if [k] is large enough, [N2Bv_gen k a] contains all digits of [a] plus some zeros. *) -Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat), +Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat), N2Bv_gen (Nsize a + k) a = Vextend _ _ _ (N2Bv a) (Bvect_false k). Proof. destruct a; simpl. @@ -662,7 +662,7 @@ Qed. (** Here comes now the second composition result. *) -Lemma N2Bv_Bv2N : forall n (bv:Bvector n), +Lemma N2Bv_Bv2N : forall n (bv:Bvector n), N2Bv_gen n (Bv2N n bv) = bv. Proof. induction n; intros. @@ -670,36 +670,36 @@ rewrite (V0_eq _ bv); simpl; auto. rewrite (VSn_eq _ _ bv); simpl. generalize (IHn (Vtail _ _ bv)); clear IHn. unfold Bcons. -destruct (Bv2N _ (Vtail _ _ bv)); - destruct (Vhead _ _ bv); intro H; rewrite <- H; simpl; trivial; +destruct (Bv2N _ (Vtail _ _ bv)); + destruct (Vhead _ _ bv); intro H; rewrite <- H; simpl; trivial; induction n; simpl; auto. Qed. (** accessing some precise bits. *) -Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)), +Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)), Nbit0 (Bv2N _ bv) = Blow _ bv. Proof. intros. unfold Blow. rewrite (VSn_eq _ _ bv) at 1. simpl. -destruct (Bv2N n (Vtail bool n bv)); simpl; +destruct (Bv2N n (Vtail bool n bv)); simpl; destruct (Vhead bool n bv); auto. Qed. Definition Bnth (n:nat)(bv:Bvector n)(p:nat) : p bool. Proof. - induction 1. + induction bv in p |- *. intros. - elimtype False; inversion H. + exfalso; inversion H. intros. destruct p. exact a. apply (IHbv p); auto with arith. Defined. -Lemma Bnth_Nbit : forall n (bv:Bvector n) p (H:p a = N0. Proof. - simple induction a; trivial. + simple induction a; trivial. unfold Nplength in |- *; intros; discriminate H. Qed. @@ -42,7 +42,7 @@ Lemma Nplength_zeros : forall (a:N) (n:nat), Nplength a = ni n -> forall k:nat, k < n -> Nbit a k = false. Proof. - simple induction a; trivial. + simple induction a; trivial. simple induction p. simple induction n. intros. inversion H1. simple induction k. simpl in H1. discriminate H1. intros. simpl in H1. discriminate H1. @@ -116,11 +116,11 @@ Qed. Lemma ni_min_assoc : forall d d' d'':natinf, ni_min (ni_min d d') d'' = ni_min d (ni_min d' d''). Proof. - simple induction d; trivial. simple induction d'; trivial. + simple induction d; trivial. simple induction d'; trivial. simple induction d''; trivial. unfold ni_min in |- *. intro. cut (min (min n n0) n1 = min n (min n0 n1)). intro. rewrite H. reflexivity. - generalize n0 n1. elim n; trivial. + generalize n0 n1. elim n; trivial. simple induction n3; trivial. simple induction n5; trivial. intros. simpl in |- *. auto. Qed. @@ -250,10 +250,10 @@ Proof. Qed. -(** We define an ultrametric distance between [N] numbers: - $d(a,a')=1/2^pd(a,a')$, - where $pd(a,a')$ is the number of identical bits at the beginning - of $a$ and $a'$ (infinity if $a=a'$). +(** We define an ultrametric distance between [N] numbers: + $d(a,a')=1/2^pd(a,a')$, + where $pd(a,a')$ is the number of identical bits at the beginning + of $a$ and $a'$ (infinity if $a=a'$). Instead of working with $d$, we work with $pd$, namely [Npdist]: *) @@ -286,7 +286,7 @@ Qed. This follows from the fact that $a ~Ra~|a| = 1/2^{\texttt{Nplength}}(a))$ is an ultrametric norm, i.e. that $|a-a'| \leq max (|a-a''|, |a''-a'|)$, or equivalently that $|a+b|<=max(|a|,|b|)$, i.e. that - min $(\texttt{Nplength}(a), \texttt{Nplength}(b)) \leq + min $(\texttt{Nplength}(a), \texttt{Nplength}(b)) \leq \texttt{Nplength} (a~\texttt{xor}~ b)$ (lemma [Nplength_ultra]). *) diff --git a/theories/NArith/Nminmax.v b/theories/NArith/Nminmax.v new file mode 100644 index 00000000..475b4dfb --- /dev/null +++ b/theories/NArith/Nminmax.v @@ -0,0 +1,126 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Nmax x y = x. +Proof. + unfold Nle, Nmax. intros x y. + generalize (Ncompare_eq_correct x y). rewrite <- (Ncompare_antisym x y). + destruct (x ?= y); intuition. +Qed. + +Lemma Nmax_r : forall x y, x<=y -> Nmax x y = y. +Proof. + unfold Nle, Nmax. intros x y. destruct (x ?= y); intuition. +Qed. + +Lemma Nmin_l : forall x y, x<=y -> Nmin x y = x. +Proof. + unfold Nle, Nmin. intros x y. destruct (x ?= y); intuition. +Qed. + +Lemma Nmin_r : forall x y, y<=x -> Nmin x y = y. +Proof. + unfold Nle, Nmin. intros x y. + generalize (Ncompare_eq_correct x y). rewrite <- (Ncompare_antisym x y). + destruct (x ?= y); intuition. +Qed. + +Module NHasMinMax <: HasMinMax N_as_OT. + Definition max := Nmax. + Definition min := Nmin. + Definition max_l := Nmax_l. + Definition max_r := Nmax_r. + Definition min_l := Nmin_l. + Definition min_r := Nmin_r. +End NHasMinMax. + +Module N. + +(** We obtain hence all the generic properties of max and min. *) + +Include UsualMinMaxProperties N_as_OT NHasMinMax. + +(** * Properties specific to the [positive] domain *) + +(** Simplifications *) + +Lemma max_0_l : forall n, Nmax 0 n = n. +Proof. + intros. unfold Nmax. rewrite <- Ncompare_antisym. generalize (Ncompare_0 n). + destruct (n ?= 0); intuition. +Qed. + +Lemma max_0_r : forall n, Nmax n 0 = n. +Proof. intros. rewrite N.max_comm. apply max_0_l. Qed. + +Lemma min_0_l : forall n, Nmin 0 n = 0. +Proof. + intros. unfold Nmin. rewrite <- Ncompare_antisym. generalize (Ncompare_0 n). + destruct (n ?= 0); intuition. +Qed. + +Lemma min_0_r : forall n, Nmin n 0 = 0. +Proof. intros. rewrite N.min_comm. apply min_0_l. Qed. + +(** Compatibilities (consequences of monotonicity) *) + +Lemma succ_max_distr : + forall n m, Nsucc (Nmax n m) = Nmax (Nsucc n) (Nsucc m). +Proof. + intros. symmetry. apply max_monotone. + intros x x'. unfold Nle. + rewrite 2 nat_of_Ncompare, 2 nat_of_Nsucc. + simpl; auto. +Qed. + +Lemma succ_min_distr : forall n m, Nsucc (Nmin n m) = Nmin (Nsucc n) (Nsucc m). +Proof. + intros. symmetry. apply min_monotone. + intros x x'. unfold Nle. + rewrite 2 nat_of_Ncompare, 2 nat_of_Nsucc. + simpl; auto. +Qed. + +Lemma plus_max_distr_l : forall n m p, Nmax (p + n) (p + m) = p + Nmax n m. +Proof. + intros. apply max_monotone. + intros x x'. unfold Nle. + rewrite 2 nat_of_Ncompare, 2 nat_of_Nplus. + rewrite <- 2 Compare_dec.nat_compare_le. auto with arith. +Qed. + +Lemma plus_max_distr_r : forall n m p, Nmax (n + p) (m + p) = Nmax n m + p. +Proof. + intros. rewrite (Nplus_comm n p), (Nplus_comm m p), (Nplus_comm _ p). + apply plus_max_distr_l. +Qed. + +Lemma plus_min_distr_l : forall n m p, Nmin (p + n) (p + m) = p + Nmin n m. +Proof. + intros. apply min_monotone. + intros x x'. unfold Nle. + rewrite 2 nat_of_Ncompare, 2 nat_of_Nplus. + rewrite <- 2 Compare_dec.nat_compare_le. auto with arith. +Qed. + +Lemma plus_min_distr_r : forall n m p, Nmin (n + p) (m + p) = Nmin n m + p. +Proof. + intros. rewrite (Nplus_comm n p), (Nplus_comm m p), (Nplus_comm _ p). + apply plus_min_distr_l. +Qed. + +End N. \ No newline at end of file diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v index bc3711ee..0016d035 100644 --- a/theories/NArith/Nnat.v +++ b/theories/NArith/Nnat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Nnat.v 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id$ i*) Require Import Arith_base. Require Import Compare_dec. @@ -39,7 +39,7 @@ Definition N_of_nat (n:nat) := Lemma N_of_nat_of_N : forall a:N, N_of_nat (nat_of_N a) = a. Proof. destruct a as [| p]. reflexivity. - simpl in |- *. elim (ZL4 p). intros n H. rewrite H. simpl in |- *. + simpl in |- *. elim (ZL4 p). intros n H. rewrite H. simpl in |- *. rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H. rewrite nat_of_P_inj with (1 := H). reflexivity. Qed. @@ -66,14 +66,14 @@ Proof. apply N_of_nat_of_N. Qed. -Lemma nat_of_Ndouble_plus_one : +Lemma nat_of_Ndouble_plus_one : forall a, nat_of_N (Ndouble_plus_one a) = S (2*(nat_of_N a)). Proof. destruct a; simpl nat_of_N; auto. apply nat_of_P_xI. Qed. -Lemma N_of_double_plus_one : +Lemma N_of_double_plus_one : forall n, N_of_nat (S (2*n)) = Ndouble_plus_one (N_of_nat n). Proof. intros. @@ -97,14 +97,14 @@ Proof. apply N_of_nat_of_N. Qed. -Lemma nat_of_Nplus : +Lemma nat_of_Nplus : forall a a', nat_of_N (Nplus a a') = (nat_of_N a)+(nat_of_N a'). Proof. destruct a; destruct a'; simpl; auto. apply nat_of_P_plus_morphism. Qed. -Lemma N_of_plus : +Lemma N_of_plus : forall n n', N_of_nat (n+n') = Nplus (N_of_nat n) (N_of_nat n'). Proof. intros. @@ -138,14 +138,14 @@ Proof. apply N_of_nat_of_N. Qed. -Lemma nat_of_Nmult : +Lemma nat_of_Nmult : forall a a', nat_of_N (Nmult a a') = (nat_of_N a)*(nat_of_N a'). Proof. destruct a; destruct a'; simpl; auto. apply nat_of_P_mult_morphism. Qed. -Lemma N_of_mult : +Lemma N_of_mult : forall n n', N_of_nat (n*n') = Nmult (N_of_nat n) (N_of_nat n'). Proof. intros. @@ -155,7 +155,7 @@ Proof. apply N_of_nat_of_N. Qed. -Lemma nat_of_Ndiv2 : +Lemma nat_of_Ndiv2 : forall a, nat_of_N (Ndiv2 a) = div2 (nat_of_N a). Proof. destruct a; simpl in *; auto. @@ -164,9 +164,9 @@ Proof. rewrite div2_double_plus_one; auto. rewrite nat_of_P_xO. rewrite div2_double; auto. -Qed. +Qed. -Lemma N_of_div2 : +Lemma N_of_div2 : forall n, N_of_nat (div2 n) = Ndiv2 (N_of_nat n). Proof. intros. @@ -175,29 +175,19 @@ Proof. apply N_of_nat_of_N. Qed. -Lemma nat_of_Ncompare : +Lemma nat_of_Ncompare : forall a a', Ncompare a a' = nat_compare (nat_of_N a) (nat_of_N a'). Proof. destruct a; destruct a'; simpl. - compute; auto. - generalize (lt_O_nat_of_P p). - unfold nat_compare. - destruct (lt_eq_lt_dec 0 (nat_of_P p)) as [[H|H]|H]; auto. - rewrite <- H; inversion 1. - intros; generalize (lt_trans _ _ _ H0 H); inversion 1. - generalize (lt_O_nat_of_P p). - unfold nat_compare. - destruct (lt_eq_lt_dec (nat_of_P p) 0) as [[H|H]|H]; auto. - intros; generalize (lt_trans _ _ _ H0 H); inversion 1. - rewrite H; inversion 1. - unfold nat_compare. - destruct (lt_eq_lt_dec (nat_of_P p) (nat_of_P p0)) as [[H|H]|H]; auto. - apply nat_of_P_lt_Lt_compare_complement_morphism; auto. - rewrite (nat_of_P_inj _ _ H); apply Pcompare_refl. - apply nat_of_P_gt_Gt_compare_complement_morphism; auto. -Qed. - -Lemma N_of_nat_compare : + reflexivity. + assert (NZ : 0 < nat_of_P p) by auto using lt_O_nat_of_P. + destruct nat_of_P; [inversion NZ|auto]. + assert (NZ : 0 < nat_of_P p) by auto using lt_O_nat_of_P. + destruct nat_of_P; [inversion NZ|auto]. + apply nat_of_P_compare_morphism. +Qed. + +Lemma N_of_nat_compare : forall n n', nat_compare n n' = Ncompare (N_of_nat n) (N_of_nat n'). Proof. intros. @@ -210,8 +200,8 @@ Lemma nat_of_Nmin : forall a a', nat_of_N (Nmin a a') = min (nat_of_N a) (nat_of_N a'). Proof. intros; unfold Nmin; rewrite nat_of_Ncompare. - unfold nat_compare. - destruct (lt_eq_lt_dec (nat_of_N a) (nat_of_N a')) as [[|]|]; + rewrite nat_compare_equiv; unfold nat_compare_alt. + destruct (lt_eq_lt_dec (nat_of_N a) (nat_of_N a')) as [[|]|]; simpl; intros; symmetry; auto with arith. apply min_l; rewrite e; auto with arith. Qed. @@ -230,8 +220,8 @@ Lemma nat_of_Nmax : forall a a', nat_of_N (Nmax a a') = max (nat_of_N a) (nat_of_N a'). Proof. intros; unfold Nmax; rewrite nat_of_Ncompare. - unfold nat_compare. - destruct (lt_eq_lt_dec (nat_of_N a) (nat_of_N a')) as [[|]|]; + rewrite nat_compare_equiv; unfold nat_compare_alt. + destruct (lt_eq_lt_dec (nat_of_N a) (nat_of_N a')) as [[|]|]; simpl; intros; symmetry; auto with arith. apply max_r; rewrite e; auto with arith. Qed. @@ -331,17 +321,17 @@ Qed. Lemma Z_of_N_of_nat : forall n:nat, Z_of_N (N_of_nat n) = Z_of_nat n. Proof. destruct n; simpl; auto. -Qed. +Qed. Lemma Z_of_N_pos : forall p:positive, Z_of_N (Npos p) = Zpos p. Proof. destruct p; simpl; auto. -Qed. +Qed. Lemma Z_of_N_abs : forall z:Z, Z_of_N (Zabs_N z) = Zabs z. Proof. destruct z; simpl; auto. -Qed. +Qed. Lemma Z_of_N_le_0 : forall n, (0 <= Z_of_N n)%Z. Proof. @@ -358,22 +348,22 @@ Proof. destruct n; destruct m; auto. Qed. -Lemma Z_of_N_minus : forall n m:N, Z_of_N (n-m) = Zmax 0 (Z_of_N n - Z_of_N m). +Lemma Z_of_N_minus : forall n m:N, Z_of_N (n-m) = Zmax 0 (Z_of_N n - Z_of_N m). Proof. intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nminus; apply inj_minus. Qed. -Lemma Z_of_N_succ : forall n:N, Z_of_N (Nsucc n) = Zsucc (Z_of_N n). +Lemma Z_of_N_succ : forall n:N, Z_of_N (Nsucc n) = Zsucc (Z_of_N n). Proof. intros; do 2 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nsucc; apply inj_S. Qed. -Lemma Z_of_N_min : forall n m:N, Z_of_N (Nmin n m) = Zmin (Z_of_N n) (Z_of_N m). +Lemma Z_of_N_min : forall n m:N, Z_of_N (Nmin n m) = Zmin (Z_of_N n) (Z_of_N m). Proof. intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmin; apply inj_min. Qed. -Lemma Z_of_N_max : forall n m:N, Z_of_N (Nmax n m) = Zmax (Z_of_N n) (Z_of_N m). +Lemma Z_of_N_max : forall n m:N, Z_of_N (Nmax n m) = Zmax (Z_of_N n) (Z_of_N m). Proof. intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmax; apply inj_max. Qed. diff --git a/theories/NArith/POrderedType.v b/theories/NArith/POrderedType.v new file mode 100644 index 00000000..9c0f8261 --- /dev/null +++ b/theories/NArith/POrderedType.v @@ -0,0 +1,60 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Logic.eq==>iff) Plt. + Proof. repeat red; intros; subst; auto. Qed. + + Definition le_lteq := Ple_lteq. + Definition compare_spec := Pcompare_spec. + +End Positive_as_OT. + +(** Note that [Positive_as_OT] can also be seen as a [UsualOrderedType] + and a [OrderedType] (and also as a [DecidableType]). *) + + + +(** * An [order] tactic for positive numbers *) + +Module PositiveOrder := OTF_to_OrderTac Positive_as_OT. +Ltac p_order := PositiveOrder.order. + +(** Note that [p_order] is domain-agnostic: it will not prove + [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) diff --git a/theories/NArith/Pminmax.v b/theories/NArith/Pminmax.v new file mode 100644 index 00000000..4cc48af6 --- /dev/null +++ b/theories/NArith/Pminmax.v @@ -0,0 +1,126 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Pmax x y = x. +Proof. + unfold Ple, Pmax. intros x y. + rewrite (ZC4 y x). generalize (Pcompare_eq_iff x y). + destruct ((x ?= y) Eq); intuition. +Qed. + +Lemma Pmax_r : forall x y, x<=y -> Pmax x y = y. +Proof. + unfold Ple, Pmax. intros x y. destruct ((x ?= y) Eq); intuition. +Qed. + +Lemma Pmin_l : forall x y, x<=y -> Pmin x y = x. +Proof. + unfold Ple, Pmin. intros x y. destruct ((x ?= y) Eq); intuition. +Qed. + +Lemma Pmin_r : forall x y, y<=x -> Pmin x y = y. +Proof. + unfold Ple, Pmin. intros x y. + rewrite (ZC4 y x). generalize (Pcompare_eq_iff x y). + destruct ((x ?= y) Eq); intuition. +Qed. + +Module PositiveHasMinMax <: HasMinMax Positive_as_OT. + Definition max := Pmax. + Definition min := Pmin. + Definition max_l := Pmax_l. + Definition max_r := Pmax_r. + Definition min_l := Pmin_l. + Definition min_r := Pmin_r. +End PositiveHasMinMax. + + +Module P. +(** We obtain hence all the generic properties of max and min. *) + +Include UsualMinMaxProperties Positive_as_OT PositiveHasMinMax. + +(** * Properties specific to the [positive] domain *) + +(** Simplifications *) + +Lemma max_1_l : forall n, Pmax 1 n = n. +Proof. + intros. unfold Pmax. rewrite ZC4. generalize (Pcompare_1 n). + destruct (n ?= 1); intuition. +Qed. + +Lemma max_1_r : forall n, Pmax n 1 = n. +Proof. intros. rewrite P.max_comm. apply max_1_l. Qed. + +Lemma min_1_l : forall n, Pmin 1 n = 1. +Proof. + intros. unfold Pmin. rewrite ZC4. generalize (Pcompare_1 n). + destruct (n ?= 1); intuition. +Qed. + +Lemma min_1_r : forall n, Pmin n 1 = 1. +Proof. intros. rewrite P.min_comm. apply min_1_l. Qed. + +(** Compatibilities (consequences of monotonicity) *) + +Lemma succ_max_distr : + forall n m, Psucc (Pmax n m) = Pmax (Psucc n) (Psucc m). +Proof. + intros. symmetry. apply max_monotone. + intros x x'. unfold Ple. + rewrite 2 nat_of_P_compare_morphism, 2 nat_of_P_succ_morphism. + simpl; auto. +Qed. + +Lemma succ_min_distr : forall n m, Psucc (Pmin n m) = Pmin (Psucc n) (Psucc m). +Proof. + intros. symmetry. apply min_monotone. + intros x x'. unfold Ple. + rewrite 2 nat_of_P_compare_morphism, 2 nat_of_P_succ_morphism. + simpl; auto. +Qed. + +Lemma plus_max_distr_l : forall n m p, Pmax (p + n) (p + m) = p + Pmax n m. +Proof. + intros. apply max_monotone. + intros x x'. unfold Ple. + rewrite 2 nat_of_P_compare_morphism, 2 nat_of_P_plus_morphism. + rewrite <- 2 Compare_dec.nat_compare_le. auto with arith. +Qed. + +Lemma plus_max_distr_r : forall n m p, Pmax (n + p) (m + p) = Pmax n m + p. +Proof. + intros. rewrite (Pplus_comm n p), (Pplus_comm m p), (Pplus_comm _ p). + apply plus_max_distr_l. +Qed. + +Lemma plus_min_distr_l : forall n m p, Pmin (p + n) (p + m) = p + Pmin n m. +Proof. + intros. apply min_monotone. + intros x x'. unfold Ple. + rewrite 2 nat_of_P_compare_morphism, 2 nat_of_P_plus_morphism. + rewrite <- 2 Compare_dec.nat_compare_le. auto with arith. +Qed. + +Lemma plus_min_distr_r : forall n m p, Pmin (n + p) (m + p) = Pmin n m + p. +Proof. + intros. rewrite (Pplus_comm n p), (Pplus_comm m p), (Pplus_comm _ p). + apply plus_min_distr_l. +Qed. + +End P. \ No newline at end of file diff --git a/theories/NArith/Pnat.v b/theories/NArith/Pnat.v index 2c007398..0891dea2 100644 --- a/theories/NArith/Pnat.v +++ b/theories/NArith/Pnat.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* nat_of_P p < nat_of_P q. + forall p q:positive, (p ?= q) Eq = Lt -> nat_of_P p < nat_of_P q. Proof. intro x; induction x as [p H| p H| ]; intro y; destruct y as [q| q| ]; intro H2; @@ -178,7 +183,7 @@ intro x; induction x as [p H| p H| ]; intro y; destruct y as [q| q| ]; apply ZL7; apply H; assumption | simpl in |- *; discriminate H2 | unfold nat_of_P in |- *; simpl in |- *; apply lt_n_S; rewrite ZL6; - elim (ZL4 q); intros h H3; rewrite H3; simpl in |- *; + elim (ZL4 q); intros h H3; rewrite H3; simpl in |- *; apply lt_O_Sn | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 q); intros h H3; rewrite H3; simpl in |- *; rewrite <- plus_n_Sm; @@ -193,29 +198,35 @@ Qed. *) Lemma nat_of_P_gt_Gt_compare_morphism : - forall p q:positive, (p ?= q)%positive Eq = Gt -> nat_of_P p > nat_of_P q. + forall p q:positive, (p ?= q) Eq = Gt -> nat_of_P p > nat_of_P q. Proof. -unfold gt in |- *; intro x; induction x as [p H| p H| ]; intro y; - destruct y as [q| q| ]; intro H2; - [ simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6; - apply lt_n_S; apply ZL7; apply H; assumption - | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6; - elim (Pcompare_Gt_Gt p q H2); - [ intros H3; apply lt_S; apply ZL7; apply H; assumption - | intros E; rewrite E; apply lt_n_Sn ] - | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 p); - intros h H3; rewrite H3; simpl in |- *; apply lt_n_S; - apply lt_O_Sn - | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6; - apply ZL8; apply H; apply Pcompare_Lt_Gt; assumption - | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6; - apply ZL7; apply H; assumption - | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 p); - intros h H3; rewrite H3; simpl in |- *; rewrite <- plus_n_Sm; - apply lt_n_S; apply lt_O_Sn - | simpl in |- *; discriminate H2 - | simpl in |- *; discriminate H2 - | simpl in |- *; discriminate H2 ]. +intros p q GT. unfold gt. +apply nat_of_P_lt_Lt_compare_morphism. +change ((q ?= p) (CompOpp Eq) = CompOpp Gt). +rewrite <- Pcompare_antisym, GT; auto. +Qed. + +(** [nat_of_P] is a morphism for [Pcompare] and [nat_compare] *) + +Lemma nat_of_P_compare_morphism : forall p q, + (p ?= q) Eq = nat_compare (nat_of_P p) (nat_of_P q). +Proof. + intros p q; symmetry. + destruct ((p ?= q) Eq) as [ | | ]_eqn. + rewrite (Pcompare_Eq_eq p q); auto. + apply <- nat_compare_eq_iff; auto. + apply -> nat_compare_lt. apply nat_of_P_lt_Lt_compare_morphism; auto. + apply -> nat_compare_gt. apply nat_of_P_gt_Gt_compare_morphism; auto. +Qed. + +(** [nat_of_P] is hence injective. *) + +Lemma nat_of_P_inj : forall p q:positive, nat_of_P p = nat_of_P q -> p = q. +Proof. +intros. +apply Pcompare_Eq_eq. +rewrite nat_of_P_compare_morphism. +apply <- nat_compare_eq_iff; auto. Qed. (** [nat_of_P] is a morphism from [positive] to [nat] for [lt] (expressed @@ -225,17 +236,10 @@ Qed. *) Lemma nat_of_P_lt_Lt_compare_complement_morphism : - forall p q:positive, nat_of_P p < nat_of_P q -> (p ?= q)%positive Eq = Lt. + forall p q:positive, nat_of_P p < nat_of_P q -> (p ?= q) Eq = Lt. Proof. -intros x y; unfold gt in |- *; elim (Dcompare ((x ?= y)%positive Eq)); - [ intros E; rewrite (Pcompare_Eq_eq x y E); intros H; - absurd (nat_of_P y < nat_of_P y); [ apply lt_irrefl | assumption ] - | intros H; elim H; - [ auto - | intros H1 H2; absurd (nat_of_P x < nat_of_P y); - [ apply lt_asym; change (nat_of_P x > nat_of_P y) in |- *; - apply nat_of_P_gt_Gt_compare_morphism; assumption - | assumption ] ] ]. + intros. rewrite nat_of_P_compare_morphism. + apply -> nat_compare_lt; auto. Qed. (** [nat_of_P] is a morphism from [positive] to [nat] for [gt] (expressed @@ -245,18 +249,13 @@ Qed. *) Lemma nat_of_P_gt_Gt_compare_complement_morphism : - forall p q:positive, nat_of_P p > nat_of_P q -> (p ?= q)%positive Eq = Gt. + forall p q:positive, nat_of_P p > nat_of_P q -> (p ?= q) Eq = Gt. Proof. -intros x y; unfold gt in |- *; elim (Dcompare ((x ?= y)%positive Eq)); - [ intros E; rewrite (Pcompare_Eq_eq x y E); intros H; - absurd (nat_of_P y < nat_of_P y); [ apply lt_irrefl | assumption ] - | intros H; elim H; - [ intros H1 H2; absurd (nat_of_P y < nat_of_P x); - [ apply lt_asym; apply nat_of_P_lt_Lt_compare_morphism; assumption - | assumption ] - | auto ] ]. + intros. rewrite nat_of_P_compare_morphism. + apply -> nat_compare_gt; auto. Qed. + (** [nat_of_P] is strictly positive *) Lemma le_Pmult_nat : forall (p:positive) (n:nat), n <= Pmult_nat p n. @@ -301,25 +300,22 @@ Qed. Lemma nat_of_P_xO : forall p:positive, nat_of_P (xO p) = 2 * nat_of_P p. Proof. - simple induction p. unfold nat_of_P in |- *. simpl in |- *. intros. rewrite Pmult_nat_2_mult_2_permute. - rewrite Pmult_nat_4_mult_2_permute. rewrite H. simpl in |- *. rewrite <- plus_Snm_nSm. reflexivity. - unfold nat_of_P in |- *. simpl in |- *. intros. rewrite Pmult_nat_2_mult_2_permute. rewrite Pmult_nat_4_mult_2_permute. - rewrite H. reflexivity. - reflexivity. + intros. + change 2 with (nat_of_P 2). + rewrite <- nat_of_P_mult_morphism. + f_equal. Qed. Lemma nat_of_P_xI : forall p:positive, nat_of_P (xI p) = S (2 * nat_of_P p). Proof. - simple induction p. unfold nat_of_P in |- *. simpl in |- *. intro p0. intro. rewrite Pmult_nat_2_mult_2_permute. - rewrite Pmult_nat_4_mult_2_permute; injection H; intro H1; rewrite H1; - rewrite <- plus_Snm_nSm; reflexivity. - unfold nat_of_P in |- *. simpl in |- *. intros. rewrite Pmult_nat_2_mult_2_permute. rewrite Pmult_nat_4_mult_2_permute. - injection H; intro H1; rewrite H1; reflexivity. - reflexivity. + intros. + change 2 with (nat_of_P 2). + rewrite <- nat_of_P_mult_morphism, <- nat_of_P_succ_morphism. + f_equal. Qed. (**********************************************************************) -(** Properties of the shifted injection from Peano natural numbers to +(** Properties of the shifted injection from Peano natural numbers to binary positive numbers *) (** Composition of [P_of_succ_nat] and [nat_of_P] is successor on [nat] *) @@ -327,9 +323,9 @@ Qed. Theorem nat_of_P_o_P_of_succ_nat_eq_succ : forall n:nat, nat_of_P (P_of_succ_nat n) = S n. Proof. -intro m; induction m as [| n H]; - [ reflexivity - | simpl in |- *; rewrite nat_of_P_succ_morphism; rewrite H; auto ]. +induction n as [|n H]. +reflexivity. +simpl; rewrite nat_of_P_succ_morphism, H; auto. Qed. (** Miscellaneous lemmas on [P_of_succ_nat] *) @@ -337,17 +333,17 @@ Qed. Lemma ZL3 : forall n:nat, Psucc (P_of_succ_nat (n + n)) = xO (P_of_succ_nat n). Proof. -intro x; induction x as [| n H]; - [ simpl in |- *; auto with arith - | simpl in |- *; rewrite plus_comm; simpl in |- *; rewrite H; +induction n as [| n H]; simpl; + [ auto with arith + | rewrite plus_comm; simpl; rewrite H; rewrite xO_succ_permute; auto with arith ]. Qed. Lemma ZL5 : forall n:nat, P_of_succ_nat (S n + S n) = xI (P_of_succ_nat n). Proof. -intro x; induction x as [| n H]; simpl in |- *; +induction n as [| n H]; simpl; [ auto with arith - | rewrite <- plus_n_Sm; simpl in |- *; simpl in H; rewrite H; + | rewrite <- plus_n_Sm; simpl; simpl in H; rewrite H; auto with arith ]. Qed. @@ -356,19 +352,9 @@ Qed. Theorem P_of_succ_nat_o_nat_of_P_eq_succ : forall p:positive, P_of_succ_nat (nat_of_P p) = Psucc p. Proof. -intro x; induction x as [p H| p H| ]; - [ simpl in |- *; rewrite <- H; change 2 with (1 + 1) in |- *; - rewrite Pmult_nat_r_plus_morphism; elim (ZL4 p); - unfold nat_of_P in |- *; intros n H1; rewrite H1; - rewrite ZL3; auto with arith - | unfold nat_of_P in |- *; simpl in |- *; change 2 with (1 + 1) in |- *; - rewrite Pmult_nat_r_plus_morphism; - rewrite <- (Ppred_succ (P_of_succ_nat (Pmult_nat p 1 + Pmult_nat p 1))); - rewrite <- (Ppred_succ (xI p)); simpl in |- *; - rewrite <- H; elim (ZL4 p); unfold nat_of_P in |- *; - intros n H1; rewrite H1; rewrite ZL5; simpl in |- *; - trivial with arith - | unfold nat_of_P in |- *; simpl in |- *; auto with arith ]. +intros. +apply nat_of_P_inj. +rewrite nat_of_P_o_P_of_succ_nat_eq_succ, nat_of_P_succ_morphism; auto. Qed. (** Composition of [nat_of_P], [P_of_succ_nat] and [Ppred] is identity @@ -377,45 +363,36 @@ Qed. Theorem pred_o_P_of_succ_nat_o_nat_of_P_eq_id : forall p:positive, Ppred (P_of_succ_nat (nat_of_P p)) = p. Proof. -intros x; rewrite P_of_succ_nat_o_nat_of_P_eq_succ; rewrite Ppred_succ; - trivial with arith. +intros; rewrite P_of_succ_nat_o_nat_of_P_eq_succ, Ppred_succ; auto. Qed. (**********************************************************************) -(** Extra properties of the injection from binary positive numbers to Peano +(** Extra properties of the injection from binary positive numbers to Peano natural numbers *) (** [nat_of_P] is a morphism for subtraction on positive numbers *) Theorem nat_of_P_minus_morphism : forall p q:positive, - (p ?= q)%positive Eq = Gt -> nat_of_P (p - q) = nat_of_P p - nat_of_P q. + (p ?= q) Eq = Gt -> nat_of_P (p - q) = nat_of_P p - nat_of_P q. Proof. intros x y H; apply plus_reg_l with (nat_of_P y); rewrite le_plus_minus_r; [ rewrite <- nat_of_P_plus_morphism; rewrite Pplus_minus; auto with arith | apply lt_le_weak; exact (nat_of_P_gt_Gt_compare_morphism x y H) ]. Qed. -(** [nat_of_P] is injective *) - -Lemma nat_of_P_inj : forall p q:positive, nat_of_P p = nat_of_P q -> p = q. -Proof. -intros x y H; rewrite <- (pred_o_P_of_succ_nat_o_nat_of_P_eq_id x); - rewrite <- (pred_o_P_of_succ_nat_o_nat_of_P_eq_id y); - rewrite H; trivial with arith. -Qed. Lemma ZL16 : forall p q:positive, nat_of_P p - nat_of_P q < nat_of_P p. Proof. intros p q; elim (ZL4 p); elim (ZL4 q); intros h H1 i H2; rewrite H1; - rewrite H2; simpl in |- *; unfold lt in |- *; apply le_n_S; + rewrite H2; simpl in |- *; unfold lt in |- *; apply le_n_S; apply le_minus. Qed. Lemma ZL17 : forall p q:positive, nat_of_P p < nat_of_P (p + q). Proof. intros p q; rewrite nat_of_P_plus_morphism; unfold lt in |- *; elim (ZL4 q); - intros k H; rewrite H; rewrite plus_comm; simpl in |- *; + intros k H; rewrite H; rewrite plus_comm; simpl in |- *; apply le_n_S; apply le_plus_r. Qed. @@ -423,9 +400,9 @@ Qed. Lemma Pcompare_minus_r : forall p q r:positive, - (q ?= p)%positive Eq = Lt -> - (r ?= p)%positive Eq = Gt -> - (r ?= q)%positive Eq = Gt -> (r - p ?= r - q)%positive Eq = Lt. + (q ?= p) Eq = Lt -> + (r ?= p) Eq = Gt -> + (r ?= q) Eq = Gt -> (r - p ?= r - q) Eq = Lt. Proof. intros; apply nat_of_P_lt_Lt_compare_complement_morphism; rewrite nat_of_P_minus_morphism; @@ -434,7 +411,7 @@ intros; apply nat_of_P_lt_Lt_compare_complement_morphism; [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p); rewrite plus_assoc; rewrite le_plus_minus_r; [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l; - apply nat_of_P_lt_Lt_compare_morphism; + apply nat_of_P_lt_Lt_compare_morphism; assumption | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption ] @@ -446,9 +423,9 @@ Qed. Lemma Pcompare_minus_l : forall p q r:positive, - (q ?= p)%positive Eq = Lt -> - (p ?= r)%positive Eq = Gt -> - (q ?= r)%positive Eq = Gt -> (q - r ?= p - r)%positive Eq = Lt. + (q ?= p) Eq = Lt -> + (p ?= r) Eq = Gt -> + (q ?= r) Eq = Gt -> (q - r ?= p - r) Eq = Lt. Proof. intros p q z; intros; apply nat_of_P_lt_Lt_compare_complement_morphism; rewrite nat_of_P_minus_morphism; @@ -469,8 +446,8 @@ Qed. Theorem Pmult_minus_distr_l : forall p q r:positive, - (q ?= r)%positive Eq = Gt -> - (p * (q - r))%positive = (p * q - p * r)%positive. + (q ?= r) Eq = Gt -> + (p * (q - r) = p * q - p * r)%positive. Proof. intros x y z H; apply nat_of_P_inj; rewrite nat_of_P_mult_morphism; rewrite nat_of_P_minus_morphism; @@ -478,7 +455,7 @@ intros x y z H; apply nat_of_P_inj; rewrite nat_of_P_mult_morphism; [ do 2 rewrite nat_of_P_mult_morphism; do 3 rewrite (mult_comm (nat_of_P x)); apply mult_minus_distr_r | apply nat_of_P_gt_Gt_compare_complement_morphism; - do 2 rewrite nat_of_P_mult_morphism; unfold gt in |- *; + do 2 rewrite nat_of_P_mult_morphism; unfold gt in |- *; elim (ZL4 x); intros h H1; rewrite H1; apply mult_S_lt_compat_l; exact (nat_of_P_gt_Gt_compare_morphism y z H) ] | assumption ]. diff --git a/theories/NArith/vo.itarget b/theories/NArith/vo.itarget new file mode 100644 index 00000000..32f94f01 --- /dev/null +++ b/theories/NArith/vo.itarget @@ -0,0 +1,12 @@ +BinNat.vo +BinPos.vo +NArith.vo +Ndec.vo +Ndigits.vo +Ndist.vo +Nnat.vo +Pnat.vo +POrderedType.vo +Pminmax.vo +NOrderedType.vo +Nminmax.vo diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v index 83ecd10d..dd7d9046 100644 --- a/theories/Numbers/BigNumPrelude.v +++ b/theories/Numbers/BigNumPrelude.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: BigNumPrelude.v 11207 2008-07-04 16:50:32Z letouzey $ i*) +(*i $Id$ i*) (** * BigNumPrelude *) @@ -21,6 +21,8 @@ Require Export ZArith. Require Export Znumtheory. Require Export Zpow_facts. +Declare ML Module "numbers_syntax_plugin". + (* *** Nota Bene *** All results that were general enough has been moved in ZArith. Only remain here specialized lemmas and compatibility elements. @@ -28,8 +30,8 @@ Require Export Zpow_facts. *) -Open Local Scope Z_scope. - +Local Open Scope Z_scope. + (* For compatibility of scripts, weaker version of some lemmas of Zdiv *) Lemma Zlt0_not_eq : forall n, 0 n<>0. @@ -43,14 +45,14 @@ Definition Z_div_plus_l a b c H := Zdiv.Z_div_plus_full_l a b c (Zlt0_not_eq _ H (* Automation *) -Hint Extern 2 (Zle _ _) => +Hint Extern 2 (Zle _ _) => (match goal with |- Zpos _ <= Zpos _ => exact (refl_equal _) | H: _ <= ?p |- _ <= ?p => apply Zle_trans with (2 := H) | H: _ < ?p |- _ <= ?p => apply Zlt_le_weak; apply Zle_lt_trans with (2 := H) end). -Hint Extern 2 (Zlt _ _) => +Hint Extern 2 (Zlt _ _) => (match goal with |- Zpos _ < Zpos _ => exact (refl_equal _) | H: _ <= ?p |- _ <= ?p => apply Zlt_le_trans with (2 := H) @@ -60,13 +62,13 @@ Hint Extern 2 (Zlt _ _) => Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. -(************************************** +(************************************** Properties of order and product **************************************) - Theorem beta_lex: forall a b c d beta, - a * beta + b <= c * beta + d -> - 0 <= b < beta -> 0 <= d < beta -> + Theorem beta_lex: forall a b c d beta, + a * beta + b <= c * beta + d -> + 0 <= b < beta -> 0 <= d < beta -> a <= c. Proof. intros a b c d beta H1 (H3, H4) (H5, H6). @@ -78,15 +80,15 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. Theorem beta_lex_inv: forall a b c d beta, a < c -> 0 <= b < beta -> - 0 <= d < beta -> - a * beta + b < c * beta + d. + 0 <= d < beta -> + a * beta + b < c * beta + d. Proof. intros a b c d beta H1 (H3, H4) (H5, H6). case (Zle_or_lt (c * beta + d) (a * beta + b)); auto with zarith. intros H7; contradict H1;apply Zle_not_lt;apply beta_lex with (1 := H7);auto. Qed. - Lemma beta_mult : forall h l beta, + Lemma beta_mult : forall h l beta, 0 <= h < beta -> 0 <= l < beta -> 0 <= h*beta+l < beta^2. Proof. intros h l beta H1 H2;split. auto with zarith. @@ -94,7 +96,7 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. apply beta_lex_inv;auto with zarith. Qed. - Lemma Zmult_lt_b : + Lemma Zmult_lt_b : forall b x y, 0 <= x < b -> 0 <= y < b -> 0 <= x * y <= b^2 - 2*b + 1. Proof. intros b x y (Hx1,Hx2) (Hy1,Hy2);split;auto with zarith. @@ -104,17 +106,17 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. Qed. Lemma sum_mul_carry : forall xh xl yh yl wc cc beta, - 1 < beta -> + 1 < beta -> 0 <= wc < beta -> 0 <= xh < beta -> 0 <= xl < beta -> 0 <= yh < beta -> 0 <= yl < beta -> 0 <= cc < beta^2 -> - wc*beta^2 + cc = xh*yl + xl*yh -> + wc*beta^2 + cc = xh*yl + xl*yh -> 0 <= wc <= 1. Proof. - intros xh xl yh yl wc cc beta U H1 H2 H3 H4 H5 H6 H7. + intros xh xl yh yl wc cc beta U H1 H2 H3 H4 H5 H6 H7. assert (H8 := Zmult_lt_b beta xh yl H2 H5). assert (H9 := Zmult_lt_b beta xl yh H3 H4). split;auto with zarith. @@ -132,7 +134,7 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. apply Zle_lt_trans with ((beta-1)*(beta-1)+(beta-1)); auto with zarith. apply Zplus_le_compat; auto with zarith. apply Zmult_le_compat; auto with zarith. - repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); + repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); rewrite Zpower_2; auto with zarith. Qed. @@ -147,7 +149,7 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. apply Zle_lt_trans with ((beta-1)*(beta-1)+(2*beta-2));auto with zarith. apply Zplus_le_compat; auto with zarith. apply Zmult_le_compat; auto with zarith. - repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); + repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); rewrite Zpower_2; auto with zarith. Qed. @@ -199,9 +201,9 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. apply Zplus_le_lt_compat; auto with zarith. replace b with ((b - a) + a); try ring. rewrite Zpower_exp; auto with zarith. - pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); + pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); try rewrite <- Zmult_minus_distr_r. - rewrite (Zmult_comm (2 ^(b - a))); rewrite Zmult_mod_distr_l; + rewrite (Zmult_comm (2 ^(b - a))); rewrite Zmult_mod_distr_l; auto with zarith. rewrite (Zmult_comm (2 ^a)); apply Zmult_le_compat_r; auto with zarith. match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; @@ -222,22 +224,22 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. split; auto with zarith. assert (0 <= 2 ^a * r); auto with zarith. apply Zplus_le_0_compat; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; auto with zarith. pattern (2 ^ b) at 2;replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); try ring. apply Zplus_le_lt_compat; auto with zarith. replace b with ((b - a) + a); try ring. rewrite Zpower_exp; auto with zarith. - pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); + pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); try rewrite <- Zmult_minus_distr_r. repeat rewrite (fun x => Zmult_comm x (2 ^ a)); rewrite Zmult_mod_distr_l; auto with zarith. apply Zmult_le_compat_l; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; auto with zarith. Qed. - Theorem Zdiv_shift_r: + Theorem Zdiv_shift_r: forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> (r * 2 ^a + t) / (2 ^ b) = (r * 2 ^a) / (2 ^ b). Proof. @@ -251,7 +253,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. rewrite <- Zmod_shift_r; auto with zarith. rewrite (Zmult_comm (2 ^ b)); rewrite Z_div_plus_full_l; auto with zarith. rewrite (fun x y => @Zdiv_small (x mod y)); auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; auto with zarith. Qed. @@ -262,8 +264,8 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. a * 2^p = a / 2^(n - p) * 2^n + (a*2^p) mod 2^n. Proof. intros n p a H1 H2. - pattern (a*2^p) at 1;replace (a*2^p) with - (a*2^p/2^n * 2^n + a*2^p mod 2^n). + pattern (a*2^p) at 1;replace (a*2^p) with + (a*2^p/2^n * 2^n + a*2^p mod 2^n). 2:symmetry;rewrite (Zmult_comm (a*2^p/2^n));apply Z_div_mod_eq. replace (a * 2 ^ p / 2 ^ n) with (a / 2 ^ (n - p));trivial. replace (2^n) with (2^(n-p)*2^p). @@ -277,8 +279,8 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. Qed. - Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> - ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = + Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> + ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = a mod 2 ^ p. Proof. intros. @@ -310,16 +312,16 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p. Proof. intros p x Hle;destruct (Z_le_gt_dec 0 p). - apply Zdiv_le_lower_bound;auto with zarith. + apply Zdiv_le_lower_bound;auto with zarith. replace (2^p) with 0. destruct x;compute;intro;discriminate. destruct p;trivial;discriminate z. Qed. - + Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. Proof. intros p x y H;destruct (Z_le_gt_dec 0 p). - apply Zdiv_lt_upper_bound;auto with zarith. + apply Zdiv_lt_upper_bound;auto with zarith. apply Zlt_le_trans with y;auto with zarith. rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith. assert (0 < 2^p);auto with zarith. @@ -331,7 +333,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. Theorem Zgcd_div_pos a b: 0 < b -> 0 < Zgcd a b -> 0 < b / Zgcd a b. Proof. - intros a b Ha Hg. + intros Ha Hg. case (Zle_lt_or_eq 0 (b/Zgcd a b)); auto. apply Z_div_pos; auto with zarith. intros H; generalize Ha. @@ -343,7 +345,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. Theorem Zdiv_neg a b: a < 0 -> 0 < b -> a / b < 0. Proof. - intros a b Ha Hb. + intros Ha Hb. assert (b > 0) by omega. generalize (Z_mult_div_ge a _ H); intros. assert (b * (a / b) < 0)%Z. @@ -354,22 +356,8 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. compute in H1; discriminate. compute; auto. Qed. - - Lemma Zgcd_Zabs : forall z z', Zgcd (Zabs z) z' = Zgcd z z'. - Proof. - destruct z; simpl; auto. - Qed. - Lemma Zgcd_sym : forall p q, Zgcd p q = Zgcd q p. - Proof. - intros. - apply Zis_gcd_gcd. - apply Zgcd_is_pos. - apply Zis_gcd_sym. - apply Zgcd_is_gcd. - Qed. - - Lemma Zdiv_gcd_zero : forall a b, b / Zgcd a b = 0 -> b <> 0 -> + Lemma Zdiv_gcd_zero : forall a b, b / Zgcd a b = 0 -> b <> 0 -> Zgcd a b = 0. Proof. intros. @@ -381,13 +369,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. intros; subst k; simpl in *; subst b; elim H0; auto. Qed. - Lemma Zgcd_1 : forall z, Zgcd z 1 = 1. - Proof. - intros; apply Zis_gcd_gcd; auto with zarith; apply Zis_gcd_1. - Qed. - Hint Resolve Zgcd_1. - - Lemma Zgcd_mult_rel_prime : forall a b c, + Lemma Zgcd_mult_rel_prime : forall a b c, Zgcd a c = 1 -> Zgcd b c = 1 -> Zgcd (a*b) c = 1. Proof. intros. @@ -396,7 +378,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. Qed. Lemma Zcompare_gt : forall (A:Type)(a a':A)(p q:Z), - match (p?=q)%Z with Gt => a | _ => a' end = + match (p?=q)%Z with Gt => a | _ => a' end = if Z_le_gt_dec p q then a' else a. Proof. intros. diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index 528d78c3..51df2fa3 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -8,12 +8,12 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(* $Id: CyclicAxioms.v 11012 2008-05-28 16:34:43Z letouzey $ *) +(* $Id$ *) (** * Signature and specification of a bounded integer structure *) -(** This file specifies how to represent [Z/nZ] when [n=2^d], - [d] being the number of digits of these bounded integers. *) +(** This file specifies how to represent [Z/nZ] when [n=2^d], + [d] being the number of digits of these bounded integers. *) Set Implicit Arguments. @@ -22,7 +22,7 @@ Require Import Znumtheory. Require Import BigNumPrelude. Require Import DoubleType. -Open Local Scope Z_scope. +Local Open Scope Z_scope. (** First, a description via an operator record and a spec record. *) @@ -33,7 +33,7 @@ Section Z_nZ_Op. Record znz_op := mk_znz_op { (* Conversion functions with Z *) - znz_digits : positive; + znz_digits : positive; znz_zdigits: znz; znz_to_Z : znz -> Z; znz_of_pos : positive -> N * znz; (* Euclidean division by [2^digits] *) @@ -78,12 +78,12 @@ Section Z_nZ_Op. znz_div : znz -> znz -> znz * znz; znz_mod_gt : znz -> znz -> znz; (* specialized version of [znz_mod] *) - znz_mod : znz -> znz -> znz; + znz_mod : znz -> znz -> znz; znz_gcd_gt : znz -> znz -> znz; (* specialized version of [znz_gcd] *) - znz_gcd : znz -> znz -> znz; + znz_gcd : znz -> znz -> znz; (* [znz_add_mul_div p i j] is a combination of the [(digits-p)] - low bits of [i] above the [p] high bits of [j]: + low bits of [i] above the [p] high bits of [j]: [znz_add_mul_div p i j = i*2^p+j/2^(digits-p)] *) znz_add_mul_div : znz -> znz -> znz -> znz; (* [znz_pos_mod p i] is [i mod 2^p] *) @@ -135,7 +135,7 @@ Section Z_nZ_Spec. Let w_mul_c := w_op.(znz_mul_c). Let w_mul := w_op.(znz_mul). Let w_square_c := w_op.(znz_square_c). - + Let w_div21 := w_op.(znz_div21). Let w_div_gt := w_op.(znz_div_gt). Let w_div := w_op.(znz_div). @@ -229,25 +229,25 @@ Section Z_nZ_Spec. spec_div : forall a b, 0 < [|b|] -> let (q,r) := w_div a b in [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]; - + 0 <= [|r|] < [|b|]; + spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> [|w_mod_gt a b|] = [|a|] mod [|b|]; spec_mod : forall a b, 0 < [|b|] -> [|w_mod a b|] = [|a|] mod [|b|]; - + spec_gcd_gt : forall a b, [|a|] > [|b|] -> Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]; spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|w_gcd a b|]; - + (* shift operations *) spec_head00: forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits; spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB; + wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB; spec_tail00: forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits; - spec_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|w_tail0 x|]) ; + spec_tail0 : forall x, 0 < [|x|] -> + exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|w_tail0 x|]) ; spec_add_mul_div : forall x y p, [|p|] <= Zpos w_digits -> [| w_add_mul_div p x y |] = @@ -272,23 +272,23 @@ End Z_nZ_Spec. (** Generic construction of double words *) Section WW. - + Variable w : Type. Variable w_op : znz_op w. Variable op_spec : znz_spec w_op. - + Let wB := base w_op.(znz_digits). Let w_to_Z := w_op.(znz_to_Z). Let w_eq0 := w_op.(znz_eq0). Let w_0 := w_op.(znz_0). - Definition znz_W0 h := + Definition znz_W0 h := if w_eq0 h then W0 else WW h w_0. - Definition znz_0W l := + Definition znz_0W l := if w_eq0 l then W0 else WW w_0 l. - Definition znz_WW h l := + Definition znz_WW h l := if w_eq0 h then znz_0W l else WW h l. Lemma spec_W0 : forall h, @@ -300,7 +300,7 @@ Section WW. unfold w_0; rewrite op_spec.(spec_0); auto with zarith. Qed. - Lemma spec_0W : forall l, + Lemma spec_0W : forall l, zn2z_to_Z wB w_to_Z (znz_0W l) = w_to_Z l. Proof. unfold zn2z_to_Z, znz_0W, w_to_Z; simpl; intros. @@ -309,7 +309,7 @@ Section WW. unfold w_0; rewrite op_spec.(spec_0); auto with zarith. Qed. - Lemma spec_WW : forall h l, + Lemma spec_WW : forall h l, zn2z_to_Z wB w_to_Z (znz_WW h l) = (w_to_Z h)*wB + w_to_Z l. Proof. unfold znz_WW, w_to_Z; simpl; intros. @@ -324,7 +324,7 @@ End WW. (** Injecting [Z] numbers into a cyclic structure *) Section znz_of_pos. - + Variable w : Type. Variable w_op : znz_op w. Variable op_spec : znz_spec w_op. @@ -349,7 +349,7 @@ Section znz_of_pos. apply Zle_trans with X; auto with zarith end. match goal with |- ?X <= _ => - pattern X at 1; rewrite <- (Zmult_1_l); + pattern X at 1; rewrite <- (Zmult_1_l); apply Zmult_le_compat_r; auto with zarith end. case p1; simpl; intros; red; simpl; intros; discriminate. @@ -373,3 +373,112 @@ Module Type CyclicType. Parameter w_op : znz_op w. Parameter w_spec : znz_spec w_op. End CyclicType. + + +(** A Cyclic structure can be seen as a ring *) + +Module CyclicRing (Import Cyclic : CyclicType). + +Definition t := w. + +Local Notation "[| x |]" := (w_op.(znz_to_Z) x) (at level 0, x at level 99). + +Definition eq (n m : t) := [| n |] = [| m |]. +Definition zero : t := w_op.(znz_0). +Definition one := w_op.(znz_1). +Definition add := w_op.(znz_add). +Definition sub := w_op.(znz_sub). +Definition mul := w_op.(znz_mul). +Definition opp := w_op.(znz_opp). + +Local Infix "==" := eq (at level 70). +Local Notation "0" := zero. +Local Notation "1" := one. +Local Infix "+" := add. +Local Infix "-" := sub. +Local Infix "*" := mul. +Local Notation "!!" := (base (znz_digits w_op)). + +Hint Rewrite + w_spec.(spec_0) w_spec.(spec_1) + w_spec.(spec_add) w_spec.(spec_mul) w_spec.(spec_opp) w_spec.(spec_sub) + : cyclic. + +Ltac zify := + unfold eq, zero, one, add, sub, mul, opp in *; autorewrite with cyclic. + +Lemma add_0_l : forall x, 0 + x == x. +Proof. +intros. zify. rewrite Zplus_0_l. +apply Zmod_small. apply w_spec.(spec_to_Z). +Qed. + +Lemma add_comm : forall x y, x + y == y + x. +Proof. +intros. zify. now rewrite Zplus_comm. +Qed. + +Lemma add_assoc : forall x y z, x + (y + z) == x + y + z. +Proof. +intros. zify. now rewrite Zplus_mod_idemp_r, Zplus_mod_idemp_l, Zplus_assoc. +Qed. + +Lemma mul_1_l : forall x, 1 * x == x. +Proof. +intros. zify. rewrite Zmult_1_l. +apply Zmod_small. apply w_spec.(spec_to_Z). +Qed. + +Lemma mul_comm : forall x y, x * y == y * x. +Proof. +intros. zify. now rewrite Zmult_comm. +Qed. + +Lemma mul_assoc : forall x y z, x * (y * z) == x * y * z. +Proof. +intros. zify. now rewrite Zmult_mod_idemp_r, Zmult_mod_idemp_l, Zmult_assoc. +Qed. + +Lemma mul_add_distr_r : forall x y z, (x+y)*z == x*z + y*z. +Proof. +intros. zify. now rewrite <- Zplus_mod, Zmult_mod_idemp_l, Zmult_plus_distr_l. +Qed. + +Lemma add_opp_r : forall x y, x + opp y == x-y. +Proof. +intros. zify. rewrite <- Zminus_mod_idemp_r. unfold Zminus. +destruct (Z_eq_dec ([|y|] mod !!) 0) as [EQ|NEQ]. +rewrite Z_mod_zero_opp_full, EQ, 2 Zplus_0_r; auto. +rewrite Z_mod_nz_opp_full by auto. +rewrite <- Zplus_mod_idemp_r, <- Zminus_mod_idemp_l. +rewrite Z_mod_same_full. simpl. now rewrite Zplus_mod_idemp_r. +Qed. + +Lemma add_opp_diag_r : forall x, x + opp x == 0. +Proof. +intros. red. rewrite add_opp_r. zify. now rewrite Zminus_diag, Zmod_0_l. +Qed. + +Lemma CyclicRing : ring_theory 0 1 add mul sub opp eq. +Proof. +constructor. +exact add_0_l. exact add_comm. exact add_assoc. +exact mul_1_l. exact mul_comm. exact mul_assoc. +exact mul_add_distr_r. +symmetry. apply add_opp_r. +exact add_opp_diag_r. +Qed. + +Definition eqb x y := + match w_op.(znz_compare) x y with Eq => true | _ => false end. + +Lemma eqb_eq : forall x y, eqb x y = true <-> x == y. +Proof. + intros. unfold eqb, eq. generalize (w_spec.(spec_compare) x y). + destruct (w_op.(znz_compare) x y); intuition; try discriminate. +Qed. + +Lemma eqb_correct : forall x y, eqb x y = true -> x==y. +Proof. now apply eqb_eq. Qed. + +End CyclicRing. \ No newline at end of file diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index fb3f0cef..517e48ad 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZCyclic.v 11238 2008-07-19 09:34:03Z herbelin $ i*) +(*i $Id$ i*) Require Export NZAxioms. Require Import BigNumPrelude. @@ -17,89 +17,79 @@ Require Import CyclicAxioms. (** * From [CyclicType] to [NZAxiomsSig] *) -(** A [Z/nZ] representation given by a module type [CyclicType] - implements [NZAxiomsSig], e.g. the common properties between - N and Z with no ordering. Notice that the [n] in [Z/nZ] is +(** A [Z/nZ] representation given by a module type [CyclicType] + implements [NZAxiomsSig], e.g. the common properties between + N and Z with no ordering. Notice that the [n] in [Z/nZ] is a power of 2. *) Module NZCyclicAxiomsMod (Import Cyclic : CyclicType) <: NZAxiomsSig. -Open Local Scope Z_scope. +Local Open Scope Z_scope. -Definition NZ := w. +Definition t := w. -Definition NZ_to_Z : NZ -> Z := znz_to_Z w_op. -Definition Z_to_NZ : Z -> NZ := znz_of_Z w_op. -Notation Local wB := (base w_op.(znz_digits)). +Definition NZ_to_Z : t -> Z := znz_to_Z w_op. +Definition Z_to_NZ : Z -> t := znz_of_Z w_op. +Local Notation wB := (base w_op.(znz_digits)). -Notation Local "[| x |]" := (w_op.(znz_to_Z) x) (at level 0, x at level 99). +Local Notation "[| x |]" := (w_op.(znz_to_Z) x) (at level 0, x at level 99). -Definition NZeq (n m : NZ) := [| n |] = [| m |]. -Definition NZ0 := w_op.(znz_0). -Definition NZsucc := w_op.(znz_succ). -Definition NZpred := w_op.(znz_pred). -Definition NZadd := w_op.(znz_add). -Definition NZsub := w_op.(znz_sub). -Definition NZmul := w_op.(znz_mul). +Definition eq (n m : t) := [| n |] = [| m |]. +Definition zero := w_op.(znz_0). +Definition succ := w_op.(znz_succ). +Definition pred := w_op.(znz_pred). +Definition add := w_op.(znz_add). +Definition sub := w_op.(znz_sub). +Definition mul := w_op.(znz_mul). -Theorem NZeq_equiv : equiv NZ NZeq. -Proof. -unfold equiv, reflexive, symmetric, transitive, NZeq; repeat split; intros; auto. -now transitivity [| y |]. -Qed. +Local Infix "==" := eq (at level 70). +Local Notation "0" := zero. +Local Notation S := succ. +Local Notation P := pred. +Local Infix "+" := add. +Local Infix "-" := sub. +Local Infix "*" := mul. -Add Relation NZ NZeq - reflexivity proved by (proj1 NZeq_equiv) - symmetry proved by (proj2 (proj2 NZeq_equiv)) - transitivity proved by (proj1 (proj2 NZeq_equiv)) -as NZeq_rel. +Hint Rewrite w_spec.(spec_0) w_spec.(spec_succ) w_spec.(spec_pred) + w_spec.(spec_add) w_spec.(spec_mul) w_spec.(spec_sub) : w. +Ltac wsimpl := + unfold eq, zero, succ, pred, add, sub, mul; autorewrite with w. +Ltac wcongruence := repeat red; intros; wsimpl; congruence. -Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd. +Instance eq_equiv : Equivalence eq. Proof. -unfold NZeq; intros n m H. do 2 rewrite w_spec.(spec_succ). now rewrite H. +unfold eq. firstorder. Qed. -Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd. +Instance succ_wd : Proper (eq ==> eq) succ. Proof. -unfold NZeq; intros n m H. do 2 rewrite w_spec.(spec_pred). now rewrite H. +wcongruence. Qed. -Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd. +Instance pred_wd : Proper (eq ==> eq) pred. Proof. -unfold NZeq; intros n1 n2 H1 m1 m2 H2. do 2 rewrite w_spec.(spec_add). -now rewrite H1, H2. +wcongruence. Qed. -Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd. +Instance add_wd : Proper (eq ==> eq ==> eq) add. Proof. -unfold NZeq; intros n1 n2 H1 m1 m2 H2. do 2 rewrite w_spec.(spec_sub). -now rewrite H1, H2. +wcongruence. Qed. -Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd. +Instance sub_wd : Proper (eq ==> eq ==> eq) sub. Proof. -unfold NZeq; intros n1 n2 H1 m1 m2 H2. do 2 rewrite w_spec.(spec_mul). -now rewrite H1, H2. +wcongruence. Qed. -Delimit Scope IntScope with Int. -Bind Scope IntScope with NZ. -Open Local Scope IntScope. -Notation "x == y" := (NZeq x y) (at level 70) : IntScope. -Notation "x ~= y" := (~ NZeq x y) (at level 70) : IntScope. -Notation "0" := NZ0 : IntScope. -Notation S x := (NZsucc x). -Notation P x := (NZpred x). -(*Notation "1" := (S 0) : IntScope.*) -Notation "x + y" := (NZadd x y) : IntScope. -Notation "x - y" := (NZsub x y) : IntScope. -Notation "x * y" := (NZmul x y) : IntScope. +Instance mul_wd : Proper (eq ==> eq ==> eq) mul. +Proof. +wcongruence. +Qed. Theorem gt_wB_1 : 1 < wB. Proof. -unfold base. -apply Zpower_gt_1; unfold Zlt; auto with zarith. +unfold base. apply Zpower_gt_1; unfold Zlt; auto with zarith. Qed. Theorem gt_wB_0 : 0 < wB. @@ -107,7 +97,7 @@ Proof. pose proof gt_wB_1; auto with zarith. Qed. -Lemma NZsucc_mod_wB : forall n : Z, (n + 1) mod wB = ((n mod wB) + 1) mod wB. +Lemma succ_mod_wB : forall n : Z, (n + 1) mod wB = ((n mod wB) + 1) mod wB. Proof. intro n. pattern 1 at 2. replace 1 with (1 mod wB). rewrite <- Zplus_mod. @@ -115,7 +105,7 @@ reflexivity. now rewrite Zmod_small; [ | split; [auto with zarith | apply gt_wB_1]]. Qed. -Lemma NZpred_mod_wB : forall n : Z, (n - 1) mod wB = ((n mod wB) - 1) mod wB. +Lemma pred_mod_wB : forall n : Z, (n - 1) mod wB = ((n mod wB) - 1) mod wB. Proof. intro n. pattern 1 at 2. replace 1 with (1 mod wB). rewrite <- Zminus_mod. @@ -123,34 +113,32 @@ reflexivity. now rewrite Zmod_small; [ | split; [auto with zarith | apply gt_wB_1]]. Qed. -Lemma NZ_to_Z_mod : forall n : NZ, [| n |] mod wB = [| n |]. +Lemma NZ_to_Z_mod : forall n, [| n |] mod wB = [| n |]. Proof. intro n; rewrite Zmod_small. reflexivity. apply w_spec.(spec_to_Z). Qed. -Theorem NZpred_succ : forall n : NZ, P (S n) == n. +Theorem pred_succ : forall n, P (S n) == n. Proof. -intro n; unfold NZsucc, NZpred, NZeq. rewrite w_spec.(spec_pred), w_spec.(spec_succ). -rewrite <- NZpred_mod_wB. +intro n. wsimpl. +rewrite <- pred_mod_wB. replace ([| n |] + 1 - 1)%Z with [| n |] by auto with zarith. apply NZ_to_Z_mod. Qed. -Lemma Z_to_NZ_0 : Z_to_NZ 0%Z == 0%Int. +Lemma Z_to_NZ_0 : Z_to_NZ 0%Z == 0. Proof. -unfold NZeq, NZ_to_Z, Z_to_NZ. rewrite znz_of_Z_correct. -symmetry; apply w_spec.(spec_0). +unfold NZ_to_Z, Z_to_NZ. wsimpl. +rewrite znz_of_Z_correct; auto. exact w_spec. split; [auto with zarith |apply gt_wB_0]. Qed. Section Induction. -Variable A : NZ -> Prop. -Hypothesis A_wd : predicate_wd NZeq A. +Variable A : t -> Prop. +Hypothesis A_wd : Proper (eq ==> iff) A. Hypothesis A0 : A 0. -Hypothesis AS : forall n : NZ, A n <-> A (S n). (* Below, we use only -> direction *) - -Add Morphism A with signature NZeq ==> iff as A_morph. -Proof. apply A_wd. Qed. +Hypothesis AS : forall n, A n <-> A (S n). + (* Below, we use only -> direction *) Let B (n : Z) := A (Z_to_NZ n). @@ -163,8 +151,8 @@ Lemma BS : forall n : Z, 0 <= n -> n < wB - 1 -> B n -> B (n + 1). Proof. intros n H1 H2 H3. unfold B in *. apply -> AS in H3. -setoid_replace (Z_to_NZ (n + 1)) with (S (Z_to_NZ n)) using relation NZeq. assumption. -unfold NZeq. rewrite w_spec.(spec_succ). +setoid_replace (Z_to_NZ (n + 1)) with (S (Z_to_NZ n)). assumption. +wsimpl. unfold NZ_to_Z, Z_to_NZ. do 2 (rewrite znz_of_Z_correct; [ | exact w_spec | auto with zarith]). symmetry; apply Zmod_small; auto with zarith. @@ -177,11 +165,11 @@ apply Zbounded_induction with wB. apply B0. apply BS. assumption. assumption. Qed. -Theorem NZinduction : forall n : NZ, A n. +Theorem bi_induction : forall n, A n. Proof. -intro n. setoid_replace n with (Z_to_NZ (NZ_to_Z n)) using relation NZeq. +intro n. setoid_replace n with (Z_to_NZ (NZ_to_Z n)). apply B_holds. apply w_spec.(spec_to_Z). -unfold NZeq, NZ_to_Z, Z_to_NZ; rewrite znz_of_Z_correct. +unfold eq, NZ_to_Z, Z_to_NZ; rewrite znz_of_Z_correct. reflexivity. exact w_spec. apply w_spec.(spec_to_Z). @@ -189,47 +177,40 @@ Qed. End Induction. -Theorem NZadd_0_l : forall n : NZ, 0 + n == n. +Theorem add_0_l : forall n, 0 + n == n. Proof. -intro n; unfold NZadd, NZ0, NZeq. rewrite w_spec.(spec_add). rewrite w_spec.(spec_0). +intro n. wsimpl. rewrite Zplus_0_l. rewrite Zmod_small; [reflexivity | apply w_spec.(spec_to_Z)]. Qed. -Theorem NZadd_succ_l : forall n m : NZ, (S n) + m == S (n + m). +Theorem add_succ_l : forall n m, (S n) + m == S (n + m). Proof. -intros n m; unfold NZadd, NZsucc, NZeq. rewrite w_spec.(spec_add). -do 2 rewrite w_spec.(spec_succ). rewrite w_spec.(spec_add). -rewrite NZsucc_mod_wB. repeat rewrite Zplus_mod_idemp_l; try apply gt_wB_0. +intros n m. wsimpl. +rewrite succ_mod_wB. repeat rewrite Zplus_mod_idemp_l; try apply gt_wB_0. rewrite <- (Zplus_assoc ([| n |] mod wB) 1 [| m |]). rewrite Zplus_mod_idemp_l. rewrite (Zplus_comm 1 [| m |]); now rewrite Zplus_assoc. Qed. -Theorem NZsub_0_r : forall n : NZ, n - 0 == n. +Theorem sub_0_r : forall n, n - 0 == n. Proof. -intro n; unfold NZsub, NZ0, NZeq. rewrite w_spec.(spec_sub). -rewrite w_spec.(spec_0). rewrite Zminus_0_r. apply NZ_to_Z_mod. +intro n. wsimpl. rewrite Zminus_0_r. apply NZ_to_Z_mod. Qed. -Theorem NZsub_succ_r : forall n m : NZ, n - (S m) == P (n - m). +Theorem sub_succ_r : forall n m, n - (S m) == P (n - m). Proof. -intros n m; unfold NZsub, NZsucc, NZpred, NZeq. -rewrite w_spec.(spec_pred). do 2 rewrite w_spec.(spec_sub). -rewrite w_spec.(spec_succ). rewrite Zminus_mod_idemp_r. -rewrite Zminus_mod_idemp_l. -now replace ([|n|] - ([|m|] + 1))%Z with ([|n|] - [|m|] - 1)%Z by auto with zarith. +intros n m. wsimpl. rewrite Zminus_mod_idemp_r, Zminus_mod_idemp_l. +now replace ([|n|] - ([|m|] + 1))%Z with ([|n|] - [|m|] - 1)%Z + by auto with zarith. Qed. -Theorem NZmul_0_l : forall n : NZ, 0 * n == 0. +Theorem mul_0_l : forall n, 0 * n == 0. Proof. -intro n; unfold NZmul, NZ0, NZ, NZeq. rewrite w_spec.(spec_mul). -rewrite w_spec.(spec_0). now rewrite Zmult_0_l. +intro n. wsimpl. now rewrite Zmult_0_l. Qed. -Theorem NZmul_succ_l : forall n m : NZ, (S n) * m == n * m + m. +Theorem mul_succ_l : forall n m, (S n) * m == n * m + m. Proof. -intros n m; unfold NZmul, NZsucc, NZadd, NZeq. rewrite w_spec.(spec_mul). -rewrite w_spec.(spec_add), w_spec.(spec_mul), w_spec.(spec_succ). -rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l. +intros n m. wsimpl. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l. now rewrite Zmult_plus_distr_l, Zmult_1_l. Qed. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v index 61d8d0fb..aa798e1c 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleAdd.v 10964 2008-05-22 11:08:13Z letouzey $ i*) +(*i $Id$ i*) Set Implicit Arguments. @@ -17,7 +17,7 @@ Require Import BigNumPrelude. Require Import DoubleType. Require Import DoubleBase. -Open Local Scope Z_scope. +Local Open Scope Z_scope. Section DoubleAdd. Variable w : Type. @@ -36,10 +36,10 @@ Section DoubleAdd. Definition ww_succ_c x := match x with | W0 => C0 ww_1 - | WW xh xl => + | WW xh xl => match w_succ_c xl with | C0 l => C0 (WW xh l) - | C1 l => + | C1 l => match w_succ_c xh with | C0 h => C0 (WW h w_0) | C1 h => C1 W0 @@ -47,13 +47,13 @@ Section DoubleAdd. end end. - Definition ww_succ x := + Definition ww_succ x := match x with | W0 => ww_1 | WW xh xl => match w_succ_c xl with | C0 l => WW xh l - | C1 l => w_W0 (w_succ xh) + | C1 l => w_W0 (w_succ xh) end end. @@ -63,12 +63,12 @@ Section DoubleAdd. | _, W0 => C0 x | WW xh xl, WW yh yl => match w_add_c xl yl with - | C0 l => + | C0 l => match w_add_c xh yh with | C0 h => C0 (WW h l) | C1 h => C1 (w_WW h l) - end - | C1 l => + end + | C1 l => match w_add_carry_c xh yh with | C0 h => C0 (WW h l) | C1 h => C1 (w_WW h l) @@ -85,12 +85,12 @@ Section DoubleAdd. | _, W0 => f0 x | WW xh xl, WW yh yl => match w_add_c xl yl with - | C0 l => + | C0 l => match w_add_c xh yh with | C0 h => f0 (WW h l) | C1 h => f1 (w_WW h l) - end - | C1 l => + end + | C1 l => match w_add_carry_c xh yh with | C0 h => f0 (WW h l) | C1 h => f1 (w_WW h l) @@ -118,12 +118,12 @@ Section DoubleAdd. | WW xh xl, W0 => ww_succ_c (WW xh xl) | WW xh xl, WW yh yl => match w_add_carry_c xl yl with - | C0 l => + | C0 l => match w_add_c xh yh with | C0 h => C0 (WW h l) | C1 h => C1 (WW h l) end - | C1 l => + | C1 l => match w_add_carry_c xh yh with | C0 h => C0 (WW h l) | C1 h => C1 (w_WW h l) @@ -131,7 +131,7 @@ Section DoubleAdd. end end. - Definition ww_add_carry x y := + Definition ww_add_carry x y := match x, y with | W0, W0 => ww_1 | W0, WW yh yl => ww_succ (WW yh yl) @@ -146,7 +146,7 @@ Section DoubleAdd. (*Section DoubleProof.*) Variable w_digits : positive. Variable w_to_Z : w -> Z. - + Notation wB := (base w_digits). Notation wwB := (base (ww_digits w_digits)). @@ -157,11 +157,11 @@ Section DoubleAdd. (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). Variable spec_w_0 : [|w_0|] = 0. @@ -172,7 +172,7 @@ Section DoubleAdd. Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. Variable spec_w_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1. Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add_carry_c : + Variable spec_w_add_carry_c : forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB. Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. @@ -187,11 +187,11 @@ Section DoubleAdd. rewrite <- Zplus_assoc;rewrite <- H;rewrite Zmult_1_l. assert ([|l|] = 0). generalize (spec_to_Z xl)(spec_to_Z l);omega. rewrite H0;generalize (spec_w_succ_c xh);destruct (w_succ_c xh) as [h|h]; - intro H1;unfold interp_carry in H1. + intro H1;unfold interp_carry in H1. simpl;rewrite H1;rewrite spec_w_0;ring. unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB. assert ([|xh|] = wB - 1). generalize (spec_to_Z xh)(spec_to_Z h);omega. - rewrite H2;ring. + rewrite H2;ring. Qed. Lemma spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. @@ -222,12 +222,12 @@ Section DoubleAdd. Proof. destruct x as [ |xh xl];simpl;trivial. apply spec_f0;trivial. - destruct y as [ |yh yl];simpl. + destruct y as [ |yh yl];simpl. apply spec_f0;simpl;rewrite Zplus_0_r;trivial. generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; intros H;unfold interp_carry in H. generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *. + intros H1;unfold interp_carry in *. apply spec_f0. simpl;rewrite H;rewrite H1;ring. apply spec_f1. simpl;rewrite spec_w_WW;rewrite H. rewrite Zplus_assoc;rewrite wwB_wBwB. rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. @@ -236,12 +236,12 @@ Section DoubleAdd. as [h|h]; intros H1;unfold interp_carry in *. apply spec_f0;simpl;rewrite H1. rewrite Zmult_plus_distr_l. rewrite <- Zplus_assoc;rewrite H;ring. - apply spec_f1. simpl;rewrite spec_w_WW;rewrite wwB_wBwB. - rewrite Zplus_assoc; rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. + apply spec_f1. simpl;rewrite spec_w_WW;rewrite wwB_wBwB. + rewrite Zplus_assoc; rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. rewrite Zmult_1_l in H1;rewrite H1. rewrite Zmult_plus_distr_l. rewrite <- Zplus_assoc;rewrite H;ring. Qed. - + End Cont. Lemma spec_ww_add_carry_c : @@ -251,16 +251,16 @@ Section DoubleAdd. exact (spec_ww_succ_c y). destruct y as [ |yh yl];simpl. rewrite Zplus_0_r;exact (spec_ww_succ_c (WW xh xl)). - replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) + replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. - generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) + generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) as [l|l];intros H;unfold interp_carry in H;rewrite <- H. generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. unfold interp_carry;repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring. rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) - as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. + generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) + as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. unfold interp_carry;rewrite spec_w_WW; repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring. Qed. @@ -287,9 +287,9 @@ Section DoubleAdd. rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial. destruct y as [ |yh yl]. change [[W0]] with 0;rewrite Zplus_0_r. - rewrite Zmod_small;trivial. + rewrite Zmod_small;trivial. exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)). - simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) + simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring. generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; unfold interp_carry;intros H;simpl;rewrite <- H. @@ -305,14 +305,14 @@ Section DoubleAdd. exact (spec_ww_succ y). destruct y as [ |yh yl]. change [[W0]] with 0;rewrite Zplus_0_r. exact (spec_ww_succ (WW xh xl)). - simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) + simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. - generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) + generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) as [l|l];unfold interp_carry;intros H;rewrite <- H;simpl ww_to_Z. rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial. rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial. - Qed. + Qed. (* End DoubleProof. *) End DoubleAdd. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v index 952516ac..88c34915 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleBase.v 10964 2008-05-22 11:08:13Z letouzey $ i*) +(*i $Id$ i*) Set Implicit Arguments. @@ -16,7 +16,7 @@ Require Import ZArith. Require Import BigNumPrelude. Require Import DoubleType. -Open Local Scope Z_scope. +Local Open Scope Z_scope. Section DoubleBase. Variable w : Type. @@ -29,8 +29,8 @@ Section DoubleBase. Variable w_zdigits: w. Variable w_add: w -> w -> zn2z w. Variable w_to_Z : w -> Z. - Variable w_compare : w -> w -> comparison. - + Variable w_compare : w -> w -> comparison. + Definition ww_digits := xO w_digits. Definition ww_zdigits := w_add w_zdigits w_zdigits. @@ -46,7 +46,7 @@ Section DoubleBase. | W0, W0 => W0 | _, _ => WW xh xl end. - + Definition ww_W0 h : zn2z (zn2z w) := match h with | W0 => W0 @@ -58,10 +58,10 @@ Section DoubleBase. | W0 => W0 | _ => WW W0 l end. - - Definition double_WW (n:nat) := - match n return word w n -> word w n -> word w (S n) with - | O => w_WW + + Definition double_WW (n:nat) := + match n return word w n -> word w n -> word w (S n) with + | O => w_WW | S n => fun (h l : zn2z (word w n)) => match h, l with @@ -70,8 +70,8 @@ Section DoubleBase. end end. - Fixpoint double_digits (n:nat) : positive := - match n with + Fixpoint double_digits (n:nat) : positive := + match n with | O => w_digits | S n => xO (double_digits n) end. @@ -80,7 +80,7 @@ Section DoubleBase. Fixpoint double_to_Z (n:nat) : word w n -> Z := match n return word w n -> Z with - | O => w_to_Z + | O => w_to_Z | S n => zn2z_to_Z (double_wB n) (double_to_Z n) end. @@ -98,21 +98,21 @@ Section DoubleBase. end. Definition double_0 n : word w n := - match n return word w n with + match n return word w n with | O => w_0 | S _ => W0 end. - + Definition double_split (n:nat) (x:zn2z (word w n)) := - match x with - | W0 => - match n return word w n * word w n with + match x with + | W0 => + match n return word w n * word w n with | O => (w_0,w_0) | S _ => (W0, W0) end | WW h l => (h,l) end. - + Definition ww_compare x y := match x, y with | W0, W0 => Eq @@ -148,15 +148,15 @@ Section DoubleBase. end end. - + Section DoubleProof. Notation wB := (base w_digits). Notation wwB := (base ww_digits). Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z x) (at level 0, x at level 99). - Notation "[+[ c ]]" := + Notation "[+[ c ]]" := (interp_carry 1 wwB ww_to_Z c) (at level 0, x at level 99). - Notation "[-[ c ]]" := + Notation "[-[ c ]]" := (interp_carry (-1) wwB ww_to_Z c) (at level 0, x at level 99). Notation "[! n | x !]" := (double_to_Z n x) (at level 0, x at level 99). @@ -188,7 +188,7 @@ Section DoubleBase. Proof. simpl;rewrite spec_w_Bm1;rewrite wwB_wBwB;ring. Qed. Lemma lt_0_wB : 0 < wB. - Proof. + Proof. unfold base;apply Zpower_gt_0. unfold Zlt;reflexivity. unfold Zle;intros H;discriminate H. Qed. @@ -197,25 +197,25 @@ Section DoubleBase. Proof. rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_lt_0_compat;apply lt_0_wB. Qed. Lemma wB_pos: 1 < wB. - Proof. + Proof. unfold base;apply Zlt_le_trans with (2^1). unfold Zlt;reflexivity. apply Zpower_le_monotone. unfold Zlt;reflexivity. split;unfold Zle;intros H. discriminate H. clear spec_w_0W w_0W spec_w_Bm1 spec_to_Z spec_w_WW w_WW. destruct w_digits; discriminate H. Qed. - - Lemma wwB_pos: 1 < wwB. + + Lemma wwB_pos: 1 < wwB. Proof. assert (H:= wB_pos);rewrite wwB_wBwB;rewrite <-(Zmult_1_r 1). rewrite Zpower_2. apply Zmult_lt_compat2;(split;[unfold Zlt;reflexivity|trivial]). - apply Zlt_le_weak;trivial. + apply Zlt_le_weak;trivial. Qed. Theorem wB_div_2: 2 * (wB / 2) = wB. Proof. - clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W + clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W spec_to_Z;unfold base. assert (2 ^ Zpos w_digits = 2 * (2 ^ (Zpos w_digits - 1))). pattern 2 at 2; rewrite <- Zpower_1_r. @@ -228,7 +228,7 @@ Section DoubleBase. Theorem wwB_div_2 : wwB / 2 = wB / 2 * wB. Proof. - clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W + clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W spec_to_Z. rewrite wwB_wBwB; rewrite Zpower_2. pattern wB at 1; rewrite <- wB_div_2; auto. @@ -236,11 +236,11 @@ Section DoubleBase. repeat (rewrite (Zmult_comm 2); rewrite Z_div_mult); auto with zarith. Qed. - Lemma mod_wwB : forall z x, + Lemma mod_wwB : forall z x, (z*wB + [|x|]) mod wwB = (z mod wB)*wB + [|x|]. Proof. intros z x. - rewrite Zplus_mod. + rewrite Zplus_mod. pattern wwB at 1;rewrite wwB_wBwB; rewrite Zpower_2. rewrite Zmult_mod_distr_r;try apply lt_0_wB. rewrite (Zmod_small [|x|]). @@ -260,8 +260,8 @@ Section DoubleBase. destruct (spec_to_Z x);trivial. Qed. - Lemma wB_div_plus : forall x y p, - 0 <= p -> + Lemma wB_div_plus : forall x y p, + 0 <= p -> ([|x|]*wB + [|y|]) / 2^(Zpos w_digits + p) = [|x|] / 2^p. Proof. clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. @@ -277,7 +277,7 @@ Section DoubleBase. assert (0 < Zpos w_digits). compute;reflexivity. unfold ww_digits;rewrite Zpos_xO;auto with zarith. Qed. - + Lemma w_to_Z_wwB : forall x, x < wB -> x < wwB. Proof. intros x H;apply Zlt_trans with wB;trivial;apply lt_wB_wwB. @@ -298,7 +298,7 @@ Section DoubleBase. Proof. intros n;unfold double_wB;simpl. unfold base;rewrite (Zpos_xO (double_digits n)). - replace (2 * Zpos (double_digits n)) with + replace (2 * Zpos (double_digits n)) with (Zpos (double_digits n) + Zpos (double_digits n)). symmetry; apply Zpower_exp;intro;discriminate. ring. @@ -327,7 +327,7 @@ Section DoubleBase. unfold base; auto with zarith. Qed. - Lemma spec_double_to_Z : + Lemma spec_double_to_Z : forall n (x:word w n), 0 <= [!n | x!] < double_wB n. Proof. clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. @@ -347,7 +347,7 @@ Section DoubleBase. Qed. Lemma spec_get_low: - forall n x, + forall n x, [!n | x!] < wB -> [|get_low n x|] = [!n | x!]. Proof. clear spec_w_1 spec_w_Bm1. @@ -380,19 +380,19 @@ Section DoubleBase. Qed. Lemma spec_extend_aux : forall n x, [!S n|extend_aux n x!] = [[x]]. - Proof. induction n;simpl;trivial. Qed. + Proof. induction n;simpl;trivial. Qed. Lemma spec_extend : forall n x, [!S n|extend n x!] = [|x|]. - Proof. + Proof. intros n x;assert (H:= spec_w_0W x);unfold extend. - destruct (w_0W x);simpl;trivial. + destruct (w_0W x);simpl;trivial. rewrite <- H;exact (spec_extend_aux n (WW w0 w1)). Qed. Lemma spec_double_0 : forall n, [!n|double_0 n!] = 0. Proof. destruct n;trivial. Qed. - Lemma spec_double_split : forall n x, + Lemma spec_double_split : forall n x, let (h,l) := double_split n x in [!S n|x!] = [!n|h!] * double_wB n + [!n|l!]. Proof. @@ -401,9 +401,9 @@ Section DoubleBase. rewrite spec_w_0;trivial. Qed. - Lemma wB_lex_inv: forall a b c d, - a < c -> - a * wB + [|b|] < c * wB + [|d|]. + Lemma wB_lex_inv: forall a b c d, + a < c -> + a * wB + [|b|] < c * wB + [|d|]. Proof. intros a b c d H1; apply beta_lex_inv with (1 := H1); auto. Qed. @@ -420,7 +420,7 @@ Section DoubleBase. intros H;rewrite spec_w_0 in H. rewrite <- H;simpl;rewrite <- spec_w_0;apply spec_w_compare. change 0 with (0*wB+0);pattern 0 at 2;rewrite <- spec_w_0. - apply wB_lex_inv;trivial. + apply wB_lex_inv;trivial. absurd (0 <= [|yh|]). apply Zgt_not_le;trivial. destruct (spec_to_Z yh);trivial. generalize (spec_w_compare xh w_0);destruct (w_compare xh w_0); @@ -429,8 +429,8 @@ Section DoubleBase. absurd (0 <= [|xh|]). apply Zgt_not_le;apply Zlt_gt;trivial. destruct (spec_to_Z xh);trivial. apply Zlt_gt;change 0 with (0*wB+0);pattern 0 at 2;rewrite <- spec_w_0. - apply wB_lex_inv;apply Zgt_lt;trivial. - + apply wB_lex_inv;apply Zgt_lt;trivial. + generalize (spec_w_compare xh yh);destruct (w_compare xh yh);intros H. rewrite H;generalize (spec_w_compare xl yl);destruct (w_compare xl yl); intros H1;[rewrite H1|apply Zplus_lt_compat_l|apply Zplus_gt_compat_l]; @@ -439,7 +439,7 @@ Section DoubleBase. apply Zlt_gt;apply wB_lex_inv;apply Zgt_lt;trivial. Qed. - + End DoubleProof. End DoubleBase. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v index cca32a59..eea29e7c 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleCyclic.v 11012 2008-05-28 16:34:43Z letouzey $ i*) +(*i $Id$ i*) Set Implicit Arguments. @@ -22,10 +22,10 @@ Require Import DoubleMul. Require Import DoubleSqrt. Require Import DoubleLift. Require Import DoubleDivn1. -Require Import DoubleDiv. +Require Import DoubleDiv. Require Import CyclicAxioms. -Open Local Scope Z_scope. +Local Open Scope Z_scope. Section Z_2nZ. @@ -80,7 +80,7 @@ Section Z_2nZ. Let w_gcd_gt := w_op.(znz_gcd_gt). Let w_gcd := w_op.(znz_gcd). - Let w_add_mul_div := w_op.(znz_add_mul_div). + Let w_add_mul_div := w_op.(znz_add_mul_div). Let w_pos_mod := w_op.(znz_pos_mod). @@ -93,7 +93,7 @@ Section Z_2nZ. Let wB := base w_digits. Let w_Bm2 := w_pred w_Bm1. - + Let ww_1 := ww_1 w_0 w_1. Let ww_Bm1 := ww_Bm1 w_Bm1. @@ -112,16 +112,16 @@ Section Z_2nZ. Let ww_of_pos p := match w_of_pos p with | (N0, l) => (N0, WW w_0 l) - | (Npos ph,l) => + | (Npos ph,l) => let (n,h) := w_of_pos ph in (n, w_WW h l) end. Let head0 := - Eval lazy beta delta [ww_head0] in + Eval lazy beta delta [ww_head0] in ww_head0 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits. Let tail0 := - Eval lazy beta delta [ww_tail0] in + Eval lazy beta delta [ww_tail0] in ww_tail0 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits. Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW w). @@ -132,7 +132,7 @@ Section Z_2nZ. Let compare := Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare. - Let eq0 (x:zn2z w) := + Let eq0 (x:zn2z w) := match x with | W0 => true | _ => false @@ -147,7 +147,7 @@ Section Z_2nZ. Let opp_carry := Eval lazy beta delta [ww_opp_carry] in ww_opp_carry w_WW ww_Bm1 w_opp_carry. - + (* ** Additions ** *) Let succ_c := @@ -157,16 +157,16 @@ Section Z_2nZ. Eval lazy beta delta [ww_add_c] in ww_add_c w_WW w_add_c w_add_carry_c. Let add_carry_c := - Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in + Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in ww_add_carry_c w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c. - Let succ := + Let succ := Eval lazy beta delta [ww_succ] in ww_succ w_W0 ww_1 w_succ_c w_succ. Let add := Eval lazy beta delta [ww_add] in ww_add w_add_c w_add w_add_carry. - Let add_carry := + Let add_carry := Eval lazy beta iota delta [ww_add_carry ww_succ] in ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry. @@ -174,9 +174,9 @@ Section Z_2nZ. Let pred_c := Eval lazy beta delta [ww_pred_c] in ww_pred_c w_Bm1 w_WW ww_Bm1 w_pred_c. - + Let sub_c := - Eval lazy beta iota delta [ww_sub_c ww_opp_c] in + Eval lazy beta iota delta [ww_sub_c ww_opp_c] in ww_sub_c w_0 w_WW w_opp_c w_opp_carry w_sub_c w_sub_carry_c. Let sub_carry_c := @@ -186,8 +186,8 @@ Section Z_2nZ. Let pred := Eval lazy beta delta [ww_pred] in ww_pred w_Bm1 w_WW ww_Bm1 w_pred_c w_pred. - Let sub := - Eval lazy beta iota delta [ww_sub ww_opp] in + Let sub := + Eval lazy beta iota delta [ww_sub ww_opp] in ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry. Let sub_carry := @@ -204,7 +204,7 @@ Section Z_2nZ. Let karatsuba_c := Eval lazy beta iota delta [ww_karatsuba_c double_mul_c kara_prod] in - ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c + ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c add_c add add_carry sub_c sub. Let mul := @@ -219,7 +219,7 @@ Section Z_2nZ. Let div32 := Eval lazy beta iota delta [w_div32] in - w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c + w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c. Let div21 := @@ -234,40 +234,40 @@ Section Z_2nZ. Let div_gt := Eval lazy beta delta [ww_div_gt] in - ww_div_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp + ww_div_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits. Let div := Eval lazy beta delta [ww_div] in ww_div ww_1 compare div_gt. - + Let mod_gt := Eval lazy beta delta [ww_mod_gt] in ww_mod_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_mod_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div w_zdigits. - Let mod_ := + Let mod_ := Eval lazy beta delta [ww_mod] in ww_mod compare mod_gt. - Let pos_mod := - Eval lazy beta delta [ww_pos_mod] in + Let pos_mod := + Eval lazy beta delta [ww_pos_mod] in ww_pos_mod w_0 w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits. - Let is_even := + Let is_even := Eval lazy beta delta [ww_is_even] in ww_is_even w_is_even. - Let sqrt2 := + Let sqrt2 := Eval lazy beta delta [ww_sqrt2] in ww_sqrt2 w_is_even w_compare w_0 w_1 w_Bm1 w_0W w_sub w_square_c w_div21 w_add_mul_div w_zdigits w_add_c w_sqrt2 w_pred pred_c pred add_c add sub_c add_mul_div. - Let sqrt := + Let sqrt := Eval lazy beta delta [ww_sqrt] in ww_sqrt w_is_even w_0 w_sub w_add_mul_div w_zdigits _ww_zdigits w_sqrt2 pred add_mul_div head0 compare low. - Let gcd_gt_fix := + Let gcd_gt_fix := Eval cbv beta delta [ww_gcd_gt_aux ww_gcd_gt_body] in ww_gcd_gt_aux w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt @@ -278,7 +278,7 @@ Section Z_2nZ. Eval lazy beta delta [gcd_cont] in gcd_cont ww_1 w_1 w_compare. Let gcd_gt := - Eval lazy beta delta [ww_gcd_gt] in + Eval lazy beta delta [ww_gcd_gt] in ww_gcd_gt w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. Let gcd := @@ -286,18 +286,18 @@ Section Z_2nZ. ww_gcd compare w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. (* ** Record of operators on 2 words *) - - Definition mk_zn2z_op := + + Definition mk_zn2z_op := mk_znz_op _ww_digits _ww_zdigits to_Z ww_of_pos head0 tail0 W0 ww_1 ww_Bm1 compare eq0 opp_c opp opp_carry - succ_c add_c add_carry_c - succ add add_carry - pred_c sub_c sub_carry_c + succ_c add_c add_carry_c + succ add add_carry + pred_c sub_c sub_carry_c pred sub sub_carry - mul_c mul square_c + mul_c mul square_c div21 div_gt div mod_gt mod_ gcd_gt gcd @@ -307,17 +307,17 @@ Section Z_2nZ. sqrt2 sqrt. - Definition mk_zn2z_op_karatsuba := + Definition mk_zn2z_op_karatsuba := mk_znz_op _ww_digits _ww_zdigits to_Z ww_of_pos head0 tail0 W0 ww_1 ww_Bm1 compare eq0 opp_c opp opp_carry - succ_c add_c add_carry_c - succ add add_carry - pred_c sub_c sub_carry_c + succ_c add_c add_carry_c + succ add add_carry + pred_c sub_c sub_carry_c pred sub sub_carry - karatsuba_c mul square_c + karatsuba_c mul square_c div21 div_gt div mod_gt mod_ gcd_gt gcd @@ -330,7 +330,7 @@ Section Z_2nZ. (* Proof *) Variable op_spec : znz_spec w_op. - Hint Resolve + Hint Resolve (spec_to_Z op_spec) (spec_of_pos op_spec) (spec_0 op_spec) @@ -358,13 +358,13 @@ Section Z_2nZ. (spec_square_c op_spec) (spec_div21 op_spec) (spec_div_gt op_spec) - (spec_div op_spec) + (spec_div op_spec) (spec_mod_gt op_spec) - (spec_mod op_spec) + (spec_mod op_spec) (spec_gcd_gt op_spec) - (spec_gcd op_spec) - (spec_head0 op_spec) - (spec_tail0 op_spec) + (spec_gcd op_spec) + (spec_head0 op_spec) + (spec_tail0 op_spec) (spec_add_mul_div op_spec) (spec_pos_mod) (spec_is_even) @@ -417,20 +417,20 @@ Section Z_2nZ. Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1. Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed. - Let spec_ww_compare : + Let spec_ww_compare : forall x y, match compare x y with | Eq => [|x|] = [|y|] | Lt => [|x|] < [|y|] | Gt => [|x|] > [|y|] end. - Proof. - refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto. - exact (spec_compare op_spec). + Proof. + refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto. + exact (spec_compare op_spec). Qed. Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0. - Proof. destruct x;simpl;intros;trivial;discriminate. Qed. + Proof. destruct x;simpl;intros;trivial;discriminate. Qed. Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|]. Proof. @@ -440,7 +440,7 @@ Section Z_2nZ. 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 + refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp w_digits w_to_Z _ _ _ _ _); auto. Qed. @@ -480,25 +480,25 @@ Section Z_2nZ. Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB. Proof. - refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ + refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto. Qed. Let spec_ww_pred_c : forall x, [-|pred_c x|] = [|x|] - 1. Proof. - refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z + refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z _ _ _ _ _);wwauto. Qed. Let spec_ww_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]. Proof. - refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c + refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _);wwauto. Qed. Let spec_ww_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|]-[|y|]-1. Proof. - refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c + refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto. Qed. @@ -533,17 +533,17 @@ Section Z_2nZ. _ _ _ _ _ _ _ _ _ _ _ _); wwauto. unfold w_digits; apply spec_more_than_1_digit; auto. exact (spec_compare op_spec). - Qed. + Qed. Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB. Proof. refine (spec_ww_mul w_W0 w_add w_mul_c w_mul add w_digits w_to_Z _ _ _ _ _); - wwauto. + wwauto. Qed. Let spec_ww_square_c : forall x, [[square_c x]] = [|x|] * [|x|]. Proof. - refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add + refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add add_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);wwauto. Qed. @@ -574,7 +574,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, @@ -602,7 +602,7 @@ Section Z_2nZ. unfold wB, base; auto with zarith. Qed. - Let spec_ww_digits: + Let spec_ww_digits: [|_ww_zdigits|] = Zpos (xO w_digits). Proof. unfold w_to_Z, _ww_zdigits. @@ -615,7 +615,7 @@ Section Z_2nZ. Let spec_ww_head00 : forall x, [|x|] = 0 -> [|head0 x|] = Zpos _ww_digits. Proof. - refine (spec_ww_head00 w_0 w_0W + refine (spec_ww_head00 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); auto. exact (spec_compare op_spec). @@ -626,8 +626,8 @@ Section Z_2nZ. Let spec_ww_head0 : forall x, 0 < [|x|] -> wwB/ 2 <= 2 ^ [|head0 x|] * [|x|] < wwB. Proof. - refine (spec_ww_head0 w_0 w_0W w_compare w_head0 - w_add2 w_zdigits _ww_zdigits + refine (spec_ww_head0 w_0 w_0W w_compare w_head0 + w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);wwauto. exact (spec_compare op_spec). exact (spec_zdigits op_spec). @@ -635,7 +635,7 @@ Section Z_2nZ. Let spec_ww_tail00 : forall x, [|x|] = 0 -> [|tail0 x|] = Zpos _ww_digits. Proof. - refine (spec_ww_tail00 w_0 w_0W + refine (spec_ww_tail00 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); wwauto. exact (spec_compare op_spec). @@ -647,7 +647,7 @@ Section Z_2nZ. Let spec_ww_tail0 : forall x, 0 < [|x|] -> exists y, 0 <= y /\ [|x|] = (2 * y + 1) * 2 ^ [|tail0 x|]. Proof. - refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0 + refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);wwauto. exact (spec_compare op_spec). exact (spec_zdigits op_spec). @@ -659,19 +659,19 @@ Section Z_2nZ. ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos _ww_digits) - [|p|]))) mod wwB. Proof. - refine (@spec_ww_add_mul_div w w_0 w_WW w_W0 w_0W compare w_add_mul_div + refine (@spec_ww_add_mul_div w w_0 w_WW w_W0 w_0W compare w_add_mul_div sub w_digits w_zdigits low w_to_Z _ _ _ _ _ _ _ _ _ _ _);wwauto. exact (spec_zdigits op_spec). Qed. - Let spec_ww_div_gt : forall a b, + Let spec_ww_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> let (q,r) := div_gt a b in [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. Proof. -refine -(@spec_ww_div_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 +refine +(@spec_ww_div_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ @@ -707,14 +707,14 @@ refine refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);auto. Qed. - Let spec_ww_mod_gt : forall a b, + Let spec_ww_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> [|mod_gt a b|] = [|a|] mod [|b|]. Proof. - refine (@spec_ww_mod_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 + refine (@spec_ww_mod_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_mod_gt - w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div - w_zdigits w_to_Z + w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div + w_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. exact (spec_compare op_spec). exact (spec_div_gt op_spec). @@ -731,12 +731,12 @@ refine Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] -> Zis_gcd [|a|] [|b|] [|gcd_gt a b|]. Proof. - refine (@spec_ww_gcd_gt w w_digits W0 w_to_Z _ + refine (@spec_ww_gcd_gt w w_digits W0 w_to_Z _ w_0 w_0 w_eq0 w_gcd_gt _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto. refine (@spec_ww_gcd_gt_aux w 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 + w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. exact (spec_compare op_spec). exact (spec_div21 op_spec). @@ -753,7 +753,7 @@ refine _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto. refine (@spec_ww_gcd_gt_aux w 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 + w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. exact (spec_compare op_spec). exact (spec_div21 op_spec). @@ -798,7 +798,7 @@ refine Let spec_ww_sqrt : forall x, [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. Proof. - refine (@spec_ww_sqrt w w_is_even w_0 w_1 w_Bm1 + refine (@spec_ww_sqrt w 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. @@ -814,7 +814,7 @@ refine apply mk_znz_spec;auto. exact spec_ww_add_mul_div. - refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW + refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _);wwauto. exact (spec_pos_mod op_spec). @@ -828,7 +828,7 @@ refine Proof. apply mk_znz_spec;auto. exact spec_ww_add_mul_div. - refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW + refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _);wwauto. exact (spec_pos_mod op_spec). @@ -838,10 +838,10 @@ refine rewrite <- Zpos_xO; exact spec_ww_digits. Qed. -End Z_2nZ. - +End Z_2nZ. + Section MulAdd. - + Variable w: Type. Variable op: znz_op w. Variable sop: znz_spec op. @@ -870,7 +870,7 @@ Section MulAdd. End MulAdd. -(** Modular versions of DoubleCyclic *) +(** Modular versions of DoubleCyclic *) Module DoubleCyclic (C:CyclicType) <: CyclicType. Definition w := zn2z C.w. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v index 075aef59..9204b4e0 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleDiv.v 10964 2008-05-22 11:08:13Z letouzey $ i*) +(*i $Id$ i*) Set Implicit Arguments. @@ -20,7 +20,7 @@ Require Import DoubleDivn1. Require Import DoubleAdd. Require Import DoubleSub. -Open Local Scope Z_scope. +Local Open Scope Z_scope. Ltac zarith := auto with zarith. @@ -41,13 +41,13 @@ Section POS_MOD. Variable ww_zdigits : zn2z w. - Definition ww_pos_mod p x := + Definition ww_pos_mod p x := let zdigits := w_0W w_zdigits in match x with | W0 => W0 | WW xh xl => match ww_compare p zdigits with - | Eq => w_WW w_0 xl + | Eq => w_WW w_0 xl | Lt => w_WW w_0 (w_pos_mod (low p) xl) | Gt => match ww_compare p ww_zdigits with @@ -87,7 +87,7 @@ Section POS_MOD. | Lt => [[x]] < [[y]] | Gt => [[x]] > [[y]] end. - Variable spec_ww_sub: forall x y, + Variable spec_ww_sub: forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits. @@ -106,7 +106,7 @@ Section POS_MOD. unfold ww_pos_mod; case w1. simpl; rewrite Zmod_small; split; auto with zarith. intros xh xl; generalize (spec_ww_compare p (w_0W w_zdigits)); - case ww_compare; + case ww_compare; rewrite spec_w_0W; rewrite spec_zdigits; fold wB; intros H1. rewrite H1; simpl ww_to_Z. @@ -135,13 +135,13 @@ Section POS_MOD. autorewrite with w_rewrite rm10. rewrite Zmod_mod; auto with zarith. generalize (spec_ww_compare p ww_zdigits); - case ww_compare; rewrite spec_ww_zdigits; + case ww_compare; rewrite spec_ww_zdigits; rewrite spec_zdigits; intros H2. replace (2^[[p]]) with wwB. rewrite Zmod_small; auto with zarith. unfold base; rewrite H2. rewrite spec_ww_digits; auto. - assert (HH0: [|low (ww_sub p (w_0W w_zdigits))|] = + assert (HH0: [|low (ww_sub p (w_0W w_zdigits))|] = [[p]] - Zpos w_digits). rewrite spec_low. rewrite spec_ww_sub. @@ -152,11 +152,11 @@ generalize (spec_ww_compare p ww_zdigits); apply Zlt_le_trans with (Zpos w_digits); auto with zarith. unfold base; apply Zpower2_le_lin; auto with zarith. exists wB; unfold base; rewrite <- Zpower_exp; auto with zarith. - rewrite spec_ww_digits; + rewrite spec_ww_digits; apply f_equal with (f := Zpower 2); rewrite Zpos_xO; auto with zarith. simpl ww_to_Z; autorewrite with w_rewrite. rewrite spec_pos_mod; rewrite HH0. - pattern [|xh|] at 2; + pattern [|xh|] at 2; rewrite Z_div_mod_eq with (b := 2 ^ ([[p]] - Zpos w_digits)); auto with zarith. rewrite (fun x => (Zmult_comm (2 ^ x))); rewrite Zmult_plus_distr_l. @@ -196,7 +196,7 @@ generalize (spec_ww_compare p ww_zdigits); split; auto with zarith. rewrite Zpos_xO; auto with zarith. Qed. - + End POS_MOD. Section DoubleDiv32. @@ -222,24 +222,24 @@ Section DoubleDiv32. 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 + 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 + 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 + 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. - (* Proof *) + (* Proof *) Variable w_digits : positive. Variable w_to_Z : w -> Z. @@ -253,8 +253,8 @@ Section DoubleDiv32. (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). @@ -273,7 +273,7 @@ Section DoubleDiv32. | Gt => [|x|] > [|y|] end. Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add_carry_c : + Variable spec_w_add_carry_c : forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. @@ -315,8 +315,8 @@ Section DoubleDiv32. wB/2 <= [|b1|] -> [[WW a1 a2]] < [[WW b1 b2]] -> let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + [|a1|] * wwB + [|a2|] * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ 0 <= [[r]] < [|b1|] * wB + [|b2|]. Proof. intros a1 a2 a3 b1 b2 Hle Hlt. @@ -327,17 +327,17 @@ Section DoubleDiv32. 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 + 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 + 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 + 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) @@ -360,7 +360,7 @@ Section DoubleDiv32. [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ 0 <= [[r]] < [|b1|] * wB + [|b2|]);eauto. rewrite H0;intros r. - repeat + repeat (rewrite spec_ww_add;eauto || rewrite spec_w_Bm1 || rewrite spec_w_Bm2); simpl ww_to_Z;try rewrite Zmult_1_l;intros H1. assert (0<= ([[r]] + ([|b1|] * wB + [|b2|])) - wwB < [|b1|] * wB + [|b2|]). @@ -385,7 +385,7 @@ Section DoubleDiv32. 1 ([[r]] + ([|b1|] * wB + [|b2|]) - wwB));zarith;try (ring;fail). split. rewrite H1;rewrite Hcmp;ring. trivial. Spec_ww_to_Z (WW b1 b2). simpl in HH4;zarith. - rewrite H0;intros r;repeat + rewrite H0;intros r;repeat (rewrite spec_w_Bm1 || rewrite spec_w_Bm2); simpl ww_to_Z;try rewrite Zmult_1_l;intros H1. assert ([[r]]=([|a2|]-[|b2|])*wB+[|a3|]+([|b1|]*wB+[|b2|])). zarith. @@ -409,7 +409,7 @@ Section DoubleDiv32. as [r1|r1];repeat (rewrite spec_w_WW || rewrite spec_mul_c); unfold interp_carry;intros H1. rewrite H1. - split. ring. split. + split. ring. split. rewrite <- H1;destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z r1);trivial. apply Zle_lt_trans with ([|r|] * wB + [|a3|]). assert ( 0 <= [|q|] * [|b2|]);zarith. @@ -418,7 +418,7 @@ Section DoubleDiv32. rewrite <- H1;ring. Spec_ww_to_Z r1; assert (0 <= [|r|]*wB). zarith. assert (0 < [|q|] * [|b2|]). zarith. - assert (0 < [|q|]). + assert (0 < [|q|]). apply Zmult_lt_0_reg_r_2 with [|b2|];zarith. eapply spec_ww_add_c_cont with (P := fun (x y:zn2z w) (res:w*zn2z w) => @@ -440,18 +440,18 @@ Section DoubleDiv32. wwB * 1 + ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2 * ([|b1|] * wB + [|b2|]))). rewrite H7;rewrite H2;ring. - assert - ([|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) + assert + ([|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) < [|b1|]*wB + [|b2|]). Spec_ww_to_Z r2;omega. Spec_ww_to_Z (WW b1 b2). simpl in HH5. - assert - (0 <= [|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) + assert + (0 <= [|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) < wwB). split;try omega. replace (2*([|b1|]*wB+[|b2|])) with ((2*[|b1|])*wB+2*[|b2|]). 2:ring. assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB). rewrite wwB_wBwB; rewrite Zpower_2; zarith. omega. - rewrite <- (Zmod_unique + rewrite <- (Zmod_unique ([[r2]] + ([|b1|] * wB + [|b2|])) wwB 1 @@ -486,7 +486,7 @@ Section DoubleDiv21. Definition ww_div21 a1 a2 b := match a1 with - | W0 => + | W0 => match ww_compare a2 b with | Gt => (ww_1, ww_sub a2 b) | Eq => (ww_1, W0) @@ -529,8 +529,8 @@ Section DoubleDiv21. Notation wwB := (base (ww_digits w_digits)). Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). Variable spec_w_0 : [|w_0|] = 0. @@ -540,8 +540,8 @@ Section DoubleDiv21. wB/2 <= [|b1|] -> [[WW a1 a2]] < [[WW b1 b2]] -> let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + [|a1|] * wwB + [|a2|] * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ 0 <= [[r]] < [|b1|] * wB + [|b2|]. Variable spec_ww_1 : [[ww_1]] = 1. Variable spec_ww_compare : forall x y, @@ -591,10 +591,10 @@ Section DoubleDiv21. intros Hlt H; match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); intros q1 r H0 - end; (assert (Eq1: wB / 2 <= [|b1|]);[ + end; (assert (Eq1: wB / 2 <= [|b1|]);[ apply (@beta_lex (wB / 2) 0 [|b1|] [|b2|] wB); auto with zarith; autorewrite with rm10;repeat rewrite (Zmult_comm wB); - rewrite <- wwB_div_2; trivial + rewrite <- wwB_div_2; trivial | generalize (H0 Eq1 Hlt);clear H0;destruct r as [ |r1 r2];simpl; try rewrite spec_w_0; try rewrite spec_w_0W;repeat rewrite Zplus_0_r; intros (H1,H2) ]). @@ -611,10 +611,10 @@ Section DoubleDiv21. rewrite <- wwB_wBwB;rewrite H1. rewrite spec_w_0 in H4;rewrite Zplus_0_r in H4. repeat rewrite Zmult_plus_distr_l. rewrite <- (Zmult_assoc [|r1|]). - rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H4;simpl;ring. + rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H4;simpl;ring. split;[rewrite wwB_wBwB | split;zarith]. - replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|])) - with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]). + replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|])) + with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]). rewrite H1;ring. rewrite wwB_wBwB;ring. change [|a4|] with (0*wB+[|a4|]);apply beta_lex_inv;zarith. assert (1 <= wB/2);zarith. @@ -624,7 +624,7 @@ Section DoubleDiv21. intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end. split;trivial. replace (([|a1h|] * wB + [|a1l|]) * wwB + ([|a3|] * wB + [|a4|])) with - (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB + [|a4|]); + (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB + [|a4|]); [rewrite H1 | rewrite wwB_wBwB;ring]. replace (([|q1|]*([|b1|]*wB+[|b2|])+([|r1|]*wB+[|r2|]))*wB+[|a4|]) with (([|q1|]*([|b1|]*wB+[|b2|]))*wB+([|r1|]*wwB+[|r2|]*wB+[|a4|])); @@ -666,22 +666,22 @@ Section DoubleDivGt. Eval lazy beta iota delta [ww_sub ww_opp] in let p := w_head0 bh in match w_compare p w_0 with - | Gt => + | Gt => let b1 := w_add_mul_div p bh bl in let b2 := w_add_mul_div p bl w_0 in let a1 := w_add_mul_div p w_0 ah in let a2 := w_add_mul_div p ah al in let a3 := w_add_mul_div p al w_0 in let (q,r) := w_div32 a1 a2 a3 b1 b2 in - (WW w_0 q, ww_add_mul_div + (WW w_0 q, ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r) | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)) end. - Definition ww_div_gt a b := - Eval lazy beta iota delta [ww_div_gt_aux double_divn1 + Definition ww_div_gt a b := + Eval lazy beta iota delta [ww_div_gt_aux double_divn1 double_divn1_p double_divn1_p_aux double_divn1_0 double_divn1_0_aux double_split double_0 double_WW] in match a, b with @@ -691,11 +691,11 @@ Section DoubleDivGt. if w_eq0 ah then let (q,r) := w_div_gt al bl in (WW w_0 q, w_0W r) - else + else match w_compare w_0 bh with - | Eq => + | Eq => let(q,r):= - double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 + double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 a bl in (q, w_0W r) | Lt => ww_div_gt_aux ah al bh bl @@ -707,7 +707,7 @@ Section DoubleDivGt. Eval lazy beta iota delta [ww_sub ww_opp] in let p := w_head0 bh in match w_compare p w_0 with - | Gt => + | Gt => let b1 := w_add_mul_div p bh bl in let b2 := w_add_mul_div p bl w_0 in let a1 := w_add_mul_div p w_0 ah in @@ -716,13 +716,13 @@ Section DoubleDivGt. let (q,r) := w_div32 a1 a2 a3 b1 b2 in ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r - | _ => + | _ => ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry (WW ah al) (WW bh bl) end. - Definition ww_mod_gt a b := - Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 + Definition ww_mod_gt a b := + Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux double_split double_0 double_WW snd] in match a, b with @@ -730,10 +730,10 @@ Section DoubleDivGt. | _, W0 => W0 | WW ah al, WW bh bl => if w_eq0 ah then w_0W (w_mod_gt al bl) - else + else match w_compare w_0 bh with - | Eq => - w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + | Eq => + w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 w_compare w_sub 1 a bl) | Lt => ww_mod_gt_aux ah al bh bl | Gt => W0 (* cas absurde *) @@ -741,14 +741,14 @@ Section DoubleDivGt. end. Definition ww_gcd_gt_body (cont: w->w->w->w->zn2z w) (ah al bh bl: w) := - Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 + Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux double_split double_0 double_WW snd] in match w_compare w_0 bh with | Eq => match w_compare w_0 bl with | Eq => WW ah al (* normalement n'arrive pas si forme normale *) - | Lt => + | Lt => let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW ah al) bl in WW w_0 (w_gcd_gt bl m) @@ -757,14 +757,14 @@ Section DoubleDivGt. | Lt => let m := ww_mod_gt_aux ah al bh bl in match m with - | W0 => WW bh bl + | W0 => WW bh bl | WW mh ml => match w_compare w_0 mh with | Eq => match w_compare w_0 ml with | Eq => WW bh bl - | _ => - let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + | _ => + let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW bh bl) ml in WW w_0 (w_gcd_gt ml r) end @@ -779,18 +779,18 @@ Section DoubleDivGt. end | Gt => W0 (* absurde *) end. - - Fixpoint ww_gcd_gt_aux - (p:positive) (cont: w -> w -> w -> w -> zn2z w) (ah al bh bl : w) + + Fixpoint ww_gcd_gt_aux + (p:positive) (cont: w -> w -> w -> w -> zn2z w) (ah al bh bl : w) {struct p} : zn2z w := - ww_gcd_gt_body + ww_gcd_gt_body (fun mh ml rh rl => match p with | xH => cont mh ml rh rl | xO p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl | xI p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl end) ah al bh bl. - + (* Proof *) Variable w_to_Z : w -> Z. @@ -816,7 +816,7 @@ Section DoubleDivGt. | Gt => [|x|] > [|y|] end. Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. - + Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB. Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1. @@ -854,8 +854,8 @@ Section DoubleDivGt. wB/2 <= [|b1|] -> [[WW a1 a2]] < [[WW b1 b2]] -> let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + [|a1|] * wwB + [|a2|] * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ 0 <= [[r]] < [|b1|] * wB + [|b2|]. Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits. @@ -899,14 +899,14 @@ Section DoubleDivGt. change (let (q, r) := let p := w_head0 bh in match w_compare p w_0 with - | Gt => + | Gt => let b1 := w_add_mul_div p bh bl in let b2 := w_add_mul_div p bl w_0 in let a1 := w_add_mul_div p w_0 ah in let a2 := w_add_mul_div p ah al in let a3 := w_add_mul_div p al w_0 in let (q,r) := w_div32 a1 a2 a3 b1 b2 in - (WW w_0 q, ww_add_mul_div + (WW w_0 q, ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r) | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c @@ -931,7 +931,7 @@ Section DoubleDivGt. case (spec_to_Z (w_head0 bh)); auto with zarith. assert ([|w_head0 bh|] < Zpos w_digits). destruct (Z_lt_ge_dec [|w_head0 bh|] (Zpos w_digits));trivial. - elimtype False. + exfalso. assert (2 ^ [|w_head0 bh|] * [|bh|] >= wB);auto with zarith. apply Zle_ge; replace wB with (wB * 1);try ring. Spec_w_to_Z bh;apply Zmult_le_compat;zarith. @@ -945,11 +945,11 @@ Section DoubleDivGt. (spec_add_mul_div bl w_0 Hb); rewrite spec_w_0; repeat rewrite Zmult_0_l;repeat rewrite Zplus_0_l; rewrite Zdiv_0_l;repeat rewrite Zplus_0_r. - Spec_w_to_Z ah;Spec_w_to_Z bh. + Spec_w_to_Z ah;Spec_w_to_Z bh. unfold base;repeat rewrite Zmod_shift_r;zarith. assert (H3:=to_Z_div_minus_p ah HHHH);assert(H4:=to_Z_div_minus_p al HHHH); assert (H5:=to_Z_div_minus_p bl HHHH). - rewrite Zmult_comm in Hh. + rewrite Zmult_comm in Hh. assert (2^[|w_head0 bh|] < wB). unfold base;apply Zpower_lt_monotone;zarith. unfold base in H0;rewrite Zmod_small;zarith. fold wB; rewrite (Zmod_small ([|bh|] * 2 ^ [|w_head0 bh|]));zarith. @@ -964,15 +964,15 @@ Section DoubleDivGt. (w_add_mul_div (w_head0 bh) al w_0) (w_add_mul_div (w_head0 bh) bh bl) (w_add_mul_div (w_head0 bh) bl w_0)) as (q,r). - rewrite V1;rewrite V2. rewrite Zmult_plus_distr_l. - rewrite <- (Zplus_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)). + rewrite V1;rewrite V2. rewrite Zmult_plus_distr_l. + rewrite <- (Zplus_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)). unfold base;rewrite <- shift_unshift_mod;zarith. fold wB. replace ([|bh|] * 2 ^ [|w_head0 bh|] * wB + [|bl|] * 2 ^ [|w_head0 bh|]) with ([[WW bh bl]] * 2^[|w_head0 bh|]). 2:simpl;ring. fold wwB. rewrite wwB_wBwB. rewrite Zpower_2. rewrite U1;rewrite U2;rewrite U3. - rewrite Zmult_assoc. rewrite Zmult_plus_distr_l. + rewrite Zmult_assoc. rewrite Zmult_plus_distr_l. rewrite (Zplus_assoc ([|ah|] / 2^(Zpos(w_digits) - [|w_head0 bh|])*wB * wB)). - rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc. + rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc. unfold base;repeat rewrite <- shift_unshift_mod;zarith. fold wB. replace ([|ah|] * 2 ^ [|w_head0 bh|] * wB + [|al|] * 2 ^ [|w_head0 bh|]) with ([[WW ah al]] * 2^[|w_head0 bh|]). 2:simpl;ring. @@ -1027,7 +1027,7 @@ Section DoubleDivGt. [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]. Proof. - intros a b Hgt Hpos;unfold ww_div_gt. + intros a b Hgt Hpos;unfold ww_div_gt. change (let (q,r) := match a, b with | W0, _ => (W0,W0) | _, W0 => (W0,W0) @@ -1035,23 +1035,23 @@ Section DoubleDivGt. if w_eq0 ah then let (q,r) := w_div_gt al bl in (WW w_0 q, w_0W r) - else + else match w_compare w_0 bh with - | Eq => + | Eq => let(q,r):= - double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 + double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 a bl in (q, w_0W r) | Lt => ww_div_gt_aux ah al bh bl | Gt => (W0,W0) (* cas absurde *) end - end in [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]). + end in [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]). destruct a as [ |ah al]. simpl in Hgt;omega. destruct b as [ |bh bl]. simpl in Hpos;omega. Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). simpl ww_to_Z;rewrite H;trivial. simpl in Hgt;rewrite H in Hgt;trivial. - assert ([|bh|] <= 0). + assert ([|bh|] <= 0). apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;rewrite H1;simpl in Hgt. simpl. simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. @@ -1066,12 +1066,12 @@ Section DoubleDivGt. w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hpos). unfold double_to_Z,double_wB,double_digits in H2. - destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 + destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW ah al) bl). rewrite spec_w_0W;unfold ww_to_Z;trivial. apply spec_ww_div_gt_aux;trivial. rewrite spec_w_0 in Hcmp;trivial. - rewrite spec_w_0 in Hcmp;elimtype False;omega. + rewrite spec_w_0 in Hcmp;exfalso;omega. Qed. Lemma spec_ww_mod_gt_aux_eq : forall ah al bh bl, @@ -1104,26 +1104,26 @@ Section DoubleDivGt. rewrite Zmult_comm in H;destruct H. symmetry;apply Zmod_unique with [|q|];trivial. Qed. - + Lemma spec_ww_mod_gt_eq : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> [[ww_mod_gt a b]] = [[snd (ww_div_gt a b)]]. Proof. intros a b Hgt Hpos. - change (ww_mod_gt a b) with + change (ww_mod_gt a b) with (match a, b with | W0, _ => W0 | _, W0 => W0 | WW ah al, WW bh bl => if w_eq0 ah then w_0W (w_mod_gt al bl) - else + else match w_compare w_0 bh with - | Eq => - w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + | Eq => + w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 w_compare w_sub 1 a bl) | Lt => ww_mod_gt_aux ah al bh bl | Gt => W0 (* cas absurde *) end end). - change (ww_div_gt a b) with + change (ww_div_gt a b) with (match a, b with | W0, _ => (W0,W0) | _, W0 => (W0,W0) @@ -1131,11 +1131,11 @@ Section DoubleDivGt. if w_eq0 ah then let (q,r) := w_div_gt al bl in (WW w_0 q, w_0W r) - else + else match w_compare w_0 bh with - | Eq => + | Eq => let(q,r):= - double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 + double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 a bl in (q, w_0W r) | Lt => ww_div_gt_aux ah al bh bl @@ -1147,7 +1147,7 @@ Section DoubleDivGt. Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). simpl in Hgt;rewrite H in Hgt;trivial. - assert ([|bh|] <= 0). + assert ([|bh|] <= 0). apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. @@ -1155,7 +1155,7 @@ Section DoubleDivGt. destruct (w_div_gt al bl);simpl;rewrite spec_w_0W;trivial. clear H. assert (H2 := spec_compare w_0 bh);destruct (w_compare w_0 bh). - rewrite (@spec_double_modn1_aux w w_zdigits w_0 w_WW w_head0 w_add_mul_div + rewrite (@spec_double_modn1_aux w w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub w_to_Z spec_w_0 spec_compare 1 (WW ah al) bl). destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW ah al) bl);simpl;trivial. @@ -1174,7 +1174,7 @@ Section DoubleDivGt. rewrite Zmult_comm;trivial. Qed. - Lemma Zis_gcd_mod : forall a b d, + Lemma Zis_gcd_mod : forall a b d, 0 < b -> Zis_gcd b (a mod b) d -> Zis_gcd a b d. Proof. intros a b d H H1; apply Zis_gcd_for_euclid with (a/b). @@ -1182,12 +1182,12 @@ Section DoubleDivGt. ring_simplify (b * (a / b) + a mod b - a / b * b);trivial. zarith. Qed. - Lemma spec_ww_gcd_gt_aux_body : + Lemma spec_ww_gcd_gt_aux_body : forall ah al bh bl n cont, - [[WW bh bl]] <= 2^n -> + [[WW bh bl]] <= 2^n -> [[WW ah al]] > [[WW bh bl]] -> - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^(n-1) -> + (forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^(n-1) -> Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> Zis_gcd [[WW ah al]] [[WW bh bl]] [[ww_gcd_gt_body cont ah al bh bl]]. Proof. @@ -1196,7 +1196,7 @@ Section DoubleDivGt. | Eq => match w_compare w_0 bl with | Eq => WW ah al (* normalement n'arrive pas si forme normale *) - | Lt => + | Lt => let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW ah al) bl in WW w_0 (w_gcd_gt bl m) @@ -1205,14 +1205,14 @@ Section DoubleDivGt. | Lt => let m := ww_mod_gt_aux ah al bh bl in match m with - | W0 => WW bh bl + | W0 => WW bh bl | WW mh ml => match w_compare w_0 mh with | Eq => match w_compare w_0 ml with | Eq => WW bh bl - | _ => - let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + | _ => + let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW bh bl) ml in WW w_0 (w_gcd_gt ml r) end @@ -1227,10 +1227,10 @@ Section DoubleDivGt. end | Gt => W0 (* absurde *) end). - assert (Hbh := spec_compare w_0 bh);destruct (w_compare w_0 bh). + assert (Hbh := spec_compare w_0 bh);destruct (w_compare w_0 bh). simpl ww_to_Z in *. rewrite spec_w_0 in Hbh;rewrite <- Hbh; rewrite Zmult_0_l;rewrite Zplus_0_l. - assert (Hbl := spec_compare w_0 bl); destruct (w_compare w_0 bl). + assert (Hbl := spec_compare w_0 bl); destruct (w_compare w_0 bl). rewrite spec_w_0 in Hbl;rewrite <- Hbl;apply Zis_gcd_0. simpl;rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l. rewrite spec_w_0 in Hbl. @@ -1239,54 +1239,54 @@ Section DoubleDivGt. rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hbl). - apply spec_gcd_gt. - rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. - apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + apply spec_gcd_gt. + rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. + apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => destruct (Z_mod_lt x y);zarith end. - rewrite spec_w_0 in Hbl;Spec_w_to_Z bl;elimtype False;omega. + rewrite spec_w_0 in Hbl;Spec_w_to_Z bl;exfalso;omega. rewrite spec_w_0 in Hbh;assert (H:= spec_ww_mod_gt_aux _ _ _ Hgt Hbh). - assert (H2 : 0 < [[WW bh bl]]). + assert (H2 : 0 < [[WW bh bl]]). simpl;Spec_w_to_Z bl. apply Zlt_le_trans with ([|bh|]*wB);zarith. apply Zmult_lt_0_compat;zarith. apply Zis_gcd_mod;trivial. rewrite <- H. simpl in *;destruct (ww_mod_gt_aux ah al bh bl) as [ |mh ml]. - simpl;apply Zis_gcd_0;zarith. - assert (Hmh := spec_compare w_0 mh);destruct (w_compare w_0 mh). + simpl;apply Zis_gcd_0;zarith. + assert (Hmh := spec_compare w_0 mh);destruct (w_compare w_0 mh). simpl;rewrite spec_w_0 in Hmh; rewrite <- Hmh;simpl. - assert (Hml := spec_compare w_0 ml);destruct (w_compare w_0 ml). + assert (Hml := spec_compare w_0 ml);destruct (w_compare w_0 ml). rewrite <- Hml;rewrite spec_w_0;simpl;apply Zis_gcd_0. - simpl;rewrite spec_w_0;simpl. + simpl;rewrite spec_w_0;simpl. rewrite spec_w_0 in Hml. apply Zis_gcd_mod;zarith. change ([|bh|] * wB + [|bl|]) with (double_to_Z w_digits w_to_Z 1 (WW bh bl)). rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div spec_div21 spec_compare spec_sub 1 (WW bh bl) ml Hml). - apply spec_gcd_gt. - rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. - apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + apply spec_gcd_gt. + rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. + apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => destruct (Z_mod_lt x y);zarith end. - rewrite spec_w_0 in Hml;Spec_w_to_Z ml;elimtype False;omega. + rewrite spec_w_0 in Hml;Spec_w_to_Z ml;exfalso;omega. rewrite spec_w_0 in Hmh. assert ([[WW bh bl]] > [[WW mh ml]]). - rewrite H;simpl; apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + rewrite H;simpl; apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => destruct (Z_mod_lt x y);zarith end. assert (H1:= spec_ww_mod_gt_aux _ _ _ H0 Hmh). - assert (H3 : 0 < [[WW mh ml]]). + assert (H3 : 0 < [[WW mh ml]]). simpl;Spec_w_to_Z ml. apply Zlt_le_trans with ([|mh|]*wB);zarith. apply Zmult_lt_0_compat;zarith. apply Zis_gcd_mod;zarith. simpl in *;rewrite <- H1. destruct (ww_mod_gt_aux bh bl mh ml) as [ |rh rl]. simpl; apply Zis_gcd_0. simpl;apply Hcont. simpl in H1;rewrite H1. - apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => destruct (Z_mod_lt x y);zarith end. - apply Zle_trans with (2^n/2). - apply Zdiv_le_lower_bound;zarith. + apply Zle_trans with (2^n/2). + apply Zdiv_le_lower_bound;zarith. apply Zle_trans with ([|bh|] * wB + [|bl|]);zarith. assert (H3' := Z_div_mod_eq [[WW bh bl]] [[WW mh ml]] (Zlt_gt _ _ H3)). assert (H4' : 0 <= [[WW bh bl]]/[[WW mh ml]]). apply Zge_le;apply Z_div_ge0;zarith. simpl in *;rewrite H1. pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3'. destruct (Zle_lt_or_eq _ _ H4'). - assert (H6' : [[WW bh bl]] mod [[WW mh ml]] = + assert (H6' : [[WW bh bl]] mod [[WW mh ml]] = [[WW bh bl]] - [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). simpl;pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3';ring. simpl in H6'. assert ([[WW mh ml]] <= [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). @@ -1300,14 +1300,14 @@ Section DoubleDivGt. rewrite Z_div_mult;zarith. assert (2^1 <= 2^n). change (2^1) with 2;zarith. assert (H7 := @Zpower_le_monotone_inv 2 1 n);zarith. - rewrite spec_w_0 in Hmh;Spec_w_to_Z mh;elimtype False;zarith. - rewrite spec_w_0 in Hbh;Spec_w_to_Z bh;elimtype False;zarith. + rewrite spec_w_0 in Hmh;Spec_w_to_Z mh;exfalso;zarith. + rewrite spec_w_0 in Hbh;Spec_w_to_Z bh;exfalso;zarith. Qed. - Lemma spec_ww_gcd_gt_aux : + Lemma spec_ww_gcd_gt_aux : forall p cont n, - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> + (forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^n -> Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> @@ -1334,7 +1334,7 @@ Section DoubleDivGt. apply Zle_trans with (2 ^ (Zpos p + n -1));zarith. apply Zpower_le_monotone2;zarith. apply Zle_trans with (2 ^ (2*Zpos p + n -1));zarith. - apply Zpower_le_monotone2;zarith. + apply Zpower_le_monotone2;zarith. apply spec_ww_gcd_gt_aux_body with (n := n+1);trivial. rewrite Zplus_comm;trivial. ring_simplify (n + 1 - 1);trivial. @@ -1352,16 +1352,16 @@ Section DoubleDiv. Variable ww_div_gt : zn2z w -> zn2z w -> zn2z w * zn2z w. Variable ww_mod_gt : zn2z w -> zn2z w -> zn2z w. - Definition ww_div a b := - match ww_compare a b with - | Gt => ww_div_gt a b + Definition ww_div a b := + match ww_compare a b with + | Gt => ww_div_gt a b | Eq => (ww_1, W0) | Lt => (W0, a) end. - Definition ww_mod a b := - match ww_compare a b with - | Gt => ww_mod_gt a b + Definition ww_mod a b := + match ww_compare a b with + | Gt => ww_mod_gt a b | Eq => W0 | Lt => a end. @@ -1401,7 +1401,7 @@ Section DoubleDiv. Proof. intros a b Hpos;unfold ww_div. assert (H:=spec_ww_compare a b);destruct (ww_compare a b). - simpl;rewrite spec_ww_1;split;zarith. + simpl;rewrite spec_ww_1;split;zarith. simpl;split;[ring|Spec_ww_to_Z a;zarith]. apply spec_ww_div_gt;trivial. Qed. @@ -1409,7 +1409,7 @@ Section DoubleDiv. Lemma spec_ww_mod : forall a b, 0 < [[b]] -> [[ww_mod a b]] = [[a]] mod [[b]]. Proof. - intros a b Hpos;unfold ww_mod. + intros a b Hpos;unfold ww_mod. assert (H := spec_ww_compare a b);destruct (ww_compare a b). simpl;apply Zmod_unique with 1;try rewrite H;zarith. Spec_ww_to_Z a;symmetry;apply Zmod_small;zarith. @@ -1424,8 +1424,8 @@ Section DoubleDiv. Variable w_gcd_gt : w -> w -> w. Variable _ww_digits : positive. Variable spec_ww_digits_ : _ww_digits = xO w_digits. - Variable ww_gcd_gt_fix : - positive -> (w -> w -> w -> w -> zn2z w) -> + Variable ww_gcd_gt_fix : + positive -> (w -> w -> w -> w -> zn2z w) -> w -> w -> w -> w -> zn2z w. Variable spec_w_0 : [|w_0|] = 0. @@ -1440,10 +1440,10 @@ Section DoubleDiv. Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. Variable spec_gcd_gt : forall a b, [|a|] > [|b|] -> Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]. - Variable spec_gcd_gt_fix : + Variable spec_gcd_gt_fix : forall p cont n, - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> + (forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^n -> Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> @@ -1451,20 +1451,20 @@ Section DoubleDiv. Zis_gcd [[WW ah al]] [[WW bh bl]] [[ww_gcd_gt_fix p cont ah al bh bl]]. - Definition gcd_cont (xh xl yh yl:w) := + Definition gcd_cont (xh xl yh yl:w) := match w_compare w_1 yl with - | Eq => ww_1 + | Eq => ww_1 | _ => WW xh xl end. - Lemma spec_gcd_cont : forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> + Lemma spec_gcd_cont : forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 1 -> Zis_gcd [[WW xh xl]] [[WW yh yl]] [[gcd_cont xh xl yh yl]]. Proof. intros xh xl yh yl Hgt' Hle. simpl in Hle. assert ([|yh|] = 0). - change 1 with (0*wB+1) in Hle. + change 1 with (0*wB+1) in Hle. assert (0 <= 1 < wB). split;zarith. apply wB_pos. assert (H1:= beta_lex _ _ _ _ _ Hle (spec_to_Z yl) H). Spec_w_to_Z yh;zarith. @@ -1473,20 +1473,20 @@ Section DoubleDiv. simpl;rewrite H;simpl;destruct (w_compare w_1 yl). rewrite spec_ww_1;rewrite <- Hcmpy;apply Zis_gcd_mod;zarith. rewrite <- (Zmod_unique ([|xh|]*wB+[|xl|]) 1 ([|xh|]*wB+[|xl|]) 0);zarith. - rewrite H in Hle; elimtype False;zarith. + rewrite H in Hle; exfalso;zarith. assert ([|yl|] = 0). Spec_w_to_Z yl;zarith. rewrite H0;simpl;apply Zis_gcd_0;trivial. Qed. - + Variable cont : w -> w -> w -> w -> zn2z w. - Variable spec_cont : forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> + Variable spec_cont : forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 1 -> Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]. - - Definition ww_gcd_gt a b := - match a, b with + + Definition ww_gcd_gt a b := + match a, b with | W0, _ => b | _, W0 => a | WW ah al, WW bh bl => @@ -1509,8 +1509,8 @@ Section DoubleDiv. destruct a as [ |ah al]. simpl;apply Zis_gcd_sym;apply Zis_gcd_0. destruct b as [ |bh bl]. simpl;apply Zis_gcd_0. simpl in Hgt. generalize (@spec_eq0 ah);destruct (w_eq0 ah);intros. - simpl;rewrite H in Hgt;trivial;rewrite H;trivial;rewrite spec_w_0;simpl. - assert ([|bh|] <= 0). + simpl;rewrite H in Hgt;trivial;rewrite H;trivial;rewrite spec_w_0;simpl. + assert ([|bh|] <= 0). apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. Spec_w_to_Z bh;assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. rewrite H1;simpl;auto. clear H. @@ -1522,7 +1522,7 @@ Section DoubleDiv. Lemma spec_ww_gcd : forall a b, Zis_gcd [[a]] [[b]] [[ww_gcd a b]]. Proof. intros a b. - change (ww_gcd a b) with + change (ww_gcd a b) with (match ww_compare a b with | Gt => ww_gcd_gt a b | Eq => a diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v index d6f6a05f..386bbb9e 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleDivn1.v 10964 2008-05-22 11:08:13Z letouzey $ i*) +(*i $Id$ i*) Set Implicit Arguments. @@ -17,7 +17,7 @@ Require Import BigNumPrelude. Require Import DoubleType. Require Import DoubleBase. -Open Local Scope Z_scope. +Local Open Scope Z_scope. Section GENDIVN1. @@ -31,19 +31,19 @@ Section GENDIVN1. Variable w_div21 : w -> w -> w -> w * w. Variable w_compare : w -> w -> comparison. Variable w_sub : w -> w -> w. - - + + (* ** For proofs ** *) Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). + + Notation wB := (base w_digits). Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) + Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) (at level 0, x at level 99). Notation "[[ x ]]" := (zn2z_to_Z wB w_to_Z x) (at level 0, x at level 99). - + Variable spec_to_Z : forall x, 0 <= [| x |] < wB. Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits. Variable spec_0 : [|w_0|] = 0. @@ -68,10 +68,10 @@ Section GENDIVN1. | Lt => [|x|] < [|y|] | Gt => [|x|] > [|y|] end. - Variable spec_sub: forall x y, + Variable spec_sub: forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - + Section DIVAUX. Variable b2p : w. @@ -85,10 +85,10 @@ Section GENDIVN1. Fixpoint double_divn1_0 (n:nat) : w -> word w n -> word w n * w := match n return w -> word w n -> word w n * w with - | O => fun r x => w_div21 r x b2p - | S n => double_divn1_0_aux n (double_divn1_0 n) + | O => fun r x => w_div21 r x b2p + | S n => double_divn1_0_aux n (double_divn1_0 n) end. - + Lemma spec_split : forall (n : nat) (x : zn2z (word w n)), let (h, l) := double_split w_0 n x in [!S n | x!] = [!n | h!] * double_wB w_digits n + [!n | l!]. @@ -132,11 +132,11 @@ Section GENDIVN1. induction n;simpl;intros;trivial. unfold double_modn1_0_aux, double_divn1_0_aux. destruct (double_split w_0 n x) as (hh,hl). - rewrite (IHn r hh). + rewrite (IHn r hh). destruct (double_divn1_0 n r hh) as (qh,rh);simpl. rewrite IHn. destruct (double_divn1_0 n rh hl);trivial. Qed. - + Variable p : w. Variable p_bounded : [|p|] <= Zpos w_digits. @@ -148,18 +148,18 @@ Section GENDIVN1. intros;apply spec_add_mul_div;auto. Qed. - Definition double_divn1_p_aux n - (divn1 : w -> word w n -> word w n -> word w n * w) r h l := + Definition double_divn1_p_aux n + (divn1 : w -> word w n -> word w n -> word w n * w) r h l := let (hh,hl) := double_split w_0 n h in - let (lh,ll) := double_split w_0 n l in + let (lh,ll) := double_split w_0 n l in let (qh,rh) := divn1 r hh hl in let (ql,rl) := divn1 rh hl lh in (double_WW w_WW n qh ql, rl). Fixpoint double_divn1_p (n:nat) : w -> word w n -> word w n -> word w n * w := match n return w -> word w n -> word w n -> word w n * w with - | O => fun r h l => w_div21 r (w_add_mul_div p h l) b2p - | S n => double_divn1_p_aux n (double_divn1_p n) + | O => fun r h l => w_div21 r (w_add_mul_div p h l) b2p + | S n => double_divn1_p_aux n (double_divn1_p n) end. Lemma p_lt_double_digits : forall n, [|p|] <= Zpos (double_digits w_digits n). @@ -175,8 +175,8 @@ Section GENDIVN1. Lemma spec_double_divn1_p : forall n r h l, [|r|] < [|b2p|] -> let (q,r') := double_divn1_p n r h l in - [|r|] * double_wB w_digits n + - ([!n|h!]*2^[|p|] + + [|r|] * double_wB w_digits n + + ([!n|h!]*2^[|p|] + [!n|l!] / (2^(Zpos(double_digits w_digits n) - [|p|]))) mod double_wB w_digits n = [!n|q!] * [|b2p|] + [|r'|] /\ 0 <= [|r'|] < [|b2p|]. @@ -198,26 +198,26 @@ Section GENDIVN1. ([!n|lh!] * double_wB w_digits n + [!n|ll!]) / 2^(Zpos (double_digits w_digits (S n)) - [|p|])) mod (double_wB w_digits n * double_wB w_digits n)) with - (([|r|] * double_wB w_digits n + ([!n|hh!] * 2^[|p|] + + (([|r|] * double_wB w_digits n + ([!n|hh!] * 2^[|p|] + [!n|hl!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod double_wB w_digits n) * double_wB w_digits n + - ([!n|hl!] * 2^[|p|] + - [!n|lh!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod + ([!n|hl!] * 2^[|p|] + + [!n|lh!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod double_wB w_digits n). generalize (IHn r hh hl H);destruct (double_divn1_p n r hh hl) as (qh,rh); intros (H3,H4);rewrite H3. - assert ([|rh|] < [|b2p|]). omega. + assert ([|rh|] < [|b2p|]). omega. replace (([!n|qh!] * [|b2p|] + [|rh|]) * double_wB w_digits n + ([!n|hl!] * 2 ^ [|p|] + [!n|lh!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])) mod - double_wB w_digits n) with + double_wB w_digits n) with ([!n|qh!] * [|b2p|] *double_wB w_digits n + ([|rh|]*double_wB w_digits n + ([!n|hl!] * 2 ^ [|p|] + [!n|lh!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])) mod double_wB w_digits n)). 2:ring. generalize (IHn rh hl lh H0);destruct (double_divn1_p n rh hl lh) as (ql,rl); intros (H5,H6);rewrite H5. - split;[rewrite spec_double_WW;trivial;ring|trivial]. + split;[rewrite spec_double_WW;trivial;ring|trivial]. assert (Uhh := spec_double_to_Z w_digits w_to_Z spec_to_Z n hh); unfold double_wB,base in Uhh. assert (Uhl := spec_double_to_Z w_digits w_to_Z spec_to_Z n hl); @@ -228,37 +228,37 @@ Section GENDIVN1. unfold double_wB,base in Ull. unfold double_wB,base. assert (UU:=p_lt_double_digits n). - rewrite Zdiv_shift_r;auto with zarith. - 2:change (Zpos (double_digits w_digits (S n))) + rewrite Zdiv_shift_r;auto with zarith. + 2:change (Zpos (double_digits w_digits (S n))) with (2*Zpos (double_digits w_digits n));auto with zarith. replace (2 ^ (Zpos (double_digits w_digits (S n)) - [|p|])) with (2^(Zpos (double_digits w_digits n) - [|p|])*2^Zpos (double_digits w_digits n)). rewrite Zdiv_mult_cancel_r;auto with zarith. - rewrite Zmult_plus_distr_l with (p:= 2^[|p|]). + rewrite Zmult_plus_distr_l with (p:= 2^[|p|]). pattern ([!n|hl!] * 2^[|p|]) at 2; rewrite (shift_unshift_mod (Zpos(double_digits w_digits n))([|p|])([!n|hl!])); auto with zarith. - rewrite Zplus_assoc. - replace + rewrite Zplus_assoc. + replace ([!n|hh!] * 2^Zpos (double_digits w_digits n)* 2^[|p|] + ([!n|hl!] / 2^(Zpos (double_digits w_digits n)-[|p|])* 2^Zpos(double_digits w_digits n))) - with - (([!n|hh!] *2^[|p|] + double_to_Z w_digits w_to_Z n hl / + with + (([!n|hh!] *2^[|p|] + double_to_Z w_digits w_to_Z n hl / 2^(Zpos (double_digits w_digits n)-[|p|])) * 2^Zpos(double_digits w_digits n));try (ring;fail). rewrite <- Zplus_assoc. rewrite <- (Zmod_shift_r ([|p|]));auto with zarith. - replace + replace (2 ^ Zpos (double_digits w_digits n) * 2 ^ Zpos (double_digits w_digits n)) with (2 ^ (Zpos (double_digits w_digits n) + Zpos (double_digits w_digits n))). rewrite (Zmod_shift_r (Zpos (double_digits w_digits n)));auto with zarith. replace (2 ^ (Zpos (double_digits w_digits n) + Zpos (double_digits w_digits n))) - with (2^Zpos(double_digits w_digits n) *2^Zpos(double_digits w_digits n)). + with (2^Zpos(double_digits w_digits n) *2^Zpos(double_digits w_digits n)). rewrite (Zmult_comm (([!n|hh!] * 2 ^ [|p|] + [!n|hl!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])))). rewrite Zmult_mod_distr_l;auto with zarith. - ring. + ring. rewrite Zpower_exp;auto with zarith. assert (0 < Zpos (double_digits w_digits n)). unfold Zlt;reflexivity. auto with zarith. @@ -267,24 +267,24 @@ Section GENDIVN1. split;auto with zarith. apply Zdiv_lt_upper_bound;auto with zarith. rewrite <- Zpower_exp;auto with zarith. - replace ([|p|] + (Zpos (double_digits w_digits n) - [|p|])) with + replace ([|p|] + (Zpos (double_digits w_digits n) - [|p|])) with (Zpos(double_digits w_digits n));auto with zarith. rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (double_digits w_digits (S n)) - [|p|]) with - (Zpos (double_digits w_digits n) - [|p|] + + replace (Zpos (double_digits w_digits (S n)) - [|p|]) with + (Zpos (double_digits w_digits n) - [|p|] + Zpos (double_digits w_digits n));trivial. - change (Zpos (double_digits w_digits (S n))) with + change (Zpos (double_digits w_digits (S n))) with (2*Zpos (double_digits w_digits n)). ring. Qed. Definition double_modn1_p_aux n (modn1 : w -> word w n -> word w n -> w) r h l:= let (hh,hl) := double_split w_0 n h in - let (lh,ll) := double_split w_0 n l in + let (lh,ll) := double_split w_0 n l in modn1 (modn1 r hh hl) hl lh. Fixpoint double_modn1_p (n:nat) : w -> word w n -> word w n -> w := match n return w -> word w n -> word w n -> w with - | O => fun r h l => snd (w_div21 r (w_add_mul_div p h l) b2p) + | O => fun r h l => snd (w_div21 r (w_add_mul_div p h l) b2p) | S n => double_modn1_p_aux n (double_modn1_p n) end. @@ -302,8 +302,8 @@ Section GENDIVN1. Fixpoint high (n:nat) : word w n -> w := match n return word w n -> w with - | O => fun a => a - | S n => + | O => fun a => a + | S n => fun (a:zn2z (word w n)) => match a with | W0 => w_0 @@ -314,20 +314,20 @@ Section GENDIVN1. Lemma spec_double_digits:forall n, Zpos w_digits <= Zpos (double_digits w_digits n). Proof. induction n;simpl;auto with zarith. - change (Zpos (xO (double_digits w_digits n))) with + change (Zpos (xO (double_digits w_digits n))) with (2*Zpos (double_digits w_digits n)). assert (0 < Zpos w_digits);auto with zarith. exact (refl_equal Lt). Qed. - Lemma spec_high : forall n (x:word w n), + Lemma spec_high : forall n (x:word w n), [|high n x|] = [!n|x!] / 2^(Zpos (double_digits w_digits n) - Zpos w_digits). Proof. induction n;intros. unfold high,double_digits,double_to_Z. replace (Zpos w_digits - Zpos w_digits) with 0;try ring. simpl. rewrite <- (Zdiv_unique [|x|] 1 [|x|] 0);auto with zarith. - assert (U2 := spec_double_digits n). + assert (U2 := spec_double_digits n). assert (U3 : 0 < Zpos w_digits). exact (refl_equal Lt). destruct x;unfold high;fold high. unfold double_to_Z,zn2z_to_Z;rewrite spec_0. @@ -337,31 +337,31 @@ Section GENDIVN1. simpl [!S n|WW w0 w1!]. unfold double_wB,base;rewrite Zdiv_shift_r;auto with zarith. replace (2 ^ (Zpos (double_digits w_digits (S n)) - Zpos w_digits)) with - (2^(Zpos (double_digits w_digits n) - Zpos w_digits) * + (2^(Zpos (double_digits w_digits n) - Zpos w_digits) * 2^Zpos (double_digits w_digits n)). rewrite Zdiv_mult_cancel_r;auto with zarith. rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (double_digits w_digits n) - Zpos w_digits + + replace (Zpos (double_digits w_digits n) - Zpos w_digits + Zpos (double_digits w_digits n)) with (Zpos (double_digits w_digits (S n)) - Zpos w_digits);trivial. - change (Zpos (double_digits w_digits (S n))) with + change (Zpos (double_digits w_digits (S n))) with (2*Zpos (double_digits w_digits n));ring. - change (Zpos (double_digits w_digits (S n))) with + change (Zpos (double_digits w_digits (S n))) with (2*Zpos (double_digits w_digits n)); auto with zarith. Qed. - - Definition double_divn1 (n:nat) (a:word w n) (b:w) := + + Definition double_divn1 (n:nat) (a:word w n) (b:w) := let p := w_head0 b in match w_compare p w_0 with | Gt => let b2p := w_add_mul_div p b w_0 in let ha := high n a in let k := w_sub w_zdigits p in - let lsr_n := w_add_mul_div k w_0 in + let lsr_n := w_add_mul_div k w_0 in let r0 := w_add_mul_div p w_0 ha in let (q,r) := double_divn1_p b2p p n r0 a (double_0 w_0 n) in (q, lsr_n r) - | _ => double_divn1_0 b n w_0 a + | _ => double_divn1_0 b n w_0 a end. Lemma spec_double_divn1 : forall n a b, @@ -392,21 +392,21 @@ Section GENDIVN1. apply Zmult_le_compat;auto with zarith. assert (wB <= 2^[|w_head0 b|]). unfold base;apply Zpower_le_monotone;auto with zarith. omega. - assert ([|w_add_mul_div (w_head0 b) b w_0|] = + assert ([|w_add_mul_div (w_head0 b) b w_0|] = 2 ^ [|w_head0 b|] * [|b|]). rewrite (spec_add_mul_div b w_0); auto with zarith. rewrite spec_0;rewrite Zdiv_0_l; try omega. rewrite Zplus_0_r; rewrite Zmult_comm. rewrite Zmod_small; auto with zarith. assert (H5 := spec_to_Z (high n a)). - assert + assert ([|w_add_mul_div (w_head0 b) w_0 (high n a)|] <[|w_add_mul_div (w_head0 b) b w_0|]). rewrite H4. rewrite spec_add_mul_div;auto with zarith. rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l. assert (([|high n a|]/2^(Zpos w_digits - [|w_head0 b|])) < wB). - apply Zdiv_lt_upper_bound;auto with zarith. + apply Zdiv_lt_upper_bound;auto with zarith. apply Zlt_le_trans with wB;auto with zarith. pattern wB at 1;replace wB with (wB*1);try ring. apply Zmult_le_compat;auto with zarith. @@ -420,8 +420,8 @@ Section GENDIVN1. apply Zmult_le_compat;auto with zarith. pattern 2 at 1;rewrite <- Zpower_1_r. apply Zpower_le_monotone;split;auto with zarith. - rewrite <- H4 in H0. - assert (Hb3: [|w_head0 b|] <= Zpos w_digits); auto with zarith. + rewrite <- H4 in H0. + assert (Hb3: [|w_head0 b|] <= Zpos w_digits); auto with zarith. assert (H7:= spec_double_divn1_p H0 Hb3 n a (double_0 w_0 n) H6). destruct (double_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n (w_add_mul_div (w_head0 b) w_0 (high n a)) a @@ -436,7 +436,7 @@ Section GENDIVN1. rewrite Zmod_small;auto with zarith. rewrite spec_high. rewrite Zdiv_Zdiv;auto with zarith. rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (double_digits w_digits n) - Zpos w_digits + + replace (Zpos (double_digits w_digits n) - Zpos w_digits + (Zpos w_digits - [|w_head0 b|])) with (Zpos (double_digits w_digits n) - [|w_head0 b|]);trivial;ring. assert (H8 := Zpower_gt_0 2 (Zpos w_digits - [|w_head0 b|]));auto with zarith. @@ -448,11 +448,11 @@ Section GENDIVN1. rewrite H8 in H7;unfold double_wB,base in H7. rewrite <- shift_unshift_mod in H7;auto with zarith. rewrite H4 in H7. - assert ([|w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r|] + assert ([|w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r|] = [|r|]/2^[|w_head0 b|]). rewrite spec_add_mul_div. rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l. - replace (Zpos w_digits - [|w_sub w_zdigits (w_head0 b)|]) + replace (Zpos w_digits - [|w_sub w_zdigits (w_head0 b)|]) with ([|w_head0 b|]). rewrite Zmod_small;auto with zarith. assert (H9 := spec_to_Z r). @@ -474,11 +474,11 @@ Section GENDIVN1. split. rewrite <- (Z_div_mult [!n|a!] (2^[|w_head0 b|]));auto with zarith. rewrite H71;rewrite H9. - replace ([!n|q!] * (2 ^ [|w_head0 b|] * [|b|])) + replace ([!n|q!] * (2 ^ [|w_head0 b|] * [|b|])) with ([!n|q!] *[|b|] * 2^[|w_head0 b|]); try (ring;fail). rewrite Z_div_plus_l;auto with zarith. - assert (H10 := spec_to_Z + assert (H10 := spec_to_Z (w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r));split; auto with zarith. rewrite H9. @@ -487,19 +487,19 @@ Section GENDIVN1. exact (spec_double_to_Z w_digits w_to_Z spec_to_Z n a). Qed. - - Definition double_modn1 (n:nat) (a:word w n) (b:w) := + + Definition double_modn1 (n:nat) (a:word w n) (b:w) := let p := w_head0 b in match w_compare p w_0 with | Gt => let b2p := w_add_mul_div p b w_0 in let ha := high n a in let k := w_sub w_zdigits p in - let lsr_n := w_add_mul_div k w_0 in + let lsr_n := w_add_mul_div k w_0 in let r0 := w_add_mul_div p w_0 ha in let r := double_modn1_p b2p p n r0 a (double_0 w_0 n) in lsr_n r - | _ => double_modn1_0 b n w_0 a + | _ => double_modn1_0 b n w_0 a end. Lemma spec_double_modn1_aux : forall n a b, @@ -525,4 +525,4 @@ Section GENDIVN1. destruct H1 as (h1,h2);rewrite h1;ring. Qed. -End GENDIVN1. +End GENDIVN1. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v index 50c72487..21e694e5 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleLift.v 10964 2008-05-22 11:08:13Z letouzey $ i*) +(*i $Id$ i*) Set Implicit Arguments. @@ -17,7 +17,7 @@ Require Import BigNumPrelude. Require Import DoubleType. Require Import DoubleBase. -Open Local Scope Z_scope. +Local Open Scope Z_scope. Section DoubleLift. Variable w : Type. @@ -61,13 +61,13 @@ Section DoubleLift. (* 0 < p < ww_digits *) - Definition ww_add_mul_div p x y := + Definition ww_add_mul_div p x y := let zdigits := w_0W w_zdigits in match x, y with | W0, W0 => W0 | W0, WW yh yl => match ww_compare p zdigits with - | Eq => w_0W yh + | Eq => w_0W yh | Lt => w_0W (w_add_mul_div (low p) w_0 yh) | Gt => let n := low (ww_sub p zdigits) in @@ -75,15 +75,15 @@ Section DoubleLift. end | WW xh xl, W0 => match ww_compare p zdigits with - | Eq => w_W0 xl + | Eq => w_W0 xl | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl w_0) | Gt => let n := low (ww_sub p zdigits) in - w_W0 (w_add_mul_div n xl w_0) + w_W0 (w_add_mul_div n xl w_0) end | WW xh xl, WW yh yl => match ww_compare p zdigits with - | Eq => w_WW xl yh + | Eq => w_WW xl yh | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl yh) | Gt => let n := low (ww_sub p zdigits) in @@ -93,7 +93,7 @@ Section DoubleLift. Section DoubleProof. Variable w_to_Z : w -> Z. - + Notation wB := (base w_digits). Notation wwB := (base (ww_digits w_digits)). Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). @@ -122,21 +122,21 @@ Section DoubleLift. Variable spec_w_head0 : forall x, 0 < [|x|] -> wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB. Variable spec_w_tail00 : forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits. - Variable spec_w_tail0 : forall x, 0 < [|x|] -> + Variable spec_w_tail0 : forall x, 0 < [|x|] -> exists y, 0 <= y /\ [|x|] = (2* y + 1) * (2 ^ [|w_tail0 x|]). Variable spec_w_add_mul_div : forall x y p, [|p|] <= Zpos w_digits -> [| w_add_mul_div p x y |] = ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_w_add: forall x y, + Variable spec_w_add: forall x y, [[w_add x y]] = [|x|] + [|y|]. - Variable spec_ww_sub: forall x y, + Variable spec_ww_sub: forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits. Variable spec_low: forall x, [| low x|] = [[x]] mod wB. - + Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos ww_Digits. Hint Resolve div_le_0 div_lt w_to_Z_wwB: lift. @@ -168,7 +168,7 @@ Section DoubleLift. rewrite spec_w_0; auto with zarith. rewrite spec_w_0; auto with zarith. Qed. - + Lemma spec_ww_head0 : forall x, 0 < [[x]] -> wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB. Proof. @@ -179,7 +179,7 @@ Section DoubleLift. assert (H0 := spec_compare w_0 xh);rewrite spec_w_0 in H0. destruct (w_compare w_0 xh). rewrite <- H0. simpl Zplus. rewrite <- H0 in H;simpl in H. - case (spec_to_Z w_zdigits); + case (spec_to_Z w_zdigits); case (spec_to_Z (w_head0 xl)); intros HH1 HH2 HH3 HH4. rewrite spec_w_add. rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith. @@ -209,7 +209,7 @@ Section DoubleLift. rewrite <- Zmult_assoc; apply Zmult_lt_compat_l; zarith. rewrite <- (Zplus_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith. apply Zmult_lt_reg_r with (2 ^ p); zarith. - rewrite <- Zpower_exp;zarith. + rewrite <- Zpower_exp;zarith. rewrite Zmult_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith. assert (H1 := spec_to_Z xh);zarith. Qed. @@ -293,8 +293,8 @@ Section DoubleLift. Qed. Hint Rewrite Zdiv_0_l Zmult_0_l Zplus_0_l Zmult_0_r Zplus_0_r - spec_w_W0 spec_w_0W spec_w_WW spec_w_0 - (wB_div w_digits w_to_Z spec_to_Z) + spec_w_W0 spec_w_0W spec_w_WW spec_w_0 + (wB_div w_digits w_to_Z spec_to_Z) (wB_div_plus w_digits w_to_Z spec_to_Z) : w_rewrite. Ltac w_rewrite := autorewrite with w_rewrite;trivial. @@ -303,12 +303,12 @@ Section DoubleLift. [[p]] <= Zpos (xO w_digits) -> [[match ww_compare p zdigits with | Eq => w_WW xl yh - | Lt => w_WW (w_add_mul_div (low p) xh xl) + | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl yh) | Gt => let n := low (ww_sub p zdigits) in w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl) - end]] = + end]] = ([[WW xh xl]] * (2^[[p]]) + [[WW yh yl]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. Proof. @@ -317,7 +317,7 @@ Section DoubleLift. case (spec_to_w_Z p); intros Hv1 Hv2. replace (Zpos (xO w_digits)) with (Zpos w_digits + Zpos w_digits). 2 : rewrite Zpos_xO;ring. - replace (Zpos w_digits + Zpos w_digits - [[p]]) with + replace (Zpos w_digits + Zpos w_digits - [[p]]) with (Zpos w_digits + (Zpos w_digits - [[p]])). 2:ring. intros Hp; assert (Hxh := spec_to_Z xh);assert (Hxl:=spec_to_Z xl); assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)); @@ -330,7 +330,7 @@ Section DoubleLift. fold wB. rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc;rewrite <- Zplus_assoc. rewrite <- Zpower_2. - rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|]. + rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|]. exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xl yh)). ring. simpl ww_to_Z; w_rewrite;zarith. assert (HH0: [|low p|] = [[p]]). @@ -353,7 +353,7 @@ Section DoubleLift. rewrite Zmult_plus_distr_l. pattern ([|xl|] * 2 ^ [[p]]) at 2; rewrite shift_unshift_mod with (n:= Zpos w_digits);fold wB;zarith. - replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring. + replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring. rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc. unfold base at 5;rewrite <- Zmod_shift_r;zarith. unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); @@ -387,8 +387,8 @@ Section DoubleLift. lazy zeta; simpl ww_to_Z; w_rewrite;zarith. repeat rewrite spec_w_add_mul_div;zarith. rewrite HH0. - pattern wB at 5;replace wB with - (2^(([[p]] - Zpos w_digits) + pattern wB at 5;replace wB with + (2^(([[p]] - Zpos w_digits) + (Zpos w_digits - ([[p]] - Zpos w_digits)))). rewrite Zpower_exp;zarith. rewrite Zmult_assoc. rewrite Z_div_plus_l;zarith. @@ -401,28 +401,28 @@ Section DoubleLift. repeat rewrite <- Zplus_assoc. unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); fold wB;fold wwB;zarith. - unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits) + unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits) (b:= Zpos w_digits);fold wB;fold wwB;zarith. rewrite wwB_wBwB; rewrite Zpower_2; rewrite Zmult_mod_distr_r;zarith. rewrite Zmult_plus_distr_l. - replace ([|xh|] * wB * 2 ^ u) with + replace ([|xh|] * wB * 2 ^ u) with ([|xh|]*2^u*wB). 2:ring. - repeat rewrite <- Zplus_assoc. + repeat rewrite <- Zplus_assoc. rewrite (Zplus_comm ([|xh|] * 2 ^ u * wB)). rewrite Z_mod_plus;zarith. rewrite Z_mod_mult;zarith. unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. - unfold u; split;zarith. + unfold u; split;zarith. split;zarith. unfold u; apply Zdiv_lt_upper_bound;zarith. rewrite <- Zpower_exp;zarith. - fold u. - ring_simplify (u + (Zpos w_digits - u)); fold + fold u. + ring_simplify (u + (Zpos w_digits - u)); fold wB;zarith. unfold ww_digits;rewrite Zpos_xO;zarith. unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. unfold u; split;zarith. unfold u; split;zarith. apply Zdiv_lt_upper_bound;zarith. rewrite <- Zpower_exp;zarith. - fold u. + fold u. ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith. unfold u;zarith. unfold u;zarith. @@ -446,7 +446,7 @@ Section DoubleLift. clear H1;w_rewrite);simpl ww_add_mul_div. replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. intros Heq;rewrite <- Heq;clear Heq; auto. - generalize (spec_ww_compare p (w_0W w_zdigits)); + generalize (spec_ww_compare p (w_0W w_zdigits)); case ww_compare; intros H1; w_rewrite. rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. generalize H1; w_rewrite; rewrite spec_zdigits; clear H1; intros H1. @@ -459,7 +459,7 @@ Section DoubleLift. rewrite HH0; auto with zarith. replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. intros Heq;rewrite <- Heq;clear Heq. - generalize (spec_ww_compare p (w_0W w_zdigits)); + generalize (spec_ww_compare p (w_0W w_zdigits)); case ww_compare; intros H1; w_rewrite. rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. rewrite Zpos_xO in H;zarith. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v index c7d83acc..7090c76a 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleMul.v 10964 2008-05-22 11:08:13Z letouzey $ i*) +(*i $Id$ i*) Set Implicit Arguments. @@ -17,7 +17,7 @@ Require Import BigNumPrelude. Require Import DoubleType. Require Import DoubleBase. -Open Local Scope Z_scope. +Local Open Scope Z_scope. Section DoubleMul. Variable w : Type. @@ -45,7 +45,7 @@ Section DoubleMul. (* (xh*B+xl) (yh*B + yl) xh*yh = hh = |hhh|hhl|B2 xh*yl +xl*yh = cc = |cch|ccl|B - xl*yl = ll = |llh|lll + xl*yl = ll = |llh|lll *) Definition double_mul_c (cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w) x y := @@ -56,7 +56,7 @@ Section DoubleMul. let hh := w_mul_c xh yh in let ll := w_mul_c xl yl in let (wc,cc) := cross xh xl yh yl hh ll in - match cc with + match cc with | W0 => WW (ww_add hh (w_W0 wc)) ll | WW cch ccl => match ww_add_c (w_W0 ccl) ll with @@ -67,8 +67,8 @@ Section DoubleMul. end. Definition ww_mul_c := - double_mul_c - (fun xh xl yh yl hh ll=> + double_mul_c + (fun xh xl yh yl hh ll=> match ww_add_c (w_mul_c xh yl) (w_mul_c xl yh) with | C0 cc => (w_0, cc) | C1 cc => (w_1, cc) @@ -77,11 +77,11 @@ Section DoubleMul. Definition w_2 := w_add w_1 w_1. Definition kara_prod xh xl yh yl hh ll := - match ww_add_c hh ll with + match ww_add_c hh ll with C0 m => match w_compare xl xh with Eq => (w_0, m) - | Lt => + | Lt => match w_compare yl yh with Eq => (w_0, m) | Lt => (w_0, ww_sub m (w_mul_c (w_sub xh xl) (w_sub yh yl))) @@ -89,7 +89,7 @@ Section DoubleMul. C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1) end end - | Gt => + | Gt => match w_compare yl yh with Eq => (w_0, m) | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with @@ -101,17 +101,17 @@ Section DoubleMul. | C1 m => match w_compare xl xh with Eq => (w_1, m) - | Lt => + | Lt => match w_compare yl yh with Eq => (w_1, m) | Lt => match ww_sub_c m (w_mul_c (w_sub xh xl) (w_sub yh yl)) with C0 m1 => (w_1, m1) | C1 m1 => (w_0, m1) - end + end | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1) end end - | Gt => + | Gt => match w_compare yl yh with Eq => (w_1, m) | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with @@ -129,8 +129,8 @@ Section DoubleMul. Definition ww_mul x y := match x, y with | W0, _ => W0 - | _, W0 => W0 - | WW xh xl, WW yh yl => + | _, W0 => W0 + | WW xh xl, WW yh yl => let ccl := w_add (w_mul xh yl) (w_mul xl yh) in ww_add (w_W0 ccl) (w_mul_c xl yl) end. @@ -161,9 +161,9 @@ Section DoubleMul. Variable w_mul_add : w -> w -> w -> w * w. Fixpoint double_mul_add_n1 (n:nat) : word w n -> w -> w -> w * word w n := - match n return word w n -> w -> w -> w * word w n with - | O => w_mul_add - | S n1 => + match n return word w n -> w -> w -> w * word w n with + | O => w_mul_add + | S n1 => let mul_add := double_mul_add_n1 n1 in fun x y r => match x with @@ -183,11 +183,11 @@ Section DoubleMul. Variable wn_0W : wn -> zn2z wn. Variable wn_WW : wn -> wn -> zn2z wn. Variable w_mul_add_n1 : wn -> w -> w -> w*wn. - Fixpoint double_mul_add_mn1 (m:nat) : + Fixpoint double_mul_add_mn1 (m:nat) : word wn m -> w -> w -> w*word wn m := - match m return word wn m -> w -> w -> w*word wn m with - | O => w_mul_add_n1 - | S m1 => + match m return word wn m -> w -> w -> w*word wn m with + | O => w_mul_add_n1 + | S m1 => let mul_add := double_mul_add_mn1 m1 in fun x y r => match x with @@ -207,11 +207,11 @@ Section DoubleMul. | WW h l => match w_add_c l r with | C0 lr => (h,lr) - | C1 lr => (w_succ h, lr) + | C1 lr => (w_succ h, lr) end end. - + (*Section DoubleProof. *) Variable w_digits : positive. Variable w_to_Z : w -> Z. @@ -225,11 +225,11 @@ Section DoubleMul. (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). Notation "[|| x ||]" := @@ -269,8 +269,8 @@ Section DoubleMul. forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB. Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - - + + Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB. Proof. intros x;apply spec_ww_to_Z;auto. Qed. @@ -281,21 +281,21 @@ Section DoubleMul. Ltac zarith := auto with zarith mult. Lemma wBwB_lex: forall a b c d, - a * wB^2 + [[b]] <= c * wB^2 + [[d]] -> + a * wB^2 + [[b]] <= c * wB^2 + [[d]] -> a <= c. - Proof. + Proof. intros a b c d H; apply beta_lex with [[b]] [[d]] (wB^2);zarith. Qed. - Lemma wBwB_lex_inv: forall a b c d, - a < c -> - a * wB^2 + [[b]] < c * wB^2 + [[d]]. + Lemma wBwB_lex_inv: forall a b c d, + a < c -> + a * wB^2 + [[b]] < c * wB^2 + [[d]]. Proof. intros a b c d H; apply beta_lex_inv; zarith. Qed. Lemma sum_mul_carry : forall xh xl yh yl wc cc, - [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> + [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> 0 <= [|wc|] <= 1. Proof. intros. @@ -303,14 +303,14 @@ Section DoubleMul. apply wB_pos. Qed. - Theorem mult_add_ineq: forall xH yH crossH, + Theorem mult_add_ineq: forall xH yH crossH, 0 <= [|xH|] * [|yH|] + [|crossH|] < wwB. Proof. intros;rewrite wwB_wBwB;apply mult_add_ineq;zarith. Qed. - + Hint Resolve mult_add_ineq : mult. - + Lemma spec_mul_aux : forall xh xl yh yl wc (cc:zn2z w) hh ll, [[hh]] = [|xh|] * [|yh|] -> [[ll]] = [|xl|] * [|yl|] -> @@ -325,9 +325,9 @@ Section DoubleMul. end||] = ([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|]). Proof. intros;assert (U1 := wB_pos w_digits). - replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with + replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with ([|xh|]*[|yh|]*wB^2 + ([|xh|]*[|yl|] + [|xl|]*[|yh|])*wB + [|xl|]*[|yl|]). - 2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0. + 2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0. assert (H2 := sum_mul_carry _ _ _ _ _ _ H1). destruct cc as [ | cch ccl]; simpl zn2z_to_Z; simpl ww_to_Z. rewrite spec_ww_add;rewrite spec_w_W0;rewrite Zmod_small; @@ -346,7 +346,7 @@ Section DoubleMul. rewrite <- Zmult_plus_distr_l. assert (((2 * wB - 4) + 2)*wB <= ([|wc|] * wB + [|cch|])*wB). apply Zmult_le_compat;zarith. - rewrite Zmult_plus_distr_l in H3. + rewrite Zmult_plus_distr_l in H3. intros. assert (U2 := spec_to_Z ccl);omega. generalize (spec_ww_add_c (w_W0 ccl) ll);destruct (ww_add_c (w_W0 ccl) ll) as [l|l];unfold interp_carry;rewrite spec_w_W0;try rewrite Zmult_1_l; @@ -363,8 +363,8 @@ Section DoubleMul. (forall xh xl yh yl hh ll, [[hh]] = [|xh|]*[|yh|] -> [[ll]] = [|xl|]*[|yl|] -> - let (wc,cc) := cross xh xl yh yl hh ll in - [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) -> + let (wc,cc) := cross xh xl yh yl hh ll in + [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) -> forall x y, [||double_mul_c cross x y||] = [[x]] * [[y]]. Proof. intros cross Hcross x y;destruct x as [ |xh xl];simpl;trivial. @@ -376,7 +376,7 @@ Section DoubleMul. rewrite <- wwB_wBwB;trivial. Qed. - Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]]. + Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]]. Proof. intros x y;unfold ww_mul_c;apply spec_double_mul_c. intros xh xl yh yl hh ll H1 H2. @@ -402,9 +402,9 @@ Section DoubleMul. let (wc,cc) := kara_prod xh xl yh yl hh ll in [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]. Proof. - intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux; + intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux; rewrite <- H; rewrite <- H0; unfold kara_prod. - assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl)); + assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl)); assert (Hyh := (spec_to_Z yh)); assert (Hyl := (spec_to_Z yl)). generalize (spec_ww_add_c hh ll); case (ww_add_c hh ll); intros z Hz; rewrite <- Hz; unfold interp_carry; assert (Hz1 := (spec_ww_to_Z z)). @@ -412,7 +412,7 @@ Section DoubleMul. try rewrite Hxlh; try rewrite spec_w_0; try (ring; fail). generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh. rewrite Hylh; rewrite spec_w_0; try (ring; fail). - rewrite spec_w_0; try (ring; fail). + rewrite spec_w_0; try (ring; fail). repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c). repeat rewrite Zmod_small; auto with zarith; try (ring; fail). split; auto with zarith. @@ -508,8 +508,8 @@ Section DoubleMul. repeat rewrite Zmod_small; auto with zarith; try (ring; fail). Qed. - Lemma sub_carry : forall xh xl yh yl z, - 0 <= z -> + Lemma sub_carry : forall xh xl yh yl z, + 0 <= z -> [|xh|]*[|yl|] + [|xl|]*[|yh|] = wwB + z -> z < wwB. Proof. @@ -519,7 +519,7 @@ Section DoubleMul. generalize (Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)). rewrite <- wwB_wBwB;intros H1 H2. assert (H3 := wB_pos w_digits). - assert (2*wB <= wwB). + assert (2*wB <= wwB). rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat;zarith. omega. Qed. @@ -528,7 +528,7 @@ Section DoubleMul. let H:= fresh "H" in assert (H:= spec_ww_to_Z x). - Ltac Zmult_lt_b x y := + Ltac Zmult_lt_b x y := let H := fresh "H" in assert (H := Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)). @@ -582,7 +582,7 @@ Section DoubleMul. Variable w_mul_add : w -> w -> w -> w * w. Variable spec_w_mul_add : forall x y r, let (h,l):= w_mul_add x y r in - [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. + [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. Lemma spec_double_mul_add_n1 : forall n x y r, let (h,l) := double_mul_add_n1 w_mul_add n x y r in @@ -590,7 +590,7 @@ Section DoubleMul. Proof. induction n;intros x y r;trivial. exact (spec_w_mul_add x y r). - unfold double_mul_add_n1;destruct x as[ |xh xl]; + unfold double_mul_add_n1;destruct x as[ |xh xl]; fold(double_mul_add_n1 w_mul_add). rewrite spec_w_0;rewrite spec_extend;simpl;trivial. assert(H:=IHn xl y r);destruct (double_mul_add_n1 w_mul_add n xl y r)as(rl,l). @@ -599,13 +599,13 @@ Section DoubleMul. rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc;rewrite <- H. rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. rewrite U;ring. - Qed. - + Qed. + End DoubleMulAddn1Proof. - Lemma spec_w_mul_add : forall x y r, + Lemma spec_w_mul_add : forall x y r, let (h,l):= w_mul_add x y r in - [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. + [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. Proof. intros x y r;unfold w_mul_add;assert (H:=spec_w_mul_c x y); destruct (w_mul_c x y) as [ |h l];simpl;rewrite <- H. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v index 043ff351..83a2e717 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleSqrt.v 10964 2008-05-22 11:08:13Z letouzey $ i*) +(*i $Id$ i*) Set Implicit Arguments. @@ -17,7 +17,7 @@ Require Import BigNumPrelude. Require Import DoubleType. Require Import DoubleBase. -Open Local Scope Z_scope. +Local Open Scope Z_scope. Section DoubleSqrt. Variable w : Type. @@ -52,7 +52,7 @@ Section DoubleSqrt. Let wwBm1 := ww_Bm1 w_Bm1. - Definition ww_is_even x := + Definition ww_is_even x := match x with | W0 => true | WW xh xl => w_is_even xl @@ -62,7 +62,7 @@ Section DoubleSqrt. match w_compare x z with | Eq => match w_compare y z with - Eq => (C1 w_1, w_0) + Eq => (C1 w_1, w_0) | Gt => (C1 w_1, w_sub y z) | Lt => (C1 w_0, y) end @@ -120,7 +120,7 @@ Section DoubleSqrt. let ( q, r) := w_sqrt2 x1 x2 in let (q1, r1) := w_div2s r y1 q in match q1 with - C0 q1 => + C0 q1 => let q2 := w_square_c q1 in let a := WW q q1 in match r1 with @@ -132,9 +132,9 @@ Section DoubleSqrt. | C0 r2 => match ww_sub_c (WW r2 y2) q2 with C0 r3 => (a, C0 r3) - | C1 r3 => + | C1 r3 => let a2 := ww_add_mul_div (w_0W w_1) a W0 in - match ww_pred_c a2 with + match ww_pred_c a2 with C0 a3 => (ww_pred a, ww_add_c a3 r3) | C1 a3 => @@ -166,20 +166,20 @@ Section DoubleSqrt. | Gt => match ww_add_mul_div p x W0 with W0 => W0 - | WW x1 x2 => + | WW x1 x2 => let (r, _) := w_sqrt2 x1 x2 in - WW w_0 (w_add_mul_div - (w_sub w_zdigits + WW w_0 (w_add_mul_div + (w_sub w_zdigits (low (ww_add_mul_div (ww_pred ww_zdigits) W0 p))) w_0 r) end - | _ => + | _ => match x with W0 => W0 | WW x1 x2 => WW w_0 (fst (w_sqrt2 x1 x2)) end end. - + Variable w_to_Z : w -> Z. @@ -192,11 +192,11 @@ Section DoubleSqrt. (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). Notation "[|| x ||]" := @@ -269,14 +269,12 @@ Section DoubleSqrt. Let spec_ww_Bm1 : [[wwBm1]] = wwB - 1. Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed. - - Hint Rewrite spec_w_0 spec_w_1 w_Bm1 spec_w_WW spec_w_sub - spec_w_div21 spec_w_add_mul_div spec_ww_Bm1 - spec_w_add_c spec_w_sqrt2: w_rewrite. + Hint Rewrite spec_w_0 spec_w_1 spec_w_WW spec_w_sub + spec_w_add_mul_div spec_ww_Bm1 spec_w_add_c : w_rewrite. Lemma spec_ww_is_even : forall x, if ww_is_even x then [[x]] mod 2 = 0 else [[x]] mod 2 = 1. -clear spec_more_than_1_digit. +clear spec_more_than_1_digit. intros x; case x; simpl ww_is_even. simpl. rewrite Zmod_small; auto with zarith. @@ -379,8 +377,8 @@ intros x; case x; simpl ww_is_even. end. rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith. destruct (spec_to_Z w1) as [H1 H2];auto with zarith. - split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. + split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. rewrite Hp; ring. Qed. @@ -402,7 +400,7 @@ intros x; case x; simpl ww_is_even. rewrite Zmax_right; auto with zarith. rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith. destruct (spec_to_Z w1) as [H1 H2];auto with zarith. - split; auto with zarith. + split; auto with zarith. unfold base. match goal with |- _ < _ ^ ?X => assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; @@ -434,7 +432,7 @@ intros x; case x; simpl ww_is_even. intros w1. rewrite spec_ww_add_mul_div; auto with zarith. autorewrite with w_rewrite rm10. - rewrite spec_w_0W; rewrite spec_w_1. + rewrite spec_w_0W; rewrite spec_w_1. rewrite Zpower_1_r; auto with zarith. rewrite Zmult_comm; auto. rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. @@ -458,7 +456,7 @@ intros x; case x; simpl ww_is_even. match goal with |- 0 <= ?X - 1 => assert (0 < X); auto with zarith end. - apply Zpower_gt_0; auto with zarith. + apply Zpower_gt_0; auto with zarith. match goal with |- 0 <= ?X - 1 => assert (0 < X); auto with zarith; red; reflexivity end. @@ -542,7 +540,7 @@ intros x; case x; simpl ww_is_even. rewrite add_mult_div_2_plus_1; unfold base. match goal with |- context[_ ^ ?X] => assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith end. rewrite Zpos_minus; auto with zarith. @@ -559,7 +557,7 @@ intros x; case x; simpl ww_is_even. unfold base. match goal with |- context[_ ^ ?X] => assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith end. rewrite Zpos_minus; auto with zarith. @@ -592,7 +590,7 @@ intros x; case x; simpl ww_is_even. rewrite H1; unfold base. match goal with |- context[_ ^ ?X] => assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith end. rewrite Zpos_minus; auto with zarith. @@ -611,7 +609,7 @@ intros x; case x; simpl ww_is_even. rewrite H1; unfold base. match goal with |- context[_ ^ ?X] => assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith end. rewrite Zpos_minus; auto with zarith. @@ -682,7 +680,7 @@ intros x; case x; simpl ww_is_even. rewrite Zsquare_mult; replace (p * p) with ((- p) * (- p)); try ring. apply Zmult_le_0_compat; auto with zarith. Qed. - + Lemma spec_split: forall x, [|fst (split x)|] * wB + [|snd (split x)|] = [[x]]. intros x; case x; simpl; autorewrite with w_rewrite; @@ -751,7 +749,7 @@ intros x; case x; simpl ww_is_even. match goal with |- ?X <= ?Y => replace Y with (2 * (wB/ 2 - 1)); auto with zarith end. - pattern wB at 2; rewrite <- wB_div_2; auto with zarith. + pattern wB at 2; rewrite <- wB_div_2; auto with zarith. match type of H1 with ?X = _ => assert (U5: X < wB / 4 * wB) end. @@ -764,9 +762,9 @@ intros x; case x; simpl ww_is_even. destruct (spec_to_Z w3);auto with zarith. generalize (@spec_w_div2s c w0 w4 U1 H2). case (w_div2s c w0 w4). - intros c0; case c0; intros w5; + intros c0; case c0; intros w5; repeat (rewrite C0_id || rewrite C1_plus_wB). - intros c1; case c1; intros w6; + intros c1; case c1; intros w6; repeat (rewrite C0_id || rewrite C1_plus_wB). intros (H3, H4). match goal with |- context [ww_sub_c ?y ?z] => @@ -1038,7 +1036,7 @@ intros x; case x; simpl ww_is_even. end. apply Zle_not_lt; rewrite <- H3; auto with zarith. rewrite Zmult_plus_distr_l. - apply Zlt_le_trans with ((2 * [|w4|]) * wB + 0); + apply Zlt_le_trans with ((2 * [|w4|]) * wB + 0); auto with zarith. apply beta_lex_inv; auto with zarith. destruct (spec_to_Z w0);auto with zarith. @@ -1119,9 +1117,9 @@ intros x; case x; simpl ww_is_even. auto with zarith. simpl ww_to_Z. assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z x);auto with zarith. - Qed. - - Lemma wwB_4_2: 2 * (wwB / 4) = wwB/ 2. + Qed. + + Lemma wwB_4_2: 2 * (wwB / 4) = wwB/ 2. pattern wwB at 1; rewrite wwB_wBwB; rewrite Zpower_2. rewrite <- wB_div_2. match goal with |- context[(2 * ?X) * (2 * ?Z)] => @@ -1134,7 +1132,7 @@ intros x; case x; simpl ww_is_even. Lemma spec_ww_head1 - : forall x : zn2z w, + : forall x : zn2z w, (ww_is_even (ww_head1 x) = true) /\ (0 < [[x]] -> wwB / 4 <= 2 ^ [[ww_head1 x]] * [[x]] < wwB). assert (U := wB_pos w_digits). @@ -1167,7 +1165,7 @@ intros x; case x; simpl ww_is_even. rewrite Hp. rewrite Zminus_mod; auto with zarith. rewrite H2; repeat rewrite Zmod_small; auto with zarith. - intros H3; rewrite Hp. + intros H3; rewrite Hp. case (spec_ww_head0 x); auto; intros Hv3 Hv4. assert (Hu: forall u, 0 < u -> 2 * 2 ^ (u - 1) = 2 ^u). intros u Hu. @@ -1189,7 +1187,7 @@ intros x; case x; simpl ww_is_even. apply sym_equal; apply Zdiv_unique with 0; auto with zarith. rewrite Zmult_assoc; rewrite wB_div_4; auto with zarith. - rewrite wwB_wBwB; ring. + rewrite wwB_wBwB; ring. Qed. Lemma spec_ww_sqrt : forall x, @@ -1198,14 +1196,14 @@ intros x; case x; simpl ww_is_even. intro x; unfold ww_sqrt. generalize (spec_ww_is_zero x); case (ww_is_zero x). simpl ww_to_Z; simpl Zpower; unfold Zpower_pos; simpl; - auto with zarith. + auto with zarith. intros H1. generalize (spec_ww_compare (ww_head1 x) W0); case ww_compare; simpl ww_to_Z; autorewrite with rm10. generalize H1; case x. intros HH; contradict HH; simpl ww_to_Z; auto with zarith. intros w0 w1; simpl ww_to_Z; autorewrite with w_rewrite rm10. - intros H2; case (spec_ww_head1 (WW w0 w1)); intros H3 H4 H5. + intros H2; case (spec_ww_head1 (WW w0 w1)); intros H3 H4 H5. generalize (H4 H2); clear H4; rewrite H5; clear H5; autorewrite with rm10. intros (H4, H5). assert (V: wB/4 <= [|w0|]). @@ -1241,7 +1239,7 @@ intros x; case x; simpl ww_is_even. apply Zle_not_lt; unfold base. apply Zle_trans with (2 ^ [[ww_head1 x]]). apply Zpower_le_monotone; auto with zarith. - pattern (2 ^ [[ww_head1 x]]) at 1; + pattern (2 ^ [[ww_head1 x]]) at 1; rewrite <- (Zmult_1_r (2 ^ [[ww_head1 x]])). apply Zmult_le_compat_l; auto with zarith. generalize (spec_ww_add_mul_div x W0 (ww_head1 x) Hv2); @@ -1283,13 +1281,13 @@ intros x; case x; simpl ww_is_even. rewrite Zmod_small; auto with zarith. split; auto with zarith. apply Zlt_le_trans with (Zpos (xO w_digits)); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. + unfold base; apply Zpower2_le_lin; auto with zarith. assert (Hv4: [[ww_head1 x]]/2 < wB). apply Zle_lt_trans with (Zpos w_digits). apply Zmult_le_reg_r with 2; auto with zarith. repeat rewrite (fun x => Zmult_comm x 2). rewrite <- Hv0; rewrite <- Zpos_xO; auto. - unfold base; apply Zpower2_lt_lin; auto with zarith. + unfold base; apply Zpower2_lt_lin; auto with zarith. assert (Hv5: [[(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))]] = [[ww_head1 x]]/2). rewrite spec_ww_add_mul_div. @@ -1330,14 +1328,14 @@ intros x; case x; simpl ww_is_even. rewrite tmp; clear tmp. apply Zpower_le_monotone3; auto with zarith. split; auto with zarith. - pattern [|w2|] at 2; + pattern [|w2|] at 2; rewrite (Z_div_mod_eq [|w2|] (2 ^ ([[ww_head1 x]] / 2))); auto with zarith. match goal with |- ?X <= ?X + ?Y => assert (0 <= Y); auto with zarith end. case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]] / 2))); auto with zarith. - case c; unfold interp_carry; autorewrite with rm10; + case c; unfold interp_carry; autorewrite with rm10; intros w3; assert (V3 := spec_to_Z w3);auto with zarith. apply Zmult_lt_reg_r with (2 ^ [[ww_head1 x]]); auto with zarith. rewrite H4. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v index 269d62bb..a7e55671 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleSub.v 10964 2008-05-22 11:08:13Z letouzey $ i*) +(*i $Id$ i*) Set Implicit Arguments. @@ -17,7 +17,7 @@ Require Import BigNumPrelude. Require Import DoubleType. Require Import DoubleBase. -Open Local Scope Z_scope. +Local Open Scope Z_scope. Section DoubleSub. Variable w : Type. @@ -39,7 +39,7 @@ Section DoubleSub. Definition ww_opp_c x := match x with | W0 => C0 W0 - | WW xh xl => + | WW xh xl => match w_opp_c xl with | C0 _ => match w_opp_c xh with @@ -53,7 +53,7 @@ Section DoubleSub. Definition ww_opp x := match x with | W0 => W0 - | WW xh xl => + | WW xh xl => match w_opp_c xl with | C0 _ => WW (w_opp xh) w_0 | C1 l => WW (w_opp_carry xh) l @@ -72,14 +72,14 @@ Section DoubleSub. | WW xh xl => match w_pred_c xl with | C0 l => C0 (w_WW xh l) - | C1 _ => - match w_pred_c xh with + | C1 _ => + match w_pred_c xh with | C0 h => C0 (WW h w_Bm1) | C1 _ => C1 ww_Bm1 end end end. - + Definition ww_pred x := match x with | W0 => ww_Bm1 @@ -89,19 +89,19 @@ Section DoubleSub. | C1 l => WW (w_pred xh) w_Bm1 end end. - + Definition ww_sub_c x y := match y, x with | W0, _ => C0 x | WW yh yl, W0 => ww_opp_c (WW yh yl) | WW yh yl, WW xh xl => match w_sub_c xl yl with - | C0 l => + | C0 l => match w_sub_c xh yh with | C0 h => C0 (w_WW h l) | C1 h => C1 (WW h l) end - | C1 l => + | C1 l => match w_sub_carry_c xh yh with | C0 h => C0 (WW h l) | C1 h => C1 (WW h l) @@ -109,7 +109,7 @@ Section DoubleSub. end end. - Definition ww_sub x y := + Definition ww_sub x y := match y, x with | W0, _ => x | WW yh yl, W0 => ww_opp (WW yh yl) @@ -127,7 +127,7 @@ Section DoubleSub. | WW yh yl, W0 => C1 (ww_opp_carry (WW yh yl)) | WW yh yl, WW xh xl => match w_sub_carry_c xl yl with - | C0 l => + | C0 l => match w_sub_c xh yh with | C0 h => C0 (w_WW h l) | C1 h => C1 (WW h l) @@ -155,7 +155,7 @@ Section DoubleSub. (*Section DoubleProof.*) Variable w_digits : positive. Variable w_to_Z : w -> Z. - + Notation wB := (base w_digits). Notation wwB := (base (ww_digits w_digits)). @@ -166,13 +166,13 @@ Section DoubleSub. (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). - + Variable spec_w_0 : [|w_0|] = 0. Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. Variable spec_ww_Bm1 : [[ww_Bm1]] = wwB - 1. @@ -187,7 +187,7 @@ Section DoubleSub. Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]. Variable spec_sub_carry_c : forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1. - + Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. Variable spec_sub_carry : @@ -197,12 +197,12 @@ Section DoubleSub. Lemma spec_ww_opp_c : forall x, [-[ww_opp_c x]] = -[[x]]. Proof. destruct x as [ |xh xl];simpl. reflexivity. - rewrite Zopp_plus_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl) + rewrite Zopp_plus_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl) as [l|l];intros H;unfold interp_carry in H;rewrite <- H; - rewrite Zopp_mult_distr_l. + rewrite Zopp_mult_distr_l. assert ([|l|] = 0). assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. - rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh) + rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh) as [h|h];intros H1;unfold interp_carry in *;rewrite <- H1. assert ([|h|] = 0). assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. @@ -216,7 +216,7 @@ Section DoubleSub. Proof. destruct x as [ |xh xl];simpl. reflexivity. rewrite Zopp_plus_distr;rewrite Zopp_mult_distr_l. - generalize (spec_opp_c xl);destruct (w_opp_c xl) + generalize (spec_opp_c xl);destruct (w_opp_c xl) as [l|l];intros H;unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. rewrite spec_w_0;rewrite Zplus_0_r;rewrite wwB_wBwB. assert ([|l|] = 0). @@ -247,7 +247,7 @@ Section DoubleSub. assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. rewrite H0;change ([|xh|] + -1) with ([|xh|] - 1). generalize (spec_pred_c xh);destruct (w_pred_c xh) as [h|h]; - intros H1;unfold interp_carry in H1;rewrite <- H1. + intros H1;unfold interp_carry in H1;rewrite <- H1. simpl;rewrite spec_w_Bm1;ring. assert ([|h|] = wB - 1). assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. @@ -258,14 +258,14 @@ Section DoubleSub. Proof. destruct y as [ |yh yl];simpl. ring. destruct x as [ |xh xl];simpl. exact (spec_ww_opp_c (WW yh yl)). - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|])). 2:ring. generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl) as [l|l];intros H; unfold interp_carry in H;rewrite <- H. generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; intros H1;unfold interp_carry in *;rewrite <- H1;simpl ww_to_Z; @@ -275,37 +275,37 @@ Section DoubleSub. Lemma spec_ww_sub_carry_c : forall x y, [-[ww_sub_carry_c x y]] = [[x]] - [[y]] - 1. Proof. - destruct y as [ |yh yl];simpl. + destruct y as [ |yh yl];simpl. unfold Zminus;simpl;rewrite Zplus_0_r;exact (spec_ww_pred_c x). destruct x as [ |xh xl]. unfold interp_carry;rewrite spec_w_WW;simpl ww_to_Z;rewrite wwB_wBwB; repeat rewrite spec_opp_carry;ring. simpl ww_to_Z. - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|]-1)). 2:ring. - generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl) + generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl) as [l|l];intros H;unfold interp_carry in H;rewrite <- H. generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; intros H1;unfold interp_carry in *;rewrite <- H1;try rewrite spec_w_WW; simpl ww_to_Z; try rewrite wwB_wBwB;ring. - Qed. - + Qed. + Lemma spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB. Proof. - destruct x as [ |xh xl];simpl. + destruct x as [ |xh xl];simpl. apply Zmod_unique with (-1). apply spec_ww_to_Z;trivial. rewrite spec_ww_Bm1;ring. replace ([|xh|]*wB + [|xl|] - 1) with ([|xh|]*wB + ([|xl|] - 1)). 2:ring. generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];intro H; unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. - rewrite Zmod_small. apply spec_w_WW. + rewrite Zmod_small. apply spec_w_WW. exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh l)). - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. change ([|xh|] + -1) with ([|xh|] - 1). assert ([|l|] = wB - 1). assert (H1:= spec_to_Z l);assert (H2:= spec_to_Z xl);omega. @@ -318,7 +318,7 @@ Section DoubleSub. destruct y as [ |yh yl];simpl. ring_simplify ([[x]] - 0);rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial. destruct x as [ |xh xl];simpl. exact (spec_ww_opp (WW yh yl)). - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|])). 2:ring. generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl)as[l|l];intros H; unfold interp_carry in H;rewrite <- H. @@ -338,7 +338,7 @@ Section DoubleSub. apply spec_ww_to_Z;trivial. fold (ww_opp_carry (WW yh yl)). rewrite (spec_ww_opp_carry (WW yh yl));simpl ww_to_Z;ring. - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|] - 1)). 2:ring. generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)as[l|l]; intros H;unfold interp_carry in H;rewrite <- H;rewrite spec_w_WW. @@ -354,4 +354,4 @@ End DoubleSub. - + diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v index 28d40094..88cbb484 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v @@ -8,12 +8,12 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleType.v 10964 2008-05-22 11:08:13Z letouzey $ i*) +(*i $Id$ i*) Set Implicit Arguments. Require Import ZArith. -Open Local Scope Z_scope. +Local Open Scope Z_scope. Definition base digits := Zpower 2 (Zpos digits). @@ -37,10 +37,10 @@ Section Zn2Z. Variable znz : Type. - (** From a type [znz] representing a cyclic structure Z/nZ, + (** From a type [znz] representing a cyclic structure Z/nZ, we produce a representation of Z/2nZ by pairs of elements of [znz] - (plus a special case for zero). High half of the new number comes - first. + (plus a special case for zero). High half of the new number comes + first. *) Inductive zn2z := @@ -57,10 +57,10 @@ End Zn2Z. Implicit Arguments W0 [znz]. -(** From a cyclic representation [w], we iterate the [zn2z] construct - [n] times, gaining the type of binary trees of depth at most [n], - whose leafs are either W0 (if depth < n) or elements of w - (if depth = n). +(** From a cyclic representation [w], we iterate the [zn2z] construct + [n] times, gaining the type of binary trees of depth at most [n], + whose leafs are either W0 (if depth < n) or elements of w + (if depth = n). *) Fixpoint word (w:Type) (n:nat) : Type := diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index 6da1c6ec..8addf5b9 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Cyclic31.v 11907 2009-02-10 23:54:28Z letouzey $ i*) +(*i $Id$ i*) (** * Int31 numbers defines indeed a cyclic structure : Z/(2^31)Z *) @@ -24,8 +24,8 @@ Require Import BigNumPrelude. Require Import CyclicAxioms. Require Import ROmega. -Open Scope nat_scope. -Open Scope int31_scope. +Local Open Scope nat_scope. +Local Open Scope int31_scope. Section Basics. @@ -34,9 +34,9 @@ Section Basics. Lemma iszero_eq0 : forall x, iszero x = true -> x=0. Proof. destruct x; simpl; intros. - repeat - match goal with H:(if ?d then _ else _) = true |- _ => - destruct d; try discriminate + repeat + match goal with H:(if ?d then _ else _) = true |- _ => + destruct d; try discriminate end. reflexivity. Qed. @@ -46,26 +46,26 @@ Section Basics. intros x H Eq; rewrite Eq in H; simpl in *; discriminate. Qed. - Lemma sneakl_shiftr : forall x, + Lemma sneakl_shiftr : forall x, x = sneakl (firstr x) (shiftr x). Proof. destruct x; simpl; auto. Qed. - Lemma sneakr_shiftl : forall x, + Lemma sneakr_shiftl : forall x, x = sneakr (firstl x) (shiftl x). Proof. destruct x; simpl; auto. Qed. - Lemma twice_zero : forall x, + Lemma twice_zero : forall x, twice x = 0 <-> twice_plus_one x = 1. Proof. - destruct x; simpl in *; split; + destruct x; simpl in *; split; intro H; injection H; intros; subst; auto. Qed. - Lemma twice_or_twice_plus_one : forall x, + Lemma twice_or_twice_plus_one : forall x, x = twice (shiftr x) \/ x = twice_plus_one (shiftr x). Proof. intros; case_eq (firstr x); intros. @@ -79,13 +79,13 @@ Section Basics. Definition nshiftr n x := iter_nat n _ shiftr x. - Lemma nshiftr_S : + Lemma nshiftr_S : forall n x, nshiftr (S n) x = shiftr (nshiftr n x). Proof. reflexivity. Qed. - Lemma nshiftr_S_tail : + Lemma nshiftr_S_tail : forall n x, nshiftr (S n) x = nshiftr n (shiftr x). Proof. induction n; simpl; auto. @@ -103,7 +103,7 @@ Section Basics. destruct x; simpl; auto. Qed. - Lemma nshiftr_above_size : forall k x, size<=k -> + Lemma nshiftr_above_size : forall k x, size<=k -> nshiftr k x = 0. Proof. intros. @@ -117,13 +117,13 @@ Section Basics. Definition nshiftl n x := iter_nat n _ shiftl x. - Lemma nshiftl_S : + Lemma nshiftl_S : forall n x, nshiftl (S n) x = shiftl (nshiftl n x). Proof. reflexivity. Qed. - Lemma nshiftl_S_tail : + Lemma nshiftl_S_tail : forall n x, nshiftl (S n) x = nshiftl n (shiftl x). Proof. induction n; simpl; auto. @@ -141,7 +141,7 @@ Section Basics. destruct x; simpl; auto. Qed. - Lemma nshiftl_above_size : forall k x, size<=k -> + Lemma nshiftl_above_size : forall k x, size<=k -> nshiftl k x = 0. Proof. intros. @@ -151,27 +151,27 @@ Section Basics. simpl; rewrite nshiftl_S, IHn; auto. Qed. - Lemma firstr_firstl : + Lemma firstr_firstl : forall x, firstr x = firstl (nshiftl (pred size) x). Proof. destruct x; simpl; auto. Qed. - Lemma firstl_firstr : + Lemma firstl_firstr : forall x, firstl x = firstr (nshiftr (pred size) x). Proof. destruct x; simpl; auto. Qed. - + (** More advanced results about [nshiftr] *) - Lemma nshiftr_predsize_0_firstl : forall x, + Lemma nshiftr_predsize_0_firstl : forall x, nshiftr (pred size) x = 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 -> + Lemma nshiftr_0_propagates : forall n p x, n <= p -> nshiftr n x = 0 -> nshiftr p x = 0. Proof. intros. @@ -181,7 +181,7 @@ Section Basics. simpl; rewrite nshiftr_S; rewrite IHn0; auto. Qed. - Lemma nshiftr_0_firstl : forall n x, n < size -> + Lemma nshiftr_0_firstl : forall n x, n < size -> nshiftr n x = 0 -> firstl x = D0. Proof. intros. @@ -194,8 +194,8 @@ Section Basics. (** Not used for the moment. Are they really useful ? *) Lemma int31_ind_sneakl : forall P : int31->Prop, - P 0 -> - (forall x d, P x -> P (sneakl d x)) -> + P 0 -> + (forall x d, P x -> P (sneakl d x)) -> forall x, P x. Proof. intros. @@ -210,10 +210,10 @@ Section Basics. change x with (nshiftr (size-size) x); auto. Qed. - Lemma int31_ind_twice : forall P : int31->Prop, - P 0 -> - (forall x, P x -> P (twice x)) -> - (forall x, P x -> P (twice_plus_one x)) -> + Lemma int31_ind_twice : forall P : int31->Prop, + P 0 -> + (forall x, P x -> P (twice x)) -> + (forall x, P x -> P (twice_plus_one x)) -> forall x, P x. Proof. induction x using int31_ind_sneakl; auto. @@ -224,21 +224,21 @@ Section Basics. (** * Some generic results about [recr] *) Section Recr. - + (** [recr] satisfies the fixpoint equation used for its definition. *) Variable (A:Type)(case0:A)(caserec:digits->int31->A->A). - - Lemma recr_aux_eqn : forall n x, iszero x = false -> - recr_aux (S n) A case0 caserec x = + + Lemma recr_aux_eqn : forall n x, iszero x = false -> + recr_aux (S n) A case0 caserec x = caserec (firstr x) (shiftr x) (recr_aux n A case0 caserec (shiftr x)). Proof. intros; simpl; rewrite H; auto. Qed. - Lemma recr_aux_converges : + Lemma recr_aux_converges : forall n p x, n <= size -> n <= p -> - recr_aux n A case0 caserec (nshiftr (size - n) x) = + recr_aux n A case0 caserec (nshiftr (size - n) x) = recr_aux p A case0 caserec (nshiftr (size - n) x). Proof. induction n. @@ -255,8 +255,8 @@ Section Basics. apply IHn; auto with arith. Qed. - Lemma recr_eqn : forall x, iszero x = false -> - recr A case0 caserec x = + Lemma recr_eqn : forall x, iszero x = false -> + recr A case0 caserec x = caserec (firstr x) (shiftr x) (recr A case0 caserec (shiftr x)). Proof. intros. @@ -265,11 +265,11 @@ Section Basics. rewrite (recr_aux_converges size (S size)); auto with arith. rewrite recr_aux_eqn; auto. Qed. - - (** [recr] is usually equivalent to a variant [recrbis] + + (** [recr] is usually equivalent to a variant [recrbis] written without [iszero] check. *) - Fixpoint recrbis_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) + Fixpoint recrbis_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) (i:int31) : A := match n with | O => case0 @@ -277,7 +277,7 @@ Section Basics. let si := shiftr i in caserec (firstr i) si (recrbis_aux next A case0 caserec si) end. - + Definition recrbis := recrbis_aux size. Hypothesis case0_caserec : caserec D0 0 case0 = case0. @@ -291,8 +291,8 @@ Section Basics. replace (recrbis_aux n A case0 caserec 0) with case0; auto. clear H IHn; induction n; simpl; congruence. Qed. - - Lemma recrbis_equiv : forall x, + + Lemma recrbis_equiv : forall x, recrbis A case0 caserec x = recr A case0 caserec x. Proof. intros; apply recrbis_aux_equiv; auto. @@ -348,7 +348,7 @@ Section Basics. rewrite incr_eqn1; destruct x; simpl; auto. Qed. - Lemma incr_twice_plus_one_firstl : + Lemma incr_twice_plus_one_firstl : forall x, firstl x = D0 -> incr (twice_plus_one x) = twice (incr x). Proof. intros. @@ -356,9 +356,9 @@ Section Basics. f_equal; f_equal. destruct x; simpl in *; rewrite H; auto. Qed. - - (** The previous result is actually true even without the - constraint on [firstl], but this is harder to prove + + (** The previous result is actually true even without the + constraint on [firstl], but this is harder to prove (see later). *) End Incr. @@ -369,9 +369,9 @@ Section Basics. (** Variant of [phi] via [recrbis] *) - Let Phi := fun b (_:int31) => + Let Phi := fun b (_:int31) => match b with D0 => Zdouble | D1 => Zdouble_plus_one end. - + Definition phibis_aux n x := recrbis_aux n _ Z0 Phi x. Lemma phibis_aux_equiv : forall x, phibis_aux size x = phi x. @@ -382,7 +382,7 @@ Section Basics. (** Recursive equations satisfied by [phi] *) - Lemma phi_eqn1 : forall x, firstr x = D0 -> + Lemma phi_eqn1 : forall x, firstr x = D0 -> phi x = Zdouble (phi (shiftr x)). Proof. intros. @@ -392,7 +392,7 @@ Section Basics. rewrite H; auto. Qed. - Lemma phi_eqn2 : forall x, firstr x = D1 -> + Lemma phi_eqn2 : forall x, firstr x = D1 -> phi x = Zdouble_plus_one (phi (shiftr x)). Proof. intros. @@ -402,7 +402,7 @@ Section Basics. rewrite H; auto. Qed. - Lemma phi_twice_firstl : forall x, firstl x = D0 -> + Lemma phi_twice_firstl : forall x, firstl x = D0 -> phi (twice x) = Zdouble (phi x). Proof. intros. @@ -411,7 +411,7 @@ Section Basics. destruct x; simpl in *; rewrite H; auto. Qed. - Lemma phi_twice_plus_one_firstl : forall x, firstl x = D0 -> + Lemma phi_twice_plus_one_firstl : forall x, firstl x = D0 -> phi (twice_plus_one x) = Zdouble_plus_one (phi x). Proof. intros. @@ -427,23 +427,23 @@ Section Basics. Lemma phibis_aux_pos : forall n x, (0 <= phibis_aux n x)%Z. Proof. induction n. - simpl; unfold phibis_aux; simpl; auto with zarith. + simpl; unfold phibis_aux; simpl; auto with zarith. intros. - unfold phibis_aux, recrbis_aux; fold recrbis_aux; + unfold phibis_aux, recrbis_aux; fold recrbis_aux; fold (phibis_aux n (shiftr x)). destruct (firstr x). specialize IHn with (shiftr x); rewrite Zdouble_mult; omega. specialize IHn with (shiftr x); rewrite Zdouble_plus_one_mult; omega. Qed. - Lemma phibis_aux_bounded : - forall n x, n <= size -> + Lemma phibis_aux_bounded : + forall n x, n <= size -> (phibis_aux n (nshiftr (size-n) x) < 2 ^ (Z_of_nat n))%Z. Proof. induction n. simpl; unfold phibis_aux; simpl; auto with zarith. intros. - unfold phibis_aux, recrbis_aux; fold recrbis_aux; + 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). replace (size - n)%nat with (S (size - (S n))) by omega. @@ -468,8 +468,8 @@ Section Basics. apply phibis_aux_bounded; auto. Qed. - Lemma phibis_aux_lowerbound : - forall n x, firstr (nshiftr n x) = D1 -> + Lemma phibis_aux_lowerbound : + forall n x, firstr (nshiftr n x) = D1 -> (2 ^ Z_of_nat n <= phibis_aux (S n) x)%Z. Proof. induction n. @@ -480,7 +480,7 @@ Section Basics. intros. remember (S n) as m. - unfold phibis_aux, recrbis_aux; fold recrbis_aux; + unfold phibis_aux, recrbis_aux; fold recrbis_aux; fold (phibis_aux m (shiftr x)). subst m. rewrite inj_S, Zpower_Zsucc; auto with zarith. @@ -488,13 +488,13 @@ Section Basics. apply IHn. rewrite <- nshiftr_S_tail; auto. destruct (firstr x). - change (Zdouble (phibis_aux (S n) (shiftr x))) with + change (Zdouble (phibis_aux (S n) (shiftr x))) with (2*(phibis_aux (S n) (shiftr x)))%Z. omega. rewrite Zdouble_plus_one_mult; omega. Qed. - Lemma phi_lowerbound : + Lemma phi_lowerbound : forall x, firstl x = D1 -> (2^(Z_of_nat (pred size)) <= phi x)%Z. Proof. intros. @@ -508,9 +508,9 @@ Section Basics. Section EqShiftL. - (** After killing [n] bits at the left, are the numbers equal ?*) + (** After killing [n] bits at the left, are the numbers equal ?*) - Definition EqShiftL n x y := + Definition EqShiftL n x y := nshiftl n x = nshiftl n y. Lemma EqShiftL_zero : forall x y, EqShiftL O x y <-> x = y. @@ -523,7 +523,7 @@ Section Basics. red; intros; rewrite 2 nshiftl_above_size; auto. Qed. - Lemma EqShiftL_le : forall k k' x y, k <= k' -> + Lemma EqShiftL_le : forall k k' x y, k <= k' -> EqShiftL k x y -> EqShiftL k' x y. Proof. unfold EqShiftL; intros. @@ -534,18 +534,18 @@ Section Basics. rewrite 2 nshiftl_S; f_equal; auto. Qed. - Lemma EqShiftL_firstr : forall k x y, k < size -> + Lemma EqShiftL_firstr : forall k x y, k < size -> EqShiftL k x y -> firstr x = firstr y. Proof. intros. rewrite 2 firstr_firstl. f_equal. - apply EqShiftL_le with k; auto. + apply EqShiftL_le with k; auto. unfold size. auto with arith. Qed. - Lemma EqShiftL_twice : forall k x y, + Lemma EqShiftL_twice : forall k x y, EqShiftL k (twice x) (twice y) <-> EqShiftL (S k) x y. Proof. intros; unfold EqShiftL. @@ -553,7 +553,7 @@ Section Basics. Qed. (** * From int31 to list of digits. *) - + (** Lower (=rightmost) bits comes first. *) Definition i2l := recrbis _ nil (fun d _ rec => d::rec). @@ -561,10 +561,10 @@ Section Basics. Lemma i2l_length : forall x, length (i2l x) = size. Proof. intros; reflexivity. - Qed. + Qed. - Fixpoint lshiftl l x := - match l with + Fixpoint lshiftl l x := + match l with | nil => x | d::l => sneakl d (lshiftl l x) end. @@ -576,19 +576,19 @@ Section Basics. destruct x; compute; auto. Qed. - Lemma i2l_sneakr : forall x d, + Lemma i2l_sneakr : forall x d, i2l (sneakr d x) = tail (i2l x) ++ d::nil. Proof. destruct x; compute; auto. Qed. - Lemma i2l_sneakl : forall x d, + Lemma i2l_sneakl : forall x d, i2l (sneakl d x) = d :: removelast (i2l x). Proof. destruct x; compute; auto. Qed. - Lemma i2l_l2i : forall l, length l = size -> + Lemma i2l_l2i : forall l, length l = size -> i2l (l2i l) = l. Proof. repeat (destruct l as [ |? l]; [intros; discriminate | ]). @@ -596,9 +596,9 @@ Section Basics. intros _; compute; auto. Qed. - Fixpoint cstlist (A:Type)(a:A) n := - match n with - | O => nil + Fixpoint cstlist (A:Type)(a:A) n := + match n with + | O => nil | S n => a::cstlist _ a n end. @@ -612,7 +612,7 @@ Section Basics. induction (i2l x); simpl; f_equal; auto. rewrite H0; clear H0. reflexivity. - + intros. rewrite nshiftl_S. unfold shiftl; rewrite i2l_sneakl. @@ -657,10 +657,10 @@ Section Basics. f_equal; auto. Qed. - (** This equivalence allows to prove easily the following delicate + (** This equivalence allows to prove easily the following delicate result *) - Lemma EqShiftL_twice_plus_one : forall k x y, + 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. @@ -683,7 +683,7 @@ Section Basics. subst lx n; rewrite i2l_length; omega. Qed. - Lemma EqShiftL_shiftr : forall k x y, EqShiftL k x y -> + Lemma EqShiftL_shiftr : forall k x y, EqShiftL k x y -> EqShiftL (S k) (shiftr x) (shiftr y). Proof. intros. @@ -704,41 +704,41 @@ Section Basics. omega. Qed. - Lemma EqShiftL_incrbis : forall n k x y, n<=size -> + Lemma EqShiftL_incrbis : forall n k x y, n<=size -> (n+k=S size)%nat -> - EqShiftL k x y -> + EqShiftL k x y -> EqShiftL k (incrbis_aux n x) (incrbis_aux n y). Proof. induction n; simpl; intros. red; auto. - destruct (eq_nat_dec k size). + destruct (eq_nat_dec k size). subst k; apply EqShiftL_size; auto. - unfold incrbis_aux; simpl; + unfold incrbis_aux; simpl; fold (incrbis_aux n (shiftr x)); fold (incrbis_aux n (shiftr y)). rewrite (EqShiftL_firstr k x y); auto; try omega. case_eq (firstr y); intros. rewrite EqShiftL_twice_plus_one. apply EqShiftL_shiftr; auto. - + rewrite EqShiftL_twice. apply IHn; try omega. apply EqShiftL_shiftr; auto. Qed. - Lemma EqShiftL_incr : forall x y, + Lemma EqShiftL_incr : forall x y, EqShiftL 1 x y -> EqShiftL 1 (incr x) (incr y). Proof. intros. rewrite <- 2 incrbis_aux_equiv. apply EqShiftL_incrbis; auto. Qed. - + End EqShiftL. (** * More equations about [incr] *) - Lemma incr_twice_plus_one : + Lemma incr_twice_plus_one : forall x, incr (twice_plus_one x) = twice (incr x). Proof. intros. @@ -757,7 +757,7 @@ Section Basics. destruct (incr (shiftr x)); simpl; discriminate. Qed. - Lemma incr_inv : forall x y, + Lemma incr_inv : forall x y, incr x = twice_plus_one y -> x = twice y. Proof. intros. @@ -777,7 +777,7 @@ Section Basics. (** First, recursive equations *) - Lemma phi_inv_double_plus_one : forall z, + Lemma phi_inv_double_plus_one : forall z, phi_inv (Zdouble_plus_one z) = twice_plus_one (phi_inv z). Proof. destruct z; simpl; auto. @@ -789,14 +789,14 @@ Section Basics. auto. Qed. - Lemma phi_inv_double : forall z, + Lemma phi_inv_double : forall z, phi_inv (Zdouble z) = twice (phi_inv z). Proof. destruct z; simpl; auto. rewrite incr_twice_plus_one; auto. Qed. - Lemma phi_inv_incr : forall z, + Lemma phi_inv_incr : forall z, phi_inv (Zsucc z) = incr (phi_inv z). Proof. destruct z. @@ -816,19 +816,19 @@ Section Basics. rewrite incr_twice_plus_one; auto. Qed. - (** [phi_inv o inv], the always-exact and easy-to-prove trip : + (** [phi_inv o inv], the always-exact and easy-to-prove trip : from int31 to Z and then back to int31. *) - Lemma phi_inv_phi_aux : - forall n x, n <= size -> - phi_inv (phibis_aux n (nshiftr (size-n) x)) = + Lemma phi_inv_phi_aux : + forall n x, n <= size -> + phi_inv (phibis_aux n (nshiftr (size-n) x)) = nshiftr (size-n) x. Proof. induction n. intros; simpl. rewrite nshiftr_size; auto. intros. - unfold phibis_aux, recrbis_aux; fold recrbis_aux; + 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). replace (size - n)%nat with (S (size - (S n))); auto; omega. @@ -863,10 +863,10 @@ Section Basics. (** * [positive_to_int31] *) - (** A variant of [p2i] with [twice] and [twice_plus_one] instead of + (** A variant of [p2i] with [twice] and [twice_plus_one] instead of [2*i] and [2*i+1] *) - Fixpoint p2ibis n p : (N*int31)%type := + Fixpoint p2ibis n p : (N*int31)%type := match n with | O => (Npos p, On) | S n => match p with @@ -876,7 +876,7 @@ Section Basics. end end. - Lemma p2ibis_bounded : forall n p, + Lemma p2ibis_bounded : forall n p, nshiftr n (snd (p2ibis n p)) = 0. Proof. induction n. @@ -906,20 +906,20 @@ Section Basics. replace (shiftr In) with 0; auto. apply nshiftr_n_0. Qed. - + Lemma p2ibis_spec : forall n p, n<=size -> - Zpos p = ((Z_of_N (fst (p2ibis n p)))*2^(Z_of_nat n) + + Zpos p = ((Z_of_N (fst (p2ibis n p)))*2^(Z_of_nat n) + phi (snd (p2ibis n p)))%Z. Proof. induction n; intros. simpl; rewrite Pmult_1_r; auto. - replace (2^(Z_of_nat (S n)))%Z with (2*2^(Z_of_nat n))%Z by - (rewrite <- Zpower_Zsucc, <- Zpos_P_of_succ_nat; + replace (2^(Z_of_nat (S n)))%Z with (2*2^(Z_of_nat n))%Z by + (rewrite <- Zpower_Zsucc, <- Zpos_P_of_succ_nat; auto with zarith). rewrite (Zmult_comm 2). assert (n<=size) by omega. - destruct p; simpl; [ | | auto]; - specialize (IHn p H0); + destruct p; simpl; [ | | auto]; + specialize (IHn p H0); generalize (p2ibis_bounded n p); destruct (p2ibis n p) as (r,i); simpl in *; intros. @@ -937,25 +937,25 @@ Section Basics. (** We now prove that this [p2ibis] is related to [phi_inv_positive] *) - Lemma phi_inv_positive_p2ibis : forall n p, (n<=size)%nat -> + Lemma phi_inv_positive_p2ibis : forall n p, (n<=size)%nat -> EqShiftL (size-n) (phi_inv_positive p) (snd (p2ibis n p)). Proof. induction n. intros. apply EqShiftL_size; auto. intros. - simpl p2ibis; destruct p; [ | | red; auto]; - specialize IHn with p; - 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; + simpl p2ibis; destruct p; [ | | red; auto]; + specialize IHn with p; + 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. Qed. (** This gives the expected result about [phi o phi_inv], at least for the positive case. *) - Lemma phi_phi_inv_positive : forall p, + Lemma phi_phi_inv_positive : forall p, phi (phi_inv_positive p) = (Zpos p) mod (2^(Z_of_nat size)). Proof. intros. @@ -975,12 +975,12 @@ Section Basics. Lemma double_twice_firstl : forall x, firstl x = D0 -> Twon*x = twice x. Proof. - intros. + intros. unfold mul31. rewrite <- Zdouble_mult, <- phi_twice_firstl, phi_inv_phi; auto. Qed. - Lemma double_twice_plus_one_firstl : forall x, firstl x = D0 -> + Lemma double_twice_plus_one_firstl : forall x, firstl x = D0 -> Twon*x+In = twice_plus_one x. Proof. intros. @@ -989,14 +989,14 @@ Section Basics. rewrite phi_twice_firstl, <- Zdouble_plus_one_mult, <- phi_twice_plus_one_firstl, phi_inv_phi; auto. Qed. - - Lemma p2i_p2ibis : forall n p, (n<=size)%nat -> + + Lemma p2i_p2ibis : forall n p, (n<=size)%nat -> p2i n p = p2ibis n p. Proof. induction n; simpl; auto; intros. - destruct p; auto; specialize IHn with p; - generalize (p2ibis_bounded n p); - rewrite IHn; try omega; destruct (p2ibis n p); simpl; intros; + destruct p; auto; specialize IHn with p; + generalize (p2ibis_bounded n p); + rewrite IHn; try omega; destruct (p2ibis n p); simpl; intros; f_equal; auto. apply double_twice_plus_one_firstl. apply (nshiftr_0_firstl n); auto; omega. @@ -1004,7 +1004,7 @@ Section Basics. apply (nshiftr_0_firstl n); auto; omega. Qed. - Lemma positive_to_int31_phi_inv_positive : forall p, + Lemma positive_to_int31_phi_inv_positive : forall p, snd (positive_to_int31 p) = phi_inv_positive p. Proof. intros; unfold positive_to_int31. @@ -1014,8 +1014,8 @@ Section Basics. apply (phi_inv_positive_p2ibis size); auto. Qed. - Lemma positive_to_int31_spec : forall p, - Zpos p = ((Z_of_N (fst (positive_to_int31 p)))*2^(Z_of_nat size) + + Lemma positive_to_int31_spec : forall p, + Zpos p = ((Z_of_N (fst (positive_to_int31 p)))*2^(Z_of_nat size) + phi (snd (positive_to_int31 p)))%Z. Proof. unfold positive_to_int31. @@ -1023,11 +1023,11 @@ Section Basics. apply p2ibis_spec; auto. Qed. - (** Thanks to the result about [phi o phi_inv_positive], we can - now establish easily the most general results about + (** Thanks to the result about [phi o phi_inv_positive], we can + now establish easily the most general results about [phi o twice] and so one. *) - - Lemma phi_twice : forall x, + + Lemma phi_twice : forall x, phi (twice x) = (Zdouble (phi x)) mod 2^(Z_of_nat size). Proof. intros. @@ -1041,7 +1041,7 @@ Section Basics. compute in H; elim H; auto. Qed. - Lemma phi_twice_plus_one : forall x, + Lemma phi_twice_plus_one : forall x, phi (twice_plus_one x) = (Zdouble_plus_one (phi x)) mod 2^(Z_of_nat size). Proof. intros. @@ -1055,14 +1055,14 @@ Section Basics. compute in H; elim H; auto. Qed. - Lemma phi_incr : forall x, + Lemma phi_incr : forall x, phi (incr x) = (Zsucc (phi x)) mod 2^(Z_of_nat size). Proof. intros. pattern x at 1; rewrite <- (phi_inv_phi x). rewrite <- phi_inv_incr. assert (0 <= Zsucc (phi x))%Z. - change (Zsucc (phi x)) with ((phi x)+1)%Z; + change (Zsucc (phi x)) with ((phi x)+1)%Z; generalize (phi_bounded x); omega. destruct (Zsucc (phi x)). simpl; auto. @@ -1070,10 +1070,10 @@ Section Basics. compute in H; elim H; auto. Qed. - (** With the previous results, we can deal with [phi o phi_inv] even + (** With the previous results, we can deal with [phi o phi_inv] even in the negative case *) - Lemma phi_phi_inv_negative : + Lemma phi_phi_inv_negative : forall p, phi (incr (complement_negative p)) = (Zneg p) mod 2^(Z_of_nat size). Proof. induction p. @@ -1091,11 +1091,11 @@ Section Basics. rewrite incr_twice_plus_one, phi_twice. remember (phi (incr (complement_negative p))) as q. rewrite Zdouble_mult, IHp, Zmult_mod_idemp_r; auto with zarith. - + simpl; auto. Qed. - Lemma phi_phi_inv : + Lemma phi_phi_inv : forall z, phi (phi_inv z) = z mod 2 ^ (Z_of_nat size). Proof. destruct z. @@ -1120,7 +1120,7 @@ Let w_pos_mod p i := end. (** Parity test *) -Let w_iseven i := +Let w_iseven i := let (_,r) := i/2 in match r ?= 0 with Eq => true | _ => false end. @@ -1140,7 +1140,7 @@ Definition int31_op := (mk_znz_op w_iszero (* Basic arithmetic operations *) (fun i => 0 -c i) - (fun i => 0 - i) + opp31 (fun i => 0-i-1) (fun i => i +c 1) add31c @@ -1181,14 +1181,14 @@ Definition int31_op := (mk_znz_op End Int31_Op. Section Int31_Spec. - - Open Local Scope Z_scope. + + Local Open Scope Z_scope. Notation "[| x |]" := (phi x) (at level 0, x at level 99). - Notation Local wB := (2 ^ (Z_of_nat size)). - - Lemma wB_pos : wB > 0. + Local Notation wB := (2 ^ (Z_of_nat size)). + + Lemma wB_pos : wB > 0. Proof. auto with zarith. Qed. @@ -1216,12 +1216,12 @@ Section Int31_Spec. Proof. reflexivity. Qed. - + Lemma spec_1 : [| 1 |] = 1. Proof. reflexivity. Qed. - + Lemma spec_Bm1 : [| Tn |] = wB - 1. Proof. reflexivity. @@ -1252,16 +1252,16 @@ Section Int31_Spec. destruct (Z_lt_le_dec (X+Y) wB). contradict H1; auto using Zmod_small with zarith. rewrite <- (Z_mod_plus_full (X+Y) (-1) wB). - rewrite Zmod_small; romega. + rewrite Zmod_small; romega. generalize (Zcompare_Eq_eq ((X+Y) mod wB) (X+Y)); intros Heq. - destruct Zcompare; intros; + destruct Zcompare; intros; [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. Qed. Lemma spec_succ_c : forall x, [+|add31c x 1|] = [|x|] + 1. Proof. - intros; apply spec_add_c. + intros; apply spec_add_c. Qed. Lemma spec_add_carry_c : forall x y, [+|add31carryc x y|] = [|x|] + [|y|] + 1. @@ -1279,7 +1279,7 @@ Section Int31_Spec. rewrite Zmod_small; romega. generalize (Zcompare_Eq_eq ((X+Y+1) mod wB) (X+Y+1)); intros Heq. - destruct Zcompare; intros; + destruct Zcompare; intros; [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. Qed. @@ -1304,7 +1304,7 @@ Section Int31_Spec. (** Substraction *) Lemma spec_sub_c : forall x y, [-|sub31c x y|] = [|x|] - [|y|]. - Proof. + Proof. unfold sub31c, sub31, interp_carry; intros. rewrite phi_phi_inv. generalize (phi_bounded x)(phi_bounded y); intros. @@ -1337,7 +1337,7 @@ Section Int31_Spec. contradict H1; apply Zmod_small; romega. generalize (Zcompare_Eq_eq ((X-Y-1) mod wB) (X-Y-1)); intros Heq. - destruct Zcompare; intros; + destruct Zcompare; intros; [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. Qed. @@ -1355,7 +1355,7 @@ Section Int31_Spec. Qed. Lemma spec_opp_c : forall x, [-|sub31c 0 x|] = -[|x|]. - Proof. + Proof. intros; apply spec_sub_c. Qed. @@ -1402,7 +1402,7 @@ Section Int31_Spec. change (wB*wB) with (wB^2); ring. unfold phi_inv2. - destruct x; unfold zn2z_to_Z; rewrite ?phi_phi_inv; + destruct x; unfold zn2z_to_Z; rewrite ?phi_phi_inv; change base with wB; auto. Qed. @@ -1426,7 +1426,7 @@ Section Int31_Spec. intros; apply spec_mul_c. Qed. - (** Division *) + (** Division *) Lemma spec_div21 : forall a1 a2 b, wB/2 <= [|b|] -> @@ -1537,7 +1537,7 @@ Section Int31_Spec. intros (H,_); compute in H; elim H; auto. Qed. - Lemma iter_int31_iter_nat : forall A f i a, + Lemma iter_int31_iter_nat : forall A f i a, iter_int31 i A f a = iter_nat (Zabs_nat [|i|]) A f a. Proof. intros. @@ -1548,17 +1548,17 @@ Section Int31_Spec. revert i a; induction size. simpl; auto. simpl; intros. - case_eq (firstr i); intros H; rewrite 2 IHn; + case_eq (firstr i); intros H; rewrite 2 IHn; 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; + generalize (phibis_aux_pos n (shiftr i)); intros; + set (z := phibis_aux n (shiftr i)) in *; clearbody z; rewrite <- iter_nat_plus. f_equal. rewrite Zdouble_mult, Zmult_comm, <- Zplus_diag_eq_mult_2. symmetry; apply Zabs_nat_Zplus; auto with zarith. - change (iter_nat (S (Zabs_nat z + Zabs_nat z)) A f a = + change (iter_nat (S (Zabs_nat z + Zabs_nat z)) A f a = iter_nat (Zabs_nat (Zdouble_plus_one z)) A f a); f_equal. rewrite Zdouble_plus_one_mult, Zmult_comm, <- Zplus_diag_eq_mult_2. rewrite Zabs_nat_Zplus; auto with zarith. @@ -1566,13 +1566,13 @@ Section Int31_Spec. change (Zabs_nat 1) with 1%nat; omega. Qed. - Fixpoint addmuldiv31_alt n i j := - match n with - | O => i + Fixpoint addmuldiv31_alt n i j := + match n with + | O => i | S n => addmuldiv31_alt n (sneakl (firstl j) i) (shiftl j) end. - Lemma addmuldiv31_equiv : forall p x y, + Lemma addmuldiv31_equiv : forall p x y, addmuldiv31 p x y = addmuldiv31_alt (Zabs_nat [|p|]) x y. Proof. intros. @@ -1588,7 +1588,7 @@ Section Int31_Spec. Qed. Lemma spec_add_mul_div : forall x y p, [|p|] <= Zpos 31 -> - [| addmuldiv31 p x y |] = + [| addmuldiv31 p x y |] = ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos 31) - [|p|]))) mod wB. Proof. intros. @@ -1626,7 +1626,7 @@ Section Int31_Spec. replace (31-Z_of_nat n) with (Zsucc(31-Zsucc(Z_of_nat n))) by ring. rewrite Zpower_Zsucc, <- Zdiv_Zdiv; auto with zarith. rewrite Zmult_comm, Z_div_mult; auto with zarith. - + rewrite phi_twice_plus_one, Zdouble_plus_one_mult. rewrite phi_twice; auto. change (Zdouble [|y|]) with (2*[|y|]). @@ -1644,7 +1644,7 @@ Section Int31_Spec. unfold wB'. rewrite <- Zpower_Zsucc, <- inj_S by (auto with zarith). f_equal. rewrite H1. - replace wB with (2^(Z_of_nat n)*2^(31-Z_of_nat n)) by + replace wB with (2^(Z_of_nat n)*2^(31-Z_of_nat n)) by (rewrite <- Zpower_exp; auto with zarith; f_equal; unfold size; ring). unfold Zminus; rewrite Zopp_mult_distr_l. rewrite Z_div_plus; auto with zarith. @@ -1669,8 +1669,8 @@ Section Int31_Spec. apply Zlt_le_trans with wB; auto with zarith. apply Zpower_le_monotone; auto with zarith. intros. - case_eq ([|p|] ?= 31); intros; - [ apply H; rewrite (Zcompare_Eq_eq _ _ H0); auto with zarith | | + case_eq ([|p|] ?= 31); intros; + [ apply H; rewrite (Zcompare_Eq_eq _ _ H0); auto with zarith | | apply H; change ([|p|]>31)%Z in H0; auto with zarith ]. change ([|p|]<31) in H0. rewrite spec_add_mul_div by auto with zarith. @@ -1701,16 +1701,16 @@ Section Int31_Spec. simpl; auto. Qed. - Fixpoint head031_alt n x := - match n with + Fixpoint head031_alt n x := + match n with | O => 0%nat - | S n => match firstl x with + | S n => match firstl x with | D0 => S (head031_alt n (shiftl x)) | D1 => 0%nat end end. - Lemma head031_equiv : + Lemma head031_equiv : forall x, [|head031 x|] = Z_of_nat (head031_alt size x). Proof. intros. @@ -1720,10 +1720,10 @@ Section Int31_Spec. unfold head031, recl. change On with (phi_inv (Z_of_nat (31-size))). - replace (head031_alt size x) with + replace (head031_alt size x) with (head031_alt size x + (31 - size))%nat by (apply plus_0_r; auto). assert (size <= 31)%nat by auto with arith. - + revert x H; induction size; intros. simpl; auto. unfold recl_aux; fold recl_aux. @@ -1748,7 +1748,7 @@ Section Int31_Spec. change [|In|] with 1. replace (31-n)%nat with (S (31 - S n))%nat by omega. rewrite inj_S; ring. - + clear - H H2. rewrite (sneakr_shiftl x) in H. rewrite H2 in H. @@ -1793,7 +1793,7 @@ Section Int31_Spec. rewrite (sneakr_shiftl x), H1, H; auto. rewrite <- nshiftl_S_tail; auto. - + change (2^(Z_of_nat 0)) with 1; rewrite Zmult_1_l. generalize (phi_bounded x); unfold size; split; auto with zarith. change (2^(Z_of_nat 31)/2) with (2^(Z_of_nat (pred size))). @@ -1809,16 +1809,16 @@ Section Int31_Spec. simpl; auto. Qed. - Fixpoint tail031_alt n x := - match n with + Fixpoint tail031_alt n x := + match n with | O => 0%nat - | S n => match firstr x with + | S n => match firstr x with | D0 => S (tail031_alt n (shiftr x)) | D1 => 0%nat end end. - Lemma tail031_equiv : + Lemma tail031_equiv : forall x, [|tail031 x|] = Z_of_nat (tail031_alt size x). Proof. intros. @@ -1828,10 +1828,10 @@ Section Int31_Spec. unfold tail031, recr. change On with (phi_inv (Z_of_nat (31-size))). - replace (tail031_alt size x) with + replace (tail031_alt size x) with (tail031_alt size x + (31 - size))%nat by (apply plus_0_r; auto). assert (size <= 31)%nat by auto with arith. - + revert x H; induction size; intros. simpl; auto. unfold recr_aux; fold recr_aux. @@ -1856,7 +1856,7 @@ Section Int31_Spec. change [|In|] with 1. replace (31-n)%nat with (S (31 - S n))%nat by omega. rewrite inj_S; ring. - + clear - H H2. rewrite (sneakl_shiftr x) in H. rewrite H2 in H. @@ -1864,7 +1864,7 @@ Section Int31_Spec. rewrite (iszero_eq0 _ H0) in H; discriminate. Qed. - Lemma spec_tail0 : forall x, 0 < [|x|] -> + Lemma spec_tail0 : forall x, 0 < [|x|] -> exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail031 x|]). Proof. intros. @@ -1882,23 +1882,23 @@ Section Int31_Spec. case_eq (firstr x); intros. rewrite (inj_S (tail031_alt n (shiftr x))), Zpower_Zsucc; auto with zarith. destruct (IHn (shiftr x)) as (y & Hy1 & Hy2). - + rewrite phi_nz; rewrite phi_nz in H; contradict H. rewrite (sneakl_shiftr x), H1, H; auto. rewrite <- nshiftr_S_tail; auto. - + exists y; split; auto. rewrite phi_eqn1; auto. rewrite Zdouble_mult, Hy2; ring. - + exists [|shiftr x|]. split. generalize (phi_bounded (shiftr x)); auto with zarith. rewrite phi_eqn2; auto. rewrite Zdouble_plus_one_mult; simpl; ring. Qed. - + (* Sqrt *) (* Direct transcription of an old proof @@ -1906,27 +1906,27 @@ Section Int31_Spec. Lemma quotient_by_2 a: a - 1 <= (a/2) + (a/2). Proof. - intros a; case (Z_mod_lt a 2); auto with zarith. + case (Z_mod_lt a 2); auto with zarith. intros H1; rewrite Zmod_eq_full; auto with zarith. Qed. - Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> + Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> (j * k) + j <= ((j + k)/2 + 1) ^ 2. Proof. - intros j k Hj; generalize Hj k; pattern j; apply natlike_ind; + intros Hj; generalize Hj k; pattern j; apply natlike_ind; auto; clear k j Hj. intros _ k Hk; repeat rewrite Zplus_0_l. apply Zmult_le_0_compat; generalize (Z_div_pos k 2); auto with zarith. intros j Hj Hrec _ k Hk; pattern k; apply natlike_ind; auto; clear k Hk. rewrite Zmult_0_r, Zplus_0_r, Zplus_0_l. - generalize (sqr_pos (Zsucc j / 2)) (quotient_by_2 (Zsucc j)); + generalize (sqr_pos (Zsucc j / 2)) (quotient_by_2 (Zsucc j)); unfold Zsucc. rewrite Zpower_2, Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. auto with zarith. intros k Hk _. replace ((Zsucc j + Zsucc k) / 2) with ((j + k)/2 + 1). generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)). - unfold Zsucc; repeat rewrite Zpower_2; + unfold Zsucc; repeat rewrite Zpower_2; repeat rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. repeat rewrite Zmult_1_l; repeat rewrite Zmult_1_r. auto with zarith. @@ -1936,7 +1936,7 @@ Section Int31_Spec. Lemma sqrt_main i j: 0 <= i -> 0 < j -> i < ((j + (i/j))/2 + 1) ^ 2. Proof. - intros i j Hi Hj. + intros Hi Hj. assert (Hij: 0 <= i/j) by (apply Z_div_pos; auto with zarith). apply Zlt_le_trans with (2 := sqrt_main_trick _ _ (Zlt_le_weak _ _ Hj) Hij). pattern i at 1; rewrite (Z_div_mod_eq i j); case (Z_mod_lt i j); auto with zarith. @@ -1944,7 +1944,7 @@ Section Int31_Spec. Lemma sqrt_init i: 1 < i -> i < (i/2 + 1) ^ 2. Proof. - intros i Hi. + intros Hi. assert (H1: 0 <= i - 2) by auto with zarith. assert (H2: 1 <= (i / 2) ^ 2); auto with zarith. replace i with (1* 2 + (i - 2)); auto with zarith. @@ -1962,14 +1962,14 @@ Section Int31_Spec. Lemma sqrt_test_true i j: 0 <= i -> 0 < j -> i/j >= j -> j ^ 2 <= i. Proof. - intros i j Hi Hj Hd; rewrite Zpower_2. + intros Hi Hj Hd; rewrite Zpower_2. apply Zle_trans with (j * (i/j)); auto with zarith. apply Z_mult_div_ge; auto with zarith. Qed. Lemma sqrt_test_false i j: 0 <= i -> 0 < j -> i/j < j -> (j + (i/j))/2 < j. Proof. - intros i j Hi Hj H; case (Zle_or_lt j ((j + (i/j))/2)); auto. + intros Hi Hj H; case (Zle_or_lt j ((j + (i/j))/2)); auto. intros H1; contradict H; apply Zle_not_lt. assert (2 * j <= j + (i/j)); auto with zarith. apply Zle_trans with (2 * ((j + (i/j))/2)); auto with zarith. @@ -1984,32 +1984,32 @@ Section Int31_Spec. Lemma Zcompare_spec i j: ZcompareSpec i j (i ?= j). Proof. - intros i j; case_eq (Zcompare i j); intros H. + case_eq (Zcompare i j); intros H. apply ZcompareSpecEq; apply Zcompare_Eq_eq; auto. apply ZcompareSpecLt; auto. apply ZcompareSpecGt; apply Zgt_lt; auto. Qed. Lemma sqrt31_step_def rec i j: - sqrt31_step rec i j = + sqrt31_step rec i j = match (fst (i/j) ?= j)%int31 with Lt => rec i (fst ((j + fst(i/j))/2))%int31 | _ => j end. Proof. - intros rec i j; unfold sqrt31_step; case div31; intros. + unfold sqrt31_step; case div31; intros. simpl; case compare31; auto. Qed. Lemma div31_phi i j: 0 < [|j|] -> [|fst (i/j)%int31|] = [|i|]/[|j|]. - intros i j Hj; generalize (spec_div i j Hj). + intros Hj; generalize (spec_div i j Hj). case div31; intros q r; simpl fst. intros (H1,H2); apply Zdiv_unique with [|r|]; auto with zarith. rewrite H1; ring. Qed. - Lemma sqrt31_step_correct rec i j: - 0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 -> + Lemma sqrt31_step_correct rec i j: + 0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 -> 2 * [|j|] < wB -> (forall j1 : int31, 0 < [|j1|] < [|j|] -> [|i|] < ([|j1|] + 1) ^ 2 -> @@ -2017,15 +2017,15 @@ Section Int31_Spec. [|sqrt31_step rec i j|] ^ 2 <= [|i|] < ([|sqrt31_step rec i j|] + 1) ^ 2. Proof. assert (Hp2: 0 < [|2|]) by exact (refl_equal Lt). - intros rec i j Hi Hj Hij H31 Hrec; rewrite sqrt31_step_def. - generalize (spec_compare (fst (i/j)%int31) j); case compare31; + intros Hi Hj Hij H31 Hrec; rewrite sqrt31_step_def. + generalize (spec_compare (fst (i/j)%int31) j); case compare31; rewrite div31_phi; auto; intros Hc; try (split; auto; apply sqrt_test_true; auto with zarith; fail). apply Hrec; repeat rewrite div31_phi; auto with zarith. replace [|(j + fst (i / j)%int31)|] with ([|j|] + [|i|] / [|j|]). split. case (Zle_lt_or_eq 1 [|j|]); auto with zarith; intros Hj1. - replace ([|j|] + [|i|]/[|j|]) with + replace ([|j|] + [|i|]/[|j|]) with (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])); try ring. rewrite Z_div_plus_full_l; auto with zarith. assert (0 <= [|i|]/ [|j|]) by (apply Z_div_pos; auto with zarith). @@ -2048,12 +2048,12 @@ Section Int31_Spec. Lemma iter31_sqrt_correct n rec i j: 0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 -> 2 * [|j|] < 2 ^ (Z_of_nat size) -> - (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> + (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> [|i|] < ([|j1|] + 1) ^ 2 -> 2 * [|j1|] < 2 ^ (Z_of_nat size) -> [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) -> [|iter31_sqrt n rec i j|] ^ 2 <= [|i|] < ([|iter31_sqrt n rec i j|] + 1) ^ 2. Proof. - intros n; elim n; unfold iter31_sqrt; fold iter31_sqrt; clear n. + revert rec i j; elim n; unfold iter31_sqrt; fold iter31_sqrt; clear n. intros rec i j Hi Hj Hij H31 Hrec; apply sqrt31_step_correct; auto with zarith. intros; apply Hrec; auto with zarith. rewrite Zpower_0_r; auto with zarith. @@ -2098,7 +2098,7 @@ Section Int31_Spec. Qed. Lemma sqrt312_step_def rec ih il j: - sqrt312_step rec ih il j = + sqrt312_step rec ih il j = match (ih ?= j)%int31 with Eq => j | Gt => j @@ -2112,14 +2112,14 @@ Section Int31_Spec. end end. Proof. - intros rec ih il j; unfold sqrt312_step; case div3121; intros. + unfold sqrt312_step; case div3121; intros. simpl; case compare31; auto. Qed. - Lemma sqrt312_lower_bound ih il j: + Lemma sqrt312_lower_bound ih il j: phi2 ih il < ([|j|] + 1) ^ 2 -> [|ih|] <= [|j|]. Proof. - intros ih il j H1. + intros H1. case (phi_bounded j); intros Hbj _. case (phi_bounded il); intros Hbil _. case (phi_bounded ih); intros Hbih Hbih1. @@ -2133,22 +2133,22 @@ Section Int31_Spec. Lemma div312_phi ih il j: (2^30 <= [|j|] -> [|ih|] < [|j|] -> [|fst (div3121 ih il j)|] = phi2 ih il/[|j|])%Z. Proof. - intros ih il j Hj Hj1. + intros Hj Hj1. 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 trans_equal with (1 := Hq); ring. Qed. - Lemma sqrt312_step_correct rec ih il j: - 2 ^ 29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> + Lemma sqrt312_step_correct rec ih il j: + 2 ^ 29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> (forall j1, 0 < [|j1|] < [|j|] -> phi2 ih il < ([|j1|] + 1) ^ 2 -> [|rec ih il j1|] ^ 2 <= phi2 ih il < ([|rec ih il j1|] + 1) ^ 2) -> - [|sqrt312_step rec ih il j|] ^ 2 <= phi2 ih il + [|sqrt312_step rec ih il j|] ^ 2 <= phi2 ih il < ([|sqrt312_step rec ih il j|] + 1) ^ 2. Proof. assert (Hp2: (0 < [|2|])%Z) by exact (refl_equal Lt). - intros rec ih il j Hih Hj Hij Hrec; rewrite sqrt312_step_def. + intros Hih Hj Hij Hrec; rewrite sqrt312_step_def. assert (H1: ([|ih|] <= [|j|])%Z) by (apply sqrt312_lower_bound with il; auto). case (phi_bounded ih); intros Hih1 _. case (phi_bounded il); intros Hil1 _. @@ -2174,7 +2174,7 @@ Section Int31_Spec. case (Zle_lt_or_eq 1 ([|j|])); auto with zarith; intros Hf2. 2: contradict Hc; apply Zle_not_lt; rewrite <- Hf2, Zdiv_1_r; auto with zarith. assert (Hf3: 0 < ([|j|] + phi2 ih il / [|j|]) / 2). - replace ([|j|] + phi2 ih il/ [|j|])%Z with + replace ([|j|] + phi2 ih il/ [|j|])%Z with (1 * 2 + (([|j|] - 2) + phi2 ih il / [|j|])); try ring. rewrite Z_div_plus_full_l; auto with zarith. assert (0 <= ([|j|] - 2 + phi2 ih il / [|j|]) / 2) ; auto with zarith. @@ -2213,7 +2213,7 @@ Section Int31_Spec. rewrite div31_phi; change (phi 2) with 2%Z; auto. change (2 ^Z_of_nat size) with (base/2 + phi v30). assert (phi r / 2 < base/2); auto with zarith. - apply Zmult_gt_0_lt_reg_r with 2; auto with zarith. + apply Zmult_gt_0_lt_reg_r with 2; auto with zarith. change (base/2 * 2) with base. apply Zle_lt_trans with (phi r). rewrite Zmult_comm; apply Z_mult_div_ge; auto with zarith. @@ -2234,15 +2234,15 @@ Section Int31_Spec. apply Zge_le; apply Z_div_ge; auto with zarith. Qed. - Lemma iter312_sqrt_correct n rec ih il j: - 2^29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> - (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> - phi2 ih il < ([|j1|] + 1) ^ 2 -> + Lemma iter312_sqrt_correct n rec ih il j: + 2^29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> + (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> + phi2 ih il < ([|j1|] + 1) ^ 2 -> [|rec ih il j1|] ^ 2 <= phi2 ih il < ([|rec ih il j1|] + 1) ^ 2) -> - [|iter312_sqrt n rec ih il j|] ^ 2 <= phi2 ih il + [|iter312_sqrt n rec ih il j|] ^ 2 <= phi2 ih il < ([|iter312_sqrt n rec ih il j|] + 1) ^ 2. Proof. - intros n; elim n; unfold iter312_sqrt; fold iter312_sqrt; clear n. + revert rec ih il j; elim n; unfold iter312_sqrt; fold iter312_sqrt; clear n. intros rec ih il j Hi Hj Hij Hrec; apply sqrt312_step_correct; auto with zarith. intros; apply Hrec; auto with zarith. rewrite Zpower_0_r; auto with zarith. @@ -2265,7 +2265,7 @@ Section Int31_Spec. Proof. intros ih il Hih; unfold sqrt312. change [||WW ih il||] with (phi2 ih il). - assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by + assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by (intros s; ring). assert (Hb: 0 <= base) by (red; intros HH; discriminate). assert (Hi2: phi2 ih il < (phi Tn + 1) ^ 2). @@ -2428,9 +2428,9 @@ Section Int31_Spec. apply Zcompare_Eq_eq. now destruct ([|x|] ?= 0). Qed. - + (* Even *) - + Let w_is_even := int31_op.(znz_is_even). Lemma spec_is_even : forall x, @@ -2460,13 +2460,13 @@ Section Int31_Spec. exact spec_more_than_1_digit. exact spec_0. - exact spec_1. + exact spec_1. exact spec_Bm1. exact spec_compare. exact spec_eq0. - exact spec_opp_c. + exact spec_opp_c. exact spec_opp. exact spec_opp_carry. @@ -2500,7 +2500,7 @@ Section Int31_Spec. exact spec_head00. exact spec_head0. - exact spec_tail00. + exact spec_tail00. exact spec_tail0. exact spec_add_mul_div. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index 154b436b..cc224254 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: Int31.v 11072 2008-06-08 16:13:37Z herbelin $ i*) +(*i $Id$ i*) Require Import NaryFunctions. Require Import Wf_nat. @@ -17,7 +17,7 @@ Require Export DoubleType. Unset Boxed Definitions. -(** * 31-bit integers *) +(** * 31-bit integers *) (** This file contains basic definitions of a 31-bit integer arithmetic. In fact it is more general than that. The only reason @@ -36,11 +36,13 @@ Definition size := 31%nat. Inductive digits : Type := D0 | D1. (** The type of 31-bit integers *) - -(** The type [int31] has a unique constructor [I31] that expects + +(** The type [int31] has a unique constructor [I31] that expects 31 arguments of type [digits]. *) -Inductive int31 : Type := I31 : nfun digits size int31. +Definition digits31 t := Eval compute in nfun digits size t. + +Inductive int31 : Type := I31 : digits31 int31. (* spiwack: Registration of the type of integers, so that the matchs in the functions below perform dynamic decompilation (otherwise some segfault @@ -50,7 +52,7 @@ Register int31 as int31 type in "coq_int31" by True. Delimit Scope int31_scope with int31. Bind Scope int31_scope with int31. -Open Scope int31_scope. +Local Open Scope int31_scope. (** * Constants *) @@ -69,26 +71,26 @@ Definition Twon : int31 := Eval compute in (napply_cst _ _ D0 (size-2) I31) D1 D (** * Bits manipulation *) -(** [sneakr b x] shifts [x] to the right by one bit. +(** [sneakr b x] shifts [x] to the right by one bit. Rightmost digit is lost while leftmost digit becomes [b]. - Pseudo-code is + Pseudo-code is [ match x with (I31 d0 ... dN) => I31 b d0 ... d(N-1) end ] *) Definition sneakr : digits -> int31 -> int31 := Eval compute in fun b => int31_rect _ (napply_except_last _ _ (size-1) (I31 b)). -(** [sneakl b x] shifts [x] to the left by one bit. +(** [sneakl b x] shifts [x] to the left by one bit. Leftmost digit is lost while rightmost digit becomes [b]. - Pseudo-code is + Pseudo-code is [ match x with (I31 d0 ... dN) => I31 d1 ... dN b end ] *) -Definition sneakl : digits -> int31 -> int31 := Eval compute in +Definition sneakl : digits -> int31 -> int31 := Eval compute in fun b => int31_rect _ (fun _ => napply_then_last _ _ b (size-1) I31). -(** [shiftl], [shiftr], [twice] and [twice_plus_one] are direct +(** [shiftl], [shiftr], [twice] and [twice_plus_one] are direct consequences of [sneakl] and [sneakr]. *) Definition shiftl := sneakl D0. @@ -96,31 +98,31 @@ Definition shiftr := sneakr D0. Definition twice := sneakl D0. Definition twice_plus_one := sneakl D1. -(** [firstl x] returns the leftmost digit of number [x]. +(** [firstl x] returns the leftmost digit of number [x]. Pseudo-code is [ match x with (I31 d0 ... dN) => d0 end ] *) -Definition firstl : int31 -> digits := Eval compute in +Definition firstl : int31 -> digits := Eval compute in int31_rect _ (fun d => napply_discard _ _ d (size-1)). -(** [firstr x] returns the rightmost digit of number [x]. +(** [firstr x] returns the rightmost digit of number [x]. Pseudo-code is [ match x with (I31 d0 ... dN) => dN end ] *) -Definition firstr : int31 -> digits := Eval compute in +Definition firstr : int31 -> digits := Eval compute in int31_rect _ (napply_discard _ _ (fun d=>d) (size-1)). -(** [iszero x] is true iff [x = I31 D0 ... D0]. Pseudo-code is +(** [iszero x] is true iff [x = I31 D0 ... D0]. Pseudo-code is [ match x with (I31 D0 ... D0) => true | _ => false end ] *) -Definition iszero : int31 -> bool := Eval compute in - let f d b := match d with D0 => b | D1 => false end +Definition iszero : int31 -> bool := Eval compute in + let f d b := match d with D0 => b | D1 => false end in int31_rect _ (nfold_bis _ _ f true size). -(* NB: DO NOT transform the above match in a nicer (if then else). +(* NB: DO NOT transform the above match in a nicer (if then else). It seems to work, but later "unfold iszero" takes forever. *) -(** [base] is [2^31], obtained via iterations of [Zdouble]. - It can also be seen as the smallest b > 0 s.t. phi_inv b = 0 +(** [base] is [2^31], obtained via iterations of [Zdouble]. + It can also be seen as the smallest b > 0 s.t. phi_inv b = 0 (see below) *) Definition base := Eval compute in @@ -140,7 +142,7 @@ Fixpoint recl_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) caserec (firstl i) si (recl_aux next A case0 caserec si) end. -Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) +Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) (i:int31) : A := match n with | O => case0 @@ -159,22 +161,22 @@ Definition recr := recr_aux size. (** From int31 to Z, we simply iterates [Zdouble] or [Zdouble_plus_one]. *) -Definition phi : int31 -> Z := +Definition phi : int31 -> Z := recr Z (0%Z) (fun b _ => match b with D0 => Zdouble | D1 => Zdouble_plus_one end). -(** From positive to int31. An abstract definition could be : - [ phi_inv (2n) = 2*(phi_inv n) /\ +(** From positive to int31. An abstract definition could be : + [ phi_inv (2n) = 2*(phi_inv n) /\ phi_inv 2n+1 = 2*(phi_inv n) + 1 ] *) -Fixpoint phi_inv_positive p := +Fixpoint phi_inv_positive p := match p with | xI q => twice_plus_one (phi_inv_positive q) | xO q => twice (phi_inv_positive q) | xH => In end. -(** The negative part : 2-complement *) +(** The negative part : 2-complement *) Fixpoint complement_negative p := match p with @@ -186,9 +188,9 @@ Fixpoint complement_negative p := (** A simple incrementation function *) Definition incr : int31 -> int31 := - recr int31 In - (fun b si rec => match b with - | D0 => sneakl D1 si + recr int31 In + (fun b si rec => match b with + | D0 => sneakl D1 si | D1 => sneakl D0 rec end). (** We can now define the conversion from Z to int31. *) @@ -196,11 +198,11 @@ Definition incr : int31 -> int31 := Definition phi_inv : Z -> int31 := fun n => match n with | Z0 => On - | Zpos p => phi_inv_positive p + | Zpos p => phi_inv_positive p | Zneg p => incr (complement_negative p) end. -(** [phi_inv2] is similar to [phi_inv] but returns a double word +(** [phi_inv2] is similar to [phi_inv] but returns a double word [zn2z int31] *) Definition phi_inv2 n := @@ -211,7 +213,7 @@ Definition phi_inv2 n := (** [phi2] is similar to [phi] but takes a double word (two args) *) -Definition phi2 nh nl := +Definition phi2 nh nl := ((phi nh)*base+(phi nl))%Z. (** * Addition *) @@ -227,11 +229,11 @@ Notation "n + m" := (add31 n m) : int31_scope. (* mode, (phi n)+(phi m) is computed twice*) (* it may be considered to optimize it *) -Definition add31c (n m : int31) := +Definition add31c (n m : int31) := let npm := n+m in - match (phi npm ?= (phi n)+(phi m))%Z with - | Eq => C0 npm - | _ => C1 npm + match (phi npm ?= (phi n)+(phi m))%Z with + | Eq => C0 npm + | _ => C1 npm end. Notation "n '+c' m" := (add31c n m) (at level 50, no associativity) : int31_scope. @@ -254,7 +256,7 @@ Notation "n - m" := (sub31 n m) : int31_scope. (** Subtraction with carry (thus exact) *) -Definition sub31c (n m : int31) := +Definition sub31c (n m : int31) := let nmm := n-m in match (phi nmm ?= (phi n)-(phi m))%Z with | Eq => C0 nmm @@ -272,6 +274,10 @@ Definition sub31carryc (n m : int31) := | _ => C1 nmmmone end. +(** Opposite *) + +Definition opp31 x := On - x. +Notation "- x" := (opp31 x) : int31_scope. (** Multiplication *) @@ -290,13 +296,13 @@ Notation "n '*c' m" := (mul31c n m) (at level 40, no associativity) : int31_scop (** Division of a double size word modulo [2^31] *) -Definition div3121 (nh nl m : int31) := +Definition div3121 (nh nl m : int31) := let (q,r) := Zdiv_eucl (phi2 nh nl) (phi m) in (phi_inv q, phi_inv r). (** Division modulo [2^31] *) -Definition div31 (n m : int31) := +Definition div31 (n m : int31) := let (q,r) := Zdiv_eucl (phi n) (phi m) in (phi_inv q, phi_inv r). Notation "n / m" := (div31 n m) : int31_scope. @@ -307,13 +313,16 @@ Notation "n / m" := (div31 n m) : int31_scope. Definition compare31 (n m : int31) := ((phi n)?=(phi m))%Z. Notation "n ?= m" := (compare31 n m) (at level 70, no associativity) : int31_scope. +Definition eqb31 (n m : int31) := + match n ?= m with Eq => true | _ => false end. + -(** Computing the [i]-th iterate of a function: +(** Computing the [i]-th iterate of a function: [iter_int31 i A f = f^i] *) Definition iter_int31 i A f := - recr (A->A) (fun x => x) - (fun b si rec => match b with + recr (A->A) (fun x => x) + (fun b si rec => match b with | D0 => fun x => rec (rec x) | D1 => fun x => f (rec (rec x)) end) @@ -322,9 +331,9 @@ Definition iter_int31 i A f := (** Combining the [(31-p)] low bits of [i] above the [p] high bits of [j]: [addmuldiv31 p i j = i*2^p+j/2^(31-p)] (modulo [2^31]) *) -Definition addmuldiv31 p i j := - let (res, _ ) := - iter_int31 p (int31*int31) +Definition addmuldiv31 p i j := + let (res, _ ) := + iter_int31 p (int31*int31) (fun ij => let (i,j) := ij in (sneakl (firstl j) i, shiftl j)) (i,j) in @@ -346,7 +355,7 @@ Register addmuldiv31 as int31 addmuldiv in "coq_int31" by True. Definition gcd31 (i j:int31) := (fix euler (guard:nat) (i j:int31) {struct guard} := - match guard with + match guard with | O => In | S p => match j ?= On with | Eq => i @@ -370,17 +379,17 @@ Eval lazy delta [Twon] in | _ => j end. -Fixpoint iter31_sqrt (n: nat) (rec: int31 -> int31 -> int31) +Fixpoint iter31_sqrt (n: nat) (rec: int31 -> int31 -> int31) (i j: int31) {struct n} : int31 := - sqrt31_step + sqrt31_step (match n with O => rec | S n => (iter31_sqrt n (iter31_sqrt n rec)) end) i j. -Definition sqrt31 i := +Definition sqrt31 i := Eval lazy delta [On In Twon] in - match compare31 In i with + match compare31 In i with Gt => On | Eq => In | Lt => iter31_sqrt 31 (fun i j => j) i (fst (i/Twon)) @@ -388,7 +397,7 @@ Eval lazy delta [On In Twon] in Definition v30 := Eval compute in (addmuldiv31 (phi_inv (Z_of_nat size - 1)) In On). -Definition sqrt312_step (rec: int31 -> int31 -> int31 -> int31) +Definition sqrt312_step (rec: int31 -> int31 -> int31 -> int31) (ih il j: int31) := Eval lazy delta [Twon v30] in match ih ?= j with Eq => j | Gt => j | _ => @@ -401,28 +410,28 @@ Eval lazy delta [Twon v30] in | _ => j end end. -Fixpoint iter312_sqrt (n: nat) - (rec: int31 -> int31 -> int31 -> int31) +Fixpoint iter312_sqrt (n: nat) + (rec: int31 -> int31 -> int31 -> int31) (ih il j: int31) {struct n} : int31 := - sqrt312_step + sqrt312_step (match n with O => rec | S n => (iter312_sqrt n (iter312_sqrt n rec)) end) ih il j. -Definition sqrt312 ih il := +Definition sqrt312 ih il := Eval lazy delta [On In] in let s := iter312_sqrt 31 (fun ih il j => j) ih il Tn in match s *c s with W0 => (On, C0 On) (* impossible *) | WW ih1 il1 => match il -c il1 with - C0 il2 => + C0 il2 => match ih ?= ih1 with Gt => (s, C1 il2) | _ => (s, C0 il2) end - | C1 il2 => + | C1 il2 => match (ih - In) ?= ih1 with (* we could parametrize ih - 1 *) Gt => (s, C1 il2) | _ => (s, C0 il2) @@ -431,7 +440,7 @@ Eval lazy delta [On In] in end. -Fixpoint p2i n p : (N*int31)%type := +Fixpoint p2i n p : (N*int31)%type := match n with | O => (Npos p, On) | S n => match p with @@ -444,26 +453,26 @@ Fixpoint p2i n p : (N*int31)%type := Definition positive_to_int31 (p:positive) := p2i size p. (** Constant 31 converted into type int31. - It is used as default answer for numbers of zeros + It is used as default answer for numbers of zeros in [head0] and [tail0] *) Definition T31 : int31 := Eval compute in phi_inv (Z_of_nat size). Definition head031 (i:int31) := - recl _ (fun _ => T31) - (fun b si rec n => match b with + recl _ (fun _ => T31) + (fun b si rec n => match b with | D0 => rec (add31 n In) | D1 => n end) i On. Definition tail031 (i:int31) := - recr _ (fun _ => T31) - (fun b si rec n => match b with + recr _ (fun _ => T31) + (fun b si rec n => match b with | D0 => rec (add31 n In) | D1 => n end) i On. Register head031 as int31 head0 in "coq_int31" by True. -Register tail031 as int31 tail0 in "coq_int31" by True. +Register tail031 as int31 tail0 in "coq_int31" by True. diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v new file mode 100644 index 00000000..2ec406b0 --- /dev/null +++ b/theories/Numbers/Cyclic/Int31/Ring31.v @@ -0,0 +1,103 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr:true + | ?t::?l => match t with + | D1 => isInt31cst_lst l + | D0 => isInt31cst_lst l + | _ => constr:false + end + | _ => constr:false + end. + +Ltac isInt31cst t := + match t with + | I31 ?i0 ?i1 ?i2 ?i3 ?i4 ?i5 ?i6 ?i7 ?i8 ?i9 ?i10 + ?i11 ?i12 ?i13 ?i14 ?i15 ?i16 ?i17 ?i18 ?i19 ?i20 + ?i21 ?i22 ?i23 ?i24 ?i25 ?i26 ?i27 ?i28 ?i29 ?i30 => + let l := + constr:(i0::i1::i2::i3::i4::i5::i6::i7::i8::i9::i10 + ::i11::i12::i13::i14::i15::i16::i17::i18::i19::i20 + ::i21::i22::i23::i24::i25::i26::i27::i28::i29::i30::nil) + in isInt31cst_lst l + | Int31.On => constr:true + | Int31.In => constr:true + | Int31.Tn => constr:true + | Int31.Twon => constr:true + | _ => constr:false + end. + +Ltac Int31cst t := + match isInt31cst t with + | true => constr:t + | false => constr:NotConstant + end. + +(** The generic ring structure inferred from the Cyclic structure *) + +Module Int31ring := CyclicRing Int31Cyclic. + +(** Unlike in the generic [CyclicRing], we can use Leibniz here. *) + +Lemma Int31_canonic : forall x y, phi x = phi y -> x = y. +Proof. + intros x y EQ. + now rewrite <- (phi_inv_phi x), <- (phi_inv_phi y), EQ. +Qed. + +Lemma ring_theory_switch_eq : + forall A (R R':A->A->Prop) zero one add mul sub opp, + (forall x y : A, R x y -> R' x y) -> + ring_theory zero one add mul sub opp R -> + ring_theory zero one add mul sub opp R'. +Proof. +intros A R R' zero one add mul sub opp Impl Ring. +constructor; intros; apply Impl; apply Ring. +Qed. + +Lemma Int31Ring : ring_theory 0 1 add31 mul31 sub31 opp31 Logic.eq. +Proof. +exact (ring_theory_switch_eq _ _ _ _ _ _ _ _ _ Int31_canonic Int31ring.CyclicRing). +Qed. + +Lemma eqb31_eq : forall x y, eqb31 x y = true <-> x=y. +Proof. +unfold eqb31. intros x y. +generalize (Cyclic31.spec_compare x y). +destruct (x ?= y); intuition; subst; auto with zarith; try discriminate. +apply Int31_canonic; auto. +Qed. + +Lemma eqb31_correct : forall x y, eqb31 x y = true -> x=y. +Proof. now apply eqb31_eq. Qed. + +Add Ring Int31Ring : Int31Ring + (decidable eqb31_correct, + constants [Int31cst]). + +Section TestRing. +Let test : forall x y, 1 + x*y + x*x + 1 = 1*1 + 1 + y*x + 1*x*x. +intros. ring. +Qed. +End TestRing. + diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index 7c770e97..4f0f6c7c 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -6,13 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ZModulo.v 11033 2008-06-01 22:56:50Z letouzey $ *) +(* $Id$ *) -(** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ] +(** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ] as defined abstractly in CyclicAxioms. *) -(** Even if the construction provided here is not reused for building - the efficient arbitrary precision numbers, it provides a simple +(** Even if the construction provided here is not reused for building + the efficient arbitrary precision numbers, it provides a simple implementation of CyclicAxioms, hence ensuring its coherence. *) Set Implicit Arguments. @@ -24,7 +24,7 @@ Require Import BigNumPrelude. Require Import DoubleType. Require Import CyclicAxioms. -Open Local Scope Z_scope. +Local Open Scope Z_scope. Section ZModulo. @@ -56,9 +56,9 @@ Section ZModulo. destruct 1; auto. Qed. Let digits_gt_1 := spec_more_than_1_digit. - + Lemma wB_pos : wB > 0. - Proof. + Proof. unfold wB, base; auto with zarith. Qed. Hint Resolve wB_pos. @@ -79,7 +79,7 @@ Section ZModulo. auto. Qed. - Definition znz_of_pos x := + Definition znz_of_pos x := let (q,r) := Zdiv_eucl_POS x wB in (N_of_Z q, r). Lemma spec_of_pos : forall p, @@ -90,10 +90,10 @@ Section ZModulo. destruct (Zdiv_eucl_POS p wB); simpl; destruct 1. unfold znz_to_Z; rewrite Zmod_small; auto. assert (0 <= z). - replace z with (Zpos p / wB) by + replace z with (Zpos p / wB) by (symmetry; apply Zdiv_unique with z0; auto). apply Z_div_pos; auto with zarith. - replace (Z_of_N (N_of_Z z)) with z by + replace (Z_of_N (N_of_Z z)) with z by (destruct z; simpl; auto; elim H1; auto). rewrite Zmult_comm; auto. Qed. @@ -110,7 +110,7 @@ Section ZModulo. Definition znz_0 := 0. Definition znz_1 := 1. Definition znz_Bm1 := wB - 1. - + Lemma spec_0 : [|znz_0|] = 0. Proof. unfold znz_to_Z, znz_0. @@ -121,7 +121,7 @@ Section ZModulo. Proof. unfold znz_to_Z, znz_1. apply Zmod_small; split; auto with zarith. - unfold wB, base. + unfold wB, base. apply Zlt_trans with (Zpos digits); auto. apply Zpower2_lt_lin; auto with zarith. Qed. @@ -138,7 +138,7 @@ Section ZModulo. Definition znz_compare x y := Zcompare [|x|] [|y|]. - Lemma spec_compare : forall x y, + Lemma spec_compare : forall x y, match znz_compare x y with | Eq => [|x|] = [|y|] | Lt => [|x|] < [|y|] @@ -150,19 +150,19 @@ Section ZModulo. intros; apply Zcompare_Eq_eq; auto. Qed. - Definition znz_eq0 x := + Definition znz_eq0 x := match [|x|] with Z0 => true | _ => false end. - + Lemma spec_eq0 : forall x, znz_eq0 x = true -> [|x|] = 0. Proof. unfold znz_eq0; intros; now destruct [|x|]. Qed. - Definition znz_opp_c x := + Definition znz_opp_c x := if znz_eq0 x then C0 0 else C1 (- x). Definition znz_opp x := - x. Definition znz_opp_carry x := - x - 1. - + Lemma spec_opp_c : forall x, [-|znz_opp_c x|] = -[|x|]. Proof. intros; unfold znz_opp_c, znz_to_Z; auto. @@ -180,7 +180,7 @@ Section ZModulo. change ((- x) mod wB = (0 - (x mod wB)) mod wB). rewrite Zminus_mod_idemp_r; simpl; auto. Qed. - + Lemma spec_opp_carry : forall x, [|znz_opp_carry x|] = wB - [|x|] - 1. Proof. intros; unfold znz_opp_carry, znz_to_Z; auto. @@ -194,15 +194,15 @@ Section ZModulo. generalize (Z_mod_lt x wB wB_pos); omega. Qed. - Definition znz_succ_c x := - let y := Zsucc x in + Definition znz_succ_c x := + let y := Zsucc x in if znz_eq0 y then C1 0 else C0 y. - Definition znz_add_c x y := - let z := [|x|] + [|y|] in + Definition znz_add_c x y := + let z := [|x|] + [|y|] in if Z_lt_le_dec z wB then C0 z else C1 (z-wB). - Definition znz_add_carry_c x y := + Definition znz_add_carry_c x y := let z := [|x|]+[|y|]+1 in if Z_lt_le_dec z wB then C0 z else C1 (z-wB). @@ -210,7 +210,7 @@ Section ZModulo. Definition znz_add := Zplus. Definition znz_add_carry x y := x + y + 1. - Lemma Zmod_equal : + Lemma Zmod_equal : forall x y z, z>0 -> (x-y) mod z = 0 -> x mod z = y mod z. Proof. intros. @@ -225,12 +225,12 @@ Section ZModulo. Proof. intros; unfold znz_succ_c, znz_to_Z, Zsucc. case_eq (znz_eq0 (x+1)); intros; unfold interp_carry. - + rewrite Zmult_1_l. replace (wB + 0 mod wB) with wB by auto with zarith. symmetry; rewrite Zeq_plus_swap. assert ((x+1) mod wB = 0) by (apply spec_eq0; auto). - replace (wB-1) with ((wB-1) mod wB) by + replace (wB-1) with ((wB-1) mod wB) by (apply Zmod_small; generalize wB_pos; omega). rewrite <- Zminus_mod_idemp_l; rewrite Z_mod_same; simpl; auto. apply Zmod_equal; auto. @@ -289,15 +289,15 @@ Section ZModulo. rewrite Zplus_mod_idemp_l; auto. Qed. - Definition znz_pred_c x := + Definition znz_pred_c x := if znz_eq0 x then C1 (wB-1) else C0 (x-1). - Definition znz_sub_c x y := - let z := [|x|]-[|y|] in + Definition znz_sub_c x y := + let z := [|x|]-[|y|] in if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z. - Definition znz_sub_carry_c x y := - let z := [|x|]-[|y|]-1 in + Definition znz_sub_carry_c x y := + let z := [|x|]-[|y|]-1 in if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z. Definition znz_pred := Zpred. @@ -323,7 +323,7 @@ Section ZModulo. Proof. intros; unfold znz_sub_c, znz_to_Z, interp_carry. destruct Z_lt_le_dec. - replace ((wB + (x mod wB - y mod wB)) mod wB) with + replace ((wB + (x mod wB - y mod wB)) mod wB) with (wB + (x mod wB - y mod wB)). omega. symmetry; apply Zmod_small. @@ -337,7 +337,7 @@ Section ZModulo. Proof. intros; unfold znz_sub_carry_c, znz_to_Z, interp_carry. destruct Z_lt_le_dec. - replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with + replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with (wB + (x mod wB - y mod wB -1)). omega. symmetry; apply Zmod_small. @@ -358,7 +358,7 @@ Section ZModulo. intros; unfold znz_sub, znz_to_Z; apply Zminus_mod. Qed. - Lemma spec_sub_carry : + Lemma spec_sub_carry : forall x y, [|znz_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. Proof. intros; unfold znz_sub_carry, znz_to_Z. @@ -367,15 +367,15 @@ Section ZModulo. rewrite Zminus_mod_idemp_l. auto. Qed. - - Definition znz_mul_c x y := + + Definition znz_mul_c x y := let (h,l) := Zdiv_eucl ([|x|]*[|y|]) wB in if znz_eq0 h then if znz_eq0 l then W0 else WW h l else WW h l. Definition znz_mul := Zmult. Definition znz_square_c x := znz_mul_c x x. - + Lemma spec_mul_c : forall x y, [|| znz_mul_c x y ||] = [|x|] * [|y|]. Proof. intros; unfold znz_mul_c, zn2z_to_Z. @@ -426,7 +426,7 @@ Section ZModulo. destruct Zdiv_eucl as (q,r); destruct 1; intros. injection H1; clear H1; intros. assert ([|r|]=r). - apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; + apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; auto with zarith. assert ([|q|]=q). apply Zmod_small. @@ -453,7 +453,7 @@ Section ZModulo. Definition znz_mod x y := [|x|] mod [|y|]. Definition znz_mod_gt x y := [|x|] mod [|y|]. - + Lemma spec_mod : forall a b, 0 < [|b|] -> [|znz_mod a b|] = [|a|] mod [|b|]. Proof. @@ -469,7 +469,7 @@ Section ZModulo. Proof. intros; apply spec_mod; auto. Qed. - + Definition znz_gcd x y := Zgcd [|x|] [|y|]. Definition znz_gcd_gt x y := Zgcd [|x|] [|y|]. @@ -516,7 +516,7 @@ Section ZModulo. intros. apply spec_gcd; auto. Qed. - Definition znz_div21 a1 a2 b := + Definition znz_div21 a1 a2 b := Zdiv_eucl ([|a1|]*wB+[|a2|]) [|b|]. Lemma spec_div21 : forall a1 a2 b, @@ -537,7 +537,7 @@ Section ZModulo. destruct Zdiv_eucl as (q,r); destruct 1; intros. injection H4; clear H4; intros. assert ([|r|]=r). - apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; + apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; auto with zarith. assert ([|q|]=q). apply Zmod_small. @@ -546,7 +546,6 @@ Section ZModulo. apply Z_div_pos; auto with zarith. subst a; auto with zarith. apply Zdiv_lt_upper_bound; auto with zarith. - subst a; auto with zarith. subst a. replace (wB*[|b|]) with (([|b|]-1)*wB + wB) by ring. apply Zlt_le_trans with ([|a1|]*wB+wB); auto with zarith. @@ -577,7 +576,7 @@ Section ZModulo. apply Zmod_le; auto with zarith. Qed. - Definition znz_is_even x := + Definition znz_is_even x := if Z_eq_dec ([|x|] mod 2) 0 then true else false. Lemma spec_is_even : forall x, @@ -587,7 +586,7 @@ Section ZModulo. generalize (Z_mod_lt [|x|] 2); omega. Qed. - Definition znz_sqrt x := Zsqrt_plain [|x|]. + Definition znz_sqrt x := Zsqrt_plain [|x|]. Lemma spec_sqrt : forall x, [|znz_sqrt x|] ^ 2 <= [|x|] < ([|znz_sqrt x|] + 1) ^ 2. Proof. @@ -610,12 +609,12 @@ Section ZModulo. generalize wB_pos; auto with zarith. Qed. - Definition znz_sqrt2 x y := - let z := [|x|]*wB+[|y|] in - match z with + Definition znz_sqrt2 x y := + let z := [|x|]*wB+[|y|] in + match z with | Z0 => (0, C0 0) - | Zpos p => - let (s,r,_,_) := sqrtrempos p in + | Zpos p => + let (s,r,_,_) := sqrtrempos p in (s, if Z_lt_le_dec r wB then C0 r else C1 (r-wB)) | Zneg _ => (0, C0 0) end. @@ -652,7 +651,7 @@ Section ZModulo. rewrite Zpower_2; auto with zarith. replace [|r-wB|] with (r-wB) by (symmetry; apply Zmod_small; auto with zarith). rewrite Zpower_2; omega. - + assert (0<=Zneg p). rewrite Heqz; generalize wB_pos; auto with zarith. compute in H0; elim H0; auto. @@ -666,8 +665,8 @@ Section ZModulo. apply two_power_pos_correct. Qed. - Definition znz_head0 x := match [|x|] with - | Z0 => znz_zdigits + Definition znz_head0 x := match [|x|] with + | Z0 => znz_zdigits | Zpos p => znz_zdigits - log_inf p - 1 | _ => 0 end. @@ -696,7 +695,7 @@ Section ZModulo. change (Zpos x~0) with (2*(Zpos x)) in H. replace p with (Zsucc (p-1)) in H; auto with zarith. rewrite Zpower_Zsucc in H; auto with zarith. - + simpl; intros; destruct p; compute; auto with zarith. Qed. @@ -731,8 +730,8 @@ Section ZModulo. by ring. unfold wB, base, znz_zdigits; auto with zarith. apply Zmult_le_compat; auto with zarith. - - apply Zlt_le_trans + + apply Zlt_le_trans with (2^(znz_zdigits - log_inf p - 1)*(2^(Zsucc (log_inf p)))). apply Zmult_lt_compat_l; auto with zarith. rewrite <- Zpower_exp; auto with zarith. @@ -741,17 +740,17 @@ Section ZModulo. unfold wB, base, znz_zdigits; auto with zarith. Qed. - Fixpoint Ptail p := match p with + Fixpoint Ptail p := match p with | xO p => (Ptail p)+1 | _ => 0 - end. + end. Lemma Ptail_pos : forall p, 0 <= Ptail p. Proof. induction p; simpl; auto with zarith. Qed. Hint Resolve Ptail_pos. - + Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d. Proof. induction p; try (compute; auto; fail). @@ -776,7 +775,7 @@ Section ZModulo. Qed. Definition znz_tail0 x := - match [|x|] with + match [|x|] with | Z0 => znz_zdigits | Zpos p => Ptail p | Zneg _ => 0 @@ -789,7 +788,7 @@ Section ZModulo. apply spec_zdigits. Qed. - Lemma spec_tail0 : forall x, 0 < [|x|] -> + Lemma spec_tail0 : forall x, 0 < [|x|] -> exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|znz_tail0 x|]). Proof. intros; unfold znz_tail0. @@ -819,7 +818,7 @@ Section ZModulo. (** Let's now group everything in two records *) - Definition zmod_op := mk_znz_op + Definition zmod_op := mk_znz_op (znz_digits : positive) (znz_zdigits: znz) (znz_to_Z : znz -> Z) @@ -860,11 +859,11 @@ Section ZModulo. (znz_div_gt : znz -> znz -> znz * znz) (znz_div : znz -> znz -> znz * znz) - (znz_mod_gt : znz -> znz -> znz) - (znz_mod : znz -> znz -> znz) + (znz_mod_gt : znz -> znz -> znz) + (znz_mod : znz -> znz -> znz) (znz_gcd_gt : znz -> znz -> znz) - (znz_gcd : znz -> znz -> znz) + (znz_gcd : znz -> znz -> znz) (znz_add_mul_div : znz -> znz -> znz -> znz) (znz_pos_mod : znz -> znz -> znz) @@ -879,54 +878,54 @@ Section ZModulo. spec_more_than_1_digit spec_0 - spec_1 - spec_Bm1 - - spec_compare - spec_eq0 - - spec_opp_c - spec_opp - spec_opp_carry - - spec_succ_c - spec_add_c - spec_add_carry_c - spec_succ - spec_add - spec_add_carry - - spec_pred_c - spec_sub_c - spec_sub_carry_c - spec_pred - spec_sub - spec_sub_carry - - spec_mul_c - spec_mul - spec_square_c - - spec_div21 - spec_div_gt - spec_div - - spec_mod_gt - spec_mod - - spec_gcd_gt - spec_gcd - - spec_head00 - spec_head0 - spec_tail00 - spec_tail0 - - spec_add_mul_div - spec_pos_mod - - spec_is_even - spec_sqrt2 + spec_1 + spec_Bm1 + + spec_compare + spec_eq0 + + spec_opp_c + spec_opp + spec_opp_carry + + spec_succ_c + spec_add_c + spec_add_carry_c + spec_succ + spec_add + spec_add_carry + + spec_pred_c + spec_sub_c + spec_sub_carry_c + spec_pred + spec_sub + spec_sub_carry + + spec_mul_c + spec_mul + spec_square_c + + spec_div21 + spec_div_gt + spec_div + + spec_mod_gt + spec_mod + + spec_gcd_gt + spec_gcd + + spec_head00 + spec_head0 + spec_tail00 + spec_tail0 + + spec_add_mul_div + spec_pos_mod + + spec_is_even + spec_sqrt2 spec_sqrt. End ZModulo. @@ -935,7 +934,7 @@ End ZModulo. Module Type PositiveNotOne. Parameter p : positive. - Axiom not_one : p<> 1%positive. + Axiom not_one : p<> 1%positive. End PositiveNotOne. Module ZModuloCyclicType (P:PositiveNotOne) <: CyclicType. diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v index df941d90..5663408d 100644 --- a/theories/Numbers/Integer/Abstract/ZAdd.v +++ b/theories/Numbers/Integer/Abstract/ZAdd.v @@ -8,338 +8,286 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZAdd.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) Require Export ZBase. -Module ZAddPropFunct (Import ZAxiomsMod : ZAxiomsSig). -Module Export ZBasePropMod := ZBasePropFunct ZAxiomsMod. -Open Local Scope IntScope. +Module ZAddPropFunct (Import Z : ZAxiomsSig'). +Include ZBasePropFunct Z. -Theorem Zadd_wd : - forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> n1 + m1 == n2 + m2. -Proof NZadd_wd. +(** Theorems that are either not valid on N or have different proofs + on N and Z *) -Theorem Zadd_0_l : forall n : Z, 0 + n == n. -Proof NZadd_0_l. - -Theorem Zadd_succ_l : forall n m : Z, (S n) + m == S (n + m). -Proof NZadd_succ_l. - -Theorem Zsub_0_r : forall n : Z, n - 0 == n. -Proof NZsub_0_r. - -Theorem Zsub_succ_r : forall n m : Z, n - (S m) == P (n - m). -Proof NZsub_succ_r. - -Theorem Zopp_0 : - 0 == 0. -Proof Zopp_0. - -Theorem Zopp_succ : forall n : Z, - (S n) == P (- n). -Proof Zopp_succ. - -(* Theorems that are valid for both natural numbers and integers *) - -Theorem Zadd_0_r : forall n : Z, n + 0 == n. -Proof NZadd_0_r. - -Theorem Zadd_succ_r : forall n m : Z, n + S m == S (n + m). -Proof NZadd_succ_r. - -Theorem Zadd_comm : forall n m : Z, n + m == m + n. -Proof NZadd_comm. - -Theorem Zadd_assoc : forall n m p : Z, n + (m + p) == (n + m) + p. -Proof NZadd_assoc. - -Theorem Zadd_shuffle1 : forall n m p q : Z, (n + m) + (p + q) == (n + p) + (m + q). -Proof NZadd_shuffle1. - -Theorem Zadd_shuffle2 : forall n m p q : Z, (n + m) + (p + q) == (n + q) + (m + p). -Proof NZadd_shuffle2. - -Theorem Zadd_1_l : forall n : Z, 1 + n == S n. -Proof NZadd_1_l. - -Theorem Zadd_1_r : forall n : Z, n + 1 == S n. -Proof NZadd_1_r. - -Theorem Zadd_cancel_l : forall n m p : Z, p + n == p + m <-> n == m. -Proof NZadd_cancel_l. - -Theorem Zadd_cancel_r : forall n m p : Z, n + p == m + p <-> n == m. -Proof NZadd_cancel_r. - -(* Theorems that are either not valid on N or have different proofs on N and Z *) - -Theorem Zadd_pred_l : forall n m : Z, P n + m == P (n + m). +Theorem add_pred_l : forall n m, P n + m == P (n + m). Proof. intros n m. -rewrite <- (Zsucc_pred n) at 2. -rewrite Zadd_succ_l. now rewrite Zpred_succ. +rewrite <- (succ_pred n) at 2. +rewrite add_succ_l. now rewrite pred_succ. Qed. -Theorem Zadd_pred_r : forall n m : Z, n + P m == P (n + m). +Theorem add_pred_r : forall n m, n + P m == P (n + m). Proof. -intros n m; rewrite (Zadd_comm n (P m)), (Zadd_comm n m); -apply Zadd_pred_l. +intros n m; rewrite (add_comm n (P m)), (add_comm n m); +apply add_pred_l. Qed. -Theorem Zadd_opp_r : forall n m : Z, n + (- m) == n - m. +Theorem add_opp_r : forall n m, n + (- m) == n - m. Proof. -NZinduct m. -rewrite Zopp_0; rewrite Zsub_0_r; now rewrite Zadd_0_r. -intro m. rewrite Zopp_succ, Zsub_succ_r, Zadd_pred_r; now rewrite Zpred_inj_wd. +nzinduct m. +rewrite opp_0; rewrite sub_0_r; now rewrite add_0_r. +intro m. rewrite opp_succ, sub_succ_r, add_pred_r; now rewrite pred_inj_wd. Qed. -Theorem Zsub_0_l : forall n : Z, 0 - n == - n. +Theorem sub_0_l : forall n, 0 - n == - n. Proof. -intro n; rewrite <- Zadd_opp_r; now rewrite Zadd_0_l. +intro n; rewrite <- add_opp_r; now rewrite add_0_l. Qed. -Theorem Zsub_succ_l : forall n m : Z, S n - m == S (n - m). +Theorem sub_succ_l : forall n m, S n - m == S (n - m). Proof. -intros n m; do 2 rewrite <- Zadd_opp_r; now rewrite Zadd_succ_l. +intros n m; do 2 rewrite <- add_opp_r; now rewrite add_succ_l. Qed. -Theorem Zsub_pred_l : forall n m : Z, P n - m == P (n - m). +Theorem sub_pred_l : forall n m, P n - m == P (n - m). Proof. -intros n m. rewrite <- (Zsucc_pred n) at 2. -rewrite Zsub_succ_l; now rewrite Zpred_succ. +intros n m. rewrite <- (succ_pred n) at 2. +rewrite sub_succ_l; now rewrite pred_succ. Qed. -Theorem Zsub_pred_r : forall n m : Z, n - (P m) == S (n - m). +Theorem sub_pred_r : forall n m, n - (P m) == S (n - m). Proof. -intros n m. rewrite <- (Zsucc_pred m) at 2. -rewrite Zsub_succ_r; now rewrite Zsucc_pred. +intros n m. rewrite <- (succ_pred m) at 2. +rewrite sub_succ_r; now rewrite succ_pred. Qed. -Theorem Zopp_pred : forall n : Z, - (P n) == S (- n). +Theorem opp_pred : forall n, - (P n) == S (- n). Proof. -intro n. rewrite <- (Zsucc_pred n) at 2. -rewrite Zopp_succ. now rewrite Zsucc_pred. +intro n. rewrite <- (succ_pred n) at 2. +rewrite opp_succ. now rewrite succ_pred. Qed. -Theorem Zsub_diag : forall n : Z, n - n == 0. +Theorem sub_diag : forall n, n - n == 0. Proof. -NZinduct n. -now rewrite Zsub_0_r. -intro n. rewrite Zsub_succ_r, Zsub_succ_l; now rewrite Zpred_succ. +nzinduct n. +now rewrite sub_0_r. +intro n. rewrite sub_succ_r, sub_succ_l; now rewrite pred_succ. Qed. -Theorem Zadd_opp_diag_l : forall n : Z, - n + n == 0. +Theorem add_opp_diag_l : forall n, - n + n == 0. Proof. -intro n; now rewrite Zadd_comm, Zadd_opp_r, Zsub_diag. +intro n; now rewrite add_comm, add_opp_r, sub_diag. Qed. -Theorem Zadd_opp_diag_r : forall n : Z, n + (- n) == 0. +Theorem add_opp_diag_r : forall n, n + (- n) == 0. Proof. -intro n; rewrite Zadd_comm; apply Zadd_opp_diag_l. +intro n; rewrite add_comm; apply add_opp_diag_l. Qed. -Theorem Zadd_opp_l : forall n m : Z, - m + n == n - m. +Theorem add_opp_l : forall n m, - m + n == n - m. Proof. -intros n m; rewrite <- Zadd_opp_r; now rewrite Zadd_comm. +intros n m; rewrite <- add_opp_r; now rewrite add_comm. Qed. -Theorem Zadd_sub_assoc : forall n m p : Z, n + (m - p) == (n + m) - p. +Theorem add_sub_assoc : forall n m p, n + (m - p) == (n + m) - p. Proof. -intros n m p; do 2 rewrite <- Zadd_opp_r; now rewrite Zadd_assoc. +intros n m p; do 2 rewrite <- add_opp_r; now rewrite add_assoc. Qed. -Theorem Zopp_involutive : forall n : Z, - (- n) == n. +Theorem opp_involutive : forall n, - (- n) == n. Proof. -NZinduct n. -now do 2 rewrite Zopp_0. -intro n. rewrite Zopp_succ, Zopp_pred; now rewrite Zsucc_inj_wd. +nzinduct n. +now do 2 rewrite opp_0. +intro n. rewrite opp_succ, opp_pred; now rewrite succ_inj_wd. Qed. -Theorem Zopp_add_distr : forall n m : Z, - (n + m) == - n + (- m). +Theorem opp_add_distr : forall n m, - (n + m) == - n + (- m). Proof. -intros n m; NZinduct n. -rewrite Zopp_0; now do 2 rewrite Zadd_0_l. -intro n. rewrite Zadd_succ_l; do 2 rewrite Zopp_succ; rewrite Zadd_pred_l. -now rewrite Zpred_inj_wd. +intros n m; nzinduct n. +rewrite opp_0; now do 2 rewrite add_0_l. +intro n. rewrite add_succ_l; do 2 rewrite opp_succ; rewrite add_pred_l. +now rewrite pred_inj_wd. Qed. -Theorem Zopp_sub_distr : forall n m : Z, - (n - m) == - n + m. +Theorem opp_sub_distr : forall n m, - (n - m) == - n + m. Proof. -intros n m; rewrite <- Zadd_opp_r, Zopp_add_distr. -now rewrite Zopp_involutive. +intros n m; rewrite <- add_opp_r, opp_add_distr. +now rewrite opp_involutive. Qed. -Theorem Zopp_inj : forall n m : Z, - n == - m -> n == m. +Theorem opp_inj : forall n m, - n == - m -> n == m. Proof. -intros n m H. apply Zopp_wd in H. now do 2 rewrite Zopp_involutive in H. +intros n m H. apply opp_wd in H. now do 2 rewrite opp_involutive in H. Qed. -Theorem Zopp_inj_wd : forall n m : Z, - n == - m <-> n == m. +Theorem opp_inj_wd : forall n m, - n == - m <-> n == m. Proof. -intros n m; split; [apply Zopp_inj | apply Zopp_wd]. +intros n m; split; [apply opp_inj | apply opp_wd]. Qed. -Theorem Zeq_opp_l : forall n m : Z, - n == m <-> n == - m. +Theorem eq_opp_l : forall n m, - n == m <-> n == - m. Proof. -intros n m. now rewrite <- (Zopp_inj_wd (- n) m), Zopp_involutive. +intros n m. now rewrite <- (opp_inj_wd (- n) m), opp_involutive. Qed. -Theorem Zeq_opp_r : forall n m : Z, n == - m <-> - n == m. +Theorem eq_opp_r : forall n m, n == - m <-> - n == m. Proof. -symmetry; apply Zeq_opp_l. +symmetry; apply eq_opp_l. Qed. -Theorem Zsub_add_distr : forall n m p : Z, n - (m + p) == (n - m) - p. +Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p. Proof. -intros n m p; rewrite <- Zadd_opp_r, Zopp_add_distr, Zadd_assoc. -now do 2 rewrite Zadd_opp_r. +intros n m p; rewrite <- add_opp_r, opp_add_distr, add_assoc. +now do 2 rewrite add_opp_r. Qed. -Theorem Zsub_sub_distr : forall n m p : Z, n - (m - p) == (n - m) + p. +Theorem sub_sub_distr : forall n m p, n - (m - p) == (n - m) + p. Proof. -intros n m p; rewrite <- Zadd_opp_r, Zopp_sub_distr, Zadd_assoc. -now rewrite Zadd_opp_r. +intros n m p; rewrite <- add_opp_r, opp_sub_distr, add_assoc. +now rewrite add_opp_r. Qed. -Theorem sub_opp_l : forall n m : Z, - n - m == - m - n. +Theorem sub_opp_l : forall n m, - n - m == - m - n. Proof. -intros n m. do 2 rewrite <- Zadd_opp_r. now rewrite Zadd_comm. +intros n m. do 2 rewrite <- add_opp_r. now rewrite add_comm. Qed. -Theorem Zsub_opp_r : forall n m : Z, n - (- m) == n + m. +Theorem sub_opp_r : forall n m, n - (- m) == n + m. Proof. -intros n m; rewrite <- Zadd_opp_r; now rewrite Zopp_involutive. +intros n m; rewrite <- add_opp_r; now rewrite opp_involutive. Qed. -Theorem Zadd_sub_swap : forall n m p : Z, n + m - p == n - p + m. +Theorem add_sub_swap : forall n m p, n + m - p == n - p + m. Proof. -intros n m p. rewrite <- Zadd_sub_assoc, <- (Zadd_opp_r n p), <- Zadd_assoc. -now rewrite Zadd_opp_l. +intros n m p. rewrite <- add_sub_assoc, <- (add_opp_r n p), <- add_assoc. +now rewrite add_opp_l. Qed. -Theorem Zsub_cancel_l : forall n m p : Z, n - m == n - p <-> m == p. +Theorem sub_cancel_l : forall n m p, n - m == n - p <-> m == p. Proof. -intros n m p. rewrite <- (Zadd_cancel_l (n - m) (n - p) (- n)). -do 2 rewrite Zadd_sub_assoc. rewrite Zadd_opp_diag_l; do 2 rewrite Zsub_0_l. -apply Zopp_inj_wd. +intros n m p. rewrite <- (add_cancel_l (n - m) (n - p) (- n)). +do 2 rewrite add_sub_assoc. rewrite add_opp_diag_l; do 2 rewrite sub_0_l. +apply opp_inj_wd. Qed. -Theorem Zsub_cancel_r : forall n m p : Z, n - p == m - p <-> n == m. +Theorem sub_cancel_r : forall n m p, n - p == m - p <-> n == m. Proof. intros n m p. -stepl (n - p + p == m - p + p) by apply Zadd_cancel_r. -now do 2 rewrite <- Zsub_sub_distr, Zsub_diag, Zsub_0_r. +stepl (n - p + p == m - p + p) by apply add_cancel_r. +now do 2 rewrite <- sub_sub_distr, sub_diag, sub_0_r. Qed. -(* The next several theorems are devoted to moving terms from one side of -an equation to the other. The name contains the operation in the original -equation (add or sub) and the indication whether the left or right term -is moved. *) +(** The next several theorems are devoted to moving terms from one + side of an equation to the other. The name contains the operation + in the original equation ([add] or [sub]) and the indication + whether the left or right term is moved. *) -Theorem Zadd_move_l : forall n m p : Z, n + m == p <-> m == p - n. +Theorem add_move_l : forall n m p, n + m == p <-> m == p - n. Proof. intros n m p. -stepl (n + m - n == p - n) by apply Zsub_cancel_r. -now rewrite Zadd_comm, <- Zadd_sub_assoc, Zsub_diag, Zadd_0_r. +stepl (n + m - n == p - n) by apply sub_cancel_r. +now rewrite add_comm, <- add_sub_assoc, sub_diag, add_0_r. Qed. -Theorem Zadd_move_r : forall n m p : Z, n + m == p <-> n == p - m. +Theorem add_move_r : forall n m p, n + m == p <-> n == p - m. Proof. -intros n m p; rewrite Zadd_comm; now apply Zadd_move_l. +intros n m p; rewrite add_comm; now apply add_move_l. Qed. -(* The two theorems above do not allow rewriting subformulas of the form -n - m == p to n == p + m since subtraction is in the right-hand side of -the equation. Hence the following two theorems. *) +(** The two theorems above do not allow rewriting subformulas of the + form [n - m == p] to [n == p + m] since subtraction is in the + right-hand side of the equation. Hence the following two + theorems. *) -Theorem Zsub_move_l : forall n m p : Z, n - m == p <-> - m == p - n. +Theorem sub_move_l : forall n m p, n - m == p <-> - m == p - n. Proof. -intros n m p; rewrite <- (Zadd_opp_r n m); apply Zadd_move_l. +intros n m p; rewrite <- (add_opp_r n m); apply add_move_l. Qed. -Theorem Zsub_move_r : forall n m p : Z, n - m == p <-> n == p + m. +Theorem sub_move_r : forall n m p, n - m == p <-> n == p + m. Proof. -intros n m p; rewrite <- (Zadd_opp_r n m). now rewrite Zadd_move_r, Zsub_opp_r. +intros n m p; rewrite <- (add_opp_r n m). now rewrite add_move_r, sub_opp_r. Qed. -Theorem Zadd_move_0_l : forall n m : Z, n + m == 0 <-> m == - n. +Theorem add_move_0_l : forall n m, n + m == 0 <-> m == - n. Proof. -intros n m; now rewrite Zadd_move_l, Zsub_0_l. +intros n m; now rewrite add_move_l, sub_0_l. Qed. -Theorem Zadd_move_0_r : forall n m : Z, n + m == 0 <-> n == - m. +Theorem add_move_0_r : forall n m, n + m == 0 <-> n == - m. Proof. -intros n m; now rewrite Zadd_move_r, Zsub_0_l. +intros n m; now rewrite add_move_r, sub_0_l. Qed. -Theorem Zsub_move_0_l : forall n m : Z, n - m == 0 <-> - m == - n. +Theorem sub_move_0_l : forall n m, n - m == 0 <-> - m == - n. Proof. -intros n m. now rewrite Zsub_move_l, Zsub_0_l. +intros n m. now rewrite sub_move_l, sub_0_l. Qed. -Theorem Zsub_move_0_r : forall n m : Z, n - m == 0 <-> n == m. +Theorem sub_move_0_r : forall n m, n - m == 0 <-> n == m. Proof. -intros n m. now rewrite Zsub_move_r, Zadd_0_l. +intros n m. now rewrite sub_move_r, add_0_l. Qed. -(* The following section is devoted to cancellation of like terms. The name -includes the first operator and the position of the term being canceled. *) +(** The following section is devoted to cancellation of like + terms. The name includes the first operator and the position of + the term being canceled. *) -Theorem Zadd_simpl_l : forall n m : Z, n + m - n == m. +Theorem add_simpl_l : forall n m, n + m - n == m. Proof. -intros; now rewrite Zadd_sub_swap, Zsub_diag, Zadd_0_l. +intros; now rewrite add_sub_swap, sub_diag, add_0_l. Qed. -Theorem Zadd_simpl_r : forall n m : Z, n + m - m == n. +Theorem add_simpl_r : forall n m, n + m - m == n. Proof. -intros; now rewrite <- Zadd_sub_assoc, Zsub_diag, Zadd_0_r. +intros; now rewrite <- add_sub_assoc, sub_diag, add_0_r. Qed. -Theorem Zsub_simpl_l : forall n m : Z, - n - m + n == - m. +Theorem sub_simpl_l : forall n m, - n - m + n == - m. Proof. -intros; now rewrite <- Zadd_sub_swap, Zadd_opp_diag_l, Zsub_0_l. +intros; now rewrite <- add_sub_swap, add_opp_diag_l, sub_0_l. Qed. -Theorem Zsub_simpl_r : forall n m : Z, n - m + m == n. +Theorem sub_simpl_r : forall n m, n - m + m == n. Proof. -intros; now rewrite <- Zsub_sub_distr, Zsub_diag, Zsub_0_r. +intros; now rewrite <- sub_sub_distr, sub_diag, sub_0_r. Qed. -(* Now we have two sums or differences; the name includes the two operators -and the position of the terms being canceled *) +(** Now we have two sums or differences; the name includes the two + operators and the position of the terms being canceled *) -Theorem Zadd_add_simpl_l_l : forall n m p : Z, (n + m) - (n + p) == m - p. +Theorem add_add_simpl_l_l : forall n m p, (n + m) - (n + p) == m - p. Proof. -intros n m p. now rewrite (Zadd_comm n m), <- Zadd_sub_assoc, -Zsub_add_distr, Zsub_diag, Zsub_0_l, Zadd_opp_r. +intros n m p. now rewrite (add_comm n m), <- add_sub_assoc, +sub_add_distr, sub_diag, sub_0_l, add_opp_r. Qed. -Theorem Zadd_add_simpl_l_r : forall n m p : Z, (n + m) - (p + n) == m - p. +Theorem add_add_simpl_l_r : forall n m p, (n + m) - (p + n) == m - p. Proof. -intros n m p. rewrite (Zadd_comm p n); apply Zadd_add_simpl_l_l. +intros n m p. rewrite (add_comm p n); apply add_add_simpl_l_l. Qed. -Theorem Zadd_add_simpl_r_l : forall n m p : Z, (n + m) - (m + p) == n - p. +Theorem add_add_simpl_r_l : forall n m p, (n + m) - (m + p) == n - p. Proof. -intros n m p. rewrite (Zadd_comm n m); apply Zadd_add_simpl_l_l. +intros n m p. rewrite (add_comm n m); apply add_add_simpl_l_l. Qed. -Theorem Zadd_add_simpl_r_r : forall n m p : Z, (n + m) - (p + m) == n - p. +Theorem add_add_simpl_r_r : forall n m p, (n + m) - (p + m) == n - p. Proof. -intros n m p. rewrite (Zadd_comm p m); apply Zadd_add_simpl_r_l. +intros n m p. rewrite (add_comm p m); apply add_add_simpl_r_l. Qed. -Theorem Zsub_add_simpl_r_l : forall n m p : Z, (n - m) + (m + p) == n + p. +Theorem sub_add_simpl_r_l : forall n m p, (n - m) + (m + p) == n + p. Proof. -intros n m p. now rewrite <- Zsub_sub_distr, Zsub_add_distr, Zsub_diag, -Zsub_0_l, Zsub_opp_r. +intros n m p. now rewrite <- sub_sub_distr, sub_add_distr, sub_diag, +sub_0_l, sub_opp_r. Qed. -Theorem Zsub_add_simpl_r_r : forall n m p : Z, (n - m) + (p + m) == n + p. +Theorem sub_add_simpl_r_r : forall n m p, (n - m) + (p + m) == n + p. Proof. -intros n m p. rewrite (Zadd_comm p m); apply Zsub_add_simpl_r_l. +intros n m p. rewrite (add_comm p m); apply sub_add_simpl_r_l. Qed. -(* Of course, there are many other variants *) +(** Of course, there are many other variants *) End ZAddPropFunct. diff --git a/theories/Numbers/Integer/Abstract/ZAddOrder.v b/theories/Numbers/Integer/Abstract/ZAddOrder.v index 101ea634..de12993f 100644 --- a/theories/Numbers/Integer/Abstract/ZAddOrder.v +++ b/theories/Numbers/Integer/Abstract/ZAddOrder.v @@ -8,365 +8,292 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZAddOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) Require Export ZLt. -Module ZAddOrderPropFunct (Import ZAxiomsMod : ZAxiomsSig). -Module Export ZOrderPropMod := ZOrderPropFunct ZAxiomsMod. -Open Local Scope IntScope. +Module ZAddOrderPropFunct (Import Z : ZAxiomsSig'). +Include ZOrderPropFunct Z. -(* Theorems that are true on both natural numbers and integers *) +(** Theorems that are either not valid on N or have different proofs + on N and Z *) -Theorem Zadd_lt_mono_l : forall n m p : Z, n < m <-> p + n < p + m. -Proof NZadd_lt_mono_l. - -Theorem Zadd_lt_mono_r : forall n m p : Z, n < m <-> n + p < m + p. -Proof NZadd_lt_mono_r. - -Theorem Zadd_lt_mono : forall n m p q : Z, n < m -> p < q -> n + p < m + q. -Proof NZadd_lt_mono. - -Theorem Zadd_le_mono_l : forall n m p : Z, n <= m <-> p + n <= p + m. -Proof NZadd_le_mono_l. - -Theorem Zadd_le_mono_r : forall n m p : Z, n <= m <-> n + p <= m + p. -Proof NZadd_le_mono_r. - -Theorem Zadd_le_mono : forall n m p q : Z, n <= m -> p <= q -> n + p <= m + q. -Proof NZadd_le_mono. - -Theorem Zadd_lt_le_mono : forall n m p q : Z, n < m -> p <= q -> n + p < m + q. -Proof NZadd_lt_le_mono. - -Theorem Zadd_le_lt_mono : forall n m p q : Z, n <= m -> p < q -> n + p < m + q. -Proof NZadd_le_lt_mono. - -Theorem Zadd_pos_pos : forall n m : Z, 0 < n -> 0 < m -> 0 < n + m. -Proof NZadd_pos_pos. - -Theorem Zadd_pos_nonneg : forall n m : Z, 0 < n -> 0 <= m -> 0 < n + m. -Proof NZadd_pos_nonneg. - -Theorem Zadd_nonneg_pos : forall n m : Z, 0 <= n -> 0 < m -> 0 < n + m. -Proof NZadd_nonneg_pos. - -Theorem Zadd_nonneg_nonneg : forall n m : Z, 0 <= n -> 0 <= m -> 0 <= n + m. -Proof NZadd_nonneg_nonneg. - -Theorem Zlt_add_pos_l : forall n m : Z, 0 < n -> m < n + m. -Proof NZlt_add_pos_l. - -Theorem Zlt_add_pos_r : forall n m : Z, 0 < n -> m < m + n. -Proof NZlt_add_pos_r. - -Theorem Zle_lt_add_lt : forall n m p q : Z, n <= m -> p + m < q + n -> p < q. -Proof NZle_lt_add_lt. - -Theorem Zlt_le_add_lt : forall n m p q : Z, n < m -> p + m <= q + n -> p < q. -Proof NZlt_le_add_lt. - -Theorem Zle_le_add_le : forall n m p q : Z, n <= m -> p + m <= q + n -> p <= q. -Proof NZle_le_add_le. - -Theorem Zadd_lt_cases : forall n m p q : Z, n + m < p + q -> n < p \/ m < q. -Proof NZadd_lt_cases. - -Theorem Zadd_le_cases : forall n m p q : Z, n + m <= p + q -> n <= p \/ m <= q. -Proof NZadd_le_cases. - -Theorem Zadd_neg_cases : forall n m : Z, n + m < 0 -> n < 0 \/ m < 0. -Proof NZadd_neg_cases. - -Theorem Zadd_pos_cases : forall n m : Z, 0 < n + m -> 0 < n \/ 0 < m. -Proof NZadd_pos_cases. - -Theorem Zadd_nonpos_cases : forall n m : Z, n + m <= 0 -> n <= 0 \/ m <= 0. -Proof NZadd_nonpos_cases. - -Theorem Zadd_nonneg_cases : forall n m : Z, 0 <= n + m -> 0 <= n \/ 0 <= m. -Proof NZadd_nonneg_cases. - -(* Theorems that are either not valid on N or have different proofs on N and Z *) - -Theorem Zadd_neg_neg : forall n m : Z, n < 0 -> m < 0 -> n + m < 0. +Theorem add_neg_neg : forall n m, n < 0 -> m < 0 -> n + m < 0. Proof. -intros n m H1 H2. rewrite <- (Zadd_0_l 0). now apply Zadd_lt_mono. +intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono. Qed. -Theorem Zadd_neg_nonpos : forall n m : Z, n < 0 -> m <= 0 -> n + m < 0. +Theorem add_neg_nonpos : forall n m, n < 0 -> m <= 0 -> n + m < 0. Proof. -intros n m H1 H2. rewrite <- (Zadd_0_l 0). now apply Zadd_lt_le_mono. +intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono. Qed. -Theorem Zadd_nonpos_neg : forall n m : Z, n <= 0 -> m < 0 -> n + m < 0. +Theorem add_nonpos_neg : forall n m, n <= 0 -> m < 0 -> n + m < 0. Proof. -intros n m H1 H2. rewrite <- (Zadd_0_l 0). now apply Zadd_le_lt_mono. +intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono. Qed. -Theorem Zadd_nonpos_nonpos : forall n m : Z, n <= 0 -> m <= 0 -> n + m <= 0. +Theorem add_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> n + m <= 0. Proof. -intros n m H1 H2. rewrite <- (Zadd_0_l 0). now apply Zadd_le_mono. +intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono. Qed. (** Sub and order *) -Theorem Zlt_0_sub : forall n m : Z, 0 < m - n <-> n < m. +Theorem lt_0_sub : forall n m, 0 < m - n <-> n < m. Proof. -intros n m. stepl (0 + n < m - n + n) by symmetry; apply Zadd_lt_mono_r. -rewrite Zadd_0_l; now rewrite Zsub_simpl_r. +intros n m. stepl (0 + n < m - n + n) by symmetry; apply add_lt_mono_r. +rewrite add_0_l; now rewrite sub_simpl_r. Qed. -Notation Zsub_pos := Zlt_0_sub (only parsing). +Notation sub_pos := lt_0_sub (only parsing). -Theorem Zle_0_sub : forall n m : Z, 0 <= m - n <-> n <= m. +Theorem le_0_sub : forall n m, 0 <= m - n <-> n <= m. Proof. -intros n m; stepl (0 + n <= m - n + n) by symmetry; apply Zadd_le_mono_r. -rewrite Zadd_0_l; now rewrite Zsub_simpl_r. +intros n m; stepl (0 + n <= m - n + n) by symmetry; apply add_le_mono_r. +rewrite add_0_l; now rewrite sub_simpl_r. Qed. -Notation Zsub_nonneg := Zle_0_sub (only parsing). +Notation sub_nonneg := le_0_sub (only parsing). -Theorem Zlt_sub_0 : forall n m : Z, n - m < 0 <-> n < m. +Theorem lt_sub_0 : forall n m, n - m < 0 <-> n < m. Proof. -intros n m. stepl (n - m + m < 0 + m) by symmetry; apply Zadd_lt_mono_r. -rewrite Zadd_0_l; now rewrite Zsub_simpl_r. +intros n m. stepl (n - m + m < 0 + m) by symmetry; apply add_lt_mono_r. +rewrite add_0_l; now rewrite sub_simpl_r. Qed. -Notation Zsub_neg := Zlt_sub_0 (only parsing). +Notation sub_neg := lt_sub_0 (only parsing). -Theorem Zle_sub_0 : forall n m : Z, n - m <= 0 <-> n <= m. +Theorem le_sub_0 : forall n m, n - m <= 0 <-> n <= m. Proof. -intros n m. stepl (n - m + m <= 0 + m) by symmetry; apply Zadd_le_mono_r. -rewrite Zadd_0_l; now rewrite Zsub_simpl_r. +intros n m. stepl (n - m + m <= 0 + m) by symmetry; apply add_le_mono_r. +rewrite add_0_l; now rewrite sub_simpl_r. Qed. -Notation Zsub_nonpos := Zle_sub_0 (only parsing). +Notation sub_nonpos := le_sub_0 (only parsing). -Theorem Zopp_lt_mono : forall n m : Z, n < m <-> - m < - n. +Theorem opp_lt_mono : forall n m, n < m <-> - m < - n. Proof. -intros n m. stepr (m + - m < m + - n) by symmetry; apply Zadd_lt_mono_l. -do 2 rewrite Zadd_opp_r. rewrite Zsub_diag. symmetry; apply Zlt_0_sub. +intros n m. stepr (m + - m < m + - n) by symmetry; apply add_lt_mono_l. +do 2 rewrite add_opp_r. rewrite sub_diag. symmetry; apply lt_0_sub. Qed. -Theorem Zopp_le_mono : forall n m : Z, n <= m <-> - m <= - n. +Theorem opp_le_mono : forall n m, n <= m <-> - m <= - n. Proof. -intros n m. stepr (m + - m <= m + - n) by symmetry; apply Zadd_le_mono_l. -do 2 rewrite Zadd_opp_r. rewrite Zsub_diag. symmetry; apply Zle_0_sub. +intros n m. stepr (m + - m <= m + - n) by symmetry; apply add_le_mono_l. +do 2 rewrite add_opp_r. rewrite sub_diag. symmetry; apply le_0_sub. Qed. -Theorem Zopp_pos_neg : forall n : Z, 0 < - n <-> n < 0. +Theorem opp_pos_neg : forall n, 0 < - n <-> n < 0. Proof. -intro n; rewrite (Zopp_lt_mono n 0); now rewrite Zopp_0. +intro n; rewrite (opp_lt_mono n 0); now rewrite opp_0. Qed. -Theorem Zopp_neg_pos : forall n : Z, - n < 0 <-> 0 < n. +Theorem opp_neg_pos : forall n, - n < 0 <-> 0 < n. Proof. -intro n. rewrite (Zopp_lt_mono 0 n). now rewrite Zopp_0. +intro n. rewrite (opp_lt_mono 0 n). now rewrite opp_0. Qed. -Theorem Zopp_nonneg_nonpos : forall n : Z, 0 <= - n <-> n <= 0. +Theorem opp_nonneg_nonpos : forall n, 0 <= - n <-> n <= 0. Proof. -intro n; rewrite (Zopp_le_mono n 0); now rewrite Zopp_0. +intro n; rewrite (opp_le_mono n 0); now rewrite opp_0. Qed. -Theorem Zopp_nonpos_nonneg : forall n : Z, - n <= 0 <-> 0 <= n. +Theorem opp_nonpos_nonneg : forall n, - n <= 0 <-> 0 <= n. Proof. -intro n. rewrite (Zopp_le_mono 0 n). now rewrite Zopp_0. +intro n. rewrite (opp_le_mono 0 n). now rewrite opp_0. Qed. -Theorem Zsub_lt_mono_l : forall n m p : Z, n < m <-> p - m < p - n. +Theorem sub_lt_mono_l : forall n m p, n < m <-> p - m < p - n. Proof. -intros n m p. do 2 rewrite <- Zadd_opp_r. rewrite <- Zadd_lt_mono_l. -apply Zopp_lt_mono. +intros n m p. do 2 rewrite <- add_opp_r. rewrite <- add_lt_mono_l. +apply opp_lt_mono. Qed. -Theorem Zsub_lt_mono_r : forall n m p : Z, n < m <-> n - p < m - p. +Theorem sub_lt_mono_r : forall n m p, n < m <-> n - p < m - p. Proof. -intros n m p; do 2 rewrite <- Zadd_opp_r; apply Zadd_lt_mono_r. +intros n m p; do 2 rewrite <- add_opp_r; apply add_lt_mono_r. Qed. -Theorem Zsub_lt_mono : forall n m p q : Z, n < m -> q < p -> n - p < m - q. +Theorem sub_lt_mono : forall n m p q, n < m -> q < p -> n - p < m - q. Proof. intros n m p q H1 H2. -apply NZlt_trans with (m - p); -[now apply -> Zsub_lt_mono_r | now apply -> Zsub_lt_mono_l]. +apply lt_trans with (m - p); +[now apply -> sub_lt_mono_r | now apply -> sub_lt_mono_l]. Qed. -Theorem Zsub_le_mono_l : forall n m p : Z, n <= m <-> p - m <= p - n. +Theorem sub_le_mono_l : forall n m p, n <= m <-> p - m <= p - n. Proof. -intros n m p; do 2 rewrite <- Zadd_opp_r; rewrite <- Zadd_le_mono_l; -apply Zopp_le_mono. +intros n m p; do 2 rewrite <- add_opp_r; rewrite <- add_le_mono_l; +apply opp_le_mono. Qed. -Theorem Zsub_le_mono_r : forall n m p : Z, n <= m <-> n - p <= m - p. +Theorem sub_le_mono_r : forall n m p, n <= m <-> n - p <= m - p. Proof. -intros n m p; do 2 rewrite <- Zadd_opp_r; apply Zadd_le_mono_r. +intros n m p; do 2 rewrite <- add_opp_r; apply add_le_mono_r. Qed. -Theorem Zsub_le_mono : forall n m p q : Z, n <= m -> q <= p -> n - p <= m - q. +Theorem sub_le_mono : forall n m p q, n <= m -> q <= p -> n - p <= m - q. Proof. intros n m p q H1 H2. -apply NZle_trans with (m - p); -[now apply -> Zsub_le_mono_r | now apply -> Zsub_le_mono_l]. +apply le_trans with (m - p); +[now apply -> sub_le_mono_r | now apply -> sub_le_mono_l]. Qed. -Theorem Zsub_lt_le_mono : forall n m p q : Z, n < m -> q <= p -> n - p < m - q. +Theorem sub_lt_le_mono : forall n m p q, n < m -> q <= p -> n - p < m - q. Proof. intros n m p q H1 H2. -apply NZlt_le_trans with (m - p); -[now apply -> Zsub_lt_mono_r | now apply -> Zsub_le_mono_l]. +apply lt_le_trans with (m - p); +[now apply -> sub_lt_mono_r | now apply -> sub_le_mono_l]. Qed. -Theorem Zsub_le_lt_mono : forall n m p q : Z, n <= m -> q < p -> n - p < m - q. +Theorem sub_le_lt_mono : forall n m p q, n <= m -> q < p -> n - p < m - q. Proof. intros n m p q H1 H2. -apply NZle_lt_trans with (m - p); -[now apply -> Zsub_le_mono_r | now apply -> Zsub_lt_mono_l]. +apply le_lt_trans with (m - p); +[now apply -> sub_le_mono_r | now apply -> sub_lt_mono_l]. Qed. -Theorem Zle_lt_sub_lt : forall n m p q : Z, n <= m -> p - n < q - m -> p < q. +Theorem le_lt_sub_lt : forall n m p q, n <= m -> p - n < q - m -> p < q. Proof. -intros n m p q H1 H2. apply (Zle_lt_add_lt (- m) (- n)); -[now apply -> Zopp_le_mono | now do 2 rewrite Zadd_opp_r]. +intros n m p q H1 H2. apply (le_lt_add_lt (- m) (- n)); +[now apply -> opp_le_mono | now do 2 rewrite add_opp_r]. Qed. -Theorem Zlt_le_sub_lt : forall n m p q : Z, n < m -> p - n <= q - m -> p < q. +Theorem lt_le_sub_lt : forall n m p q, n < m -> p - n <= q - m -> p < q. Proof. -intros n m p q H1 H2. apply (Zlt_le_add_lt (- m) (- n)); -[now apply -> Zopp_lt_mono | now do 2 rewrite Zadd_opp_r]. +intros n m p q H1 H2. apply (lt_le_add_lt (- m) (- n)); +[now apply -> opp_lt_mono | now do 2 rewrite add_opp_r]. Qed. -Theorem Zle_le_sub_lt : forall n m p q : Z, n <= m -> p - n <= q - m -> p <= q. +Theorem le_le_sub_lt : forall n m p q, n <= m -> p - n <= q - m -> p <= q. Proof. -intros n m p q H1 H2. apply (Zle_le_add_le (- m) (- n)); -[now apply -> Zopp_le_mono | now do 2 rewrite Zadd_opp_r]. +intros n m p q H1 H2. apply (le_le_add_le (- m) (- n)); +[now apply -> opp_le_mono | now do 2 rewrite add_opp_r]. Qed. -Theorem Zlt_add_lt_sub_r : forall n m p : Z, n + p < m <-> n < m - p. +Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p. Proof. -intros n m p. stepl (n + p - p < m - p) by symmetry; apply Zsub_lt_mono_r. -now rewrite Zadd_simpl_r. +intros n m p. stepl (n + p - p < m - p) by symmetry; apply sub_lt_mono_r. +now rewrite add_simpl_r. Qed. -Theorem Zle_add_le_sub_r : forall n m p : Z, n + p <= m <-> n <= m - p. +Theorem le_add_le_sub_r : forall n m p, n + p <= m <-> n <= m - p. Proof. -intros n m p. stepl (n + p - p <= m - p) by symmetry; apply Zsub_le_mono_r. -now rewrite Zadd_simpl_r. +intros n m p. stepl (n + p - p <= m - p) by symmetry; apply sub_le_mono_r. +now rewrite add_simpl_r. Qed. -Theorem Zlt_add_lt_sub_l : forall n m p : Z, n + p < m <-> p < m - n. +Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n. Proof. -intros n m p. rewrite Zadd_comm; apply Zlt_add_lt_sub_r. +intros n m p. rewrite add_comm; apply lt_add_lt_sub_r. Qed. -Theorem Zle_add_le_sub_l : forall n m p : Z, n + p <= m <-> p <= m - n. +Theorem le_add_le_sub_l : forall n m p, n + p <= m <-> p <= m - n. Proof. -intros n m p. rewrite Zadd_comm; apply Zle_add_le_sub_r. +intros n m p. rewrite add_comm; apply le_add_le_sub_r. Qed. -Theorem Zlt_sub_lt_add_r : forall n m p : Z, n - p < m <-> n < m + p. +Theorem lt_sub_lt_add_r : forall n m p, n - p < m <-> n < m + p. Proof. -intros n m p. stepl (n - p + p < m + p) by symmetry; apply Zadd_lt_mono_r. -now rewrite Zsub_simpl_r. +intros n m p. stepl (n - p + p < m + p) by symmetry; apply add_lt_mono_r. +now rewrite sub_simpl_r. Qed. -Theorem Zle_sub_le_add_r : forall n m p : Z, n - p <= m <-> n <= m + p. +Theorem le_sub_le_add_r : forall n m p, n - p <= m <-> n <= m + p. Proof. -intros n m p. stepl (n - p + p <= m + p) by symmetry; apply Zadd_le_mono_r. -now rewrite Zsub_simpl_r. +intros n m p. stepl (n - p + p <= m + p) by symmetry; apply add_le_mono_r. +now rewrite sub_simpl_r. Qed. -Theorem Zlt_sub_lt_add_l : forall n m p : Z, n - m < p <-> n < m + p. +Theorem lt_sub_lt_add_l : forall n m p, n - m < p <-> n < m + p. Proof. -intros n m p. rewrite Zadd_comm; apply Zlt_sub_lt_add_r. +intros n m p. rewrite add_comm; apply lt_sub_lt_add_r. Qed. -Theorem Zle_sub_le_add_l : forall n m p : Z, n - m <= p <-> n <= m + p. +Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p. Proof. -intros n m p. rewrite Zadd_comm; apply Zle_sub_le_add_r. +intros n m p. rewrite add_comm; apply le_sub_le_add_r. Qed. -Theorem Zlt_sub_lt_add : forall n m p q : Z, n - m < p - q <-> n + q < m + p. +Theorem lt_sub_lt_add : forall n m p q, n - m < p - q <-> n + q < m + p. Proof. -intros n m p q. rewrite Zlt_sub_lt_add_l. rewrite Zadd_sub_assoc. -now rewrite <- Zlt_add_lt_sub_r. +intros n m p q. rewrite lt_sub_lt_add_l. rewrite add_sub_assoc. +now rewrite <- lt_add_lt_sub_r. Qed. -Theorem Zle_sub_le_add : forall n m p q : Z, n - m <= p - q <-> n + q <= m + p. +Theorem le_sub_le_add : forall n m p q, n - m <= p - q <-> n + q <= m + p. Proof. -intros n m p q. rewrite Zle_sub_le_add_l. rewrite Zadd_sub_assoc. -now rewrite <- Zle_add_le_sub_r. +intros n m p q. rewrite le_sub_le_add_l. rewrite add_sub_assoc. +now rewrite <- le_add_le_sub_r. Qed. -Theorem Zlt_sub_pos : forall n m : Z, 0 < m <-> n - m < n. +Theorem lt_sub_pos : forall n m, 0 < m <-> n - m < n. Proof. -intros n m. stepr (n - m < n - 0) by now rewrite Zsub_0_r. apply Zsub_lt_mono_l. +intros n m. stepr (n - m < n - 0) by now rewrite sub_0_r. apply sub_lt_mono_l. Qed. -Theorem Zle_sub_nonneg : forall n m : Z, 0 <= m <-> n - m <= n. +Theorem le_sub_nonneg : forall n m, 0 <= m <-> n - m <= n. Proof. -intros n m. stepr (n - m <= n - 0) by now rewrite Zsub_0_r. apply Zsub_le_mono_l. +intros n m. stepr (n - m <= n - 0) by now rewrite sub_0_r. apply sub_le_mono_l. Qed. -Theorem Zsub_lt_cases : forall n m p q : Z, n - m < p - q -> n < m \/ q < p. +Theorem sub_lt_cases : forall n m p q, n - m < p - q -> n < m \/ q < p. Proof. -intros n m p q H. rewrite Zlt_sub_lt_add in H. now apply Zadd_lt_cases. +intros n m p q H. rewrite lt_sub_lt_add in H. now apply add_lt_cases. Qed. -Theorem Zsub_le_cases : forall n m p q : Z, n - m <= p - q -> n <= m \/ q <= p. +Theorem sub_le_cases : forall n m p q, n - m <= p - q -> n <= m \/ q <= p. Proof. -intros n m p q H. rewrite Zle_sub_le_add in H. now apply Zadd_le_cases. +intros n m p q H. rewrite le_sub_le_add in H. now apply add_le_cases. Qed. -Theorem Zsub_neg_cases : forall n m : Z, n - m < 0 -> n < 0 \/ 0 < m. +Theorem sub_neg_cases : forall n m, n - m < 0 -> n < 0 \/ 0 < m. Proof. -intros n m H; rewrite <- Zadd_opp_r in H. -setoid_replace (0 < m) with (- m < 0) using relation iff by (symmetry; apply Zopp_neg_pos). -now apply Zadd_neg_cases. +intros n m H; rewrite <- add_opp_r in H. +setoid_replace (0 < m) with (- m < 0) using relation iff by (symmetry; apply opp_neg_pos). +now apply add_neg_cases. Qed. -Theorem Zsub_pos_cases : forall n m : Z, 0 < n - m -> 0 < n \/ m < 0. +Theorem sub_pos_cases : forall n m, 0 < n - m -> 0 < n \/ m < 0. Proof. -intros n m H; rewrite <- Zadd_opp_r in H. -setoid_replace (m < 0) with (0 < - m) using relation iff by (symmetry; apply Zopp_pos_neg). -now apply Zadd_pos_cases. +intros n m H; rewrite <- add_opp_r in H. +setoid_replace (m < 0) with (0 < - m) using relation iff by (symmetry; apply opp_pos_neg). +now apply add_pos_cases. Qed. -Theorem Zsub_nonpos_cases : forall n m : Z, n - m <= 0 -> n <= 0 \/ 0 <= m. +Theorem sub_nonpos_cases : forall n m, n - m <= 0 -> n <= 0 \/ 0 <= m. Proof. -intros n m H; rewrite <- Zadd_opp_r in H. -setoid_replace (0 <= m) with (- m <= 0) using relation iff by (symmetry; apply Zopp_nonpos_nonneg). -now apply Zadd_nonpos_cases. +intros n m H; rewrite <- add_opp_r in H. +setoid_replace (0 <= m) with (- m <= 0) using relation iff by (symmetry; apply opp_nonpos_nonneg). +now apply add_nonpos_cases. Qed. -Theorem Zsub_nonneg_cases : forall n m : Z, 0 <= n - m -> 0 <= n \/ m <= 0. +Theorem sub_nonneg_cases : forall n m, 0 <= n - m -> 0 <= n \/ m <= 0. Proof. -intros n m H; rewrite <- Zadd_opp_r in H. -setoid_replace (m <= 0) with (0 <= - m) using relation iff by (symmetry; apply Zopp_nonneg_nonpos). -now apply Zadd_nonneg_cases. +intros n m H; rewrite <- add_opp_r in H. +setoid_replace (m <= 0) with (0 <= - m) using relation iff by (symmetry; apply opp_nonneg_nonpos). +now apply add_nonneg_cases. Qed. Section PosNeg. -Variable P : Z -> Prop. -Hypothesis P_wd : predicate_wd Zeq P. - -Add Morphism P with signature Zeq ==> iff as P_morph. Proof. exact P_wd. Qed. +Variable P : Z.t -> Prop. +Hypothesis P_wd : Proper (Z.eq ==> iff) P. -Theorem Z0_pos_neg : - P 0 -> (forall n : Z, 0 < n -> P n /\ P (- n)) -> forall n : Z, P n. +Theorem zero_pos_neg : + P 0 -> (forall n, 0 < n -> P n /\ P (- n)) -> forall n, P n. Proof. -intros H1 H2 n. destruct (Zlt_trichotomy n 0) as [H3 | [H3 | H3]]. -apply <- Zopp_pos_neg in H3. apply H2 in H3. destruct H3 as [_ H3]. -now rewrite Zopp_involutive in H3. +intros H1 H2 n. destruct (lt_trichotomy n 0) as [H3 | [H3 | H3]]. +apply <- opp_pos_neg in H3. apply H2 in H3. destruct H3 as [_ H3]. +now rewrite opp_involutive in H3. now rewrite H3. apply H2 in H3; now destruct H3. Qed. End PosNeg. -Ltac Z0_pos_neg n := induction_maker n ltac:(apply Z0_pos_neg). +Ltac zero_pos_neg n := induction_maker n ltac:(apply zero_pos_neg). End ZAddOrderPropFunct. diff --git a/theories/Numbers/Integer/Abstract/ZAxioms.v b/theories/Numbers/Integer/Abstract/ZAxioms.v index c4a4b6b8..9158a214 100644 --- a/theories/Numbers/Integer/Abstract/ZAxioms.v +++ b/theories/Numbers/Integer/Abstract/ZAxioms.v @@ -8,58 +8,31 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZAxioms.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) Require Export NZAxioms. Set Implicit Arguments. -Module Type ZAxiomsSig. -Declare Module Export NZOrdAxiomsMod : NZOrdAxiomsSig. +Module Type Opp (Import T:Typ). + Parameter Inline opp : t -> t. +End Opp. -Delimit Scope IntScope with Int. -Notation Z := NZ. -Notation Zeq := NZeq. -Notation Z0 := NZ0. -Notation Z1 := (NZsucc NZ0). -Notation S := NZsucc. -Notation P := NZpred. -Notation Zadd := NZadd. -Notation Zmul := NZmul. -Notation Zsub := NZsub. -Notation Zlt := NZlt. -Notation Zle := NZle. -Notation Zmin := NZmin. -Notation Zmax := NZmax. -Notation "x == y" := (NZeq x y) (at level 70) : IntScope. -Notation "x ~= y" := (~ NZeq x y) (at level 70) : IntScope. -Notation "0" := NZ0 : IntScope. -Notation "1" := (NZsucc NZ0) : IntScope. -Notation "x + y" := (NZadd x y) : IntScope. -Notation "x - y" := (NZsub x y) : IntScope. -Notation "x * y" := (NZmul x y) : IntScope. -Notation "x < y" := (NZlt x y) : IntScope. -Notation "x <= y" := (NZle x y) : IntScope. -Notation "x > y" := (NZlt y x) (only parsing) : IntScope. -Notation "x >= y" := (NZle y x) (only parsing) : IntScope. +Module Type OppNotation (T:Typ)(Import O : Opp T). + Notation "- x" := (opp x) (at level 35, right associativity). +End OppNotation. -Parameter Zopp : Z -> Z. +Module Type Opp' (T:Typ) := Opp T <+ OppNotation T. -(*Notation "- 1" := (Zopp 1) : IntScope. -Check (-1).*) +(** We obtain integers by postulating that every number has a predecessor. *) -Add Morphism Zopp with signature Zeq ==> Zeq as Zopp_wd. +Module Type IsOpp (Import Z : NZAxiomsSig')(Import O : Opp' Z). + Declare Instance opp_wd : Proper (eq==>eq) opp. + Axiom succ_pred : forall n, S (P n) == n. + Axiom opp_0 : - 0 == 0. + Axiom opp_succ : forall n, - (S n) == P (- n). +End IsOpp. -Notation "- x" := (Zopp x) (at level 35, right associativity) : IntScope. -Notation "- 1" := (Zopp (NZsucc NZ0)) : IntScope. - -Open Local Scope IntScope. - -(* Integers are obtained by postulating that every number has a predecessor *) -Axiom Zsucc_pred : forall n : Z, S (P n) == n. - -Axiom Zopp_0 : - 0 == 0. -Axiom Zopp_succ : forall n : Z, - (S n) == P (- n). - -End ZAxiomsSig. +Module Type ZAxiomsSig := NZOrdAxiomsSig <+ Opp <+ IsOpp. +Module Type ZAxiomsSig' := NZOrdAxiomsSig' <+ Opp' <+ IsOpp. diff --git a/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v index 0f71f2cc..44bb02ec 100644 --- a/theories/Numbers/Integer/Abstract/ZBase.v +++ b/theories/Numbers/Integer/Abstract/ZBase.v @@ -8,78 +8,25 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZBase.v 11674 2008-12-12 19:48:40Z letouzey $ i*) +(*i $Id$ i*) Require Export Decidable. Require Export ZAxioms. -Require Import NZMulOrder. +Require Import NZProperties. -Module ZBasePropFunct (Import ZAxiomsMod : ZAxiomsSig). - -(* Note: writing "Export" instead of "Import" on the previous line leads to -some warnings about hiding repeated declarations and results in the loss of -notations in Zadd and later *) - -Open Local Scope IntScope. - -Module Export NZMulOrderMod := NZMulOrderPropFunct NZOrdAxiomsMod. - -Theorem Zsucc_wd : forall n1 n2 : Z, n1 == n2 -> S n1 == S n2. -Proof NZsucc_wd. - -Theorem Zpred_wd : forall n1 n2 : Z, n1 == n2 -> P n1 == P n2. -Proof NZpred_wd. - -Theorem Zpred_succ : forall n : Z, P (S n) == n. -Proof NZpred_succ. - -Theorem Zeq_refl : forall n : Z, n == n. -Proof (proj1 NZeq_equiv). - -Theorem Zeq_sym : forall n m : Z, n == m -> m == n. -Proof (proj2 (proj2 NZeq_equiv)). - -Theorem Zeq_trans : forall n m p : Z, n == m -> m == p -> n == p. -Proof (proj1 (proj2 NZeq_equiv)). - -Theorem Zneq_sym : forall n m : Z, n ~= m -> m ~= n. -Proof NZneq_sym. - -Theorem Zsucc_inj : forall n1 n2 : Z, S n1 == S n2 -> n1 == n2. -Proof NZsucc_inj. - -Theorem Zsucc_inj_wd : forall n1 n2 : Z, S n1 == S n2 <-> n1 == n2. -Proof NZsucc_inj_wd. - -Theorem Zsucc_inj_wd_neg : forall n m : Z, S n ~= S m <-> n ~= m. -Proof NZsucc_inj_wd_neg. - -(* Decidability and stability of equality was proved only in NZOrder, but -since it does not mention order, we'll put it here *) - -Theorem Zeq_dec : forall n m : Z, decidable (n == m). -Proof NZeq_dec. - -Theorem Zeq_dne : forall n m : Z, ~ ~ n == m <-> n == m. -Proof NZeq_dne. - -Theorem Zcentral_induction : -forall A : Z -> Prop, predicate_wd Zeq A -> - forall z : Z, A z -> - (forall n : Z, A n <-> A (S n)) -> - forall n : Z, A n. -Proof NZcentral_induction. +Module ZBasePropFunct (Import Z : ZAxiomsSig'). +Include NZPropFunct Z. (* Theorems that are true for integers but not for natural numbers *) -Theorem Zpred_inj : forall n m : Z, P n == P m -> n == m. +Theorem pred_inj : forall n m, P n == P m -> n == m. Proof. -intros n m H. apply NZsucc_wd in H. now do 2 rewrite Zsucc_pred in H. +intros n m H. apply succ_wd in H. now do 2 rewrite succ_pred in H. Qed. -Theorem Zpred_inj_wd : forall n1 n2 : Z, P n1 == P n2 <-> n1 == n2. +Theorem pred_inj_wd : forall n1 n2, P n1 == P n2 <-> n1 == n2. Proof. -intros n1 n2; split; [apply Zpred_inj | apply NZpred_wd]. +intros n1 n2; split; [apply pred_inj | apply pred_wd]. Qed. End ZBasePropFunct. diff --git a/theories/Numbers/Integer/Abstract/ZDivEucl.v b/theories/Numbers/Integer/Abstract/ZDivEucl.v new file mode 100644 index 00000000..bcd16fec --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZDivEucl.v @@ -0,0 +1,605 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 0 -> exists b q, a = b*q+r /\ 0 < r < |b| ] + + The outcome of the modulo function is hence always positive. + This corresponds to convention "E" in the following paper: + + R. Boute, "The Euclidean definition of the functions div and mod", + ACM Transactions on Programming Languages and Systems, + Vol. 14, No.2, pp. 127-144, April 1992. + + See files [ZDivTrunc] and [ZDivFloor] for others conventions. +*) + +Require Import ZAxioms ZProperties NZDiv. + +Module Type ZDivSpecific (Import Z : ZAxiomsExtSig')(Import DM : DivMod' Z). + Axiom mod_always_pos : forall a b, 0 <= a mod b < abs b. +End ZDivSpecific. + +Module Type ZDiv (Z:ZAxiomsExtSig) + := DivMod Z <+ NZDivCommon Z <+ ZDivSpecific Z. + +Module Type ZDivSig := ZAxiomsExtSig <+ ZDiv. +Module Type ZDivSig' := ZAxiomsExtSig' <+ ZDiv <+ DivModNotation. + +Module ZDivPropFunct (Import Z : ZDivSig')(Import ZP : ZPropSig Z). + +(** We benefit from what already exists for NZ *) + + Module ZD <: NZDiv Z. + Definition div := div. + Definition modulo := modulo. + Definition div_wd := div_wd. + Definition mod_wd := mod_wd. + Definition div_mod := div_mod. + Lemma mod_bound : forall a b, 0<=a -> 0 0 <= a mod b < b. + Proof. + intros. rewrite <- (abs_eq b) at 3 by now apply lt_le_incl. + apply mod_always_pos. + Qed. + End ZD. + Module Import NZDivP := NZDivPropFunct Z ZP ZD. + +(** Another formulation of the main equation *) + +Lemma mod_eq : + forall a b, b~=0 -> a mod b == a - b*(a/b). +Proof. +intros. +rewrite <- add_move_l. +symmetry. now apply div_mod. +Qed. + +Ltac pos_or_neg a := + let LT := fresh "LT" in + let LE := fresh "LE" in + destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. + +(** Uniqueness theorems *) + +Theorem div_mod_unique : forall b q1 q2 r1 r2 : t, + 0<=r1 0<=r2 + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. +Proof. +intros b q1 q2 r1 r2 Hr1 Hr2 EQ. +pos_or_neg b. +rewrite abs_eq in * by trivial. +apply div_mod_unique with b; trivial. +rewrite abs_neq' in * by auto using lt_le_incl. +rewrite eq_sym_iff. apply div_mod_unique with (-b); trivial. +rewrite 2 mul_opp_l. +rewrite add_move_l, sub_opp_r. +rewrite <-add_assoc. +symmetry. rewrite add_move_l, sub_opp_r. +now rewrite (add_comm r2), (add_comm r1). +Qed. + +Theorem div_unique: + forall a b q r, 0<=r a == b*q + r -> q == a/b. +Proof. +intros a b q r Hr EQ. +assert (Hb : b~=0). + pos_or_neg b. + rewrite abs_eq in Hr; intuition; order. + rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order. +destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. +now apply mod_always_pos. +now rewrite <- div_mod. +Qed. + +Theorem mod_unique: + forall a b q r, 0<=r a == b*q + r -> r == a mod b. +Proof. +intros a b q r Hr EQ. +assert (Hb : b~=0). + pos_or_neg b. + rewrite abs_eq in Hr; intuition; order. + rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order. +destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. +now apply mod_always_pos. +now rewrite <- div_mod. +Qed. + +(** Sign rules *) + +Lemma div_opp_r : forall a b, b~=0 -> a/(-b) == -(a/b). +Proof. +intros. symmetry. +apply div_unique with (a mod b). +rewrite abs_opp; apply mod_always_pos. +rewrite mul_opp_opp; now apply div_mod. +Qed. + +Lemma mod_opp_r : forall a b, b~=0 -> a mod (-b) == a mod b. +Proof. +intros. symmetry. +apply mod_unique with (-(a/b)). +rewrite abs_opp; apply mod_always_pos. +rewrite mul_opp_opp; now apply div_mod. +Qed. + +Lemma div_opp_l_z : forall a b, b~=0 -> a mod b == 0 -> + (-a)/b == -(a/b). +Proof. +intros a b Hb Hab. symmetry. +apply div_unique with (-(a mod b)). +rewrite Hab, opp_0. split; [order|]. +pos_or_neg b; [rewrite abs_eq | rewrite abs_neq']; order. +now rewrite mul_opp_r, <-opp_add_distr, <-div_mod. +Qed. + +Lemma div_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 -> + (-a)/b == -(a/b)-sgn b. +Proof. +intros a b Hb Hab. symmetry. +apply div_unique with (abs b -(a mod b)). +rewrite lt_sub_lt_add_l. +rewrite <- le_add_le_sub_l. nzsimpl. +rewrite <- (add_0_l (abs b)) at 2. +rewrite <- add_lt_mono_r. +destruct (mod_always_pos a b); intuition order. +rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r. +rewrite sgn_abs. +rewrite add_shuffle2, add_opp_diag_l; nzsimpl. +rewrite <-opp_add_distr, <-div_mod; order. +Qed. + +Lemma mod_opp_l_z : forall a b, b~=0 -> a mod b == 0 -> + (-a) mod b == 0. +Proof. +intros a b Hb Hab. symmetry. +apply mod_unique with (-(a/b)). +split; [order|now rewrite abs_pos]. +now rewrite <-opp_0, <-Hab, mul_opp_r, <-opp_add_distr, <-div_mod. +Qed. + +Lemma mod_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 -> + (-a) mod b == abs b - (a mod b). +Proof. +intros a b Hb Hab. symmetry. +apply mod_unique with (-(a/b)-sgn b). +rewrite lt_sub_lt_add_l. +rewrite <- le_add_le_sub_l. nzsimpl. +rewrite <- (add_0_l (abs b)) at 2. +rewrite <- add_lt_mono_r. +destruct (mod_always_pos a b); intuition order. +rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r. +rewrite sgn_abs. +rewrite add_shuffle2, add_opp_diag_l; nzsimpl. +rewrite <-opp_add_distr, <-div_mod; order. +Qed. + +Lemma div_opp_opp_z : forall a b, b~=0 -> a mod b == 0 -> + (-a)/(-b) == a/b. +Proof. +intros. now rewrite div_opp_r, div_opp_l_z, opp_involutive. +Qed. + +Lemma div_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 -> + (-a)/(-b) == a/b + sgn(b). +Proof. +intros. rewrite div_opp_r, div_opp_l_nz by trivial. +now rewrite opp_sub_distr, opp_involutive. +Qed. + +Lemma mod_opp_opp_z : forall a b, b~=0 -> a mod b == 0 -> + (-a) mod (-b) == 0. +Proof. +intros. now rewrite mod_opp_r, mod_opp_l_z. +Qed. + +Lemma mod_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 -> + (-a) mod (-b) == abs b - a mod b. +Proof. +intros. now rewrite mod_opp_r, mod_opp_l_nz. +Qed. + +(** A division by itself returns 1 *) + +Lemma div_same : forall a, a~=0 -> a/a == 1. +Proof. +intros. symmetry. apply div_unique with 0. +split; [order|now rewrite abs_pos]. +now nzsimpl. +Qed. + +Lemma mod_same : forall a, a~=0 -> a mod a == 0. +Proof. +intros. +rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag. +Qed. + +(** A division of a small number by a bigger one yields zero. *) + +Theorem div_small: forall a b, 0<=a a/b == 0. +Proof. exact div_small. Qed. + +(** Same situation, in term of modulo: *) + +Theorem mod_small: forall a b, 0<=a a mod b == a. +Proof. exact mod_small. Qed. + +(** * Basic values of divisions and modulo. *) + +Lemma div_0_l: forall a, a~=0 -> 0/a == 0. +Proof. +intros. pos_or_neg a. apply div_0_l; order. +apply opp_inj. rewrite <- div_opp_r, opp_0 by trivial. now apply div_0_l. +Qed. + +Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. +Proof. +intros; rewrite mod_eq, div_0_l; now nzsimpl. +Qed. + +Lemma div_1_r: forall a, a/1 == a. +Proof. +intros. symmetry. apply div_unique with 0. +assert (H:=lt_0_1); rewrite abs_pos; intuition; order. +now nzsimpl. +Qed. + +Lemma mod_1_r: forall a, a mod 1 == 0. +Proof. +intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag. +apply neq_sym, lt_neq; apply lt_0_1. +Qed. + +Lemma div_1_l: forall a, 1 1/a == 0. +Proof. exact div_1_l. Qed. + +Lemma mod_1_l: forall a, 1 1 mod a == 1. +Proof. exact mod_1_l. Qed. + +Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. +Proof. +intros. symmetry. apply div_unique with 0. +split; [order|now rewrite abs_pos]. +nzsimpl; apply mul_comm. +Qed. + +Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. +Proof. +intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag. +Qed. + +(** * Order results about mod and div *) + +(** A modulo cannot grow beyond its starting point. *) + +Theorem mod_le: forall a b, 0<=a -> b~=0 -> a mod b <= a. +Proof. +intros. pos_or_neg b. apply mod_le; order. +rewrite <- mod_opp_r by trivial. apply mod_le; order. +Qed. + +Theorem div_pos : forall a b, 0<=a -> 0 0<= a/b. +Proof. exact div_pos. Qed. + +Lemma div_str_pos : forall a b, 0 0 < a/b. +Proof. exact div_str_pos. Qed. + +Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a (a mod b == a <-> 0<=a 1 a/b < a. +Proof. exact div_lt. Qed. + +(** [le] is compatible with a positive division. *) + +Lemma div_le_mono : forall a b c, 0 a<=b -> a/c <= b/c. +Proof. +intros a b c Hc Hab. +rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; + [|rewrite EQ; order]. +rewrite <- lt_succ_r. +rewrite (mul_lt_mono_pos_l c) by order. +nzsimpl. +rewrite (add_lt_mono_r _ _ (a mod c)). +rewrite <- div_mod by order. +apply lt_le_trans with b; trivial. +rewrite (div_mod b c) at 1 by order. +rewrite <- add_assoc, <- add_le_mono_l. +apply le_trans with (c+0). +nzsimpl; destruct (mod_always_pos b c); try order. +rewrite abs_eq in *; order. +rewrite <- add_le_mono_l. destruct (mod_always_pos a c); order. +Qed. + +(** In this convention, [div] performs Rounding-Toward-Bottom + when divisor is positive, and Rounding-Toward-Top otherwise. + + Since we cannot speak of rational values here, we express this + fact by multiplying back by [b], and this leads to a nice + unique statement. +*) + +Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a. +Proof. +intros. +rewrite (div_mod a b) at 2; trivial. +rewrite <- (add_0_r (b*(a/b))) at 1. +rewrite <- add_le_mono_l. +now destruct (mod_always_pos a b). +Qed. + +(** Giving a reversed bound is slightly more complex *) + +Lemma mul_succ_div_gt: forall a b, 0 a < b*(S (a/b)). +Proof. +intros. +nzsimpl. +rewrite (div_mod a b) at 1; try order. +rewrite <- add_lt_mono_l. +destruct (mod_always_pos a b). +rewrite abs_eq in *; order. +Qed. + +Lemma mul_pred_div_gt: forall a b, b<0 -> a < b*(P (a/b)). +Proof. +intros a b Hb. +rewrite mul_pred_r, <- add_opp_r. +rewrite (div_mod a b) at 1; try order. +rewrite <- add_lt_mono_l. +destruct (mod_always_pos a b). +rewrite <- opp_pos_neg in Hb. rewrite abs_neq' in *; order. +Qed. + +(** NB: The three previous properties could be used as + specifications for [div]. *) + +(** Inequality [mul_div_le] is exact iff the modulo is zero. *) + +Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). +Proof. +intros. +rewrite (div_mod a b) at 1; try order. +rewrite <- (add_0_r (b*(a/b))) at 2. +apply add_cancel_l. +Qed. + +(** Some additionnal inequalities about div. *) + +Theorem div_lt_upper_bound: + forall a b q, 0 a < b*q -> a/b < q. +Proof. +intros. +rewrite (mul_lt_mono_pos_l b) by trivial. +apply le_lt_trans with a; trivial. +apply mul_div_le; order. +Qed. + +Theorem div_le_upper_bound: + forall a b q, 0 a <= b*q -> a/b <= q. +Proof. +intros. +rewrite <- (div_mul q b) by order. +apply div_le_mono; trivial. now rewrite mul_comm. +Qed. + +Theorem div_le_lower_bound: + forall a b q, 0 b*q <= a -> q <= a/b. +Proof. +intros. +rewrite <- (div_mul q b) by order. +apply div_le_mono; trivial. now rewrite mul_comm. +Qed. + +(** A division respects opposite monotonicity for the divisor *) + +Lemma div_le_compat_l: forall p q r, 0<=p -> 0 p/r <= p/q. +Proof. exact div_le_compat_l. Qed. + +(** * Relations between usual operations and mod and div *) + +Lemma mod_add : forall a b c, c~=0 -> + (a + b * c) mod c == a mod c. +Proof. +intros. +symmetry. +apply mod_unique with (a/c+b); trivial. +now apply mod_always_pos. +rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. +now rewrite mul_comm. +Qed. + +Lemma div_add : forall a b c, c~=0 -> + (a + b * c) / c == a / c + b. +Proof. +intros. +apply (mul_cancel_l _ _ c); try order. +apply (add_cancel_r _ _ ((a+b*c) mod c)). +rewrite <- div_mod, mod_add by order. +rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. +now rewrite mul_comm. +Qed. + +Lemma div_add_l: forall a b c, b~=0 -> + (a * b + c) / b == a + c / b. +Proof. + intros a b c. rewrite (add_comm _ c), (add_comm a). + now apply div_add. +Qed. + +(** Cancellations. *) + +(** With the current convention, the following isn't always true + when [c<0]: [-3*-1 / -2*-1 = 3/2 = 1] while [-3/-2 = 2] *) + +Lemma div_mul_cancel_r : forall a b c, b~=0 -> 0 + (a*c)/(b*c) == a/b. +Proof. +intros. +symmetry. +apply div_unique with ((a mod b)*c). +(* ineqs *) +rewrite abs_mul, (abs_eq c) by order. +rewrite <-(mul_0_l c), <-mul_lt_mono_pos_r, <-mul_le_mono_pos_r by trivial. +apply mod_always_pos. +(* equation *) +rewrite (div_mod a b) at 1 by order. +rewrite mul_add_distr_r. +rewrite add_cancel_r. +rewrite <- 2 mul_assoc. now rewrite (mul_comm c). +Qed. + +Lemma div_mul_cancel_l : forall a b c, b~=0 -> 0 + (c*a)/(c*b) == a/b. +Proof. +intros. rewrite !(mul_comm c); now apply div_mul_cancel_r. +Qed. + +Lemma mul_mod_distr_l: forall a b c, b~=0 -> 0 + (c*a) mod (c*b) == c * (a mod b). +Proof. +intros. +rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). +rewrite <- div_mod. +rewrite div_mul_cancel_l by trivial. +rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. +apply div_mod; order. +rewrite <- neq_mul_0; intuition; order. +Qed. + +Lemma mul_mod_distr_r: forall a b c, b~=0 -> 0 + (a*c) mod (b*c) == (a mod b) * c. +Proof. + intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. +Qed. + + +(** Operations modulo. *) + +Theorem mod_mod: forall a n, n~=0 -> + (a mod n) mod n == a mod n. +Proof. +intros. rewrite mod_small_iff by trivial. +now apply mod_always_pos. +Qed. + +Lemma mul_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)*b) mod n == (a*b) mod n. +Proof. + intros a b n Hn. symmetry. + rewrite (div_mod a n) at 1 by order. + rewrite add_comm, (mul_comm n), (mul_comm _ b). + rewrite mul_add_distr_l, mul_assoc. + rewrite mod_add by trivial. + now rewrite mul_comm. +Qed. + +Lemma mul_mod_idemp_r : forall a b n, n~=0 -> + (a*(b mod n)) mod n == (a*b) mod n. +Proof. + intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l. +Qed. + +Theorem mul_mod: forall a b n, n~=0 -> + (a * b) mod n == ((a mod n) * (b mod n)) mod n. +Proof. + intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r. +Qed. + +Lemma add_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)+b) mod n == (a+b) mod n. +Proof. + intros a b n Hn. symmetry. + rewrite (div_mod a n) at 1 by order. + rewrite <- add_assoc, add_comm, mul_comm. + now rewrite mod_add. +Qed. + +Lemma add_mod_idemp_r : forall a b n, n~=0 -> + (a+(b mod n)) mod n == (a+b) mod n. +Proof. + intros. rewrite !(add_comm a). now apply add_mod_idemp_l. +Qed. + +Theorem add_mod: forall a b n, n~=0 -> + (a+b) mod n == (a mod n + b mod n) mod n. +Proof. + intros. now rewrite add_mod_idemp_l, add_mod_idemp_r. +Qed. + +(** With the current convention, the following result isn't always + true for negative divisors. For instance + [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ]. *) + +Lemma div_div : forall a b c, 0 0 + (a/b)/c == a/(b*c). +Proof. + intros a b c Hb Hc. + apply div_unique with (b*((a/b) mod c) + a mod b). + (* begin 0<= ... 0 0<=c -> c*(a/b) <= (c*a)/b. +Proof. exact div_mul_le. Qed. + +(** mod is related to divisibility *) + +Lemma mod_divides : forall a b, b~=0 -> + (a mod b == 0 <-> exists c, a == b*c). +Proof. +intros a b Hb. split. +intros Hab. exists (a/b). rewrite (div_mod a b Hb) at 1. + rewrite Hab; now nzsimpl. +intros (c,Hc). +rewrite Hc, mul_comm. +now apply mod_mul. +Qed. + + +End ZDivPropFunct. + diff --git a/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v new file mode 100644 index 00000000..1e7624ba --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v @@ -0,0 +1,632 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 0 <= a mod b < b. + Axiom mod_neg_bound : forall a b, b < 0 -> b < a mod b <= 0. +End ZDivSpecific. + +Module Type ZDiv (Z:ZAxiomsSig) + := DivMod Z <+ NZDivCommon Z <+ ZDivSpecific Z. + +Module Type ZDivSig := ZAxiomsExtSig <+ ZDiv. +Module Type ZDivSig' := ZAxiomsExtSig' <+ ZDiv <+ DivModNotation. + +Module ZDivPropFunct (Import Z : ZDivSig')(Import ZP : ZPropSig Z). + +(** We benefit from what already exists for NZ *) + + Module ZD <: NZDiv Z. + Definition div := div. + Definition modulo := modulo. + Definition div_wd := div_wd. + Definition mod_wd := mod_wd. + Definition div_mod := div_mod. + Lemma mod_bound : forall a b, 0<=a -> 0 0 <= a mod b < b. + Proof. intros. now apply mod_pos_bound. Qed. + End ZD. + Module Import NZDivP := NZDivPropFunct Z ZP ZD. + +(** Another formulation of the main equation *) + +Lemma mod_eq : + forall a b, b~=0 -> a mod b == a - b*(a/b). +Proof. +intros. +rewrite <- add_move_l. +symmetry. now apply div_mod. +Qed. + +(** Uniqueness theorems *) + +Theorem div_mod_unique : forall b q1 q2 r1 r2 : t, + (0<=r1 (0<=r2 + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. +Proof. +intros b q1 q2 r1 r2 Hr1 Hr2 EQ. +destruct Hr1; destruct Hr2; try (intuition; order). +apply div_mod_unique with b; trivial. +rewrite <- (opp_inj_wd r1 r2). +apply div_mod_unique with (-b); trivial. +rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. +rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. +now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd. +Qed. + +Theorem div_unique: + forall a b q r, (0<=r a == b*q + r -> q == a/b. +Proof. +intros a b q r Hr EQ. +assert (Hb : b~=0) by (destruct Hr; intuition; order). +destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. +destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound]; + intuition order. +now rewrite <- div_mod. +Qed. + +Theorem div_unique_pos: + forall a b q r, 0<=r a == b*q + r -> q == a/b. +Proof. intros; apply div_unique with r; auto. Qed. + +Theorem div_unique_neg: + forall a b q r, 0<=r a == b*q + r -> q == a/b. +Proof. intros; apply div_unique with r; auto. Qed. + +Theorem mod_unique: + forall a b q r, (0<=r a == b*q + r -> r == a mod b. +Proof. +intros a b q r Hr EQ. +assert (Hb : b~=0) by (destruct Hr; intuition; order). +destruct (div_mod_unique b q (a/b) r (a mod b)); trivial. +destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound]; + intuition order. +now rewrite <- div_mod. +Qed. + +Theorem mod_unique_pos: + forall a b q r, 0<=r a == b*q + r -> r == a mod b. +Proof. intros; apply mod_unique with q; auto. Qed. + +Theorem mod_unique_neg: + forall a b q r, b a == b*q + r -> r == a mod b. +Proof. intros; apply mod_unique with q; auto. Qed. + +(** Sign rules *) + +Ltac pos_or_neg a := + let LT := fresh "LT" in + let LE := fresh "LE" in + destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. + +Fact mod_bound_or : forall a b, b~=0 -> 0<=a mod b + 0 <= -(a mod b) < -b \/ -b < -(a mod b) <= 0. +Proof. +intros. +destruct (lt_ge_cases 0 b); [right|left]. +rewrite <- opp_lt_mono, opp_nonpos_nonneg. + destruct (mod_pos_bound a b); intuition; order. +rewrite <- opp_lt_mono, opp_nonneg_nonpos. + destruct (mod_neg_bound a b); intuition; order. +Qed. + +Lemma div_opp_opp : forall a b, b~=0 -> -a/-b == a/b. +Proof. +intros. symmetry. apply div_unique with (- (a mod b)). +now apply opp_mod_bound_or. +rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order. +Qed. + +Lemma mod_opp_opp : forall a b, b~=0 -> (-a) mod (-b) == - (a mod b). +Proof. +intros. symmetry. apply mod_unique with (a/b). +now apply opp_mod_bound_or. +rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order. +Qed. + +(** With the current conventions, the other sign rules are rather complex. *) + +Lemma div_opp_l_z : + forall a b, b~=0 -> a mod b == 0 -> (-a)/b == -(a/b). +Proof. +intros a b Hb H. symmetry. apply div_unique with 0. +destruct (lt_ge_cases 0 b); [left|right]; intuition; order. +rewrite <- opp_0, <- H. +rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order. +Qed. + +Lemma div_opp_l_nz : + forall a b, b~=0 -> a mod b ~= 0 -> (-a)/b == -(a/b)-1. +Proof. +intros a b Hb H. symmetry. apply div_unique with (b - a mod b). +destruct (lt_ge_cases 0 b); [left|right]. +rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l. +destruct (mod_pos_bound a b); intuition; order. +rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l. +destruct (mod_neg_bound a b); intuition; order. +rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l. +rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order. +Qed. + +Lemma mod_opp_l_z : + forall a b, b~=0 -> a mod b == 0 -> (-a) mod b == 0. +Proof. +intros a b Hb H. symmetry. apply mod_unique with (-(a/b)). +destruct (lt_ge_cases 0 b); [left|right]; intuition; order. +rewrite <- opp_0, <- H. +rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order. +Qed. + +Lemma mod_opp_l_nz : + forall a b, b~=0 -> a mod b ~= 0 -> (-a) mod b == b - a mod b. +Proof. +intros a b Hb H. symmetry. apply mod_unique with (-(a/b)-1). +destruct (lt_ge_cases 0 b); [left|right]. +rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l. +destruct (mod_pos_bound a b); intuition; order. +rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l. +destruct (mod_neg_bound a b); intuition; order. +rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l. +rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order. +Qed. + +Lemma div_opp_r_z : + forall a b, b~=0 -> a mod b == 0 -> a/(-b) == -(a/b). +Proof. +intros. rewrite <- (opp_involutive a) at 1. +rewrite div_opp_opp; auto using div_opp_l_z. +Qed. + +Lemma div_opp_r_nz : + forall a b, b~=0 -> a mod b ~= 0 -> a/(-b) == -(a/b)-1. +Proof. +intros. rewrite <- (opp_involutive a) at 1. +rewrite div_opp_opp; auto using div_opp_l_nz. +Qed. + +Lemma mod_opp_r_z : + forall a b, b~=0 -> a mod b == 0 -> a mod (-b) == 0. +Proof. +intros. rewrite <- (opp_involutive a) at 1. +now rewrite mod_opp_opp, mod_opp_l_z, opp_0. +Qed. + +Lemma mod_opp_r_nz : + forall a b, b~=0 -> a mod b ~= 0 -> a mod (-b) == (a mod b) - b. +Proof. +intros. rewrite <- (opp_involutive a) at 1. +rewrite mod_opp_opp, mod_opp_l_nz by trivial. +now rewrite opp_sub_distr, add_comm, add_opp_r. +Qed. + +(** The sign of [a mod b] is the one of [b] *) + +(* TODO: a proper sgn function and theory *) + +Lemma mod_sign : forall a b, b~=0 -> (0 <= (a mod b) * b). +Proof. +intros. destruct (lt_ge_cases 0 b). +apply mul_nonneg_nonneg; destruct (mod_pos_bound a b); order. +apply mul_nonpos_nonpos; destruct (mod_neg_bound a b); order. +Qed. + +(** A division by itself returns 1 *) + +Lemma div_same : forall a, a~=0 -> a/a == 1. +Proof. +intros. pos_or_neg a. apply div_same; order. +rewrite <- div_opp_opp by trivial. now apply div_same. +Qed. + +Lemma mod_same : forall a, a~=0 -> a mod a == 0. +Proof. +intros. rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag. +Qed. + +(** A division of a small number by a bigger one yields zero. *) + +Theorem div_small: forall a b, 0<=a a/b == 0. +Proof. exact div_small. Qed. + +(** Same situation, in term of modulo: *) + +Theorem mod_small: forall a b, 0<=a a mod b == a. +Proof. exact mod_small. Qed. + +(** * Basic values of divisions and modulo. *) + +Lemma div_0_l: forall a, a~=0 -> 0/a == 0. +Proof. +intros. pos_or_neg a. apply div_0_l; order. +rewrite <- div_opp_opp, opp_0 by trivial. now apply div_0_l. +Qed. + +Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. +Proof. +intros; rewrite mod_eq, div_0_l; now nzsimpl. +Qed. + +Lemma div_1_r: forall a, a/1 == a. +Proof. +intros. symmetry. apply div_unique with 0. left. split; order || apply lt_0_1. +now nzsimpl. +Qed. + +Lemma mod_1_r: forall a, a mod 1 == 0. +Proof. +intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag. +intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1. +Qed. + +Lemma div_1_l: forall a, 1 1/a == 0. +Proof. exact div_1_l. Qed. + +Lemma mod_1_l: forall a, 1 1 mod a == 1. +Proof. exact mod_1_l. Qed. + +Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. +Proof. +intros. symmetry. apply div_unique with 0. +destruct (lt_ge_cases 0 b); [left|right]; split; order. +nzsimpl; apply mul_comm. +Qed. + +Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. +Proof. +intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag. +Qed. + +(** * Order results about mod and div *) + +(** A modulo cannot grow beyond its starting point. *) + +Theorem mod_le: forall a b, 0<=a -> 0 a mod b <= a. +Proof. exact mod_le. Qed. + +Theorem div_pos : forall a b, 0<=a -> 0 0<= a/b. +Proof. exact div_pos. Qed. + +Lemma div_str_pos : forall a b, 0 0 < a/b. +Proof. exact div_str_pos. Qed. + +Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a (a mod b == a <-> 0<=a 1 a/b < a. +Proof. exact div_lt. Qed. + +(** [le] is compatible with a positive division. *) + +Lemma div_le_mono : forall a b c, 0 a<=b -> a/c <= b/c. +Proof. +intros a b c Hc Hab. +rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; + [|rewrite EQ; order]. +rewrite <- lt_succ_r. +rewrite (mul_lt_mono_pos_l c) by order. +nzsimpl. +rewrite (add_lt_mono_r _ _ (a mod c)). +rewrite <- div_mod by order. +apply lt_le_trans with b; trivial. +rewrite (div_mod b c) at 1 by order. +rewrite <- add_assoc, <- add_le_mono_l. +apply le_trans with (c+0). +nzsimpl; destruct (mod_pos_bound b c); order. +rewrite <- add_le_mono_l. destruct (mod_pos_bound a c); order. +Qed. + +(** In this convention, [div] performs Rounding-Toward-Bottom. + + Since we cannot speak of rational values here, we express this + fact by multiplying back by [b], and this leads to separates + statements according to the sign of [b]. + + First, [a/b] is below the exact fraction ... +*) + +Lemma mul_div_le : forall a b, 0 b*(a/b) <= a. +Proof. +intros. +rewrite (div_mod a b) at 2; try order. +rewrite <- (add_0_r (b*(a/b))) at 1. +rewrite <- add_le_mono_l. +now destruct (mod_pos_bound a b). +Qed. + +Lemma mul_div_ge : forall a b, b<0 -> a <= b*(a/b). +Proof. +intros. rewrite <- div_opp_opp, opp_le_mono, <-mul_opp_l by order. +apply mul_div_le. now rewrite opp_pos_neg. +Qed. + +(** ... and moreover it is the larger such integer, since [S(a/b)] + is strictly above the exact fraction. +*) + +Lemma mul_succ_div_gt: forall a b, 0 a < b*(S (a/b)). +Proof. +intros. +nzsimpl. +rewrite (div_mod a b) at 1; try order. +rewrite <- add_lt_mono_l. +destruct (mod_pos_bound a b); order. +Qed. + +Lemma mul_succ_div_lt: forall a b, b<0 -> b*(S (a/b)) < a. +Proof. +intros. rewrite <- div_opp_opp, opp_lt_mono, <-mul_opp_l by order. +apply mul_succ_div_gt. now rewrite opp_pos_neg. +Qed. + +(** NB: The four previous properties could be used as + specifications for [div]. *) + +(** Inequality [mul_div_le] is exact iff the modulo is zero. *) + +Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). +Proof. +intros. +rewrite (div_mod a b) at 1; try order. +rewrite <- (add_0_r (b*(a/b))) at 2. +apply add_cancel_l. +Qed. + +(** Some additionnal inequalities about div. *) + +Theorem div_lt_upper_bound: + forall a b q, 0 a < b*q -> a/b < q. +Proof. +intros. +rewrite (mul_lt_mono_pos_l b) by trivial. +apply le_lt_trans with a; trivial. +now apply mul_div_le. +Qed. + +Theorem div_le_upper_bound: + forall a b q, 0 a <= b*q -> a/b <= q. +Proof. +intros. +rewrite <- (div_mul q b) by order. +apply div_le_mono; trivial. now rewrite mul_comm. +Qed. + +Theorem div_le_lower_bound: + forall a b q, 0 b*q <= a -> q <= a/b. +Proof. +intros. +rewrite <- (div_mul q b) by order. +apply div_le_mono; trivial. now rewrite mul_comm. +Qed. + +(** A division respects opposite monotonicity for the divisor *) + +Lemma div_le_compat_l: forall p q r, 0<=p -> 0 p/r <= p/q. +Proof. exact div_le_compat_l. Qed. + +(** * Relations between usual operations and mod and div *) + +Lemma mod_add : forall a b c, c~=0 -> + (a + b * c) mod c == a mod c. +Proof. +intros. +symmetry. +apply mod_unique with (a/c+b); trivial. +now apply mod_bound_or. +rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. +now rewrite mul_comm. +Qed. + +Lemma div_add : forall a b c, c~=0 -> + (a + b * c) / c == a / c + b. +Proof. +intros. +apply (mul_cancel_l _ _ c); try order. +apply (add_cancel_r _ _ ((a+b*c) mod c)). +rewrite <- div_mod, mod_add by order. +rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. +now rewrite mul_comm. +Qed. + +Lemma div_add_l: forall a b c, b~=0 -> + (a * b + c) / b == a + c / b. +Proof. + intros a b c. rewrite (add_comm _ c), (add_comm a). + now apply div_add. +Qed. + +(** Cancellations. *) + +Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> + (a*c)/(b*c) == a/b. +Proof. +intros. +symmetry. +apply div_unique with ((a mod b)*c). +(* ineqs *) +destruct (lt_ge_cases 0 c). +rewrite <-(mul_0_l c), <-2mul_lt_mono_pos_r, <-2mul_le_mono_pos_r by trivial. +now apply mod_bound_or. +rewrite <-(mul_0_l c), <-2mul_lt_mono_neg_r, <-2mul_le_mono_neg_r by order. +destruct (mod_bound_or a b); tauto. +(* equation *) +rewrite (div_mod a b) at 1 by order. +rewrite mul_add_distr_r. +rewrite add_cancel_r. +rewrite <- 2 mul_assoc. now rewrite (mul_comm c). +Qed. + +Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> + (c*a)/(c*b) == a/b. +Proof. +intros. rewrite !(mul_comm c); now apply div_mul_cancel_r. +Qed. + +Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 -> + (c*a) mod (c*b) == c * (a mod b). +Proof. +intros. +rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). +rewrite <- div_mod. +rewrite div_mul_cancel_l by trivial. +rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. +apply div_mod; order. +rewrite <- neq_mul_0; auto. +Qed. + +Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> + (a*c) mod (b*c) == (a mod b) * c. +Proof. + intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. +Qed. + + +(** Operations modulo. *) + +Theorem mod_mod: forall a n, n~=0 -> + (a mod n) mod n == a mod n. +Proof. +intros. rewrite mod_small_iff by trivial. +now apply mod_bound_or. +Qed. + +Lemma mul_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)*b) mod n == (a*b) mod n. +Proof. + intros a b n Hn. symmetry. + rewrite (div_mod a n) at 1 by order. + rewrite add_comm, (mul_comm n), (mul_comm _ b). + rewrite mul_add_distr_l, mul_assoc. + intros. rewrite mod_add by trivial. + now rewrite mul_comm. +Qed. + +Lemma mul_mod_idemp_r : forall a b n, n~=0 -> + (a*(b mod n)) mod n == (a*b) mod n. +Proof. + intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l. +Qed. + +Theorem mul_mod: forall a b n, n~=0 -> + (a * b) mod n == ((a mod n) * (b mod n)) mod n. +Proof. + intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r. +Qed. + +Lemma add_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)+b) mod n == (a+b) mod n. +Proof. + intros a b n Hn. symmetry. + rewrite (div_mod a n) at 1 by order. + rewrite <- add_assoc, add_comm, mul_comm. + intros. now rewrite mod_add. +Qed. + +Lemma add_mod_idemp_r : forall a b n, n~=0 -> + (a+(b mod n)) mod n == (a+b) mod n. +Proof. + intros. rewrite !(add_comm a). now apply add_mod_idemp_l. +Qed. + +Theorem add_mod: forall a b n, n~=0 -> + (a+b) mod n == (a mod n + b mod n) mod n. +Proof. + intros. now rewrite add_mod_idemp_l, add_mod_idemp_r. +Qed. + +(** With the current convention, the following result isn't always + true for negative divisors. For instance + [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ]. *) + +Lemma div_div : forall a b c, 0 0 + (a/b)/c == a/(b*c). +Proof. + intros a b c Hb Hc. + apply div_unique with (b*((a/b) mod c) + a mod b). + (* begin 0<= ... 0 0<=c -> c*(a/b) <= (c*a)/b. +Proof. exact div_mul_le. Qed. + +(** mod is related to divisibility *) + +Lemma mod_divides : forall a b, b~=0 -> + (a mod b == 0 <-> exists c, a == b*c). +Proof. +intros a b Hb. split. +intros Hab. exists (a/b). rewrite (div_mod a b Hb) at 1. + rewrite Hab. now nzsimpl. +intros (c,Hc). +rewrite Hc, mul_comm. +now apply mod_mul. +Qed. + +End ZDivPropFunct. + diff --git a/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v new file mode 100644 index 00000000..3200ba2a --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v @@ -0,0 +1,532 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 0 0 <= a mod b < b. + Axiom mod_opp_l : forall a b, b ~= 0 -> (-a) mod b == - (a mod b). + Axiom mod_opp_r : forall a b, b ~= 0 -> a mod (-b) == a mod b. +End ZDivSpecific. + +Module Type ZDiv (Z:ZAxiomsSig) + := DivMod Z <+ NZDivCommon Z <+ ZDivSpecific Z. + +Module Type ZDivSig := ZAxiomsExtSig <+ ZDiv. +Module Type ZDivSig' := ZAxiomsExtSig' <+ ZDiv <+ DivModNotation. + +Module ZDivPropFunct (Import Z : ZDivSig')(Import ZP : ZPropSig Z). + +(** We benefit from what already exists for NZ *) + + Module Import NZDivP := NZDivPropFunct Z ZP Z. + +Ltac pos_or_neg a := + let LT := fresh "LT" in + let LE := fresh "LE" in + destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT]. + +(** Another formulation of the main equation *) + +Lemma mod_eq : + forall a b, b~=0 -> a mod b == a - b*(a/b). +Proof. +intros. +rewrite <- add_move_l. +symmetry. now apply div_mod. +Qed. + +(** A few sign rules (simple ones) *) + +Lemma mod_opp_opp : forall a b, b ~= 0 -> (-a) mod (-b) == - (a mod b). +Proof. intros. now rewrite mod_opp_r, mod_opp_l. Qed. + +Lemma div_opp_l : forall a b, b ~= 0 -> (-a)/b == -(a/b). +Proof. +intros. +rewrite <- (mul_cancel_l _ _ b) by trivial. +rewrite <- (add_cancel_r _ _ ((-a) mod b)). +now rewrite <- div_mod, mod_opp_l, mul_opp_r, <- opp_add_distr, <- div_mod. +Qed. + +Lemma div_opp_r : forall a b, b ~= 0 -> a/(-b) == -(a/b). +Proof. +intros. +assert (-b ~= 0) by (now rewrite eq_opp_l, opp_0). +rewrite <- (mul_cancel_l _ _ (-b)) by trivial. +rewrite <- (add_cancel_r _ _ (a mod (-b))). +now rewrite <- div_mod, mod_opp_r, mul_opp_opp, <- div_mod. +Qed. + +Lemma div_opp_opp : forall a b, b ~= 0 -> (-a)/(-b) == a/b. +Proof. intros. now rewrite div_opp_r, div_opp_l, opp_involutive. Qed. + +(** The sign of [a mod b] is the one of [a] *) + +(* TODO: a proper sgn function and theory *) + +Lemma mod_sign : forall a b, b~=0 -> 0 <= (a mod b) * a. +Proof. +assert (Aux : forall a b, 0 0 <= (a mod b) * a). + intros. pos_or_neg a. + apply mul_nonneg_nonneg; trivial. now destruct (mod_bound a b). + rewrite <- mul_opp_opp, <- mod_opp_l by order. + apply mul_nonneg_nonneg; try order. destruct (mod_bound (-a) b); order. +intros. pos_or_neg b. apply Aux; order. +rewrite <- mod_opp_r by order. apply Aux; order. +Qed. + + +(** Uniqueness theorems *) + +Theorem div_mod_unique : forall b q1 q2 r1 r2 : t, + (0<=r1 (0<=r2 + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. +Proof. +intros b q1 q2 r1 r2 Hr1 Hr2 EQ. +destruct Hr1; destruct Hr2; try (intuition; order). +apply div_mod_unique with b; trivial. +rewrite <- (opp_inj_wd r1 r2). +apply div_mod_unique with (-b); trivial. +rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. +rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto. +now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd. +Qed. + +Theorem div_unique: + forall a b q r, 0<=a -> 0<=r a == b*q + r -> q == a/b. +Proof. intros; now apply div_unique with r. Qed. + +Theorem mod_unique: + forall a b q r, 0<=a -> 0<=r a == b*q + r -> r == a mod b. +Proof. intros; now apply mod_unique with q. Qed. + +(** A division by itself returns 1 *) + +Lemma div_same : forall a, a~=0 -> a/a == 1. +Proof. +intros. pos_or_neg a. apply div_same; order. +rewrite <- div_opp_opp by trivial. now apply div_same. +Qed. + +Lemma mod_same : forall a, a~=0 -> a mod a == 0. +Proof. +intros. rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag. +Qed. + +(** A division of a small number by a bigger one yields zero. *) + +Theorem div_small: forall a b, 0<=a a/b == 0. +Proof. exact div_small. Qed. + +(** Same situation, in term of modulo: *) + +Theorem mod_small: forall a b, 0<=a a mod b == a. +Proof. exact mod_small. Qed. + +(** * Basic values of divisions and modulo. *) + +Lemma div_0_l: forall a, a~=0 -> 0/a == 0. +Proof. +intros. pos_or_neg a. apply div_0_l; order. +rewrite <- div_opp_opp, opp_0 by trivial. now apply div_0_l. +Qed. + +Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. +Proof. +intros; rewrite mod_eq, div_0_l; now nzsimpl. +Qed. + +Lemma div_1_r: forall a, a/1 == a. +Proof. +intros. pos_or_neg a. now apply div_1_r. +apply opp_inj. rewrite <- div_opp_l. apply div_1_r; order. +intro EQ; symmetry in EQ; revert EQ; apply lt_neq, lt_0_1. +Qed. + +Lemma mod_1_r: forall a, a mod 1 == 0. +Proof. +intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag. +intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1. +Qed. + +Lemma div_1_l: forall a, 1 1/a == 0. +Proof. exact div_1_l. Qed. + +Lemma mod_1_l: forall a, 1 1 mod a == 1. +Proof. exact mod_1_l. Qed. + +Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. +Proof. +intros. pos_or_neg a; pos_or_neg b. apply div_mul; order. +rewrite <- div_opp_opp, <- mul_opp_r by order. apply div_mul; order. +rewrite <- opp_inj_wd, <- div_opp_l, <- mul_opp_l by order. apply div_mul; order. +rewrite <- opp_inj_wd, <- div_opp_r, <- mul_opp_opp by order. apply div_mul; order. +Qed. + +Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. +Proof. +intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag. +Qed. + +(** * Order results about mod and div *) + +(** A modulo cannot grow beyond its starting point. *) + +Theorem mod_le: forall a b, 0<=a -> 0 a mod b <= a. +Proof. exact mod_le. Qed. + +Theorem div_pos : forall a b, 0<=a -> 0 0<= a/b. +Proof. exact div_pos. Qed. + +Lemma div_str_pos : forall a b, 0 0 < a/b. +Proof. exact div_str_pos. Qed. + +Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> abs a < abs b). +Proof. +intros. pos_or_neg a; pos_or_neg b. +rewrite div_small_iff; try order. rewrite 2 abs_eq; intuition; order. +rewrite <- opp_inj_wd, opp_0, <- div_opp_r, div_small_iff by order. + rewrite (abs_eq a), (abs_neq' b); intuition; order. +rewrite <- opp_inj_wd, opp_0, <- div_opp_l, div_small_iff by order. + rewrite (abs_neq' a), (abs_eq b); intuition; order. +rewrite <- div_opp_opp, div_small_iff by order. + rewrite (abs_neq' a), (abs_neq' b); intuition; order. +Qed. + +Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> abs a < abs b). +Proof. +intros. rewrite mod_eq, <- div_small_iff by order. +rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l. +rewrite eq_sym_iff, eq_mul_0. tauto. +Qed. + +(** As soon as the divisor is strictly greater than 1, + the division is strictly decreasing. *) + +Lemma div_lt : forall a b, 0 1 a/b < a. +Proof. exact div_lt. Qed. + +(** [le] is compatible with a positive division. *) + +Lemma div_le_mono : forall a b c, 0 a<=b -> a/c <= b/c. +Proof. +intros. pos_or_neg a. apply div_le_mono; auto. +pos_or_neg b. apply le_trans with 0. + rewrite <- opp_nonneg_nonpos, <- div_opp_l by order. + apply div_pos; order. + apply div_pos; order. +rewrite opp_le_mono in *. rewrite <- 2 div_opp_l by order. + apply div_le_mono; intuition; order. +Qed. + +(** With this choice of division, + rounding of div is always done toward zero: *) + +Lemma mul_div_le : forall a b, 0<=a -> b~=0 -> 0 <= b*(a/b) <= a. +Proof. +intros. pos_or_neg b. +split. +apply mul_nonneg_nonneg; [|apply div_pos]; order. +apply mul_div_le; order. +rewrite <- mul_opp_opp, <- div_opp_r by order. +split. +apply mul_nonneg_nonneg; [|apply div_pos]; order. +apply mul_div_le; order. +Qed. + +Lemma mul_div_ge : forall a b, a<=0 -> b~=0 -> a <= b*(a/b) <= 0. +Proof. +intros. +rewrite <- opp_nonneg_nonpos, opp_le_mono, <-mul_opp_r, <-div_opp_l by order. +rewrite <- opp_nonneg_nonpos in *. +destruct (mul_div_le (-a) b); tauto. +Qed. + +(** For positive numbers, considering [S (a/b)] leads to an upper bound for [a] *) + +Lemma mul_succ_div_gt: forall a b, 0<=a -> 0 a < b*(S (a/b)). +Proof. exact mul_succ_div_gt. Qed. + +(** Similar results with negative numbers *) + +Lemma mul_pred_div_lt: forall a b, a<=0 -> 0 b*(P (a/b)) < a. +Proof. +intros. +rewrite opp_lt_mono, <- mul_opp_r, opp_pred, <- div_opp_l by order. +rewrite <- opp_nonneg_nonpos in *. +now apply mul_succ_div_gt. +Qed. + +Lemma mul_pred_div_gt: forall a b, 0<=a -> b<0 -> a < b*(P (a/b)). +Proof. +intros. +rewrite <- mul_opp_opp, opp_pred, <- div_opp_r by order. +rewrite <- opp_pos_neg in *. +now apply mul_succ_div_gt. +Qed. + +Lemma mul_succ_div_lt: forall a b, a<=0 -> b<0 -> b*(S (a/b)) < a. +Proof. +intros. +rewrite opp_lt_mono, <- mul_opp_l, <- div_opp_opp by order. +rewrite <- opp_nonneg_nonpos, <- opp_pos_neg in *. +now apply mul_succ_div_gt. +Qed. + +(** Inequality [mul_div_le] is exact iff the modulo is zero. *) + +Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). +Proof. +intros. rewrite mod_eq by order. rewrite sub_move_r; nzsimpl; tauto. +Qed. + +(** Some additionnal inequalities about div. *) + +Theorem div_lt_upper_bound: + forall a b q, 0<=a -> 0 a < b*q -> a/b < q. +Proof. exact div_lt_upper_bound. Qed. + +Theorem div_le_upper_bound: + forall a b q, 0 a <= b*q -> a/b <= q. +Proof. +intros. +rewrite <- (div_mul q b) by order. +apply div_le_mono; trivial. now rewrite mul_comm. +Qed. + +Theorem div_le_lower_bound: + forall a b q, 0 b*q <= a -> q <= a/b. +Proof. +intros. +rewrite <- (div_mul q b) by order. +apply div_le_mono; trivial. now rewrite mul_comm. +Qed. + +(** A division respects opposite monotonicity for the divisor *) + +Lemma div_le_compat_l: forall p q r, 0<=p -> 0 p/r <= p/q. +Proof. exact div_le_compat_l. Qed. + +(** * Relations between usual operations and mod and div *) + +(** Unlike with other division conventions, some results here aren't + always valid, and need to be restricted. For instance + [(a+b*c) mod c <> a mod c] for [a=9,b=-5,c=2] *) + +Lemma mod_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> + (a + b * c) mod c == a mod c. +Proof. +assert (forall a b c, c~=0 -> 0<=a -> 0<=a+b*c -> (a+b*c) mod c == a mod c). + intros. pos_or_neg c. apply mod_add; order. + rewrite <- (mod_opp_r a), <- (mod_opp_r (a+b*c)) by order. + rewrite <- mul_opp_opp in *. + apply mod_add; order. +intros a b c Hc Habc. +destruct (le_0_mul _ _ Habc) as [(Habc',Ha)|(Habc',Ha)]. auto. +apply opp_inj. revert Ha Habc'. +rewrite <- 2 opp_nonneg_nonpos. +rewrite <- 2 mod_opp_l, opp_add_distr, <- mul_opp_l by order. auto. +Qed. + +Lemma div_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> + (a + b * c) / c == a / c + b. +Proof. +intros. +rewrite <- (mul_cancel_l _ _ c) by trivial. +rewrite <- (add_cancel_r _ _ ((a+b*c) mod c)). +rewrite <- div_mod, mod_add by trivial. +now rewrite mul_add_distr_l, add_shuffle0, <-div_mod, mul_comm. +Qed. + +Lemma div_add_l: forall a b c, b~=0 -> 0 <= (a*b+c)*c -> + (a * b + c) / b == a + c / b. +Proof. + intros a b c. rewrite add_comm, (add_comm a). now apply div_add. +Qed. + +(** Cancellations. *) + +Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> + (a*c)/(b*c) == a/b. +Proof. +assert (Aux1 : forall a b c, 0<=a -> 0 c~=0 -> (a*c)/(b*c) == a/b). + intros. pos_or_neg c. apply div_mul_cancel_r; order. + rewrite <- div_opp_opp, <- 2 mul_opp_r. apply div_mul_cancel_r; order. + rewrite <- neq_mul_0; intuition order. +assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a*c)/(b*c) == a/b). + intros. pos_or_neg b. apply Aux1; order. + apply opp_inj. rewrite <- 2 div_opp_r, <- mul_opp_l; try order. apply Aux1; order. + rewrite <- neq_mul_0; intuition order. +intros. pos_or_neg a. apply Aux2; order. +apply opp_inj. rewrite <- 2 div_opp_l, <- mul_opp_l; try order. apply Aux2; order. +rewrite <- neq_mul_0; intuition order. +Qed. + +Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> + (c*a)/(c*b) == a/b. +Proof. +intros. rewrite !(mul_comm c); now apply div_mul_cancel_r. +Qed. + +Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> + (a*c) mod (b*c) == (a mod b) * c. +Proof. +intros. +assert (b*c ~= 0) by (rewrite <- neq_mul_0; tauto). +rewrite ! mod_eq by trivial. +rewrite div_mul_cancel_r by order. +now rewrite mul_sub_distr_r, <- !mul_assoc, (mul_comm (a/b) c). +Qed. + +Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 -> + (c*a) mod (c*b) == c * (a mod b). +Proof. +intros; rewrite !(mul_comm c); now apply mul_mod_distr_r. +Qed. + +(** Operations modulo. *) + +Theorem mod_mod: forall a n, n~=0 -> + (a mod n) mod n == a mod n. +Proof. +intros. pos_or_neg a; pos_or_neg n. apply mod_mod; order. +rewrite <- ! (mod_opp_r _ n) by trivial. apply mod_mod; order. +apply opp_inj. rewrite <- !mod_opp_l by order. apply mod_mod; order. +apply opp_inj. rewrite <- !mod_opp_opp by order. apply mod_mod; order. +Qed. + +Lemma mul_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)*b) mod n == (a*b) mod n. +Proof. +assert (Aux1 : forall a b n, 0<=a -> 0<=b -> n~=0 -> + ((a mod n)*b) mod n == (a*b) mod n). + intros. pos_or_neg n. apply mul_mod_idemp_l; order. + rewrite <- ! (mod_opp_r _ n) by order. apply mul_mod_idemp_l; order. +assert (Aux2 : forall a b n, 0<=a -> n~=0 -> + ((a mod n)*b) mod n == (a*b) mod n). + intros. pos_or_neg b. now apply Aux1. + apply opp_inj. rewrite <-2 mod_opp_l, <-2 mul_opp_r by order. + apply Aux1; order. +intros a b n Hn. pos_or_neg a. now apply Aux2. +apply opp_inj. rewrite <-2 mod_opp_l, <-2 mul_opp_l, <-mod_opp_l by order. +apply Aux2; order. +Qed. + +Lemma mul_mod_idemp_r : forall a b n, n~=0 -> + (a*(b mod n)) mod n == (a*b) mod n. +Proof. +intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l. +Qed. + +Theorem mul_mod: forall a b n, n~=0 -> + (a * b) mod n == ((a mod n) * (b mod n)) mod n. +Proof. +intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r. +Qed. + +(** addition and modulo + + Generally speaking, unlike with other conventions, we don't have + [(a+b) mod n = (a mod n + b mod n) mod n] + for any a and b. + For instance, take (8 + (-10)) mod 3 = -2 whereas + (8 mod 3 + (-10 mod 3)) mod 3 = 1. +*) + +Lemma add_mod_idemp_l : forall a b n, n~=0 -> 0 <= a*b -> + ((a mod n)+b) mod n == (a+b) mod n. +Proof. +assert (Aux : forall a b n, 0<=a -> 0<=b -> n~=0 -> + ((a mod n)+b) mod n == (a+b) mod n). + intros. pos_or_neg n. apply add_mod_idemp_l; order. + rewrite <- ! (mod_opp_r _ n) by order. apply add_mod_idemp_l; order. +intros a b n Hn Hab. destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)]. +now apply Aux. +apply opp_inj. rewrite <-2 mod_opp_l, 2 opp_add_distr, <-mod_opp_l by order. +rewrite <- opp_nonneg_nonpos in *. +now apply Aux. +Qed. + +Lemma add_mod_idemp_r : forall a b n, n~=0 -> 0 <= a*b -> + (a+(b mod n)) mod n == (a+b) mod n. +Proof. +intros. rewrite !(add_comm a). apply add_mod_idemp_l; trivial. +now rewrite mul_comm. +Qed. + +Theorem add_mod: forall a b n, n~=0 -> 0 <= a*b -> + (a+b) mod n == (a mod n + b mod n) mod n. +Proof. +intros a b n Hn Hab. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. +reflexivity. +destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)]; + destruct (le_0_mul _ _ (mod_sign b n Hn)) as [(Hb',Hm)|(Hb',Hm)]; + auto using mul_nonneg_nonneg, mul_nonpos_nonpos. + setoid_replace b with 0 by order. rewrite mod_0_l by order. nzsimpl; order. + setoid_replace b with 0 by order. rewrite mod_0_l by order. nzsimpl; order. +Qed. + + +(** Conversely, the following result needs less restrictions here. *) + +Lemma div_div : forall a b c, b~=0 -> c~=0 -> + (a/b)/c == a/(b*c). +Proof. +assert (Aux1 : forall a b c, 0<=a -> 0 c~=0 -> (a/b)/c == a/(b*c)). + intros. pos_or_neg c. apply div_div; order. + apply opp_inj. rewrite <- 2 div_opp_r, <- mul_opp_r; trivial. + apply div_div; order. + rewrite <- neq_mul_0; intuition order. +assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a/b)/c == a/(b*c)). + intros. pos_or_neg b. apply Aux1; order. + apply opp_inj. rewrite <- div_opp_l, <- 2 div_opp_r, <- mul_opp_l; trivial. + apply Aux1; trivial. + rewrite <- neq_mul_0; intuition order. +intros. pos_or_neg a. apply Aux2; order. +apply opp_inj. rewrite <- 3 div_opp_l; try order. apply Aux2; order. +rewrite <- neq_mul_0. tauto. +Qed. + +(** A last inequality: *) + +Theorem div_mul_le: + forall a b c, 0<=a -> 0 0<=c -> c*(a/b) <= (c*a)/b. +Proof. exact div_mul_le. Qed. + +(** mod is related to divisibility *) + +Lemma mod_divides : forall a b, b~=0 -> + (a mod b == 0 <-> exists c, a == b*c). +Proof. + intros a b Hb. split. + intros Hab. exists (a/b). rewrite (div_mod a b Hb) at 1. + rewrite Hab; now nzsimpl. + intros (c,Hc). rewrite Hc, mul_comm. now apply mod_mul. +Qed. + +End ZDivPropFunct. + diff --git a/theories/Numbers/Integer/Abstract/ZDomain.v b/theories/Numbers/Integer/Abstract/ZDomain.v deleted file mode 100644 index 9a17e151..00000000 --- a/theories/Numbers/Integer/Abstract/ZDomain.v +++ /dev/null @@ -1,69 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Z -> Prop. -Parameter Inline e : Z -> Z -> bool. - -Axiom eq_equiv_e : forall x y : Z, Zeq x y <-> e x y. -Axiom eq_equiv : equiv Z Zeq. - -Add Relation Z Zeq - reflexivity proved by (proj1 eq_equiv) - symmetry proved by (proj2 (proj2 eq_equiv)) - transitivity proved by (proj1 (proj2 eq_equiv)) -as eq_rel. - -Delimit Scope IntScope with Int. -Bind Scope IntScope with Z. -Notation "x == y" := (Zeq x y) (at level 70) : IntScope. -Notation "x # y" := (~ Zeq x y) (at level 70) : IntScope. - -End ZDomainSignature. - -Module ZDomainProperties (Import ZDomainModule : ZDomainSignature). -Open Local Scope IntScope. - -Add Morphism e with signature Zeq ==> Zeq ==> eq_bool as e_wd. -Proof. -intros x x' Exx' y y' Eyy'. -case_eq (e x y); case_eq (e x' y'); intros H1 H2; trivial. -assert (x == y); [apply <- eq_equiv_e; now rewrite H2 | -assert (x' == y'); [rewrite <- Exx'; now rewrite <- Eyy' | -rewrite <- H1; assert (H3 : e x' y'); [now apply -> eq_equiv_e | now inversion H3]]]. -assert (x' == y'); [apply <- eq_equiv_e; now rewrite H1 | -assert (x == y); [rewrite Exx'; now rewrite Eyy' | -rewrite <- H2; assert (H3 : e x y); [now apply -> eq_equiv_e | now inversion H3]]]. -Qed. - -Theorem neq_sym : forall n m, n # m -> m # n. -Proof. -intros n m H1 H2; symmetry in H2; false_hyp H2 H1. -Qed. - -Theorem ZE_stepl : forall x y z : Z, x == y -> x == z -> z == y. -Proof. -intros x y z H1 H2; now rewrite <- H1. -Qed. - -Declare Left Step ZE_stepl. - -(* The right step lemma is just transitivity of Zeq *) -Declare Right Step (proj1 (proj2 eq_equiv)). - -End ZDomainProperties. - - diff --git a/theories/Numbers/Integer/Abstract/ZLt.v b/theories/Numbers/Integer/Abstract/ZLt.v index 2a88a535..849bf6b4 100644 --- a/theories/Numbers/Integer/Abstract/ZLt.v +++ b/theories/Numbers/Integer/Abstract/ZLt.v @@ -8,424 +8,126 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZLt.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) Require Export ZMul. -Module ZOrderPropFunct (Import ZAxiomsMod : ZAxiomsSig). -Module Export ZMulPropMod := ZMulPropFunct ZAxiomsMod. -Open Local Scope IntScope. +Module ZOrderPropFunct (Import Z : ZAxiomsSig'). +Include ZMulPropFunct Z. -(* Axioms *) +(** Instances of earlier theorems for m == 0 *) -Theorem Zlt_wd : - forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> (n1 < m1 <-> n2 < m2). -Proof NZlt_wd. - -Theorem Zle_wd : - forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> (n1 <= m1 <-> n2 <= m2). -Proof NZle_wd. - -Theorem Zmin_wd : - forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> Zmin n1 m1 == Zmin n2 m2. -Proof NZmin_wd. - -Theorem Zmax_wd : - forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> Zmax n1 m1 == Zmax n2 m2. -Proof NZmax_wd. - -Theorem Zlt_eq_cases : forall n m : Z, n <= m <-> n < m \/ n == m. -Proof NZlt_eq_cases. - -Theorem Zlt_irrefl : forall n : Z, ~ n < n. -Proof NZlt_irrefl. - -Theorem Zlt_succ_r : forall n m : Z, n < S m <-> n <= m. -Proof NZlt_succ_r. - -Theorem Zmin_l : forall n m : Z, n <= m -> Zmin n m == n. -Proof NZmin_l. - -Theorem Zmin_r : forall n m : Z, m <= n -> Zmin n m == m. -Proof NZmin_r. - -Theorem Zmax_l : forall n m : Z, m <= n -> Zmax n m == n. -Proof NZmax_l. - -Theorem Zmax_r : forall n m : Z, n <= m -> Zmax n m == m. -Proof NZmax_r. - -(* Renaming theorems from NZOrder.v *) - -Theorem Zlt_le_incl : forall n m : Z, n < m -> n <= m. -Proof NZlt_le_incl. - -Theorem Zlt_neq : forall n m : Z, n < m -> n ~= m. -Proof NZlt_neq. - -Theorem Zle_neq : forall n m : Z, n < m <-> n <= m /\ n ~= m. -Proof NZle_neq. - -Theorem Zle_refl : forall n : Z, n <= n. -Proof NZle_refl. - -Theorem Zlt_succ_diag_r : forall n : Z, n < S n. -Proof NZlt_succ_diag_r. - -Theorem Zle_succ_diag_r : forall n : Z, n <= S n. -Proof NZle_succ_diag_r. - -Theorem Zlt_0_1 : 0 < 1. -Proof NZlt_0_1. - -Theorem Zle_0_1 : 0 <= 1. -Proof NZle_0_1. - -Theorem Zlt_lt_succ_r : forall n m : Z, n < m -> n < S m. -Proof NZlt_lt_succ_r. - -Theorem Zle_le_succ_r : forall n m : Z, n <= m -> n <= S m. -Proof NZle_le_succ_r. - -Theorem Zle_succ_r : forall n m : Z, n <= S m <-> n <= m \/ n == S m. -Proof NZle_succ_r. - -Theorem Zneq_succ_diag_l : forall n : Z, S n ~= n. -Proof NZneq_succ_diag_l. - -Theorem Zneq_succ_diag_r : forall n : Z, n ~= S n. -Proof NZneq_succ_diag_r. - -Theorem Znlt_succ_diag_l : forall n : Z, ~ S n < n. -Proof NZnlt_succ_diag_l. - -Theorem Znle_succ_diag_l : forall n : Z, ~ S n <= n. -Proof NZnle_succ_diag_l. - -Theorem Zle_succ_l : forall n m : Z, S n <= m <-> n < m. -Proof NZle_succ_l. - -Theorem Zlt_succ_l : forall n m : Z, S n < m -> n < m. -Proof NZlt_succ_l. - -Theorem Zsucc_lt_mono : forall n m : Z, n < m <-> S n < S m. -Proof NZsucc_lt_mono. - -Theorem Zsucc_le_mono : forall n m : Z, n <= m <-> S n <= S m. -Proof NZsucc_le_mono. - -Theorem Zlt_asymm : forall n m, n < m -> ~ m < n. -Proof NZlt_asymm. - -Notation Zlt_ngt := Zlt_asymm (only parsing). - -Theorem Zlt_trans : forall n m p : Z, n < m -> m < p -> n < p. -Proof NZlt_trans. - -Theorem Zle_trans : forall n m p : Z, n <= m -> m <= p -> n <= p. -Proof NZle_trans. - -Theorem Zle_lt_trans : forall n m p : Z, n <= m -> m < p -> n < p. -Proof NZle_lt_trans. - -Theorem Zlt_le_trans : forall n m p : Z, n < m -> m <= p -> n < p. -Proof NZlt_le_trans. - -Theorem Zle_antisymm : forall n m : Z, n <= m -> m <= n -> n == m. -Proof NZle_antisymm. - -Theorem Zlt_1_l : forall n m : Z, 0 < n -> n < m -> 1 < m. -Proof NZlt_1_l. - -(** Trichotomy, decidability, and double negation elimination *) - -Theorem Zlt_trichotomy : forall n m : Z, n < m \/ n == m \/ m < n. -Proof NZlt_trichotomy. - -Notation Zlt_eq_gt_cases := Zlt_trichotomy (only parsing). - -Theorem Zlt_gt_cases : forall n m : Z, n ~= m <-> n < m \/ n > m. -Proof NZlt_gt_cases. - -Theorem Zle_gt_cases : forall n m : Z, n <= m \/ n > m. -Proof NZle_gt_cases. - -Theorem Zlt_ge_cases : forall n m : Z, n < m \/ n >= m. -Proof NZlt_ge_cases. - -Theorem Zle_ge_cases : forall n m : Z, n <= m \/ n >= m. -Proof NZle_ge_cases. - -(** Instances of the previous theorems for m == 0 *) - -Theorem Zneg_pos_cases : forall n : Z, n ~= 0 <-> n < 0 \/ n > 0. +Theorem neg_pos_cases : forall n, n ~= 0 <-> n < 0 \/ n > 0. Proof. -intro; apply Zlt_gt_cases. +intro; apply lt_gt_cases. Qed. -Theorem Znonpos_pos_cases : forall n : Z, n <= 0 \/ n > 0. +Theorem nonpos_pos_cases : forall n, n <= 0 \/ n > 0. Proof. -intro; apply Zle_gt_cases. +intro; apply le_gt_cases. Qed. -Theorem Zneg_nonneg_cases : forall n : Z, n < 0 \/ n >= 0. +Theorem neg_nonneg_cases : forall n, n < 0 \/ n >= 0. Proof. -intro; apply Zlt_ge_cases. +intro; apply lt_ge_cases. Qed. -Theorem Znonpos_nonneg_cases : forall n : Z, n <= 0 \/ n >= 0. +Theorem nonpos_nonneg_cases : forall n, n <= 0 \/ n >= 0. Proof. -intro; apply Zle_ge_cases. +intro; apply le_ge_cases. Qed. -Theorem Zle_ngt : forall n m : Z, n <= m <-> ~ n > m. -Proof NZle_ngt. - -Theorem Znlt_ge : forall n m : Z, ~ n < m <-> n >= m. -Proof NZnlt_ge. - -Theorem Zlt_dec : forall n m : Z, decidable (n < m). -Proof NZlt_dec. - -Theorem Zlt_dne : forall n m, ~ ~ n < m <-> n < m. -Proof NZlt_dne. - -Theorem Znle_gt : forall n m : Z, ~ n <= m <-> n > m. -Proof NZnle_gt. - -Theorem Zlt_nge : forall n m : Z, n < m <-> ~ n >= m. -Proof NZlt_nge. - -Theorem Zle_dec : forall n m : Z, decidable (n <= m). -Proof NZle_dec. - -Theorem Zle_dne : forall n m : Z, ~ ~ n <= m <-> n <= m. -Proof NZle_dne. - -Theorem Znlt_succ_r : forall n m : Z, ~ m < S n <-> n < m. -Proof NZnlt_succ_r. - -Theorem Zlt_exists_pred : - forall z n : Z, z < n -> exists k : Z, n == S k /\ z <= k. -Proof NZlt_exists_pred. - -Theorem Zlt_succ_iter_r : - forall (n : nat) (m : Z), m < NZsucc_iter (Datatypes.S n) m. -Proof NZlt_succ_iter_r. - -Theorem Zneq_succ_iter_l : - forall (n : nat) (m : Z), NZsucc_iter (Datatypes.S n) m ~= m. -Proof NZneq_succ_iter_l. - -(** Stronger variant of induction with assumptions n >= 0 (n < 0) -in the induction step *) - -Theorem Zright_induction : - forall A : Z -> Prop, predicate_wd Zeq A -> - forall z : Z, A z -> - (forall n : Z, z <= n -> A n -> A (S n)) -> - forall n : Z, z <= n -> A n. -Proof NZright_induction. - -Theorem Zleft_induction : - forall A : Z -> Prop, predicate_wd Zeq A -> - forall z : Z, A z -> - (forall n : Z, n < z -> A (S n) -> A n) -> - forall n : Z, n <= z -> A n. -Proof NZleft_induction. - -Theorem Zright_induction' : - forall A : Z -> Prop, predicate_wd Zeq A -> - forall z : Z, - (forall n : Z, n <= z -> A n) -> - (forall n : Z, z <= n -> A n -> A (S n)) -> - forall n : Z, A n. -Proof NZright_induction'. - -Theorem Zleft_induction' : - forall A : Z -> Prop, predicate_wd Zeq A -> - forall z : Z, - (forall n : Z, z <= n -> A n) -> - (forall n : Z, n < z -> A (S n) -> A n) -> - forall n : Z, A n. -Proof NZleft_induction'. - -Theorem Zstrong_right_induction : - forall A : Z -> Prop, predicate_wd Zeq A -> - forall z : Z, - (forall n : Z, z <= n -> (forall m : Z, z <= m -> m < n -> A m) -> A n) -> - forall n : Z, z <= n -> A n. -Proof NZstrong_right_induction. - -Theorem Zstrong_left_induction : - forall A : Z -> Prop, predicate_wd Zeq A -> - forall z : Z, - (forall n : Z, n <= z -> (forall m : Z, m <= z -> S n <= m -> A m) -> A n) -> - forall n : Z, n <= z -> A n. -Proof NZstrong_left_induction. - -Theorem Zstrong_right_induction' : - forall A : Z -> Prop, predicate_wd Zeq A -> - forall z : Z, - (forall n : Z, n <= z -> A n) -> - (forall n : Z, z <= n -> (forall m : Z, z <= m -> m < n -> A m) -> A n) -> - forall n : Z, A n. -Proof NZstrong_right_induction'. - -Theorem Zstrong_left_induction' : - forall A : Z -> Prop, predicate_wd Zeq A -> - forall z : Z, - (forall n : Z, z <= n -> A n) -> - (forall n : Z, n <= z -> (forall m : Z, m <= z -> S n <= m -> A m) -> A n) -> - forall n : Z, A n. -Proof NZstrong_left_induction'. - -Theorem Zorder_induction : - forall A : Z -> Prop, predicate_wd Zeq A -> - forall z : Z, A z -> - (forall n : Z, z <= n -> A n -> A (S n)) -> - (forall n : Z, n < z -> A (S n) -> A n) -> - forall n : Z, A n. -Proof NZorder_induction. - -Theorem Zorder_induction' : - forall A : Z -> Prop, predicate_wd Zeq A -> - forall z : Z, A z -> - (forall n : Z, z <= n -> A n -> A (S n)) -> - (forall n : Z, n <= z -> A n -> A (P n)) -> - forall n : Z, A n. -Proof NZorder_induction'. - -Theorem Zorder_induction_0 : - forall A : Z -> Prop, predicate_wd Zeq A -> - A 0 -> - (forall n : Z, 0 <= n -> A n -> A (S n)) -> - (forall n : Z, n < 0 -> A (S n) -> A n) -> - forall n : Z, A n. -Proof NZorder_induction_0. - -Theorem Zorder_induction'_0 : - forall A : Z -> Prop, predicate_wd Zeq A -> - A 0 -> - (forall n : Z, 0 <= n -> A n -> A (S n)) -> - (forall n : Z, n <= 0 -> A n -> A (P n)) -> - forall n : Z, A n. -Proof NZorder_induction'_0. - -Ltac Zinduct n := induction_maker n ltac:(apply Zorder_induction_0). - -(** Elimintation principle for < *) - -Theorem Zlt_ind : - forall A : Z -> Prop, predicate_wd Zeq A -> - forall n : Z, A (S n) -> - (forall m : Z, n < m -> A m -> A (S m)) -> forall m : Z, n < m -> A m. -Proof NZlt_ind. - -(** Elimintation principle for <= *) - -Theorem Zle_ind : - forall A : Z -> Prop, predicate_wd Zeq A -> - forall n : Z, A n -> - (forall m : Z, n <= m -> A m -> A (S m)) -> forall m : Z, n <= m -> A m. -Proof NZle_ind. - -(** Well-founded relations *) - -Theorem Zlt_wf : forall z : Z, well_founded (fun n m : Z => z <= n /\ n < m). -Proof NZlt_wf. - -Theorem Zgt_wf : forall z : Z, well_founded (fun n m : Z => m < n /\ n <= z). -Proof NZgt_wf. +Ltac zinduct n := induction_maker n ltac:(apply order_induction_0). -(* Theorems that are either not valid on N or have different proofs on N and Z *) +(** Theorems that are either not valid on N or have different proofs + on N and Z *) -Theorem Zlt_pred_l : forall n : Z, P n < n. +Theorem lt_pred_l : forall n, P n < n. Proof. -intro n; rewrite <- (Zsucc_pred n) at 2; apply Zlt_succ_diag_r. +intro n; rewrite <- (succ_pred n) at 2; apply lt_succ_diag_r. Qed. -Theorem Zle_pred_l : forall n : Z, P n <= n. +Theorem le_pred_l : forall n, P n <= n. Proof. -intro; apply Zlt_le_incl; apply Zlt_pred_l. +intro; apply lt_le_incl; apply lt_pred_l. Qed. -Theorem Zlt_le_pred : forall n m : Z, n < m <-> n <= P m. +Theorem lt_le_pred : forall n m, n < m <-> n <= P m. Proof. -intros n m; rewrite <- (Zsucc_pred m); rewrite Zpred_succ. apply Zlt_succ_r. +intros n m; rewrite <- (succ_pred m); rewrite pred_succ. apply lt_succ_r. Qed. -Theorem Znle_pred_r : forall n : Z, ~ n <= P n. +Theorem nle_pred_r : forall n, ~ n <= P n. Proof. -intro; rewrite <- Zlt_le_pred; apply Zlt_irrefl. +intro; rewrite <- lt_le_pred; apply lt_irrefl. Qed. -Theorem Zlt_pred_le : forall n m : Z, P n < m <-> n <= m. +Theorem lt_pred_le : forall n m, P n < m <-> n <= m. Proof. -intros n m; rewrite <- (Zsucc_pred n) at 2. -symmetry; apply Zle_succ_l. +intros n m; rewrite <- (succ_pred n) at 2. +symmetry; apply le_succ_l. Qed. -Theorem Zlt_lt_pred : forall n m : Z, n < m -> P n < m. +Theorem lt_lt_pred : forall n m, n < m -> P n < m. Proof. -intros; apply <- Zlt_pred_le; now apply Zlt_le_incl. +intros; apply <- lt_pred_le; now apply lt_le_incl. Qed. -Theorem Zle_le_pred : forall n m : Z, n <= m -> P n <= m. +Theorem le_le_pred : forall n m, n <= m -> P n <= m. Proof. -intros; apply Zlt_le_incl; now apply <- Zlt_pred_le. +intros; apply lt_le_incl; now apply <- lt_pred_le. Qed. -Theorem Zlt_pred_lt : forall n m : Z, n < P m -> n < m. +Theorem lt_pred_lt : forall n m, n < P m -> n < m. Proof. -intros n m H; apply Zlt_trans with (P m); [assumption | apply Zlt_pred_l]. +intros n m H; apply lt_trans with (P m); [assumption | apply lt_pred_l]. Qed. -Theorem Zle_pred_lt : forall n m : Z, n <= P m -> n <= m. +Theorem le_pred_lt : forall n m, n <= P m -> n <= m. Proof. -intros; apply Zlt_le_incl; now apply <- Zlt_le_pred. +intros; apply lt_le_incl; now apply <- lt_le_pred. Qed. -Theorem Zpred_lt_mono : forall n m : Z, n < m <-> P n < P m. +Theorem pred_lt_mono : forall n m, n < m <-> P n < P m. Proof. -intros; rewrite Zlt_le_pred; symmetry; apply Zlt_pred_le. +intros; rewrite lt_le_pred; symmetry; apply lt_pred_le. Qed. -Theorem Zpred_le_mono : forall n m : Z, n <= m <-> P n <= P m. +Theorem pred_le_mono : forall n m, n <= m <-> P n <= P m. Proof. -intros; rewrite <- Zlt_pred_le; now rewrite Zlt_le_pred. +intros; rewrite <- lt_pred_le; now rewrite lt_le_pred. Qed. -Theorem Zlt_succ_lt_pred : forall n m : Z, S n < m <-> n < P m. +Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m. Proof. -intros n m; now rewrite (Zpred_lt_mono (S n) m), Zpred_succ. +intros n m; now rewrite (pred_lt_mono (S n) m), pred_succ. Qed. -Theorem Zle_succ_le_pred : forall n m : Z, S n <= m <-> n <= P m. +Theorem le_succ_le_pred : forall n m, S n <= m <-> n <= P m. Proof. -intros n m; now rewrite (Zpred_le_mono (S n) m), Zpred_succ. +intros n m; now rewrite (pred_le_mono (S n) m), pred_succ. Qed. -Theorem Zlt_pred_lt_succ : forall n m : Z, P n < m <-> n < S m. +Theorem lt_pred_lt_succ : forall n m, P n < m <-> n < S m. Proof. -intros; rewrite Zlt_pred_le; symmetry; apply Zlt_succ_r. +intros; rewrite lt_pred_le; symmetry; apply lt_succ_r. Qed. -Theorem Zle_pred_lt_succ : forall n m : Z, P n <= m <-> n <= S m. +Theorem le_pred_lt_succ : forall n m, P n <= m <-> n <= S m. Proof. -intros n m; now rewrite (Zpred_le_mono n (S m)), Zpred_succ. +intros n m; now rewrite (pred_le_mono n (S m)), pred_succ. Qed. -Theorem Zneq_pred_l : forall n : Z, P n ~= n. +Theorem neq_pred_l : forall n, P n ~= n. Proof. -intro; apply Zlt_neq; apply Zlt_pred_l. +intro; apply lt_neq; apply lt_pred_l. Qed. -Theorem Zlt_n1_r : forall n m : Z, n < m -> m < 0 -> n < -1. +Theorem lt_n1_r : forall n m, n < m -> m < 0 -> n < -(1). Proof. -intros n m H1 H2. apply -> Zlt_le_pred in H2. -setoid_replace (P 0) with (-1) in H2. now apply NZlt_le_trans with m. -apply <- Zeq_opp_r. now rewrite Zopp_pred, Zopp_0. +intros n m H1 H2. apply -> lt_le_pred in H2. +setoid_replace (P 0) with (-(1)) in H2. now apply lt_le_trans with m. +apply <- eq_opp_r. now rewrite opp_pred, opp_0. Qed. End ZOrderPropFunct. diff --git a/theories/Numbers/Integer/Abstract/ZMul.v b/theories/Numbers/Integer/Abstract/ZMul.v index c48d1b4c..84d840ad 100644 --- a/theories/Numbers/Integer/Abstract/ZMul.v +++ b/theories/Numbers/Integer/Abstract/ZMul.v @@ -8,106 +8,63 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZMul.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) Require Export ZAdd. -Module ZMulPropFunct (Import ZAxiomsMod : ZAxiomsSig). -Module Export ZAddPropMod := ZAddPropFunct ZAxiomsMod. -Open Local Scope IntScope. +Module ZMulPropFunct (Import Z : ZAxiomsSig'). +Include ZAddPropFunct Z. -Theorem Zmul_wd : - forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> n1 * m1 == n2 * m2. -Proof NZmul_wd. +(** A note on naming: right (correspondingly, left) distributivity + happens when the sum is multiplied by a number on the right + (left), not when the sum itself is the right (left) factor in the + product (see planetmath.org and mathworld.wolfram.com). In the old + library BinInt, distributivity over subtraction was named + correctly, but distributivity over addition was named + incorrectly. The names in Isabelle/HOL library are also + incorrect. *) -Theorem Zmul_0_l : forall n : Z, 0 * n == 0. -Proof NZmul_0_l. +(** Theorems that are either not valid on N or have different proofs + on N and Z *) -Theorem Zmul_succ_l : forall n m : Z, (S n) * m == n * m + m. -Proof NZmul_succ_l. - -(* Theorems that are valid for both natural numbers and integers *) - -Theorem Zmul_0_r : forall n : Z, n * 0 == 0. -Proof NZmul_0_r. - -Theorem Zmul_succ_r : forall n m : Z, n * (S m) == n * m + n. -Proof NZmul_succ_r. - -Theorem Zmul_comm : forall n m : Z, n * m == m * n. -Proof NZmul_comm. - -Theorem Zmul_add_distr_r : forall n m p : Z, (n + m) * p == n * p + m * p. -Proof NZmul_add_distr_r. - -Theorem Zmul_add_distr_l : forall n m p : Z, n * (m + p) == n * m + n * p. -Proof NZmul_add_distr_l. - -(* A note on naming: right (correspondingly, left) distributivity happens -when the sum is multiplied by a number on the right (left), not when the -sum itself is the right (left) factor in the product (see planetmath.org -and mathworld.wolfram.com). In the old library BinInt, distributivity over -subtraction was named correctly, but distributivity over addition was named -incorrectly. The names in Isabelle/HOL library are also incorrect. *) - -Theorem Zmul_assoc : forall n m p : Z, n * (m * p) == (n * m) * p. -Proof NZmul_assoc. - -Theorem Zmul_1_l : forall n : Z, 1 * n == n. -Proof NZmul_1_l. - -Theorem Zmul_1_r : forall n : Z, n * 1 == n. -Proof NZmul_1_r. - -(* The following two theorems are true in an ordered ring, -but since they don't mention order, we'll put them here *) - -Theorem Zeq_mul_0 : forall n m : Z, n * m == 0 <-> n == 0 \/ m == 0. -Proof NZeq_mul_0. - -Theorem Zneq_mul_0 : forall n m : Z, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. -Proof NZneq_mul_0. - -(* Theorems that are either not valid on N or have different proofs on N and Z *) - -Theorem Zmul_pred_r : forall n m : Z, n * (P m) == n * m - n. +Theorem mul_pred_r : forall n m, n * (P m) == n * m - n. Proof. intros n m. -rewrite <- (Zsucc_pred m) at 2. -now rewrite Zmul_succ_r, <- Zadd_sub_assoc, Zsub_diag, Zadd_0_r. +rewrite <- (succ_pred m) at 2. +now rewrite mul_succ_r, <- add_sub_assoc, sub_diag, add_0_r. Qed. -Theorem Zmul_pred_l : forall n m : Z, (P n) * m == n * m - m. +Theorem mul_pred_l : forall n m, (P n) * m == n * m - m. Proof. -intros n m; rewrite (Zmul_comm (P n) m), (Zmul_comm n m). apply Zmul_pred_r. +intros n m; rewrite (mul_comm (P n) m), (mul_comm n m). apply mul_pred_r. Qed. -Theorem Zmul_opp_l : forall n m : Z, (- n) * m == - (n * m). +Theorem mul_opp_l : forall n m, (- n) * m == - (n * m). Proof. -intros n m. apply -> Zadd_move_0_r. -now rewrite <- Zmul_add_distr_r, Zadd_opp_diag_l, Zmul_0_l. +intros n m. apply -> add_move_0_r. +now rewrite <- mul_add_distr_r, add_opp_diag_l, mul_0_l. Qed. -Theorem Zmul_opp_r : forall n m : Z, n * (- m) == - (n * m). +Theorem mul_opp_r : forall n m, n * (- m) == - (n * m). Proof. -intros n m; rewrite (Zmul_comm n (- m)), (Zmul_comm n m); apply Zmul_opp_l. +intros n m; rewrite (mul_comm n (- m)), (mul_comm n m); apply mul_opp_l. Qed. -Theorem Zmul_opp_opp : forall n m : Z, (- n) * (- m) == n * m. +Theorem mul_opp_opp : forall n m, (- n) * (- m) == n * m. Proof. -intros n m; now rewrite Zmul_opp_l, Zmul_opp_r, Zopp_involutive. +intros n m; now rewrite mul_opp_l, mul_opp_r, opp_involutive. Qed. -Theorem Zmul_sub_distr_l : forall n m p : Z, n * (m - p) == n * m - n * p. +Theorem mul_sub_distr_l : forall n m p, n * (m - p) == n * m - n * p. Proof. -intros n m p. do 2 rewrite <- Zadd_opp_r. rewrite Zmul_add_distr_l. -now rewrite Zmul_opp_r. +intros n m p. do 2 rewrite <- add_opp_r. rewrite mul_add_distr_l. +now rewrite mul_opp_r. Qed. -Theorem Zmul_sub_distr_r : forall n m p : Z, (n - m) * p == n * p - m * p. +Theorem mul_sub_distr_r : forall n m p, (n - m) * p == n * p - m * p. Proof. -intros n m p; rewrite (Zmul_comm (n - m) p), (Zmul_comm n p), (Zmul_comm m p); -now apply Zmul_sub_distr_l. +intros n m p; rewrite (mul_comm (n - m) p), (mul_comm n p), (mul_comm m p); +now apply mul_sub_distr_l. Qed. End ZMulPropFunct. diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v index c7996ffd..99be58eb 100644 --- a/theories/Numbers/Integer/Abstract/ZMulOrder.v +++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v @@ -8,335 +8,225 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZMulOrder.v 11674 2008-12-12 19:48:40Z letouzey $ i*) +(*i $Id$ i*) Require Export ZAddOrder. -Module ZMulOrderPropFunct (Import ZAxiomsMod : ZAxiomsSig). -Module Export ZAddOrderPropMod := ZAddOrderPropFunct ZAxiomsMod. -Open Local Scope IntScope. +Module Type ZMulOrderPropFunct (Import Z : ZAxiomsSig'). +Include ZAddOrderPropFunct Z. -Theorem Zmul_lt_pred : - forall p q n m : Z, S p == q -> (p * n < p * m <-> q * n + m < q * m + n). -Proof NZmul_lt_pred. +Local Notation "- 1" := (-(1)). -Theorem Zmul_lt_mono_pos_l : forall p n m : Z, 0 < p -> (n < m <-> p * n < p * m). -Proof NZmul_lt_mono_pos_l. - -Theorem Zmul_lt_mono_pos_r : forall p n m : Z, 0 < p -> (n < m <-> n * p < m * p). -Proof NZmul_lt_mono_pos_r. - -Theorem Zmul_lt_mono_neg_l : forall p n m : Z, p < 0 -> (n < m <-> p * m < p * n). -Proof NZmul_lt_mono_neg_l. - -Theorem Zmul_lt_mono_neg_r : forall p n m : Z, p < 0 -> (n < m <-> m * p < n * p). -Proof NZmul_lt_mono_neg_r. - -Theorem Zmul_le_mono_nonneg_l : forall n m p : Z, 0 <= p -> n <= m -> p * n <= p * m. -Proof NZmul_le_mono_nonneg_l. - -Theorem Zmul_le_mono_nonpos_l : forall n m p : Z, p <= 0 -> n <= m -> p * m <= p * n. -Proof NZmul_le_mono_nonpos_l. - -Theorem Zmul_le_mono_nonneg_r : forall n m p : Z, 0 <= p -> n <= m -> n * p <= m * p. -Proof NZmul_le_mono_nonneg_r. - -Theorem Zmul_le_mono_nonpos_r : forall n m p : Z, p <= 0 -> n <= m -> m * p <= n * p. -Proof NZmul_le_mono_nonpos_r. - -Theorem Zmul_cancel_l : forall n m p : Z, p ~= 0 -> (p * n == p * m <-> n == m). -Proof NZmul_cancel_l. - -Theorem Zmul_cancel_r : forall n m p : Z, p ~= 0 -> (n * p == m * p <-> n == m). -Proof NZmul_cancel_r. - -Theorem Zmul_id_l : forall n m : Z, m ~= 0 -> (n * m == m <-> n == 1). -Proof NZmul_id_l. - -Theorem Zmul_id_r : forall n m : Z, n ~= 0 -> (n * m == n <-> m == 1). -Proof NZmul_id_r. - -Theorem Zmul_le_mono_pos_l : forall n m p : Z, 0 < p -> (n <= m <-> p * n <= p * m). -Proof NZmul_le_mono_pos_l. - -Theorem Zmul_le_mono_pos_r : forall n m p : Z, 0 < p -> (n <= m <-> n * p <= m * p). -Proof NZmul_le_mono_pos_r. - -Theorem Zmul_le_mono_neg_l : forall n m p : Z, p < 0 -> (n <= m <-> p * m <= p * n). -Proof NZmul_le_mono_neg_l. - -Theorem Zmul_le_mono_neg_r : forall n m p : Z, p < 0 -> (n <= m <-> m * p <= n * p). -Proof NZmul_le_mono_neg_r. - -Theorem Zmul_lt_mono_nonneg : - forall n m p q : Z, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q. -Proof NZmul_lt_mono_nonneg. - -Theorem Zmul_lt_mono_nonpos : - forall n m p q : Z, m <= 0 -> n < m -> q <= 0 -> p < q -> m * q < n * p. +Theorem mul_lt_mono_nonpos : + forall n m p q, m <= 0 -> n < m -> q <= 0 -> p < q -> m * q < n * p. Proof. intros n m p q H1 H2 H3 H4. -apply Zle_lt_trans with (m * p). -apply Zmul_le_mono_nonpos_l; [assumption | now apply Zlt_le_incl]. -apply -> Zmul_lt_mono_neg_r; [assumption | now apply Zlt_le_trans with q]. +apply le_lt_trans with (m * p). +apply mul_le_mono_nonpos_l; [assumption | now apply lt_le_incl]. +apply -> mul_lt_mono_neg_r; [assumption | now apply lt_le_trans with q]. Qed. -Theorem Zmul_le_mono_nonneg : - forall n m p q : Z, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q. -Proof NZmul_le_mono_nonneg. - -Theorem Zmul_le_mono_nonpos : - forall n m p q : Z, m <= 0 -> n <= m -> q <= 0 -> p <= q -> m * q <= n * p. +Theorem mul_le_mono_nonpos : + forall n m p q, m <= 0 -> n <= m -> q <= 0 -> p <= q -> m * q <= n * p. Proof. intros n m p q H1 H2 H3 H4. -apply Zle_trans with (m * p). -now apply Zmul_le_mono_nonpos_l. -apply Zmul_le_mono_nonpos_r; [now apply Zle_trans with q | assumption]. -Qed. - -Theorem Zmul_pos_pos : forall n m : Z, 0 < n -> 0 < m -> 0 < n * m. -Proof NZmul_pos_pos. - -Theorem Zmul_neg_neg : forall n m : Z, n < 0 -> m < 0 -> 0 < n * m. -Proof NZmul_neg_neg. - -Theorem Zmul_pos_neg : forall n m : Z, 0 < n -> m < 0 -> n * m < 0. -Proof NZmul_pos_neg. - -Theorem Zmul_neg_pos : forall n m : Z, n < 0 -> 0 < m -> n * m < 0. -Proof NZmul_neg_pos. - -Theorem Zmul_nonneg_nonneg : forall n m : Z, 0 <= n -> 0 <= m -> 0 <= n * m. -Proof. -intros n m H1 H2. -rewrite <- (Zmul_0_l m). now apply Zmul_le_mono_nonneg_r. +apply le_trans with (m * p). +now apply mul_le_mono_nonpos_l. +apply mul_le_mono_nonpos_r; [now apply le_trans with q | assumption]. Qed. -Theorem Zmul_nonpos_nonpos : forall n m : Z, n <= 0 -> m <= 0 -> 0 <= n * m. +Theorem mul_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> 0 <= n * m. Proof. intros n m H1 H2. -rewrite <- (Zmul_0_l m). now apply Zmul_le_mono_nonpos_r. +rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r. Qed. -Theorem Zmul_nonneg_nonpos : forall n m : Z, 0 <= n -> m <= 0 -> n * m <= 0. +Theorem mul_nonneg_nonpos : forall n m, 0 <= n -> m <= 0 -> n * m <= 0. Proof. intros n m H1 H2. -rewrite <- (Zmul_0_l m). now apply Zmul_le_mono_nonpos_r. +rewrite <- (mul_0_l m). now apply mul_le_mono_nonpos_r. Qed. -Theorem Zmul_nonpos_nonneg : forall n m : Z, n <= 0 -> 0 <= m -> n * m <= 0. +Theorem mul_nonpos_nonneg : forall n m, n <= 0 -> 0 <= m -> n * m <= 0. Proof. -intros; rewrite Zmul_comm; now apply Zmul_nonneg_nonpos. +intros; rewrite mul_comm; now apply mul_nonneg_nonpos. Qed. -Theorem Zlt_1_mul_pos : forall n m : Z, 1 < n -> 0 < m -> 1 < n * m. -Proof NZlt_1_mul_pos. - -Theorem Zeq_mul_0 : forall n m : Z, n * m == 0 <-> n == 0 \/ m == 0. -Proof NZeq_mul_0. - -Theorem Zneq_mul_0 : forall n m : Z, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. -Proof NZneq_mul_0. - -Theorem Zeq_square_0 : forall n : Z, n * n == 0 <-> n == 0. -Proof NZeq_square_0. +Notation mul_pos := lt_0_mul (only parsing). -Theorem Zeq_mul_0_l : forall n m : Z, n * m == 0 -> m ~= 0 -> n == 0. -Proof NZeq_mul_0_l. - -Theorem Zeq_mul_0_r : forall n m : Z, n * m == 0 -> n ~= 0 -> m == 0. -Proof NZeq_mul_0_r. - -Theorem Zlt_0_mul : forall n m : Z, 0 < n * m <-> 0 < n /\ 0 < m \/ m < 0 /\ n < 0. -Proof NZlt_0_mul. - -Notation Zmul_pos := Zlt_0_mul (only parsing). - -Theorem Zlt_mul_0 : - forall n m : Z, n * m < 0 <-> n < 0 /\ m > 0 \/ n > 0 /\ m < 0. +Theorem lt_mul_0 : + forall n m, n * m < 0 <-> n < 0 /\ m > 0 \/ n > 0 /\ m < 0. Proof. intros n m; split; [intro H | intros [[H1 H2] | [H1 H2]]]. -destruct (Zlt_trichotomy n 0) as [H1 | [H1 | H1]]; -[| rewrite H1 in H; rewrite Zmul_0_l in H; false_hyp H Zlt_irrefl |]; -(destruct (Zlt_trichotomy m 0) as [H2 | [H2 | H2]]; -[| rewrite H2 in H; rewrite Zmul_0_r in H; false_hyp H Zlt_irrefl |]); +destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; +[| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; +(destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; +[| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); try (left; now split); try (right; now split). -assert (H3 : n * m > 0) by now apply Zmul_neg_neg. -elimtype False; now apply (Zlt_asymm (n * m) 0). -assert (H3 : n * m > 0) by now apply Zmul_pos_pos. -elimtype False; now apply (Zlt_asymm (n * m) 0). -now apply Zmul_neg_pos. now apply Zmul_pos_neg. +assert (H3 : n * m > 0) by now apply mul_neg_neg. +exfalso; now apply (lt_asymm (n * m) 0). +assert (H3 : n * m > 0) by now apply mul_pos_pos. +exfalso; now apply (lt_asymm (n * m) 0). +now apply mul_neg_pos. now apply mul_pos_neg. Qed. -Notation Zmul_neg := Zlt_mul_0 (only parsing). +Notation mul_neg := lt_mul_0 (only parsing). -Theorem Zle_0_mul : - forall n m : Z, 0 <= n * m -> 0 <= n /\ 0 <= m \/ n <= 0 /\ m <= 0. +Theorem le_0_mul : + forall n m, 0 <= n * m -> 0 <= n /\ 0 <= m \/ n <= 0 /\ m <= 0. Proof. -assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_sym). -intros n m. repeat rewrite Zlt_eq_cases. repeat rewrite R. -rewrite Zlt_0_mul, Zeq_mul_0. -pose proof (Zlt_trichotomy n 0); pose proof (Zlt_trichotomy m 0). tauto. +assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym). +intros n m. repeat rewrite lt_eq_cases. repeat rewrite R. +rewrite lt_0_mul, eq_mul_0. +pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto. Qed. -Notation Zmul_nonneg := Zle_0_mul (only parsing). +Notation mul_nonneg := le_0_mul (only parsing). -Theorem Zle_mul_0 : - forall n m : Z, n * m <= 0 -> 0 <= n /\ m <= 0 \/ n <= 0 /\ 0 <= m. +Theorem le_mul_0 : + forall n m, n * m <= 0 -> 0 <= n /\ m <= 0 \/ n <= 0 /\ 0 <= m. Proof. -assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_sym). -intros n m. repeat rewrite Zlt_eq_cases. repeat rewrite R. -rewrite Zlt_mul_0, Zeq_mul_0. -pose proof (Zlt_trichotomy n 0); pose proof (Zlt_trichotomy m 0). tauto. +assert (R : forall n, 0 == n <-> n == 0) by (intros; split; apply eq_sym). +intros n m. repeat rewrite lt_eq_cases. repeat rewrite R. +rewrite lt_mul_0, eq_mul_0. +pose proof (lt_trichotomy n 0); pose proof (lt_trichotomy m 0). tauto. Qed. -Notation Zmul_nonpos := Zle_mul_0 (only parsing). +Notation mul_nonpos := le_mul_0 (only parsing). -Theorem Zle_0_square : forall n : Z, 0 <= n * n. +Theorem le_0_square : forall n, 0 <= n * n. Proof. -intro n; destruct (Zneg_nonneg_cases n). -apply Zlt_le_incl; now apply Zmul_neg_neg. -now apply Zmul_nonneg_nonneg. +intro n; destruct (neg_nonneg_cases n). +apply lt_le_incl; now apply mul_neg_neg. +now apply mul_nonneg_nonneg. Qed. -Notation Zsquare_nonneg := Zle_0_square (only parsing). +Notation square_nonneg := le_0_square (only parsing). -Theorem Znlt_square_0 : forall n : Z, ~ n * n < 0. +Theorem nlt_square_0 : forall n, ~ n * n < 0. Proof. -intros n H. apply -> Zlt_nge in H. apply H. apply Zsquare_nonneg. +intros n H. apply -> lt_nge in H. apply H. apply square_nonneg. Qed. -Theorem Zsquare_lt_mono_nonneg : forall n m : Z, 0 <= n -> n < m -> n * n < m * m. -Proof NZsquare_lt_mono_nonneg. - -Theorem Zsquare_lt_mono_nonpos : forall n m : Z, n <= 0 -> m < n -> n * n < m * m. +Theorem square_lt_mono_nonpos : forall n m, n <= 0 -> m < n -> n * n < m * m. Proof. -intros n m H1 H2. now apply Zmul_lt_mono_nonpos. +intros n m H1 H2. now apply mul_lt_mono_nonpos. Qed. -Theorem Zsquare_le_mono_nonneg : forall n m : Z, 0 <= n -> n <= m -> n * n <= m * m. -Proof NZsquare_le_mono_nonneg. - -Theorem Zsquare_le_mono_nonpos : forall n m : Z, n <= 0 -> m <= n -> n * n <= m * m. +Theorem square_le_mono_nonpos : forall n m, n <= 0 -> m <= n -> n * n <= m * m. Proof. -intros n m H1 H2. now apply Zmul_le_mono_nonpos. +intros n m H1 H2. now apply mul_le_mono_nonpos. Qed. -Theorem Zsquare_lt_simpl_nonneg : forall n m : Z, 0 <= m -> n * n < m * m -> n < m. -Proof NZsquare_lt_simpl_nonneg. - -Theorem Zsquare_le_simpl_nonneg : forall n m : Z, 0 <= m -> n * n <= m * m -> n <= m. -Proof NZsquare_le_simpl_nonneg. - -Theorem Zsquare_lt_simpl_nonpos : forall n m : Z, m <= 0 -> n * n < m * m -> m < n. +Theorem square_lt_simpl_nonpos : forall n m, m <= 0 -> n * n < m * m -> m < n. Proof. -intros n m H1 H2. destruct (Zle_gt_cases n 0). -destruct (NZlt_ge_cases m n). -assumption. assert (F : m * m <= n * n) by now apply Zsquare_le_mono_nonpos. -apply -> NZle_ngt in F. false_hyp H2 F. -now apply Zle_lt_trans with 0. +intros n m H1 H2. destruct (le_gt_cases n 0). +destruct (lt_ge_cases m n). +assumption. assert (F : m * m <= n * n) by now apply square_le_mono_nonpos. +apply -> le_ngt in F. false_hyp H2 F. +now apply le_lt_trans with 0. Qed. -Theorem Zsquare_le_simpl_nonpos : forall n m : NZ, m <= 0 -> n * n <= m * m -> m <= n. +Theorem square_le_simpl_nonpos : forall n m, m <= 0 -> n * n <= m * m -> m <= n. Proof. -intros n m H1 H2. destruct (NZle_gt_cases n 0). -destruct (NZle_gt_cases m n). -assumption. assert (F : m * m < n * n) by now apply Zsquare_lt_mono_nonpos. -apply -> NZlt_nge in F. false_hyp H2 F. -apply Zlt_le_incl; now apply NZle_lt_trans with 0. +intros n m H1 H2. destruct (le_gt_cases n 0). +destruct (le_gt_cases m n). +assumption. assert (F : m * m < n * n) by now apply square_lt_mono_nonpos. +apply -> lt_nge in F. false_hyp H2 F. +apply lt_le_incl; now apply le_lt_trans with 0. Qed. -Theorem Zmul_2_mono_l : forall n m : Z, n < m -> 1 + (1 + 1) * n < (1 + 1) * m. -Proof NZmul_2_mono_l. - -Theorem Zlt_1_mul_neg : forall n m : Z, n < -1 -> m < 0 -> 1 < n * m. +Theorem lt_1_mul_neg : forall n m, n < -1 -> m < 0 -> 1 < n * m. Proof. -intros n m H1 H2. apply -> (NZmul_lt_mono_neg_r m) in H1. -apply <- Zopp_pos_neg in H2. rewrite Zmul_opp_l, Zmul_1_l in H1. -now apply Zlt_1_l with (- m). +intros n m H1 H2. apply -> (mul_lt_mono_neg_r m) in H1. +apply <- opp_pos_neg in H2. rewrite mul_opp_l, mul_1_l in H1. +now apply lt_1_l with (- m). assumption. Qed. -Theorem Zlt_mul_n1_neg : forall n m : Z, 1 < n -> m < 0 -> n * m < -1. +Theorem lt_mul_n1_neg : forall n m, 1 < n -> m < 0 -> n * m < -1. Proof. -intros n m H1 H2. apply -> (NZmul_lt_mono_neg_r m) in H1. -rewrite Zmul_1_l in H1. now apply Zlt_n1_r with m. +intros n m H1 H2. apply -> (mul_lt_mono_neg_r m) in H1. +rewrite mul_1_l in H1. now apply lt_n1_r with m. assumption. Qed. -Theorem Zlt_mul_n1_pos : forall n m : Z, n < -1 -> 0 < m -> n * m < -1. +Theorem lt_mul_n1_pos : forall n m, n < -1 -> 0 < m -> n * m < -1. Proof. -intros n m H1 H2. apply -> (NZmul_lt_mono_pos_r m) in H1. -rewrite Zmul_opp_l, Zmul_1_l in H1. -apply <- Zopp_neg_pos in H2. now apply Zlt_n1_r with (- m). +intros n m H1 H2. apply -> (mul_lt_mono_pos_r m) in H1. +rewrite mul_opp_l, mul_1_l in H1. +apply <- opp_neg_pos in H2. now apply lt_n1_r with (- m). assumption. Qed. -Theorem Zlt_1_mul_l : forall n m : Z, 1 < n -> n * m < -1 \/ n * m == 0 \/ 1 < n * m. +Theorem lt_1_mul_l : forall n m, 1 < n -> + n * m < -1 \/ n * m == 0 \/ 1 < n * m. Proof. -intros n m H; destruct (Zlt_trichotomy m 0) as [H1 | [H1 | H1]]. -left. now apply Zlt_mul_n1_neg. -right; left; now rewrite H1, Zmul_0_r. -right; right; now apply Zlt_1_mul_pos. +intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]]. +left. now apply lt_mul_n1_neg. +right; left; now rewrite H1, mul_0_r. +right; right; now apply lt_1_mul_pos. Qed. -Theorem Zlt_n1_mul_r : forall n m : Z, n < -1 -> n * m < -1 \/ n * m == 0 \/ 1 < n * m. +Theorem lt_n1_mul_r : forall n m, n < -1 -> + n * m < -1 \/ n * m == 0 \/ 1 < n * m. Proof. -intros n m H; destruct (Zlt_trichotomy m 0) as [H1 | [H1 | H1]]. -right; right. now apply Zlt_1_mul_neg. -right; left; now rewrite H1, Zmul_0_r. -left. now apply Zlt_mul_n1_pos. +intros n m H; destruct (lt_trichotomy m 0) as [H1 | [H1 | H1]]. +right; right. now apply lt_1_mul_neg. +right; left; now rewrite H1, mul_0_r. +left. now apply lt_mul_n1_pos. Qed. -Theorem Zeq_mul_1 : forall n m : Z, n * m == 1 -> n == 1 \/ n == -1. +Theorem eq_mul_1 : forall n m, n * m == 1 -> n == 1 \/ n == -1. Proof. assert (F : ~ 1 < -1). intro H. -assert (H1 : -1 < 0). apply <- Zopp_neg_pos. apply Zlt_succ_diag_r. -assert (H2 : 1 < 0) by now apply Zlt_trans with (-1). false_hyp H2 Znlt_succ_diag_l. -Z0_pos_neg n. -intros m H; rewrite Zmul_0_l in H; false_hyp H Zneq_succ_diag_r. -intros n H; split; apply <- Zle_succ_l in H; le_elim H. -intros m H1; apply (Zlt_1_mul_l n m) in H. +assert (H1 : -1 < 0). apply <- opp_neg_pos. apply lt_succ_diag_r. +assert (H2 : 1 < 0) by now apply lt_trans with (-1). +false_hyp H2 nlt_succ_diag_l. +zero_pos_neg n. +intros m H; rewrite mul_0_l in H; false_hyp H neq_succ_diag_r. +intros n H; split; apply <- le_succ_l in H; le_elim H. +intros m H1; apply (lt_1_mul_l n m) in H. rewrite H1 in H; destruct H as [H | [H | H]]. -false_hyp H F. false_hyp H Zneq_succ_diag_l. false_hyp H Zlt_irrefl. +false_hyp H F. false_hyp H neq_succ_diag_l. false_hyp H lt_irrefl. intros; now left. -intros m H1; apply (Zlt_1_mul_l n m) in H. rewrite Zmul_opp_l in H1; -apply -> Zeq_opp_l in H1. rewrite H1 in H; destruct H as [H | [H | H]]. -false_hyp H Zlt_irrefl. apply -> Zeq_opp_l in H. rewrite Zopp_0 in H. -false_hyp H Zneq_succ_diag_l. false_hyp H F. -intros; right; symmetry; now apply Zopp_wd. +intros m H1; apply (lt_1_mul_l n m) in H. rewrite mul_opp_l in H1; +apply -> eq_opp_l in H1. rewrite H1 in H; destruct H as [H | [H | H]]. +false_hyp H lt_irrefl. apply -> eq_opp_l in H. rewrite opp_0 in H. +false_hyp H neq_succ_diag_l. false_hyp H F. +intros; right; symmetry; now apply opp_wd. Qed. -Theorem Zlt_mul_diag_l : forall n m : Z, n < 0 -> (1 < m <-> n * m < n). +Theorem lt_mul_diag_l : forall n m, n < 0 -> (1 < m <-> n * m < n). Proof. -intros n m H. stepr (n * m < n * 1) by now rewrite Zmul_1_r. -now apply Zmul_lt_mono_neg_l. +intros n m H. stepr (n * m < n * 1) by now rewrite mul_1_r. +now apply mul_lt_mono_neg_l. Qed. -Theorem Zlt_mul_diag_r : forall n m : Z, 0 < n -> (1 < m <-> n < n * m). +Theorem lt_mul_diag_r : forall n m, 0 < n -> (1 < m <-> n < n * m). Proof. -intros n m H. stepr (n * 1 < n * m) by now rewrite Zmul_1_r. -now apply Zmul_lt_mono_pos_l. +intros n m H. stepr (n * 1 < n * m) by now rewrite mul_1_r. +now apply mul_lt_mono_pos_l. Qed. -Theorem Zle_mul_diag_l : forall n m : Z, n < 0 -> (1 <= m <-> n * m <= n). +Theorem le_mul_diag_l : forall n m, n < 0 -> (1 <= m <-> n * m <= n). Proof. -intros n m H. stepr (n * m <= n * 1) by now rewrite Zmul_1_r. -now apply Zmul_le_mono_neg_l. +intros n m H. stepr (n * m <= n * 1) by now rewrite mul_1_r. +now apply mul_le_mono_neg_l. Qed. -Theorem Zle_mul_diag_r : forall n m : Z, 0 < n -> (1 <= m <-> n <= n * m). +Theorem le_mul_diag_r : forall n m, 0 < n -> (1 <= m <-> n <= n * m). Proof. -intros n m H. stepr (n * 1 <= n * m) by now rewrite Zmul_1_r. -now apply Zmul_le_mono_pos_l. +intros n m H. stepr (n * 1 <= n * m) by now rewrite mul_1_r. +now apply mul_le_mono_pos_l. Qed. -Theorem Zlt_mul_r : forall n m p : Z, 0 < n -> 1 < p -> n < m -> n < m * p. +Theorem lt_mul_r : forall n m p, 0 < n -> 1 < p -> n < m -> n < m * p. Proof. -intros. stepl (n * 1) by now rewrite Zmul_1_r. -apply Zmul_lt_mono_nonneg. -now apply Zlt_le_incl. assumption. apply Zle_0_1. assumption. +intros. stepl (n * 1) by now rewrite mul_1_r. +apply mul_lt_mono_nonneg. +now apply lt_le_incl. assumption. apply le_0_1. assumption. Qed. End ZMulOrderPropFunct. diff --git a/theories/Numbers/Integer/Abstract/ZProperties.v b/theories/Numbers/Integer/Abstract/ZProperties.v new file mode 100644 index 00000000..dc46edda --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZProperties.v @@ -0,0 +1,24 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t. + Axiom abs_eq : forall n, 0<=n -> abs n == n. + Axiom abs_neq : forall n, n<=0 -> abs n == -n. +End HasAbs. + +(** Since we already have [max], we could have defined [abs]. *) + +Module GenericAbs (Import Z : ZAxiomsSig') + (Import ZP : ZMulOrderPropFunct Z) <: HasAbs Z. + Definition abs n := max n (-n). + Lemma abs_eq : forall n, 0<=n -> abs n == n. + Proof. + intros. unfold abs. apply max_l. + apply le_trans with 0; auto. + rewrite opp_nonpos_nonneg; auto. + Qed. + Lemma abs_neq : forall n, n<=0 -> abs n == -n. + Proof. + intros. unfold abs. apply max_r. + apply le_trans with 0; auto. + rewrite opp_nonneg_nonpos; auto. + Qed. +End GenericAbs. + +(** An Axiomatization of [sgn]. *) + +Module Type HasSgn (Import Z : ZAxiomsSig'). + Parameter Inline sgn : t -> t. + Axiom sgn_null : forall n, n==0 -> sgn n == 0. + Axiom sgn_pos : forall n, 0 sgn n == 1. + Axiom sgn_neg : forall n, n<0 -> sgn n == -(1). +End HasSgn. + +(** We can deduce a [sgn] function from a [compare] function *) + +Module Type ZDecAxiomsSig := ZAxiomsSig <+ HasCompare. +Module Type ZDecAxiomsSig' := ZAxiomsSig' <+ HasCompare. + +Module Type GenericSgn (Import Z : ZDecAxiomsSig') + (Import ZP : ZMulOrderPropFunct Z) <: HasSgn Z. + Definition sgn n := + match compare 0 n with Eq => 0 | Lt => 1 | Gt => -(1) end. + Lemma sgn_null : forall n, n==0 -> sgn n == 0. + Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. + Lemma sgn_pos : forall n, 0 sgn n == 1. + Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. + Lemma sgn_neg : forall n, n<0 -> sgn n == -(1). + Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. +End GenericSgn. + +Module Type ZAxiomsExtSig := ZAxiomsSig <+ HasAbs <+ HasSgn. +Module Type ZAxiomsExtSig' := ZAxiomsSig' <+ HasAbs <+ HasSgn. + +Module Type ZSgnAbsPropSig (Import Z : ZAxiomsExtSig') + (Import ZP : ZMulOrderPropFunct Z). + +Ltac destruct_max n := + destruct (le_ge_cases 0 n); + [rewrite (abs_eq n) by auto | rewrite (abs_neq n) by auto]. + +Instance abs_wd : Proper (eq==>eq) abs. +Proof. + intros x y EQ. destruct_max x. + rewrite abs_eq; trivial. now rewrite <- EQ. + rewrite abs_neq; try order. now rewrite opp_inj_wd. +Qed. + +Lemma abs_max : forall n, abs n == max n (-n). +Proof. + intros n. destruct_max n. + rewrite max_l; auto with relations. + apply le_trans with 0; auto. + rewrite opp_nonpos_nonneg; auto. + rewrite max_r; auto with relations. + apply le_trans with 0; auto. + rewrite opp_nonneg_nonpos; auto. +Qed. + +Lemma abs_neq' : forall n, 0<=-n -> abs n == -n. +Proof. + intros. apply abs_neq. now rewrite <- opp_nonneg_nonpos. +Qed. + +Lemma abs_nonneg : forall n, 0 <= abs n. +Proof. + intros n. destruct_max n; auto. + now rewrite opp_nonneg_nonpos. +Qed. + +Lemma abs_eq_iff : forall n, abs n == n <-> 0<=n. +Proof. + split; try apply abs_eq. intros EQ. + rewrite <- EQ. apply abs_nonneg. +Qed. + +Lemma abs_neq_iff : forall n, abs n == -n <-> n<=0. +Proof. + split; try apply abs_neq. intros EQ. + rewrite <- opp_nonneg_nonpos, <- EQ. apply abs_nonneg. +Qed. + +Lemma abs_opp : forall n, abs (-n) == abs n. +Proof. + intros. destruct_max n. + rewrite (abs_neq (-n)), opp_involutive. reflexivity. + now rewrite opp_nonpos_nonneg. + rewrite (abs_eq (-n)). reflexivity. + now rewrite opp_nonneg_nonpos. +Qed. + +Lemma abs_0 : abs 0 == 0. +Proof. + apply abs_eq. apply le_refl. +Qed. + +Lemma abs_0_iff : forall n, abs n == 0 <-> n==0. +Proof. + split. destruct_max n; auto. + now rewrite eq_opp_l, opp_0. + intros EQ; rewrite EQ. rewrite abs_eq; auto using eq_refl, le_refl. +Qed. + +Lemma abs_pos : forall n, 0 < abs n <-> n~=0. +Proof. + intros. rewrite <- abs_0_iff. split; [intros LT| intros NEQ]. + intro EQ. rewrite EQ in LT. now elim (lt_irrefl 0). + assert (LE : 0 <= abs n) by apply abs_nonneg. + rewrite lt_eq_cases in LE; destruct LE; auto. + elim NEQ; auto with relations. +Qed. + +Lemma abs_eq_or_opp : forall n, abs n == n \/ abs n == -n. +Proof. + intros. destruct_max n; auto with relations. +Qed. + +Lemma abs_or_opp_abs : forall n, n == abs n \/ n == - abs n. +Proof. + intros. destruct_max n; rewrite ? opp_involutive; auto with relations. +Qed. + +Lemma abs_involutive : forall n, abs (abs n) == abs n. +Proof. + intros. apply abs_eq. apply abs_nonneg. +Qed. + +Lemma abs_spec : forall n, + (0 <= n /\ abs n == n) \/ (n < 0 /\ abs n == -n). +Proof. + intros. destruct (le_gt_cases 0 n). + left; split; auto. now apply abs_eq. + right; split; auto. apply abs_neq. now apply lt_le_incl. +Qed. + +Lemma abs_case_strong : + forall (P:t->Prop) n, Proper (eq==>iff) P -> + (0<=n -> P n) -> (n<=0 -> P (-n)) -> P (abs n). +Proof. + intros. destruct_max n; auto. +Qed. + +Lemma abs_case : forall (P:t->Prop) n, Proper (eq==>iff) P -> + P n -> P (-n) -> P (abs n). +Proof. intros. now apply abs_case_strong. Qed. + +Lemma abs_eq_cases : forall n m, abs n == abs m -> n == m \/ n == - m. +Proof. + intros n m EQ. destruct (abs_or_opp_abs n) as [EQn|EQn]. + rewrite EQn, EQ. apply abs_eq_or_opp. + rewrite EQn, EQ, opp_inj_wd, eq_opp_l, or_comm. apply abs_eq_or_opp. +Qed. + +(** Triangular inequality *) + +Lemma abs_triangle : forall n m, abs (n + m) <= abs n + abs m. +Proof. + intros. destruct_max n; destruct_max m. + rewrite abs_eq. apply le_refl. now apply add_nonneg_nonneg. + destruct_max (n+m); try rewrite opp_add_distr; + apply add_le_mono_l || apply add_le_mono_r. + apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos. + apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg. + destruct_max (n+m); try rewrite opp_add_distr; + apply add_le_mono_l || apply add_le_mono_r. + apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos. + apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg. + rewrite abs_neq, opp_add_distr. apply le_refl. + now apply add_nonpos_nonpos. +Qed. + +Lemma abs_sub_triangle : forall n m, abs n - abs m <= abs (n-m). +Proof. + intros. + rewrite le_sub_le_add_l, add_comm. + rewrite <- (sub_simpl_r n m) at 1. + apply abs_triangle. +Qed. + +(** Absolute value and multiplication *) + +Lemma abs_mul : forall n m, abs (n * m) == abs n * abs m. +Proof. + assert (H : forall n m, 0<=n -> abs (n*m) == n * abs m). + intros. destruct_max m. + rewrite abs_eq. apply eq_refl. now apply mul_nonneg_nonneg. + rewrite abs_neq, mul_opp_r. reflexivity. now apply mul_nonneg_nonpos . + intros. destruct_max n. now apply H. + rewrite <- mul_opp_opp, H, abs_opp. reflexivity. + now apply opp_nonneg_nonpos. +Qed. + +Lemma abs_square : forall n, abs n * abs n == n * n. +Proof. + intros. rewrite <- abs_mul. apply abs_eq. apply le_0_square. +Qed. + +(** Some results about the sign function. *) + +Ltac destruct_sgn n := + let LT := fresh "LT" in + let EQ := fresh "EQ" in + let GT := fresh "GT" in + destruct (lt_trichotomy 0 n) as [LT|[EQ|GT]]; + [rewrite (sgn_pos n) by auto| + rewrite (sgn_null n) by auto with relations| + rewrite (sgn_neg n) by auto]. + +Instance sgn_wd : Proper (eq==>eq) sgn. +Proof. + intros x y Hxy. destruct_sgn x. + rewrite sgn_pos; auto with relations. rewrite <- Hxy; auto. + rewrite sgn_null; auto with relations. rewrite <- Hxy; auto with relations. + rewrite sgn_neg; auto with relations. rewrite <- Hxy; auto. +Qed. + +Lemma sgn_spec : forall n, + 0 < n /\ sgn n == 1 \/ + 0 == n /\ sgn n == 0 \/ + 0 > n /\ sgn n == -(1). +Proof. + intros n. + destruct_sgn n; [left|right;left|right;right]; auto with relations. +Qed. + +Lemma sgn_0 : sgn 0 == 0. +Proof. + now apply sgn_null. +Qed. + +Lemma sgn_pos_iff : forall n, sgn n == 1 <-> 0 n==0. +Proof. + split; try apply sgn_null. destruct_sgn n; auto with relations. + intros. elim (lt_neq 0 1); auto with relations. apply lt_0_1. + intros. elim (lt_neq (-(1)) 0); auto. + rewrite opp_neg_pos. apply lt_0_1. +Qed. + +Lemma sgn_neg_iff : forall n, sgn n == -(1) <-> n<0. +Proof. + split; try apply sgn_neg. destruct_sgn n; auto with relations. + intros. elim (lt_neq (-(1)) 1); auto with relations. + apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1. + intros. elim (lt_neq (-(1)) 0); auto with relations. + rewrite opp_neg_pos. apply lt_0_1. +Qed. + +Lemma sgn_opp : forall n, sgn (-n) == - sgn n. +Proof. + intros. destruct_sgn n. + apply sgn_neg. now rewrite opp_neg_pos. + setoid_replace n with 0 by auto with relations. + rewrite opp_0. apply sgn_0. + rewrite opp_involutive. apply sgn_pos. now rewrite opp_pos_neg. +Qed. + +Lemma sgn_nonneg : forall n, 0 <= sgn n <-> 0 <= n. +Proof. + split. + destruct_sgn n; intros. + now apply lt_le_incl. + order. + elim (lt_irrefl 0). apply lt_le_trans with 1; auto using lt_0_1. + now rewrite <- opp_nonneg_nonpos. + rewrite lt_eq_cases; destruct 1. + rewrite sgn_pos by auto. apply lt_le_incl, lt_0_1. + rewrite sgn_null by auto with relations. apply le_refl. +Qed. + +Lemma sgn_nonpos : forall n, sgn n <= 0 <-> n <= 0. +Proof. + intros. rewrite <- 2 opp_nonneg_nonpos, <- sgn_opp. apply sgn_nonneg. +Qed. + +Lemma sgn_mul : forall n m, sgn (n*m) == sgn n * sgn m. +Proof. + intros. destruct_sgn n; nzsimpl. + destruct_sgn m. + apply sgn_pos. now apply mul_pos_pos. + apply sgn_null. rewrite eq_mul_0; auto with relations. + apply sgn_neg. now apply mul_pos_neg. + apply sgn_null. rewrite eq_mul_0; auto with relations. + destruct_sgn m; try rewrite mul_opp_opp; nzsimpl. + apply sgn_neg. now apply mul_neg_pos. + apply sgn_null. rewrite eq_mul_0; auto with relations. + apply sgn_pos. now apply mul_neg_neg. +Qed. + +Lemma sgn_abs : forall n, n * sgn n == abs n. +Proof. + intros. symmetry. + destruct_sgn n; try rewrite mul_opp_r; nzsimpl. + apply abs_eq. now apply lt_le_incl. + rewrite abs_0_iff; auto with relations. + apply abs_neq. now apply lt_le_incl. +Qed. + +Lemma abs_sgn : forall n, abs n * sgn n == n. +Proof. + intros. + destruct_sgn n; try rewrite mul_opp_r; nzsimpl; auto. + apply abs_eq. now apply lt_le_incl. + rewrite eq_opp_l. apply abs_neq. now apply lt_le_incl. +Qed. + +End ZSgnAbsPropSig. + + diff --git a/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v index e5e950ac..4e024c02 100644 --- a/theories/Numbers/Integer/BigZ/BigZ.v +++ b/theories/Numbers/Integer/BigZ/BigZ.v @@ -8,20 +8,31 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: BigZ.v 11576 2008-11-10 19:13:15Z msozeau $ i*) +(*i $Id$ i*) Require Export BigN. -Require Import ZMulOrder. -Require Import ZSig. -Require Import ZSigZAxioms. -Require Import ZMake. +Require Import ZProperties ZDivFloor ZSig ZSigZAxioms ZMake. -Module BigZ <: ZType := ZMake.Make BigN. +(** * [BigZ] : arbitrary large efficient integers. -(** Module [BigZ] implements [ZAxiomsSig] *) + The following [BigZ] module regroups both the operations and + all the abstract properties: -Module Export BigZAxiomsMod := ZSig_ZAxioms BigZ. -Module Export BigZMulOrderPropMod := ZMulOrderPropFunct BigZAxiomsMod. + - [ZMake.Make BigN] provides the operations and basic specs w.r.t. ZArith + - [ZTypeIsZAxioms] shows (mainly) that these operations implement + the interface [ZAxioms] + - [ZPropSig] adds all generic properties derived from [ZAxioms] + - [ZDivPropFunct] provides generic properties of [div] and [mod] + ("Floor" variant) + - [MinMax*Properties] provides properties of [min] and [max] + +*) + + +Module BigZ <: ZType <: OrderedTypeFull <: TotalOrder := + ZMake.Make BigN <+ ZTypeIsZAxioms + <+ !ZPropSig <+ !ZDivPropFunct <+ HasEqBool2Dec + <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties. (** Notations about [BigZ] *) @@ -31,26 +42,60 @@ Delimit Scope bigZ_scope with bigZ. Bind Scope bigZ_scope with bigZ. Bind Scope bigZ_scope with BigZ.t. Bind Scope bigZ_scope with BigZ.t_. - -Notation Local "0" := BigZ.zero : bigZ_scope. +(* Bind Scope has no retroactive effect, let's declare scopes by hand. *) +Arguments Scope BigZ.Pos [bigN_scope]. +Arguments Scope BigZ.Neg [bigN_scope]. +Arguments Scope BigZ.to_Z [bigZ_scope]. +Arguments Scope BigZ.succ [bigZ_scope]. +Arguments Scope BigZ.pred [bigZ_scope]. +Arguments Scope BigZ.opp [bigZ_scope]. +Arguments Scope BigZ.square [bigZ_scope]. +Arguments Scope BigZ.add [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.sub [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.mul [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.div [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.eq [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.lt [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.le [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.eq [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.compare [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.min [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.max [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.eq_bool [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.power_pos [bigZ_scope positive_scope]. +Arguments Scope BigZ.power [bigZ_scope N_scope]. +Arguments Scope BigZ.sqrt [bigZ_scope]. +Arguments Scope BigZ.div_eucl [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.modulo [bigZ_scope bigZ_scope]. +Arguments Scope BigZ.gcd [bigZ_scope bigZ_scope]. + +Local Notation "0" := BigZ.zero : bigZ_scope. +Local Notation "1" := BigZ.one : bigZ_scope. Infix "+" := BigZ.add : bigZ_scope. Infix "-" := BigZ.sub : bigZ_scope. Notation "- x" := (BigZ.opp x) : bigZ_scope. Infix "*" := BigZ.mul : bigZ_scope. Infix "/" := BigZ.div : bigZ_scope. +Infix "^" := BigZ.power : bigZ_scope. Infix "?=" := BigZ.compare : bigZ_scope. Infix "==" := BigZ.eq (at level 70, no associativity) : bigZ_scope. +Notation "x != y" := (~x==y)%bigZ (at level 70, no associativity) : bigZ_scope. Infix "<" := BigZ.lt : bigZ_scope. Infix "<=" := BigZ.le : bigZ_scope. Notation "x > y" := (BigZ.lt y x)(only parsing) : bigZ_scope. Notation "x >= y" := (BigZ.le y x)(only parsing) : bigZ_scope. +Notation "x < y < z" := (x x==y. +Proof. now apply BigZ.eqb_eq. Qed. + +Lemma BigZpower : power_theory 1 BigZ.mul BigZ.eq (@id N) BigZ.power. Proof. -red; intros; zsimpl; auto with zarith. +constructor. +intros. red. rewrite BigZ.spec_power. unfold id. +destruct Zpower_theory as [EQ]. rewrite EQ. +destruct n; simpl. reflexivity. +induction p; simpl; intros; BigZ.zify; rewrite ?IHp; auto. Qed. -(** [BigZ] is a ring *) +Lemma BigZdiv : div_theory BigZ.eq BigZ.add BigZ.mul (@id _) + (fun a b => if BigZ.eq_bool b 0 then (0,a) else BigZ.div_eucl a b). +Proof. +constructor. unfold id. intros a b. +BigZ.zify. +generalize (Zeq_bool_if [b] 0); destruct (Zeq_bool [b] 0). +BigZ.zify. auto with zarith. +intros NEQ. +generalize (BigZ.spec_div_eucl a b). +generalize (Z_div_mod_full [a] [b] NEQ). +destruct BigZ.div_eucl as (q,r), Zdiv_eucl as (q',r'). +intros (EQ,_). injection 1. intros EQr EQq. +BigZ.zify. rewrite EQr, EQq; auto. +Qed. -Lemma BigZring : - ring_theory BigZ.zero BigZ.one BigZ.add BigZ.mul BigZ.sub BigZ.opp BigZ.eq. +(** Detection of constants *) + +Ltac isBigZcst t := + match t with + | BigZ.Pos ?t => isBigNcst t + | BigZ.Neg ?t => isBigNcst t + | BigZ.zero => constr:true + | BigZ.one => constr:true + | BigZ.minus_one => constr:true + | _ => constr:false + end. + +Ltac BigZcst t := + match isBigZcst t with + | true => constr:t + | false => constr:NotConstant + end. + +(** Registration for the "ring" tactic *) + +Add Ring BigZr : BigZring + (decidable BigZeqb_correct, + constants [BigZcst], + power_tac BigZpower [Ncst], + div BigZdiv). + +Section TestRing. +Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x. Proof. -constructor. -exact Zadd_0_l. -exact Zadd_comm. -exact Zadd_assoc. -exact Zmul_1_l. -exact Zmul_comm. -exact Zmul_assoc. -exact Zmul_add_distr_r. -exact sub_opp. -exact add_opp. +intros. ring_simplify. reflexivity. Qed. +Let test' : forall x y, 1 + x*y + x^2 - 1*1 - y*x + 1*(-x)*x == 0. +Proof. +intros. ring_simplify. reflexivity. +Qed. +End TestRing. + +(** [BigZ] also benefits from an "order" tactic *) + +Ltac bigZ_order := BigZ.order. + +Section TestOrder. +Let test : forall x y : bigZ, x<=y -> y<=x -> x==y. +Proof. bigZ_order. Qed. +End TestOrder. -Add Ring BigZr : BigZring. +(** We can use at least a bit of (r)omega by translating to [Z]. *) -(** Todo: tactic translating from [BigZ] to [Z] + omega *) +Section TestOmega. +Let test : forall x y : bigZ, x<=y -> y<=x -> x==y. +Proof. intros x y. BigZ.zify. omega. Qed. +End TestOmega. (** Todo: micromega *) diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v index 98ad4c64..3196f11e 100644 --- a/theories/Numbers/Integer/BigZ/ZMake.v +++ b/theories/Numbers/Integer/BigZ/ZMake.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZMake.v 11576 2008-11-10 19:13:15Z msozeau $ i*) +(*i $Id$ i*) Require Import ZArith. Require Import BigNumPrelude. @@ -17,31 +17,31 @@ Require Import ZSig. Open Scope Z_scope. -(** * ZMake - - A generic transformation from a structure of natural numbers +(** * ZMake + + A generic transformation from a structure of natural numbers [NSig.NType] to a structure of integers [ZSig.ZType]. *) Module Make (N:NType) <: ZType. - - Inductive t_ := + + Inductive t_ := | Pos : N.t -> t_ | Neg : N.t -> t_. - + Definition t := t_. Definition zero := Pos N.zero. Definition one := Pos N.one. Definition minus_one := Neg N.one. - Definition of_Z x := + Definition of_Z x := match x with | Zpos x => Pos (N.of_N (Npos x)) | Z0 => zero | Zneg x => Neg (N.of_N (Npos x)) end. - + Definition to_Z x := match x with | Pos nx => N.to_Z nx @@ -49,6 +49,7 @@ Module Make (N:NType) <: ZType. end. Theorem spec_of_Z: forall x, to_Z (of_Z x) = x. + Proof. intros x; case x; unfold to_Z, of_Z, zero. exact N.spec_0. intros; rewrite N.spec_of_N; auto. @@ -85,72 +86,52 @@ Module Make (N:NType) <: ZType. | Neg nx, Neg ny => N.compare ny nx end. - Definition lt n m := compare n m = Lt. - Definition le n m := compare n m <> Gt. - Definition min n m := match compare n m with Gt => m | _ => n end. - Definition max n m := match compare n m with Lt => m | _ => n end. + Theorem spec_compare : + forall x y, compare x y = Zcompare (to_Z x) (to_Z y). + Proof. + unfold compare, to_Z. + destruct x as [x|x], y as [y|y]; + rewrite ?N.spec_compare, ?N.spec_0, <-?Zcompare_opp; auto; + assert (Hx:=N.spec_pos x); assert (Hy:=N.spec_pos y); + set (X:=N.to_Z x) in *; set (Y:=N.to_Z y) in *; clearbody X Y. + destruct (Zcompare_spec X 0) as [EQ|LT|GT]. + rewrite EQ. rewrite <- Zopp_0 at 2. apply Zcompare_opp. + exfalso. omega. + symmetry. change (X > -Y). omega. + destruct (Zcompare_spec 0 X) as [EQ|LT|GT]. + rewrite <- EQ. rewrite Zopp_0; auto. + symmetry. change (-X < Y). omega. + exfalso. omega. + Qed. - Theorem spec_compare: forall x y, - match compare x y with - Eq => to_Z x = to_Z y - | Lt => to_Z x < to_Z y - | Gt => to_Z x > to_Z y - end. - unfold compare, to_Z; intros x y; case x; case y; clear x y; - intros x y; auto; generalize (N.spec_pos x) (N.spec_pos y). - generalize (N.spec_compare y x); case N.compare; auto with zarith. - generalize (N.spec_compare y N.zero); case N.compare; - try rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare x N.zero); case N.compare; - rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare x N.zero); case N.compare; - rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare N.zero y); case N.compare; - try rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare N.zero x); case N.compare; - rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare N.zero x); case N.compare; - rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare x y); case N.compare; auto with zarith. - Qed. - - Definition eq_bool x y := + Definition eq_bool x y := match compare x y with | Eq => true | _ => false end. - Theorem spec_eq_bool: forall x y, - if eq_bool x y then to_Z x = to_Z y else to_Z x <> to_Z y. - intros x y; unfold eq_bool; - generalize (spec_compare x y); case compare; auto with zarith. + Theorem spec_eq_bool: + forall x y, eq_bool x y = Zeq_bool (to_Z x) (to_Z y). + Proof. + unfold eq_bool, Zeq_bool; intros; rewrite spec_compare; reflexivity. Qed. - Definition cmp_sign x y := - match x, y with - | Pos nx, Neg ny => - if N.eq_bool ny N.zero then Eq else Gt - | Neg nx, Pos ny => - if N.eq_bool nx N.zero then Eq else Lt - | _, _ => Eq - end. + Definition lt n m := to_Z n < to_Z m. + Definition le n m := to_Z n <= to_Z m. + + Definition min n m := match compare n m with Gt => m | _ => n end. + Definition max n m := match compare n m with Lt => m | _ => n end. + + Theorem spec_min : forall n m, to_Z (min n m) = Zmin (to_Z n) (to_Z m). + Proof. + unfold min, Zmin. intros. rewrite spec_compare. destruct Zcompare; auto. + Qed. + + Theorem spec_max : forall n m, to_Z (max n m) = Zmax (to_Z n) (to_Z m). + Proof. + unfold max, Zmax. intros. rewrite spec_compare. destruct Zcompare; auto. + Qed. - Theorem spec_cmp_sign: forall x y, - match cmp_sign x y with - | Gt => 0 <= to_Z x /\ to_Z y < 0 - | Lt => to_Z x < 0 /\ 0 <= to_Z y - | Eq => True - end. - Proof. - intros [x | x] [y | y]; unfold cmp_sign; auto. - generalize (N.spec_eq_bool y N.zero); case N.eq_bool; auto. - rewrite N.spec_0; unfold to_Z. - generalize (N.spec_pos x) (N.spec_pos y); auto with zarith. - generalize (N.spec_eq_bool x N.zero); case N.eq_bool; auto. - rewrite N.spec_0; unfold to_Z. - generalize (N.spec_pos x) (N.spec_pos y); auto with zarith. - Qed. - Definition to_N x := match x with | Pos nx => nx @@ -160,21 +141,23 @@ Module Make (N:NType) <: ZType. Definition abs x := Pos (to_N x). Theorem spec_abs: forall x, to_Z (abs x) = Zabs (to_Z x). + Proof. intros x; case x; clear x; intros x; assert (F:=N.spec_pos x). simpl; rewrite Zabs_eq; auto. simpl; rewrite Zabs_non_eq; simpl; auto with zarith. Qed. - - Definition opp x := - match x with + + Definition opp x := + match x with | Pos nx => Neg nx | Neg nx => Pos nx end. Theorem spec_opp: forall x, to_Z (opp x) = - to_Z x. + Proof. intros x; case x; simpl; auto with zarith. Qed. - + Definition succ x := match x with | Pos n => Pos (N.succ n) @@ -186,12 +169,12 @@ Module Make (N:NType) <: ZType. end. Theorem spec_succ: forall n, to_Z (succ n) = to_Z n + 1. + Proof. intros x; case x; clear x; intros x. exact (N.spec_succ x). - simpl; generalize (N.spec_compare N.zero x); case N.compare; - rewrite N.spec_0; simpl. + simpl. rewrite N.spec_compare. case Zcompare_spec; rewrite ?N.spec_0; simpl. intros HH; rewrite <- HH; rewrite N.spec_1; ring. - intros HH; rewrite N.spec_pred; auto with zarith. + intros HH; rewrite N.spec_pred, Zmax_r; auto with zarith. generalize (N.spec_pos x); auto with zarith. Qed. @@ -212,19 +195,13 @@ Module Make (N:NType) <: ZType. end | Neg nx, Neg ny => Neg (N.add nx ny) end. - + Theorem spec_add: forall x y, to_Z (add x y) = to_Z x + to_Z y. - unfold add, to_Z; intros [x | x] [y | y]. - exact (N.spec_add x y). - unfold zero; generalize (N.spec_compare x y); case N.compare. - rewrite N.spec_0; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - unfold zero; generalize (N.spec_compare x y); case N.compare. - rewrite N.spec_0; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - intros; rewrite N.spec_add; try ring; auto with zarith. + Proof. + unfold add, to_Z; intros [x | x] [y | y]; + try (rewrite N.spec_add; auto with zarith); + rewrite N.spec_compare; case Zcompare_spec; + unfold zero; rewrite ?N.spec_0, ?N.spec_sub; omega with *. Qed. Definition pred x := @@ -238,17 +215,17 @@ Module Make (N:NType) <: ZType. end. Theorem spec_pred: forall x, to_Z (pred x) = to_Z x - 1. - unfold pred, to_Z, minus_one; intros [x | x]. - generalize (N.spec_compare N.zero x); case N.compare; - rewrite N.spec_0; try rewrite N.spec_1; auto with zarith. - intros H; exact (N.spec_pred _ H). - generalize (N.spec_pos x); auto with zarith. - rewrite N.spec_succ; ring. + Proof. + unfold pred, to_Z, minus_one; intros [x | x]; + try (rewrite N.spec_succ; ring). + rewrite N.spec_compare; case Zcompare_spec; + rewrite ?N.spec_0, ?N.spec_1, ?N.spec_pred; + generalize (N.spec_pos x); omega with *. Qed. Definition sub x y := match x, y with - | Pos nx, Pos ny => + | Pos nx, Pos ny => match N.compare nx ny with | Gt => Pos (N.sub nx ny) | Eq => zero @@ -256,7 +233,7 @@ Module Make (N:NType) <: ZType. end | Pos nx, Neg ny => Pos (N.add nx ny) | Neg nx, Pos ny => Neg (N.add nx ny) - | Neg nx, Neg ny => + | Neg nx, Neg ny => match N.compare nx ny with | Gt => Neg (N.sub nx ny) | Eq => zero @@ -265,20 +242,14 @@ Module Make (N:NType) <: ZType. end. Theorem spec_sub: forall x y, to_Z (sub x y) = to_Z x - to_Z y. - unfold sub, to_Z; intros [x | x] [y | y]. - unfold zero; generalize (N.spec_compare x y); case N.compare. - rewrite N.spec_0; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - rewrite N.spec_add; ring. - rewrite N.spec_add; ring. - unfold zero; generalize (N.spec_compare x y); case N.compare. - rewrite N.spec_0; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. + Proof. + unfold sub, to_Z; intros [x | x] [y | y]; + try (rewrite N.spec_add; auto with zarith); + rewrite N.spec_compare; case Zcompare_spec; + unfold zero; rewrite ?N.spec_0, ?N.spec_sub; omega with *. Qed. - Definition mul x y := + Definition mul x y := match x, y with | Pos nx, Pos ny => Pos (N.mul nx ny) | Pos nx, Neg ny => Neg (N.mul nx ny) @@ -286,25 +257,26 @@ Module Make (N:NType) <: ZType. | Neg nx, Neg ny => Pos (N.mul nx ny) end. - Theorem spec_mul: forall x y, to_Z (mul x y) = to_Z x * to_Z y. + Proof. unfold mul, to_Z; intros [x | x] [y | y]; rewrite N.spec_mul; ring. Qed. - Definition square x := + Definition square x := match x with | Pos nx => Pos (N.square nx) | Neg nx => Pos (N.square nx) end. Theorem spec_square: forall x, to_Z (square x) = to_Z x * to_Z x. + Proof. unfold square, to_Z; intros [x | x]; rewrite N.spec_square; ring. Qed. Definition power_pos x p := match x with | Pos nx => Pos (N.power_pos nx p) - | Neg nx => + | Neg nx => match p with | xH => x | xO _ => Pos (N.power_pos nx p) @@ -313,9 +285,10 @@ Module Make (N:NType) <: ZType. end. Theorem spec_power_pos: forall x n, to_Z (power_pos x n) = to_Z x ^ Zpos n. + Proof. assert (F0: forall x, (-x)^2 = x^2). intros x; rewrite Zpower_2; ring. - unfold power_pos, to_Z; intros [x | x] [p | p |]; + unfold power_pos, to_Z; intros [x | x] [p | p |]; try rewrite N.spec_power_pos; try ring. assert (F: 0 <= 2 * Zpos p). assert (0 <= Zpos p); auto with zarith. @@ -329,15 +302,28 @@ Module Make (N:NType) <: ZType. rewrite F0; ring. Qed. + Definition power x n := + match n with + | N0 => one + | Npos p => power_pos x p + end. + + Theorem spec_power: forall x n, to_Z (power x n) = to_Z x ^ Z_of_N n. + Proof. + destruct n; simpl. rewrite N.spec_1; reflexivity. + apply spec_power_pos. + Qed. + + Definition sqrt x := match x with | Pos nx => Pos (N.sqrt nx) | Neg nx => Neg N.zero end. - - Theorem spec_sqrt: forall x, 0 <= to_Z x -> + Theorem spec_sqrt: forall x, 0 <= to_Z x -> to_Z (sqrt x) ^ 2 <= to_Z x < (to_Z (sqrt x) + 1) ^ 2. + Proof. unfold to_Z, sqrt; intros [x | x] H. exact (N.spec_sqrt x). replace (N.to_Z x) with 0. @@ -353,113 +339,75 @@ Module Make (N:NType) <: ZType. (Pos q, Pos r) | Pos nx, Neg ny => let (q, r) := N.div_eucl nx ny in - match N.compare N.zero r with - | Eq => (Neg q, zero) - | _ => (Neg (N.succ q), Neg (N.sub ny r)) - end + if N.eq_bool N.zero r + then (Neg q, zero) + else (Neg (N.succ q), Neg (N.sub ny r)) | Neg nx, Pos ny => let (q, r) := N.div_eucl nx ny in - match N.compare N.zero r with - | Eq => (Neg q, zero) - | _ => (Neg (N.succ q), Pos (N.sub ny r)) - end + if N.eq_bool N.zero r + then (Neg q, zero) + else (Neg (N.succ q), Pos (N.sub ny r)) | Neg nx, Neg ny => let (q, r) := N.div_eucl nx ny in (Pos q, Neg r) end. + Ltac break_nonneg x px EQx := + let H := fresh "H" in + assert (H:=N.spec_pos x); + destruct (N.to_Z x) as [|px|px]_eqn:EQx; + [clear H|clear H|elim H; reflexivity]. Theorem spec_div_eucl: forall x y, - to_Z y <> 0 -> - let (q,r) := div_eucl x y in - (to_Z q, to_Z r) = Zdiv_eucl (to_Z x) (to_Z y). - unfold div_eucl, to_Z; intros [x | x] [y | y] H. - assert (H1: 0 < N.to_Z y). - generalize (N.spec_pos y); auto with zarith. - generalize (N.spec_div_eucl x y H1); case N.div_eucl; auto. - assert (HH: 0 < N.to_Z y). - generalize (N.spec_pos y); auto with zarith. - generalize (N.spec_div_eucl x y HH); case N.div_eucl; auto. - intros q r; generalize (N.spec_pos x) HH; unfold Zdiv_eucl; - case_eq (N.to_Z x); case_eq (N.to_Z y); - try (intros; apply False_ind; auto with zarith; fail). - intros p He1 He2 _ _ H1; injection H1; intros H2 H3. - generalize (N.spec_compare N.zero r); case N.compare; - unfold zero; rewrite N.spec_0; try rewrite H3; auto. - rewrite H2; intros; apply False_ind; auto with zarith. - rewrite H2; intros; apply False_ind; auto with zarith. - intros p _ _ _ H1; discriminate H1. - intros p He p1 He1 H1 _. - generalize (N.spec_compare N.zero r); case N.compare. - change (- Zpos p) with (Zneg p). - unfold zero; lazy zeta. - rewrite N.spec_0; intros H2; rewrite <- H2. - intros H3; rewrite <- H3; auto. - rewrite N.spec_0; intros H2. - change (- Zpos p) with (Zneg p); lazy iota beta. - intros H3; rewrite <- H3; auto. - rewrite N.spec_succ; rewrite N.spec_sub. - generalize H2; case (N.to_Z r). - intros; apply False_ind; auto with zarith. - intros p2 _; rewrite He; auto with zarith. - change (Zneg p) with (- (Zpos p)); apply f_equal2 with (f := @pair Z Z); ring. - intros p2 H4; discriminate H4. - assert (N.to_Z r = (Zpos p1 mod (Zpos p))). - unfold Zmod, Zdiv_eucl; rewrite <- H3; auto. - case (Z_mod_lt (Zpos p1) (Zpos p)); auto with zarith. - rewrite N.spec_0; intros H2; generalize (N.spec_pos r); - intros; apply False_ind; auto with zarith. - assert (HH: 0 < N.to_Z y). - generalize (N.spec_pos y); auto with zarith. - generalize (N.spec_div_eucl x y HH); case N.div_eucl; auto. - intros q r; generalize (N.spec_pos x) HH; unfold Zdiv_eucl; - case_eq (N.to_Z x); case_eq (N.to_Z y); - try (intros; apply False_ind; auto with zarith; fail). - intros p He1 He2 _ _ H1; injection H1; intros H2 H3. - generalize (N.spec_compare N.zero r); case N.compare; - unfold zero; rewrite N.spec_0; try rewrite H3; auto. - rewrite H2; intros; apply False_ind; auto with zarith. - rewrite H2; intros; apply False_ind; auto with zarith. - intros p _ _ _ H1; discriminate H1. - intros p He p1 He1 H1 _. - generalize (N.spec_compare N.zero r); case N.compare. - change (- Zpos p1) with (Zneg p1). - unfold zero; lazy zeta. - rewrite N.spec_0; intros H2; rewrite <- H2. - intros H3; rewrite <- H3; auto. - rewrite N.spec_0; intros H2. - change (- Zpos p1) with (Zneg p1); lazy iota beta. - intros H3; rewrite <- H3; auto. - rewrite N.spec_succ; rewrite N.spec_sub. - generalize H2; case (N.to_Z r). - intros; apply False_ind; auto with zarith. - intros p2 _; rewrite He; auto with zarith. - intros p2 H4; discriminate H4. - assert (N.to_Z r = (Zpos p1 mod (Zpos p))). - unfold Zmod, Zdiv_eucl; rewrite <- H3; auto. - case (Z_mod_lt (Zpos p1) (Zpos p)); auto with zarith. - rewrite N.spec_0; generalize (N.spec_pos r); intros; apply False_ind; auto with zarith. - assert (H1: 0 < N.to_Z y). - generalize (N.spec_pos y); auto with zarith. - generalize (N.spec_div_eucl x y H1); case N.div_eucl; auto. - intros q r; generalize (N.spec_pos x) H1; unfold Zdiv_eucl; - case_eq (N.to_Z x); case_eq (N.to_Z y); - try (intros; apply False_ind; auto with zarith; fail). - change (-0) with 0; lazy iota beta; auto. - intros p _ _ _ _ H2; injection H2. - intros H3 H4; rewrite H3; rewrite H4; auto. - intros p _ _ _ H2; discriminate H2. - intros p He p1 He1 _ _ H2. - change (- Zpos p1) with (Zneg p1); lazy iota beta. - change (- Zpos p) with (Zneg p); lazy iota beta. - rewrite <- H2; auto. + let (q,r) := div_eucl x y in + (to_Z q, to_Z r) = Zdiv_eucl (to_Z x) (to_Z y). + Proof. + unfold div_eucl, to_Z. intros [x | x] [y | y]. + (* Pos Pos *) + generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y); auto. + (* Pos Neg *) + generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y) as (q,r). + break_nonneg x px EQx; break_nonneg y py EQy; + try (injection 1; intros Hr Hq; rewrite N.spec_eq_bool, N.spec_0, Hr; + simpl; rewrite Hq, N.spec_0; auto). + change (- Zpos py) with (Zneg py). + assert (GT : Zpos py > 0) by (compute; auto). + generalize (Z_div_mod (Zpos px) (Zpos py) GT). + unfold Zdiv_eucl. destruct (Zdiv_eucl_POS px (Zpos py)) as (q',r'). + intros (EQ,MOD). injection 1. intros Hr' Hq'. + rewrite N.spec_eq_bool, N.spec_0, Hr'. + break_nonneg r pr EQr. + subst; simpl. rewrite N.spec_0; auto. + subst. lazy iota beta delta [Zeq_bool Zcompare]. + rewrite N.spec_sub, N.spec_succ, EQy, EQr. f_equal. omega with *. + (* Neg Pos *) + generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y) as (q,r). + break_nonneg x px EQx; break_nonneg y py EQy; + try (injection 1; intros Hr Hq; rewrite N.spec_eq_bool, N.spec_0, Hr; + simpl; rewrite Hq, N.spec_0; auto). + change (- Zpos px) with (Zneg px). + assert (GT : Zpos py > 0) by (compute; auto). + generalize (Z_div_mod (Zpos px) (Zpos py) GT). + unfold Zdiv_eucl. destruct (Zdiv_eucl_POS px (Zpos py)) as (q',r'). + intros (EQ,MOD). injection 1. intros Hr' Hq'. + rewrite N.spec_eq_bool, N.spec_0, Hr'. + break_nonneg r pr EQr. + subst; simpl. rewrite N.spec_0; auto. + subst. lazy iota beta delta [Zeq_bool Zcompare]. + rewrite N.spec_sub, N.spec_succ, EQy, EQr. f_equal. omega with *. + (* Neg Neg *) + generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y) as (q,r). + break_nonneg x px EQx; break_nonneg y py EQy; + try (injection 1; intros Hr Hq; rewrite Hr, Hq; auto). + simpl. intros <-; auto. Qed. Definition div x y := fst (div_eucl x y). Definition spec_div: forall x y, - to_Z y <> 0 -> to_Z (div x y) = to_Z x / to_Z y. - intros x y H1; generalize (spec_div_eucl x y H1); unfold div, Zdiv. + to_Z (div x y) = to_Z x / to_Z y. + Proof. + intros x y; generalize (spec_div_eucl x y); unfold div, Zdiv. case div_eucl; case Zdiv_eucl; simpl; auto. intros q r q11 r1 H; injection H; auto. Qed. @@ -467,8 +415,9 @@ Module Make (N:NType) <: ZType. Definition modulo x y := snd (div_eucl x y). Theorem spec_modulo: - forall x y, to_Z y <> 0 -> to_Z (modulo x y) = to_Z x mod to_Z y. - intros x y H1; generalize (spec_div_eucl x y H1); unfold modulo, Zmod. + forall x y, to_Z (modulo x y) = to_Z x mod to_Z y. + Proof. + intros x y; generalize (spec_div_eucl x y); unfold modulo, Zmod. case div_eucl; case Zdiv_eucl; simpl; auto. intros q r q11 r1 H; injection H; auto. Qed. @@ -478,14 +427,30 @@ Module Make (N:NType) <: ZType. | Pos nx, Pos ny => Pos (N.gcd nx ny) | Pos nx, Neg ny => Pos (N.gcd nx ny) | Neg nx, Pos ny => Pos (N.gcd nx ny) - | Neg nx, Neg ny => Pos (N.gcd nx ny) + | Neg nx, Neg ny => Pos (N.gcd nx ny) end. Theorem spec_gcd: forall a b, to_Z (gcd a b) = Zgcd (to_Z a) (to_Z b). + Proof. unfold gcd, Zgcd, to_Z; intros [x | x] [y | y]; rewrite N.spec_gcd; unfold Zgcd; auto; case N.to_Z; simpl; auto with zarith; try rewrite Zabs_Zopp; auto; case N.to_Z; simpl; auto with zarith. Qed. + Definition sgn x := + match compare zero x with + | Lt => one + | Eq => zero + | Gt => minus_one + end. + + Lemma spec_sgn : forall x, to_Z (sgn x) = Zsgn (to_Z x). + Proof. + intros. unfold sgn. rewrite spec_compare. case Zcompare_spec. + rewrite spec_0. intros <-; auto. + rewrite spec_0, spec_1. symmetry. rewrite Zsgn_pos; auto. + rewrite spec_0, spec_m1. symmetry. rewrite Zsgn_neg; auto with zarith. + Qed. + End Make. diff --git a/theories/Numbers/Integer/Binary/ZBinary.v b/theories/Numbers/Integer/Binary/ZBinary.v index 66d2a96a..835f7958 100644 --- a/theories/Numbers/Integer/Binary/ZBinary.v +++ b/theories/Numbers/Integer/Binary/ZBinary.v @@ -8,212 +8,103 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZBinary.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) -Require Import ZMulOrder. -Require Import ZArith. -Open Local Scope Z_scope. +Require Import ZAxioms ZProperties. +Require Import ZArith_base. -Module ZBinAxiomsMod <: ZAxiomsSig. -Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig. -Module Export NZAxiomsMod <: NZAxiomsSig. +Local Open Scope Z_scope. -Definition NZ := Z. -Definition NZeq := (@eq Z). -Definition NZ0 := 0. -Definition NZsucc := Zsucc'. -Definition NZpred := Zpred'. -Definition NZadd := Zplus. -Definition NZsub := Zminus. -Definition NZmul := Zmult. +(** * Implementation of [ZAxiomsSig] by [BinInt.Z] *) -Theorem NZeq_equiv : equiv Z NZeq. -Proof. -exact (@eq_equiv Z). -Qed. - -Add Relation Z NZeq - reflexivity proved by (proj1 NZeq_equiv) - symmetry proved by (proj2 (proj2 NZeq_equiv)) - transitivity proved by (proj1 (proj2 NZeq_equiv)) -as NZeq_rel. - -Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd. -Proof. -congruence. -Qed. +Module ZBinAxiomsMod <: ZAxiomsExtSig. -Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd. -Proof. -congruence. -Qed. - -Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd. -Proof. -congruence. -Qed. +(** Bi-directional induction. *) -Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd. -Proof. -congruence. -Qed. - -Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd. -Proof. -congruence. -Qed. - -Theorem NZpred_succ : forall n : Z, NZpred (NZsucc n) = n. -Proof. -exact Zpred'_succ'. -Qed. - -Theorem NZinduction : - forall A : Z -> Prop, predicate_wd NZeq A -> - A 0 -> (forall n : Z, A n <-> A (NZsucc n)) -> forall n : Z, A n. +Theorem bi_induction : + forall A : Z -> Prop, Proper (eq ==> iff) A -> + A 0 -> (forall n : Z, A n <-> A (Zsucc n)) -> forall n : Z, A n. Proof. intros A A_wd A0 AS n; apply Zind; clear n. assumption. -intros; now apply -> AS. -intros n H. rewrite <- (Zsucc'_pred' n) in H. now apply <- AS. -Qed. - -Theorem NZadd_0_l : forall n : Z, 0 + n = n. -Proof. -exact Zplus_0_l. -Qed. - -Theorem NZadd_succ_l : forall n m : Z, (NZsucc n) + m = NZsucc (n + m). -Proof. -intros; do 2 rewrite <- Zsucc_succ'; apply Zplus_succ_l. -Qed. - -Theorem NZsub_0_r : forall n : Z, n - 0 = n. -Proof. -exact Zminus_0_r. -Qed. - -Theorem NZsub_succ_r : forall n m : Z, n - (NZsucc m) = NZpred (n - m). -Proof. -intros; rewrite <- Zsucc_succ'; rewrite <- Zpred_pred'; -apply Zminus_succ_r. -Qed. - -Theorem NZmul_0_l : forall n : Z, 0 * n = 0. -Proof. -reflexivity. -Qed. - -Theorem NZmul_succ_l : forall n m : Z, (NZsucc n) * m = n * m + m. -Proof. -intros; rewrite <- Zsucc_succ'; apply Zmult_succ_l. -Qed. - -End NZAxiomsMod. - -Definition NZlt := Zlt. -Definition NZle := Zle. -Definition NZmin := Zmin. -Definition NZmax := Zmax. - -Add Morphism NZlt with signature NZeq ==> NZeq ==> iff as NZlt_wd. -Proof. -unfold NZeq. intros n1 n2 H1 m1 m2 H2; rewrite H1; now rewrite H2. -Qed. - -Add Morphism NZle with signature NZeq ==> NZeq ==> iff as NZle_wd. -Proof. -unfold NZeq. intros n1 n2 H1 m1 m2 H2; rewrite H1; now rewrite H2. -Qed. - -Add Morphism NZmin with signature NZeq ==> NZeq ==> NZeq as NZmin_wd. -Proof. -congruence. -Qed. - -Add Morphism NZmax with signature NZeq ==> NZeq ==> NZeq as NZmax_wd. -Proof. -congruence. -Qed. - -Theorem NZlt_eq_cases : forall n m : Z, n <= m <-> n < m \/ n = m. -Proof. -intros n m; split. apply Zle_lt_or_eq. -intro H; destruct H as [H | H]. now apply Zlt_le_weak. rewrite H; apply Zle_refl. -Qed. - -Theorem NZlt_irrefl : forall n : Z, ~ n < n. -Proof. -exact Zlt_irrefl. -Qed. - -Theorem NZlt_succ_r : forall n m : Z, n < (NZsucc m) <-> n <= m. -Proof. -intros; unfold NZsucc; rewrite <- Zsucc_succ'; split; -[apply Zlt_succ_le | apply Zle_lt_succ]. -Qed. - -Theorem NZmin_l : forall n m : NZ, n <= m -> NZmin n m = n. -Proof. -unfold NZmin, Zmin, Zle; intros n m H. -destruct (n ?= m); try reflexivity. now elim H. -Qed. - -Theorem NZmin_r : forall n m : NZ, m <= n -> NZmin n m = m. -Proof. -unfold NZmin, Zmin, Zle; intros n m H. -case_eq (n ?= m); intro H1; try reflexivity. -now apply Zcompare_Eq_eq. -apply <- Zcompare_Gt_Lt_antisym in H1. now elim H. -Qed. - -Theorem NZmax_l : forall n m : NZ, m <= n -> NZmax n m = n. -Proof. -unfold NZmax, Zmax, Zle; intros n m H. -case_eq (n ?= m); intro H1; try reflexivity. -apply <- Zcompare_Gt_Lt_antisym in H1. now elim H. -Qed. - -Theorem NZmax_r : forall n m : NZ, n <= m -> NZmax n m = m. -Proof. -unfold NZmax, Zmax, Zle; intros n m H. -case_eq (n ?= m); intro H1. -now apply Zcompare_Eq_eq. reflexivity. now elim H. -Qed. - -End NZOrdAxiomsMod. - -Definition Zopp (x : Z) := -match x with -| Z0 => Z0 -| Zpos x => Zneg x -| Zneg x => Zpos x -end. - -Add Morphism Zopp with signature NZeq ==> NZeq as Zopp_wd. -Proof. -congruence. -Qed. - -Theorem Zsucc_pred : forall n : Z, NZsucc (NZpred n) = n. -Proof. -exact Zsucc'_pred'. -Qed. - -Theorem Zopp_0 : - 0 = 0. -Proof. -reflexivity. -Qed. - -Theorem Zopp_succ : forall n : Z, - (NZsucc n) = NZpred (- n). -Proof. -intro; rewrite <- Zsucc_succ'; rewrite <- Zpred_pred'. apply Zopp_succ. -Qed. +intros; rewrite <- Zsucc_succ'. now apply -> AS. +intros n H. rewrite <- Zpred_pred'. rewrite Zsucc_pred in H. now apply <- AS. +Qed. + +(** Basic operations. *) + +Definition eq_equiv : Equivalence (@eq Z) := eq_equivalence. +Local Obligation Tactic := simpl_relation. +Program Instance succ_wd : Proper (eq==>eq) Zsucc. +Program Instance pred_wd : Proper (eq==>eq) Zpred. +Program Instance add_wd : Proper (eq==>eq==>eq) Zplus. +Program Instance sub_wd : Proper (eq==>eq==>eq) Zminus. +Program Instance mul_wd : Proper (eq==>eq==>eq) Zmult. + +Definition pred_succ n := eq_sym (Zpred_succ n). +Definition add_0_l := Zplus_0_l. +Definition add_succ_l := Zplus_succ_l. +Definition sub_0_r := Zminus_0_r. +Definition sub_succ_r := Zminus_succ_r. +Definition mul_0_l := Zmult_0_l. +Definition mul_succ_l := Zmult_succ_l. + +(** Order *) + +Program Instance lt_wd : Proper (eq==>eq==>iff) Zlt. + +Definition lt_eq_cases := Zle_lt_or_eq_iff. +Definition lt_irrefl := Zlt_irrefl. +Definition lt_succ_r := Zlt_succ_r. + +Definition min_l := Zmin_l. +Definition min_r := Zmin_r. +Definition max_l := Zmax_l. +Definition max_r := Zmax_r. + +(** Properties specific to integers, not natural numbers. *) + +Program Instance opp_wd : Proper (eq==>eq) Zopp. + +Definition succ_pred n := eq_sym (Zsucc_pred n). +Definition opp_0 := Zopp_0. +Definition opp_succ := Zopp_succ. + +(** Absolute value and sign *) + +Definition abs_eq := Zabs_eq. +Definition abs_neq := Zabs_non_eq. + +Lemma sgn_null : forall x, x = 0 -> Zsgn x = 0. +Proof. intros. apply <- Zsgn_null; auto. Qed. +Lemma sgn_pos : forall x, 0 < x -> Zsgn x = 1. +Proof. intros. apply <- Zsgn_pos; auto. Qed. +Lemma sgn_neg : forall x, x < 0 -> Zsgn x = -1. +Proof. intros. apply <- Zsgn_neg; auto. Qed. + +(** The instantiation of operations. + Placing them at the very end avoids having indirections in above lemmas. *) + +Definition t := Z. +Definition eq := (@eq Z). +Definition zero := 0. +Definition succ := Zsucc. +Definition pred := Zpred. +Definition add := Zplus. +Definition sub := Zminus. +Definition mul := Zmult. +Definition lt := Zlt. +Definition le := Zle. +Definition min := Zmin. +Definition max := Zmax. +Definition opp := Zopp. +Definition abs := Zabs. +Definition sgn := Zsgn. End ZBinAxiomsMod. -Module Export ZBinMulOrderPropMod := ZMulOrderPropFunct ZBinAxiomsMod. +Module Export ZBinPropMod := ZPropFunct ZBinAxiomsMod. (** Z forms a ring *) diff --git a/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v index 9427b37b..8b5624cd 100644 --- a/theories/Numbers/Integer/NatPairs/ZNatPairs.v +++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v @@ -8,400 +8,306 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZNatPairs.v 11674 2008-12-12 19:48:40Z letouzey $ i*) +(*i $Id$ i*) -Require Import NSub. (* The most complete file for natural numbers *) -Require Export ZMulOrder. (* The most complete file for integers *) +Require Import NProperties. (* The most complete file for N *) +Require Export ZProperties. (* The most complete file for Z *) Require Export Ring. -Module ZPairsAxiomsMod (Import NAxiomsMod : NAxiomsSig) <: ZAxiomsSig. -Module Import NPropMod := NSubPropFunct NAxiomsMod. (* Get all properties of natural numbers *) - -(* We do not declare ring in Natural/Abstract for two reasons. First, some -of the properties proved in NAdd and NMul are used in the new BinNat, -and it is in turn used in Ring. Using ring in Natural/Abstract would be -circular. It is possible, however, not to make BinNat dependent on -Numbers/Natural and prove the properties necessary for ring from scratch -(this is, of course, how it used to be). In addition, if we define semiring -structures in the implementation subdirectories of Natural, we are able to -specify binary natural numbers as the type of coefficients. For these -reasons we define an abstract semiring here. *) - -Open Local Scope NatScope. - -Lemma Nsemi_ring : semi_ring_theory 0 1 add mul Neq. -Proof. -constructor. -exact add_0_l. -exact add_comm. -exact add_assoc. -exact mul_1_l. -exact mul_0_l. -exact mul_comm. -exact mul_assoc. -exact mul_add_distr_r. -Qed. - -Add Ring NSR : Nsemi_ring. - -(* The definitios of functions (NZadd, NZmul, etc.) will be unfolded by -the properties functor. Since we don't want Zadd_comm to refer to unfolded -definitions of equality: fun p1 p2 : NZ => (fst p1 + snd p2) = (fst p2 + snd p1), -we will provide an extra layer of definitions. *) - -Definition Z := (N * N)%type. -Definition Z0 : Z := (0, 0). -Definition Zeq (p1 p2 : Z) := ((fst p1) + (snd p2) == (fst p2) + (snd p1)). -Definition Zsucc (n : Z) : Z := (S (fst n), snd n). -Definition Zpred (n : Z) : Z := (fst n, S (snd n)). - -(* We do not have Zpred (Zsucc n) = n but only Zpred (Zsucc n) == n. It -could be possible to consider as canonical only pairs where one of the -elements is 0, and make all operations convert canonical values into other -canonical values. In that case, we could get rid of setoids and arrive at -integers as signed natural numbers. *) - -Definition Zadd (n m : Z) : Z := ((fst n) + (fst m), (snd n) + (snd m)). -Definition Zsub (n m : Z) : Z := ((fst n) + (snd m), (snd n) + (fst m)). - -(* Unfortunately, the elements of the pair keep increasing, even during -subtraction *) - -Definition Zmul (n m : Z) : Z := - ((fst n) * (fst m) + (snd n) * (snd m), (fst n) * (snd m) + (snd n) * (fst m)). -Definition Zlt (n m : Z) := (fst n) + (snd m) < (fst m) + (snd n). -Definition Zle (n m : Z) := (fst n) + (snd m) <= (fst m) + (snd n). -Definition Zmin (n m : Z) := (min ((fst n) + (snd m)) ((fst m) + (snd n)), (snd n) + (snd m)). -Definition Zmax (n m : Z) := (max ((fst n) + (snd m)) ((fst m) + (snd n)), (snd n) + (snd m)). - -Delimit Scope IntScope with Int. -Bind Scope IntScope with Z. -Notation "x == y" := (Zeq x y) (at level 70) : IntScope. -Notation "x ~= y" := (~ Zeq x y) (at level 70) : IntScope. -Notation "0" := Z0 : IntScope. -Notation "1" := (Zsucc Z0) : IntScope. -Notation "x + y" := (Zadd x y) : IntScope. -Notation "x - y" := (Zsub x y) : IntScope. -Notation "x * y" := (Zmul x y) : IntScope. -Notation "x < y" := (Zlt x y) : IntScope. -Notation "x <= y" := (Zle x y) : IntScope. -Notation "x > y" := (Zlt y x) (only parsing) : IntScope. -Notation "x >= y" := (Zle y x) (only parsing) : IntScope. - -Notation Local N := NZ. -(* To remember N without having to use a long qualifying name. since NZ will be redefined *) -Notation Local NE := NZeq (only parsing). -Notation Local add_wd := NZadd_wd (only parsing). - -Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig. -Module Export NZAxiomsMod <: NZAxiomsSig. - -Definition NZ : Type := Z. -Definition NZeq := Zeq. -Definition NZ0 := Z0. -Definition NZsucc := Zsucc. -Definition NZpred := Zpred. -Definition NZadd := Zadd. -Definition NZsub := Zsub. -Definition NZmul := Zmul. - -Theorem ZE_refl : reflexive Z Zeq. -Proof. -unfold reflexive, Zeq. reflexivity. -Qed. - -Theorem ZE_sym : symmetric Z Zeq. -Proof. -unfold symmetric, Zeq; now symmetry. -Qed. - -Theorem ZE_trans : transitive Z Zeq. -Proof. -unfold transitive, Zeq. intros n m p H1 H2. -assert (H3 : (fst n + snd m) + (fst m + snd p) == (fst m + snd n) + (fst p + snd m)) -by now apply add_wd. -stepl ((fst n + snd p) + (fst m + snd m)) in H3 by ring. -stepr ((fst p + snd n) + (fst m + snd m)) in H3 by ring. -now apply -> add_cancel_r in H3. +Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. +Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. +Open Local Scope pair_scope. + +Module ZPairsAxiomsMod (Import N : NAxiomsSig) <: ZAxiomsSig. +Module Import NPropMod := NPropFunct N. (* Get all properties of N *) + +Delimit Scope NScope with N. +Bind Scope NScope with N.t. +Infix "==" := N.eq (at level 70) : NScope. +Notation "x ~= y" := (~ N.eq x y) (at level 70) : NScope. +Notation "0" := N.zero : NScope. +Notation "1" := (N.succ N.zero) : NScope. +Infix "+" := N.add : NScope. +Infix "-" := N.sub : NScope. +Infix "*" := N.mul : NScope. +Infix "<" := N.lt : NScope. +Infix "<=" := N.le : NScope. +Local Open Scope NScope. + +(** The definitions of functions ([add], [mul], etc.) will be unfolded + by the properties functor. Since we don't want [add_comm] to refer + to unfolded definitions of equality: [fun p1 p2 => (fst p1 + + snd p2) = (fst p2 + snd p1)], we will provide an extra layer of + definitions. *) + +Module Z. + +Definition t := (N.t * N.t)%type. +Definition zero : t := (0, 0). +Definition eq (p q : t) := (p#1 + q#2 == q#1 + p#2). +Definition succ (n : t) : t := (N.succ n#1, n#2). +Definition pred (n : t) : t := (n#1, N.succ n#2). +Definition opp (n : t) : t := (n#2, n#1). +Definition add (n m : t) : t := (n#1 + m#1, n#2 + m#2). +Definition sub (n m : t) : t := (n#1 + m#2, n#2 + m#1). +Definition mul (n m : t) : t := + (n#1 * m#1 + n#2 * m#2, n#1 * m#2 + n#2 * m#1). +Definition lt (n m : t) := n#1 + m#2 < m#1 + n#2. +Definition le (n m : t) := n#1 + m#2 <= m#1 + n#2. +Definition min (n m : t) : t := (min (n#1 + m#2) (m#1 + n#2), n#2 + m#2). +Definition max (n m : t) : t := (max (n#1 + m#2) (m#1 + n#2), n#2 + m#2). + +(** NB : We do not have [Zpred (Zsucc n) = n] but only [Zpred (Zsucc n) == n]. + It could be possible to consider as canonical only pairs where + one of the elements is 0, and make all operations convert + canonical values into other canonical values. In that case, we + could get rid of setoids and arrive at integers as signed natural + numbers. *) + +(** NB : Unfortunately, the elements of the pair keep increasing during + many operations, even during subtraction. *) + +End Z. + +Delimit Scope ZScope with Z. +Bind Scope ZScope with Z.t. +Infix "==" := Z.eq (at level 70) : ZScope. +Notation "x ~= y" := (~ Z.eq x y) (at level 70) : ZScope. +Notation "0" := Z.zero : ZScope. +Notation "1" := (Z.succ Z.zero) : ZScope. +Infix "+" := Z.add : ZScope. +Infix "-" := Z.sub : ZScope. +Infix "*" := Z.mul : ZScope. +Notation "- x" := (Z.opp x) : ZScope. +Infix "<" := Z.lt : ZScope. +Infix "<=" := Z.le : ZScope. +Local Open Scope ZScope. + +Lemma sub_add_opp : forall n m, Z.sub n m = Z.add n (Z.opp m). +Proof. reflexivity. Qed. + +Instance eq_equiv : Equivalence Z.eq. +Proof. +split. +unfold Reflexive, Z.eq. reflexivity. +unfold Symmetric, Z.eq; now symmetry. +unfold Transitive, Z.eq. intros (n1,n2) (m1,m2) (p1,p2) H1 H2; simpl in *. +apply (add_cancel_r _ _ (m1+m2)%N). +rewrite add_shuffle2, H1, add_shuffle1, H2. +now rewrite add_shuffle1, (add_comm m1). +Qed. + +Instance pair_wd : Proper (N.eq==>N.eq==>Z.eq) (@pair N.t N.t). +Proof. +intros n1 n2 H1 m1 m2 H2; unfold Z.eq; simpl; now rewrite H1, H2. +Qed. + +Instance succ_wd : Proper (Z.eq ==> Z.eq) Z.succ. +Proof. +unfold Z.succ, Z.eq; intros n m H; simpl. +do 2 rewrite add_succ_l; now rewrite H. Qed. -Theorem NZeq_equiv : equiv Z Zeq. +Instance pred_wd : Proper (Z.eq ==> Z.eq) Z.pred. Proof. -unfold equiv; repeat split; [apply ZE_refl | apply ZE_trans | apply ZE_sym]. -Qed. - -Add Relation Z Zeq - reflexivity proved by (proj1 NZeq_equiv) - symmetry proved by (proj2 (proj2 NZeq_equiv)) - transitivity proved by (proj1 (proj2 NZeq_equiv)) -as NZeq_rel. - -Add Morphism (@pair N N) with signature NE ==> NE ==> Zeq as Zpair_wd. -Proof. -intros n1 n2 H1 m1 m2 H2; unfold Zeq; simpl; rewrite H1; now rewrite H2. +unfold Z.pred, Z.eq; intros n m H; simpl. +do 2 rewrite add_succ_r; now rewrite H. Qed. -Add Morphism NZsucc with signature Zeq ==> Zeq as NZsucc_wd. +Instance add_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.add. Proof. -unfold NZsucc, Zeq; intros n m H; simpl. -do 2 rewrite add_succ_l; now rewrite H. +unfold Z.eq, Z.add; intros n1 m1 H1 n2 m2 H2; simpl. +now rewrite add_shuffle1, H1, H2, add_shuffle1. Qed. -Add Morphism NZpred with signature Zeq ==> Zeq as NZpred_wd. +Instance opp_wd : Proper (Z.eq ==> Z.eq) Z.opp. Proof. -unfold NZpred, Zeq; intros n m H; simpl. -do 2 rewrite add_succ_r; now rewrite H. +unfold Z.eq, Z.opp; intros (n1,n2) (m1,m2) H; simpl in *. +now rewrite (add_comm n2), (add_comm m2). Qed. -Add Morphism NZadd with signature Zeq ==> Zeq ==> Zeq as NZadd_wd. +Instance sub_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.sub. Proof. -unfold Zeq, NZadd; intros n1 m1 H1 n2 m2 H2; simpl. -assert (H3 : (fst n1 + snd m1) + (fst n2 + snd m2) == (fst m1 + snd n1) + (fst m2 + snd n2)) -by now apply add_wd. -stepl (fst n1 + snd m1 + (fst n2 + snd m2)) by ring. -now stepr (fst m1 + snd n1 + (fst m2 + snd n2)) by ring. +intros n1 m1 H1 n2 m2 H2. rewrite 2 sub_add_opp. +apply add_wd, opp_wd; auto. Qed. -Add Morphism NZsub with signature Zeq ==> Zeq ==> Zeq as NZsub_wd. +Lemma mul_comm : forall n m, n*m == m*n. Proof. -unfold Zeq, NZsub; intros n1 m1 H1 n2 m2 H2; simpl. -symmetry in H2. -assert (H3 : (fst n1 + snd m1) + (fst m2 + snd n2) == (fst m1 + snd n1) + (fst n2 + snd m2)) -by now apply add_wd. -stepl (fst n1 + snd m1 + (fst m2 + snd n2)) by ring. -now stepr (fst m1 + snd n1 + (fst n2 + snd m2)) by ring. +intros (n1,n2) (m1,m2); compute. +rewrite (add_comm (m1*n2)%N). +apply N.add_wd; apply N.add_wd; apply mul_comm. Qed. -Add Morphism NZmul with signature Zeq ==> Zeq ==> Zeq as NZmul_wd. +Instance mul_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.mul. Proof. -unfold NZmul, Zeq; intros n1 m1 H1 n2 m2 H2; simpl. -stepl (fst n1 * fst n2 + (snd n1 * snd n2 + fst m1 * snd m2 + snd m1 * fst m2)) by ring. -stepr (fst n1 * snd n2 + (fst m1 * fst m2 + snd m1 * snd m2 + snd n1 * fst n2)) by ring. -apply add_mul_repl_pair with (n := fst m2) (m := snd m2); [| now idtac]. -stepl (snd n1 * snd n2 + (fst n1 * fst m2 + fst m1 * snd m2 + snd m1 * fst m2)) by ring. -stepr (snd n1 * fst n2 + (fst n1 * snd m2 + fst m1 * fst m2 + snd m1 * snd m2)) by ring. -apply add_mul_repl_pair with (n := snd m2) (m := fst m2); -[| (stepl (fst n2 + snd m2) by ring); now stepr (fst m2 + snd n2) by ring]. -stepl (snd m2 * snd n1 + (fst n1 * fst m2 + fst m1 * snd m2 + snd m1 * fst m2)) by ring. -stepr (snd m2 * fst n1 + (snd n1 * fst m2 + fst m1 * fst m2 + snd m1 * snd m2)) by ring. -apply add_mul_repl_pair with (n := snd m1) (m := fst m1); -[ | (stepl (fst n1 + snd m1) by ring); now stepr (fst m1 + snd n1) by ring]. -stepl (fst m2 * fst n1 + (snd m2 * snd m1 + fst m1 * snd m2 + snd m1 * fst m2)) by ring. -stepr (fst m2 * snd n1 + (snd m2 * fst m1 + fst m1 * fst m2 + snd m1 * snd m2)) by ring. -apply add_mul_repl_pair with (n := fst m1) (m := snd m1); [| now idtac]. -ring. +assert (forall n, Proper (Z.eq ==> Z.eq) (Z.mul n)). + unfold Z.mul, Z.eq. intros (n1,n2) (p1,p2) (q1,q2) H; simpl in *. + rewrite add_shuffle1, (add_comm (n1*p1)%N). + symmetry. rewrite add_shuffle1. + rewrite <- ! mul_add_distr_l. + rewrite (add_comm p2), (add_comm q2), H. + reflexivity. +intros n n' Hn m m' Hm. +rewrite Hm, (mul_comm n), (mul_comm n'), Hn. +reflexivity. Qed. Section Induction. -Open Scope NatScope. (* automatically closes at the end of the section *) -Variable A : Z -> Prop. -Hypothesis A_wd : predicate_wd Zeq A. +Variable A : Z.t -> Prop. +Hypothesis A_wd : Proper (Z.eq==>iff) A. -Add Morphism A with signature Zeq ==> iff as A_morph. +Theorem bi_induction : + A 0 -> (forall n, A n <-> A (Z.succ n)) -> forall n, A n. Proof. -exact A_wd. -Qed. - -Theorem NZinduction : - A 0 -> (forall n : Z, A n <-> A (Zsucc n)) -> forall n : Z, A n. (* 0 is interpreted as in Z due to "Bind" directive *) -Proof. -intros A0 AS n; unfold NZ0, Zsucc, predicate_wd, fun_wd, Zeq in *. +intros A0 AS n; unfold Z.zero, Z.succ, Z.eq in *. destruct n as [n m]. -cut (forall p : N, A (p, 0)); [intro H1 |]. -cut (forall p : N, A (0, p)); [intro H2 |]. +cut (forall p, A (p, 0%N)); [intro H1 |]. +cut (forall p, A (0%N, p)); [intro H2 |]. destruct (add_dichotomy n m) as [[p H] | [p H]]. -rewrite (A_wd (n, m) (0, p)) by (rewrite add_0_l; now rewrite add_comm). +rewrite (A_wd (n, m) (0%N, p)) by (rewrite add_0_l; now rewrite add_comm). apply H2. -rewrite (A_wd (n, m) (p, 0)) by now rewrite add_0_r. apply H1. +rewrite (A_wd (n, m) (p, 0%N)) by now rewrite add_0_r. apply H1. induct p. assumption. intros p IH. -apply -> (A_wd (0, p) (1, S p)) in IH; [| now rewrite add_0_l, add_1_l]. +apply -> (A_wd (0%N, p) (1%N, N.succ p)) in IH; [| now rewrite add_0_l, add_1_l]. now apply <- AS. induct p. assumption. intros p IH. -replace 0 with (snd (p, 0)); [| reflexivity]. -replace (S p) with (S (fst (p, 0))); [| reflexivity]. now apply -> AS. +replace 0%N with (snd (p, 0%N)); [| reflexivity]. +replace (N.succ p) with (N.succ (fst (p, 0%N))); [| reflexivity]. now apply -> AS. Qed. End Induction. (* Time to prove theorems in the language of Z *) -Open Local Scope IntScope. - -Theorem NZpred_succ : forall n : Z, Zpred (Zsucc n) == n. +Theorem pred_succ : forall n, Z.pred (Z.succ n) == n. Proof. -unfold NZpred, NZsucc, Zeq; intro n; simpl. -rewrite add_succ_l; now rewrite add_succ_r. +unfold Z.pred, Z.succ, Z.eq; intro n; simpl; now nzsimpl. Qed. -Theorem NZadd_0_l : forall n : Z, 0 + n == n. +Theorem succ_pred : forall n, Z.succ (Z.pred n) == n. Proof. -intro n; unfold NZadd, Zeq; simpl. now do 2 rewrite add_0_l. +intro n; unfold Z.succ, Z.pred, Z.eq; simpl; now nzsimpl. Qed. -Theorem NZadd_succ_l : forall n m : Z, (Zsucc n) + m == Zsucc (n + m). +Theorem opp_0 : - 0 == 0. Proof. -intros n m; unfold NZadd, Zeq; simpl. now do 2 rewrite add_succ_l. +unfold Z.opp, Z.eq; simpl. now nzsimpl. Qed. -Theorem NZsub_0_r : forall n : Z, n - 0 == n. +Theorem opp_succ : forall n, - (Z.succ n) == Z.pred (- n). Proof. -intro n; unfold NZsub, Zeq; simpl. now do 2 rewrite add_0_r. -Qed. - -Theorem NZsub_succ_r : forall n m : Z, n - (Zsucc m) == Zpred (n - m). -Proof. -intros n m; unfold NZsub, Zeq; simpl. symmetry; now rewrite add_succ_r. +reflexivity. Qed. -Theorem NZmul_0_l : forall n : Z, 0 * n == 0. +Theorem add_0_l : forall n, 0 + n == n. Proof. -intro n; unfold NZmul, Zeq; simpl. -repeat rewrite mul_0_l. now rewrite add_assoc. +intro n; unfold Z.add, Z.eq; simpl. now nzsimpl. Qed. -Theorem NZmul_succ_l : forall n m : Z, (Zsucc n) * m == n * m + m. +Theorem add_succ_l : forall n m, (Z.succ n) + m == Z.succ (n + m). Proof. -intros n m; unfold NZmul, NZsucc, Zeq; simpl. -do 2 rewrite mul_succ_l. ring. +intros n m; unfold Z.add, Z.eq; simpl. now nzsimpl. Qed. -End NZAxiomsMod. - -Definition NZlt := Zlt. -Definition NZle := Zle. -Definition NZmin := Zmin. -Definition NZmax := Zmax. - -Add Morphism NZlt with signature Zeq ==> Zeq ==> iff as NZlt_wd. +Theorem sub_0_r : forall n, n - 0 == n. Proof. -unfold NZlt, Zlt, Zeq; intros n1 m1 H1 n2 m2 H2; simpl. split; intro H. -stepr (snd m1 + fst m2) by apply add_comm. -apply (add_lt_repl_pair (fst n1) (snd n1)); [| assumption]. -stepl (snd m2 + fst n1) by apply add_comm. -stepr (fst m2 + snd n1) by apply add_comm. -apply (add_lt_repl_pair (snd n2) (fst n2)). -now stepl (fst n1 + snd n2) by apply add_comm. -stepl (fst m2 + snd n2) by apply add_comm. now stepr (fst n2 + snd m2) by apply add_comm. -stepr (snd n1 + fst n2) by apply add_comm. -apply (add_lt_repl_pair (fst m1) (snd m1)); [| now symmetry]. -stepl (snd n2 + fst m1) by apply add_comm. -stepr (fst n2 + snd m1) by apply add_comm. -apply (add_lt_repl_pair (snd m2) (fst m2)). -now stepl (fst m1 + snd m2) by apply add_comm. -stepl (fst n2 + snd m2) by apply add_comm. now stepr (fst m2 + snd n2) by apply add_comm. +intro n; unfold Z.sub, Z.eq; simpl. now nzsimpl. Qed. -Add Morphism NZle with signature Zeq ==> Zeq ==> iff as NZle_wd. +Theorem sub_succ_r : forall n m, n - (Z.succ m) == Z.pred (n - m). Proof. -unfold NZle, Zle, Zeq; intros n1 m1 H1 n2 m2 H2; simpl. -do 2 rewrite lt_eq_cases. rewrite (NZlt_wd n1 m1 H1 n2 m2 H2). fold (m1 < m2)%Int. -fold (n1 == n2)%Int (m1 == m2)%Int; fold (n1 == m1)%Int in H1; fold (n2 == m2)%Int in H2. -now rewrite H1, H2. +intros n m; unfold Z.sub, Z.eq; simpl. symmetry; now rewrite add_succ_r. Qed. -Add Morphism NZmin with signature Zeq ==> Zeq ==> Zeq as NZmin_wd. +Theorem mul_0_l : forall n, 0 * n == 0. Proof. -intros n1 m1 H1 n2 m2 H2; unfold NZmin, Zeq; simpl. -destruct (le_ge_cases (fst n1 + snd n2) (fst n2 + snd n1)) as [H | H]. -rewrite (min_l (fst n1 + snd n2) (fst n2 + snd n1)) by assumption. -rewrite (min_l (fst m1 + snd m2) (fst m2 + snd m1)) by -now apply -> (NZle_wd n1 m1 H1 n2 m2 H2). -stepl ((fst n1 + snd m1) + (snd n2 + snd m2)) by ring. -unfold Zeq in H1. rewrite H1. ring. -rewrite (min_r (fst n1 + snd n2) (fst n2 + snd n1)) by assumption. -rewrite (min_r (fst m1 + snd m2) (fst m2 + snd m1)) by -now apply -> (NZle_wd n2 m2 H2 n1 m1 H1). -stepl ((fst n2 + snd m2) + (snd n1 + snd m1)) by ring. -unfold Zeq in H2. rewrite H2. ring. +intros (n1,n2); unfold Z.mul, Z.eq; simpl; now nzsimpl. Qed. -Add Morphism NZmax with signature Zeq ==> Zeq ==> Zeq as NZmax_wd. +Theorem mul_succ_l : forall n m, (Z.succ n) * m == n * m + m. Proof. -intros n1 m1 H1 n2 m2 H2; unfold NZmax, Zeq; simpl. -destruct (le_ge_cases (fst n1 + snd n2) (fst n2 + snd n1)) as [H | H]. -rewrite (max_r (fst n1 + snd n2) (fst n2 + snd n1)) by assumption. -rewrite (max_r (fst m1 + snd m2) (fst m2 + snd m1)) by -now apply -> (NZle_wd n1 m1 H1 n2 m2 H2). -stepl ((fst n2 + snd m2) + (snd n1 + snd m1)) by ring. -unfold Zeq in H2. rewrite H2. ring. -rewrite (max_l (fst n1 + snd n2) (fst n2 + snd n1)) by assumption. -rewrite (max_l (fst m1 + snd m2) (fst m2 + snd m1)) by -now apply -> (NZle_wd n2 m2 H2 n1 m1 H1). -stepl ((fst n1 + snd m1) + (snd n2 + snd m2)) by ring. -unfold Zeq in H1. rewrite H1. ring. +intros (n1,n2) (m1,m2); unfold Z.mul, Z.succ, Z.eq; simpl; nzsimpl. +rewrite <- (add_assoc _ m1), (add_comm m1), (add_assoc _ _ m1). +now rewrite <- (add_assoc _ m2), (add_comm m2), (add_assoc _ (n2*m1)%N m2). Qed. -Open Local Scope IntScope. +(** Order *) -Theorem NZlt_eq_cases : forall n m : Z, n <= m <-> n < m \/ n == m. +Lemma lt_eq_cases : forall n m, n<=m <-> n n <= m. +Theorem lt_succ_r : forall n m, n < (Z.succ m) <-> n <= m. Proof. -intros n m; unfold Zlt, Zle, Zeq; simpl. rewrite add_succ_l; apply lt_succ_r. +intros n m; unfold Z.lt, Z.le, Z.eq; simpl; nzsimpl. apply lt_succ_r. Qed. -Theorem NZmin_l : forall n m : Z, n <= m -> Zmin n m == n. +Theorem min_l : forall n m, n <= m -> Z.min n m == n. Proof. -unfold Zmin, Zle, Zeq; simpl; intros n m H. -rewrite min_l by assumption. ring. +unfold Z.min, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *. +rewrite min_l by assumption. +now rewrite <- add_assoc, (add_comm m2). Qed. -Theorem NZmin_r : forall n m : Z, m <= n -> Zmin n m == m. +Theorem min_r : forall n m, m <= n -> Z.min n m == m. Proof. -unfold Zmin, Zle, Zeq; simpl; intros n m H. -rewrite min_r by assumption. ring. +unfold Z.min, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *. +rewrite min_r by assumption. +now rewrite add_assoc. Qed. -Theorem NZmax_l : forall n m : Z, m <= n -> Zmax n m == n. +Theorem max_l : forall n m, m <= n -> Z.max n m == n. Proof. -unfold Zmax, Zle, Zeq; simpl; intros n m H. -rewrite max_l by assumption. ring. +unfold Z.max, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *. +rewrite max_l by assumption. +now rewrite <- add_assoc, (add_comm m2). Qed. -Theorem NZmax_r : forall n m : Z, n <= m -> Zmax n m == m. +Theorem max_r : forall n m, n <= m -> Z.max n m == m. Proof. -unfold Zmax, Zle, Zeq; simpl; intros n m H. -rewrite max_r by assumption. ring. +unfold Z.max, Z.le, Z.eq; simpl; intros n m H. +rewrite max_r by assumption. +now rewrite add_assoc. Qed. -End NZOrdAxiomsMod. - -Definition Zopp (n : Z) : Z := (snd n, fst n). - -Notation "- x" := (Zopp x) : IntScope. - -Add Morphism Zopp with signature Zeq ==> Zeq as Zopp_wd. -Proof. -unfold Zeq; intros n m H; simpl. symmetry. -stepl (fst n + snd m) by apply add_comm. -now stepr (fst m + snd n) by apply add_comm. -Qed. - -Open Local Scope IntScope. - -Theorem Zsucc_pred : forall n : Z, Zsucc (Zpred n) == n. +Theorem lt_nge : forall n m, n < m <-> ~(m<=n). Proof. -intro n; unfold Zsucc, Zpred, Zeq; simpl. -rewrite add_succ_l; now rewrite add_succ_r. +intros. apply lt_nge. Qed. -Theorem Zopp_0 : - 0 == 0. +Instance lt_wd : Proper (Z.eq ==> Z.eq ==> iff) Z.lt. Proof. -unfold Zopp, Zeq; simpl. now rewrite add_0_l. +assert (forall n, Proper (Z.eq==>iff) (Z.lt n)). + intros (n1,n2). apply proper_sym_impl_iff; auto with *. + unfold Z.lt, Z.eq; intros (r1,r2) (s1,s2) Eq H; simpl in *. + apply le_lt_add_lt with (r1+r2)%N (r1+r2)%N; [apply le_refl; auto with *|]. + rewrite add_shuffle2, (add_comm s2), Eq. + rewrite (add_comm s1 n2), (add_shuffle1 n2), (add_comm n2 r1). + now rewrite <- add_lt_mono_r. +intros n n' Hn m m' Hm. +rewrite Hm. rewrite 2 lt_nge, 2 lt_eq_cases, Hn; auto with *. Qed. -Theorem Zopp_succ : forall n, - (Zsucc n) == Zpred (- n). -Proof. -reflexivity. -Qed. +Definition t := Z.t. +Definition eq := Z.eq. +Definition zero := Z.zero. +Definition succ := Z.succ. +Definition pred := Z.pred. +Definition add := Z.add. +Definition sub := Z.sub. +Definition mul := Z.mul. +Definition opp := Z.opp. +Definition lt := Z.lt. +Definition le := Z.le. +Definition min := Z.min. +Definition max := Z.max. End ZPairsAxiomsMod. @@ -413,9 +319,7 @@ and get their properties *) Require Import NPeano. Module Export ZPairsPeanoAxiomsMod := ZPairsAxiomsMod NPeanoAxiomsMod. -Module Export ZPairsMulOrderPropMod := ZMulOrderPropFunct ZPairsPeanoAxiomsMod. - -Open Local Scope IntScope. +Module Export ZPairsPropMod := ZPropFunct ZPairsPeanoAxiomsMod. Eval compute in (3, 5) * (4, 6). *) diff --git a/theories/Numbers/Integer/SpecViaZ/ZSig.v b/theories/Numbers/Integer/SpecViaZ/ZSig.v index 0af98c74..ffa91706 100644 --- a/theories/Numbers/Integer/SpecViaZ/ZSig.v +++ b/theories/Numbers/Integer/SpecViaZ/ZSig.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZSig.v 11027 2008-06-01 13:28:59Z letouzey $ i*) +(*i $Id$ i*) Require Import ZArith Znumtheory. @@ -25,93 +25,77 @@ Module Type ZType. Parameter t : Type. Parameter to_Z : t -> Z. - Notation "[ x ]" := (to_Z x). + Local Notation "[ x ]" := (to_Z x). - Definition eq x y := ([x] = [y]). + Definition eq x y := [x] = [y]. + Definition lt x y := [x] < [y]. + Definition le x y := [x] <= [y]. Parameter of_Z : Z -> t. Parameter spec_of_Z: forall x, to_Z (of_Z x) = x. + Parameter compare : t -> t -> comparison. + Parameter eq_bool : t -> t -> bool. + Parameter min : t -> t -> t. + Parameter max : t -> t -> t. Parameter zero : t. Parameter one : t. Parameter minus_one : t. - - Parameter spec_0: [zero] = 0. - Parameter spec_1: [one] = 1. - Parameter spec_m1: [minus_one] = -1. - - Parameter compare : t -> t -> comparison. - - Parameter spec_compare: forall x y, - match compare x y with - | Eq => [x] = [y] - | Lt => [x] < [y] - | Gt => [x] > [y] - end. - - Definition lt n m := compare n m = Lt. - Definition le n m := compare n m <> Gt. - Definition min n m := match compare n m with Gt => m | _ => n end. - Definition max n m := match compare n m with Lt => m | _ => n end. - - Parameter eq_bool : t -> t -> bool. - - Parameter spec_eq_bool: forall x y, - if eq_bool x y then [x] = [y] else [x] <> [y]. - Parameter succ : t -> t. - - Parameter spec_succ: forall n, [succ n] = [n] + 1. - Parameter add : t -> t -> t. - - Parameter spec_add: forall x y, [add x y] = [x] + [y]. - Parameter pred : t -> t. - - Parameter spec_pred: forall x, [pred x] = [x] - 1. - Parameter sub : t -> t -> t. - - Parameter spec_sub: forall x y, [sub x y] = [x] - [y]. - Parameter opp : t -> t. - - Parameter spec_opp: forall x, [opp x] = - [x]. - Parameter mul : t -> t -> t. - - Parameter spec_mul: forall x y, [mul x y] = [x] * [y]. - Parameter square : t -> t. - - Parameter spec_square: forall x, [square x] = [x] * [x]. - Parameter power_pos : t -> positive -> t. - - Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n. - + Parameter power : t -> N -> t. Parameter sqrt : t -> t. - - Parameter spec_sqrt: forall x, 0 <= [x] -> - [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. - Parameter div_eucl : t -> t -> t * t. - - Parameter spec_div_eucl: forall x y, [y] <> 0 -> - let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y]. - Parameter div : t -> t -> t. - - Parameter spec_div: forall x y, [y] <> 0 -> [div x y] = [x] / [y]. - Parameter modulo : t -> t -> t. - - Parameter spec_modulo: forall x y, [y] <> 0 -> - [modulo x y] = [x] mod [y]. - Parameter gcd : t -> t -> t. + Parameter sgn : t -> t. + Parameter abs : t -> t. + Parameter spec_compare: forall x y, compare x y = Zcompare [x] [y]. + Parameter spec_eq_bool: forall x y, eq_bool x y = Zeq_bool [x] [y]. + Parameter spec_min : forall x y, [min x y] = Zmin [x] [y]. + Parameter spec_max : forall x y, [max x y] = Zmax [x] [y]. + Parameter spec_0: [zero] = 0. + Parameter spec_1: [one] = 1. + Parameter spec_m1: [minus_one] = -1. + Parameter spec_succ: forall n, [succ n] = [n] + 1. + Parameter spec_add: forall x y, [add x y] = [x] + [y]. + Parameter spec_pred: forall x, [pred x] = [x] - 1. + Parameter spec_sub: forall x y, [sub x y] = [x] - [y]. + Parameter spec_opp: forall x, [opp x] = - [x]. + Parameter spec_mul: forall x y, [mul x y] = [x] * [y]. + Parameter spec_square: forall x, [square x] = [x] * [x]. + Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n. + Parameter spec_power: forall x n, [power x n] = [x] ^ Z_of_N n. + Parameter spec_sqrt: forall x, 0 <= [x] -> + [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. + Parameter spec_div_eucl: forall x y, + let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y]. + Parameter spec_div: forall x y, [div x y] = [x] / [y]. + Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y]. Parameter spec_gcd: forall a b, [gcd a b] = Zgcd (to_Z a) (to_Z b). + Parameter spec_sgn : forall x, [sgn x] = Zsgn [x]. + Parameter spec_abs : forall x, [abs x] = Zabs [x]. End ZType. + +Module Type ZType_Notation (Import Z:ZType). + Notation "[ x ]" := (to_Z x). + Infix "==" := eq (at level 70). + Notation "0" := zero. + Infix "+" := add. + Infix "-" := sub. + Infix "*" := mul. + Notation "- x" := (opp x). + Infix "<=" := le. + Infix "<" := lt. +End ZType_Notation. + +Module Type ZType' := ZType <+ ZType_Notation. \ No newline at end of file diff --git a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v index aceb8984..bcecb6a8 100644 --- a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v +++ b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v @@ -6,119 +6,74 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ZSigZAxioms.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id$ i*) -Require Import ZArith. -Require Import ZAxioms. -Require Import ZSig. +Require Import ZArith ZAxioms ZDivFloor ZSig. -(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig] *) +(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig] -Module ZSig_ZAxioms (Z:ZType) <: ZAxiomsSig. + It also provides [sgn], [abs], [div], [mod] +*) -Delimit Scope IntScope with Int. -Bind Scope IntScope with Z.t. -Open Local Scope IntScope. -Notation "[ x ]" := (Z.to_Z x) : IntScope. -Infix "==" := Z.eq (at level 70) : IntScope. -Notation "0" := Z.zero : IntScope. -Infix "+" := Z.add : IntScope. -Infix "-" := Z.sub : IntScope. -Infix "*" := Z.mul : IntScope. -Notation "- x" := (Z.opp x) : IntScope. -Hint Rewrite - Z.spec_0 Z.spec_1 Z.spec_add Z.spec_sub Z.spec_pred Z.spec_succ - Z.spec_mul Z.spec_opp Z.spec_of_Z : Zspec. +Module ZTypeIsZAxioms (Import Z : ZType'). -Ltac zsimpl := unfold Z.eq in *; autorewrite with Zspec. +Hint Rewrite + spec_0 spec_1 spec_add spec_sub spec_pred spec_succ + spec_mul spec_opp spec_of_Z spec_div spec_modulo + spec_compare spec_eq_bool spec_max spec_min spec_abs spec_sgn + : zsimpl. -Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig. -Module Export NZAxiomsMod <: NZAxiomsSig. +Ltac zsimpl := autorewrite with zsimpl. +Ltac zcongruence := repeat red; intros; zsimpl; congruence. +Ltac zify := unfold eq, lt, le in *; zsimpl. -Definition NZ := Z.t. -Definition NZeq := Z.eq. -Definition NZ0 := Z.zero. -Definition NZsucc := Z.succ. -Definition NZpred := Z.pred. -Definition NZadd := Z.add. -Definition NZsub := Z.sub. -Definition NZmul := Z.mul. +Instance eq_equiv : Equivalence eq. +Proof. unfold eq. firstorder. Qed. -Theorem NZeq_equiv : equiv Z.t Z.eq. -Proof. -repeat split; repeat red; intros; auto; congruence. -Qed. - -Add Relation Z.t Z.eq - reflexivity proved by (proj1 NZeq_equiv) - symmetry proved by (proj2 (proj2 NZeq_equiv)) - transitivity proved by (proj1 (proj2 NZeq_equiv)) - as NZeq_rel. - -Add Morphism NZsucc with signature Z.eq ==> Z.eq as NZsucc_wd. -Proof. -intros; zsimpl; f_equal; assumption. -Qed. - -Add Morphism NZpred with signature Z.eq ==> Z.eq as NZpred_wd. -Proof. -intros; zsimpl; f_equal; assumption. -Qed. +Local Obligation Tactic := zcongruence. -Add Morphism NZadd with signature Z.eq ==> Z.eq ==> Z.eq as NZadd_wd. -Proof. -intros; zsimpl; f_equal; assumption. -Qed. - -Add Morphism NZsub with signature Z.eq ==> Z.eq ==> Z.eq as NZsub_wd. -Proof. -intros; zsimpl; f_equal; assumption. -Qed. +Program Instance succ_wd : Proper (eq ==> eq) succ. +Program Instance pred_wd : Proper (eq ==> eq) pred. +Program Instance add_wd : Proper (eq ==> eq ==> eq) add. +Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub. +Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul. -Add Morphism NZmul with signature Z.eq ==> Z.eq ==> Z.eq as NZmul_wd. +Theorem pred_succ : forall n, pred (succ n) == n. Proof. -intros; zsimpl; f_equal; assumption. -Qed. - -Theorem NZpred_succ : forall n, Z.pred (Z.succ n) == n. -Proof. -intros; zsimpl; auto with zarith. +intros. zify. auto with zarith. Qed. Section Induction. Variable A : Z.t -> Prop. -Hypothesis A_wd : predicate_wd Z.eq A. +Hypothesis A_wd : Proper (eq==>iff) A. Hypothesis A0 : A 0. -Hypothesis AS : forall n, A n <-> A (Z.succ n). - -Add Morphism A with signature Z.eq ==> iff as A_morph. -Proof. apply A_wd. Qed. +Hypothesis AS : forall n, A n <-> A (succ n). -Let B (z : Z) := A (Z.of_Z z). +Let B (z : Z) := A (of_Z z). Lemma B0 : B 0. Proof. unfold B; simpl. rewrite <- (A_wd 0); auto. -zsimpl; auto. +zify. auto. Qed. Lemma BS : forall z : Z, B z -> B (z + 1). Proof. intros z H. unfold B in *. apply -> AS in H. -setoid_replace (Z.of_Z (z + 1)) with (Z.succ (Z.of_Z z)); auto. -zsimpl; auto. +setoid_replace (of_Z (z + 1)) with (succ (of_Z z)); auto. +zify. auto. Qed. Lemma BP : forall z : Z, B z -> B (z - 1). Proof. intros z H. unfold B in *. rewrite AS. -setoid_replace (Z.succ (Z.of_Z (z - 1))) with (Z.of_Z z); auto. -zsimpl; auto with zarith. +setoid_replace (succ (of_Z (z - 1))) with (of_Z z); auto. +zify. auto with zarith. Qed. Lemma B_holds : forall z : Z, B z. @@ -135,172 +90,170 @@ intros; rewrite Zopp_succ; unfold Zpred; apply BP; auto. subst z'; auto with zarith. Qed. -Theorem NZinduction : forall n, A n. +Theorem bi_induction : forall n, A n. Proof. -intro n. setoid_replace n with (Z.of_Z (Z.to_Z n)). +intro n. setoid_replace n with (of_Z (to_Z n)). apply B_holds. -zsimpl; auto. +zify. auto. Qed. End Induction. -Theorem NZadd_0_l : forall n, 0 + n == n. +Theorem add_0_l : forall n, 0 + n == n. Proof. -intros; zsimpl; auto with zarith. +intros. zify. auto with zarith. Qed. -Theorem NZadd_succ_l : forall n m, (Z.succ n) + m == Z.succ (n + m). +Theorem add_succ_l : forall n m, (succ n) + m == succ (n + m). Proof. -intros; zsimpl; auto with zarith. +intros. zify. auto with zarith. Qed. -Theorem NZsub_0_r : forall n, n - 0 == n. +Theorem sub_0_r : forall n, n - 0 == n. Proof. -intros; zsimpl; auto with zarith. +intros. zify. auto with zarith. Qed. -Theorem NZsub_succ_r : forall n m, n - (Z.succ m) == Z.pred (n - m). +Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m). Proof. -intros; zsimpl; auto with zarith. +intros. zify. auto with zarith. Qed. -Theorem NZmul_0_l : forall n, 0 * n == 0. +Theorem mul_0_l : forall n, 0 * n == 0. Proof. -intros; zsimpl; auto with zarith. +intros. zify. auto with zarith. Qed. -Theorem NZmul_succ_l : forall n m, (Z.succ n) * m == n * m + m. +Theorem mul_succ_l : forall n m, (succ n) * m == n * m + m. Proof. -intros; zsimpl; ring. +intros. zify. ring. Qed. -End NZAxiomsMod. +(** Order *) -Definition NZlt := Z.lt. -Definition NZle := Z.le. -Definition NZmin := Z.min. -Definition NZmax := Z.max. +Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). +Proof. + intros. zify. destruct (Zcompare_spec [x] [y]); auto. +Qed. -Infix "<=" := Z.le : IntScope. -Infix "<" := Z.lt : IntScope. +Definition eqb := eq_bool. -Lemma spec_compare_alt : forall x y, Z.compare x y = ([x] ?= [y])%Z. +Lemma eqb_eq : forall x y, eq_bool x y = true <-> x == y. Proof. - intros; generalize (Z.spec_compare x y). - destruct (Z.compare x y); auto. - intros H; rewrite H; symmetry; apply Zcompare_refl. + intros. zify. symmetry. apply Zeq_is_eq_bool. Qed. -Lemma spec_lt : forall x y, (x ([x]<[y])%Z. +Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare. Proof. - intros; unfold Z.lt, Zlt; rewrite spec_compare_alt; intuition. +intros x x' Hx y y' Hy. rewrite 2 spec_compare, Hx, Hy; intuition. Qed. -Lemma spec_le : forall x y, (x<=y) <-> ([x]<=[y])%Z. +Instance lt_wd : Proper (eq ==> eq ==> iff) lt. Proof. - intros; unfold Z.le, Zle; rewrite spec_compare_alt; intuition. +intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition. Qed. -Lemma spec_min : forall x y, [Z.min x y] = Zmin [x] [y]. +Theorem lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m. Proof. - intros; unfold Z.min, Zmin. - rewrite spec_compare_alt; destruct Zcompare; auto. +intros. zify. omega. Qed. -Lemma spec_max : forall x y, [Z.max x y] = Zmax [x] [y]. +Theorem lt_irrefl : forall n, ~ n < n. Proof. - intros; unfold Z.max, Zmax. - rewrite spec_compare_alt; destruct Zcompare; auto. +intros. zify. omega. Qed. -Add Morphism Z.compare with signature Z.eq ==> Z.eq ==> (@eq comparison) as compare_wd. -Proof. -intros x x' Hx y y' Hy. -rewrite 2 spec_compare_alt; unfold Z.eq in *; rewrite Hx, Hy; intuition. +Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m. +Proof. +intros. zify. omega. Qed. -Add Morphism Z.lt with signature Z.eq ==> Z.eq ==> iff as NZlt_wd. +Theorem min_l : forall n m, n <= m -> min n m == n. Proof. -intros x x' Hx y y' Hy; unfold Z.lt; rewrite Hx, Hy; intuition. +intros n m. zify. omega with *. Qed. -Add Morphism Z.le with signature Z.eq ==> Z.eq ==> iff as NZle_wd. +Theorem min_r : forall n m, m <= n -> min n m == m. Proof. -intros x x' Hx y y' Hy; unfold Z.le; rewrite Hx, Hy; intuition. +intros n m. zify. omega with *. Qed. -Add Morphism Z.min with signature Z.eq ==> Z.eq ==> Z.eq as NZmin_wd. +Theorem max_l : forall n m, m <= n -> max n m == n. Proof. -intros; red; rewrite 2 spec_min; congruence. +intros n m. zify. omega with *. Qed. -Add Morphism Z.max with signature Z.eq ==> Z.eq ==> Z.eq as NZmax_wd. +Theorem max_r : forall n m, n <= m -> max n m == m. Proof. -intros; red; rewrite 2 spec_max; congruence. +intros n m. zify. omega with *. Qed. -Theorem NZlt_eq_cases : forall n m, n <= m <-> n < m \/ n == m. +(** Part specific to integers, not natural numbers *) + +Program Instance opp_wd : Proper (eq ==> eq) opp. + +Theorem succ_pred : forall n, succ (pred n) == n. Proof. -intros. -unfold Z.eq; rewrite spec_lt, spec_le; omega. +intros. zify. auto with zarith. Qed. -Theorem NZlt_irrefl : forall n, ~ n < n. +Theorem opp_0 : - 0 == 0. Proof. -intros; rewrite spec_lt; auto with zarith. +intros. zify. auto with zarith. Qed. -Theorem NZlt_succ_r : forall n m, n < (Z.succ m) <-> n <= m. +Theorem opp_succ : forall n, - (succ n) == pred (- n). Proof. -intros; rewrite spec_lt, spec_le, Z.spec_succ; omega. +intros. zify. auto with zarith. Qed. -Theorem NZmin_l : forall n m, n <= m -> Z.min n m == n. +Theorem abs_eq : forall n, 0 <= n -> abs n == n. Proof. -intros n m; unfold Z.eq; rewrite spec_le, spec_min. -generalize (Zmin_spec [n] [m]); omega. +intros n. zify. omega with *. Qed. -Theorem NZmin_r : forall n m, m <= n -> Z.min n m == m. +Theorem abs_neq : forall n, n <= 0 -> abs n == -n. Proof. -intros n m; unfold Z.eq; rewrite spec_le, spec_min. -generalize (Zmin_spec [n] [m]); omega. +intros n. zify. omega with *. Qed. -Theorem NZmax_l : forall n m, m <= n -> Z.max n m == n. +Theorem sgn_null : forall n, n==0 -> sgn n == 0. Proof. -intros n m; unfold Z.eq; rewrite spec_le, spec_max. -generalize (Zmax_spec [n] [m]); omega. +intros n. zify. omega with *. Qed. -Theorem NZmax_r : forall n m, n <= m -> Z.max n m == m. +Theorem sgn_pos : forall n, 0 sgn n == succ 0. Proof. -intros n m; unfold Z.eq; rewrite spec_le, spec_max. -generalize (Zmax_spec [n] [m]); omega. +intros n. zify. omega with *. Qed. -End NZOrdAxiomsMod. - -Definition Zopp := Z.opp. - -Add Morphism Z.opp with signature Z.eq ==> Z.eq as Zopp_wd. +Theorem sgn_neg : forall n, n<0 -> sgn n == opp (succ 0). Proof. -intros; zsimpl; auto with zarith. +intros n. zify. omega with *. Qed. -Theorem Zsucc_pred : forall n, Z.succ (Z.pred n) == n. +Program Instance div_wd : Proper (eq==>eq==>eq) div. +Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. + +Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b). Proof. -red; intros; zsimpl; auto with zarith. +intros a b. zify. intros. apply Z_div_mod_eq_full; auto. Qed. -Theorem Zopp_0 : - 0 == 0. +Theorem mod_pos_bound : + forall a b, 0 < b -> 0 <= modulo a b /\ modulo a b < b. Proof. -red; intros; zsimpl; auto with zarith. +intros a b. zify. intros. apply Z_mod_lt; auto with zarith. Qed. -Theorem Zopp_succ : forall n, - (Z.succ n) == Z.pred (- n). +Theorem mod_neg_bound : + forall a b, b < 0 -> b < modulo a b /\ modulo a b <= 0. Proof. -intros; zsimpl; auto with zarith. +intros a b. zify. intros. apply Z_mod_neg; auto with zarith. Qed. -End ZSig_ZAxioms. +End ZTypeIsZAxioms. + +Module ZType_ZAxioms (Z : ZType) + <: ZAxiomsSig <: ZDivSig <: HasCompare Z <: HasEqBool Z <: HasMinMax Z + := Z <+ ZTypeIsZAxioms. diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v index 04a48d51..417463eb 100644 --- a/theories/Numbers/NaryFunctions.v +++ b/theories/Numbers/NaryFunctions.v @@ -8,27 +8,27 @@ (* Pierre Letouzey, Jerome Vouillon, PPS, Paris 7, 2008 *) (************************************************************************) -(*i $Id: NaryFunctions.v 10967 2008-05-22 12:59:38Z letouzey $ i*) +(*i $Id$ i*) -Open Local Scope type_scope. +Local Open Scope type_scope. Require Import List. (** * Generic dependently-typed operators about [n]-ary functions *) -(** The type of [n]-ary function: [nfun A n B] is +(** The type of [n]-ary function: [nfun A n B] is [A -> ... -> A -> B] with [n] occurences of [A] in this type. *) -Fixpoint nfun A n B := +Fixpoint nfun A n B := match n with - | O => B + | O => B | S n => A -> (nfun A n B) - end. + end. Notation " A ^^ n --> B " := (nfun A n B) (at level 50, n at next level) : type_scope. -(** [napply_cst _ _ a n f] iterates [n] times the application of a +(** [napply_cst _ _ a n f] iterates [n] times the application of a particular constant [a] to the [n]-ary function [f]. *) Fixpoint napply_cst (A B:Type)(a:A) n : (A^^n-->B) -> B := @@ -40,47 +40,47 @@ Fixpoint napply_cst (A B:Type)(a:A) n : (A^^n-->B) -> B := (** A generic transformation from an n-ary function to another one.*) -Fixpoint nfun_to_nfun (A B C:Type)(f:B -> C) n : +Fixpoint nfun_to_nfun (A B C:Type)(f:B -> C) n : (A^^n-->B) -> (A^^n-->C) := - match n return (A^^n-->B) -> (A^^n-->C) with + match n return (A^^n-->B) -> (A^^n-->C) with | O => f | S n => fun g a => nfun_to_nfun _ _ _ f n (g a) end. -(** [napply_except_last _ _ n f] expects [n] arguments of type [A], - applies [n-1] of them to [f] and discard the last one. *) +(** [napply_except_last _ _ n f] expects [n] arguments of type [A], + applies [n-1] of them to [f] and discard the last one. *) -Definition napply_except_last (A B:Type) := +Definition napply_except_last (A B:Type) := nfun_to_nfun A B (A->B) (fun b a => b). -(** [napply_then_last _ _ a n f] expects [n] arguments of type [A], - applies them to [f] and then apply [a] to the result. *) +(** [napply_then_last _ _ a n f] expects [n] arguments of type [A], + applies them to [f] and then apply [a] to the result. *) -Definition napply_then_last (A B:Type)(a:A) := +Definition napply_then_last (A B:Type)(a:A) := nfun_to_nfun A (A->B) B (fun fab => fab a). -(** [napply_discard _ b n] expects [n] arguments, discards then, +(** [napply_discard _ b n] expects [n] arguments, discards then, and returns [b]. *) Fixpoint napply_discard (A B:Type)(b:B) n : A^^n-->B := - match n return A^^n-->B with + match n return A^^n-->B with | O => b | S n => fun _ => napply_discard _ _ b n end. (** A fold function *) -Fixpoint nfold A B (f:A->B->B)(b:B) n : (A^^n-->B) := - match n return (A^^n-->B) with +Fixpoint nfold A B (f:A->B->B)(b:B) n : (A^^n-->B) := + match n return (A^^n-->B) with | O => b | S n => fun a => (nfold _ _ f (f a b) n) end. -(** [n]-ary products : [nprod A n] is [A*...*A*unit], +(** [n]-ary products : [nprod A n] is [A*...*A*unit], with [n] occurrences of [A] in this type. *) -Fixpoint nprod A n : Type := match n with +Fixpoint nprod A n : Type := match n with | O => unit | S n => (A * nprod A n)%type end. @@ -89,54 +89,54 @@ Notation "A ^ n" := (nprod A n) : type_scope. (** [n]-ary curryfication / uncurryfication *) -Fixpoint ncurry (A B:Type) n : (A^n -> B) -> (A^^n-->B) := - match n return (A^n -> B) -> (A^^n-->B) with +Fixpoint ncurry (A B:Type) n : (A^n -> B) -> (A^^n-->B) := + match n return (A^n -> B) -> (A^^n-->B) with | O => fun x => x tt | S n => fun f a => ncurry _ _ n (fun p => f (a,p)) end. -Fixpoint nuncurry (A B:Type) n : (A^^n-->B) -> (A^n -> B) := +Fixpoint nuncurry (A B:Type) n : (A^^n-->B) -> (A^n -> B) := match n return (A^^n-->B) -> (A^n -> B) with | O => fun x _ => x | S n => fun f p => let (x,p) := p in nuncurry _ _ n (f x) p end. -(** Earlier functions can also be defined via [ncurry/nuncurry]. +(** Earlier functions can also be defined via [ncurry/nuncurry]. For instance : *) Definition nfun_to_nfun_bis A B C (f:B->C) n : - (A^^n-->B) -> (A^^n-->C) := + (A^^n-->B) -> (A^^n-->C) := fun anb => ncurry _ _ n (fun an => f ((nuncurry _ _ n anb) an)). -(** We can also us it to obtain another [fold] function, +(** We can also us it to obtain another [fold] function, equivalent to the previous one, but with a nicer expansion (see for instance Int31.iszero). *) -Fixpoint nfold_bis A B (f:A->B->B)(b:B) n : (A^^n-->B) := - match n return (A^^n-->B) with +Fixpoint nfold_bis A B (f:A->B->B)(b:B) n : (A^^n-->B) := + match n return (A^^n-->B) with | O => b - | S n => fun a => + | S n => fun a => nfun_to_nfun_bis _ _ _ (f a) n (nfold_bis _ _ f b n) end. (** From [nprod] to [list] *) -Fixpoint nprod_to_list (A:Type) n : A^n -> list A := - match n with +Fixpoint nprod_to_list (A:Type) n : A^n -> list A := + match n with | O => fun _ => nil | S n => fun p => let (x,p) := p in x::(nprod_to_list _ n p) end. (** From [list] to [nprod] *) -Fixpoint nprod_of_list (A:Type)(l:list A) : A^(length l) := - match l return A^(length l) with +Fixpoint nprod_of_list (A:Type)(l:list A) : A^(length l) := + match l return A^(length l) with | nil => tt | x::l => (x, nprod_of_list _ l) end. (** This gives an additional way to write the fold *) -Definition nfold_list (A B:Type)(f:A->B->B)(b:B) n : (A^^n-->B) := +Definition nfold_list (A B:Type)(f:A->B->B)(b:B) n : (A^^n-->B) := ncurry _ _ n (fun p => fold_right f b (nprod_to_list _ _ p)). diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v index c9bb5c95..9535cfdb 100644 --- a/theories/Numbers/NatInt/NZAdd.v +++ b/theories/Numbers/NatInt/NZAdd.v @@ -8,84 +8,83 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZAdd.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) -Require Import NZAxioms. -Require Import NZBase. +Require Import NZAxioms NZBase. -Module NZAddPropFunct (Import NZAxiomsMod : NZAxiomsSig). -Module Export NZBasePropMod := NZBasePropFunct NZAxiomsMod. -Open Local Scope NatIntScope. +Module Type NZAddPropSig + (Import NZ : NZAxiomsSig')(Import NZBase : NZBasePropSig NZ). -Theorem NZadd_0_r : forall n : NZ, n + 0 == n. +Hint Rewrite + pred_succ add_0_l add_succ_l mul_0_l mul_succ_l sub_0_r sub_succ_r : nz. +Ltac nzsimpl := autorewrite with nz. + +Theorem add_0_r : forall n, n + 0 == n. Proof. -NZinduct n. now rewrite NZadd_0_l. -intro. rewrite NZadd_succ_l. now rewrite NZsucc_inj_wd. +nzinduct n. now nzsimpl. +intro. nzsimpl. now rewrite succ_inj_wd. Qed. -Theorem NZadd_succ_r : forall n m : NZ, n + S m == S (n + m). +Theorem add_succ_r : forall n m, n + S m == S (n + m). Proof. -intros n m; NZinduct n. -now do 2 rewrite NZadd_0_l. -intro. repeat rewrite NZadd_succ_l. now rewrite NZsucc_inj_wd. +intros n m; nzinduct n. now nzsimpl. +intro. nzsimpl. now rewrite succ_inj_wd. Qed. -Theorem NZadd_comm : forall n m : NZ, n + m == m + n. +Hint Rewrite add_0_r add_succ_r : nz. + +Theorem add_comm : forall n m, n + m == m + n. Proof. -intros n m; NZinduct n. -rewrite NZadd_0_l; now rewrite NZadd_0_r. -intros n. rewrite NZadd_succ_l; rewrite NZadd_succ_r. now rewrite NZsucc_inj_wd. +intros n m; nzinduct n. now nzsimpl. +intro. nzsimpl. now rewrite succ_inj_wd. Qed. -Theorem NZadd_1_l : forall n : NZ, 1 + n == S n. +Theorem add_1_l : forall n, 1 + n == S n. Proof. -intro n; rewrite NZadd_succ_l; now rewrite NZadd_0_l. +intro n; now nzsimpl. Qed. -Theorem NZadd_1_r : forall n : NZ, n + 1 == S n. +Theorem add_1_r : forall n, n + 1 == S n. Proof. -intro n; rewrite NZadd_comm; apply NZadd_1_l. +intro n; now nzsimpl. Qed. -Theorem NZadd_assoc : forall n m p : NZ, n + (m + p) == (n + m) + p. +Theorem add_assoc : forall n m p, n + (m + p) == (n + m) + p. Proof. -intros n m p; NZinduct n. -now do 2 rewrite NZadd_0_l. -intro. do 3 rewrite NZadd_succ_l. now rewrite NZsucc_inj_wd. +intros n m p; nzinduct n. now nzsimpl. +intro. nzsimpl. now rewrite succ_inj_wd. Qed. -Theorem NZadd_shuffle1 : forall n m p q : NZ, (n + m) + (p + q) == (n + p) + (m + q). +Theorem add_cancel_l : forall n m p, p + n == p + m <-> n == m. Proof. -intros n m p q. -rewrite <- (NZadd_assoc n m (p + q)). rewrite (NZadd_comm m (p + q)). -rewrite <- (NZadd_assoc p q m). rewrite (NZadd_assoc n p (q + m)). -now rewrite (NZadd_comm q m). +intros n m p; nzinduct p. now nzsimpl. +intro p. nzsimpl. now rewrite succ_inj_wd. Qed. -Theorem NZadd_shuffle2 : forall n m p q : NZ, (n + m) + (p + q) == (n + q) + (m + p). +Theorem add_cancel_r : forall n m p, n + p == m + p <-> n == m. Proof. -intros n m p q. -rewrite <- (NZadd_assoc n m (p + q)). rewrite (NZadd_assoc m p q). -rewrite (NZadd_comm (m + p) q). now rewrite <- (NZadd_assoc n q (m + p)). +intros n m p. rewrite (add_comm n p), (add_comm m p). apply add_cancel_l. Qed. -Theorem NZadd_cancel_l : forall n m p : NZ, p + n == p + m <-> n == m. +Theorem add_shuffle0 : forall n m p, n+m+p == n+p+m. Proof. -intros n m p; NZinduct p. -now do 2 rewrite NZadd_0_l. -intro p. do 2 rewrite NZadd_succ_l. now rewrite NZsucc_inj_wd. +intros n m p. rewrite <- 2 add_assoc, add_cancel_l. apply add_comm. Qed. -Theorem NZadd_cancel_r : forall n m p : NZ, n + p == m + p <-> n == m. +Theorem add_shuffle1 : forall n m p q, (n + m) + (p + q) == (n + p) + (m + q). Proof. -intros n m p. rewrite (NZadd_comm n p); rewrite (NZadd_comm m p). -apply NZadd_cancel_l. +intros n m p q. rewrite 2 add_assoc, add_cancel_r. apply add_shuffle0. Qed. -Theorem NZsub_1_r : forall n : NZ, n - 1 == P n. +Theorem add_shuffle2 : forall n m p q, (n + m) + (p + q) == (n + q) + (m + p). Proof. -intro n; rewrite NZsub_succ_r; now rewrite NZsub_0_r. +intros n m p q. +rewrite 2 add_assoc, add_shuffle0, add_cancel_r. apply add_shuffle0. Qed. -End NZAddPropFunct. +Theorem sub_1_r : forall n, n - 1 == P n. +Proof. +intro n; now nzsimpl. +Qed. +End NZAddPropSig. diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v index 50d1c42f..97c12202 100644 --- a/theories/Numbers/NatInt/NZAddOrder.v +++ b/theories/Numbers/NatInt/NZAddOrder.v @@ -8,159 +8,146 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZAddOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) -Require Import NZAxioms. -Require Import NZOrder. +Require Import NZAxioms NZBase NZMul NZOrder. -Module NZAddOrderPropFunct (Import NZOrdAxiomsMod : NZOrdAxiomsSig). -Module Export NZOrderPropMod := NZOrderPropFunct NZOrdAxiomsMod. -Open Local Scope NatIntScope. +Module Type NZAddOrderPropSig (Import NZ : NZOrdAxiomsSig'). +Include NZBasePropSig NZ <+ NZMulPropSig NZ <+ NZOrderPropSig NZ. -Theorem NZadd_lt_mono_l : forall n m p : NZ, n < m <-> p + n < p + m. +Theorem add_lt_mono_l : forall n m p, n < m <-> p + n < p + m. Proof. -intros n m p; NZinduct p. -now do 2 rewrite NZadd_0_l. -intro p. do 2 rewrite NZadd_succ_l. now rewrite <- NZsucc_lt_mono. +intros n m p; nzinduct p. now nzsimpl. +intro p. nzsimpl. now rewrite <- succ_lt_mono. Qed. -Theorem NZadd_lt_mono_r : forall n m p : NZ, n < m <-> n + p < m + p. +Theorem add_lt_mono_r : forall n m p, n < m <-> n + p < m + p. Proof. -intros n m p. -rewrite (NZadd_comm n p); rewrite (NZadd_comm m p); apply NZadd_lt_mono_l. +intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_lt_mono_l. Qed. -Theorem NZadd_lt_mono : forall n m p q : NZ, n < m -> p < q -> n + p < m + q. +Theorem add_lt_mono : forall n m p q, n < m -> p < q -> n + p < m + q. Proof. intros n m p q H1 H2. -apply NZlt_trans with (m + p); -[now apply -> NZadd_lt_mono_r | now apply -> NZadd_lt_mono_l]. +apply lt_trans with (m + p); +[now apply -> add_lt_mono_r | now apply -> add_lt_mono_l]. Qed. -Theorem NZadd_le_mono_l : forall n m p : NZ, n <= m <-> p + n <= p + m. +Theorem add_le_mono_l : forall n m p, n <= m <-> p + n <= p + m. Proof. -intros n m p; NZinduct p. -now do 2 rewrite NZadd_0_l. -intro p. do 2 rewrite NZadd_succ_l. now rewrite <- NZsucc_le_mono. +intros n m p; nzinduct p. now nzsimpl. +intro p. nzsimpl. now rewrite <- succ_le_mono. Qed. -Theorem NZadd_le_mono_r : forall n m p : NZ, n <= m <-> n + p <= m + p. +Theorem add_le_mono_r : forall n m p, n <= m <-> n + p <= m + p. Proof. -intros n m p. -rewrite (NZadd_comm n p); rewrite (NZadd_comm m p); apply NZadd_le_mono_l. +intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_le_mono_l. Qed. -Theorem NZadd_le_mono : forall n m p q : NZ, n <= m -> p <= q -> n + p <= m + q. +Theorem add_le_mono : forall n m p q, n <= m -> p <= q -> n + p <= m + q. Proof. intros n m p q H1 H2. -apply NZle_trans with (m + p); -[now apply -> NZadd_le_mono_r | now apply -> NZadd_le_mono_l]. +apply le_trans with (m + p); +[now apply -> add_le_mono_r | now apply -> add_le_mono_l]. Qed. -Theorem NZadd_lt_le_mono : forall n m p q : NZ, n < m -> p <= q -> n + p < m + q. +Theorem add_lt_le_mono : forall n m p q, n < m -> p <= q -> n + p < m + q. Proof. intros n m p q H1 H2. -apply NZlt_le_trans with (m + p); -[now apply -> NZadd_lt_mono_r | now apply -> NZadd_le_mono_l]. +apply lt_le_trans with (m + p); +[now apply -> add_lt_mono_r | now apply -> add_le_mono_l]. Qed. -Theorem NZadd_le_lt_mono : forall n m p q : NZ, n <= m -> p < q -> n + p < m + q. +Theorem add_le_lt_mono : forall n m p q, n <= m -> p < q -> n + p < m + q. Proof. intros n m p q H1 H2. -apply NZle_lt_trans with (m + p); -[now apply -> NZadd_le_mono_r | now apply -> NZadd_lt_mono_l]. +apply le_lt_trans with (m + p); +[now apply -> add_le_mono_r | now apply -> add_lt_mono_l]. Qed. -Theorem NZadd_pos_pos : forall n m : NZ, 0 < n -> 0 < m -> 0 < n + m. +Theorem add_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n + m. Proof. -intros n m H1 H2. rewrite <- (NZadd_0_l 0). now apply NZadd_lt_mono. +intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono. Qed. -Theorem NZadd_pos_nonneg : forall n m : NZ, 0 < n -> 0 <= m -> 0 < n + m. +Theorem add_pos_nonneg : forall n m, 0 < n -> 0 <= m -> 0 < n + m. Proof. -intros n m H1 H2. rewrite <- (NZadd_0_l 0). now apply NZadd_lt_le_mono. +intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono. Qed. -Theorem NZadd_nonneg_pos : forall n m : NZ, 0 <= n -> 0 < m -> 0 < n + m. +Theorem add_nonneg_pos : forall n m, 0 <= n -> 0 < m -> 0 < n + m. Proof. -intros n m H1 H2. rewrite <- (NZadd_0_l 0). now apply NZadd_le_lt_mono. +intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono. Qed. -Theorem NZadd_nonneg_nonneg : forall n m : NZ, 0 <= n -> 0 <= m -> 0 <= n + m. +Theorem add_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n + m. Proof. -intros n m H1 H2. rewrite <- (NZadd_0_l 0). now apply NZadd_le_mono. +intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono. Qed. -Theorem NZlt_add_pos_l : forall n m : NZ, 0 < n -> m < n + m. +Theorem lt_add_pos_l : forall n m, 0 < n -> m < n + m. Proof. -intros n m H. apply -> (NZadd_lt_mono_r 0 n m) in H. -now rewrite NZadd_0_l in H. +intros n m. rewrite (add_lt_mono_r 0 n m). now nzsimpl. Qed. -Theorem NZlt_add_pos_r : forall n m : NZ, 0 < n -> m < m + n. +Theorem lt_add_pos_r : forall n m, 0 < n -> m < m + n. Proof. -intros; rewrite NZadd_comm; now apply NZlt_add_pos_l. +intros; rewrite add_comm; now apply lt_add_pos_l. Qed. -Theorem NZle_lt_add_lt : forall n m p q : NZ, n <= m -> p + m < q + n -> p < q. +Theorem le_lt_add_lt : forall n m p q, n <= m -> p + m < q + n -> p < q. Proof. -intros n m p q H1 H2. destruct (NZle_gt_cases q p); [| assumption]. -pose proof (NZadd_le_mono q p n m H H1) as H3. apply <- NZnle_gt in H2. -false_hyp H3 H2. +intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption]. +contradict H2. rewrite nlt_ge. now apply add_le_mono. Qed. -Theorem NZlt_le_add_lt : forall n m p q : NZ, n < m -> p + m <= q + n -> p < q. +Theorem lt_le_add_lt : forall n m p q, n < m -> p + m <= q + n -> p < q. Proof. -intros n m p q H1 H2. destruct (NZle_gt_cases q p); [| assumption]. -pose proof (NZadd_le_lt_mono q p n m H H1) as H3. apply <- NZnle_gt in H3. -false_hyp H2 H3. +intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption]. +contradict H2. rewrite nle_gt. now apply add_le_lt_mono. Qed. -Theorem NZle_le_add_le : forall n m p q : NZ, n <= m -> p + m <= q + n -> p <= q. +Theorem le_le_add_le : forall n m p q, n <= m -> p + m <= q + n -> p <= q. Proof. -intros n m p q H1 H2. destruct (NZle_gt_cases p q); [assumption |]. -pose proof (NZadd_lt_le_mono q p n m H H1) as H3. apply <- NZnle_gt in H3. -false_hyp H2 H3. +intros n m p q H1 H2. destruct (le_gt_cases p q); [assumption |]. +contradict H2. rewrite nle_gt. now apply add_lt_le_mono. Qed. -Theorem NZadd_lt_cases : forall n m p q : NZ, n + m < p + q -> n < p \/ m < q. +Theorem add_lt_cases : forall n m p q, n + m < p + q -> n < p \/ m < q. Proof. intros n m p q H; -destruct (NZle_gt_cases p n) as [H1 | H1]. -destruct (NZle_gt_cases q m) as [H2 | H2]. -pose proof (NZadd_le_mono p n q m H1 H2) as H3. apply -> NZle_ngt in H3. -false_hyp H H3. -now right. now left. +destruct (le_gt_cases p n) as [H1 | H1]; [| now left]. +destruct (le_gt_cases q m) as [H2 | H2]; [| now right]. +contradict H; rewrite nlt_ge. now apply add_le_mono. Qed. -Theorem NZadd_le_cases : forall n m p q : NZ, n + m <= p + q -> n <= p \/ m <= q. +Theorem add_le_cases : forall n m p q, n + m <= p + q -> n <= p \/ m <= q. Proof. intros n m p q H. -destruct (NZle_gt_cases n p) as [H1 | H1]. now left. -destruct (NZle_gt_cases m q) as [H2 | H2]. now right. -assert (H3 : p + q < n + m) by now apply NZadd_lt_mono. -apply -> NZle_ngt in H. false_hyp H3 H. +destruct (le_gt_cases n p) as [H1 | H1]. now left. +destruct (le_gt_cases m q) as [H2 | H2]. now right. +contradict H; rewrite nle_gt. now apply add_lt_mono. Qed. -Theorem NZadd_neg_cases : forall n m : NZ, n + m < 0 -> n < 0 \/ m < 0. +Theorem add_neg_cases : forall n m, n + m < 0 -> n < 0 \/ m < 0. Proof. -intros n m H; apply NZadd_lt_cases; now rewrite NZadd_0_l. +intros n m H; apply add_lt_cases; now nzsimpl. Qed. -Theorem NZadd_pos_cases : forall n m : NZ, 0 < n + m -> 0 < n \/ 0 < m. +Theorem add_pos_cases : forall n m, 0 < n + m -> 0 < n \/ 0 < m. Proof. -intros n m H; apply NZadd_lt_cases; now rewrite NZadd_0_l. +intros n m H; apply add_lt_cases; now nzsimpl. Qed. -Theorem NZadd_nonpos_cases : forall n m : NZ, n + m <= 0 -> n <= 0 \/ m <= 0. +Theorem add_nonpos_cases : forall n m, n + m <= 0 -> n <= 0 \/ m <= 0. Proof. -intros n m H; apply NZadd_le_cases; now rewrite NZadd_0_l. +intros n m H; apply add_le_cases; now nzsimpl. Qed. -Theorem NZadd_nonneg_cases : forall n m : NZ, 0 <= n + m -> 0 <= n \/ 0 <= m. +Theorem add_nonneg_cases : forall n m, 0 <= n + m -> 0 <= n \/ 0 <= m. Proof. -intros n m H; apply NZadd_le_cases; now rewrite NZadd_0_l. +intros n m H; apply add_le_cases; now nzsimpl. Qed. -End NZAddOrderPropFunct. +End NZAddOrderPropSig. diff --git a/theories/Numbers/NatInt/NZAxioms.v b/theories/Numbers/NatInt/NZAxioms.v index 26933646..ee7ee159 100644 --- a/theories/Numbers/NatInt/NZAxioms.v +++ b/theories/Numbers/NatInt/NZAxioms.v @@ -5,95 +5,115 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Evgeny Makarov, INRIA, 2007 *) -(************************************************************************) -(*i $Id: NZAxioms.v 11040 2008-06-03 00:04:16Z letouzey $ i*) - -Require Export NumPrelude. - -Module Type NZAxiomsSig. - -Parameter Inline NZ : Type. -Parameter Inline NZeq : NZ -> NZ -> Prop. -Parameter Inline NZ0 : NZ. -Parameter Inline NZsucc : NZ -> NZ. -Parameter Inline NZpred : NZ -> NZ. -Parameter Inline NZadd : NZ -> NZ -> NZ. -Parameter Inline NZsub : NZ -> NZ -> NZ. -Parameter Inline NZmul : NZ -> NZ -> NZ. - -(* Unary subtraction (opp) is not defined on natural numbers, so we have - it for integers only *) - -Axiom NZeq_equiv : equiv NZ NZeq. -Add Relation NZ NZeq - reflexivity proved by (proj1 NZeq_equiv) - symmetry proved by (proj2 (proj2 NZeq_equiv)) - transitivity proved by (proj1 (proj2 NZeq_equiv)) -as NZeq_rel. - -Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd. -Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd. -Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd. -Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd. -Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd. - -Delimit Scope NatIntScope with NatInt. -Open Local Scope NatIntScope. -Notation "x == y" := (NZeq x y) (at level 70) : NatIntScope. -Notation "x ~= y" := (~ NZeq x y) (at level 70) : NatIntScope. -Notation "0" := NZ0 : NatIntScope. -Notation S := NZsucc. -Notation P := NZpred. -Notation "1" := (S 0) : NatIntScope. -Notation "x + y" := (NZadd x y) : NatIntScope. -Notation "x - y" := (NZsub x y) : NatIntScope. -Notation "x * y" := (NZmul x y) : NatIntScope. - -Axiom NZpred_succ : forall n : NZ, P (S n) == n. - -Axiom NZinduction : - forall A : NZ -> Prop, predicate_wd NZeq A -> - A 0 -> (forall n : NZ, A n <-> A (S n)) -> forall n : NZ, A n. - -Axiom NZadd_0_l : forall n : NZ, 0 + n == n. -Axiom NZadd_succ_l : forall n m : NZ, (S n) + m == S (n + m). - -Axiom NZsub_0_r : forall n : NZ, n - 0 == n. -Axiom NZsub_succ_r : forall n m : NZ, n - (S m) == P (n - m). - -Axiom NZmul_0_l : forall n : NZ, 0 * n == 0. -Axiom NZmul_succ_l : forall n m : NZ, S n * m == n * m + m. - -End NZAxiomsSig. - -Module Type NZOrdAxiomsSig. -Declare Module Export NZAxiomsMod : NZAxiomsSig. -Open Local Scope NatIntScope. - -Parameter Inline NZlt : NZ -> NZ -> Prop. -Parameter Inline NZle : NZ -> NZ -> Prop. -Parameter Inline NZmin : NZ -> NZ -> NZ. -Parameter Inline NZmax : NZ -> NZ -> NZ. - -Add Morphism NZlt with signature NZeq ==> NZeq ==> iff as NZlt_wd. -Add Morphism NZle with signature NZeq ==> NZeq ==> iff as NZle_wd. -Add Morphism NZmin with signature NZeq ==> NZeq ==> NZeq as NZmin_wd. -Add Morphism NZmax with signature NZeq ==> NZeq ==> NZeq as NZmax_wd. - -Notation "x < y" := (NZlt x y) : NatIntScope. -Notation "x <= y" := (NZle x y) : NatIntScope. -Notation "x > y" := (NZlt y x) (only parsing) : NatIntScope. -Notation "x >= y" := (NZle y x) (only parsing) : NatIntScope. - -Axiom NZlt_eq_cases : forall n m : NZ, n <= m <-> n < m \/ n == m. -Axiom NZlt_irrefl : forall n : NZ, ~ (n < n). -Axiom NZlt_succ_r : forall n m : NZ, n < S m <-> n <= m. - -Axiom NZmin_l : forall n m : NZ, n <= m -> NZmin n m == n. -Axiom NZmin_r : forall n m : NZ, m <= n -> NZmin n m == m. -Axiom NZmax_l : forall n m : NZ, m <= n -> NZmax n m == n. -Axiom NZmax_r : forall n m : NZ, n <= m -> NZmax n m == m. - -End NZOrdAxiomsSig. +(** Initial Author : Evgeny Makarov, INRIA, 2007 *) + +(*i $Id$ i*) + +Require Export Equalities Orders NumPrelude GenericMinMax. + +(** Axiomatization of a domain with zero, successor, predecessor, + and a bi-directional induction principle. We require [P (S n) = n] + but not the other way around, since this domain is meant + to be either N or Z. In fact it can be a few other things, + for instance [Z/nZ] (See file [NZDomain] for a study of that). +*) + +Module Type ZeroSuccPred (Import T:Typ). + Parameter Inline zero : t. + Parameters Inline succ pred : t -> t. +End ZeroSuccPred. + +Module Type ZeroSuccPredNotation (T:Typ)(Import NZ:ZeroSuccPred T). + Notation "0" := zero. + Notation S := succ. + Notation P := pred. + Notation "1" := (S 0). + Notation "2" := (S 1). +End ZeroSuccPredNotation. + +Module Type ZeroSuccPred' (T:Typ) := + ZeroSuccPred T <+ ZeroSuccPredNotation T. + +Module Type IsNZDomain (Import E:Eq')(Import NZ:ZeroSuccPred' E). + Declare Instance succ_wd : Proper (eq ==> eq) S. + Declare Instance pred_wd : Proper (eq ==> eq) P. + Axiom pred_succ : forall n, P (S n) == n. + Axiom bi_induction : + forall A : t -> Prop, Proper (eq==>iff) A -> + A 0 -> (forall n, A n <-> A (S n)) -> forall n, A n. +End IsNZDomain. + +Module Type NZDomainSig := EqualityType <+ ZeroSuccPred <+ IsNZDomain. +Module Type NZDomainSig' := EqualityType' <+ ZeroSuccPred' <+ IsNZDomain. + + +(** Axiomatization of basic operations : [+] [-] [*] *) + +Module Type AddSubMul (Import T:Typ). + Parameters Inline add sub mul : t -> t -> t. +End AddSubMul. + +Module Type AddSubMulNotation (T:Typ)(Import NZ:AddSubMul T). + Notation "x + y" := (add x y). + Notation "x - y" := (sub x y). + Notation "x * y" := (mul x y). +End AddSubMulNotation. + +Module Type AddSubMul' (T:Typ) := AddSubMul T <+ AddSubMulNotation T. + +Module Type IsAddSubMul (Import E:NZDomainSig')(Import NZ:AddSubMul' E). + Declare Instance add_wd : Proper (eq ==> eq ==> eq) add. + Declare Instance sub_wd : Proper (eq ==> eq ==> eq) sub. + Declare Instance mul_wd : Proper (eq ==> eq ==> eq) mul. + Axiom add_0_l : forall n, 0 + n == n. + Axiom add_succ_l : forall n m, (S n) + m == S (n + m). + Axiom sub_0_r : forall n, n - 0 == n. + Axiom sub_succ_r : forall n m, n - (S m) == P (n - m). + Axiom mul_0_l : forall n, 0 * n == 0. + Axiom mul_succ_l : forall n m, S n * m == n * m + m. +End IsAddSubMul. + +Module Type NZBasicFunsSig := NZDomainSig <+ AddSubMul <+ IsAddSubMul. +Module Type NZBasicFunsSig' := NZDomainSig' <+ AddSubMul' <+IsAddSubMul. + +(** Old name for the same interface: *) + +Module Type NZAxiomsSig := NZBasicFunsSig. +Module Type NZAxiomsSig' := NZBasicFunsSig'. + +(** Axiomatization of order *) + +Module Type NZOrd := NZDomainSig <+ HasLt <+ HasLe. +Module Type NZOrd' := NZDomainSig' <+ HasLt <+ HasLe <+ + LtNotation <+ LeNotation <+ LtLeNotation. + +Module Type IsNZOrd (Import NZ : NZOrd'). + Declare Instance lt_wd : Proper (eq ==> eq ==> iff) lt. + Axiom lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m. + Axiom lt_irrefl : forall n, ~ (n < n). + Axiom lt_succ_r : forall n m, n < S m <-> n <= m. +End IsNZOrd. + +(** NB: the compatibility of [le] can be proved later from [lt_wd] + and [lt_eq_cases] *) + +Module Type NZOrdSig := NZOrd <+ IsNZOrd. +Module Type NZOrdSig' := NZOrd' <+ IsNZOrd. + +(** Everything together : *) + +Module Type NZOrdAxiomsSig <: NZBasicFunsSig <: NZOrdSig + := NZOrdSig <+ AddSubMul <+ IsAddSubMul <+ HasMinMax. +Module Type NZOrdAxiomsSig' <: NZOrdAxiomsSig + := NZOrdSig' <+ AddSubMul' <+ IsAddSubMul <+ HasMinMax. + + +(** Same, plus a comparison function. *) + +Module Type NZDecOrdSig := NZOrdSig <+ HasCompare. +Module Type NZDecOrdSig' := NZOrdSig' <+ HasCompare. + +Module Type NZDecOrdAxiomsSig := NZOrdAxiomsSig <+ HasCompare. +Module Type NZDecOrdAxiomsSig' := NZOrdAxiomsSig' <+ HasCompare. + diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v index bd4d6232..18e3b9b9 100644 --- a/theories/Numbers/NatInt/NZBase.v +++ b/theories/Numbers/NatInt/NZBase.v @@ -8,45 +8,54 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZBase.v 11674 2008-12-12 19:48:40Z letouzey $ i*) +(*i $Id$ i*) Require Import NZAxioms. -Module NZBasePropFunct (Import NZAxiomsMod : NZAxiomsSig). -Open Local Scope NatIntScope. +Module Type NZBasePropSig (Import NZ : NZDomainSig'). -Theorem NZneq_sym : forall n m : NZ, n ~= m -> m ~= n. +Include BackportEq NZ NZ. (** eq_refl, eq_sym, eq_trans *) + +Lemma eq_sym_iff : forall x y, x==y <-> y==x. +Proof. +intros; split; symmetry; auto. +Qed. + +(* TODO: how register ~= (which is just a notation) as a Symmetric relation, + hence allowing "symmetry" tac ? *) + +Theorem neq_sym : forall n m, n ~= m -> m ~= n. Proof. intros n m H1 H2; symmetry in H2; false_hyp H2 H1. Qed. -Theorem NZE_stepl : forall x y z : NZ, x == y -> x == z -> z == y. +Theorem eq_stepl : forall x y z, x == y -> x == z -> z == y. Proof. intros x y z H1 H2; now rewrite <- H1. Qed. -Declare Left Step NZE_stepl. -(* The right step lemma is just the transitivity of NZeq *) -Declare Right Step (proj1 (proj2 NZeq_equiv)). +Declare Left Step eq_stepl. +(* The right step lemma is just the transitivity of eq *) +Declare Right Step (@Equivalence_Transitive _ _ eq_equiv). -Theorem NZsucc_inj : forall n1 n2 : NZ, S n1 == S n2 -> n1 == n2. +Theorem succ_inj : forall n1 n2, S n1 == S n2 -> n1 == n2. Proof. intros n1 n2 H. -apply NZpred_wd in H. now do 2 rewrite NZpred_succ in H. +apply pred_wd in H. now do 2 rewrite pred_succ in H. Qed. (* The following theorem is useful as an equivalence for proving bidirectional induction steps *) -Theorem NZsucc_inj_wd : forall n1 n2 : NZ, S n1 == S n2 <-> n1 == n2. +Theorem succ_inj_wd : forall n1 n2, S n1 == S n2 <-> n1 == n2. Proof. intros; split. -apply NZsucc_inj. -apply NZsucc_wd. +apply succ_inj. +apply succ_wd. Qed. -Theorem NZsucc_inj_wd_neg : forall n m : NZ, S n ~= S m <-> n ~= m. +Theorem succ_inj_wd_neg : forall n m, S n ~= S m <-> n ~= m. Proof. -intros; now rewrite NZsucc_inj_wd. +intros; now rewrite succ_inj_wd. Qed. (* We cannot prove that the predecessor is injective, nor that it is @@ -54,31 +63,27 @@ left-inverse to the successor at this point *) Section CentralInduction. -Variable A : predicate NZ. - -Hypothesis A_wd : predicate_wd NZeq A. - -Add Morphism A with signature NZeq ==> iff as A_morph. -Proof. apply A_wd. Qed. +Variable A : predicate t. +Hypothesis A_wd : Proper (eq==>iff) A. -Theorem NZcentral_induction : - forall z : NZ, A z -> - (forall n : NZ, A n <-> A (S n)) -> - forall n : NZ, A n. +Theorem central_induction : + forall z, A z -> + (forall n, A n <-> A (S n)) -> + forall n, A n. Proof. -intros z Base Step; revert Base; pattern z; apply NZinduction. +intros z Base Step; revert Base; pattern z; apply bi_induction. solve_predicate_wd. -intro; now apply NZinduction. +intro; now apply bi_induction. intro; pose proof (Step n); tauto. Qed. End CentralInduction. -Tactic Notation "NZinduct" ident(n) := - induction_maker n ltac:(apply NZinduction). +Tactic Notation "nzinduct" ident(n) := + induction_maker n ltac:(apply bi_induction). -Tactic Notation "NZinduct" ident(n) constr(u) := - induction_maker n ltac:(apply NZcentral_induction with (z := u)). +Tactic Notation "nzinduct" ident(n) constr(u) := + induction_maker n ltac:(apply central_induction with (z := u)). -End NZBasePropFunct. +End NZBasePropSig. diff --git a/theories/Numbers/NatInt/NZDiv.v b/theories/Numbers/NatInt/NZDiv.v new file mode 100644 index 00000000..1f6c615b --- /dev/null +++ b/theories/Numbers/NatInt/NZDiv.v @@ -0,0 +1,542 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> t. +End DivMod. + +Module Type DivModNotation (T:Typ)(Import NZ:DivMod T). + Infix "/" := div. + Infix "mod" := modulo (at level 40, no associativity). +End DivModNotation. + +Module Type DivMod' (T:Typ) := DivMod T <+ DivModNotation T. + +Module Type NZDivCommon (Import NZ : NZAxiomsSig')(Import DM : DivMod' NZ). + Declare Instance div_wd : Proper (eq==>eq==>eq) div. + Declare Instance mod_wd : Proper (eq==>eq==>eq) modulo. + Axiom div_mod : forall a b, b ~= 0 -> a == b*(a/b) + (a mod b). +End NZDivCommon. + +(** The different divisions will only differ in the conditions + they impose on [modulo]. For NZ, we only describe behavior + on positive numbers. + + NB: This axiom would also be true for N and Z, but redundant. +*) + +Module Type NZDivSpecific (Import NZ : NZOrdAxiomsSig')(Import DM : DivMod' NZ). + Axiom mod_bound : forall a b, 0<=a -> 0 0 <= a mod b < b. +End NZDivSpecific. + +Module Type NZDiv (NZ:NZOrdAxiomsSig) + := DivMod NZ <+ NZDivCommon NZ <+ NZDivSpecific NZ. + +Module Type NZDiv' (NZ:NZOrdAxiomsSig) := NZDiv NZ <+ DivModNotation NZ. + +Module NZDivPropFunct + (Import NZ : NZOrdAxiomsSig') + (Import NZP : NZMulOrderPropSig NZ) + (Import NZD : NZDiv' NZ) +. + +(** Uniqueness theorems *) + +Theorem div_mod_unique : + forall b q1 q2 r1 r2, 0<=r1 0<=r2 + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. +Proof. +intros b. +assert (U : forall q1 q2 r1 r2, + b*q1+r1 == b*q2+r2 -> 0<=r1 0<=r2 -> q1 False). + intros q1 q2 r1 r2 EQ LT Hr1 Hr2. + contradict EQ. + apply lt_neq. + apply lt_le_trans with (b*q1+b). + rewrite <- add_lt_mono_l. tauto. + apply le_trans with (b*q2). + rewrite mul_comm, <- mul_succ_l, mul_comm. + apply mul_le_mono_nonneg_l; intuition; try order. + rewrite le_succ_l; auto. + rewrite <- (add_0_r (b*q2)) at 1. + rewrite <- add_le_mono_l. tauto. + +intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]]. +elim (U q1 q2 r1 r2); intuition. +split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto. +elim (U q2 q1 r2 r1); intuition. +Qed. + +Theorem div_unique: + forall a b q r, 0<=a -> 0<=r + a == b*q + r -> q == a/b. +Proof. +intros a b q r Ha (Hb,Hr) EQ. +destruct (div_mod_unique b q (a/b) r (a mod b)); auto. +apply mod_bound; order. +rewrite <- div_mod; order. +Qed. + +Theorem mod_unique: + forall a b q r, 0<=a -> 0<=r + a == b*q + r -> r == a mod b. +Proof. +intros a b q r Ha (Hb,Hr) EQ. +destruct (div_mod_unique b q (a/b) r (a mod b)); auto. +apply mod_bound; order. +rewrite <- div_mod; order. +Qed. + + +(** A division by itself returns 1 *) + +Lemma div_same : forall a, 0 a/a == 1. +Proof. +intros. symmetry. +apply div_unique with 0; intuition; try order. +now nzsimpl. +Qed. + +Lemma mod_same : forall a, 0 a mod a == 0. +Proof. +intros. symmetry. +apply mod_unique with 1; intuition; try order. +now nzsimpl. +Qed. + +(** A division of a small number by a bigger one yields zero. *) + +Theorem div_small: forall a b, 0<=a a/b == 0. +Proof. +intros. symmetry. +apply div_unique with a; intuition; try order. +now nzsimpl. +Qed. + +(** Same situation, in term of modulo: *) + +Theorem mod_small: forall a b, 0<=a a mod b == a. +Proof. +intros. symmetry. +apply mod_unique with 0; intuition; try order. +now nzsimpl. +Qed. + +(** * Basic values of divisions and modulo. *) + +Lemma div_0_l: forall a, 0 0/a == 0. +Proof. +intros; apply div_small; split; order. +Qed. + +Lemma mod_0_l: forall a, 0 0 mod a == 0. +Proof. +intros; apply mod_small; split; order. +Qed. + +Lemma div_1_r: forall a, 0<=a -> a/1 == a. +Proof. +intros. symmetry. +apply div_unique with 0; try split; try order; try apply lt_0_1. +now nzsimpl. +Qed. + +Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0. +Proof. +intros. symmetry. +apply mod_unique with a; try split; try order; try apply lt_0_1. +now nzsimpl. +Qed. + +Lemma div_1_l: forall a, 1 1/a == 0. +Proof. +intros; apply div_small; split; auto. apply le_succ_diag_r. +Qed. + +Lemma mod_1_l: forall a, 1 1 mod a == 1. +Proof. +intros; apply mod_small; split; auto. apply le_succ_diag_r. +Qed. + +Lemma div_mul : forall a b, 0<=a -> 0 (a*b)/b == a. +Proof. +intros; symmetry. +apply div_unique with 0; try split; try order. +apply mul_nonneg_nonneg; order. +nzsimpl; apply mul_comm. +Qed. + +Lemma mod_mul : forall a b, 0<=a -> 0 (a*b) mod b == 0. +Proof. +intros; symmetry. +apply mod_unique with a; try split; try order. +apply mul_nonneg_nonneg; order. +nzsimpl; apply mul_comm. +Qed. + + +(** * Order results about mod and div *) + +(** A modulo cannot grow beyond its starting point. *) + +Theorem mod_le: forall a b, 0<=a -> 0 a mod b <= a. +Proof. +intros. destruct (le_gt_cases b a). +apply le_trans with b; auto. +apply lt_le_incl. destruct (mod_bound a b); auto. +rewrite lt_eq_cases; right. +apply mod_small; auto. +Qed. + + +(* Division of positive numbers is positive. *) + +Lemma div_pos: forall a b, 0<=a -> 0 0 <= a/b. +Proof. +intros. +rewrite (mul_le_mono_pos_l _ _ b); auto; nzsimpl. +rewrite (add_le_mono_r _ _ (a mod b)). +rewrite <- div_mod by order. +nzsimpl. +apply mod_le; auto. +Qed. + +Lemma div_str_pos : forall a b, 0 0 < a/b. +Proof. +intros a b (Hb,Hab). +assert (LE : 0 <= a/b) by (apply div_pos; order). +assert (MOD : a mod b < b) by (destruct (mod_bound a b); order). +rewrite lt_eq_cases in LE; destruct LE as [LT|EQ]; auto. +exfalso; revert Hab. +rewrite (div_mod a b), <-EQ; nzsimpl; order. +Qed. + +Lemma div_small_iff : forall a b, 0<=a -> 0 (a/b==0 <-> a 0 (a mod b == a <-> a 0 (0 b<=a). +Proof. +intros a b Ha Hb; split; intros Hab. +destruct (lt_ge_cases a b) as [LT|LE]; auto. +rewrite <- div_small_iff in LT; order. +apply div_str_pos; auto. +Qed. + + +(** As soon as the divisor is strictly greater than 1, + the division is strictly decreasing. *) + +Lemma div_lt : forall a b, 0 1 a/b < a. +Proof. +intros. +assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1). +destruct (lt_ge_cases a b). +rewrite div_small; try split; order. +rewrite (div_mod a b) at 2 by order. +apply lt_le_trans with (b*(a/b)). +rewrite <- (mul_1_l (a/b)) at 1. +rewrite <- mul_lt_mono_pos_r; auto. +apply div_str_pos; auto. +rewrite <- (add_0_r (b*(a/b))) at 1. +rewrite <- add_le_mono_l. destruct (mod_bound a b); order. +Qed. + +(** [le] is compatible with a positive division. *) + +Lemma div_le_mono : forall a b c, 0 0<=a<=b -> a/c <= b/c. +Proof. +intros a b c Hc (Ha,Hab). +rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ]; + [|rewrite EQ; order]. +rewrite <- lt_succ_r. +rewrite (mul_lt_mono_pos_l c) by order. +nzsimpl. +rewrite (add_lt_mono_r _ _ (a mod c)). +rewrite <- div_mod by order. +apply lt_le_trans with b; auto. +rewrite (div_mod b c) at 1 by order. +rewrite <- add_assoc, <- add_le_mono_l. +apply le_trans with (c+0). +nzsimpl; destruct (mod_bound b c); order. +rewrite <- add_le_mono_l. destruct (mod_bound a c); order. +Qed. + +(** The following two properties could be used as specification of div *) + +Lemma mul_div_le : forall a b, 0<=a -> 0 b*(a/b) <= a. +Proof. +intros. +rewrite (add_le_mono_r _ _ (a mod b)), <- div_mod by order. +rewrite <- (add_0_r a) at 1. +rewrite <- add_le_mono_l. destruct (mod_bound a b); order. +Qed. + +Lemma mul_succ_div_gt : forall a b, 0<=a -> 0 a < b*(S (a/b)). +Proof. +intros. +rewrite (div_mod a b) at 1 by order. +rewrite (mul_succ_r). +rewrite <- add_lt_mono_l. +destruct (mod_bound a b); auto. +Qed. + + +(** The previous inequality is exact iff the modulo is zero. *) + +Lemma div_exact : forall a b, 0<=a -> 0 (a == b*(a/b) <-> a mod b == 0). +Proof. +intros. rewrite (div_mod a b) at 1 by order. +rewrite <- (add_0_r (b*(a/b))) at 2. +apply add_cancel_l. +Qed. + +(** Some additionnal inequalities about div. *) + +Theorem div_lt_upper_bound: + forall a b q, 0<=a -> 0 a < b*q -> a/b < q. +Proof. +intros. +rewrite (mul_lt_mono_pos_l b) by order. +apply le_lt_trans with a; auto. +apply mul_div_le; auto. +Qed. + +Theorem div_le_upper_bound: + forall a b q, 0<=a -> 0 a <= b*q -> a/b <= q. +Proof. +intros. +rewrite (mul_le_mono_pos_l _ _ b) by order. +apply le_trans with a; auto. +apply mul_div_le; auto. +Qed. + +Theorem div_le_lower_bound: + forall a b q, 0<=a -> 0 b*q <= a -> q <= a/b. +Proof. +intros a b q Ha Hb H. +destruct (lt_ge_cases 0 q). +rewrite <- (div_mul q b); try order. +apply div_le_mono; auto. +rewrite mul_comm; split; auto. +apply lt_le_incl, mul_pos_pos; auto. +apply le_trans with 0; auto; apply div_pos; auto. +Qed. + +(** A division respects opposite monotonicity for the divisor *) + +Lemma div_le_compat_l: forall p q r, 0<=p -> 0 + p/r <= p/q. +Proof. + intros p q r Hp (Hq,Hqr). + apply div_le_lower_bound; auto. + rewrite (div_mod p r) at 2 by order. + apply le_trans with (r*(p/r)). + apply mul_le_mono_nonneg_r; try order. + apply div_pos; order. + rewrite <- (add_0_r (r*(p/r))) at 1. + rewrite <- add_le_mono_l. destruct (mod_bound p r); order. +Qed. + + +(** * Relations between usual operations and mod and div *) + +Lemma mod_add : forall a b c, 0<=a -> 0<=a+b*c -> 0 + (a + b * c) mod c == a mod c. +Proof. + intros. + symmetry. + apply mod_unique with (a/c+b); auto. + apply mod_bound; auto. + rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. + now rewrite mul_comm. +Qed. + +Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0 + (a + b * c) / c == a / c + b. +Proof. + intros. + apply (mul_cancel_l _ _ c); try order. + apply (add_cancel_r _ _ ((a+b*c) mod c)). + rewrite <- div_mod, mod_add by order. + rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. + now rewrite mul_comm. +Qed. + +Lemma div_add_l: forall a b c, 0<=c -> 0<=a*b+c -> 0 + (a * b + c) / b == a + c / b. +Proof. + intros a b c. rewrite (add_comm _ c), (add_comm a). + intros. apply div_add; auto. +Qed. + +(** Cancellations. *) + +Lemma div_mul_cancel_r : forall a b c, 0<=a -> 0 0 + (a*c)/(b*c) == a/b. +Proof. + intros. + symmetry. + apply div_unique with ((a mod b)*c). + apply mul_nonneg_nonneg; order. + split. + apply mul_nonneg_nonneg; destruct (mod_bound a b); order. + rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound a b); auto. + rewrite (div_mod a b) at 1 by order. + rewrite mul_add_distr_r. + rewrite add_cancel_r. + rewrite <- 2 mul_assoc. now rewrite (mul_comm c). +Qed. + +Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0 0 + (c*a)/(c*b) == a/b. +Proof. + intros. rewrite !(mul_comm c); apply div_mul_cancel_r; auto. +Qed. + +Lemma mul_mod_distr_l: forall a b c, 0<=a -> 0 0 + (c*a) mod (c*b) == c * (a mod b). +Proof. + intros. + rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). + rewrite <- div_mod. + rewrite div_mul_cancel_l; auto. + rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order. + apply div_mod; order. + rewrite <- neq_mul_0; intuition; order. +Qed. + +Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0 0 + (a*c) mod (b*c) == (a mod b) * c. +Proof. + intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. +Qed. + +(** Operations modulo. *) + +Theorem mod_mod: forall a n, 0<=a -> 0 + (a mod n) mod n == a mod n. +Proof. + intros. destruct (mod_bound a n); auto. now rewrite mod_small_iff. +Qed. + +Lemma mul_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0 + ((a mod n)*b) mod n == (a*b) mod n. +Proof. + intros a b n Ha Hb Hn. symmetry. + generalize (mul_nonneg_nonneg _ _ Ha Hb). + rewrite (div_mod a n) at 1 2 by order. + rewrite add_comm, (mul_comm n), (mul_comm _ b). + rewrite mul_add_distr_l, mul_assoc. + intros. rewrite mod_add; auto. + now rewrite mul_comm. + apply mul_nonneg_nonneg; destruct (mod_bound a n); auto. +Qed. + +Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0 + (a*(b mod n)) mod n == (a*b) mod n. +Proof. + intros. rewrite !(mul_comm a). apply mul_mod_idemp_l; auto. +Qed. + +Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0 + (a * b) mod n == ((a mod n) * (b mod n)) mod n. +Proof. + intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. reflexivity. + now destruct (mod_bound b n). +Qed. + +Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0 + ((a mod n)+b) mod n == (a+b) mod n. +Proof. + intros a b n Ha Hb Hn. symmetry. + generalize (add_nonneg_nonneg _ _ Ha Hb). + rewrite (div_mod a n) at 1 2 by order. + rewrite <- add_assoc, add_comm, mul_comm. + intros. rewrite mod_add; trivial. reflexivity. + apply add_nonneg_nonneg; auto. destruct (mod_bound a n); auto. +Qed. + +Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0 + (a+(b mod n)) mod n == (a+b) mod n. +Proof. + intros. rewrite !(add_comm a). apply add_mod_idemp_l; auto. +Qed. + +Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0 + (a+b) mod n == (a mod n + b mod n) mod n. +Proof. + intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. reflexivity. + now destruct (mod_bound b n). +Qed. + +Lemma div_div : forall a b c, 0<=a -> 0 0 + (a/b)/c == a/(b*c). +Proof. + intros a b c Ha Hb Hc. + apply div_unique with (b*((a/b) mod c) + a mod b); trivial. + (* begin 0<= ... 0 0<=c -> c*(a/b) <= (c*a)/b. +Proof. + intros. + apply div_le_lower_bound; auto. + apply mul_nonneg_nonneg; auto. + rewrite mul_assoc, (mul_comm b c), <- mul_assoc. + apply mul_le_mono_nonneg_l; auto. + apply mul_div_le; auto. +Qed. + +(** mod is related to divisibility *) + +Lemma mod_divides : forall a b, 0<=a -> 0 + (a mod b == 0 <-> exists c, a == b*c). +Proof. + split. + intros. exists (a/b). rewrite div_exact; auto. + intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto. + rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order. +Qed. + +End NZDivPropFunct. + diff --git a/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v new file mode 100644 index 00000000..8c3c7937 --- /dev/null +++ b/theories/Numbers/NatInt/NZDomain.v @@ -0,0 +1,417 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A)(n:nat) : A -> A := fun a => + match n with + | O => a + | S n => f (iter f n a) + end. +Infix "^" := iter. + +Lemma iter_alt : forall f n m, (f^(Datatypes.S n)) m = (f^n) (f m). +Proof. +induction n; simpl; auto. +intros; rewrite <- IHn; auto. +Qed. + +Lemma iter_plus : forall f n n' m, (f^(n+n')) m = (f^n) ((f^n') m). +Proof. +induction n; simpl; auto. +intros; rewrite IHn; auto. +Qed. + +Lemma iter_plus_bis : forall f n n' m, (f^(n+n')) m = (f^n') ((f^n) m). +Proof. +induction n; simpl; auto. +intros. rewrite <- iter_alt, IHn; auto. +Qed. + +Global Instance iter_wd (R:relation A) : Proper ((R==>R)==>eq==>R==>R) iter. +Proof. +intros f f' Hf n n' Hn; subst n'. induction n; simpl; red; auto. +Qed. + +End Iter. +Implicit Arguments iter [A]. +Local Infix "^" := iter. + + +Module NZDomainProp (Import NZ:NZDomainSig'). + +(** * Relationship between points thanks to [succ] and [pred]. *) + +(** We prove that any points in NZ have a common descendant by [succ] *) + +Definition common_descendant n m := exists k, exists l, (S^k) n == (S^l) m. + +Instance common_descendant_wd : Proper (eq==>eq==>iff) common_descendant. +Proof. +unfold common_descendant. intros n n' Hn m m' Hm. +setoid_rewrite Hn. setoid_rewrite Hm. auto with *. +Qed. + +Instance common_descendant_equiv : Equivalence common_descendant. +Proof. +split; red. +intros x. exists O; exists O. simpl; auto with *. +intros x y (p & q & H); exists q; exists p; auto with *. +intros x y z (p & q & Hpq) (r & s & Hrs). +exists (r+p)%nat. exists (q+s)%nat. +rewrite !iter_plus. rewrite Hpq, <-Hrs, <-iter_plus, <- iter_plus_bis. +auto with *. +Qed. + +Lemma common_descendant_with_0 : forall n, common_descendant n 0. +Proof. +apply bi_induction. +intros n n' Hn. rewrite Hn; auto with *. +reflexivity. +split; intros (p & q & H). +exists p; exists (Datatypes.S q). rewrite <- iter_alt; simpl. + apply succ_wd; auto. +exists (Datatypes.S p); exists q. rewrite iter_alt; auto. +Qed. + +Lemma common_descendant_always : forall n m, common_descendant n m. +Proof. +intros. transitivity 0; [|symmetry]; apply common_descendant_with_0. +Qed. + +(** Thanks to [succ] being injective, we can then deduce that for any two + points, one is an iterated successor of the other. *) + +Lemma itersucc_or_itersucc : forall n m, exists k, n == (S^k) m \/ m == (S^k) n. +Proof. +intros n m. destruct (common_descendant_always n m) as (k & l & H). +revert l H. induction k. +simpl. intros; exists l; left; auto with *. +intros. destruct l. +simpl in *. exists (Datatypes.S k); right; auto with *. +simpl in *. apply pred_wd in H; rewrite !pred_succ in H. eauto. +Qed. + +(** Generalized version of [pred_succ] when iterating *) + +Lemma succ_swap_pred : forall k n m, n == (S^k) m -> m == (P^k) n. +Proof. +induction k. +simpl; auto with *. +simpl; intros. apply pred_wd in H. rewrite pred_succ in H. apply IHk in H; auto. +rewrite <- iter_alt in H; auto. +Qed. + +(** From a given point, all others are iterated successors + or iterated predecessors. *) + +Lemma itersucc_or_iterpred : forall n m, exists k, n == (S^k) m \/ n == (P^k) m. +Proof. +intros n m. destruct (itersucc_or_itersucc n m) as (k,[H|H]). +exists k; left; auto. +exists k; right. apply succ_swap_pred; auto. +Qed. + +(** In particular, all points are either iterated successors of [0] + or iterated predecessors of [0] (or both). *) + +Lemma itersucc0_or_iterpred0 : + forall n, exists p:nat, n == (S^p) 0 \/ n == (P^p) 0. +Proof. + intros n. exact (itersucc_or_iterpred n 0). +Qed. + +(** * Study of initial point w.r.t. [succ] (if any). *) + +Definition initial n := forall m, n ~= S m. + +Lemma initial_alt : forall n, initial n <-> S (P n) ~= n. +Proof. +split. intros Bn EQ. symmetry in EQ. destruct (Bn _ EQ). +intros NEQ m EQ. apply NEQ. rewrite EQ, pred_succ; auto with *. +Qed. + +Lemma initial_alt2 : forall n, initial n <-> ~exists m, n == S m. +Proof. firstorder. Qed. + +(** First case: let's assume such an initial point exists + (i.e. [S] isn't surjective)... *) + +Section InitialExists. +Hypothesis init : t. +Hypothesis Initial : initial init. + +(** ... then we have unicity of this initial point. *) + +Lemma initial_unique : forall m, initial m -> m == init. +Proof. +intros m Im. destruct (itersucc_or_itersucc init m) as (p,[H|H]). +destruct p. now simpl in *. destruct (Initial _ H). +destruct p. now simpl in *. destruct (Im _ H). +Qed. + +(** ... then all other points are descendant of it. *) + +Lemma initial_ancestor : forall m, exists p, m == (S^p) init. +Proof. +intros m. destruct (itersucc_or_itersucc init m) as (p,[H|H]). +destruct p; simpl in *; auto. exists O; auto with *. destruct (Initial _ H). +exists p; auto. +Qed. + +(** NB : We would like to have [pred n == n] for the initial element, + but nothing forces that. For instance we can have -3 as initial point, + and P(-3) = 2. A bit odd indeed, but legal according to [NZDomainSig]. + We can hence have [n == (P^k) m] without [exists k', m == (S^k') n]. +*) + +(** We need decidability of [eq] (or classical reasoning) for this: *) + +Section SuccPred. +Hypothesis eq_decidable : forall n m, n==m \/ n~=m. +Lemma succ_pred_approx : forall n, ~initial n -> S (P n) == n. +Proof. +intros n NB. rewrite initial_alt in NB. +destruct (eq_decidable (S (P n)) n); auto. +elim NB; auto. +Qed. +End SuccPred. +End InitialExists. + +(** Second case : let's suppose now [S] surjective, i.e. no initial point. *) + +Section InitialDontExists. + +Hypothesis succ_onto : forall n, exists m, n == S m. + +Lemma succ_onto_gives_succ_pred : forall n, S (P n) == n. +Proof. +intros n. destruct (succ_onto n) as (m,H). rewrite H, pred_succ; auto with *. +Qed. + +Lemma succ_onto_pred_injective : forall n m, P n == P m -> n == m. +Proof. +intros n m. intros H; apply succ_wd in H. +rewrite !succ_onto_gives_succ_pred in H; auto. +Qed. + +End InitialDontExists. + + +(** To summarize: + + S is always injective, P is always surjective (thanks to [pred_succ]). + + I) If S is not surjective, we have an initial point, which is unique. + This bottom is below zero: we have N shifted (or not) to the left. + P cannot be injective: P init = P (S (P init)). + (P init) can be arbitrary. + + II) If S is surjective, we have [forall n, S (P n) = n], S and P are + bijective and reciprocal. + + IIa) if [exists k<>O, 0 == S^k 0], then we have a cyclic structure Z/nZ + IIb) otherwise, we have Z +*) + + +(** * An alternative induction principle using [S] and [P]. *) + +(** It is weaker than [bi_induction]. For instance it cannot prove that + we can go from one point by many [S] _or_ many [P], but only by many + [S] mixed with many [P]. Think of a model with two copies of N: + + 0, 1=S 0, 2=S 1, ... + 0', 1'=S 0', 2'=S 1', ... + + and P 0 = 0' and P 0' = 0. +*) + +Lemma bi_induction_pred : + forall A : t -> Prop, Proper (eq==>iff) A -> + A 0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) -> + forall n, A n. +Proof. +intros. apply bi_induction; auto. +clear n. intros n; split; auto. +intros G; apply H2 in G. rewrite pred_succ in G; auto. +Qed. + +Lemma central_induction_pred : + forall A : t -> Prop, Proper (eq==>iff) A -> forall n0, + A n0 -> (forall n, A n -> A (S n)) -> (forall n, A n -> A (P n)) -> + forall n, A n. +Proof. +intros. +assert (A 0). +destruct (itersucc_or_iterpred 0 n0) as (k,[Hk|Hk]); rewrite Hk; clear Hk. + clear H2. induction k; simpl in *; auto. + clear H1. induction k; simpl in *; auto. +apply bi_induction_pred; auto. +Qed. + +End NZDomainProp. + +(** We now focus on the translation from [nat] into [NZ]. + First, relationship with [0], [succ], [pred]. +*) + +Module NZOfNat (Import NZ:NZDomainSig'). + +Definition ofnat (n : nat) : t := (S^n) 0. +Notation "[ n ]" := (ofnat n) (at level 7) : ofnat. +Local Open Scope ofnat. + +Lemma ofnat_zero : [O] == 0. +Proof. +reflexivity. +Qed. + +Lemma ofnat_succ : forall n, [Datatypes.S n] == succ [n]. +Proof. + now unfold ofnat. +Qed. + +Lemma ofnat_pred : forall n, n<>O -> [Peano.pred n] == P [n]. +Proof. + unfold ofnat. destruct n. destruct 1; auto. + intros _. simpl. symmetry. apply pred_succ. +Qed. + +(** Since [P 0] can be anything in NZ (either [-1], [0], or even other + numbers, we cannot state previous lemma for [n=O]. *) + +End NZOfNat. + + +(** If we require in addition a strict order on NZ, we can prove that + [ofnat] is injective, and hence that NZ is infinite + (i.e. we ban Z/nZ models) *) + +Module NZOfNatOrd (Import NZ:NZOrdSig'). +Include NZOfNat NZ. +Include NZOrderPropFunct NZ. +Local Open Scope ofnat. + +Theorem ofnat_S_gt_0 : + forall n : nat, 0 < [Datatypes.S n]. +Proof. +unfold ofnat. +intros n; induction n as [| n IH]; simpl in *. +apply lt_0_1. +apply lt_trans with 1. apply lt_0_1. now rewrite <- succ_lt_mono. +Qed. + +Theorem ofnat_S_neq_0 : + forall n : nat, 0 ~= [Datatypes.S n]. +Proof. +intros. apply lt_neq, ofnat_S_gt_0. +Qed. + +Lemma ofnat_injective : forall n m, [n]==[m] -> n = m. +Proof. +induction n as [|n IH]; destruct m; auto. +intros H; elim (ofnat_S_neq_0 _ H). +intros H; symmetry in H; elim (ofnat_S_neq_0 _ H). +intros. f_equal. apply IH. now rewrite <- succ_inj_wd. +Qed. + +Lemma ofnat_eq : forall n m, [n]==[m] <-> n = m. +Proof. +split. apply ofnat_injective. intros; now subst. +Qed. + +(* In addition, we can prove that [ofnat] preserves order. *) + +Lemma ofnat_lt : forall n m : nat, [n]<[m] <-> (n (n<=m)%nat. +Proof. +intros. rewrite lt_eq_cases, ofnat_lt, ofnat_eq. +split. +destruct 1; subst; auto with arith. +apply Lt.le_lt_or_eq. +Qed. + +End NZOfNatOrd. + + +(** For basic operations, we can prove correspondance with + their counterpart in [nat]. *) + +Module NZOfNatOps (Import NZ:NZAxiomsSig'). +Include NZOfNat NZ. +Local Open Scope ofnat. + +Lemma ofnat_add_l : forall n m, [n]+m == (S^n) m. +Proof. + induction n; intros. + apply add_0_l. + rewrite ofnat_succ, add_succ_l. simpl; apply succ_wd; auto. +Qed. + +Lemma ofnat_add : forall n m, [n+m] == [n]+[m]. +Proof. + intros. rewrite ofnat_add_l. + induction n; simpl. reflexivity. + rewrite ofnat_succ. now apply succ_wd. +Qed. + +Lemma ofnat_mul : forall n m, [n*m] == [n]*[m]. +Proof. + induction n; simpl; intros. + symmetry. apply mul_0_l. + rewrite plus_comm. + rewrite ofnat_succ, ofnat_add, mul_succ_l. + now apply add_wd. +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 apply pred_wd. +Qed. + +Lemma ofnat_sub : forall n m, m<=n -> [n-m] == [n]-[m]. +Proof. + intros n m H. rewrite ofnat_sub_r. + revert n H. induction m. intros. + rewrite <- minus_n_O. now simpl. + intros. + destruct n. + inversion H. + rewrite iter_alt. + simpl. + rewrite ofnat_succ, pred_succ; auto with arith. +Qed. + +End NZOfNatOps. diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v index fda8b7a3..296bd095 100644 --- a/theories/Numbers/NatInt/NZMul.v +++ b/theories/Numbers/NatInt/NZMul.v @@ -8,73 +8,63 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZMul.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) -Require Import NZAxioms. -Require Import NZAdd. +Require Import NZAxioms NZBase NZAdd. -Module NZMulPropFunct (Import NZAxiomsMod : NZAxiomsSig). -Module Export NZAddPropMod := NZAddPropFunct NZAxiomsMod. -Open Local Scope NatIntScope. +Module Type NZMulPropSig + (Import NZ : NZAxiomsSig')(Import NZBase : NZBasePropSig NZ). +Include NZAddPropSig NZ NZBase. -Theorem NZmul_0_r : forall n : NZ, n * 0 == 0. +Theorem mul_0_r : forall n, n * 0 == 0. Proof. -NZinduct n. -now rewrite NZmul_0_l. -intro. rewrite NZmul_succ_l. now rewrite NZadd_0_r. +nzinduct n; intros; now nzsimpl. Qed. -Theorem NZmul_succ_r : forall n m : NZ, n * (S m) == n * m + n. +Theorem mul_succ_r : forall n m, n * (S m) == n * m + n. Proof. -intros n m; NZinduct n. -do 2 rewrite NZmul_0_l; now rewrite NZadd_0_l. -intro n. do 2 rewrite NZmul_succ_l. do 2 rewrite NZadd_succ_r. -rewrite NZsucc_inj_wd. rewrite <- (NZadd_assoc (n * m) m n). -rewrite (NZadd_comm m n). rewrite NZadd_assoc. -now rewrite NZadd_cancel_r. +intros n m; nzinduct n. now nzsimpl. +intro n. nzsimpl. rewrite succ_inj_wd, <- add_assoc, (add_comm m n), add_assoc. +now rewrite add_cancel_r. Qed. -Theorem NZmul_comm : forall n m : NZ, n * m == m * n. +Hint Rewrite mul_0_r mul_succ_r : nz. + +Theorem mul_comm : forall n m, n * m == m * n. Proof. -intros n m; NZinduct n. -rewrite NZmul_0_l; now rewrite NZmul_0_r. -intro. rewrite NZmul_succ_l; rewrite NZmul_succ_r. now rewrite NZadd_cancel_r. +intros n m; nzinduct n. now nzsimpl. +intro. nzsimpl. now rewrite add_cancel_r. Qed. -Theorem NZmul_add_distr_r : forall n m p : NZ, (n + m) * p == n * p + m * p. +Theorem mul_add_distr_r : forall n m p, (n + m) * p == n * p + m * p. Proof. -intros n m p; NZinduct n. -rewrite NZmul_0_l. now do 2 rewrite NZadd_0_l. -intro n. rewrite NZadd_succ_l. do 2 rewrite NZmul_succ_l. -rewrite <- (NZadd_assoc (n * p) p (m * p)). -rewrite (NZadd_comm p (m * p)). rewrite (NZadd_assoc (n * p) (m * p) p). -now rewrite NZadd_cancel_r. +intros n m p; nzinduct n. now nzsimpl. +intro n. nzsimpl. rewrite <- add_assoc, (add_comm p (m*p)), add_assoc. +now rewrite add_cancel_r. Qed. -Theorem NZmul_add_distr_l : forall n m p : NZ, n * (m + p) == n * m + n * p. +Theorem mul_add_distr_l : forall n m p, n * (m + p) == n * m + n * p. Proof. intros n m p. -rewrite (NZmul_comm n (m + p)). rewrite (NZmul_comm n m). -rewrite (NZmul_comm n p). apply NZmul_add_distr_r. +rewrite (mul_comm n (m + p)), (mul_comm n m), (mul_comm n p). +apply mul_add_distr_r. Qed. -Theorem NZmul_assoc : forall n m p : NZ, n * (m * p) == (n * m) * p. +Theorem mul_assoc : forall n m p, n * (m * p) == (n * m) * p. Proof. -intros n m p; NZinduct n. -now do 3 rewrite NZmul_0_l. -intro n. do 2 rewrite NZmul_succ_l. rewrite NZmul_add_distr_r. -now rewrite NZadd_cancel_r. +intros n m p; nzinduct n. now nzsimpl. +intro n. nzsimpl. rewrite mul_add_distr_r. +now rewrite add_cancel_r. Qed. -Theorem NZmul_1_l : forall n : NZ, 1 * n == n. +Theorem mul_1_l : forall n, 1 * n == n. Proof. -intro n. rewrite NZmul_succ_l; rewrite NZmul_0_l. now rewrite NZadd_0_l. +intro n. now nzsimpl. Qed. -Theorem NZmul_1_r : forall n : NZ, n * 1 == n. +Theorem mul_1_r : forall n, n * 1 == n. Proof. -intro n; rewrite NZmul_comm; apply NZmul_1_l. +intro n. now nzsimpl. Qed. -End NZMulPropFunct. - +End NZMulPropSig. diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v index c707bf73..7b64a698 100644 --- a/theories/Numbers/NatInt/NZMulOrder.v +++ b/theories/Numbers/NatInt/NZMulOrder.v @@ -8,303 +8,300 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZMulOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) Require Import NZAxioms. Require Import NZAddOrder. -Module NZMulOrderPropFunct (Import NZOrdAxiomsMod : NZOrdAxiomsSig). -Module Export NZAddOrderPropMod := NZAddOrderPropFunct NZOrdAxiomsMod. -Open Local Scope NatIntScope. +Module Type NZMulOrderPropSig (Import NZ : NZOrdAxiomsSig'). +Include NZAddOrderPropSig NZ. -Theorem NZmul_lt_pred : - forall p q n m : NZ, S p == q -> (p * n < p * m <-> q * n + m < q * m + n). +Theorem mul_lt_pred : + forall p q n m, S p == q -> (p * n < p * m <-> q * n + m < q * m + n). Proof. -intros p q n m H. rewrite <- H. do 2 rewrite NZmul_succ_l. -rewrite <- (NZadd_assoc (p * n) n m). -rewrite <- (NZadd_assoc (p * m) m n). -rewrite (NZadd_comm n m). now rewrite <- NZadd_lt_mono_r. +intros p q n m H. rewrite <- H. nzsimpl. +rewrite <- ! add_assoc, (add_comm n m). +now rewrite <- add_lt_mono_r. Qed. -Theorem NZmul_lt_mono_pos_l : forall p n m : NZ, 0 < p -> (n < m <-> p * n < p * m). +Theorem mul_lt_mono_pos_l : forall p n m, 0 < p -> (n < m <-> p * n < p * m). Proof. -NZord_induct p. -intros n m H; false_hyp H NZlt_irrefl. -intros p H IH n m H1. do 2 rewrite NZmul_succ_l. -le_elim H. assert (LR : forall n m : NZ, n < m -> p * n + n < p * m + m). -intros n1 m1 H2. apply NZadd_lt_mono; [now apply -> IH | assumption]. -split; [apply LR |]. intro H2. apply -> NZlt_dne; intro H3. -apply <- NZle_ngt in H3. le_elim H3. -apply NZlt_asymm in H2. apply H2. now apply LR. -rewrite H3 in H2; false_hyp H2 NZlt_irrefl. -rewrite <- H; do 2 rewrite NZmul_0_l; now do 2 rewrite NZadd_0_l. -intros p H1 _ n m H2. apply NZlt_asymm in H1. false_hyp H2 H1. +nzord_induct p. +intros n m H; false_hyp H lt_irrefl. +intros p H IH n m H1. nzsimpl. +le_elim H. assert (LR : forall n m, n < m -> p * n + n < p * m + m). +intros n1 m1 H2. apply add_lt_mono; [now apply -> IH | assumption]. +split; [apply LR |]. intro H2. apply -> lt_dne; intro H3. +apply <- le_ngt in H3. le_elim H3. +apply lt_asymm in H2. apply H2. now apply LR. +rewrite H3 in H2; false_hyp H2 lt_irrefl. +rewrite <- H; now nzsimpl. +intros p H1 _ n m H2. destruct (lt_asymm _ _ H1 H2). Qed. -Theorem NZmul_lt_mono_pos_r : forall p n m : NZ, 0 < p -> (n < m <-> n * p < m * p). +Theorem mul_lt_mono_pos_r : forall p n m, 0 < p -> (n < m <-> n * p < m * p). Proof. intros p n m. -rewrite (NZmul_comm n p); rewrite (NZmul_comm m p). now apply NZmul_lt_mono_pos_l. +rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_pos_l. Qed. -Theorem NZmul_lt_mono_neg_l : forall p n m : NZ, p < 0 -> (n < m <-> p * m < p * n). +Theorem mul_lt_mono_neg_l : forall p n m, p < 0 -> (n < m <-> p * m < p * n). Proof. -NZord_induct p. -intros n m H; false_hyp H NZlt_irrefl. -intros p H1 _ n m H2. apply NZlt_succ_l in H2. apply <- NZnle_gt in H2. false_hyp H1 H2. -intros p H IH n m H1. apply <- NZle_succ_l in H. -le_elim H. assert (LR : forall n m : NZ, n < m -> p * m < p * n). -intros n1 m1 H2. apply (NZle_lt_add_lt n1 m1). -now apply NZlt_le_incl. do 2 rewrite <- NZmul_succ_l. now apply -> IH. -split; [apply LR |]. intro H2. apply -> NZlt_dne; intro H3. -apply <- NZle_ngt in H3. le_elim H3. -apply NZlt_asymm in H2. apply H2. now apply LR. -rewrite H3 in H2; false_hyp H2 NZlt_irrefl. -rewrite (NZmul_lt_pred p (S p)) by reflexivity. -rewrite H; do 2 rewrite NZmul_0_l; now do 2 rewrite NZadd_0_l. +nzord_induct p. +intros n m H; false_hyp H lt_irrefl. +intros p H1 _ n m H2. apply lt_succ_l in H2. apply <- nle_gt in H2. +false_hyp H1 H2. +intros p H IH n m H1. apply <- le_succ_l in H. +le_elim H. assert (LR : forall n m, n < m -> p * m < p * n). +intros n1 m1 H2. apply (le_lt_add_lt n1 m1). +now apply lt_le_incl. rewrite <- 2 mul_succ_l. now apply -> IH. +split; [apply LR |]. intro H2. apply -> lt_dne; intro H3. +apply <- le_ngt in H3. le_elim H3. +apply lt_asymm in H2. apply H2. now apply LR. +rewrite H3 in H2; false_hyp H2 lt_irrefl. +rewrite (mul_lt_pred p (S p)) by reflexivity. +rewrite H; do 2 rewrite mul_0_l; now do 2 rewrite add_0_l. Qed. -Theorem NZmul_lt_mono_neg_r : forall p n m : NZ, p < 0 -> (n < m <-> m * p < n * p). +Theorem mul_lt_mono_neg_r : forall p n m, p < 0 -> (n < m <-> m * p < n * p). Proof. intros p n m. -rewrite (NZmul_comm n p); rewrite (NZmul_comm m p). now apply NZmul_lt_mono_neg_l. +rewrite (mul_comm n p), (mul_comm m p). now apply mul_lt_mono_neg_l. Qed. -Theorem NZmul_le_mono_nonneg_l : forall n m p : NZ, 0 <= p -> n <= m -> p * n <= p * m. +Theorem mul_le_mono_nonneg_l : forall n m p, 0 <= p -> n <= m -> p * n <= p * m. Proof. intros n m p H1 H2. le_elim H1. -le_elim H2. apply NZlt_le_incl. now apply -> NZmul_lt_mono_pos_l. -apply NZeq_le_incl; now rewrite H2. -apply NZeq_le_incl; rewrite <- H1; now do 2 rewrite NZmul_0_l. +le_elim H2. apply lt_le_incl. now apply -> mul_lt_mono_pos_l. +apply eq_le_incl; now rewrite H2. +apply eq_le_incl; rewrite <- H1; now do 2 rewrite mul_0_l. Qed. -Theorem NZmul_le_mono_nonpos_l : forall n m p : NZ, p <= 0 -> n <= m -> p * m <= p * n. +Theorem mul_le_mono_nonpos_l : forall n m p, p <= 0 -> n <= m -> p * m <= p * n. Proof. intros n m p H1 H2. le_elim H1. -le_elim H2. apply NZlt_le_incl. now apply -> NZmul_lt_mono_neg_l. -apply NZeq_le_incl; now rewrite H2. -apply NZeq_le_incl; rewrite H1; now do 2 rewrite NZmul_0_l. +le_elim H2. apply lt_le_incl. now apply -> mul_lt_mono_neg_l. +apply eq_le_incl; now rewrite H2. +apply eq_le_incl; rewrite H1; now do 2 rewrite mul_0_l. Qed. -Theorem NZmul_le_mono_nonneg_r : forall n m p : NZ, 0 <= p -> n <= m -> n * p <= m * p. +Theorem mul_le_mono_nonneg_r : forall n m p, 0 <= p -> n <= m -> n * p <= m * p. Proof. -intros n m p H1 H2; rewrite (NZmul_comm n p); rewrite (NZmul_comm m p); -now apply NZmul_le_mono_nonneg_l. +intros n m p H1 H2; +rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonneg_l. Qed. -Theorem NZmul_le_mono_nonpos_r : forall n m p : NZ, p <= 0 -> n <= m -> m * p <= n * p. +Theorem mul_le_mono_nonpos_r : forall n m p, p <= 0 -> n <= m -> m * p <= n * p. Proof. -intros n m p H1 H2; rewrite (NZmul_comm n p); rewrite (NZmul_comm m p); -now apply NZmul_le_mono_nonpos_l. +intros n m p H1 H2; +rewrite (mul_comm n p), (mul_comm m p); now apply mul_le_mono_nonpos_l. Qed. -Theorem NZmul_cancel_l : forall n m p : NZ, p ~= 0 -> (p * n == p * m <-> n == m). +Theorem mul_cancel_l : forall n m p, p ~= 0 -> (p * n == p * m <-> n == m). Proof. intros n m p H; split; intro H1. -destruct (NZlt_trichotomy p 0) as [H2 | [H2 | H2]]. -apply -> NZeq_dne; intro H3. apply -> NZlt_gt_cases in H3. destruct H3 as [H3 | H3]. -assert (H4 : p * m < p * n); [now apply -> NZmul_lt_mono_neg_l |]. -rewrite H1 in H4; false_hyp H4 NZlt_irrefl. -assert (H4 : p * n < p * m); [now apply -> NZmul_lt_mono_neg_l |]. -rewrite H1 in H4; false_hyp H4 NZlt_irrefl. +destruct (lt_trichotomy p 0) as [H2 | [H2 | H2]]. +apply -> eq_dne; intro H3. apply -> lt_gt_cases in H3. destruct H3 as [H3 | H3]. +assert (H4 : p * m < p * n); [now apply -> mul_lt_mono_neg_l |]. +rewrite H1 in H4; false_hyp H4 lt_irrefl. +assert (H4 : p * n < p * m); [now apply -> mul_lt_mono_neg_l |]. +rewrite H1 in H4; false_hyp H4 lt_irrefl. false_hyp H2 H. -apply -> NZeq_dne; intro H3. apply -> NZlt_gt_cases in H3. destruct H3 as [H3 | H3]. -assert (H4 : p * n < p * m) by (now apply -> NZmul_lt_mono_pos_l). -rewrite H1 in H4; false_hyp H4 NZlt_irrefl. -assert (H4 : p * m < p * n) by (now apply -> NZmul_lt_mono_pos_l). -rewrite H1 in H4; false_hyp H4 NZlt_irrefl. +apply -> eq_dne; intro H3. apply -> lt_gt_cases in H3. destruct H3 as [H3 | H3]. +assert (H4 : p * n < p * m) by (now apply -> mul_lt_mono_pos_l). +rewrite H1 in H4; false_hyp H4 lt_irrefl. +assert (H4 : p * m < p * n) by (now apply -> mul_lt_mono_pos_l). +rewrite H1 in H4; false_hyp H4 lt_irrefl. now rewrite H1. Qed. -Theorem NZmul_cancel_r : forall n m p : NZ, p ~= 0 -> (n * p == m * p <-> n == m). +Theorem mul_cancel_r : forall n m p, p ~= 0 -> (n * p == m * p <-> n == m). Proof. -intros n m p. rewrite (NZmul_comm n p), (NZmul_comm m p); apply NZmul_cancel_l. +intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_cancel_l. Qed. -Theorem NZmul_id_l : forall n m : NZ, m ~= 0 -> (n * m == m <-> n == 1). +Theorem mul_id_l : forall n m, m ~= 0 -> (n * m == m <-> n == 1). Proof. intros n m H. -stepl (n * m == 1 * m) by now rewrite NZmul_1_l. now apply NZmul_cancel_r. +stepl (n * m == 1 * m) by now rewrite mul_1_l. now apply mul_cancel_r. Qed. -Theorem NZmul_id_r : forall n m : NZ, n ~= 0 -> (n * m == n <-> m == 1). +Theorem mul_id_r : forall n m, n ~= 0 -> (n * m == n <-> m == 1). Proof. -intros n m; rewrite NZmul_comm; apply NZmul_id_l. +intros n m; rewrite mul_comm; apply mul_id_l. Qed. -Theorem NZmul_le_mono_pos_l : forall n m p : NZ, 0 < p -> (n <= m <-> p * n <= p * m). +Theorem mul_le_mono_pos_l : forall n m p, 0 < p -> (n <= m <-> p * n <= p * m). Proof. -intros n m p H; do 2 rewrite NZlt_eq_cases. -rewrite (NZmul_lt_mono_pos_l p n m) by assumption. -now rewrite -> (NZmul_cancel_l n m p) by -(intro H1; rewrite H1 in H; false_hyp H NZlt_irrefl). +intros n m p H; do 2 rewrite lt_eq_cases. +rewrite (mul_lt_mono_pos_l p n m) by assumption. +now rewrite -> (mul_cancel_l n m p) by +(intro H1; rewrite H1 in H; false_hyp H lt_irrefl). Qed. -Theorem NZmul_le_mono_pos_r : forall n m p : NZ, 0 < p -> (n <= m <-> n * p <= m * p). +Theorem mul_le_mono_pos_r : forall n m p, 0 < p -> (n <= m <-> n * p <= m * p). Proof. -intros n m p. rewrite (NZmul_comm n p); rewrite (NZmul_comm m p); -apply NZmul_le_mono_pos_l. +intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_pos_l. Qed. -Theorem NZmul_le_mono_neg_l : forall n m p : NZ, p < 0 -> (n <= m <-> p * m <= p * n). +Theorem mul_le_mono_neg_l : forall n m p, p < 0 -> (n <= m <-> p * m <= p * n). Proof. -intros n m p H; do 2 rewrite NZlt_eq_cases. -rewrite (NZmul_lt_mono_neg_l p n m); [| assumption]. -rewrite -> (NZmul_cancel_l m n p) by (intro H1; rewrite H1 in H; false_hyp H NZlt_irrefl). -now setoid_replace (n == m) with (m == n) using relation iff by (split; now intro). +intros n m p H; do 2 rewrite lt_eq_cases. +rewrite (mul_lt_mono_neg_l p n m); [| assumption]. +rewrite -> (mul_cancel_l m n p) + by (intro H1; rewrite H1 in H; false_hyp H lt_irrefl). +now setoid_replace (n == m) with (m == n) by (split; now intro). Qed. -Theorem NZmul_le_mono_neg_r : forall n m p : NZ, p < 0 -> (n <= m <-> m * p <= n * p). +Theorem mul_le_mono_neg_r : forall n m p, p < 0 -> (n <= m <-> m * p <= n * p). Proof. -intros n m p. rewrite (NZmul_comm n p); rewrite (NZmul_comm m p); -apply NZmul_le_mono_neg_l. +intros n m p. rewrite (mul_comm n p), (mul_comm m p); apply mul_le_mono_neg_l. Qed. -Theorem NZmul_lt_mono_nonneg : - forall n m p q : NZ, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q. +Theorem mul_lt_mono_nonneg : + forall n m p q, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q. Proof. intros n m p q H1 H2 H3 H4. -apply NZle_lt_trans with (m * p). -apply NZmul_le_mono_nonneg_r; [assumption | now apply NZlt_le_incl]. -apply -> NZmul_lt_mono_pos_l; [assumption | now apply NZle_lt_trans with n]. +apply le_lt_trans with (m * p). +apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. +apply -> mul_lt_mono_pos_l; [assumption | now apply le_lt_trans with n]. Qed. (* There are still many variants of the theorem above. One can assume 0 < n or 0 < p or n <= m or p <= q. *) -Theorem NZmul_le_mono_nonneg : - forall n m p q : NZ, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q. +Theorem mul_le_mono_nonneg : + forall n m p q, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q. Proof. intros n m p q H1 H2 H3 H4. le_elim H2; le_elim H4. -apply NZlt_le_incl; now apply NZmul_lt_mono_nonneg. -rewrite <- H4; apply NZmul_le_mono_nonneg_r; [assumption | now apply NZlt_le_incl]. -rewrite <- H2; apply NZmul_le_mono_nonneg_l; [assumption | now apply NZlt_le_incl]. -rewrite H2; rewrite H4; now apply NZeq_le_incl. +apply lt_le_incl; now apply mul_lt_mono_nonneg. +rewrite <- H4; apply mul_le_mono_nonneg_r; [assumption | now apply lt_le_incl]. +rewrite <- H2; apply mul_le_mono_nonneg_l; [assumption | now apply lt_le_incl]. +rewrite H2; rewrite H4; now apply eq_le_incl. Qed. -Theorem NZmul_pos_pos : forall n m : NZ, 0 < n -> 0 < m -> 0 < n * m. +Theorem mul_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n * m. Proof. -intros n m H1 H2. -rewrite <- (NZmul_0_l m). now apply -> NZmul_lt_mono_pos_r. +intros n m H1 H2. rewrite <- (mul_0_l m). now apply -> mul_lt_mono_pos_r. Qed. -Theorem NZmul_neg_neg : forall n m : NZ, n < 0 -> m < 0 -> 0 < n * m. +Theorem mul_neg_neg : forall n m, n < 0 -> m < 0 -> 0 < n * m. Proof. -intros n m H1 H2. -rewrite <- (NZmul_0_l m). now apply -> NZmul_lt_mono_neg_r. +intros n m H1 H2. rewrite <- (mul_0_l m). now apply -> mul_lt_mono_neg_r. Qed. -Theorem NZmul_pos_neg : forall n m : NZ, 0 < n -> m < 0 -> n * m < 0. +Theorem mul_pos_neg : forall n m, 0 < n -> m < 0 -> n * m < 0. Proof. -intros n m H1 H2. -rewrite <- (NZmul_0_l m). now apply -> NZmul_lt_mono_neg_r. +intros n m H1 H2. rewrite <- (mul_0_l m). now apply -> mul_lt_mono_neg_r. Qed. -Theorem NZmul_neg_pos : forall n m : NZ, n < 0 -> 0 < m -> n * m < 0. +Theorem mul_neg_pos : forall n m, n < 0 -> 0 < m -> n * m < 0. Proof. -intros; rewrite NZmul_comm; now apply NZmul_pos_neg. +intros; rewrite mul_comm; now apply mul_pos_neg. Qed. -Theorem NZlt_1_mul_pos : forall n m : NZ, 1 < n -> 0 < m -> 1 < n * m. +Theorem mul_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n*m. Proof. -intros n m H1 H2. apply -> (NZmul_lt_mono_pos_r m) in H1. -rewrite NZmul_1_l in H1. now apply NZlt_1_l with m. +intros. rewrite <- (mul_0_l m). apply mul_le_mono_nonneg; order. +Qed. + +Theorem lt_1_mul_pos : forall n m, 1 < n -> 0 < m -> 1 < n * m. +Proof. +intros n m H1 H2. apply -> (mul_lt_mono_pos_r m) in H1. +rewrite mul_1_l in H1. now apply lt_1_l with m. assumption. Qed. -Theorem NZeq_mul_0 : forall n m : NZ, n * m == 0 <-> n == 0 \/ m == 0. +Theorem eq_mul_0 : forall n m, n * m == 0 <-> n == 0 \/ m == 0. Proof. intros n m; split. -intro H; destruct (NZlt_trichotomy n 0) as [H1 | [H1 | H1]]; -destruct (NZlt_trichotomy m 0) as [H2 | [H2 | H2]]; +intro H; destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; +destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; try (now right); try (now left). -elimtype False; now apply (NZlt_neq 0 (n * m)); [apply NZmul_neg_neg |]. -elimtype False; now apply (NZlt_neq (n * m) 0); [apply NZmul_neg_pos |]. -elimtype False; now apply (NZlt_neq (n * m) 0); [apply NZmul_pos_neg |]. -elimtype False; now apply (NZlt_neq 0 (n * m)); [apply NZmul_pos_pos |]. -intros [H | H]. now rewrite H, NZmul_0_l. now rewrite H, NZmul_0_r. +exfalso; now apply (lt_neq 0 (n * m)); [apply mul_neg_neg |]. +exfalso; now apply (lt_neq (n * m) 0); [apply mul_neg_pos |]. +exfalso; now apply (lt_neq (n * m) 0); [apply mul_pos_neg |]. +exfalso; now apply (lt_neq 0 (n * m)); [apply mul_pos_pos |]. +intros [H | H]. now rewrite H, mul_0_l. now rewrite H, mul_0_r. Qed. -Theorem NZneq_mul_0 : forall n m : NZ, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. +Theorem neq_mul_0 : forall n m, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. Proof. intros n m; split; intro H. -intro H1; apply -> NZeq_mul_0 in H1. tauto. +intro H1; apply -> eq_mul_0 in H1. tauto. split; intro H1; rewrite H1 in H; -(rewrite NZmul_0_l in H || rewrite NZmul_0_r in H); now apply H. +(rewrite mul_0_l in H || rewrite mul_0_r in H); now apply H. Qed. -Theorem NZeq_square_0 : forall n : NZ, n * n == 0 <-> n == 0. +Theorem eq_square_0 : forall n, n * n == 0 <-> n == 0. Proof. -intro n; rewrite NZeq_mul_0; tauto. +intro n; rewrite eq_mul_0; tauto. Qed. -Theorem NZeq_mul_0_l : forall n m : NZ, n * m == 0 -> m ~= 0 -> n == 0. +Theorem eq_mul_0_l : forall n m, n * m == 0 -> m ~= 0 -> n == 0. Proof. -intros n m H1 H2. apply -> NZeq_mul_0 in H1. destruct H1 as [H1 | H1]. +intros n m H1 H2. apply -> eq_mul_0 in H1. destruct H1 as [H1 | H1]. assumption. false_hyp H1 H2. Qed. -Theorem NZeq_mul_0_r : forall n m : NZ, n * m == 0 -> n ~= 0 -> m == 0. +Theorem eq_mul_0_r : forall n m, n * m == 0 -> n ~= 0 -> m == 0. Proof. -intros n m H1 H2; apply -> NZeq_mul_0 in H1. destruct H1 as [H1 | H1]. +intros n m H1 H2; apply -> eq_mul_0 in H1. destruct H1 as [H1 | H1]. false_hyp H1 H2. assumption. Qed. -Theorem NZlt_0_mul : forall n m : NZ, 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0). +Theorem lt_0_mul : forall n m, 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0). Proof. intros n m; split; [intro H | intros [[H1 H2] | [H1 H2]]]. -destruct (NZlt_trichotomy n 0) as [H1 | [H1 | H1]]; -[| rewrite H1 in H; rewrite NZmul_0_l in H; false_hyp H NZlt_irrefl |]; -(destruct (NZlt_trichotomy m 0) as [H2 | [H2 | H2]]; -[| rewrite H2 in H; rewrite NZmul_0_r in H; false_hyp H NZlt_irrefl |]); +destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]]; +[| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |]; +(destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]]; +[| rewrite H2 in H; rewrite mul_0_r in H; false_hyp H lt_irrefl |]); try (left; now split); try (right; now split). -assert (H3 : n * m < 0) by now apply NZmul_neg_pos. -elimtype False; now apply (NZlt_asymm (n * m) 0). -assert (H3 : n * m < 0) by now apply NZmul_pos_neg. -elimtype False; now apply (NZlt_asymm (n * m) 0). -now apply NZmul_pos_pos. now apply NZmul_neg_neg. +assert (H3 : n * m < 0) by now apply mul_neg_pos. +exfalso; now apply (lt_asymm (n * m) 0). +assert (H3 : n * m < 0) by now apply mul_pos_neg. +exfalso; now apply (lt_asymm (n * m) 0). +now apply mul_pos_pos. now apply mul_neg_neg. Qed. -Theorem NZsquare_lt_mono_nonneg : forall n m : NZ, 0 <= n -> n < m -> n * n < m * m. +Theorem square_lt_mono_nonneg : forall n m, 0 <= n -> n < m -> n * n < m * m. Proof. -intros n m H1 H2. now apply NZmul_lt_mono_nonneg. +intros n m H1 H2. now apply mul_lt_mono_nonneg. Qed. -Theorem NZsquare_le_mono_nonneg : forall n m : NZ, 0 <= n -> n <= m -> n * n <= m * m. +Theorem square_le_mono_nonneg : forall n m, 0 <= n -> n <= m -> n * n <= m * m. Proof. -intros n m H1 H2. now apply NZmul_le_mono_nonneg. +intros n m H1 H2. now apply mul_le_mono_nonneg. Qed. (* The converse theorems require nonnegativity (or nonpositivity) of the other variable *) -Theorem NZsquare_lt_simpl_nonneg : forall n m : NZ, 0 <= m -> n * n < m * m -> n < m. +Theorem square_lt_simpl_nonneg : forall n m, 0 <= m -> n * n < m * m -> n < m. Proof. -intros n m H1 H2. destruct (NZlt_ge_cases n 0). -now apply NZlt_le_trans with 0. -destruct (NZlt_ge_cases n m). -assumption. assert (F : m * m <= n * n) by now apply NZsquare_le_mono_nonneg. -apply -> NZle_ngt in F. false_hyp H2 F. +intros n m H1 H2. destruct (lt_ge_cases n 0). +now apply lt_le_trans with 0. +destruct (lt_ge_cases n m). +assumption. assert (F : m * m <= n * n) by now apply square_le_mono_nonneg. +apply -> le_ngt in F. false_hyp H2 F. Qed. -Theorem NZsquare_le_simpl_nonneg : forall n m : NZ, 0 <= m -> n * n <= m * m -> n <= m. +Theorem square_le_simpl_nonneg : forall n m, 0 <= m -> n * n <= m * m -> n <= m. Proof. -intros n m H1 H2. destruct (NZlt_ge_cases n 0). -apply NZlt_le_incl; now apply NZlt_le_trans with 0. -destruct (NZle_gt_cases n m). -assumption. assert (F : m * m < n * n) by now apply NZsquare_lt_mono_nonneg. -apply -> NZlt_nge in F. false_hyp H2 F. +intros n m H1 H2. destruct (lt_ge_cases n 0). +apply lt_le_incl; now apply lt_le_trans with 0. +destruct (le_gt_cases n m). +assumption. assert (F : m * m < n * n) by now apply square_lt_mono_nonneg. +apply -> lt_nge in F. false_hyp H2 F. Qed. -Theorem NZmul_2_mono_l : forall n m : NZ, n < m -> 1 + (1 + 1) * n < (1 + 1) * m. +Theorem mul_2_mono_l : forall n m, n < m -> 1 + (1 + 1) * n < (1 + 1) * m. Proof. -intros n m H. apply <- NZle_succ_l in H. -apply -> (NZmul_le_mono_pos_l (S n) m (1 + 1)) in H. -repeat rewrite NZmul_add_distr_r in *; repeat rewrite NZmul_1_l in *. -repeat rewrite NZadd_succ_r in *. repeat rewrite NZadd_succ_l in *. rewrite NZadd_0_l. -now apply -> NZle_succ_l. -apply NZadd_pos_pos; now apply NZlt_succ_diag_r. +intros n m. rewrite <- le_succ_l, (mul_le_mono_pos_l (S n) m (1 + 1)). +rewrite !mul_add_distr_r; nzsimpl; now rewrite le_succ_l. +apply add_pos_pos; now apply lt_0_1. Qed. -End NZMulOrderPropFunct. +End NZMulOrderPropSig. diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index d0e2faf8..14fa0bfd 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -8,659 +8,637 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZOrder.v 11674 2008-12-12 19:48:40Z letouzey $ i*) +(*i $Id$ i*) -Require Import NZAxioms. -Require Import NZMul. -Require Import Decidable. +Require Import NZAxioms NZBase Decidable OrdersTac. -Module NZOrderPropFunct (Import NZOrdAxiomsMod : NZOrdAxiomsSig). -Module Export NZMulPropMod := NZMulPropFunct NZAxiomsMod. -Open Local Scope NatIntScope. +Module Type NZOrderPropSig + (Import NZ : NZOrdSig')(Import NZBase : NZBasePropSig NZ). -Ltac le_elim H := rewrite NZlt_eq_cases in H; destruct H as [H | H]. - -Theorem NZlt_le_incl : forall n m : NZ, n < m -> n <= m. +Instance le_wd : Proper (eq==>eq==>iff) le. Proof. -intros; apply <- NZlt_eq_cases; now left. +intros n n' Hn m m' Hm. rewrite !lt_eq_cases, !Hn, !Hm; auto with *. Qed. -Theorem NZeq_le_incl : forall n m : NZ, n == m -> n <= m. -Proof. -intros; apply <- NZlt_eq_cases; now right. -Qed. +Ltac le_elim H := rewrite lt_eq_cases in H; destruct H as [H | H]. -Lemma NZlt_stepl : forall x y z : NZ, x < y -> x == z -> z < y. +Theorem lt_le_incl : forall n m, n < m -> n <= m. Proof. -intros x y z H1 H2; now rewrite <- H2. +intros; apply <- lt_eq_cases; now left. Qed. -Lemma NZlt_stepr : forall x y z : NZ, x < y -> y == z -> x < z. +Theorem le_refl : forall n, n <= n. Proof. -intros x y z H1 H2; now rewrite <- H2. +intro; apply <- lt_eq_cases; now right. Qed. -Lemma NZle_stepl : forall x y z : NZ, x <= y -> x == z -> z <= y. +Theorem lt_succ_diag_r : forall n, n < S n. Proof. -intros x y z H1 H2; now rewrite <- H2. +intro n. rewrite lt_succ_r. apply le_refl. Qed. -Lemma NZle_stepr : forall x y z : NZ, x <= y -> y == z -> x <= z. +Theorem le_succ_diag_r : forall n, n <= S n. Proof. -intros x y z H1 H2; now rewrite <- H2. +intro; apply lt_le_incl; apply lt_succ_diag_r. Qed. -Declare Left Step NZlt_stepl. -Declare Right Step NZlt_stepr. -Declare Left Step NZle_stepl. -Declare Right Step NZle_stepr. - -Theorem NZlt_neq : forall n m : NZ, n < m -> n ~= m. +Theorem neq_succ_diag_l : forall n, S n ~= n. Proof. -intros n m H1 H2; rewrite H2 in H1; false_hyp H1 NZlt_irrefl. +intros n H. apply (lt_irrefl n). rewrite <- H at 2. apply lt_succ_diag_r. Qed. -Theorem NZle_neq : forall n m : NZ, n < m <-> n <= m /\ n ~= m. +Theorem neq_succ_diag_r : forall n, n ~= S n. Proof. -intros n m; split; [intro H | intros [H1 H2]]. -split. now apply NZlt_le_incl. now apply NZlt_neq. -le_elim H1. assumption. false_hyp H1 H2. +intro n; apply neq_sym, neq_succ_diag_l. Qed. -Theorem NZle_refl : forall n : NZ, n <= n. +Theorem nlt_succ_diag_l : forall n, ~ S n < n. Proof. -intro; now apply NZeq_le_incl. +intros n H. apply (lt_irrefl (S n)). rewrite lt_succ_r. now apply lt_le_incl. Qed. -Theorem NZlt_succ_diag_r : forall n : NZ, n < S n. +Theorem nle_succ_diag_l : forall n, ~ S n <= n. Proof. -intro n. rewrite NZlt_succ_r. now apply NZeq_le_incl. +intros n H; le_elim H. +false_hyp H nlt_succ_diag_l. false_hyp H neq_succ_diag_l. Qed. -Theorem NZle_succ_diag_r : forall n : NZ, n <= S n. +Theorem le_succ_l : forall n m, S n <= m <-> n < m. Proof. -intro; apply NZlt_le_incl; apply NZlt_succ_diag_r. +intro n; nzinduct m n. +split; intro H. false_hyp H nle_succ_diag_l. false_hyp H lt_irrefl. +intro m. +rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd. +rewrite or_cancel_r. +reflexivity. +intros LE EQ; rewrite EQ in LE; false_hyp LE nle_succ_diag_l. +intros LT EQ; rewrite EQ in LT; false_hyp LT lt_irrefl. Qed. -Theorem NZlt_0_1 : 0 < 1. -Proof. -apply NZlt_succ_diag_r. -Qed. +(** Trichotomy *) -Theorem NZle_0_1 : 0 <= 1. +Theorem le_gt_cases : forall n m, n <= m \/ n > m. Proof. -apply NZle_succ_diag_r. +intros n m; nzinduct n m. +left; apply le_refl. +intro n. rewrite lt_succ_r, le_succ_l, !lt_eq_cases. intuition. Qed. -Theorem NZlt_lt_succ_r : forall n m : NZ, n < m -> n < S m. +Theorem lt_trichotomy : forall n m, n < m \/ n == m \/ m < n. Proof. -intros. rewrite NZlt_succ_r. now apply NZlt_le_incl. +intros n m. generalize (le_gt_cases n m); rewrite lt_eq_cases; tauto. Qed. -Theorem NZle_le_succ_r : forall n m : NZ, n <= m -> n <= S m. -Proof. -intros n m H. rewrite <- NZlt_succ_r in H. now apply NZlt_le_incl. -Qed. +Notation lt_eq_gt_cases := lt_trichotomy (only parsing). -Theorem NZle_succ_r : forall n m : NZ, n <= S m <-> n <= m \/ n == S m. +(** Asymmetry and transitivity. *) + +Theorem lt_asymm : forall n m, n < m -> ~ m < n. Proof. -intros n m; rewrite NZlt_eq_cases. now rewrite NZlt_succ_r. +intros n m; nzinduct n m. +intros H; false_hyp H lt_irrefl. +intro n; split; intros H H1 H2. +apply lt_succ_r in H2. le_elim H2. +apply H; auto. apply -> le_succ_l. now apply lt_le_incl. +rewrite H2 in H1. false_hyp H1 nlt_succ_diag_l. +apply le_succ_l in H1. le_elim H1. +apply H; auto. rewrite lt_succ_r. now apply lt_le_incl. +rewrite <- H1 in H2. false_hyp H2 nlt_succ_diag_l. Qed. -(* The following theorem is a special case of neq_succ_iter_l below, -but we prove it separately *) +Notation lt_ngt := lt_asymm (only parsing). -Theorem NZneq_succ_diag_l : forall n : NZ, S n ~= n. +Theorem lt_trans : forall n m p, n < m -> m < p -> n < p. Proof. -intros n H. pose proof (NZlt_succ_diag_r n) as H1. rewrite H in H1. -false_hyp H1 NZlt_irrefl. +intros n m p; nzinduct p m. +intros _ H; false_hyp H lt_irrefl. +intro p. rewrite 2 lt_succ_r. +split; intros H H1 H2. +apply lt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1]. +assert (n <= p) as H3 by (auto using lt_le_incl). +le_elim H3. assumption. rewrite <- H3 in H2. +elim (lt_asymm n m); auto. Qed. -Theorem NZneq_succ_diag_r : forall n : NZ, n ~= S n. +Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p. Proof. -intro n; apply NZneq_sym; apply NZneq_succ_diag_l. +intros n m p. rewrite 3 lt_eq_cases. +intros [LT|EQ] [LT'|EQ']; try rewrite EQ; try rewrite <- EQ'; + generalize (lt_trans n m p); auto with relations. Qed. -Theorem NZnlt_succ_diag_l : forall n : NZ, ~ S n < n. -Proof. -intros n H; apply NZlt_lt_succ_r in H. false_hyp H NZlt_irrefl. -Qed. +(** Some type classes about order *) -Theorem NZnle_succ_diag_l : forall n : NZ, ~ S n <= n. +Instance lt_strorder : StrictOrder lt. +Proof. split. exact lt_irrefl. exact lt_trans. Qed. + +Instance le_preorder : PreOrder le. +Proof. split. exact le_refl. exact le_trans. Qed. + +Instance le_partialorder : PartialOrder _ le. Proof. -intros n H; le_elim H. -false_hyp H NZnlt_succ_diag_l. false_hyp H NZneq_succ_diag_l. +intros x y. compute. split. +intro EQ; now rewrite EQ. +rewrite 2 lt_eq_cases. intuition. elim (lt_irrefl x). now transitivity y. Qed. -Theorem NZle_succ_l : forall n m : NZ, S n <= m <-> n < m. +(** We know enough now to benefit from the generic [order] tactic. *) + +Definition lt_compat := lt_wd. +Definition lt_total := lt_trichotomy. +Definition le_lteq := lt_eq_cases. + +Module OrderElts <: TotalOrder. + Definition t := t. + Definition eq := eq. + Definition lt := lt. + Definition le := le. + Definition eq_equiv := eq_equiv. + Definition lt_strorder := lt_strorder. + Definition lt_compat := lt_compat. + Definition lt_total := lt_total. + Definition le_lteq := le_lteq. +End OrderElts. +Module OrderTac := !MakeOrderTac OrderElts. +Ltac order := OrderTac.order. + +(** Some direct consequences of [order]. *) + +Theorem lt_neq : forall n m, n < m -> n ~= m. +Proof. order. Qed. + +Theorem le_neq : forall n m, n < m <-> n <= m /\ n ~= m. +Proof. intuition order. Qed. + +Theorem eq_le_incl : forall n m, n == m -> n <= m. +Proof. order. Qed. + +Lemma lt_stepl : forall x y z, x < y -> x == z -> z < y. +Proof. order. Qed. + +Lemma lt_stepr : forall x y z, x < y -> y == z -> x < z. +Proof. order. Qed. + +Lemma le_stepl : forall x y z, x <= y -> x == z -> z <= y. +Proof. order. Qed. + +Lemma le_stepr : forall x y z, x <= y -> y == z -> x <= z. +Proof. order. Qed. + +Declare Left Step lt_stepl. +Declare Right Step lt_stepr. +Declare Left Step le_stepl. +Declare Right Step le_stepr. + +Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p. +Proof. order. Qed. + +Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p. +Proof. order. Qed. + +Theorem le_antisymm : forall n m, n <= m -> m <= n -> n == m. +Proof. order. Qed. + +(** More properties of [<] and [<=] with respect to [S] and [0]. *) + +Theorem le_succ_r : forall n m, n <= S m <-> n <= m \/ n == S m. Proof. -intro n; NZinduct m n. -setoid_replace (n < n) with False using relation iff by - (apply -> neg_false; apply NZlt_irrefl). -now setoid_replace (S n <= n) with False using relation iff by - (apply -> neg_false; apply NZnle_succ_diag_l). -intro m. rewrite NZlt_succ_r. rewrite NZle_succ_r. -rewrite NZsucc_inj_wd. -rewrite (NZlt_eq_cases n m). -rewrite or_cancel_r. -reflexivity. -intros H1 H2; rewrite H2 in H1; false_hyp H1 NZnle_succ_diag_l. -apply NZlt_neq. +intros n m; rewrite lt_eq_cases. now rewrite lt_succ_r. Qed. -Theorem NZlt_succ_l : forall n m : NZ, S n < m -> n < m. +Theorem lt_succ_l : forall n m, S n < m -> n < m. Proof. -intros n m H; apply -> NZle_succ_l; now apply NZlt_le_incl. +intros n m H; apply -> le_succ_l; order. Qed. -Theorem NZsucc_lt_mono : forall n m : NZ, n < m <-> S n < S m. +Theorem le_le_succ_r : forall n m, n <= m -> n <= S m. Proof. -intros n m. rewrite <- NZle_succ_l. symmetry. apply NZlt_succ_r. +intros n m LE. rewrite <- lt_succ_r in LE. order. Qed. -Theorem NZsucc_le_mono : forall n m : NZ, n <= m <-> S n <= S m. +Theorem lt_lt_succ_r : forall n m, n < m -> n < S m. Proof. -intros n m. do 2 rewrite NZlt_eq_cases. -rewrite <- NZsucc_lt_mono; now rewrite NZsucc_inj_wd. +intros. rewrite lt_succ_r. order. Qed. -Theorem NZlt_asymm : forall n m, n < m -> ~ m < n. +Theorem succ_lt_mono : forall n m, n < m <-> S n < S m. Proof. -intros n m; NZinduct n m. -intros H _; false_hyp H NZlt_irrefl. -intro n; split; intros H H1 H2. -apply NZlt_succ_l in H1. apply -> NZlt_succ_r in H2. le_elim H2. -now apply H. rewrite H2 in H1; false_hyp H1 NZlt_irrefl. -apply NZlt_lt_succ_r in H2. apply <- NZle_succ_l in H1. le_elim H1. -now apply H. rewrite H1 in H2; false_hyp H2 NZlt_irrefl. +intros n m. rewrite <- le_succ_l. symmetry. apply lt_succ_r. Qed. -Theorem NZlt_trans : forall n m p : NZ, n < m -> m < p -> n < p. +Theorem succ_le_mono : forall n m, n <= m <-> S n <= S m. Proof. -intros n m p; NZinduct p m. -intros _ H; false_hyp H NZlt_irrefl. -intro p. do 2 rewrite NZlt_succ_r. -split; intros H H1 H2. -apply NZlt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1]. -assert (n <= p) as H3. apply H. assumption. now apply NZlt_le_incl. -le_elim H3. assumption. rewrite <- H3 in H2. -elimtype False; now apply (NZlt_asymm n m). +intros n m. now rewrite 2 lt_eq_cases, <- succ_lt_mono, succ_inj_wd. Qed. -Theorem NZle_trans : forall n m p : NZ, n <= m -> m <= p -> n <= p. +Theorem lt_0_1 : 0 < 1. Proof. -intros n m p H1 H2; le_elim H1. -le_elim H2. apply NZlt_le_incl; now apply NZlt_trans with (m := m). -apply NZlt_le_incl; now rewrite <- H2. now rewrite H1. +apply lt_succ_diag_r. Qed. -Theorem NZle_lt_trans : forall n m p : NZ, n <= m -> m < p -> n < p. +Theorem le_0_1 : 0 <= 1. Proof. -intros n m p H1 H2; le_elim H1. -now apply NZlt_trans with (m := m). now rewrite H1. +apply le_succ_diag_r. Qed. -Theorem NZlt_le_trans : forall n m p : NZ, n < m -> m <= p -> n < p. +Theorem lt_1_l : forall n m, 0 < n -> n < m -> 1 < m. Proof. -intros n m p H1 H2; le_elim H2. -now apply NZlt_trans with (m := m). now rewrite <- H2. +intros n m H1 H2. apply <- le_succ_l in H1. order. Qed. -Theorem NZle_antisymm : forall n m : NZ, n <= m -> m <= n -> n == m. + +(** More Trichotomy, decidability and double negation elimination. *) + +(** The following theorem is cleary redundant, but helps not to +remember whether one has to say le_gt_cases or lt_ge_cases *) + +Theorem lt_ge_cases : forall n m, n < m \/ n >= m. Proof. -intros n m H1 H2; now (le_elim H1; le_elim H2); -[elimtype False; apply (NZlt_asymm n m) | | |]. +intros n m; destruct (le_gt_cases m n); intuition order. Qed. -Theorem NZlt_1_l : forall n m : NZ, 0 < n -> n < m -> 1 < m. +Theorem le_ge_cases : forall n m, n <= m \/ n >= m. Proof. -intros n m H1 H2. apply <- NZle_succ_l in H1. now apply NZle_lt_trans with n. +intros n m; destruct (le_gt_cases n m); intuition order. Qed. -(** Trichotomy, decidability, and double negation elimination *) - -Theorem NZlt_trichotomy : forall n m : NZ, n < m \/ n == m \/ m < n. +Theorem lt_gt_cases : forall n m, n ~= m <-> n < m \/ n > m. Proof. -intros n m; NZinduct n m. -right; now left. -intro n; rewrite NZlt_succ_r. stepr ((S n < m \/ S n == m) \/ m <= n) by tauto. -rewrite <- (NZlt_eq_cases (S n) m). -setoid_replace (n == m) with (m == n) using relation iff by now split. -stepl (n < m \/ m < n \/ m == n) by tauto. rewrite <- NZlt_eq_cases. -apply or_iff_compat_r. symmetry; apply NZle_succ_l. +intros n m; destruct (lt_trichotomy n m); intuition order. Qed. -(* Decidability of equality, even though true in each finite ring, does not +(** Decidability of equality, even though true in each finite ring, does not have a uniform proof. Otherwise, the proof for two fixed numbers would reduce to a normal form that will say if the numbers are equal or not, which cannot be true in all finite rings. Therefore, we prove decidability in the presence of order. *) -Theorem NZeq_dec : forall n m : NZ, decidable (n == m). +Theorem eq_decidable : forall n m, decidable (n == m). Proof. -intros n m; destruct (NZlt_trichotomy n m) as [H | [H | H]]. -right; intro H1; rewrite H1 in H; false_hyp H NZlt_irrefl. -now left. -right; intro H1; rewrite H1 in H; false_hyp H NZlt_irrefl. +intros n m; destruct (lt_trichotomy n m) as [ | [ | ]]; + (right; order) || (left; order). Qed. -(* DNE stands for double-negation elimination *) +(** DNE stands for double-negation elimination *) -Theorem NZeq_dne : forall n m, ~ ~ n == m <-> n == m. +Theorem eq_dne : forall n m, ~ ~ n == m <-> n == m. Proof. intros n m; split; intro H. -destruct (NZeq_dec n m) as [H1 | H1]. +destruct (eq_decidable n m) as [H1 | H1]. assumption. false_hyp H1 H. intro H1; now apply H1. Qed. -Theorem NZlt_gt_cases : forall n m : NZ, n ~= m <-> n < m \/ n > m. -Proof. -intros n m; split. -pose proof (NZlt_trichotomy n m); tauto. -intros H H1; destruct H as [H | H]; rewrite H1 in H; false_hyp H NZlt_irrefl. -Qed. +Theorem le_ngt : forall n m, n <= m <-> ~ n > m. +Proof. intuition order. Qed. -Theorem NZle_gt_cases : forall n m : NZ, n <= m \/ n > m. -Proof. -intros n m; destruct (NZlt_trichotomy n m) as [H | [H | H]]. -left; now apply NZlt_le_incl. left; now apply NZeq_le_incl. now right. -Qed. - -(* The following theorem is cleary redundant, but helps not to -remember whether one has to say le_gt_cases or lt_ge_cases *) +(** Redundant but useful *) -Theorem NZlt_ge_cases : forall n m : NZ, n < m \/ n >= m. -Proof. -intros n m; destruct (NZle_gt_cases m n); try (now left); try (now right). -Qed. - -Theorem NZle_ge_cases : forall n m : NZ, n <= m \/ n >= m. -Proof. -intros n m; destruct (NZle_gt_cases n m) as [H | H]. -now left. right; now apply NZlt_le_incl. -Qed. - -Theorem NZle_ngt : forall n m : NZ, n <= m <-> ~ n > m. -Proof. -intros n m. split; intro H; [intro H1 |]. -eapply NZle_lt_trans in H; [| eassumption ..]. false_hyp H NZlt_irrefl. -destruct (NZle_gt_cases n m) as [H1 | H1]. -assumption. false_hyp H1 H. -Qed. - -(* Redundant but useful *) - -Theorem NZnlt_ge : forall n m : NZ, ~ n < m <-> n >= m. -Proof. -intros n m; symmetry; apply NZle_ngt. -Qed. +Theorem nlt_ge : forall n m, ~ n < m <-> n >= m. +Proof. intuition order. Qed. -Theorem NZlt_dec : forall n m : NZ, decidable (n < m). +Theorem lt_decidable : forall n m, decidable (n < m). Proof. -intros n m; destruct (NZle_gt_cases m n); -[right; now apply -> NZle_ngt | now left]. +intros n m; destruct (le_gt_cases m n); [right|left]; order. Qed. -Theorem NZlt_dne : forall n m, ~ ~ n < m <-> n < m. +Theorem lt_dne : forall n m, ~ ~ n < m <-> n < m. Proof. -intros n m; split; intro H; -[destruct (NZlt_dec n m) as [H1 | H1]; [assumption | false_hyp H1 H] | -intro H1; false_hyp H H1]. +intros n m; split; intro H. +destruct (lt_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. +intro H1; false_hyp H H1. Qed. -Theorem NZnle_gt : forall n m : NZ, ~ n <= m <-> n > m. -Proof. -intros n m. rewrite NZle_ngt. apply NZlt_dne. -Qed. +Theorem nle_gt : forall n m, ~ n <= m <-> n > m. +Proof. intuition order. Qed. -(* Redundant but useful *) +(** Redundant but useful *) -Theorem NZlt_nge : forall n m : NZ, n < m <-> ~ n >= m. -Proof. -intros n m; symmetry; apply NZnle_gt. -Qed. +Theorem lt_nge : forall n m, n < m <-> ~ n >= m. +Proof. intuition order. Qed. -Theorem NZle_dec : forall n m : NZ, decidable (n <= m). +Theorem le_decidable : forall n m, decidable (n <= m). Proof. -intros n m; destruct (NZle_gt_cases n m); -[now left | right; now apply <- NZnle_gt]. +intros n m; destruct (le_gt_cases n m); [left|right]; order. Qed. -Theorem NZle_dne : forall n m : NZ, ~ ~ n <= m <-> n <= m. +Theorem le_dne : forall n m, ~ ~ n <= m <-> n <= m. Proof. -intros n m; split; intro H; -[destruct (NZle_dec n m) as [H1 | H1]; [assumption | false_hyp H1 H] | -intro H1; false_hyp H H1]. +intros n m; split; intro H. +destruct (le_decidable n m) as [H1 | H1]; [assumption | false_hyp H1 H]. +intro H1; false_hyp H H1. Qed. -Theorem NZnlt_succ_r : forall n m : NZ, ~ m < S n <-> n < m. +Theorem nlt_succ_r : forall n m, ~ m < S n <-> n < m. Proof. -intros n m; rewrite NZlt_succ_r; apply NZnle_gt. +intros n m; rewrite lt_succ_r. intuition order. Qed. -(* The difference between integers and natural numbers is that for +(** The difference between integers and natural numbers is that for every integer there is a predecessor, which is not true for natural numbers. However, for both classes, every number that is bigger than some other number has a predecessor. The proof of this fact by regular induction does not go through, so we need to use strong (course-of-value) induction. *) -Lemma NZlt_exists_pred_strong : - forall z n m : NZ, z < m -> m <= n -> exists k : NZ, m == S k /\ z <= k. +Lemma lt_exists_pred_strong : + forall z n m, z < m -> m <= n -> exists k, m == S k /\ z <= k. Proof. -intro z; NZinduct n z. -intros m H1 H2; apply <- NZnle_gt in H1; false_hyp H2 H1. +intro z; nzinduct n z. +order. intro n; split; intros IH m H1 H2. -apply -> NZle_succ_r in H2; destruct H2 as [H2 | H2]. -now apply IH. exists n. now split; [| rewrite <- NZlt_succ_r; rewrite <- H2]. -apply IH. assumption. now apply NZle_le_succ_r. +apply -> le_succ_r in H2. destruct H2 as [H2 | H2]. +now apply IH. exists n. now split; [| rewrite <- lt_succ_r; rewrite <- H2]. +apply IH. assumption. now apply le_le_succ_r. Qed. -Theorem NZlt_exists_pred : - forall z n : NZ, z < n -> exists k : NZ, n == S k /\ z <= k. +Theorem lt_exists_pred : + forall z n, z < n -> exists k, n == S k /\ z <= k. Proof. -intros z n H; apply NZlt_exists_pred_strong with (z := z) (n := n). -assumption. apply NZle_refl. +intros z n H; apply lt_exists_pred_strong with (z := z) (n := n). +assumption. apply le_refl. Qed. -(** A corollary of having an order is that NZ is infinite *) - -(* This section about infinity of NZ relies on the type nat and can be -safely removed *) - -Definition NZsucc_iter (n : nat) (m : NZ) := - nat_rect (fun _ => NZ) m (fun _ l => S l) n. - -Theorem NZlt_succ_iter_r : - forall (n : nat) (m : NZ), m < NZsucc_iter (Datatypes.S n) m. -Proof. -intros n m; induction n as [| n IH]; simpl in *. -apply NZlt_succ_diag_r. now apply NZlt_lt_succ_r. -Qed. - -Theorem NZneq_succ_iter_l : - forall (n : nat) (m : NZ), NZsucc_iter (Datatypes.S n) m ~= m. -Proof. -intros n m H. pose proof (NZlt_succ_iter_r n m) as H1. rewrite H in H1. -false_hyp H1 NZlt_irrefl. -Qed. - -(* End of the section about the infinity of NZ *) - (** Stronger variant of induction with assumptions n >= 0 (n < 0) in the induction step *) Section Induction. -Variable A : NZ -> Prop. -Hypothesis A_wd : predicate_wd NZeq A. - -Add Morphism A with signature NZeq ==> iff as A_morph. -Proof. apply A_wd. Qed. +Variable A : t -> Prop. +Hypothesis A_wd : Proper (eq==>iff) A. Section Center. -Variable z : NZ. (* A z is the basis of induction *) +Variable z : t. (* A z is the basis of induction *) Section RightInduction. -Let A' (n : NZ) := forall m : NZ, z <= m -> m < n -> A m. -Let right_step := forall n : NZ, z <= n -> A n -> A (S n). -Let right_step' := forall n : NZ, z <= n -> A' n -> A n. -Let right_step'' := forall n : NZ, A' n <-> A' (S n). +Let A' (n : t) := forall m, z <= m -> m < n -> A m. +Let right_step := forall n, z <= n -> A n -> A (S n). +Let right_step' := forall n, z <= n -> A' n -> A n. +Let right_step'' := forall n, A' n <-> A' (S n). -Lemma NZrs_rs' : A z -> right_step -> right_step'. +Lemma rs_rs' : A z -> right_step -> right_step'. Proof. intros Az RS n H1 H2. -le_elim H1. apply NZlt_exists_pred in H1. destruct H1 as [k [H3 H4]]. -rewrite H3. apply RS; [assumption | apply H2; [assumption | rewrite H3; apply NZlt_succ_diag_r]]. +le_elim H1. apply lt_exists_pred in H1. destruct H1 as [k [H3 H4]]. +rewrite H3. apply RS; trivial. apply H2; trivial. +rewrite H3; apply lt_succ_diag_r. rewrite <- H1; apply Az. Qed. -Lemma NZrs'_rs'' : right_step' -> right_step''. +Lemma rs'_rs'' : right_step' -> right_step''. Proof. intros RS' n; split; intros H1 m H2 H3. -apply -> NZlt_succ_r in H3; le_elim H3; +apply -> lt_succ_r in H3; le_elim H3; [now apply H1 | rewrite H3 in *; now apply RS']. -apply H1; [assumption | now apply NZlt_lt_succ_r]. +apply H1; [assumption | now apply lt_lt_succ_r]. Qed. -Lemma NZrbase : A' z. +Lemma rbase : A' z. Proof. -intros m H1 H2. apply -> NZle_ngt in H1. false_hyp H2 H1. +intros m H1 H2. apply -> le_ngt in H1. false_hyp H2 H1. Qed. -Lemma NZA'A_right : (forall n : NZ, A' n) -> forall n : NZ, z <= n -> A n. +Lemma A'A_right : (forall n, A' n) -> forall n, z <= n -> A n. Proof. -intros H1 n H2. apply H1 with (n := S n); [assumption | apply NZlt_succ_diag_r]. +intros H1 n H2. apply H1 with (n := S n); [assumption | apply lt_succ_diag_r]. Qed. -Theorem NZstrong_right_induction: right_step' -> forall n : NZ, z <= n -> A n. +Theorem strong_right_induction: right_step' -> forall n, z <= n -> A n. Proof. -intro RS'; apply NZA'A_right; unfold A'; NZinduct n z; -[apply NZrbase | apply NZrs'_rs''; apply RS']. +intro RS'; apply A'A_right; unfold A'; nzinduct n z; +[apply rbase | apply rs'_rs''; apply RS']. Qed. -Theorem NZright_induction : A z -> right_step -> forall n : NZ, z <= n -> A n. +Theorem right_induction : A z -> right_step -> forall n, z <= n -> A n. Proof. -intros Az RS; apply NZstrong_right_induction; now apply NZrs_rs'. +intros Az RS; apply strong_right_induction; now apply rs_rs'. Qed. -Theorem NZright_induction' : - (forall n : NZ, n <= z -> A n) -> right_step -> forall n : NZ, A n. +Theorem right_induction' : + (forall n, n <= z -> A n) -> right_step -> forall n, A n. Proof. intros L R n. -destruct (NZlt_trichotomy n z) as [H | [H | H]]. -apply L; now apply NZlt_le_incl. -apply L; now apply NZeq_le_incl. -apply NZright_induction. apply L; now apply NZeq_le_incl. assumption. now apply NZlt_le_incl. +destruct (lt_trichotomy n z) as [H | [H | H]]. +apply L; now apply lt_le_incl. +apply L; now apply eq_le_incl. +apply right_induction. apply L; now apply eq_le_incl. assumption. +now apply lt_le_incl. Qed. -Theorem NZstrong_right_induction' : - (forall n : NZ, n <= z -> A n) -> right_step' -> forall n : NZ, A n. +Theorem strong_right_induction' : + (forall n, n <= z -> A n) -> right_step' -> forall n, A n. Proof. intros L R n. -destruct (NZlt_trichotomy n z) as [H | [H | H]]. -apply L; now apply NZlt_le_incl. -apply L; now apply NZeq_le_incl. -apply NZstrong_right_induction. assumption. now apply NZlt_le_incl. +destruct (lt_trichotomy n z) as [H | [H | H]]. +apply L; now apply lt_le_incl. +apply L; now apply eq_le_incl. +apply strong_right_induction. assumption. now apply lt_le_incl. Qed. End RightInduction. Section LeftInduction. -Let A' (n : NZ) := forall m : NZ, m <= z -> n <= m -> A m. -Let left_step := forall n : NZ, n < z -> A (S n) -> A n. -Let left_step' := forall n : NZ, n <= z -> A' (S n) -> A n. -Let left_step'' := forall n : NZ, A' n <-> A' (S n). +Let A' (n : t) := forall m, m <= z -> n <= m -> A m. +Let left_step := forall n, n < z -> A (S n) -> A n. +Let left_step' := forall n, n <= z -> A' (S n) -> A n. +Let left_step'' := forall n, A' n <-> A' (S n). -Lemma NZls_ls' : A z -> left_step -> left_step'. +Lemma ls_ls' : A z -> left_step -> left_step'. Proof. intros Az LS n H1 H2. le_elim H1. -apply LS; [assumption | apply H2; [now apply <- NZle_succ_l | now apply NZeq_le_incl]]. +apply LS; trivial. apply H2; [now apply <- le_succ_l | now apply eq_le_incl]. rewrite H1; apply Az. Qed. -Lemma NZls'_ls'' : left_step' -> left_step''. +Lemma ls'_ls'' : left_step' -> left_step''. Proof. intros LS' n; split; intros H1 m H2 H3. -apply -> NZle_succ_l in H3. apply NZlt_le_incl in H3. now apply H1. +apply -> le_succ_l in H3. apply lt_le_incl in H3. now apply H1. le_elim H3. -apply <- NZle_succ_l in H3. now apply H1. +apply <- le_succ_l in H3. now apply H1. rewrite <- H3 in *; now apply LS'. Qed. -Lemma NZlbase : A' (S z). +Lemma lbase : A' (S z). Proof. -intros m H1 H2. apply -> NZle_succ_l in H2. -apply -> NZle_ngt in H1. false_hyp H2 H1. +intros m H1 H2. apply -> le_succ_l in H2. +apply -> le_ngt in H1. false_hyp H2 H1. Qed. -Lemma NZA'A_left : (forall n : NZ, A' n) -> forall n : NZ, n <= z -> A n. +Lemma A'A_left : (forall n, A' n) -> forall n, n <= z -> A n. Proof. -intros H1 n H2. apply H1 with (n := n); [assumption | now apply NZeq_le_incl]. +intros H1 n H2. apply H1 with (n := n); [assumption | now apply eq_le_incl]. Qed. -Theorem NZstrong_left_induction: left_step' -> forall n : NZ, n <= z -> A n. +Theorem strong_left_induction: left_step' -> forall n, n <= z -> A n. Proof. -intro LS'; apply NZA'A_left; unfold A'; NZinduct n (S z); -[apply NZlbase | apply NZls'_ls''; apply LS']. +intro LS'; apply A'A_left; unfold A'; nzinduct n (S z); +[apply lbase | apply ls'_ls''; apply LS']. Qed. -Theorem NZleft_induction : A z -> left_step -> forall n : NZ, n <= z -> A n. +Theorem left_induction : A z -> left_step -> forall n, n <= z -> A n. Proof. -intros Az LS; apply NZstrong_left_induction; now apply NZls_ls'. +intros Az LS; apply strong_left_induction; now apply ls_ls'. Qed. -Theorem NZleft_induction' : - (forall n : NZ, z <= n -> A n) -> left_step -> forall n : NZ, A n. +Theorem left_induction' : + (forall n, z <= n -> A n) -> left_step -> forall n, A n. Proof. intros R L n. -destruct (NZlt_trichotomy n z) as [H | [H | H]]. -apply NZleft_induction. apply R. now apply NZeq_le_incl. assumption. now apply NZlt_le_incl. -rewrite H; apply R; now apply NZeq_le_incl. -apply R; now apply NZlt_le_incl. +destruct (lt_trichotomy n z) as [H | [H | H]]. +apply left_induction. apply R. now apply eq_le_incl. assumption. +now apply lt_le_incl. +rewrite H; apply R; now apply eq_le_incl. +apply R; now apply lt_le_incl. Qed. -Theorem NZstrong_left_induction' : - (forall n : NZ, z <= n -> A n) -> left_step' -> forall n : NZ, A n. +Theorem strong_left_induction' : + (forall n, z <= n -> A n) -> left_step' -> forall n, A n. Proof. intros R L n. -destruct (NZlt_trichotomy n z) as [H | [H | H]]. -apply NZstrong_left_induction; auto. now apply NZlt_le_incl. -rewrite H; apply R; now apply NZeq_le_incl. -apply R; now apply NZlt_le_incl. +destruct (lt_trichotomy n z) as [H | [H | H]]. +apply strong_left_induction; auto. now apply lt_le_incl. +rewrite H; apply R; now apply eq_le_incl. +apply R; now apply lt_le_incl. Qed. End LeftInduction. -Theorem NZorder_induction : +Theorem order_induction : A z -> - (forall n : NZ, z <= n -> A n -> A (S n)) -> - (forall n : NZ, n < z -> A (S n) -> A n) -> - forall n : NZ, A n. + (forall n, z <= n -> A n -> A (S n)) -> + (forall n, n < z -> A (S n) -> A n) -> + forall n, A n. Proof. intros Az RS LS n. -destruct (NZlt_trichotomy n z) as [H | [H | H]]. -now apply NZleft_induction; [| | apply NZlt_le_incl]. +destruct (lt_trichotomy n z) as [H | [H | H]]. +now apply left_induction; [| | apply lt_le_incl]. now rewrite H. -now apply NZright_induction; [| | apply NZlt_le_incl]. +now apply right_induction; [| | apply lt_le_incl]. Qed. -Theorem NZorder_induction' : +Theorem order_induction' : A z -> - (forall n : NZ, z <= n -> A n -> A (S n)) -> - (forall n : NZ, n <= z -> A n -> A (P n)) -> - forall n : NZ, A n. + (forall n, z <= n -> A n -> A (S n)) -> + (forall n, n <= z -> A n -> A (P n)) -> + forall n, A n. Proof. -intros Az AS AP n; apply NZorder_induction; try assumption. -intros m H1 H2. apply AP in H2; [| now apply <- NZle_succ_l]. -unfold predicate_wd, fun_wd in A_wd; apply -> (A_wd (P (S m)) m); -[assumption | apply NZpred_succ]. +intros Az AS AP n; apply order_induction; try assumption. +intros m H1 H2. apply AP in H2; [| now apply <- le_succ_l]. +apply -> (A_wd (P (S m)) m); [assumption | apply pred_succ]. Qed. End Center. -Theorem NZorder_induction_0 : +Theorem order_induction_0 : A 0 -> - (forall n : NZ, 0 <= n -> A n -> A (S n)) -> - (forall n : NZ, n < 0 -> A (S n) -> A n) -> - forall n : NZ, A n. -Proof (NZorder_induction 0). + (forall n, 0 <= n -> A n -> A (S n)) -> + (forall n, n < 0 -> A (S n) -> A n) -> + forall n, A n. +Proof (order_induction 0). -Theorem NZorder_induction'_0 : +Theorem order_induction'_0 : A 0 -> - (forall n : NZ, 0 <= n -> A n -> A (S n)) -> - (forall n : NZ, n <= 0 -> A n -> A (P n)) -> - forall n : NZ, A n. -Proof (NZorder_induction' 0). + (forall n, 0 <= n -> A n -> A (S n)) -> + (forall n, n <= 0 -> A n -> A (P n)) -> + forall n, A n. +Proof (order_induction' 0). (** Elimintation principle for < *) -Theorem NZlt_ind : forall (n : NZ), +Theorem lt_ind : forall (n : t), A (S n) -> - (forall m : NZ, n < m -> A m -> A (S m)) -> - forall m : NZ, n < m -> A m. + (forall m, n < m -> A m -> A (S m)) -> + forall m, n < m -> A m. Proof. intros n H1 H2 m H3. -apply NZright_induction with (S n); [assumption | | now apply <- NZle_succ_l]. -intros; apply H2; try assumption. now apply -> NZle_succ_l. +apply right_induction with (S n); [assumption | | now apply <- le_succ_l]. +intros; apply H2; try assumption. now apply -> le_succ_l. Qed. (** Elimintation principle for <= *) -Theorem NZle_ind : forall (n : NZ), +Theorem le_ind : forall (n : t), A n -> - (forall m : NZ, n <= m -> A m -> A (S m)) -> - forall m : NZ, n <= m -> A m. + (forall m, n <= m -> A m -> A (S m)) -> + forall m, n <= m -> A m. Proof. intros n H1 H2 m H3. -now apply NZright_induction with n. +now apply right_induction with n. Qed. End Induction. -Tactic Notation "NZord_induct" ident(n) := - induction_maker n ltac:(apply NZorder_induction_0). +Tactic Notation "nzord_induct" ident(n) := + induction_maker n ltac:(apply order_induction_0). -Tactic Notation "NZord_induct" ident(n) constr(z) := - induction_maker n ltac:(apply NZorder_induction with z). +Tactic Notation "nzord_induct" ident(n) constr(z) := + induction_maker n ltac:(apply order_induction with z). Section WF. -Variable z : NZ. +Variable z : t. -Let Rlt (n m : NZ) := z <= n /\ n < m. -Let Rgt (n m : NZ) := m < n /\ n <= z. +Let Rlt (n m : t) := z <= n /\ n < m. +Let Rgt (n m : t) := m < n /\ n <= z. -Add Morphism Rlt with signature NZeq ==> NZeq ==> iff as Rlt_wd. +Instance Rlt_wd : Proper (eq ==> eq ==> iff) Rlt. Proof. -intros x1 x2 H1 x3 x4 H2; unfold Rlt; rewrite H1; now rewrite H2. +intros x1 x2 H1 x3 x4 H2; unfold Rlt. rewrite H1; now rewrite H2. Qed. -Add Morphism Rgt with signature NZeq ==> NZeq ==> iff as Rgt_wd. +Instance Rgt_wd : Proper (eq ==> eq ==> iff) Rgt. Proof. intros x1 x2 H1 x3 x4 H2; unfold Rgt; rewrite H1; now rewrite H2. Qed. -Lemma NZAcc_lt_wd : predicate_wd NZeq (Acc Rlt). +Instance Acc_lt_wd : Proper (eq==>iff) (Acc Rlt). Proof. -unfold predicate_wd, fun_wd. intros x1 x2 H; split; intro H1; destruct H1 as [H2]; constructor; intros; apply H2; now (rewrite H || rewrite <- H). Qed. -Lemma NZAcc_gt_wd : predicate_wd NZeq (Acc Rgt). +Instance Acc_gt_wd : Proper (eq==>iff) (Acc Rgt). Proof. -unfold predicate_wd, fun_wd. intros x1 x2 H; split; intro H1; destruct H1 as [H2]; constructor; intros; apply H2; now (rewrite H || rewrite <- H). Qed. -Theorem NZlt_wf : well_founded Rlt. +Theorem lt_wf : well_founded Rlt. Proof. unfold well_founded. -apply NZstrong_right_induction' with (z := z). -apply NZAcc_lt_wd. +apply strong_right_induction' with (z := z). +apply Acc_lt_wd. intros n H; constructor; intros y [H1 H2]. -apply <- NZnle_gt in H2. elim H2. now apply NZle_trans with z. +apply <- nle_gt in H2. elim H2. now apply le_trans with z. intros n H1 H2; constructor; intros m [H3 H4]. now apply H2. Qed. -Theorem NZgt_wf : well_founded Rgt. +Theorem gt_wf : well_founded Rgt. Proof. unfold well_founded. -apply NZstrong_left_induction' with (z := z). -apply NZAcc_gt_wd. +apply strong_left_induction' with (z := z). +apply Acc_gt_wd. intros n H; constructor; intros y [H1 H2]. -apply <- NZnle_gt in H2. elim H2. now apply NZle_lt_trans with n. +apply <- nle_gt in H2. elim H2. now apply le_lt_trans with n. intros n H1 H2; constructor; intros m [H3 H4]. -apply H2. assumption. now apply <- NZle_succ_l. +apply H2. assumption. now apply <- le_succ_l. Qed. End WF. -End NZOrderPropFunct. +End NZOrderPropSig. + +Module NZOrderPropFunct (NZ : NZOrdSig) := + NZBasePropSig NZ <+ NZOrderPropSig NZ. + +(** If we have moreover a [compare] function, we can build + an [OrderedType] structure. *) + +Module NZOrderedTypeFunct (NZ : NZDecOrdSig') + <: DecidableTypeFull <: OrderedTypeFull := + NZ <+ NZOrderPropFunct <+ Compare2EqBool <+ HasEqBool2Dec. diff --git a/theories/Numbers/NatInt/NZProperties.v b/theories/Numbers/NatInt/NZProperties.v new file mode 100644 index 00000000..125b4f62 --- /dev/null +++ b/theories/Numbers/NatInt/NZProperties.v @@ -0,0 +1,20 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* forall m1 m2 : N, m1 == m2 -> n1 + m1 == n2 + m2. -Proof NZadd_wd. - -Theorem add_0_l : forall n : N, 0 + n == n. -Proof NZadd_0_l. - -Theorem add_succ_l : forall n m : N, (S n) + m == S (n + m). -Proof NZadd_succ_l. - -(** Theorems that are valid for both natural numbers and integers *) - -Theorem add_0_r : forall n : N, n + 0 == n. -Proof NZadd_0_r. - -Theorem add_succ_r : forall n m : N, n + S m == S (n + m). -Proof NZadd_succ_r. - -Theorem add_comm : forall n m : N, n + m == m + n. -Proof NZadd_comm. - -Theorem add_assoc : forall n m p : N, n + (m + p) == (n + m) + p. -Proof NZadd_assoc. - -Theorem add_shuffle1 : forall n m p q : N, (n + m) + (p + q) == (n + p) + (m + q). -Proof NZadd_shuffle1. - -Theorem add_shuffle2 : forall n m p q : N, (n + m) + (p + q) == (n + q) + (m + p). -Proof NZadd_shuffle2. - -Theorem add_1_l : forall n : N, 1 + n == S n. -Proof NZadd_1_l. - -Theorem add_1_r : forall n : N, n + 1 == S n. -Proof NZadd_1_r. - -Theorem add_cancel_l : forall n m p : N, p + n == p + m <-> n == m. -Proof NZadd_cancel_l. - -Theorem add_cancel_r : forall n m p : N, n + p == m + p <-> n == m. -Proof NZadd_cancel_r. - -(* Theorems that are valid for natural numbers but cannot be proved for Z *) - -Theorem eq_add_0 : forall n m : N, n + m == 0 <-> n == 0 /\ m == 0. +Theorem eq_add_0 : forall n m, n + m == 0 <-> n == 0 /\ m == 0. Proof. intros n m; induct n. -(* The next command does not work with the axiom add_0_l from NAddSig *) -rewrite add_0_l. intuition reflexivity. -intros n IH. rewrite add_succ_l. -setoid_replace (S (n + m) == 0) with False using relation iff by +nzsimpl; intuition. +intros n IH. nzsimpl. +setoid_replace (S (n + m) == 0) with False by (apply -> neg_false; apply neq_succ_0). -setoid_replace (S n == 0) with False using relation iff by +setoid_replace (S n == 0) with False by (apply -> neg_false; apply neq_succ_0). tauto. Qed. Theorem eq_add_succ : - forall n m : N, (exists p : N, n + m == S p) <-> - (exists n' : N, n == S n') \/ (exists m' : N, m == S m'). + forall n m, (exists p, n + m == S p) <-> + (exists n', n == S n') \/ (exists m', m == S m'). Proof. intros n m; cases n. split; intro H. @@ -88,11 +44,11 @@ left; now exists n. exists (n + m); now rewrite add_succ_l. Qed. -Theorem eq_add_1 : forall n m : N, +Theorem eq_add_1 : forall n m, n + m == 1 -> n == 1 /\ m == 0 \/ n == 0 /\ m == 1. Proof. intros n m H. -assert (H1 : exists p : N, n + m == S p) by now exists 0. +assert (H1 : exists p, n + m == S p) by now exists 0. apply -> eq_add_succ in H1. destruct H1 as [[n' H1] | [m' H1]]. left. rewrite H1 in H; rewrite add_succ_l in H; apply succ_inj in H. apply -> eq_add_0 in H. destruct H as [H2 H3]; rewrite H2 in H1; now split. @@ -100,7 +56,7 @@ right. rewrite H1 in H; rewrite add_succ_r in H; apply succ_inj in H. apply -> eq_add_0 in H. destruct H as [H2 H3]; rewrite H3 in H1; now split. Qed. -Theorem succ_add_discr : forall n m : N, m ~= S (n + m). +Theorem succ_add_discr : forall n m, m ~= S (n + m). Proof. intro n; induct m. apply neq_sym. apply neq_succ_0. @@ -108,49 +64,18 @@ intros m IH H. apply succ_inj in H. rewrite add_succ_r in H. unfold not in IH; now apply IH. Qed. -Theorem add_pred_l : forall n m : N, n ~= 0 -> P n + m == P (n + m). +Theorem add_pred_l : forall n m, n ~= 0 -> P n + m == P (n + m). Proof. intros n m; cases n. intro H; now elim H. intros n IH; rewrite add_succ_l; now do 2 rewrite pred_succ. Qed. -Theorem add_pred_r : forall n m : N, m ~= 0 -> n + P m == P (n + m). +Theorem add_pred_r : forall n m, m ~= 0 -> n + P m == P (n + m). Proof. intros n m H; rewrite (add_comm n (P m)); rewrite (add_comm n m); now apply add_pred_l. Qed. -(* One could define n <= m as exists p : N, p + n == m. Then we have -dichotomy: - -forall n m : N, n <= m \/ m <= n, - -i.e., - -forall n m : N, (exists p : N, p + n == m) \/ (exists p : N, p + m == n) (1) - -We will need (1) in the proof of induction principle for integers -constructed as pairs of natural numbers. The formula (1) can be proved -using properties of order and truncated subtraction. Thus, p would be -m - n or n - m and (1) would hold by theorem sub_add from Sub.v -depending on whether n <= m or m <= n. However, in proving induction -for integers constructed from natural numbers we do not need to -require implementations of order and sub; it is enough to prove (1) -here. *) - -Theorem add_dichotomy : - forall n m : N, (exists p : N, p + n == m) \/ (exists p : N, p + m == n). -Proof. -intros n m; induct n. -left; exists m; apply add_0_r. -intros n IH. -destruct IH as [[p H] | [p H]]. -destruct (zero_or_succ p) as [H1 | [p' H1]]; rewrite H1 in H. -rewrite add_0_l in H. right; exists (S 0); rewrite H; rewrite add_succ_l; now rewrite add_0_l. -left; exists p'; rewrite add_succ_r; now rewrite add_succ_l in H. -right; exists (S p). rewrite add_succ_l; now rewrite H. -Qed. - End NAddPropFunct. diff --git a/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v index 7024fd00..0ce04e54 100644 --- a/theories/Numbers/Natural/Abstract/NAddOrder.v +++ b/theories/Numbers/Natural/Abstract/NAddOrder.v @@ -8,107 +8,41 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NAddOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) Require Export NOrder. -Module NAddOrderPropFunct (Import NAxiomsMod : NAxiomsSig). -Module Export NOrderPropMod := NOrderPropFunct NAxiomsMod. -Open Local Scope NatScope. +Module NAddOrderPropFunct (Import N : NAxiomsSig'). +Include NOrderPropFunct N. -Theorem add_lt_mono_l : forall n m p : N, n < m <-> p + n < p + m. -Proof NZadd_lt_mono_l. +(** Theorems true for natural numbers, not for integers *) -Theorem add_lt_mono_r : forall n m p : N, n < m <-> n + p < m + p. -Proof NZadd_lt_mono_r. - -Theorem add_lt_mono : forall n m p q : N, n < m -> p < q -> n + p < m + q. -Proof NZadd_lt_mono. - -Theorem add_le_mono_l : forall n m p : N, n <= m <-> p + n <= p + m. -Proof NZadd_le_mono_l. - -Theorem add_le_mono_r : forall n m p : N, n <= m <-> n + p <= m + p. -Proof NZadd_le_mono_r. - -Theorem add_le_mono : forall n m p q : N, n <= m -> p <= q -> n + p <= m + q. -Proof NZadd_le_mono. - -Theorem add_lt_le_mono : forall n m p q : N, n < m -> p <= q -> n + p < m + q. -Proof NZadd_lt_le_mono. - -Theorem add_le_lt_mono : forall n m p q : N, n <= m -> p < q -> n + p < m + q. -Proof NZadd_le_lt_mono. - -Theorem add_pos_pos : forall n m : N, 0 < n -> 0 < m -> 0 < n + m. -Proof NZadd_pos_pos. - -Theorem lt_add_pos_l : forall n m : N, 0 < n -> m < n + m. -Proof NZlt_add_pos_l. - -Theorem lt_add_pos_r : forall n m : N, 0 < n -> m < m + n. -Proof NZlt_add_pos_r. - -Theorem le_lt_add_lt : forall n m p q : N, n <= m -> p + m < q + n -> p < q. -Proof NZle_lt_add_lt. - -Theorem lt_le_add_lt : forall n m p q : N, n < m -> p + m <= q + n -> p < q. -Proof NZlt_le_add_lt. - -Theorem le_le_add_le : forall n m p q : N, n <= m -> p + m <= q + n -> p <= q. -Proof NZle_le_add_le. - -Theorem add_lt_cases : forall n m p q : N, n + m < p + q -> n < p \/ m < q. -Proof NZadd_lt_cases. - -Theorem add_le_cases : forall n m p q : N, n + m <= p + q -> n <= p \/ m <= q. -Proof NZadd_le_cases. - -Theorem add_pos_cases : forall n m : N, 0 < n + m -> 0 < n \/ 0 < m. -Proof NZadd_pos_cases. - -(* Theorems true for natural numbers *) - -Theorem le_add_r : forall n m : N, n <= n + m. +Theorem le_add_r : forall n m, n <= n + m. Proof. intro n; induct m. rewrite add_0_r; now apply eq_le_incl. intros m IH. rewrite add_succ_r; now apply le_le_succ_r. Qed. -Theorem lt_lt_add_r : forall n m p : N, n < m -> n < m + p. +Theorem lt_lt_add_r : forall n m p, n < m -> n < m + p. Proof. intros n m p H; rewrite <- (add_0_r n). apply add_lt_le_mono; [assumption | apply le_0_l]. Qed. -Theorem lt_lt_add_l : forall n m p : N, n < m -> n < p + m. +Theorem lt_lt_add_l : forall n m p, n < m -> n < p + m. Proof. intros n m p; rewrite add_comm; apply lt_lt_add_r. Qed. -Theorem add_pos_l : forall n m : N, 0 < n -> 0 < n + m. +Theorem add_pos_l : forall n m, 0 < n -> 0 < n + m. Proof. -intros; apply NZadd_pos_nonneg. assumption. apply le_0_l. +intros; apply add_pos_nonneg. assumption. apply le_0_l. Qed. -Theorem add_pos_r : forall n m : N, 0 < m -> 0 < n + m. -Proof. -intros; apply NZadd_nonneg_pos. apply le_0_l. assumption. -Qed. - -(* The following property is used to prove the correctness of the -definition of order on integers constructed from pairs of natural numbers *) - -Theorem add_lt_repl_pair : forall n m n' m' u v : N, - n + u < m + v -> n + m' == n' + m -> n' + u < m' + v. +Theorem add_pos_r : forall n m, 0 < m -> 0 < n + m. Proof. -intros n m n' m' u v H1 H2. -symmetry in H2. assert (H3 : n' + m <= n + m') by now apply eq_le_incl. -pose proof (add_lt_le_mono _ _ _ _ H1 H3) as H4. -rewrite (add_shuffle2 n u), (add_shuffle1 m v), (add_comm m n) in H4. -do 2 rewrite <- add_assoc in H4. do 2 apply <- add_lt_mono_l in H4. -now rewrite (add_comm n' u), (add_comm m' v). +intros; apply add_nonneg_pos. apply le_0_l. assumption. Qed. End NAddOrderPropFunct. diff --git a/theories/Numbers/Natural/Abstract/NAxioms.v b/theories/Numbers/Natural/Abstract/NAxioms.v index 750cc977..42016ab1 100644 --- a/theories/Numbers/Natural/Abstract/NAxioms.v +++ b/theories/Numbers/Natural/Abstract/NAxioms.v @@ -8,64 +8,32 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NAxioms.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) Require Export NZAxioms. Set Implicit Arguments. -Module Type NAxiomsSig. -Declare Module Export NZOrdAxiomsMod : NZOrdAxiomsSig. +Module Type NAxioms (Import NZ : NZDomainSig'). -Delimit Scope NatScope with Nat. -Notation N := NZ. -Notation Neq := NZeq. -Notation N0 := NZ0. -Notation N1 := (NZsucc NZ0). -Notation S := NZsucc. -Notation P := NZpred. -Notation add := NZadd. -Notation mul := NZmul. -Notation sub := NZsub. -Notation lt := NZlt. -Notation le := NZle. -Notation min := NZmin. -Notation max := NZmax. -Notation "x == y" := (Neq x y) (at level 70) : NatScope. -Notation "x ~= y" := (~ Neq x y) (at level 70) : NatScope. -Notation "0" := NZ0 : NatScope. -Notation "1" := (NZsucc NZ0) : NatScope. -Notation "x + y" := (NZadd x y) : NatScope. -Notation "x - y" := (NZsub x y) : NatScope. -Notation "x * y" := (NZmul x y) : NatScope. -Notation "x < y" := (NZlt x y) : NatScope. -Notation "x <= y" := (NZle x y) : NatScope. -Notation "x > y" := (NZlt y x) (only parsing) : NatScope. -Notation "x >= y" := (NZle y x) (only parsing) : NatScope. - -Open Local Scope NatScope. +Axiom pred_0 : P 0 == 0. -Parameter Inline recursion : forall A : Type, A -> (N -> A -> A) -> N -> A. +Parameter Inline recursion : forall A : Type, A -> (t -> A -> A) -> t -> A. Implicit Arguments recursion [A]. -Axiom pred_0 : P 0 == 0. - -Axiom recursion_wd : forall (A : Type) (Aeq : relation A), - forall a a' : A, Aeq a a' -> - forall f f' : N -> A -> A, fun2_eq Neq Aeq Aeq f f' -> - forall x x' : N, x == x' -> - Aeq (recursion a f x) (recursion a' f' x'). +Declare Instance recursion_wd (A : Type) (Aeq : relation A) : + Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A). Axiom recursion_0 : - forall (A : Type) (a : A) (f : N -> A -> A), recursion a f 0 = a. + forall (A : Type) (a : A) (f : t -> A -> A), recursion a f 0 = a. Axiom recursion_succ : - forall (A : Type) (Aeq : relation A) (a : A) (f : N -> A -> A), - Aeq a a -> fun2_wd Neq Aeq Aeq f -> - forall n : N, Aeq (recursion a f (S n)) (f n (recursion a f n)). + forall (A : Type) (Aeq : relation A) (a : A) (f : t -> A -> A), + Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> + forall n, Aeq (recursion a f (S n)) (f n (recursion a f n)). -(*Axiom dep_rec : - forall A : N -> Type, A 0 -> (forall n : N, A n -> A (S n)) -> forall n : N, A n.*) +End NAxioms. -End NAxiomsSig. +Module Type NAxiomsSig := NZOrdAxiomsSig <+ NAxioms. +Module Type NAxiomsSig' := NZOrdAxiomsSig' <+ NAxioms. diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v index 85e2c2ab..842f4bcf 100644 --- a/theories/Numbers/Natural/Abstract/NBase.v +++ b/theories/Numbers/Natural/Abstract/NBase.v @@ -8,135 +8,78 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NBase.v 11674 2008-12-12 19:48:40Z letouzey $ i*) +(*i $Id$ i*) Require Export Decidable. Require Export NAxioms. -Require Import NZMulOrder. (* The last property functor on NZ, which subsumes all others *) +Require Import NZProperties. -Module NBasePropFunct (Import NAxiomsMod : NAxiomsSig). +Module NBasePropFunct (Import N : NAxiomsSig'). +(** First, we import all known facts about both natural numbers and integers. *) +Include NZPropFunct N. -Open Local Scope NatScope. - -(* We call the last property functor on NZ, which includes all the previous -ones, to get all properties of NZ at once. This way we will include them -only one time. *) - -Module Export NZMulOrderMod := NZMulOrderPropFunct NZOrdAxiomsMod. - -(* Here we probably need to re-prove all axioms declared in NAxioms.v to -make sure that the definitions like N, S and add are unfolded in them, -since unfolding is done only inside a functor. In fact, we'll do it in the -files that prove the corresponding properties. In those files, we will also -rename properties proved in NZ files by removing NZ from their names. In -this way, one only has to consult, for example, NAdd.v to see all -available properties for add, i.e., one does not have to go to NAxioms.v -for axioms and NZAdd.v for theorems. *) - -Theorem succ_wd : forall n1 n2 : N, n1 == n2 -> S n1 == S n2. -Proof NZsucc_wd. - -Theorem pred_wd : forall n1 n2 : N, n1 == n2 -> P n1 == P n2. -Proof NZpred_wd. - -Theorem pred_succ : forall n : N, P (S n) == n. -Proof NZpred_succ. - -Theorem pred_0 : P 0 == 0. -Proof pred_0. - -Theorem Neq_refl : forall n : N, n == n. -Proof (proj1 NZeq_equiv). - -Theorem Neq_sym : forall n m : N, n == m -> m == n. -Proof (proj2 (proj2 NZeq_equiv)). - -Theorem Neq_trans : forall n m p : N, n == m -> m == p -> n == p. -Proof (proj1 (proj2 NZeq_equiv)). - -Theorem neq_sym : forall n m : N, n ~= m -> m ~= n. -Proof NZneq_sym. - -Theorem succ_inj : forall n1 n2 : N, S n1 == S n2 -> n1 == n2. -Proof NZsucc_inj. - -Theorem succ_inj_wd : forall n1 n2 : N, S n1 == S n2 <-> n1 == n2. -Proof NZsucc_inj_wd. - -Theorem succ_inj_wd_neg : forall n m : N, S n ~= S m <-> n ~= m. -Proof NZsucc_inj_wd_neg. - -(* Decidability and stability of equality was proved only in NZOrder, but -since it does not mention order, we'll put it here *) - -Theorem eq_dec : forall n m : N, decidable (n == m). -Proof NZeq_dec. - -Theorem eq_dne : forall n m : N, ~ ~ n == m <-> n == m. -Proof NZeq_dne. - -(* Now we prove that the successor of a number is not zero by defining a +(** We prove that the successor of a number is not zero by defining a function (by recursion) that maps 0 to false and the successor to true *) -Definition if_zero (A : Set) (a b : A) (n : N) : A := +Definition if_zero (A : Type) (a b : A) (n : N.t) : A := recursion a (fun _ _ => b) n. -Add Parametric Morphism (A : Set) : (if_zero A) with signature (@eq _ ==> @eq _ ==> Neq ==> @eq _) as if_zero_wd. +Implicit Arguments if_zero [A]. + +Instance if_zero_wd (A : Type) : + Proper (Logic.eq ==> Logic.eq ==> N.eq ==> Logic.eq) (@if_zero A). Proof. -intros; unfold if_zero. apply recursion_wd with (Aeq := (@eq A)). -reflexivity. unfold fun2_eq; now intros. assumption. +intros; unfold if_zero. +repeat red; intros. apply recursion_wd; auto. repeat red; auto. Qed. -Theorem if_zero_0 : forall (A : Set) (a b : A), if_zero A a b 0 = a. +Theorem if_zero_0 : forall (A : Type) (a b : A), if_zero a b 0 = a. Proof. unfold if_zero; intros; now rewrite recursion_0. Qed. -Theorem if_zero_succ : forall (A : Set) (a b : A) (n : N), if_zero A a b (S n) = b. +Theorem if_zero_succ : + forall (A : Type) (a b : A) (n : N.t), if_zero a b (S n) = b. Proof. intros; unfold if_zero. -now rewrite (@recursion_succ A (@eq A)); [| | unfold fun2_wd; now intros]. +now rewrite recursion_succ. Qed. -Implicit Arguments if_zero [A]. - -Theorem neq_succ_0 : forall n : N, S n ~= 0. +Theorem neq_succ_0 : forall n, S n ~= 0. Proof. intros n H. -assert (true = false); [| discriminate]. -replace true with (if_zero false true (S n)) by apply if_zero_succ. -pattern false at 2; replace false with (if_zero false true 0) by apply if_zero_0. -now rewrite H. +generalize (Logic.eq_refl (if_zero false true 0)). +rewrite <- H at 1. rewrite if_zero_0, if_zero_succ; discriminate. Qed. -Theorem neq_0_succ : forall n : N, 0 ~= S n. +Theorem neq_0_succ : forall n, 0 ~= S n. Proof. intro n; apply neq_sym; apply neq_succ_0. Qed. -(* Next, we show that all numbers are nonnegative and recover regular induction -from the bidirectional induction on NZ *) +(** Next, we show that all numbers are nonnegative and recover regular + induction from the bidirectional induction on NZ *) -Theorem le_0_l : forall n : N, 0 <= n. +Theorem le_0_l : forall n, 0 <= n. Proof. -NZinduct n. -now apply NZeq_le_incl. +nzinduct n. +now apply eq_le_incl. intro n; split. -apply NZle_le_succ_r. -intro H; apply -> NZle_succ_r in H; destruct H as [H | H]. +apply le_le_succ_r. +intro H; apply -> le_succ_r in H; destruct H as [H | H]. assumption. symmetry in H; false_hyp H neq_succ_0. Qed. Theorem induction : - forall A : N -> Prop, predicate_wd Neq A -> - A 0 -> (forall n : N, A n -> A (S n)) -> forall n : N, A n. + forall A : N.t -> Prop, Proper (N.eq==>iff) A -> + A 0 -> (forall n, A n -> A (S n)) -> forall n, A n. Proof. -intros A A_wd A0 AS n; apply NZright_induction with 0; try assumption. +intros A A_wd A0 AS n; apply right_induction with 0; try assumption. intros; auto; apply le_0_l. apply le_0_l. Qed. -(* The theorems NZinduction, NZcentral_induction and the tactic NZinduct +(** The theorems [bi_induction], [central_induction] and the tactic [nzinduct] refer to bidirectional induction, which is not useful on natural numbers. Therefore, we define a new induction tactic for natural numbers. We do not have to call "Declare Left Step" and "Declare Right Step" @@ -146,8 +89,8 @@ from NZ. *) Ltac induct n := induction_maker n ltac:(apply induction). Theorem case_analysis : - forall A : N -> Prop, predicate_wd Neq A -> - A 0 -> (forall n : N, A (S n)) -> forall n : N, A n. + forall A : N.t -> Prop, Proper (N.eq==>iff) A -> + A 0 -> (forall n, A (S n)) -> forall n, A n. Proof. intros; apply induction; auto. Qed. @@ -173,7 +116,7 @@ now left. intro n; right; now exists n. Qed. -Theorem eq_pred_0 : forall n : N, P n == 0 <-> n == 0 \/ n == 1. +Theorem eq_pred_0 : forall n, P n == 0 <-> n == 0 \/ n == 1. Proof. cases n. rewrite pred_0. setoid_replace (0 == 1) with False using relation iff. tauto. @@ -184,34 +127,29 @@ setoid_replace (S n == 0) with False using relation iff by rewrite succ_inj_wd. tauto. Qed. -Theorem succ_pred : forall n : N, n ~= 0 -> S (P n) == n. +Theorem succ_pred : forall n, n ~= 0 -> S (P n) == n. Proof. cases n. -intro H; elimtype False; now apply H. +intro H; exfalso; now apply H. intros; now rewrite pred_succ. Qed. -Theorem pred_inj : forall n m : N, n ~= 0 -> m ~= 0 -> P n == P m -> n == m. +Theorem pred_inj : forall n m, n ~= 0 -> m ~= 0 -> P n == P m -> n == m. Proof. intros n m; cases n. -intros H; elimtype False; now apply H. +intros H; exfalso; now apply H. intros n _; cases m. -intros H; elimtype False; now apply H. +intros H; exfalso; now apply H. intros m H2 H3. do 2 rewrite pred_succ in H3. now rewrite H3. Qed. -(* The following induction principle is useful for reasoning about, e.g., +(** The following induction principle is useful for reasoning about, e.g., Fibonacci numbers *) Section PairInduction. -Variable A : N -> Prop. -Hypothesis A_wd : predicate_wd Neq A. - -Add Morphism A with signature Neq ==> iff as A_morph. -Proof. -exact A_wd. -Qed. +Variable A : N.t -> Prop. +Hypothesis A_wd : Proper (N.eq==>iff) A. Theorem pair_induction : A 0 -> A 1 -> @@ -224,18 +162,12 @@ Qed. End PairInduction. -(*Ltac pair_induct n := induction_maker n ltac:(apply pair_induction).*) +(** The following is useful for reasoning about, e.g., Ackermann function *) -(* The following is useful for reasoning about, e.g., Ackermann function *) Section TwoDimensionalInduction. -Variable R : N -> N -> Prop. -Hypothesis R_wd : relation_wd Neq Neq R. - -Add Morphism R with signature Neq ==> Neq ==> iff as R_morph. -Proof. -exact R_wd. -Qed. +Variable R : N.t -> N.t -> Prop. +Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. Theorem two_dim_induction : R 0 0 -> @@ -251,26 +183,16 @@ Qed. End TwoDimensionalInduction. -(*Ltac two_dim_induct n m := - try intros until n; - try intros until m; - pattern n, m; apply two_dim_induction; clear n m; - [solve_relation_wd | | | ].*) Section DoubleInduction. -Variable R : N -> N -> Prop. -Hypothesis R_wd : relation_wd Neq Neq R. - -Add Morphism R with signature Neq ==> Neq ==> iff as R_morph1. -Proof. -exact R_wd. -Qed. +Variable R : N.t -> N.t -> Prop. +Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. Theorem double_induction : - (forall m : N, R 0 m) -> - (forall n : N, R (S n) 0) -> - (forall n m : N, R n m -> R (S n) (S m)) -> forall n m : N, R n m. + (forall m, R 0 m) -> + (forall n, R (S n) 0) -> + (forall n m, R n m -> R (S n) (S m)) -> forall n m, R n m. Proof. intros H1 H2 H3; induct n; auto. intros n H; cases m; auto. diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v index 0a8f5f1e..22eb2cb3 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -8,45 +8,47 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NDefOps.v 11674 2008-12-12 19:48:40Z letouzey $ i*) +(*i $Id$ i*) Require Import Bool. (* To get the orb and negb function *) +Require Import RelationPairs. Require Export NStrongRec. -Module NdefOpsPropFunct (Import NAxiomsMod : NAxiomsSig). -Module Export NStrongRecPropMod := NStrongRecPropFunct NAxiomsMod. -Open Local Scope NatScope. +Module NdefOpsPropFunct (Import N : NAxiomsSig'). +Include NStrongRecPropFunct N. (*****************************************************) (** Addition *) -Definition def_add (x y : N) := recursion y (fun _ p => S p) x. +Definition def_add (x y : N.t) := recursion y (fun _ => S) x. -Infix Local "++" := def_add (at level 50, left associativity). +Local Infix "+++" := def_add (at level 50, left associativity). -Add Morphism def_add with signature Neq ==> Neq ==> Neq as def_add_wd. +Instance def_add_prewd : Proper (N.eq==>N.eq==>N.eq) (fun _ => S). Proof. -unfold def_add. -intros x x' Exx' y y' Eyy'. -apply recursion_wd with (Aeq := Neq). -assumption. -unfold fun2_eq; intros _ _ _ p p' Epp'; now rewrite Epp'. -assumption. +intros _ _ _ p p' Epp'; now rewrite Epp'. +Qed. + +Instance def_add_wd : Proper (N.eq ==> N.eq ==> N.eq) def_add. +Proof. +intros x x' Exx' y y' Eyy'. unfold def_add. +(* TODO: why rewrite Exx' don't work here (or verrrry slowly) ? *) +apply recursion_wd with (Aeq := N.eq); auto with *. +apply def_add_prewd. Qed. -Theorem def_add_0_l : forall y : N, 0 ++ y == y. +Theorem def_add_0_l : forall y, 0 +++ y == y. Proof. intro y. unfold def_add. now rewrite recursion_0. Qed. -Theorem def_add_succ_l : forall x y : N, S x ++ y == S (x ++ y). +Theorem def_add_succ_l : forall x y, S x +++ y == S (x +++ y). Proof. intros x y; unfold def_add. -rewrite (@recursion_succ N Neq); try reflexivity. -unfold fun2_wd. intros _ _ _ m1 m2 H2. now rewrite H2. +rewrite recursion_succ; auto with *. Qed. -Theorem def_add_add : forall n m : N, n ++ m == n + m. +Theorem def_add_add : forall n m, n +++ m == n + m. Proof. intros n m; induct n. now rewrite def_add_0_l, add_0_l. @@ -56,42 +58,37 @@ Qed. (*****************************************************) (** Multiplication *) -Definition def_mul (x y : N) := recursion 0 (fun _ p => p ++ x) y. +Definition def_mul (x y : N.t) := recursion 0 (fun _ p => p +++ x) y. -Infix Local "**" := def_mul (at level 40, left associativity). +Local Infix "**" := def_mul (at level 40, left associativity). -Lemma def_mul_step_wd : forall x : N, fun2_wd Neq Neq Neq (fun _ p => def_add p x). +Instance def_mul_prewd : + Proper (N.eq==>N.eq==>N.eq==>N.eq) (fun x _ p => p +++ x). Proof. -unfold fun2_wd. intros. now apply def_add_wd. +repeat red; intros; now apply def_add_wd. Qed. -Lemma def_mul_step_equal : - forall x x' : N, x == x' -> - fun2_eq Neq Neq Neq (fun _ p => def_add p x) (fun x p => def_add p x'). -Proof. -unfold fun2_eq; intros; apply def_add_wd; assumption. -Qed. - -Add Morphism def_mul with signature Neq ==> Neq ==> Neq as def_mul_wd. +Instance def_mul_wd : Proper (N.eq ==> N.eq ==> N.eq) def_mul. Proof. unfold def_mul. intros x x' Exx' y y' Eyy'. -apply recursion_wd with (Aeq := Neq). -reflexivity. apply def_mul_step_equal. assumption. assumption. +apply recursion_wd; auto with *. +now apply def_mul_prewd. Qed. -Theorem def_mul_0_r : forall x : N, x ** 0 == 0. +Theorem def_mul_0_r : forall x, x ** 0 == 0. Proof. intro. unfold def_mul. now rewrite recursion_0. Qed. -Theorem def_mul_succ_r : forall x y : N, x ** S y == x ** y ++ x. +Theorem def_mul_succ_r : forall x y, x ** S y == x ** y +++ x. Proof. intros x y; unfold def_mul. -now rewrite (@recursion_succ N Neq); [| apply def_mul_step_wd |]. +rewrite recursion_succ; auto with *. +now apply def_mul_prewd. Qed. -Theorem def_mul_mul : forall n m : N, n ** m == n * m. +Theorem def_mul_mul : forall n m, n ** m == n * m. Proof. intros n m; induct m. now rewrite def_mul_0_r, mul_0_r. @@ -101,120 +98,99 @@ Qed. (*****************************************************) (** Order *) -Definition def_ltb (m : N) : N -> bool := +Definition ltb (m : N.t) : N.t -> bool := recursion (if_zero false true) - (fun _ f => fun n => recursion false (fun n' _ => f n') n) + (fun _ f n => recursion false (fun n' _ => f n') n) m. -Infix Local "<<" := def_ltb (at level 70, no associativity). - -Lemma lt_base_wd : fun_wd Neq (@eq bool) (if_zero false true). -unfold fun_wd; intros; now apply if_zero_wd. -Qed. +Local Infix "<<" := ltb (at level 70, no associativity). -Lemma lt_step_wd : -fun2_wd Neq (fun_eq Neq (@eq bool)) (fun_eq Neq (@eq bool)) - (fun _ f => fun n => recursion false (fun n' _ => f n') n). +Instance ltb_prewd1 : Proper (N.eq==>Logic.eq) (if_zero false true). Proof. -unfold fun2_wd, fun_eq. -intros x x' Exx' f f' Eff' y y' Eyy'. -apply recursion_wd with (Aeq := @eq bool). -reflexivity. -unfold fun2_eq; intros; now apply Eff'. -assumption. +red; intros; apply if_zero_wd; auto. Qed. -Lemma lt_curry_wd : - forall m m' : N, m == m' -> fun_eq Neq (@eq bool) (def_ltb m) (def_ltb m'). +Instance ltb_prewd2 : Proper (N.eq==>(N.eq==>Logic.eq)==>N.eq==>Logic.eq) + (fun _ f n => recursion false (fun n' _ => f n') n). Proof. -unfold def_ltb. -intros m m' Emm'. -apply recursion_wd with (Aeq := fun_eq Neq (@eq bool)). -apply lt_base_wd. -apply lt_step_wd. -assumption. +repeat red; intros; simpl. +apply recursion_wd; auto with *. +repeat red; auto. Qed. -Add Morphism def_ltb with signature Neq ==> Neq ==> (@eq bool) as def_ltb_wd. +Instance ltb_wd : Proper (N.eq ==> N.eq ==> Logic.eq) ltb. Proof. -intros; now apply lt_curry_wd. +unfold ltb. +intros n n' Hn m m' Hm. +apply f_equiv; auto with *. +apply recursion_wd; auto; [ apply ltb_prewd1 | apply ltb_prewd2 ]. Qed. -Theorem def_ltb_base : forall n : N, 0 << n = if_zero false true n. +Theorem ltb_base : forall n, 0 << n = if_zero false true n. Proof. -intro n; unfold def_ltb; now rewrite recursion_0. +intro n; unfold ltb; now rewrite recursion_0. Qed. -Theorem def_ltb_step : - forall m n : N, S m << n = recursion false (fun n' _ => m << n') n. +Theorem ltb_step : + forall m n, S m << n = recursion false (fun n' _ => m << n') n. Proof. -intros m n; unfold def_ltb. -pose proof - (@recursion_succ - (N -> bool) - (fun_eq Neq (@eq bool)) - (if_zero false true) - (fun _ f => fun n => recursion false (fun n' _ => f n') n) - lt_base_wd - lt_step_wd - m n n) as H. -now rewrite H. +intros m n; unfold ltb at 1. +apply f_equiv; auto with *. +rewrite recursion_succ by (apply ltb_prewd1||apply ltb_prewd2). +fold (ltb m). +repeat red; intros. apply recursion_wd; auto. +repeat red; intros; now apply ltb_wd. Qed. (* Above, we rewrite applications of function. Is it possible to rewrite functions themselves, i.e., rewrite (recursion lt_base lt_step (S n)) to lt_step n (recursion lt_base lt_step n)? *) -Theorem def_ltb_0 : forall n : N, n << 0 = false. +Theorem ltb_0 : forall n, n << 0 = false. Proof. cases n. -rewrite def_ltb_base; now rewrite if_zero_0. -intro n; rewrite def_ltb_step. now rewrite recursion_0. +rewrite ltb_base; now rewrite if_zero_0. +intro n; rewrite ltb_step. now rewrite recursion_0. Qed. -Theorem def_ltb_0_succ : forall n : N, 0 << S n = true. +Theorem ltb_0_succ : forall n, 0 << S n = true. Proof. -intro n; rewrite def_ltb_base; now rewrite if_zero_succ. +intro n; rewrite ltb_base; now rewrite if_zero_succ. Qed. -Theorem succ_def_ltb_mono : forall n m : N, (S n << S m) = (n << m). +Theorem succ_ltb_mono : forall n m, (S n << S m) = (n << m). Proof. intros n m. -rewrite def_ltb_step. rewrite (@recursion_succ bool (@eq bool)); try reflexivity. -unfold fun2_wd; intros; now apply def_ltb_wd. +rewrite ltb_step. rewrite recursion_succ; try reflexivity. +repeat red; intros; now apply ltb_wd. Qed. -Theorem def_ltb_lt : forall n m : N, n << m = true <-> n < m. +Theorem ltb_lt : forall n m, n << m = true <-> n < m. Proof. double_induct n m. cases m. -rewrite def_ltb_0. split; intro H; [discriminate H | false_hyp H nlt_0_r]. -intro n. rewrite def_ltb_0_succ. split; intro; [apply lt_0_succ | reflexivity]. -intro n. rewrite def_ltb_0. split; intro H; [discriminate | false_hyp H nlt_0_r]. -intros n m. rewrite succ_def_ltb_mono. now rewrite <- succ_lt_mono. +rewrite ltb_0. split; intro H; [discriminate H | false_hyp H nlt_0_r]. +intro n. rewrite ltb_0_succ. split; intro; [apply lt_0_succ | reflexivity]. +intro n. rewrite ltb_0. split; intro H; [discriminate | false_hyp H nlt_0_r]. +intros n m. rewrite succ_ltb_mono. now rewrite <- succ_lt_mono. +Qed. + +Theorem ltb_ge : forall n m, n << m = false <-> n >= m. +Proof. +intros. rewrite <- not_true_iff_false, ltb_lt. apply nlt_ge. Qed. -(* (*****************************************************) (** Even *) -Definition even (x : N) := recursion true (fun _ p => negb p) x. - -Lemma even_step_wd : fun2_wd Neq (@eq bool) (@eq bool) (fun x p => if p then false else true). -Proof. -unfold fun2_wd. -intros x x' Exx' b b' Ebb'. -unfold eq_bool; destruct b; destruct b'; now simpl. -Qed. +Definition even (x : N.t) := recursion true (fun _ p => negb p) x. -Add Morphism even with signature Neq ==> (@eq bool) as even_wd. +Instance even_wd : Proper (N.eq==>Logic.eq) even. Proof. -unfold even; intros. -apply recursion_wd with (A := bool) (Aeq := (@eq bool)). -now unfold eq_bool. -unfold fun2_eq. intros _ _ _ b b' Ebb'. unfold eq_bool; destruct b; destruct b'; now simpl. -assumption. +intros n n' Hn. unfold even. +apply recursion_wd; auto. +congruence. Qed. Theorem even_0 : even 0 = true. @@ -223,76 +199,281 @@ unfold even. now rewrite recursion_0. Qed. -Theorem even_succ : forall x : N, even (S x) = negb (even x). +Theorem even_succ : forall x, even (S x) = negb (even x). Proof. unfold even. -intro x; rewrite (recursion_succ (@eq bool)); try reflexivity. -unfold fun2_wd. -intros _ _ _ b b' Ebb'. destruct b; destruct b'; now simpl. +intro x; rewrite recursion_succ; try reflexivity. +congruence. Qed. (*****************************************************) (** Division by 2 *) -Definition half_aux (x : N) : N * N := - recursion (0, 0) (fun _ p => let (x1, x2) := p in ((S x2, x1))) x. +Local Notation "a <= b <= c" := (a<=b /\ b<=c). +Local Notation "a <= b < c" := (a<=b /\ b let (x1, x2) := p in (S x2, x1)) x. -Definition E2 := prod_rel Neq Neq. +Definition half (x : N.t) := snd (half_aux x). -Add Relation (prod N N) E2 -reflexivity proved by (prod_rel_refl N N Neq Neq E_equiv E_equiv) -symmetry proved by (prod_rel_sym N N Neq Neq E_equiv E_equiv) -transitivity proved by (prod_rel_trans N N Neq Neq E_equiv E_equiv) -as E2_rel. +Instance half_aux_wd : Proper (N.eq ==> N.eq*N.eq) half_aux. +Proof. +intros x x' Hx. unfold half_aux. +apply recursion_wd; auto with *. +intros y y' Hy (u,v) (u',v') (Hu,Hv). compute in *. +rewrite Hu, Hv; auto with *. +Qed. -Lemma half_step_wd: fun2_wd Neq E2 E2 (fun _ p => let (x1, x2) := p in ((S x2, x1))). +Instance half_wd : Proper (N.eq==>N.eq) half. Proof. -unfold fun2_wd, E2, prod_rel. -intros _ _ _ p1 p2 [H1 H2]. -destruct p1; destruct p2; simpl in *. -now split; [rewrite H2 |]. +intros x x' Hx. unfold half. rewrite Hx; auto with *. Qed. -Add Morphism half with signature Neq ==> Neq as half_wd. +Lemma half_aux_0 : half_aux 0 = (0,0). Proof. -unfold half. -assert (H: forall x y, x == y -> E2 (half_aux x) (half_aux y)). -intros x y Exy; unfold half_aux; apply recursion_wd with (Aeq := E2); unfold E2. -unfold E2. -unfold prod_rel; simpl; now split. -unfold fun2_eq, prod_rel; simpl. -intros _ _ _ p1 p2; destruct p1; destruct p2; simpl. -intros [H1 H2]; split; [rewrite H2 | assumption]. reflexivity. assumption. -unfold E2, prod_rel in H. intros x y Exy; apply H in Exy. -exact (proj2 Exy). +unfold half_aux. rewrite recursion_0; auto. Qed. +Lemma half_aux_succ : forall x, + half_aux (S x) = (S (snd (half_aux x)), fst (half_aux x)). +Proof. +intros. +remember (half_aux x) as h. +destruct h as (f,s); simpl in *. +unfold half_aux in *. +rewrite recursion_succ, <- Heqh; simpl; auto. +repeat red; intros; subst; auto. +Qed. + +Theorem half_aux_spec : forall n, + n == fst (half_aux n) + snd (half_aux n). +Proof. +apply induction. +intros x x' Hx. setoid_rewrite Hx; auto with *. +rewrite half_aux_0; simpl; rewrite add_0_l; auto with *. +intros. +rewrite half_aux_succ. simpl. +rewrite add_succ_l, add_comm; auto. +apply succ_wd; auto. +Qed. + +Theorem half_aux_spec2 : forall n, + fst (half_aux n) == snd (half_aux n) \/ + fst (half_aux n) == S (snd (half_aux n)). +Proof. +apply induction. +intros x x' Hx. setoid_rewrite Hx; auto with *. +rewrite half_aux_0; simpl. auto with *. +intros. +rewrite half_aux_succ; simpl. +destruct H; auto with *. +right; apply succ_wd; auto with *. +Qed. + +Theorem half_0 : half 0 == 0. +Proof. +unfold half. rewrite half_aux_0; simpl; auto with *. +Qed. + +Theorem half_1 : half 1 == 0. +Proof. +unfold half. rewrite half_aux_succ, half_aux_0; simpl; auto with *. +Qed. + +Theorem half_double : forall n, + n == 2 * half n \/ n == 1 + 2 * half n. +Proof. +intros. unfold half. +nzsimpl. +destruct (half_aux_spec2 n) as [H|H]; [left|right]. +rewrite <- H at 1. apply half_aux_spec. +rewrite <- add_succ_l. rewrite <- H at 1. apply half_aux_spec. +Qed. + +Theorem half_upper_bound : forall n, 2 * half n <= n. +Proof. +intros. +destruct (half_double n) as [E|E]; rewrite E at 2. +apply le_refl. +nzsimpl. +apply le_le_succ_r, le_refl. +Qed. + +Theorem half_lower_bound : forall n, n <= 1 + 2 * half n. +Proof. +intros. +destruct (half_double n) as [E|E]; rewrite E at 1. +nzsimpl. +apply le_le_succ_r, le_refl. +apply le_refl. +Qed. + +Theorem half_nz : forall n, 1 < n -> 0 < half n. +Proof. +intros n LT. +assert (LE : 0 <= half n) by apply le_0_l. +le_elim LE; auto. +destruct (half_double n) as [E|E]; + rewrite <- LE, mul_0_r, ?add_0_r in E; rewrite E in LT. +destruct (nlt_0_r _ LT). +rewrite <- succ_lt_mono in LT. +destruct (nlt_0_r _ LT). +Qed. + +Theorem half_decrease : forall n, 0 < n -> half n < n. +Proof. +intros n LT. +destruct (half_double n) as [E|E]; rewrite E at 2; + rewrite ?mul_succ_l, ?mul_0_l, ?add_0_l, ?add_assoc. +rewrite <- add_0_l at 1. +rewrite <- add_lt_mono_r. +assert (LE : 0 <= half n) by apply le_0_l. +le_elim LE; auto. +rewrite <- LE, mul_0_r in E. rewrite E in LT. destruct (nlt_0_r _ LT). +rewrite <- add_0_l at 1. +rewrite <- add_lt_mono_r. +rewrite add_succ_l. apply lt_0_succ. +Qed. + + +(*****************************************************) +(** Power *) + +Definition pow (n m : N.t) := recursion 1 (fun _ r => n*r) m. + +Local Infix "^^" := pow (at level 30, right associativity). + +Instance pow_prewd : + Proper (N.eq==>N.eq==>N.eq==>N.eq) (fun n _ r => n*r). +Proof. +intros n n' Hn x x' Hx y y' Hy. rewrite Hn, Hy; auto with *. +Qed. + +Instance pow_wd : Proper (N.eq==>N.eq==>N.eq) pow. +Proof. +intros n n' Hn m m' Hm. unfold pow. +apply recursion_wd; auto with *. +now apply pow_prewd. +Qed. + +Lemma pow_0 : forall n, n^^0 == 1. +Proof. +intros. unfold pow. rewrite recursion_0. auto with *. +Qed. + +Lemma pow_succ : forall n m, n^^(S m) == n*(n^^m). +Proof. +intros. unfold pow. rewrite recursion_succ; auto with *. +now apply pow_prewd. +Qed. + + (*****************************************************) (** Logarithm for the base 2 *) -Definition log (x : N) : N := +Definition log (x : N.t) : N.t := strong_rec 0 - (fun x g => - if (e x 0) then 0 - else if (e x 1) then 0 + (fun g x => + if x << 2 then 0 else S (g (half x))) x. -Add Morphism log with signature Neq ==> Neq as log_wd. +Instance log_prewd : + Proper ((N.eq==>N.eq)==>N.eq==>N.eq) + (fun g x => if x<<2 then 0 else S (g (half x))). +Proof. +intros g g' Hg n n' Hn. +rewrite Hn. +destruct (n' << 2); auto with *. +apply succ_wd. +apply Hg. rewrite Hn; auto with *. +Qed. + +Instance log_wd : Proper (N.eq==>N.eq) log. Proof. intros x x' Exx'. unfold log. -apply strong_rec_wd with (Aeq := Neq); try (reflexivity || assumption). -unfold fun2_eq. intros y y' Eyy' g g' Egg'. -assert (H : e y 0 = e y' 0); [now apply e_wd|]. -rewrite <- H; clear H. -assert (H : e y 1 = e y' 1); [now apply e_wd|]. -rewrite <- H; clear H. -assert (H : S (g (half y)) == S (g' (half y'))); -[apply succ_wd; apply Egg'; now apply half_wd|]. -now destruct (e y 0); destruct (e y 1). +apply strong_rec_wd; auto with *. +apply log_prewd. Qed. + +Lemma log_good_step : forall n h1 h2, + (forall m, m < n -> h1 m == h2 m) -> + (if n << 2 then 0 else S (h1 (half n))) == + (if n << 2 then 0 else S (h2 (half n))). +Proof. +intros n h1 h2 E. +destruct (n<<2) as [ ]_eqn:H. +auto with *. +apply succ_wd, E, half_decrease. +rewrite <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H. +apply lt_succ_l; auto. +Qed. +Hint Resolve log_good_step. + +Theorem log_init : forall n, n < 2 -> log n == 0. +Proof. +intros n Hn. unfold log. rewrite strong_rec_fixpoint; auto with *. +replace (n << 2) with true; auto with *. +symmetry. now rewrite ltb_lt. +Qed. + +Theorem log_step : forall n, 2 <= n -> log n == S (log (half n)). +Proof. +intros n Hn. unfold log. rewrite strong_rec_fixpoint; auto with *. +replace (n << 2) with false; auto with *. +symmetry. rewrite <- not_true_iff_false, ltb_lt, nlt_ge; auto. +Qed. + +Theorem pow2_log : forall n, 0 < n -> half n < 2^^(log n) <= n. +Proof. +intro n; generalize (le_refl n). set (k:=n) at -2. clearbody k. +revert k. pattern n. apply induction; clear n. +intros n n' Hn; setoid_rewrite Hn; auto with *. +intros k Hk1 Hk2. + le_elim Hk1. destruct (nlt_0_r _ Hk1). + rewrite Hk1 in Hk2. destruct (nlt_0_r _ Hk2). + +intros n IH k Hk1 Hk2. +destruct (lt_ge_cases k 2) as [LT|LE]. +(* base *) +rewrite log_init, pow_0 by auto. +rewrite <- le_succ_l in Hk2. +le_elim Hk2. +rewrite <- nle_gt, le_succ_l in LT. destruct LT; auto. +rewrite <- Hk2. +rewrite half_1; auto using lt_0_1, le_refl. +(* step *) +rewrite log_step, pow_succ by auto. +rewrite le_succ_l in LE. +destruct (IH (half k)) as (IH1,IH2). + rewrite <- lt_succ_r. apply lt_le_trans with k; auto. + now apply half_decrease. + apply half_nz; auto. +set (K:=2^^log (half k)) in *; clearbody K. +split. +rewrite <- le_succ_l in IH1. +apply mul_le_mono_l with (p:=2) in IH1. +eapply lt_le_trans; eauto. +nzsimpl. +rewrite lt_succ_r. +eapply le_trans; [ eapply half_lower_bound | ]. +nzsimpl; apply le_refl. +eapply le_trans; [ | eapply half_upper_bound ]. +apply mul_le_mono_l; auto. +Qed. + +(** Later: + +Theorem log_mul : forall n m, 0 < n -> 0 < m -> + log (n*m) == log n + log m. + +Theorem log_pow2 : forall n, log (2^^n) = n. + *) + End NdefOpsPropFunct. diff --git a/theories/Numbers/Natural/Abstract/NDiv.v b/theories/Numbers/Natural/Abstract/NDiv.v new file mode 100644 index 00000000..0cb5665a --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NDiv.v @@ -0,0 +1,239 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* a mod b < b. +End NDivSpecific. + +Module Type NDivSig := NAxiomsSig <+ DivMod <+ NZDivCommon <+ NDivSpecific. +Module Type NDivSig' := NAxiomsSig' <+ DivMod' <+ NZDivCommon <+ NDivSpecific. + +Module NDivPropFunct (Import N : NDivSig')(Import NP : NPropSig N). + +(** We benefit from what already exists for NZ *) + + Module ND <: NZDiv N. + Definition div := div. + Definition modulo := modulo. + Definition div_wd := div_wd. + Definition mod_wd := mod_wd. + Definition div_mod := div_mod. + Lemma mod_bound : forall a b, 0<=a -> 0 0 <= a mod b < b. + Proof. split. apply le_0_l. apply mod_upper_bound. order. Qed. + End ND. + Module Import NZDivP := NZDivPropFunct N NP ND. + + Ltac auto' := try rewrite <- neq_0_lt_0; auto using le_0_l. + +(** Let's now state again theorems, but without useless hypothesis. *) + +(** Uniqueness theorems *) + +Theorem div_mod_unique : + forall b q1 q2 r1 r2, r1 r2 + b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. +Proof. intros. apply div_mod_unique with b; auto'. Qed. + +Theorem div_unique: + forall a b q r, r a == b*q + r -> q == a/b. +Proof. intros; apply div_unique with r; auto'. Qed. + +Theorem mod_unique: + forall a b q r, r a == b*q + r -> r == a mod b. +Proof. intros. apply mod_unique with q; auto'. Qed. + +(** A division by itself returns 1 *) + +Lemma div_same : forall a, a~=0 -> a/a == 1. +Proof. intros. apply div_same; auto'. Qed. + +Lemma mod_same : forall a, a~=0 -> a mod a == 0. +Proof. intros. apply mod_same; auto'. Qed. + +(** A division of a small number by a bigger one yields zero. *) + +Theorem div_small: forall a b, a a/b == 0. +Proof. intros. apply div_small; auto'. Qed. + +(** Same situation, in term of modulo: *) + +Theorem mod_small: forall a b, a a mod b == a. +Proof. intros. apply mod_small; auto'. Qed. + +(** * Basic values of divisions and modulo. *) + +Lemma div_0_l: forall a, a~=0 -> 0/a == 0. +Proof. intros. apply div_0_l; auto'. Qed. + +Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0. +Proof. intros. apply mod_0_l; auto'. Qed. + +Lemma div_1_r: forall a, a/1 == a. +Proof. intros. apply div_1_r; auto'. Qed. + +Lemma mod_1_r: forall a, a mod 1 == 0. +Proof. intros. apply mod_1_r; auto'. Qed. + +Lemma div_1_l: forall a, 1 1/a == 0. +Proof. exact div_1_l. Qed. + +Lemma mod_1_l: forall a, 1 1 mod a == 1. +Proof. exact mod_1_l. Qed. + +Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. +Proof. intros. apply div_mul; auto'. Qed. + +Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. +Proof. intros. apply mod_mul; auto'. Qed. + + +(** * Order results about mod and div *) + +(** A modulo cannot grow beyond its starting point. *) + +Theorem mod_le: forall a b, b~=0 -> a mod b <= a. +Proof. intros. apply mod_le; auto'. Qed. + +Lemma div_str_pos : forall a b, 0 0 < a/b. +Proof. exact div_str_pos. Qed. + +Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> a (a mod b == a <-> a (0 b<=a). +Proof. intros. apply div_str_pos_iff; auto'. Qed. + + +(** As soon as the divisor is strictly greater than 1, + the division is strictly decreasing. *) + +Lemma div_lt : forall a b, 0 1 a/b < a. +Proof. exact div_lt. Qed. + +(** [le] is compatible with a positive division. *) + +Lemma div_le_mono : forall a b c, c~=0 -> a<=b -> a/c <= b/c. +Proof. intros. apply div_le_mono; auto'. Qed. + +Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a. +Proof. intros. apply mul_div_le; auto'. Qed. + +Lemma mul_succ_div_gt: forall a b, b~=0 -> a < b*(S (a/b)). +Proof. intros; apply mul_succ_div_gt; auto'. Qed. + +(** The previous inequality is exact iff the modulo is zero. *) + +Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). +Proof. intros. apply div_exact; auto'. Qed. + +(** Some additionnal inequalities about div. *) + +Theorem div_lt_upper_bound: + forall a b q, b~=0 -> a < b*q -> a/b < q. +Proof. intros. apply div_lt_upper_bound; auto'. Qed. + +Theorem div_le_upper_bound: + forall a b q, b~=0 -> a <= b*q -> a/b <= q. +Proof. intros; apply div_le_upper_bound; auto'. Qed. + +Theorem div_le_lower_bound: + forall a b q, b~=0 -> b*q <= a -> q <= a/b. +Proof. intros; apply div_le_lower_bound; auto'. Qed. + +(** A division respects opposite monotonicity for the divisor *) + +Lemma div_le_compat_l: forall p q r, 0 p/r <= p/q. +Proof. intros. apply div_le_compat_l. auto'. auto. Qed. + +(** * Relations between usual operations and mod and div *) + +Lemma mod_add : forall a b c, c~=0 -> + (a + b * c) mod c == a mod c. +Proof. intros. apply mod_add; auto'. Qed. + +Lemma div_add : forall a b c, c~=0 -> + (a + b * c) / c == a / c + b. +Proof. intros. apply div_add; auto'. Qed. + +Lemma div_add_l: forall a b c, b~=0 -> + (a * b + c) / b == a + c / b. +Proof. intros. apply div_add_l; auto'. Qed. + +(** Cancellations. *) + +Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> + (a*c)/(b*c) == a/b. +Proof. intros. apply div_mul_cancel_r; auto'. Qed. + +Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> + (c*a)/(c*b) == a/b. +Proof. intros. apply div_mul_cancel_l; auto'. Qed. + +Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> + (a*c) mod (b*c) == (a mod b) * c. +Proof. intros. apply mul_mod_distr_r; auto'. Qed. + +Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 -> + (c*a) mod (c*b) == c * (a mod b). +Proof. intros. apply mul_mod_distr_l; auto'. Qed. + +(** Operations modulo. *) + +Theorem mod_mod: forall a n, n~=0 -> + (a mod n) mod n == a mod n. +Proof. intros. apply mod_mod; auto'. Qed. + +Lemma mul_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)*b) mod n == (a*b) mod n. +Proof. intros. apply mul_mod_idemp_l; auto'. Qed. + +Lemma mul_mod_idemp_r : forall a b n, n~=0 -> + (a*(b mod n)) mod n == (a*b) mod n. +Proof. intros. apply mul_mod_idemp_r; auto'. Qed. + +Theorem mul_mod: forall a b n, n~=0 -> + (a * b) mod n == ((a mod n) * (b mod n)) mod n. +Proof. intros. apply mul_mod; auto'. Qed. + +Lemma add_mod_idemp_l : forall a b n, n~=0 -> + ((a mod n)+b) mod n == (a+b) mod n. +Proof. intros. apply add_mod_idemp_l; auto'. Qed. + +Lemma add_mod_idemp_r : forall a b n, n~=0 -> + (a+(b mod n)) mod n == (a+b) mod n. +Proof. intros. apply add_mod_idemp_r; auto'. Qed. + +Theorem add_mod: forall a b n, n~=0 -> + (a+b) mod n == (a mod n + b mod n) mod n. +Proof. intros. apply add_mod; auto'. Qed. + +Lemma div_div : forall a b c, b~=0 -> c~=0 -> + (a/b)/c == a/(b*c). +Proof. intros. apply div_div; auto'. Qed. + +(** A last inequality: *) + +Theorem div_mul_le: + forall a b c, b~=0 -> c*(a/b) <= (c*a)/b. +Proof. intros. apply div_mul_le; auto'. Qed. + +(** mod is related to divisibility *) + +Lemma mod_divides : forall a b, b~=0 -> + (a mod b == 0 <-> exists c, a == b*c). +Proof. intros. apply mod_divides; auto'. Qed. + +End NDivPropFunct. + diff --git a/theories/Numbers/Natural/Abstract/NIso.v b/theories/Numbers/Natural/Abstract/NIso.v index f6ccf3db..47bf38cb 100644 --- a/theories/Numbers/Natural/Abstract/NIso.v +++ b/theories/Numbers/Natural/Abstract/NIso.v @@ -8,51 +8,41 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NIso.v 10934 2008-05-15 21:58:20Z letouzey $ i*) +(*i $Id$ i*) Require Import NBase. -Module Homomorphism (NAxiomsMod1 NAxiomsMod2 : NAxiomsSig). +Module Homomorphism (N1 N2 : NAxiomsSig). -Module NBasePropMod2 := NBasePropFunct NAxiomsMod2. +Local Notation "n == m" := (N2.eq n m) (at level 70, no associativity). -Notation Local N1 := NAxiomsMod1.N. -Notation Local N2 := NAxiomsMod2.N. -Notation Local Eq1 := NAxiomsMod1.Neq. -Notation Local Eq2 := NAxiomsMod2.Neq. -Notation Local O1 := NAxiomsMod1.N0. -Notation Local O2 := NAxiomsMod2.N0. -Notation Local S1 := NAxiomsMod1.S. -Notation Local S2 := NAxiomsMod2.S. -Notation Local "n == m" := (Eq2 n m) (at level 70, no associativity). +Definition homomorphism (f : N1.t -> N2.t) : Prop := + f N1.zero == N2.zero /\ forall n, f (N1.succ n) == N2.succ (f n). -Definition homomorphism (f : N1 -> N2) : Prop := - f O1 == O2 /\ forall n : N1, f (S1 n) == S2 (f n). +Definition natural_isomorphism : N1.t -> N2.t := + N1.recursion N2.zero (fun (n : N1.t) (p : N2.t) => N2.succ p). -Definition natural_isomorphism : N1 -> N2 := - NAxiomsMod1.recursion O2 (fun (n : N1) (p : N2) => S2 p). - -Add Morphism natural_isomorphism with signature Eq1 ==> Eq2 as natural_isomorphism_wd. +Instance natural_isomorphism_wd : Proper (N1.eq ==> N2.eq) natural_isomorphism. Proof. unfold natural_isomorphism. intros n m Eqxy. -apply NAxiomsMod1.recursion_wd with (Aeq := Eq2). +apply N1.recursion_wd. reflexivity. -unfold fun2_eq. intros _ _ _ y' y'' H. now apply NBasePropMod2.succ_wd. +intros _ _ _ y' y'' H. now apply N2.succ_wd. assumption. Qed. -Theorem natural_isomorphism_0 : natural_isomorphism O1 == O2. +Theorem natural_isomorphism_0 : natural_isomorphism N1.zero == N2.zero. Proof. -unfold natural_isomorphism; now rewrite NAxiomsMod1.recursion_0. +unfold natural_isomorphism; now rewrite N1.recursion_0. Qed. Theorem natural_isomorphism_succ : - forall n : N1, natural_isomorphism (S1 n) == S2 (natural_isomorphism n). + forall n : N1.t, natural_isomorphism (N1.succ n) == N2.succ (natural_isomorphism n). Proof. unfold natural_isomorphism. -intro n. now rewrite (@NAxiomsMod1.recursion_succ N2 NAxiomsMod2.Neq) ; -[ | | unfold fun2_wd; intros; apply NBasePropMod2.succ_wd]. +intro n. rewrite N1.recursion_succ; auto with *. +repeat red; intros. apply N2.succ_wd; auto. Qed. Theorem hom_nat_iso : homomorphism natural_isomorphism. @@ -63,23 +53,20 @@ Qed. End Homomorphism. -Module Inverse (NAxiomsMod1 NAxiomsMod2 : NAxiomsSig). +Module Inverse (N1 N2 : NAxiomsSig). -Module Import NBasePropMod1 := NBasePropFunct NAxiomsMod1. +Module Import NBasePropMod1 := NBasePropFunct N1. (* This makes the tactic induct available. Since it is taken from (NBasePropFunct NAxiomsMod1), it refers to induction on N1. *) -Module Hom12 := Homomorphism NAxiomsMod1 NAxiomsMod2. -Module Hom21 := Homomorphism NAxiomsMod2 NAxiomsMod1. - -Notation Local N1 := NAxiomsMod1.N. -Notation Local N2 := NAxiomsMod2.N. -Notation Local h12 := Hom12.natural_isomorphism. -Notation Local h21 := Hom21.natural_isomorphism. +Module Hom12 := Homomorphism N1 N2. +Module Hom21 := Homomorphism N2 N1. -Notation Local "n == m" := (NAxiomsMod1.Neq n m) (at level 70, no associativity). +Local Notation h12 := Hom12.natural_isomorphism. +Local Notation h21 := Hom21.natural_isomorphism. +Local Notation "n == m" := (N1.eq n m) (at level 70, no associativity). -Lemma inverse_nat_iso : forall n : N1, h21 (h12 n) == n. +Lemma inverse_nat_iso : forall n : N1.t, h21 (h12 n) == n. Proof. induct n. now rewrite Hom12.natural_isomorphism_0, Hom21.natural_isomorphism_0. @@ -89,25 +76,20 @@ Qed. End Inverse. -Module Isomorphism (NAxiomsMod1 NAxiomsMod2 : NAxiomsSig). - -Module Hom12 := Homomorphism NAxiomsMod1 NAxiomsMod2. -Module Hom21 := Homomorphism NAxiomsMod2 NAxiomsMod1. +Module Isomorphism (N1 N2 : NAxiomsSig). -Module Inverse12 := Inverse NAxiomsMod1 NAxiomsMod2. -Module Inverse21 := Inverse NAxiomsMod2 NAxiomsMod1. +Module Hom12 := Homomorphism N1 N2. +Module Hom21 := Homomorphism N2 N1. +Module Inverse12 := Inverse N1 N2. +Module Inverse21 := Inverse N2 N1. -Notation Local N1 := NAxiomsMod1.N. -Notation Local N2 := NAxiomsMod2.N. -Notation Local Eq1 := NAxiomsMod1.Neq. -Notation Local Eq2 := NAxiomsMod2.Neq. -Notation Local h12 := Hom12.natural_isomorphism. -Notation Local h21 := Hom21.natural_isomorphism. +Local Notation h12 := Hom12.natural_isomorphism. +Local Notation h21 := Hom21.natural_isomorphism. -Definition isomorphism (f1 : N1 -> N2) (f2 : N2 -> N1) : Prop := +Definition isomorphism (f1 : N1.t -> N2.t) (f2 : N2.t -> N1.t) : Prop := Hom12.homomorphism f1 /\ Hom21.homomorphism f2 /\ - forall n : N1, Eq1 (f2 (f1 n)) n /\ - forall n : N2, Eq2 (f1 (f2 n)) n. + forall n, N1.eq (f2 (f1 n)) n /\ + forall n, N2.eq (f1 (f2 n)) n. Theorem iso_nat_iso : isomorphism h12 h21. Proof. diff --git a/theories/Numbers/Natural/Abstract/NMul.v b/theories/Numbers/Natural/Abstract/NMul.v deleted file mode 100644 index 0b00f689..00000000 --- a/theories/Numbers/Natural/Abstract/NMul.v +++ /dev/null @@ -1,87 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* forall m1 m2 : N, m1 == m2 -> n1 * m1 == n2 * m2. -Proof NZmul_wd. - -Theorem mul_0_l : forall n : N, 0 * n == 0. -Proof NZmul_0_l. - -Theorem mul_succ_l : forall n m : N, (S n) * m == n * m + m. -Proof NZmul_succ_l. - -(** Theorems that are valid for both natural numbers and integers *) - -Theorem mul_0_r : forall n, n * 0 == 0. -Proof NZmul_0_r. - -Theorem mul_succ_r : forall n m, n * (S m) == n * m + n. -Proof NZmul_succ_r. - -Theorem mul_comm : forall n m : N, n * m == m * n. -Proof NZmul_comm. - -Theorem mul_add_distr_r : forall n m p : N, (n + m) * p == n * p + m * p. -Proof NZmul_add_distr_r. - -Theorem mul_add_distr_l : forall n m p : N, n * (m + p) == n * m + n * p. -Proof NZmul_add_distr_l. - -Theorem mul_assoc : forall n m p : N, n * (m * p) == (n * m) * p. -Proof NZmul_assoc. - -Theorem mul_1_l : forall n : N, 1 * n == n. -Proof NZmul_1_l. - -Theorem mul_1_r : forall n : N, n * 1 == n. -Proof NZmul_1_r. - -(* Theorems that cannot be proved in NZMul *) - -(* In proving the correctness of the definition of multiplication on -integers constructed from pairs of natural numbers, we'll need the -following fact about natural numbers: - -a * n + u == a * m + v -> n + m' == n' + m -> a * n' + u = a * m' + v - -Here n + m' == n' + m expresses equality of integers (n, m) and (n', m'), -since a pair (a, b) of natural numbers represents the integer a - b. On -integers, the formula above could be proved by moving a * m to the left, -factoring out a and replacing n - m by n' - m'. However, the formula is -required in the process of constructing integers, so it has to be proved -for natural numbers, where terms cannot be moved from one side of an -equation to the other. The proof uses the cancellation laws add_cancel_l -and add_cancel_r. *) - -Theorem add_mul_repl_pair : forall a n m n' m' u v : N, - a * n + u == a * m + v -> n + m' == n' + m -> a * n' + u == a * m' + v. -Proof. -intros a n m n' m' u v H1 H2. -apply (@NZmul_wd a a) in H2; [| reflexivity]. -do 2 rewrite mul_add_distr_l in H2. symmetry in H2. -pose proof (NZadd_wd _ _ H1 _ _ H2) as H3. -rewrite (add_shuffle1 (a * m)), (add_comm (a * m) (a * n)) in H3. -do 2 rewrite <- add_assoc in H3. apply -> add_cancel_l in H3. -rewrite (add_assoc u), (add_comm (a * m)) in H3. -apply -> add_cancel_r in H3. -now rewrite (add_comm (a * n') u), (add_comm (a * m') v). -Qed. - -End NMulPropFunct. - diff --git a/theories/Numbers/Natural/Abstract/NMulOrder.v b/theories/Numbers/Natural/Abstract/NMulOrder.v index aa21fb50..a2162b13 100644 --- a/theories/Numbers/Natural/Abstract/NMulOrder.v +++ b/theories/Numbers/Natural/Abstract/NMulOrder.v @@ -8,122 +8,71 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NMulOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) Require Export NAddOrder. -Module NMulOrderPropFunct (Import NAxiomsMod : NAxiomsSig). -Module Export NAddOrderPropMod := NAddOrderPropFunct NAxiomsMod. -Open Local Scope NatScope. +Module NMulOrderPropFunct (Import N : NAxiomsSig'). +Include NAddOrderPropFunct N. -Theorem mul_lt_pred : - forall p q n m : N, S p == q -> (p * n < p * m <-> q * n + m < q * m + n). -Proof NZmul_lt_pred. +(** Theorems that are either not valid on Z or have different proofs + on N and Z *) -Theorem mul_lt_mono_pos_l : forall p n m : N, 0 < p -> (n < m <-> p * n < p * m). -Proof NZmul_lt_mono_pos_l. - -Theorem mul_lt_mono_pos_r : forall p n m : N, 0 < p -> (n < m <-> n * p < m * p). -Proof NZmul_lt_mono_pos_r. - -Theorem mul_cancel_l : forall n m p : N, p ~= 0 -> (p * n == p * m <-> n == m). -Proof NZmul_cancel_l. - -Theorem mul_cancel_r : forall n m p : N, p ~= 0 -> (n * p == m * p <-> n == m). -Proof NZmul_cancel_r. - -Theorem mul_id_l : forall n m : N, m ~= 0 -> (n * m == m <-> n == 1). -Proof NZmul_id_l. - -Theorem mul_id_r : forall n m : N, n ~= 0 -> (n * m == n <-> m == 1). -Proof NZmul_id_r. - -Theorem mul_le_mono_pos_l : forall n m p : N, 0 < p -> (n <= m <-> p * n <= p * m). -Proof NZmul_le_mono_pos_l. - -Theorem mul_le_mono_pos_r : forall n m p : N, 0 < p -> (n <= m <-> n * p <= m * p). -Proof NZmul_le_mono_pos_r. - -Theorem mul_pos_pos : forall n m : N, 0 < n -> 0 < m -> 0 < n * m. -Proof NZmul_pos_pos. - -Theorem lt_1_mul_pos : forall n m : N, 1 < n -> 0 < m -> 1 < n * m. -Proof NZlt_1_mul_pos. - -Theorem eq_mul_0 : forall n m : N, n * m == 0 <-> n == 0 \/ m == 0. -Proof NZeq_mul_0. - -Theorem neq_mul_0 : forall n m : N, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. -Proof NZneq_mul_0. - -Theorem eq_square_0 : forall n : N, n * n == 0 <-> n == 0. -Proof NZeq_square_0. - -Theorem eq_mul_0_l : forall n m : N, n * m == 0 -> m ~= 0 -> n == 0. -Proof NZeq_mul_0_l. - -Theorem eq_mul_0_r : forall n m : N, n * m == 0 -> n ~= 0 -> m == 0. -Proof NZeq_mul_0_r. - -Theorem square_lt_mono : forall n m : N, n < m <-> n * n < m * m. +Theorem square_lt_mono : forall n m, n < m <-> n * n < m * m. Proof. intros n m; split; intro; -[apply NZsquare_lt_mono_nonneg | apply NZsquare_lt_simpl_nonneg]; +[apply square_lt_mono_nonneg | apply square_lt_simpl_nonneg]; try assumption; apply le_0_l. Qed. -Theorem square_le_mono : forall n m : N, n <= m <-> n * n <= m * m. +Theorem square_le_mono : forall n m, n <= m <-> n * n <= m * m. Proof. intros n m; split; intro; -[apply NZsquare_le_mono_nonneg | apply NZsquare_le_simpl_nonneg]; +[apply square_le_mono_nonneg | apply square_le_simpl_nonneg]; try assumption; apply le_0_l. Qed. -Theorem mul_2_mono_l : forall n m : N, n < m -> 1 + (1 + 1) * n < (1 + 1) * m. -Proof NZmul_2_mono_l. - -(* Theorems that are either not valid on Z or have different proofs on N and Z *) - -Theorem mul_le_mono_l : forall n m p : N, n <= m -> p * n <= p * m. +Theorem mul_le_mono_l : forall n m p, n <= m -> p * n <= p * m. Proof. -intros; apply NZmul_le_mono_nonneg_l. apply le_0_l. assumption. +intros; apply mul_le_mono_nonneg_l. apply le_0_l. assumption. Qed. -Theorem mul_le_mono_r : forall n m p : N, n <= m -> n * p <= m * p. +Theorem mul_le_mono_r : forall n m p, n <= m -> n * p <= m * p. Proof. -intros; apply NZmul_le_mono_nonneg_r. apply le_0_l. assumption. +intros; apply mul_le_mono_nonneg_r. apply le_0_l. assumption. Qed. -Theorem mul_lt_mono : forall n m p q : N, n < m -> p < q -> n * p < m * q. +Theorem mul_lt_mono : forall n m p q, n < m -> p < q -> n * p < m * q. Proof. -intros; apply NZmul_lt_mono_nonneg; try assumption; apply le_0_l. +intros; apply mul_lt_mono_nonneg; try assumption; apply le_0_l. Qed. -Theorem mul_le_mono : forall n m p q : N, n <= m -> p <= q -> n * p <= m * q. +Theorem mul_le_mono : forall n m p q, n <= m -> p <= q -> n * p <= m * q. Proof. -intros; apply NZmul_le_mono_nonneg; try assumption; apply le_0_l. +intros; apply mul_le_mono_nonneg; try assumption; apply le_0_l. Qed. -Theorem lt_0_mul : forall n m : N, n * m > 0 <-> n > 0 /\ m > 0. +Theorem lt_0_mul' : forall n m, n * m > 0 <-> n > 0 /\ m > 0. Proof. intros n m; split; [intro H | intros [H1 H2]]. -apply -> NZlt_0_mul in H. destruct H as [[H1 H2] | [H1 H2]]. now split. false_hyp H1 nlt_0_r. -now apply NZmul_pos_pos. +apply -> lt_0_mul in H. destruct H as [[H1 H2] | [H1 H2]]. now split. + false_hyp H1 nlt_0_r. +now apply mul_pos_pos. Qed. -Notation mul_pos := lt_0_mul (only parsing). +Notation mul_pos := lt_0_mul' (only parsing). -Theorem eq_mul_1 : forall n m : N, n * m == 1 <-> n == 1 /\ m == 1. +Theorem eq_mul_1 : forall n m, n * m == 1 <-> n == 1 /\ m == 1. Proof. intros n m. split; [| intros [H1 H2]; now rewrite H1, H2, mul_1_l]. -intro H; destruct (NZlt_trichotomy n 1) as [H1 | [H1 | H1]]. +intro H; destruct (lt_trichotomy n 1) as [H1 | [H1 | H1]]. apply -> lt_1_r in H1. rewrite H1, mul_0_l in H. false_hyp H neq_0_succ. rewrite H1, mul_1_l in H; now split. destruct (eq_0_gt_0_cases m) as [H2 | H2]. rewrite H2, mul_0_r in H; false_hyp H neq_0_succ. apply -> (mul_lt_mono_pos_r m) in H1; [| assumption]. rewrite mul_1_l in H1. -assert (H3 : 1 < n * m) by now apply (lt_1_l 0 m). +assert (H3 : 1 < n * m) by now apply (lt_1_l m). rewrite H in H3; false_hyp H3 lt_irrefl. Qed. diff --git a/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v index 15aed7ab..090c02ec 100644 --- a/theories/Numbers/Natural/Abstract/NOrder.v +++ b/theories/Numbers/Natural/Abstract/NOrder.v @@ -8,355 +8,62 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NOrder.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id$ i*) -Require Export NMul. +Require Export NAdd. -Module NOrderPropFunct (Import NAxiomsMod : NAxiomsSig). -Module Export NMulPropMod := NMulPropFunct NAxiomsMod. -Open Local Scope NatScope. +Module NOrderPropFunct (Import N : NAxiomsSig'). +Include NAddPropFunct N. -(* The tactics le_less, le_equal and le_elim are inherited from NZOrder.v *) - -(* Axioms *) - -Theorem lt_wd : - forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> (n1 < m1 <-> n2 < m2). -Proof NZlt_wd. - -Theorem le_wd : - forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> (n1 <= m1 <-> n2 <= m2). -Proof NZle_wd. - -Theorem min_wd : - forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> min n1 m1 == min n2 m2. -Proof NZmin_wd. - -Theorem max_wd : - forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> max n1 m1 == max n2 m2. -Proof NZmax_wd. - -Theorem lt_eq_cases : forall n m : N, n <= m <-> n < m \/ n == m. -Proof NZlt_eq_cases. - -Theorem lt_irrefl : forall n : N, ~ n < n. -Proof NZlt_irrefl. - -Theorem lt_succ_r : forall n m : N, n < S m <-> n <= m. -Proof NZlt_succ_r. - -Theorem min_l : forall n m : N, n <= m -> min n m == n. -Proof NZmin_l. - -Theorem min_r : forall n m : N, m <= n -> min n m == m. -Proof NZmin_r. - -Theorem max_l : forall n m : N, m <= n -> max n m == n. -Proof NZmax_l. - -Theorem max_r : forall n m : N, n <= m -> max n m == m. -Proof NZmax_r. - -(* Renaming theorems from NZOrder.v *) - -Theorem lt_le_incl : forall n m : N, n < m -> n <= m. -Proof NZlt_le_incl. - -Theorem eq_le_incl : forall n m : N, n == m -> n <= m. -Proof NZeq_le_incl. - -Theorem lt_neq : forall n m : N, n < m -> n ~= m. -Proof NZlt_neq. - -Theorem le_neq : forall n m : N, n < m <-> n <= m /\ n ~= m. -Proof NZle_neq. - -Theorem le_refl : forall n : N, n <= n. -Proof NZle_refl. - -Theorem lt_succ_diag_r : forall n : N, n < S n. -Proof NZlt_succ_diag_r. - -Theorem le_succ_diag_r : forall n : N, n <= S n. -Proof NZle_succ_diag_r. - -Theorem lt_0_1 : 0 < 1. -Proof NZlt_0_1. - -Theorem le_0_1 : 0 <= 1. -Proof NZle_0_1. - -Theorem lt_lt_succ_r : forall n m : N, n < m -> n < S m. -Proof NZlt_lt_succ_r. - -Theorem le_le_succ_r : forall n m : N, n <= m -> n <= S m. -Proof NZle_le_succ_r. - -Theorem le_succ_r : forall n m : N, n <= S m <-> n <= m \/ n == S m. -Proof NZle_succ_r. - -Theorem neq_succ_diag_l : forall n : N, S n ~= n. -Proof NZneq_succ_diag_l. - -Theorem neq_succ_diag_r : forall n : N, n ~= S n. -Proof NZneq_succ_diag_r. - -Theorem nlt_succ_diag_l : forall n : N, ~ S n < n. -Proof NZnlt_succ_diag_l. - -Theorem nle_succ_diag_l : forall n : N, ~ S n <= n. -Proof NZnle_succ_diag_l. - -Theorem le_succ_l : forall n m : N, S n <= m <-> n < m. -Proof NZle_succ_l. - -Theorem lt_succ_l : forall n m : N, S n < m -> n < m. -Proof NZlt_succ_l. - -Theorem succ_lt_mono : forall n m : N, n < m <-> S n < S m. -Proof NZsucc_lt_mono. - -Theorem succ_le_mono : forall n m : N, n <= m <-> S n <= S m. -Proof NZsucc_le_mono. - -Theorem lt_asymm : forall n m : N, n < m -> ~ m < n. -Proof NZlt_asymm. - -Notation lt_ngt := lt_asymm (only parsing). - -Theorem lt_trans : forall n m p : N, n < m -> m < p -> n < p. -Proof NZlt_trans. - -Theorem le_trans : forall n m p : N, n <= m -> m <= p -> n <= p. -Proof NZle_trans. - -Theorem le_lt_trans : forall n m p : N, n <= m -> m < p -> n < p. -Proof NZle_lt_trans. - -Theorem lt_le_trans : forall n m p : N, n < m -> m <= p -> n < p. -Proof NZlt_le_trans. - -Theorem le_antisymm : forall n m : N, n <= m -> m <= n -> n == m. -Proof NZle_antisymm. - -(** Trichotomy, decidability, and double negation elimination *) - -Theorem lt_trichotomy : forall n m : N, n < m \/ n == m \/ m < n. -Proof NZlt_trichotomy. - -Notation lt_eq_gt_cases := lt_trichotomy (only parsing). - -Theorem lt_gt_cases : forall n m : N, n ~= m <-> n < m \/ n > m. -Proof NZlt_gt_cases. - -Theorem le_gt_cases : forall n m : N, n <= m \/ n > m. -Proof NZle_gt_cases. - -Theorem lt_ge_cases : forall n m : N, n < m \/ n >= m. -Proof NZlt_ge_cases. - -Theorem le_ge_cases : forall n m : N, n <= m \/ n >= m. -Proof NZle_ge_cases. - -Theorem le_ngt : forall n m : N, n <= m <-> ~ n > m. -Proof NZle_ngt. - -Theorem nlt_ge : forall n m : N, ~ n < m <-> n >= m. -Proof NZnlt_ge. - -Theorem lt_dec : forall n m : N, decidable (n < m). -Proof NZlt_dec. - -Theorem lt_dne : forall n m : N, ~ ~ n < m <-> n < m. -Proof NZlt_dne. - -Theorem nle_gt : forall n m : N, ~ n <= m <-> n > m. -Proof NZnle_gt. - -Theorem lt_nge : forall n m : N, n < m <-> ~ n >= m. -Proof NZlt_nge. - -Theorem le_dec : forall n m : N, decidable (n <= m). -Proof NZle_dec. - -Theorem le_dne : forall n m : N, ~ ~ n <= m <-> n <= m. -Proof NZle_dne. - -Theorem nlt_succ_r : forall n m : N, ~ m < S n <-> n < m. -Proof NZnlt_succ_r. - -Theorem lt_exists_pred : - forall z n : N, z < n -> exists k : N, n == S k /\ z <= k. -Proof NZlt_exists_pred. - -Theorem lt_succ_iter_r : - forall (n : nat) (m : N), m < NZsucc_iter (Datatypes.S n) m. -Proof NZlt_succ_iter_r. - -Theorem neq_succ_iter_l : - forall (n : nat) (m : N), NZsucc_iter (Datatypes.S n) m ~= m. -Proof NZneq_succ_iter_l. - -(** Stronger variant of induction with assumptions n >= 0 (n < 0) -in the induction step *) - -Theorem right_induction : - forall A : N -> Prop, predicate_wd Neq A -> - forall z : N, A z -> - (forall n : N, z <= n -> A n -> A (S n)) -> - forall n : N, z <= n -> A n. -Proof NZright_induction. - -Theorem left_induction : - forall A : N -> Prop, predicate_wd Neq A -> - forall z : N, A z -> - (forall n : N, n < z -> A (S n) -> A n) -> - forall n : N, n <= z -> A n. -Proof NZleft_induction. - -Theorem right_induction' : - forall A : N -> Prop, predicate_wd Neq A -> - forall z : N, - (forall n : N, n <= z -> A n) -> - (forall n : N, z <= n -> A n -> A (S n)) -> - forall n : N, A n. -Proof NZright_induction'. - -Theorem left_induction' : - forall A : N -> Prop, predicate_wd Neq A -> - forall z : N, - (forall n : N, z <= n -> A n) -> - (forall n : N, n < z -> A (S n) -> A n) -> - forall n : N, A n. -Proof NZleft_induction'. - -Theorem strong_right_induction : - forall A : N -> Prop, predicate_wd Neq A -> - forall z : N, - (forall n : N, z <= n -> (forall m : N, z <= m -> m < n -> A m) -> A n) -> - forall n : N, z <= n -> A n. -Proof NZstrong_right_induction. - -Theorem strong_left_induction : - forall A : N -> Prop, predicate_wd Neq A -> - forall z : N, - (forall n : N, n <= z -> (forall m : N, m <= z -> S n <= m -> A m) -> A n) -> - forall n : N, n <= z -> A n. -Proof NZstrong_left_induction. - -Theorem strong_right_induction' : - forall A : N -> Prop, predicate_wd Neq A -> - forall z : N, - (forall n : N, n <= z -> A n) -> - (forall n : N, z <= n -> (forall m : N, z <= m -> m < n -> A m) -> A n) -> - forall n : N, A n. -Proof NZstrong_right_induction'. - -Theorem strong_left_induction' : - forall A : N -> Prop, predicate_wd Neq A -> - forall z : N, - (forall n : N, z <= n -> A n) -> - (forall n : N, n <= z -> (forall m : N, m <= z -> S n <= m -> A m) -> A n) -> - forall n : N, A n. -Proof NZstrong_left_induction'. - -Theorem order_induction : - forall A : N -> Prop, predicate_wd Neq A -> - forall z : N, A z -> - (forall n : N, z <= n -> A n -> A (S n)) -> - (forall n : N, n < z -> A (S n) -> A n) -> - forall n : N, A n. -Proof NZorder_induction. - -Theorem order_induction' : - forall A : N -> Prop, predicate_wd Neq A -> - forall z : N, A z -> - (forall n : N, z <= n -> A n -> A (S n)) -> - (forall n : N, n <= z -> A n -> A (P n)) -> - forall n : N, A n. -Proof NZorder_induction'. - -(* We don't need order_induction_0 and order_induction'_0 (see NZOrder and -ZOrder) since they boil down to regular induction *) - -(** Elimintation principle for < *) - -Theorem lt_ind : - forall A : N -> Prop, predicate_wd Neq A -> - forall n : N, - A (S n) -> - (forall m : N, n < m -> A m -> A (S m)) -> - forall m : N, n < m -> A m. -Proof NZlt_ind. - -(** Elimintation principle for <= *) - -Theorem le_ind : - forall A : N -> Prop, predicate_wd Neq A -> - forall n : N, - A n -> - (forall m : N, n <= m -> A m -> A (S m)) -> - forall m : N, n <= m -> A m. -Proof NZle_ind. - -(** Well-founded relations *) - -Theorem lt_wf : forall z : N, well_founded (fun n m : N => z <= n /\ n < m). -Proof NZlt_wf. - -Theorem gt_wf : forall z : N, well_founded (fun n m : N => m < n /\ n <= z). -Proof NZgt_wf. +(* Theorems that are true for natural numbers but not for integers *) Theorem lt_wf_0 : well_founded lt. Proof. -setoid_replace lt with (fun n m : N => 0 <= n /\ n < m) - using relation (@relations_eq N N). +setoid_replace lt with (fun n m => 0 <= n /\ n < m). apply lt_wf. intros x y; split. intro H; split; [apply le_0_l | assumption]. now intros [_ H]. Defined. -(* Theorems that are true for natural numbers but not for integers *) - (* "le_0_l : forall n : N, 0 <= n" was proved in NBase.v *) -Theorem nlt_0_r : forall n : N, ~ n < 0. +Theorem nlt_0_r : forall n, ~ n < 0. Proof. intro n; apply -> le_ngt. apply le_0_l. Qed. -Theorem nle_succ_0 : forall n : N, ~ (S n <= 0). +Theorem nle_succ_0 : forall n, ~ (S n <= 0). Proof. intros n H; apply -> le_succ_l in H; false_hyp H nlt_0_r. Qed. -Theorem le_0_r : forall n : N, n <= 0 <-> n == 0. +Theorem le_0_r : forall n, n <= 0 <-> n == 0. Proof. intros n; split; intro H. le_elim H; [false_hyp H nlt_0_r | assumption]. now apply eq_le_incl. Qed. -Theorem lt_0_succ : forall n : N, 0 < S n. +Theorem lt_0_succ : forall n, 0 < S n. Proof. induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r]. Qed. -Theorem neq_0_lt_0 : forall n : N, n ~= 0 <-> 0 < n. +Theorem neq_0_lt_0 : forall n, n ~= 0 <-> 0 < n. Proof. cases n. split; intro H; [now elim H | intro; now apply lt_irrefl with 0]. intro n; split; intro H; [apply lt_0_succ | apply neq_succ_0]. Qed. -Theorem eq_0_gt_0_cases : forall n : N, n == 0 \/ 0 < n. +Theorem eq_0_gt_0_cases : forall n, n == 0 \/ 0 < n. Proof. cases n. now left. intro; right; apply lt_0_succ. Qed. -Theorem zero_one : forall n : N, n == 0 \/ n == 1 \/ 1 < n. +Theorem zero_one : forall n, n == 0 \/ n == 1 \/ 1 < n. Proof. induct n. now left. cases n. intros; right; now left. @@ -366,7 +73,7 @@ right; right. rewrite H. apply lt_succ_diag_r. right; right. now apply lt_lt_succ_r. Qed. -Theorem lt_1_r : forall n : N, n < 1 <-> n == 0. +Theorem lt_1_r : forall n, n < 1 <-> n == 0. Proof. cases n. split; intro; [reflexivity | apply lt_succ_diag_r]. @@ -374,7 +81,7 @@ intros n. rewrite <- succ_lt_mono. split; intro H; [false_hyp H nlt_0_r | false_hyp H neq_succ_0]. Qed. -Theorem le_1_r : forall n : N, n <= 1 <-> n == 0 \/ n == 1. +Theorem le_1_r : forall n, n <= 1 <-> n == 0 \/ n == 1. Proof. cases n. split; intro; [now left | apply le_succ_diag_r]. @@ -382,36 +89,30 @@ intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd. split; [intro; now right | intros [H | H]; [false_hyp H neq_succ_0 | assumption]]. Qed. -Theorem lt_lt_0 : forall n m : N, n < m -> 0 < m. +Theorem lt_lt_0 : forall n m, n < m -> 0 < m. Proof. intros n m; induct n. trivial. intros n IH H. apply IH; now apply lt_succ_l. Qed. -Theorem lt_1_l : forall n m p : N, n < m -> m < p -> 1 < p. +Theorem lt_1_l' : forall n m p, n < m -> m < p -> 1 < p. Proof. -intros n m p H1 H2. -apply le_lt_trans with m. apply <- le_succ_l. apply le_lt_trans with n. -apply le_0_l. assumption. assumption. +intros. apply lt_1_l with m; auto. +apply le_lt_trans with n; auto. now apply le_0_l. Qed. (** Elimination principlies for < and <= for relations *) Section RelElim. -(* FIXME: Variable R : relation N. -- does not work *) - -Variable R : N -> N -> Prop. -Hypothesis R_wd : relation_wd Neq Neq R. - -Add Morphism R with signature Neq ==> Neq ==> iff as R_morph2. -Proof. apply R_wd. Qed. +Variable R : relation N.t. +Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R. Theorem le_ind_rel : - (forall m : N, R 0 m) -> - (forall n m : N, n <= m -> R n m -> R (S n) (S m)) -> - forall n m : N, n <= m -> R n m. + (forall m, R 0 m) -> + (forall n m, n <= m -> R n m -> R (S n) (S m)) -> + forall n m, n <= m -> R n m. Proof. intros Base Step; induct n. intros; apply Base. @@ -422,9 +123,9 @@ intros k H1 H2. apply -> le_succ_l in H1. apply lt_le_incl in H1. auto. Qed. Theorem lt_ind_rel : - (forall m : N, R 0 (S m)) -> - (forall n m : N, n < m -> R n m -> R (S n) (S m)) -> - forall n m : N, n < m -> R n m. + (forall m, R 0 (S m)) -> + (forall n m, n < m -> R n m -> R (S n) (S m)) -> + forall n m, n < m -> R n m. Proof. intros Base Step; induct n. intros m H. apply lt_exists_pred in H; destruct H as [m' [H _]]. @@ -439,61 +140,64 @@ End RelElim. (** Predecessor and order *) -Theorem succ_pred_pos : forall n : N, 0 < n -> S (P n) == n. +Theorem succ_pred_pos : forall n, 0 < n -> S (P n) == n. Proof. intros n H; apply succ_pred; intro H1; rewrite H1 in H. false_hyp H lt_irrefl. Qed. -Theorem le_pred_l : forall n : N, P n <= n. +Theorem le_pred_l : forall n, P n <= n. Proof. cases n. rewrite pred_0; now apply eq_le_incl. intros; rewrite pred_succ; apply le_succ_diag_r. Qed. -Theorem lt_pred_l : forall n : N, n ~= 0 -> P n < n. +Theorem lt_pred_l : forall n, n ~= 0 -> P n < n. Proof. cases n. -intro H; elimtype False; now apply H. +intro H; exfalso; now apply H. intros; rewrite pred_succ; apply lt_succ_diag_r. Qed. -Theorem le_le_pred : forall n m : N, n <= m -> P n <= m. +Theorem le_le_pred : forall n m, n <= m -> P n <= m. Proof. intros n m H; apply le_trans with n. apply le_pred_l. assumption. Qed. -Theorem lt_lt_pred : forall n m : N, n < m -> P n < m. +Theorem lt_lt_pred : forall n m, n < m -> P n < m. Proof. intros n m H; apply le_lt_trans with n. apply le_pred_l. assumption. Qed. -Theorem lt_le_pred : forall n m : N, n < m -> n <= P m. (* Converse is false for n == m == 0 *) +Theorem lt_le_pred : forall n m, n < m -> n <= P m. + (* Converse is false for n == m == 0 *) Proof. intro n; cases m. intro H; false_hyp H nlt_0_r. intros m IH. rewrite pred_succ; now apply -> lt_succ_r. Qed. -Theorem lt_pred_le : forall n m : N, P n < m -> n <= m. (* Converse is false for n == m == 0 *) +Theorem lt_pred_le : forall n m, P n < m -> n <= m. + (* Converse is false for n == m == 0 *) Proof. intros n m; cases n. rewrite pred_0; intro H; now apply lt_le_incl. intros n IH. rewrite pred_succ in IH. now apply <- le_succ_l. Qed. -Theorem lt_pred_lt : forall n m : N, n < P m -> n < m. +Theorem lt_pred_lt : forall n m, n < P m -> n < m. Proof. intros n m H; apply lt_le_trans with (P m); [assumption | apply le_pred_l]. Qed. -Theorem le_pred_le : forall n m : N, n <= P m -> n <= m. +Theorem le_pred_le : forall n m, n <= P m -> n <= m. Proof. intros n m H; apply le_trans with (P m); [assumption | apply le_pred_l]. Qed. -Theorem pred_le_mono : forall n m : N, n <= m -> P n <= P m. (* Converse is false for n == 1, m == 0 *) +Theorem pred_le_mono : forall n m, n <= m -> P n <= P m. + (* Converse is false for n == 1, m == 0 *) Proof. intros n m H; elim H using le_ind_rel. solve_relation_wd. @@ -501,7 +205,7 @@ intro; rewrite pred_0; apply le_0_l. intros p q H1 _; now do 2 rewrite pred_succ. Qed. -Theorem pred_lt_mono : forall n m : N, n ~= 0 -> (n < m <-> P n < P m). +Theorem pred_lt_mono : forall n m, n ~= 0 -> (n < m <-> P n < P m). Proof. intros n m H1; split; intro H2. assert (m ~= 0). apply <- neq_0_lt_0. now apply lt_lt_0 with n. @@ -512,22 +216,24 @@ apply lt_le_trans with (P m). assumption. apply le_pred_l. apply -> succ_lt_mono in H2. now do 2 rewrite succ_pred in H2. Qed. -Theorem lt_succ_lt_pred : forall n m : N, S n < m <-> n < P m. +Theorem lt_succ_lt_pred : forall n m, S n < m <-> n < P m. Proof. intros n m. rewrite pred_lt_mono by apply neq_succ_0. now rewrite pred_succ. Qed. -Theorem le_succ_le_pred : forall n m : N, S n <= m -> n <= P m. (* Converse is false for n == m == 0 *) +Theorem le_succ_le_pred : forall n m, S n <= m -> n <= P m. + (* Converse is false for n == m == 0 *) Proof. intros n m H. apply lt_le_pred. now apply -> le_succ_l. Qed. -Theorem lt_pred_lt_succ : forall n m : N, P n < m -> n < S m. (* Converse is false for n == m == 0 *) +Theorem lt_pred_lt_succ : forall n m, P n < m -> n < S m. + (* Converse is false for n == m == 0 *) Proof. intros n m H. apply <- lt_succ_r. now apply lt_pred_le. Qed. -Theorem le_pred_le_succ : forall n m : N, P n <= m <-> n <= S m. +Theorem le_pred_le_succ : forall n m, P n <= m <-> n <= S m. Proof. intros n m; cases n. rewrite pred_0. split; intro H; apply le_0_l. diff --git a/theories/Numbers/Natural/Abstract/NProperties.v b/theories/Numbers/Natural/Abstract/NProperties.v new file mode 100644 index 00000000..30262bd9 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NProperties.v @@ -0,0 +1,22 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A)->N->A] is the step function: + [F f n] should return [phi(n)] when [f] is a function + that coincide with [phi] for numbers strictly less than [n]. +*) -Notation Local "x ==A y" := (Aeq x y) (at level 70, no associativity). +Definition strong_rec (a : A) (f : (N.t -> A) -> N.t -> A) (n : N.t) : A := + recursion (fun _ => a) (fun _ => f) (S n) n. -Hypothesis Aeq_equiv : equiv A Aeq. +(** For convenience, we use in proofs an intermediate definition + between [recursion] and [strong_rec]. *) -Add Relation A Aeq - reflexivity proved by (proj1 Aeq_equiv) - symmetry proved by (proj2 (proj2 Aeq_equiv)) - transitivity proved by (proj1 (proj2 Aeq_equiv)) -as Aeq_rel. +Definition strong_rec0 (a : A) (f : (N.t -> A) -> N.t -> A) : N.t -> N.t -> A := + recursion (fun _ => a) (fun _ => f). -Definition strong_rec (a : A) (f : N -> (N -> A) -> A) (n : N) : A := -recursion - (fun _ : N => a) - (fun (m : N) (p : N -> A) (k : N) => f k p) - (S n) - n. +Lemma strong_rec_alt : forall a f n, + strong_rec a f n = strong_rec0 a f (S n) n. +Proof. +reflexivity. +Qed. -Theorem strong_rec_wd : -forall a a' : A, a ==A a' -> - forall f f', fun2_eq Neq (fun_eq Neq Aeq) Aeq f f' -> - forall n n', n == n' -> - strong_rec a f n ==A strong_rec a' f' n'. +(** We need a result similar to [f_equal], but for setoid equalities. *) +Lemma f_equiv : forall f g x y, + (N.eq==>Aeq)%signature f g -> N.eq x y -> Aeq (f x) (g y). +Proof. +auto. +Qed. + +Instance strong_rec0_wd : + Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> N.eq ==> Aeq) + strong_rec0. +Proof. +unfold strong_rec0. +repeat red; intros. +apply f_equiv; auto. +apply recursion_wd; try red; auto. +Qed. + +Instance strong_rec_wd : + Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> Aeq) strong_rec. Proof. intros a a' Eaa' f f' Eff' n n' Enn'. -(* First we prove that recursion (which is on type N -> A) returns -extensionally equal functions, and then we use the fact that n == n' *) -assert (H : fun_eq Neq Aeq - (recursion - (fun _ : N => a) - (fun (m : N) (p : N -> A) (k : N) => f k p) - (S n)) - (recursion - (fun _ : N => a') - (fun (m : N) (p : N -> A) (k : N) => f' k p) - (S n'))). -apply recursion_wd with (Aeq := fun_eq Neq Aeq). -unfold fun_eq; now intros. -unfold fun2_eq. intros y y' Eyy' p p' Epp'. unfold fun_eq. auto. +rewrite !strong_rec_alt. +apply strong_rec0_wd; auto. now rewrite Enn'. -unfold strong_rec. -now apply H. Qed. -(*Section FixPoint. - -Variable a : A. -Variable f : N -> (N -> A) -> A. +Section FixPoint. -Hypothesis f_wd : fun2_wd Neq (fun_eq Neq Aeq) Aeq f. +Variable f : (N.t -> A) -> N.t -> A. +Variable f_wd : Proper ((N.eq==>Aeq)==>N.eq==>Aeq) f. -Let g (n : N) : A := strong_rec a f n. +Lemma strong_rec0_0 : forall a m, + (strong_rec0 a f 0 m) = a. +Proof. +intros. unfold strong_rec0. rewrite recursion_0; auto. +Qed. -Add Morphism g with signature Neq ==> Aeq as g_wd. +Lemma strong_rec0_succ : forall a n m, + Aeq (strong_rec0 a f (S n) m) (f (strong_rec0 a f n) m). Proof. -intros n1 n2 H. unfold g. now apply strong_rec_wd. +intros. unfold strong_rec0. +apply f_equiv; auto with *. +rewrite recursion_succ; try (repeat red; auto with *; fail). +apply f_wd. +apply recursion_wd; try red; auto with *. Qed. -Theorem NtoA_eq_sym : symmetric (N -> A) (fun_eq Neq Aeq). +Lemma strong_rec_0 : forall a, + Aeq (strong_rec a f 0) (f (fun _ => a) 0). Proof. -apply fun_eq_sym. -exact (proj2 (proj2 NZeq_equiv)). -exact (proj2 (proj2 Aeq_equiv)). +intros. rewrite strong_rec_alt, strong_rec0_succ. +apply f_wd; auto with *. +red; intros; rewrite strong_rec0_0; auto with *. Qed. -Theorem NtoA_eq_trans : transitive (N -> A) (fun_eq Neq Aeq). +(* We need an assumption saying that for every n, the step function (f h n) +calls h only on the segment [0 ... n - 1]. This means that if h1 and h2 +coincide on values < n, then (f h1 n) coincides with (f h2 n) *) + +Hypothesis step_good : + forall (n : N.t) (h1 h2 : N.t -> A), + (forall m : N.t, m < n -> Aeq (h1 m) (h2 m)) -> Aeq (f h1 n) (f h2 n). + +Lemma strong_rec0_more_steps : forall a k n m, m < n -> + Aeq (strong_rec0 a f n m) (strong_rec0 a f (n+k) m). Proof. -apply fun_eq_trans. -exact (proj1 NZeq_equiv). -exact (proj1 (proj2 NZeq_equiv)). -exact (proj1 (proj2 Aeq_equiv)). + intros a k n. pattern n. + apply induction; clear n. + + intros n n' Hn; setoid_rewrite Hn; auto with *. + + intros m Hm. destruct (nlt_0_r _ Hm). + + intros n IH m Hm. + rewrite lt_succ_r in Hm. + rewrite add_succ_l. + rewrite 2 strong_rec0_succ. + apply step_good. + intros m' Hm'. + apply IH. + apply lt_le_trans with m; auto. Qed. -Add Relation (N -> A) (fun_eq Neq Aeq) - symmetry proved by NtoA_eq_sym - transitivity proved by NtoA_eq_trans -as NtoA_eq_rel. +Lemma strong_rec0_fixpoint : forall (a : A) (n : N.t), + Aeq (strong_rec0 a f (S n) n) (f (fun n => strong_rec0 a f (S n) n) n). +Proof. +intros. +rewrite strong_rec0_succ. +apply step_good. +intros m Hm. +symmetry. +setoid_replace n with (S m + (n - S m)). +apply strong_rec0_more_steps. +apply lt_succ_diag_r. +rewrite add_comm. +symmetry. +apply sub_add. +rewrite le_succ_l; auto. +Qed. -Add Morphism f with signature Neq ==> (fun_eq Neq Aeq) ==> Aeq as f_morph. +Theorem strong_rec_fixpoint : forall (a : A) (n : N.t), + Aeq (strong_rec a f n) (f (strong_rec a f) n). Proof. -apply f_wd. +intros. +transitivity (f (fun n => strong_rec0 a f (S n) n) n). +rewrite strong_rec_alt. +apply strong_rec0_fixpoint. +apply f_wd; auto with *. +intros x x' Hx; rewrite strong_rec_alt, Hx; auto with *. Qed. -(* We need an assumption saying that for every n, the step function (f n h) -calls h only on the segment [0 ... n - 1]. This means that if h1 and h2 -coincide on values < n, then (f n h1) coincides with (f n h2) *) +(** NB: without the [step_good] hypothesis, we have proved that + [strong_rec a f 0] is [f (fun _ => a) 0]. Now we can prove + that the first argument of [f] is arbitrary in this case... +*) -Hypothesis step_good : - forall (n : N) (h1 h2 : N -> A), - (forall m : N, m < n -> Aeq (h1 m) (h2 m)) -> Aeq (f n h1) (f n h2). +Theorem strong_rec_0_any : forall (a : A)(any : N.t->A), + Aeq (strong_rec a f 0) (f any 0). +Proof. +intros. +rewrite strong_rec_fixpoint. +apply step_good. +intros m Hm. destruct (nlt_0_r _ Hm). +Qed. -(* Todo: -Theorem strong_rec_fixpoint : forall n : N, Aeq (g n) (f n g). +(** ... and that first argument of [strong_rec] is always arbitrary. *) + +Lemma strong_rec_any_fst_arg : forall a a' n, + Aeq (strong_rec a f n) (strong_rec a' f n). Proof. -apply induction. -unfold predicate_wd, fun_wd. -intros x y H. rewrite H. unfold fun_eq; apply g_wd. -reflexivity. -unfold g, strong_rec. -*) +intros a a' n. +generalize (le_refl n). +set (k:=n) at -2. clearbody k. revert k. pattern n. +apply induction; clear n. +(* compat *) +intros n n' Hn. setoid_rewrite Hn; auto with *. +(* 0 *) +intros k Hk. rewrite le_0_r in Hk. +rewrite Hk, strong_rec_0. symmetry. apply strong_rec_0_any. +(* S *) +intros n IH k Hk. +rewrite 2 strong_rec_fixpoint. +apply step_good. +intros m Hm. +apply IH. +rewrite succ_le_mono. +apply le_trans with k; auto. +rewrite le_succ_l; auto. +Qed. -End FixPoint.*) +End FixPoint. End StrongRecursion. Implicit Arguments strong_rec [A]. diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v index f67689dd..35d3b8aa 100644 --- a/theories/Numbers/Natural/Abstract/NSub.v +++ b/theories/Numbers/Natural/Abstract/NSub.v @@ -8,49 +8,33 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NSub.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) Require Export NMulOrder. -Module NSubPropFunct (Import NAxiomsMod : NAxiomsSig). -Module Export NMulOrderPropMod := NMulOrderPropFunct NAxiomsMod. -Open Local Scope NatScope. +Module Type NSubPropFunct (Import N : NAxiomsSig'). +Include NMulOrderPropFunct N. -Theorem sub_wd : - forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> n1 - m1 == n2 - m2. -Proof NZsub_wd. - -Theorem sub_0_r : forall n : N, n - 0 == n. -Proof NZsub_0_r. - -Theorem sub_succ_r : forall n m : N, n - (S m) == P (n - m). -Proof NZsub_succ_r. - -Theorem sub_1_r : forall n : N, n - 1 == P n. -Proof. -intro n; rewrite sub_succ_r; now rewrite sub_0_r. -Qed. - -Theorem sub_0_l : forall n : N, 0 - n == 0. +Theorem sub_0_l : forall n, 0 - n == 0. Proof. induct n. apply sub_0_r. intros n IH; rewrite sub_succ_r; rewrite IH. now apply pred_0. Qed. -Theorem sub_succ : forall n m : N, S n - S m == n - m. +Theorem sub_succ : forall n m, S n - S m == n - m. Proof. intro n; induct m. rewrite sub_succ_r. do 2 rewrite sub_0_r. now rewrite pred_succ. intros m IH. rewrite sub_succ_r. rewrite IH. now rewrite sub_succ_r. Qed. -Theorem sub_diag : forall n : N, n - n == 0. +Theorem sub_diag : forall n, n - n == 0. Proof. induct n. apply sub_0_r. intros n IH; rewrite sub_succ; now rewrite IH. Qed. -Theorem sub_gt : forall n m : N, n > m -> n - m ~= 0. +Theorem sub_gt : forall n m, n > m -> n - m ~= 0. Proof. intros n m H; elim H using lt_ind_rel; clear n m H. solve_relation_wd. @@ -58,7 +42,7 @@ intro; rewrite sub_0_r; apply neq_succ_0. intros; now rewrite sub_succ. Qed. -Theorem add_sub_assoc : forall n m p : N, p <= m -> n + (m - p) == (n + m) - p. +Theorem add_sub_assoc : forall n m p, p <= m -> n + (m - p) == (n + m) - p. Proof. intros n m p; induct p. intro; now do 2 rewrite sub_0_r. @@ -68,32 +52,32 @@ rewrite add_pred_r by (apply sub_gt; now apply -> le_succ_l). reflexivity. Qed. -Theorem sub_succ_l : forall n m : N, n <= m -> S m - n == S (m - n). +Theorem sub_succ_l : forall n m, n <= m -> S m - n == S (m - n). Proof. intros n m H. rewrite <- (add_1_l m). rewrite <- (add_1_l (m - n)). symmetry; now apply add_sub_assoc. Qed. -Theorem add_sub : forall n m : N, (n + m) - m == n. +Theorem add_sub : forall n m, (n + m) - m == n. Proof. intros n m. rewrite <- add_sub_assoc by (apply le_refl). rewrite sub_diag; now rewrite add_0_r. Qed. -Theorem sub_add : forall n m : N, n <= m -> (m - n) + n == m. +Theorem sub_add : forall n m, n <= m -> (m - n) + n == m. Proof. intros n m H. rewrite add_comm. rewrite add_sub_assoc by assumption. rewrite add_comm. apply add_sub. Qed. -Theorem add_sub_eq_l : forall n m p : N, m + p == n -> n - m == p. +Theorem add_sub_eq_l : forall n m p, m + p == n -> n - m == p. Proof. intros n m p H. symmetry. assert (H1 : m + p - m == n - m) by now rewrite H. rewrite add_comm in H1. now rewrite add_sub in H1. Qed. -Theorem add_sub_eq_r : forall n m p : N, m + p == n -> n - p == m. +Theorem add_sub_eq_r : forall n m p, m + p == n -> n - p == m. Proof. intros n m p H; rewrite add_comm in H; now apply add_sub_eq_l. Qed. @@ -101,7 +85,7 @@ Qed. (* This could be proved by adding m to both sides. Then the proof would use add_sub_assoc and sub_0_le, which is proven below. *) -Theorem add_sub_eq_nz : forall n m p : N, p ~= 0 -> n - m == p -> m + p == n. +Theorem add_sub_eq_nz : forall n m p, p ~= 0 -> n - m == p -> m + p == n. Proof. intros n m p H; double_induct n m. intros m H1; rewrite sub_0_l in H1. symmetry in H1; false_hyp H1 H. @@ -110,14 +94,14 @@ intros n m IH H1. rewrite sub_succ in H1. apply IH in H1. rewrite add_succ_l; now rewrite H1. Qed. -Theorem sub_add_distr : forall n m p : N, n - (m + p) == (n - m) - p. +Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p. Proof. intros n m; induct p. rewrite add_0_r; now rewrite sub_0_r. intros p IH. rewrite add_succ_r; do 2 rewrite sub_succ_r. now rewrite IH. Qed. -Theorem add_sub_swap : forall n m p : N, p <= n -> n + m - p == n - p + m. +Theorem add_sub_swap : forall n m p, p <= n -> n + m - p == n - p + m. Proof. intros n m p H. rewrite (add_comm n m). @@ -127,7 +111,7 @@ Qed. (** Sub and order *) -Theorem le_sub_l : forall n m : N, n - m <= n. +Theorem le_sub_l : forall n m, n - m <= n. Proof. intro n; induct m. rewrite sub_0_r; now apply eq_le_incl. @@ -135,7 +119,7 @@ intros m IH. rewrite sub_succ_r. apply le_trans with (n - m); [apply le_pred_l | assumption]. Qed. -Theorem sub_0_le : forall n m : N, n - m == 0 <-> n <= m. +Theorem sub_0_le : forall n m, n - m == 0 <-> n <= m. Proof. double_induct n m. intro m; split; intro; [apply le_0_l | apply sub_0_l]. @@ -144,9 +128,86 @@ intro m; rewrite sub_0_r; split; intro H; intros n m H. rewrite <- succ_le_mono. now rewrite sub_succ. Qed. +Theorem sub_add_le : forall n m, n <= n - m + m. +Proof. +intros. +destruct (le_ge_cases n m) as [LE|GE]. +rewrite <- sub_0_le in LE. rewrite LE; nzsimpl. +now rewrite <- sub_0_le. +rewrite sub_add by assumption. apply le_refl. +Qed. + +Theorem le_sub_le_add_r : forall n m p, + n - p <= m <-> n <= m + p. +Proof. +intros n m p. +split; intros LE. +rewrite (add_le_mono_r _ _ p) in LE. +apply le_trans with (n-p+p); auto using sub_add_le. +destruct (le_ge_cases n p) as [LE'|GE]. +rewrite <- sub_0_le in LE'. rewrite LE'. apply le_0_l. +rewrite (add_le_mono_r _ _ p). now rewrite sub_add. +Qed. + +Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p. +Proof. +intros n m p. rewrite add_comm; apply le_sub_le_add_r. +Qed. + +Theorem lt_sub_lt_add_r : forall n m p, + n - p < m -> n < m + p. +Proof. +intros n m p LT. +rewrite (add_lt_mono_r _ _ p) in LT. +apply le_lt_trans with (n-p+p); auto using sub_add_le. +Qed. + +(** Unfortunately, we do not have [n < m + p -> n - p < m]. + For instance [1<0+2] but not [1-2<0]. *) + +Theorem lt_sub_lt_add_l : forall n m p, n - m < p -> n < m + p. +Proof. +intros n m p. rewrite add_comm; apply lt_sub_lt_add_r. +Qed. + +Theorem le_add_le_sub_r : forall n m p, n + p <= m -> n <= m - p. +Proof. +intros n m p LE. +apply (add_le_mono_r _ _ p). +rewrite sub_add. assumption. +apply le_trans with (n+p); trivial. +rewrite <- (add_0_l p) at 1. rewrite <- add_le_mono_r. apply le_0_l. +Qed. + +(** Unfortunately, we do not have [n <= m - p -> n + p <= m]. + For instance [0<=1-2] but not [2+0<=1]. *) + +Theorem le_add_le_sub_l : forall n m p, n + p <= m -> p <= m - n. +Proof. +intros n m p. rewrite add_comm; apply le_add_le_sub_r. +Qed. + +Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p. +Proof. +intros n m p. +destruct (le_ge_cases p m) as [LE|GE]. +rewrite <- (sub_add p m) at 1 by assumption. +now rewrite <- add_lt_mono_r. +assert (GE' := GE). rewrite <- sub_0_le in GE'; rewrite GE'. +split; intros LT. +elim (lt_irrefl m). apply le_lt_trans with (n+p); trivial. + rewrite <- (add_0_l m). apply add_le_mono. apply le_0_l. assumption. +now elim (nlt_0_r n). +Qed. + +Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n. +Proof. +intros n m p. rewrite add_comm; apply lt_add_lt_sub_r. +Qed. + (** Sub and mul *) -Theorem mul_pred_r : forall n m : N, n * (P m) == n * m - n. +Theorem mul_pred_r : forall n m, n * (P m) == n * m - n. Proof. intros n m; cases m. now rewrite pred_0, mul_0_r, sub_0_l. @@ -155,7 +216,7 @@ now rewrite sub_diag, add_0_r. now apply eq_le_incl. Qed. -Theorem mul_sub_distr_r : forall n m p : N, (n - m) * p == n * p - m * p. +Theorem mul_sub_distr_r : forall n m p, (n - m) * p == n * p - m * p. Proof. intros n m p; induct n. now rewrite sub_0_l, mul_0_l, sub_0_l. @@ -170,11 +231,72 @@ setoid_replace ((S n * p) - m * p) with 0 by (apply <- sub_0_le; now apply mul_l apply mul_0_l. Qed. -Theorem mul_sub_distr_l : forall n m p : N, p * (n - m) == p * n - p * m. +Theorem mul_sub_distr_l : forall n m p, p * (n - m) == p * n - p * m. Proof. intros n m p; rewrite (mul_comm p (n - m)), (mul_comm p n), (mul_comm p m). apply mul_sub_distr_r. Qed. +(** Alternative definitions of [<=] and [<] based on [+] *) + +Definition le_alt n m := exists p, p + n == m. +Definition lt_alt n m := exists p, S p + n == m. + +Lemma le_equiv : forall n m, le_alt n m <-> n <= m. +Proof. +split. +intros (p,H). rewrite <- H, add_comm. apply le_add_r. +intro H. exists (m-n). now apply sub_add. +Qed. + +Lemma lt_equiv : forall n m, lt_alt n m <-> n < m. +Proof. +split. +intros (p,H). rewrite <- H, add_succ_l, lt_succ_r, add_comm. apply le_add_r. +intro H. exists (m-S n). rewrite add_succ_l, <- add_succ_r. +apply sub_add. now rewrite le_succ_l. +Qed. + +Instance le_alt_wd : Proper (eq==>eq==>iff) le_alt. +Proof. + intros x x' Hx y y' Hy; unfold le_alt. + setoid_rewrite Hx. setoid_rewrite Hy. auto with *. +Qed. + +Instance lt_alt_wd : Proper (eq==>eq==>iff) lt_alt. +Proof. + intros x x' Hx y y' Hy; unfold lt_alt. + setoid_rewrite Hx. setoid_rewrite Hy. auto with *. +Qed. + +(** With these alternative definition, the dichotomy: + +[forall n m, n <= m \/ m <= n] + +becomes: + +[forall n m, (exists p, p + n == m) \/ (exists p, p + m == n)] + +We will need this in the proof of induction principle for integers +constructed as pairs of natural numbers. This formula can be proved +from know properties of [<=]. However, it can also be done directly. *) + +Theorem le_alt_dichotomy : forall n m, le_alt n m \/ le_alt m n. +Proof. +intros n m; induct n. +left; exists m; apply add_0_r. +intros n IH. +destruct IH as [[p H] | [p H]]. +destruct (zero_or_succ p) as [H1 | [p' H1]]; rewrite H1 in H. +rewrite add_0_l in H. right; exists (S 0); rewrite H, add_succ_l; + now rewrite add_0_l. +left; exists p'; rewrite add_succ_r; now rewrite add_succ_l in H. +right; exists (S p). rewrite add_succ_l; now rewrite H. +Qed. + +Theorem add_dichotomy : + forall n m, (exists p, p + n == m) \/ (exists p, p + m == n). +Proof. exact le_alt_dichotomy. Qed. + End NSubPropFunct. diff --git a/theories/Numbers/Natural/BigN/BigN.v b/theories/Numbers/Natural/BigN/BigN.v index 16007656..cab4b154 100644 --- a/theories/Numbers/Natural/BigN/BigN.v +++ b/theories/Numbers/Natural/BigN/BigN.v @@ -6,28 +6,32 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BigN.v 11576 2008-11-10 19:13:15Z msozeau $ i*) +(** * Efficient arbitrary large natural numbers in base 2^31 *) -(** * Natural numbers in base 2^31 *) - -(** -Author: Arnaud Spiwack -*) +(** Initial Author: Arnaud Spiwack *) Require Export Int31. -Require Import CyclicAxioms. -Require Import Cyclic31. -Require Import NSig. -Require Import NSigNAxioms. -Require Import NMake. -Require Import NSub. +Require Import CyclicAxioms Cyclic31 Ring31 NSig NSigNAxioms NMake + NProperties NDiv GenericMinMax. + +(** The following [BigN] module regroups both the operations and + all the abstract properties: -Module BigN <: NType := NMake.Make Int31Cyclic. + - [NMake.Make Int31Cyclic] provides the operations and basic specs + w.r.t. ZArith + - [NTypeIsNAxioms] shows (mainly) that these operations implement + the interface [NAxioms] + - [NPropSig] adds all generic properties derived from [NAxioms] + - [NDivPropFunct] provides generic properties of [div] and [mod]. + - [MinMax*Properties] provides properties of [min] and [max]. + +*) -(** Module [BigN] implements [NAxiomsSig] *) +Module BigN <: NType <: OrderedTypeFull <: TotalOrder := + NMake.Make Int31Cyclic <+ NTypeIsNAxioms + <+ !NPropSig <+ !NDivPropFunct <+ HasEqBool2Dec + <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties. -Module Export BigNAxiomsMod := NSig_NAxioms BigN. -Module Export BigNSubPropMod := NSubPropFunct BigNAxiomsMod. (** Notations about [BigN] *) @@ -37,49 +41,171 @@ Delimit Scope bigN_scope with bigN. Bind Scope bigN_scope with bigN. Bind Scope bigN_scope with BigN.t. Bind Scope bigN_scope with BigN.t_. - -Notation Local "0" := BigN.zero : bigN_scope. (* temporary notation *) +(* Bind Scope has no retroactive effect, let's declare scopes by hand. *) +Arguments Scope BigN.to_Z [bigN_scope]. +Arguments Scope BigN.succ [bigN_scope]. +Arguments Scope BigN.pred [bigN_scope]. +Arguments Scope BigN.square [bigN_scope]. +Arguments Scope BigN.add [bigN_scope bigN_scope]. +Arguments Scope BigN.sub [bigN_scope bigN_scope]. +Arguments Scope BigN.mul [bigN_scope bigN_scope]. +Arguments Scope BigN.div [bigN_scope bigN_scope]. +Arguments Scope BigN.eq [bigN_scope bigN_scope]. +Arguments Scope BigN.lt [bigN_scope bigN_scope]. +Arguments Scope BigN.le [bigN_scope bigN_scope]. +Arguments Scope BigN.eq [bigN_scope bigN_scope]. +Arguments Scope BigN.compare [bigN_scope bigN_scope]. +Arguments Scope BigN.min [bigN_scope bigN_scope]. +Arguments Scope BigN.max [bigN_scope bigN_scope]. +Arguments Scope BigN.eq_bool [bigN_scope bigN_scope]. +Arguments Scope BigN.power_pos [bigN_scope positive_scope]. +Arguments Scope BigN.power [bigN_scope N_scope]. +Arguments Scope BigN.sqrt [bigN_scope]. +Arguments Scope BigN.div_eucl [bigN_scope bigN_scope]. +Arguments Scope BigN.modulo [bigN_scope bigN_scope]. +Arguments Scope BigN.gcd [bigN_scope bigN_scope]. + +Local Notation "0" := BigN.zero : bigN_scope. (* temporary notation *) +Local Notation "1" := BigN.one : bigN_scope. (* temporary notation *) Infix "+" := BigN.add : bigN_scope. Infix "-" := BigN.sub : bigN_scope. Infix "*" := BigN.mul : bigN_scope. Infix "/" := BigN.div : bigN_scope. +Infix "^" := BigN.power : bigN_scope. Infix "?=" := BigN.compare : bigN_scope. Infix "==" := BigN.eq (at level 70, no associativity) : bigN_scope. +Notation "x != y" := (~x==y)%bigN (at level 70, no associativity) : bigN_scope. Infix "<" := BigN.lt : bigN_scope. Infix "<=" := BigN.le : bigN_scope. Notation "x > y" := (BigN.lt y x)(only parsing) : bigN_scope. Notation "x >= y" := (BigN.le y x)(only parsing) : bigN_scope. +Notation "x < y < z" := (x BigN.succ (BigN.pred q) == q. Proof. -intros; apply succ_pred. +intros; apply BigN.succ_pred. intro H'; rewrite H' in H; discriminate. Qed. (** [BigN] is a semi-ring *) -Lemma BigNring : - semi_ring_theory BigN.zero BigN.one BigN.add BigN.mul BigN.eq. +Lemma BigNring : semi_ring_theory 0 1 BigN.add BigN.mul BigN.eq. +Proof. +constructor. +exact BigN.add_0_l. exact BigN.add_comm. exact BigN.add_assoc. +exact BigN.mul_1_l. exact BigN.mul_0_l. exact BigN.mul_comm. +exact BigN.mul_assoc. exact BigN.mul_add_distr_r. +Qed. + +Lemma BigNeqb_correct : forall x y, BigN.eq_bool x y = true -> x==y. +Proof. now apply BigN.eqb_eq. Qed. + +Lemma BigNpower : power_theory 1 BigN.mul BigN.eq (@id N) BigN.power. Proof. constructor. -exact add_0_l. -exact add_comm. -exact add_assoc. -exact mul_1_l. -exact mul_0_l. -exact mul_comm. -exact mul_assoc. -exact mul_add_distr_r. +intros. red. rewrite BigN.spec_power. unfold id. +destruct Zpower_theory as [EQ]. rewrite EQ. +destruct n; simpl. reflexivity. +induction p; simpl; intros; BigN.zify; rewrite ?IHp; auto. +Qed. + +Lemma BigNdiv : div_theory BigN.eq BigN.add BigN.mul (@id _) + (fun a b => if BigN.eq_bool b 0 then (0,a) else BigN.div_eucl a b). +Proof. +constructor. unfold id. intros a b. +BigN.zify. +generalize (Zeq_bool_if [b] 0); destruct (Zeq_bool [b] 0). +BigN.zify. auto with zarith. +intros NEQ. +generalize (BigN.spec_div_eucl a b). +generalize (Z_div_mod_full [a] [b] NEQ). +destruct BigN.div_eucl as (q,r), Zdiv_eucl as (q',r'). +intros (EQ,_). injection 1. intros EQr EQq. +BigN.zify. rewrite EQr, EQq; auto. +Qed. + + +(** Detection of constants *) + +Ltac isStaticWordCst t := + match t with + | W0 => constr:true + | WW ?t1 ?t2 => + match isStaticWordCst t1 with + | false => constr:false + | true => isStaticWordCst t2 + end + | _ => isInt31cst t + end. + +Ltac isBigNcst t := + match t with + | BigN.N0 ?t => isStaticWordCst t + | BigN.N1 ?t => isStaticWordCst t + | BigN.N2 ?t => isStaticWordCst t + | BigN.N3 ?t => isStaticWordCst t + | BigN.N4 ?t => isStaticWordCst t + | BigN.N5 ?t => isStaticWordCst t + | BigN.N6 ?t => isStaticWordCst t + | BigN.Nn ?n ?t => match isnatcst n with + | true => isStaticWordCst t + | false => constr:false + end + | BigN.zero => constr:true + | BigN.one => constr:true + | _ => constr:false + end. + +Ltac BigNcst t := + match isBigNcst t with + | true => constr:t + | false => constr:NotConstant + end. + +Ltac Ncst t := + match isNcst t with + | true => constr:t + | false => constr:NotConstant + end. + +(** Registration for the "ring" tactic *) + +Add Ring BigNr : BigNring + (decidable BigNeqb_correct, + constants [BigNcst], + power_tac BigNpower [Ncst], + div BigNdiv). + +Section TestRing. +Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x. +intros. ring_simplify. reflexivity. Qed. +End TestRing. + +(** We benefit also from an "order" tactic *) + +Ltac bigN_order := BigN.order. + +Section TestOrder. +Let test : forall x y : bigN, x<=y -> y<=x -> x==y. +Proof. bigN_order. Qed. +End TestOrder. -Add Ring BigNr : BigNring. +(** We can use at least a bit of (r)omega by translating to [Z]. *) -(** Todo: tactic translating from [BigN] to [Z] + omega *) +Section TestOmega. +Let test : forall x y : bigN, x<=y -> y<=x -> x==y. +Proof. intros x y. BigN.zify. omega. Qed. +End TestOmega. (** Todo: micromega *) diff --git a/theories/Numbers/Natural/BigN/NMake.v b/theories/Numbers/Natural/BigN/NMake.v new file mode 100644 index 00000000..925b0535 --- /dev/null +++ b/theories/Numbers/Natural/BigN/NMake.v @@ -0,0 +1,524 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* true + | _ => false + end. + + Theorem spec_eq_bool : forall x y, eq_bool x y = Zeq_bool [x] [y]. + Proof. + intros. unfold eq_bool, Zeq_bool. rewrite spec_compare; reflexivity. + Qed. + + Theorem spec_eq_bool_aux: forall x y, + if eq_bool x y then [x] = [y] else [x] <> [y]. + Proof. + intros x y; unfold eq_bool. + generalize (spec_compare_aux x y); case compare; auto with zarith. + Qed. + + Definition lt n m := [n] < [m]. + Definition le n m := [n] <= [m]. + + Definition min n m := match compare n m with Gt => m | _ => n end. + Definition max n m := match compare n m with Lt => m | _ => n end. + + Theorem spec_max : forall n m, [max n m] = Zmax [n] [m]. + Proof. + intros. unfold max, Zmax. rewrite spec_compare; destruct Zcompare; reflexivity. + Qed. + + Theorem spec_min : forall n m, [min n m] = Zmin [n] [m]. + Proof. + intros. unfold min, Zmin. rewrite spec_compare; destruct Zcompare; reflexivity. + Qed. + + + (** * Power *) + + Fixpoint power_pos (x:t) (p:positive) {struct p} : t := + match p with + | xH => x + | xO p => square (power_pos x p) + | xI p => mul (square (power_pos x p)) x + end. + + Theorem spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n. + Proof. + intros x n; generalize x; elim n; clear n x; simpl power_pos. + intros; rewrite spec_mul; rewrite spec_square; rewrite H. + rewrite Zpos_xI; rewrite Zpower_exp; auto with zarith. + rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith. + rewrite Zpower_2; rewrite Zpower_1_r; auto. + intros; rewrite spec_square; rewrite H. + rewrite Zpos_xO; auto with zarith. + rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith. + rewrite Zpower_2; auto. + intros; rewrite Zpower_1_r; auto. + Qed. + + Definition power x (n:N) := match n with + | BinNat.N0 => one + | BinNat.Npos p => power_pos x p + end. + + Theorem spec_power: forall x n, [power x n] = [x] ^ Z_of_N n. + Proof. + destruct n; simpl. apply (spec_1 w0_spec). + apply spec_power_pos. + Qed. + + + (** * Div *) + + Definition div_eucl x y := + if eq_bool y zero then (zero,zero) else + match compare x y with + | Eq => (one, zero) + | Lt => (zero, x) + | Gt => div_gt x y + end. + + Theorem spec_div_eucl: forall x y, + let (q,r) := div_eucl x y in + ([q], [r]) = Zdiv_eucl [x] [y]. + Proof. + assert (F0: [zero] = 0). + exact (spec_0 w0_spec). + assert (F1: [one] = 1). + exact (spec_1 w0_spec). + intros x y. unfold div_eucl. + generalize (spec_eq_bool_aux y zero). destruct eq_bool; rewrite F0. + intro H. rewrite H. destruct [x]; auto. + intro H'. + assert (0 < [y]) by (generalize (spec_pos y); auto with zarith). + clear H'. + generalize (spec_compare_aux x y); case compare; try rewrite F0; + try rewrite F1; intros; auto with zarith. + rewrite H0; generalize (Z_div_same [y] (Zlt_gt _ _ H)) + (Z_mod_same [y] (Zlt_gt _ _ H)); + unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto. + assert (F2: 0 <= [x] < [y]). + generalize (spec_pos x); auto. + generalize (Zdiv_small _ _ F2) + (Zmod_small _ _ F2); + unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto. + generalize (spec_div_gt _ _ H0 H); auto. + unfold Zdiv, Zmod; case Zdiv_eucl; case div_gt. + intros a b c d (H1, H2); subst; auto. + Qed. + + Definition div x y := fst (div_eucl x y). + + Theorem spec_div: + forall x y, [div x y] = [x] / [y]. + Proof. + intros x y; unfold div; generalize (spec_div_eucl x y); + case div_eucl; simpl fst. + intros xx yy; unfold Zdiv; case Zdiv_eucl; intros qq rr H; + injection H; auto. + Qed. + + + (** * Modulo *) + + Definition modulo x y := + if eq_bool y zero then zero else + match compare x y with + | Eq => zero + | Lt => x + | Gt => mod_gt x y + end. + + Theorem spec_modulo: + forall x y, [modulo x y] = [x] mod [y]. + Proof. + assert (F0: [zero] = 0). + exact (spec_0 w0_spec). + assert (F1: [one] = 1). + exact (spec_1 w0_spec). + intros x y. unfold modulo. + generalize (spec_eq_bool_aux y zero). destruct eq_bool; rewrite F0. + intro H; rewrite H. destruct [x]; auto. + intro H'. + assert (H : 0 < [y]) by (generalize (spec_pos y); auto with zarith). + clear H'. + generalize (spec_compare_aux x y); case compare; try rewrite F0; + try rewrite F1; intros; try split; auto with zarith. + rewrite H0; apply sym_equal; apply Z_mod_same; auto with zarith. + apply sym_equal; apply Zmod_small; auto with zarith. + generalize (spec_pos x); auto with zarith. + apply spec_mod_gt; auto. + Qed. + + + (** * Gcd *) + + Definition gcd_gt_body a b cont := + match compare b zero with + | Gt => + let r := mod_gt a b in + match compare r zero with + | Gt => cont r (mod_gt b r) + | _ => b + end + | _ => a + end. + + Theorem Zspec_gcd_gt_body: forall a b cont p, + [a] > [b] -> [a] < 2 ^ p -> + (forall a1 b1, [a1] < 2 ^ (p - 1) -> [a1] > [b1] -> + Zis_gcd [a1] [b1] [cont a1 b1]) -> + Zis_gcd [a] [b] [gcd_gt_body a b cont]. + Proof. + assert (F1: [zero] = 0). + unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto. + intros a b cont p H2 H3 H4; unfold gcd_gt_body. + generalize (spec_compare_aux b zero); case compare; try rewrite F1. + intros HH; rewrite HH; apply Zis_gcd_0. + intros HH; absurd (0 <= [b]); auto with zarith. + case (spec_digits b); auto with zarith. + intros H5; generalize (spec_compare_aux (mod_gt a b) zero); + case compare; try rewrite F1. + intros H6; rewrite <- (Zmult_1_r [b]). + rewrite (Z_div_mod_eq [a] [b]); auto with zarith. + rewrite <- spec_mod_gt; auto with zarith. + rewrite H6; rewrite Zplus_0_r. + apply Zis_gcd_mult; apply Zis_gcd_1. + intros; apply False_ind. + case (spec_digits (mod_gt a b)); auto with zarith. + intros H6; apply DoubleDiv.Zis_gcd_mod; auto with zarith. + apply DoubleDiv.Zis_gcd_mod; auto with zarith. + rewrite <- spec_mod_gt; auto with zarith. + assert (F2: [b] > [mod_gt a b]). + case (Z_mod_lt [a] [b]); auto with zarith. + repeat rewrite <- spec_mod_gt; auto with zarith. + assert (F3: [mod_gt a b] > [mod_gt b (mod_gt a b)]). + case (Z_mod_lt [b] [mod_gt a b]); auto with zarith. + rewrite <- spec_mod_gt; auto with zarith. + repeat rewrite <- spec_mod_gt; auto with zarith. + apply H4; auto with zarith. + apply Zmult_lt_reg_r with 2; auto with zarith. + apply Zle_lt_trans with ([b] + [mod_gt a b]); auto with zarith. + apply Zle_lt_trans with (([a]/[b]) * [b] + [mod_gt a b]); auto with zarith. + apply Zplus_le_compat_r. + pattern [b] at 1; rewrite <- (Zmult_1_l [b]). + apply Zmult_le_compat_r; auto with zarith. + case (Zle_lt_or_eq 0 ([a]/[b])); auto with zarith. + intros HH; rewrite (Z_div_mod_eq [a] [b]) in H2; + try rewrite <- HH in H2; auto with zarith. + case (Z_mod_lt [a] [b]); auto with zarith. + rewrite Zmult_comm; rewrite spec_mod_gt; auto with zarith. + rewrite <- Z_div_mod_eq; auto with zarith. + pattern 2 at 2; rewrite <- (Zpower_1_r 2). + rewrite <- Zpower_exp; auto with zarith. + ring_simplify (p - 1 + 1); auto. + case (Zle_lt_or_eq 0 p); auto with zarith. + generalize H3; case p; simpl Zpower; auto with zarith. + intros HH; generalize H3; rewrite <- HH; simpl Zpower; auto with zarith. + Qed. + + Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) {struct p} : t := + gcd_gt_body a b + (fun a b => + match p with + | xH => cont a b + | xO p => gcd_gt_aux p (gcd_gt_aux p cont) a b + | xI p => gcd_gt_aux p (gcd_gt_aux p cont) a b + end). + + Theorem Zspec_gcd_gt_aux: forall p n a b cont, + [a] > [b] -> [a] < 2 ^ (Zpos p + n) -> + (forall a1 b1, [a1] < 2 ^ n -> [a1] > [b1] -> + Zis_gcd [a1] [b1] [cont a1 b1]) -> + Zis_gcd [a] [b] [gcd_gt_aux p cont a b]. + intros p; elim p; clear p. + intros p Hrec n a b cont H2 H3 H4. + unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xI p) + n); auto. + intros a1 b1 H6 H7. + apply Hrec with (Zpos p + n); auto. + replace (Zpos p + (Zpos p + n)) with + (Zpos (xI p) + n - 1); auto. + rewrite Zpos_xI; ring. + intros a2 b2 H9 H10. + apply Hrec with n; auto. + intros p Hrec n a b cont H2 H3 H4. + unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xO p) + n); auto. + intros a1 b1 H6 H7. + apply Hrec with (Zpos p + n - 1); auto. + replace (Zpos p + (Zpos p + n - 1)) with + (Zpos (xO p) + n - 1); auto. + rewrite Zpos_xO; ring. + intros a2 b2 H9 H10. + apply Hrec with (n - 1); auto. + replace (Zpos p + (n - 1)) with + (Zpos p + n - 1); auto with zarith. + intros a3 b3 H12 H13; apply H4; auto with zarith. + apply Zlt_le_trans with (1 := H12). + case (Zle_or_lt 1 n); intros HH. + apply Zpower_le_monotone; auto with zarith. + apply Zle_trans with 0; auto with zarith. + assert (HH1: n - 1 < 0); auto with zarith. + generalize HH1; case (n - 1); auto with zarith. + intros p1 HH2; discriminate. + intros n a b cont H H2 H3. + simpl gcd_gt_aux. + apply Zspec_gcd_gt_body with (n + 1); auto with zarith. + rewrite Zplus_comm; auto. + intros a1 b1 H5 H6; apply H3; auto. + replace n with (n + 1 - 1); auto; try ring. + Qed. + + Definition gcd_cont a b := + match compare one b with + | Eq => one + | _ => a + end. + + Definition gcd_gt a b := gcd_gt_aux (digits a) gcd_cont a b. + + Theorem spec_gcd_gt: forall a b, + [a] > [b] -> [gcd_gt a b] = Zgcd [a] [b]. + Proof. + intros a b H2. + case (spec_digits (gcd_gt a b)); intros H3 H4. + case (spec_digits a); intros H5 H6. + apply sym_equal; apply Zis_gcd_gcd; auto with zarith. + unfold gcd_gt; apply Zspec_gcd_gt_aux with 0; auto with zarith. + intros a1 a2; rewrite Zpower_0_r. + case (spec_digits a2); intros H7 H8; + intros; apply False_ind; auto with zarith. + Qed. + + Definition gcd a b := + match compare a b with + | Eq => a + | Lt => gcd_gt b a + | Gt => gcd_gt a b + end. + + Theorem spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b]. + Proof. + intros a b. + case (spec_digits a); intros H1 H2. + case (spec_digits b); intros H3 H4. + unfold gcd; generalize (spec_compare_aux a b); case compare. + intros HH; rewrite HH; apply sym_equal; apply Zis_gcd_gcd; auto. + apply Zis_gcd_refl. + intros; apply trans_equal with (Zgcd [b] [a]). + apply spec_gcd_gt; auto with zarith. + apply Zis_gcd_gcd; auto with zarith. + apply Zgcd_is_pos. + apply Zis_gcd_sym; apply Zgcd_is_gcd. + intros; apply spec_gcd_gt; auto. + Qed. + + + (** * Conversion *) + + Definition of_N x := + match x with + | BinNat.N0 => zero + | Npos p => of_pos p + end. + + Theorem spec_of_N: forall x, + [of_N x] = Z_of_N x. + Proof. + intros x; case x. + simpl of_N. + unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto. + intros p; exact (spec_of_pos p). + Qed. + + + (** * Shift *) + + Definition shiftr n x := + match compare n (Ndigits x) with + | Lt => unsafe_shiftr n x + | _ => N0 w_0 + end. + + Theorem spec_shiftr: forall n x, + [shiftr n x] = [x] / 2 ^ [n]. + Proof. + intros n x; unfold shiftr; + generalize (spec_compare_aux n (Ndigits x)); case compare; intros H. + apply trans_equal with (1 := spec_0 w0_spec). + apply sym_equal; apply Zdiv_small; rewrite H. + rewrite spec_Ndigits; exact (spec_digits x). + rewrite <- spec_unsafe_shiftr; auto with zarith. + apply trans_equal with (1 := spec_0 w0_spec). + apply sym_equal; apply Zdiv_small. + rewrite spec_Ndigits in H; case (spec_digits x); intros H1 H2. + split; auto. + apply Zlt_le_trans with (1 := H2). + apply Zpower_le_monotone; auto with zarith. + Qed. + + Definition shiftl_aux_body cont n x := + match compare n (head0 x) with + Gt => cont n (double_size x) + | _ => unsafe_shiftl n x + end. + + Theorem spec_shiftl_aux_body: forall n p x cont, + 2^ Zpos p <= [head0 x] -> + (forall x, 2 ^ (Zpos p + 1) <= [head0 x]-> + [cont n x] = [x] * 2 ^ [n]) -> + [shiftl_aux_body cont n x] = [x] * 2 ^ [n]. + Proof. + intros n p x cont H1 H2; unfold shiftl_aux_body. + generalize (spec_compare_aux n (head0 x)); case compare; intros H. + apply spec_unsafe_shiftl; auto with zarith. + apply spec_unsafe_shiftl; auto with zarith. + rewrite H2. + rewrite spec_double_size; auto. + rewrite Zplus_comm; rewrite Zpower_exp; auto with zarith. + apply Zle_trans with (2 := spec_double_size_head0 x). + rewrite Zpower_1_r; apply Zmult_le_compat_l; auto with zarith. + Qed. + + Fixpoint shiftl_aux p cont n x {struct p} := + shiftl_aux_body + (fun n x => match p with + | xH => cont n x + | xO p => shiftl_aux p (shiftl_aux p cont) n x + | xI p => shiftl_aux p (shiftl_aux p cont) n x + end) n x. + + Theorem spec_shiftl_aux: forall p q n x cont, + 2 ^ (Zpos q) <= [head0 x] -> + (forall x, 2 ^ (Zpos p + Zpos q) <= [head0 x] -> + [cont n x] = [x] * 2 ^ [n]) -> + [shiftl_aux p cont n x] = [x] * 2 ^ [n]. + Proof. + intros p; elim p; unfold shiftl_aux; fold shiftl_aux; clear p. + intros p Hrec q n x cont H1 H2. + apply spec_shiftl_aux_body with (q); auto. + intros x1 H3; apply Hrec with (q + 1)%positive; auto. + intros x2 H4; apply Hrec with (p + q + 1)%positive; auto. + rewrite <- Pplus_assoc. + rewrite Zpos_plus_distr; auto. + intros x3 H5; apply H2. + rewrite Zpos_xI. + replace (2 * Zpos p + 1 + Zpos q) with (Zpos p + Zpos (p + q + 1)); + auto. + repeat rewrite Zpos_plus_distr; ring. + intros p Hrec q n x cont H1 H2. + apply spec_shiftl_aux_body with (q); auto. + intros x1 H3; apply Hrec with (q); auto. + apply Zle_trans with (2 := H3); auto with zarith. + apply Zpower_le_monotone; auto with zarith. + intros x2 H4; apply Hrec with (p + q)%positive; auto. + intros x3 H5; apply H2. + rewrite (Zpos_xO p). + replace (2 * Zpos p + Zpos q) with (Zpos p + Zpos (p + q)); + auto. + repeat rewrite Zpos_plus_distr; ring. + intros q n x cont H1 H2. + apply spec_shiftl_aux_body with (q); auto. + rewrite Zplus_comm; auto. + Qed. + + Definition shiftl n x := + shiftl_aux_body + (shiftl_aux_body + (shiftl_aux (digits n) unsafe_shiftl)) n x. + + Theorem spec_shiftl: forall n x, + [shiftl n x] = [x] * 2 ^ [n]. + Proof. + intros n x; unfold shiftl, shiftl_aux_body. + generalize (spec_compare_aux n (head0 x)); case compare; intros H. + apply spec_unsafe_shiftl; auto with zarith. + apply spec_unsafe_shiftl; auto with zarith. + rewrite <- (spec_double_size x). + generalize (spec_compare_aux n (head0 (double_size x))); case compare; intros H1. + apply spec_unsafe_shiftl; auto with zarith. + apply spec_unsafe_shiftl; auto with zarith. + rewrite <- (spec_double_size (double_size x)). + apply spec_shiftl_aux with 1%positive. + apply Zle_trans with (2 := spec_double_size_head0 (double_size x)). + replace (2 ^ 1) with (2 * 1). + apply Zmult_le_compat_l; auto with zarith. + generalize (spec_double_size_head0_pos x); auto with zarith. + rewrite Zpower_1_r; ring. + intros x1 H2; apply spec_unsafe_shiftl. + apply Zle_trans with (2 := H2). + apply Zle_trans with (2 ^ Zpos (digits n)); auto with zarith. + case (spec_digits n); auto with zarith. + apply Zpower_le_monotone; auto with zarith. + Qed. + + + (** * Zero and One *) + + Theorem spec_0: [zero] = 0. + Proof. + exact (spec_0 w0_spec). + Qed. + + Theorem spec_1: [one] = 1. + Proof. + exact (spec_1 w0_spec). + Qed. + + +End Make. diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml index 04c7b96d..b8552a39 100644 --- a/theories/Numbers/Natural/BigN/NMake_gen.ml +++ b/theories/Numbers/Natural/BigN/NMake_gen.ml @@ -8,14 +8,14 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: NMake_gen.ml 11576 2008-11-10 19:13:15Z msozeau $ i*) +(*i $Id$ i*) (*S NMake_gen.ml : this file generates NMake.v *) (*s The two parameters that control the generation: *) -let size = 6 (* how many times should we repeat the Z/nZ --> Z/2nZ +let size = 6 (* how many times should we repeat the Z/nZ --> Z/2nZ process before relying on a generic construct *) let gen_proof = true (* should we generate proofs ? *) @@ -27,18 +27,18 @@ let c = "N" let pz n = if n == 0 then "w_0" else "W0" let rec gen2 n = if n == 0 then "1" else if n == 1 then "2" else "2 * " ^ (gen2 (n - 1)) -let rec genxO n s = +let rec genxO n s = if n == 0 then s else " (xO" ^ (genxO (n - 1) s) ^ ")" -(* NB: in ocaml >= 3.10, we could use Printf.ifprintf for printing to - /dev/null, but for being compatible with earlier ocaml and not - relying on system-dependent stuff like open_out "/dev/null", +(* NB: in ocaml >= 3.10, we could use Printf.ifprintf for printing to + /dev/null, but for being compatible with earlier ocaml and not + relying on system-dependent stuff like open_out "/dev/null", let's use instead a magical hack *) (* Standard printer, with a final newline *) let pr s = Printf.printf (s^^"\n") (* Printing to /dev/null *) -let pn = (fun s -> Obj.magic (fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> ()) +let pn = (fun s -> Obj.magic (fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> ()) : ('a, out_channel, unit) format -> 'a) (* Proof printer : prints iff gen_proof is true *) let pp = if gen_proof then pr else pn @@ -51,7 +51,7 @@ let pp0 = if gen_proof then pr0 else pn (*s The actual printing *) -let _ = +let _ = pr "(************************************************************************)"; pr "(* v * The Coq Proof Assistant / The Coq Development Team *)"; @@ -67,21 +67,13 @@ let _ = pr ""; pr "(** From a cyclic Z/nZ representation to arbitrary precision natural numbers.*)"; pr ""; - pr "(** Remark: File automatically generated by NMake_gen.ml, DO NOT EDIT ! *)"; + pr "(** Remark: File automatically generated by NMake_gen.ml, DO NOT EDIT ! *)"; pr ""; - pr "Require Import BigNumPrelude."; - pr "Require Import ZArith."; - pr "Require Import CyclicAxioms."; - pr "Require Import DoubleType."; - pr "Require Import DoubleMul."; - pr "Require Import DoubleDivn1."; - pr "Require Import DoubleCyclic."; - pr "Require Import Nbasic."; - pr "Require Import Wf_nat."; - pr "Require Import StreamMemo."; - pr "Require Import NSig."; + pr "Require Import BigNumPrelude ZArith CyclicAxioms"; + pr " DoubleType DoubleMul DoubleDivn1 DoubleCyclic Nbasic"; + pr " Wf_nat StreamMemo."; pr ""; - pr "Module Make (Import W0:CyclicType) <: NType."; + pr "Module Make (Import W0:CyclicType)."; pr ""; pr " Definition w0 := W0.w."; @@ -132,7 +124,7 @@ let _ = pr ""; pr " Inductive %s_ :=" t; - for i = 0 to size do + for i = 0 to size do pr " | %s%i : w%i -> %s_" c i i t done; pr " | %sn : forall n, word w%i (S n) -> %s_." c size t; @@ -167,20 +159,20 @@ let _ = pr " Definition to_N x := Zabs_N (to_Z x)."; pr ""; - + pr " Definition eq x y := (to_Z x = to_Z y)."; pr ""; pp " (* Regular make op (no karatsuba) *)"; - pp " Fixpoint nmake_op (ww:Type) (ww_op: znz_op ww) (n: nat) : "; + pp " Fixpoint nmake_op (ww:Type) (ww_op: znz_op ww) (n: nat) :"; pp " znz_op (word ww n) :="; - pp " match n return znz_op (word ww n) with "; + pp " match n return znz_op (word ww n) with"; pp " O => ww_op"; - pp " | S n1 => mk_zn2z_op (nmake_op ww ww_op n1) "; + pp " | S n1 => mk_zn2z_op (nmake_op ww ww_op n1)"; pp " end."; pp ""; pp " (* Simplification by rewriting for nmake_op *)"; - pp " Theorem nmake_op_S: forall ww (w_op: znz_op ww) x, "; + pp " Theorem nmake_op_S: forall ww (w_op: znz_op ww) x,"; pp " nmake_op _ w_op (S x) = mk_zn2z_op (nmake_op _ w_op x)."; pp " auto."; pp " Qed."; @@ -191,7 +183,7 @@ let _ = for i = 0 to size do pp " Let nmake_op%i := nmake_op _ w%i_op." i i; pp " Let eval%in n := znz_to_Z (nmake_op%i n)." i i; - if i == 0 then + if i == 0 then pr " Let extend%i := DoubleBase.extend (WW w_0)." i else pr " Let extend%i := DoubleBase.extend (WW (W0: w%i))." i i; @@ -199,8 +191,8 @@ let _ = pr ""; - pp " Theorem digits_doubled:forall n ww (w_op: znz_op ww), "; - pp " znz_digits (nmake_op _ w_op n) = "; + pp " Theorem digits_doubled:forall n ww (w_op: znz_op ww),"; + pp " znz_digits (nmake_op _ w_op n) ="; pp " DoubleBase.double_digits (znz_digits w_op) n."; pp " Proof."; pp " intros n; elim n; auto; clear n."; @@ -208,7 +200,7 @@ let _ = pp " rewrite <- Hrec; auto."; pp " Qed."; pp ""; - pp " Theorem nmake_double: forall n ww (w_op: znz_op ww), "; + pp " Theorem nmake_double: forall n ww (w_op: znz_op ww),"; pp " znz_to_Z (nmake_op _ w_op n) ="; pp " @DoubleBase.double_to_Z _ (znz_digits w_op) (znz_to_Z w_op) n."; pp " Proof."; @@ -220,8 +212,8 @@ let _ = pp ""; - pp " Theorem digits_nmake:forall n ww (w_op: znz_op ww), "; - pp " znz_digits (nmake_op _ w_op (S n)) = "; + pp " Theorem digits_nmake:forall n ww (w_op: znz_op ww),"; + pp " znz_digits (nmake_op _ w_op (S n)) ="; pp " xO (znz_digits (nmake_op _ w_op n))."; pp " Proof."; pp " auto."; @@ -257,30 +249,30 @@ let _ = pp " (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (omake_op n))))."; pp " rewrite Hrec; auto with arith."; pp " Qed."; - pp " "; + pp ""; for i = 1 to size + 2 do pp " Let znz_to_Z_%i: forall x y," i; - pp " znz_to_Z w%i_op (WW x y) = " i; + pp " znz_to_Z w%i_op (WW x y) =" i; pp " znz_to_Z w%i_op x * base (znz_digits w%i_op) + znz_to_Z w%i_op y." (i-1) (i-1) (i-1); pp " Proof."; pp " auto."; - pp " Qed. "; + pp " Qed."; pp ""; done; pp " Let znz_to_Z_n: forall n x y,"; - pp " znz_to_Z (make_op (S n)) (WW x y) = "; + pp " znz_to_Z (make_op (S n)) (WW x y) ="; pp " znz_to_Z (make_op n) x * base (znz_digits (make_op n)) + znz_to_Z (make_op n) y."; pp " Proof."; pp " intros n x y; rewrite make_op_S; auto."; - pp " Qed. "; + pp " Qed."; pp ""; pp " Let w0_spec: znz_spec w0_op := W0.w_spec."; for i = 1 to 3 do - pp " Let w%i_spec: znz_spec w%i_op := mk_znz2_spec w%i_spec." i i (i-1) + pp " Let w%i_spec: znz_spec w%i_op := mk_znz2_spec w%i_spec." i i (i-1) done; for i = 4 to size + 3 do pp " Let w%i_spec : znz_spec w%i_op := mk_znz2_karatsuba_spec w%i_spec." i i (i-1) @@ -309,14 +301,14 @@ let _ = for i = 0 to size do - pp " Theorem digits_w%i: znz_digits w%i_op = znz_digits (nmake_op _ w0_op %i)." i i i; + pp " Theorem digits_w%i: znz_digits w%i_op = znz_digits (nmake_op _ w0_op %i)." i i i; if i == 0 then pp " auto." else pp " rewrite digits_nmake; rewrite <- digits_w%i; auto." (i - 1); pp " Qed."; pp ""; - pp " Let spec_double_eval%in: forall n, eval%in n = DoubleBase.double_to_Z (znz_digits w%i_op) (znz_to_Z w%i_op) n." i i i i; + pp " Let spec_double_eval%in: forall n, eval%in n = DoubleBase.double_to_Z (znz_digits w%i_op) (znz_to_Z w%i_op) n." i i i i; pp " Proof."; pp " intros n; exact (nmake_double n w%i w%i_op)." i i; pp " Qed."; @@ -325,7 +317,7 @@ let _ = for i = 0 to size do for j = 0 to (size - i) do - pp " Theorem digits_w%in%i: znz_digits w%i_op = znz_digits (nmake_op _ w%i_op %i)." i j (i + j) i j; + pp " Theorem digits_w%in%i: znz_digits w%i_op = znz_digits (nmake_op _ w%i_op %i)." i j (i + j) i j; pp " Proof."; if j == 0 then if i == 0 then @@ -346,7 +338,7 @@ let _ = end; pp " Qed."; pp ""; - pp " Let spec_eval%in%i: forall x, [%s%i x] = eval%in %i x." i j c (i + j) i j; + pp " Let spec_eval%in%i: forall x, [%s%i x] = eval%in %i x." i j c (i + j) i j; pp " Proof."; if j == 0 then pp " intros x; rewrite spec_double_eval%in; unfold DoubleBase.double_to_Z, to_Z; auto." i @@ -363,7 +355,7 @@ let _ = pp " Qed."; if i + j <> size then begin - pp " Let spec_extend%in%i: forall x, [%s%i x] = [%s%i (extend%i %i x)]." i (i + j + 1) c i c (i + j + 1) i j; + pp " Let spec_extend%in%i: forall x, [%s%i x] = [%s%i (extend%i %i x)]." i (i + j + 1) c i c (i + j + 1) i j; if j == 0 then begin pp " intros x; change (extend%i 0 x) with (WW (znz_0 w%i_op) x)." i (i + j); @@ -393,7 +385,7 @@ let _ = pp " Qed."; pp ""; - pp " Let spec_eval%in%i: forall x, [%sn 0 x] = eval%in %i x." i (size - i + 1) c i (size - i + 1); + pp " Let spec_eval%in%i: forall x, [%sn 0 x] = eval%in %i x." i (size - i + 1) c i (size - i + 1); pp " Proof."; pp " intros x; case x."; pp " auto."; @@ -405,7 +397,7 @@ let _ = pp " Qed."; pp ""; - pp " Let spec_eval%in%i: forall x, [%sn 1 x] = eval%in %i x." i (size - i + 2) c i (size - i + 2); + pp " Let spec_eval%in%i: forall x, [%sn 1 x] = eval%in %i x." i (size - i + 2) c i (size - i + 2); pp " intros x; case x."; pp " auto."; pp " intros xh xl; unfold to_Z; rewrite znz_to_Z_%i." (size + 2); @@ -430,7 +422,7 @@ let _ = pp " Qed."; pp ""; - pp " Let spec_eval%in: forall n x, [%sn n x] = eval%in (S n) x." size c size; + pp " Let spec_eval%in: forall n x, [%sn n x] = eval%in (S n) x." size c size; pp " intros n; elim n; clear n."; pp " exact spec_eval%in1." size; pp " intros n Hrec x; case x; clear x."; @@ -446,7 +438,7 @@ let _ = pp " Qed."; pp ""; - pp " Let spec_extend%in: forall n x, [%s%i x] = [%sn n (extend%i n x)]." size c size c size ; + pp " Let spec_extend%in: forall n x, [%s%i x] = [%sn n (extend%i n x)]." size c size c size ; pp " intros n; elim n; clear n."; pp " intros x; change (extend%i 0 x) with (WW (znz_0 w%i_op) x)." size size; pp " unfold to_Z."; @@ -478,7 +470,6 @@ let _ = pp " unfold to_Z."; pp " case n1; auto; intros n2; repeat rewrite make_op_S; auto."; pp " Qed."; - pp " Hint Rewrite spec_extendn_0: extr."; pp ""; pp " Let spec_extendn0_0: forall n wx, [%sn (S n) (WW W0 wx)] = [%sn n wx]." c c; pp " Proof."; @@ -489,7 +480,6 @@ let _ = pp " case n; auto."; pp " intros n1; rewrite make_op_S; auto."; pp " Qed."; - pp " Hint Rewrite spec_extendn_0: extr."; pp ""; pp " Let spec_extend_tr: forall m n (w: word _ (S n)),"; pp " [%sn (m + n) (extend_tr w m)] = [%sn n w]." c c; @@ -498,7 +488,6 @@ let _ = pp " intros n x; simpl extend_tr."; pp " simpl plus; rewrite spec_extendn0_0; auto."; pp " Qed."; - pp " Hint Rewrite spec_extend_tr: extr."; pp ""; pp " Let spec_cast_l: forall n m x1,"; pp " [%sn (Max.max n m)" c; @@ -508,7 +497,6 @@ let _ = pp " intros n m x1; case (diff_r n m); simpl castm."; pp " rewrite spec_extend_tr; auto."; pp " Qed."; - pp " Hint Rewrite spec_cast_l: extr."; pp ""; pp " Let spec_cast_r: forall n m x1,"; pp " [%sn (Max.max n m)" c; @@ -518,7 +506,6 @@ let _ = pp " intros n m x1; case (diff_l n m); simpl castm."; pp " rewrite spec_extend_tr; auto."; pp " Qed."; - pp " Hint Rewrite spec_cast_r: extr."; pp ""; @@ -578,14 +565,14 @@ let _ = pr " | %s%i wx, %s%i wy => f%i (extend%i %i wx) wy" c i c j j i (j - i - 1); done; if i == size then - pr " | %s%i wx, %sn m wy => fnn m (extend%i m wx) wy" c size c size - else + pr " | %s%i wx, %sn m wy => fnn m (extend%i m wx) wy" c size c size + else pr " | %s%i wx, %sn m wy => fnn m (extend%i m (extend%i %i wx)) wy" c i c size i (size - i - 1); done; for i = 0 to size do if i == size then - pr " | %sn n wx, %s%i wy => fnn n wx (extend%i n wy)" c c size size - else + pr " | %sn n wx, %s%i wy => fnn n wx (extend%i n wy)" c c size size + else pr " | %sn n wx, %s%i wy => fnn n wx (extend%i n (extend%i %i wy))" c c i size i (size - i - 1); done; pr " | %sn n wx, Nn m wy =>" c; @@ -611,17 +598,17 @@ let _ = done; if i == size then pp " intros m y; rewrite (spec_extend%in m); apply Pfnn." size - else + else pp " intros m y; rewrite spec_extend%in%i; rewrite (spec_extend%in m); apply Pfnn." i size size; done; pp " intros n x y; case y; clear y."; for i = 0 to size do if i == size then pp " intros y; rewrite (spec_extend%in n); apply Pfnn." size - else + else pp " intros y; rewrite spec_extend%in%i; rewrite (spec_extend%in n); apply Pfnn." i size size; done; - pp " intros m y; rewrite <- (spec_cast_l n m x); "; + pp " intros m y; rewrite <- (spec_cast_l n m x);"; pp " rewrite <- (spec_cast_r n m y); apply Pfnn."; pp " Qed."; pp ""; @@ -644,7 +631,7 @@ let _ = pr " match y with"; for j = 0 to i - 1 do pr " | %s%i wy =>" c j; - if j == 0 then + if j == 0 then pr " if w0_eq0 wy then ft0 x else"; pr " f%i wx (extend%i %i wy)" i j (i - j -1); done; @@ -653,8 +640,8 @@ let _ = pr " | %s%i wy => f%i (extend%i %i wx) wy" c j j i (j - i - 1); done; if i == size then - pr " | %sn m wy => fnn m (extend%i m wx) wy" c size - else + pr " | %sn m wy => fnn m (extend%i m wx) wy" c size + else pr " | %sn m wy => fnn m (extend%i m (extend%i %i wx)) wy" c size i (size - i - 1); pr" end"; done; @@ -665,8 +652,8 @@ let _ = if i == 0 then pr " if w0_eq0 wy then ft0 x else"; if i == size then - pr " fnn n wx (extend%i n wy)" size - else + pr " fnn n wx (extend%i n wy)" size + else pr " fnn n wx (extend%i n (extend%i %i wy))" size i (size - i - 1); done; pr " | %sn m wy =>" c; @@ -707,7 +694,7 @@ let _ = done; if i == size then pp " intros m y; rewrite (spec_extend%in m); apply Pfnn." size - else + else pp " intros m y; rewrite spec_extend%in%i; rewrite (spec_extend%in m); apply Pfnn." i size size; done; pp " intros n x y; case y; clear y."; @@ -721,16 +708,16 @@ let _ = end; if i == size then pp " rewrite (spec_extend%in n); apply Pfnn." size - else + else pp " rewrite spec_extend%in%i; rewrite (spec_extend%in n); apply Pfnn." i size size; done; - pp " intros m y; rewrite <- (spec_cast_l n m x); "; + pp " intros m y; rewrite <- (spec_cast_l n m x);"; pp " rewrite <- (spec_cast_r n m y); apply Pfnn."; pp " Qed."; pp ""; pr " (* We iter the smaller argument with the bigger *)"; - pr " Definition iter (x y: t_): res := "; + pr " Definition iter (x y: t_): res :="; pr0 " Eval lazy zeta beta iota delta ["; for i = 0 to size do pr0 "extend%i " i; @@ -748,14 +735,14 @@ let _ = pr " | %s%i wx, %s%i wy => f%in %i wx wy" c i c j i (j - i - 1); done; if i == size then - pr " | %s%i wx, %sn m wy => f%in m wx wy" c size c size - else + pr " | %s%i wx, %sn m wy => f%in m wx wy" c size c size + else pr " | %s%i wx, %sn m wy => f%in m (extend%i %i wx) wy" c i c size i (size - i - 1); done; for i = 0 to size do if i == size then - pr " | %sn n wx, %s%i wy => fn%i n wx wy" c c size size - else + pr " | %sn n wx, %s%i wy => fn%i n wx wy" c c size size + else pr " | %sn n wx, %s%i wy => fn%i n wx (extend%i %i wy)" c c i size i (size - i - 1); done; pr " | %sn n wx, %sn m wy => fnm n m wx wy" c c; @@ -765,6 +752,7 @@ let _ = pp " Ltac zg_tac := try"; pp " (red; simpl Zcompare; auto;"; pp " let t := fresh \"H\" in (intros t; discriminate t))."; + pp ""; pp " Lemma spec_iter: forall x y, P [x] [y] (iter x y)."; pp " Proof."; pp " intros x; case x; clear x; unfold iter."; @@ -779,14 +767,14 @@ let _ = done; if i == size then pp " intros m y; rewrite spec_eval%in; apply Pf%in." size size - else + else pp " intros m y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pf%in." i size size size; done; pp " intros n x y; case y; clear y."; for i = 0 to size do if i == size then pp " intros y; rewrite spec_eval%in; apply Pfn%i." size size - else + else pp " intros y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pfn%i." i size size size; done; pp " intros m y; apply Pfnm."; @@ -820,8 +808,8 @@ let _ = pr " | %s%i wy => f%in %i wx wy" c j i (j - i - 1); done; if i == size then - pr " | %sn m wy => f%in m wx wy" c size - else + pr " | %sn m wy => f%in m wx wy" c size + else pr " | %sn m wy => f%in m (extend%i %i wx) wy" c size i (size - i - 1); pr " end"; done; @@ -832,8 +820,8 @@ let _ = if i == 0 then pr " if w0_eq0 wy then ft0 x else"; if i == size then - pr " fn%i n wx wy" size - else + pr " fn%i n wx wy" size + else pr " fn%i n wx (extend%i %i wy)" size i (size - i - 1); done; pr " | %sn m wy => fnm n m wx wy" c; @@ -869,7 +857,7 @@ let _ = done; if i == size then pp " intros m y; rewrite spec_eval%in; apply Pf%in." size size - else + else pp " intros m y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pf%in." i size size size; done; pp " intros n x y; case y; clear y."; @@ -883,7 +871,7 @@ let _ = end; if i == size then pp " rewrite spec_eval%in; apply Pfn%i." size size - else + else pp " rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pfn%i." i size size size; done; pp " intros m y; apply Pfnm."; @@ -897,27 +885,27 @@ let _ = pr " (***************************************************************)"; pr " (* *)"; - pr " (* Reduction *)"; + pr " (** * Reduction *)"; pr " (* *)"; pr " (***************************************************************)"; pr ""; - pr " Definition reduce_0 (x:w) := %s0 x." c; + pr " Definition reduce_0 (x:w) := %s0 x." c; pr " Definition reduce_1 :="; pr " Eval lazy beta iota delta[reduce_n1] in"; pr " reduce_n1 _ _ zero w0_eq0 %s0 %s1." c c; for i = 2 to size do pr " Definition reduce_%i :=" i; pr " Eval lazy beta iota delta[reduce_n1] in"; - pr " reduce_n1 _ _ zero w%i_eq0 reduce_%i %s%i." + pr " reduce_n1 _ _ zero w%i_eq0 reduce_%i %s%i." (i-1) (i-1) c i done; pr " Definition reduce_%i :=" (size+1); pr " Eval lazy beta iota delta[reduce_n1] in"; - pr " reduce_n1 _ _ zero w%i_eq0 reduce_%i (%sn 0)." - size size c; + pr " reduce_n1 _ _ zero w%i_eq0 reduce_%i (%sn 0)." + size size c; - pr " Definition reduce_n n := "; + pr " Definition reduce_n n :="; pr " Eval lazy beta iota delta[reduce_n] in"; pr " reduce_n _ _ zero reduce_%i %sn n." (size + 1) c; pr ""; @@ -927,7 +915,7 @@ let _ = pp " intros x; unfold to_Z, reduce_0."; pp " auto."; pp " Qed."; - pp " "; + pp ""; for i = 1 to size + 1 do if i == size + 1 then @@ -938,14 +926,14 @@ let _ = pp " intros x; case x; unfold reduce_%i." i; pp " exact (spec_0 w0_spec)."; pp " intros x1 y1."; - pp " generalize (spec_w%i_eq0 x1); " (i - 1); + pp " generalize (spec_w%i_eq0 x1);" (i - 1); pp " case w%i_eq0; intros H1; auto." (i - 1); - if i <> 1 then + if i <> 1 then pp " rewrite spec_reduce_%i." (i - 1); pp " unfold to_Z; rewrite znz_to_Z_%i." i; pp " unfold to_Z in H1; rewrite H1; auto."; pp " Qed."; - pp " "; + pp ""; done; pp " Let spec_reduce_n: forall n x, [reduce_n n x] = [%sn n x]." c; @@ -959,11 +947,11 @@ let _ = pp " rewrite Hrec."; pp " rewrite spec_extendn0_0; auto."; pp " Qed."; - pp " "; + pp ""; pr " (***************************************************************)"; pr " (* *)"; - pr " (* Successor *)"; + pr " (** * Successor *)"; pr " (* *)"; pr " (***************************************************************)"; pr ""; @@ -983,19 +971,19 @@ let _ = for i = 0 to size-1 do pr " | %s%i wx =>" c i; pr " match w%i_succ_c wx with" i; - pr " | C0 r => %s%i r" c i; + pr " | C0 r => %s%i r" c i; pr " | C1 r => %s%i (WW one%i r)" c (i+1) i; pr " end"; done; pr " | %s%i wx =>" c size; pr " match w%i_succ_c wx with" size; - pr " | C0 r => %s%i r" c size; + pr " | C0 r => %s%i r" c size; pr " | C1 r => %sn 0 (WW one%i r)" c size ; pr " end"; pr " | %sn n wx =>" c; pr " let op := make_op n in"; pr " match op.(znz_succ_c) wx with"; - pr " | C0 r => %sn n r" c; + pr " | C0 r => %sn n r" c; pr " | C1 r => %sn (S n) (WW op.(znz_1) r)" c; pr " end"; pr " end."; @@ -1027,13 +1015,13 @@ let _ = pr " (***************************************************************)"; pr " (* *)"; - pr " (* Adddition *)"; + pr " (** * Adddition *)"; pr " (* *)"; pr " (***************************************************************)"; pr ""; for i = 0 to size do - pr " Definition w%i_add_c := znz_add_c w%i_op." i i; + pr " Definition w%i_add_c := znz_add_c w%i_op." i i; pr " Definition w%i_add x y :=" i; pr " match w%i_add_c x y with" i; pr " | C0 r => %s%i r" c i; @@ -1057,26 +1045,24 @@ let _ = pp " Proof."; pp " intros n m; unfold to_Z, w%i_add, w%i_add_c." i i; pp " generalize (spec_add_c w%i_spec n m); case znz_add_c; auto." i; - pp " intros ww H; rewrite <- H."; + pp " intros ww H; rewrite <- H."; pp " rewrite znz_to_Z_%i; unfold interp_carry;" (i + 1); pp " apply f_equal2 with (f := Zplus); auto;"; pp " apply f_equal2 with (f := Zmult); auto;"; pp " exact (spec_1 w%i_spec)." i; pp " Qed."; - pp " Hint Rewrite spec_w%i_add: addr." i; pp ""; done; pp " Let spec_wn_add: forall n x y, [addn n x y] = [%sn n x] + [%sn n y]." c c; pp " Proof."; pp " intros k n m; unfold to_Z, addn."; pp " generalize (spec_add_c (wn_spec k) n m); case znz_add_c; auto."; - pp " intros ww H; rewrite <- H."; + pp " intros ww H; rewrite <- H."; pp " rewrite (znz_to_Z_n k); unfold interp_carry;"; pp " apply f_equal2 with (f := Zplus); auto;"; pp " apply f_equal2 with (f := Zmult); auto;"; pp " exact (spec_1 (wn_spec k))."; pp " Qed."; - pp " Hint Rewrite spec_wn_add: addr."; pr " Definition add := Eval lazy beta delta [same_level] in"; pr0 " (same_level t_ "; @@ -1101,7 +1087,7 @@ let _ = pr " (***************************************************************)"; pr " (* *)"; - pr " (* Predecessor *)"; + pr " (** * Predecessor *)"; pr " (* *)"; pr " (***************************************************************)"; pr ""; @@ -1116,25 +1102,25 @@ let _ = for i = 0 to size do pr " | %s%i wx =>" c i; pr " match w%i_pred_c wx with" i; - pr " | C0 r => reduce_%i r" i; + pr " | C0 r => reduce_%i r" i; pr " | C1 r => zero"; pr " end"; done; pr " | %sn n wx =>" c; pr " let op := make_op n in"; pr " match op.(znz_pred_c) wx with"; - pr " | C0 r => reduce_n n r"; + pr " | C0 r => reduce_n n r"; pr " | C1 r => zero"; pr " end"; pr " end."; pr ""; - pr " Theorem spec_pred: forall x, 0 < [x] -> [pred x] = [x] - 1."; + pr " Theorem spec_pred_pos : forall x, 0 < [x] -> [pred x] = [x] - 1."; pa " Admitted."; pp " Proof."; pp " intros x; case x; unfold pred."; for i = 0 to size do - pp " intros x1 H1; unfold w%i_pred_c; " i; + pp " intros x1 H1; unfold w%i_pred_c;" i; pp " generalize (spec_pred_c w%i_spec x1); case znz_pred_c; intros y1." i; pp " rewrite spec_reduce_%i; auto." i; pp " unfold interp_carry; unfold to_Z."; @@ -1143,7 +1129,7 @@ let _ = pp " assert (znz_to_Z w%i_op x1 - 1 < 0); auto with zarith." i; pp " unfold to_Z in H1; auto with zarith."; done; - pp " intros n x1 H1; "; + pp " intros n x1 H1;"; pp " generalize (spec_pred_c (wn_spec n) x1); case znz_pred_c; intros y1."; pp " rewrite spec_reduce_n; auto."; pp " unfold interp_carry; unfold to_Z."; @@ -1152,32 +1138,31 @@ let _ = pp " assert (znz_to_Z (make_op n) x1 - 1 < 0); auto with zarith."; pp " unfold to_Z in H1; auto with zarith."; pp " Qed."; - pp " "; - + pp ""; + pp " Let spec_pred0: forall x, [x] = 0 -> [pred x] = 0."; pp " Proof."; pp " intros x; case x; unfold pred."; for i = 0 to size do - pp " intros x1 H1; unfold w%i_pred_c; " i; + pp " intros x1 H1; unfold w%i_pred_c;" i; pp " generalize (spec_pred_c w%i_spec x1); case znz_pred_c; intros y1." i; pp " unfold interp_carry; unfold to_Z."; pp " unfold to_Z in H1; auto with zarith."; pp " case (spec_to_Z w%i_spec y1); intros HH3 HH4; auto with zarith." i; pp " intros; exact (spec_0 w0_spec)."; done; - pp " intros n x1 H1; "; + pp " intros n x1 H1;"; pp " generalize (spec_pred_c (wn_spec n) x1); case znz_pred_c; intros y1."; pp " unfold interp_carry; unfold to_Z."; pp " unfold to_Z in H1; auto with zarith."; pp " case (spec_to_Z (wn_spec n) y1); intros HH3 HH4; auto with zarith."; pp " intros; exact (spec_0 w0_spec)."; pp " Qed."; - pr " "; - + pr ""; pr " (***************************************************************)"; pr " (* *)"; - pr " (* Subtraction *)"; + pr " (** * Subtraction *)"; pr " (* *)"; pr " (***************************************************************)"; pr ""; @@ -1187,7 +1172,7 @@ let _ = done; pr ""; - for i = 0 to size do + for i = 0 to size do pr " Definition w%i_sub x y :=" i; pr " match w%i_sub_c x y with" i; pr " | C0 r => reduce_%i r" i; @@ -1208,8 +1193,8 @@ let _ = pp " Let spec_w%i_sub: forall x y, [%s%i y] <= [%s%i x] -> [w%i_sub x y] = [%s%i x] - [%s%i y]." i c i c i i c i c i; pp " Proof."; pp " intros n m; unfold w%i_sub, w%i_sub_c." i i; - pp " generalize (spec_sub_c w%i_spec n m); case znz_sub_c; " i; - if i == 0 then + pp " generalize (spec_sub_c w%i_spec n m); case znz_sub_c;" i; + if i == 0 then pp " intros x; auto." else pp " intros x; try rewrite spec_reduce_%i; auto." i; @@ -1219,11 +1204,11 @@ let _ = pp " Qed."; pp ""; done; - + pp " Let spec_wn_sub: forall n x y, [%sn n y] <= [%sn n x] -> [subn n x y] = [%sn n x] - [%sn n y]." c c c c; pp " Proof."; pp " intros k n m; unfold subn."; - pp " generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c; "; + pp " generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c;"; pp " intros x; auto."; pp " unfold interp_carry, to_Z."; pp " case (spec_to_Z (wn_spec k) x); intros; auto with zarith."; @@ -1238,7 +1223,7 @@ let _ = pr "subn)."; pr ""; - pr " Theorem spec_sub: forall x y, [y] <= [x] -> [sub x y] = [x] - [y]."; + pr " Theorem spec_sub_pos : forall x y, [y] <= [x] -> [sub x y] = [x] - [y]."; pa " Admitted."; pp " Proof."; pp " unfold sub."; @@ -1255,7 +1240,7 @@ let _ = pp " Let spec_w%i_sub0: forall x y, [%s%i x] < [%s%i y] -> [w%i_sub x y] = 0." i c i c i i; pp " Proof."; pp " intros n m; unfold w%i_sub, w%i_sub_c." i i; - pp " generalize (spec_sub_c w%i_spec n m); case znz_sub_c; " i; + pp " generalize (spec_sub_c w%i_spec n m); case znz_sub_c;" i; pp " intros x; unfold interp_carry."; pp " unfold to_Z; case (spec_to_Z w%i_spec x); intros; auto with zarith." i; pp " intros; unfold to_Z, zero, w_0; rewrite (spec_0 w0_spec); auto."; @@ -1266,7 +1251,7 @@ let _ = pp " Let spec_wn_sub0: forall n x y, [%sn n x] < [%sn n y] -> [subn n x y] = 0." c c; pp " Proof."; pp " intros k n m; unfold subn."; - pp " generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c; "; + pp " generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c;"; pp " intros x; unfold interp_carry."; pp " unfold to_Z; case (spec_to_Z (wn_spec k) x); intros; auto with zarith."; pp " intros; unfold to_Z, w_0; rewrite (spec_0 (w0_spec)); auto."; @@ -1289,7 +1274,7 @@ let _ = pr " (***************************************************************)"; pr " (* *)"; - pr " (* Comparison *)"; + pr " (** * Comparison *)"; pr " (* *)"; pr " (***************************************************************)"; pr ""; @@ -1299,7 +1284,7 @@ let _ = pr " Definition comparen_%i :=" i; pr " compare_mn_1 w%i w%i %s compare_%i (compare_%i %s) compare_%i." i i (pz i) i i (pz i) i done; - pr ""; + pr ""; pr " Definition comparenm n m wx wy :="; pr " let mn := Max.max n m in"; @@ -1310,8 +1295,8 @@ let _ = pr " (castm (diff_l n m) (extend_tr wy (fst d)))."; pr ""; - pr " Definition compare := Eval lazy beta delta [iter] in "; - pr " (iter _ "; + pr " Definition compare := Eval lazy beta delta [iter] in"; + pr " (iter _"; for i = 0 to size do pr " compare_%i" i; pr " (fun n x y => opp_compare (comparen_%i (S n) y x))" i; @@ -1320,15 +1305,9 @@ let _ = pr " comparenm)."; pr ""; - pr " Definition lt n m := compare n m = Lt."; - pr " Definition le n m := compare n m <> Gt."; - pr " Definition min n m := match compare n m with Gt => m | _ => n end."; - pr " Definition max n m := match compare n m with Lt => m | _ => n end."; - pr ""; - for i = 0 to size do pp " Let spec_compare_%i: forall x y," i; - pp " match compare_%i x y with " i; + pp " match compare_%i x y with" i; pp " Eq => [%s%i x] = [%s%i y]" c i c i; pp " | Lt => [%s%i x] < [%s%i y]" c i c i; pp " | Gt => [%s%i x] > [%s%i y]" c i c i; @@ -1337,7 +1316,7 @@ let _ = pp " unfold compare_%i, to_Z; exact (spec_compare w%i_spec)." i i; pp " Qed."; pp ""; - + pp " Let spec_comparen_%i:" i; pp " forall (n : nat) (x : word w%i n) (y : w%i)," i i; pp " match comparen_%i n x y with" i; @@ -1367,16 +1346,16 @@ let _ = pp ""; - pr " Theorem spec_compare: forall x y,"; - pr " match compare x y with "; + pr " Theorem spec_compare_aux: forall x y,"; + pr " match compare x y with"; pr " Eq => [x] = [y]"; pr " | Lt => [x] < [y]"; pr " | Gt => [x] > [y]"; pr " end."; pa " Admitted."; pp " Proof."; - pp " refine (spec_iter _ (fun x y res => "; - pp " match res with "; + pp " refine (spec_iter _ (fun x y res =>"; + pp " match res with"; pp " Eq => x = y"; pp " | Lt => x < y"; pp " | Gt => x > y"; @@ -1387,12 +1366,12 @@ let _ = pp " (fun n => comparen_%i (S n)) _ _ _" i; done; pp " comparenm _)."; - + for i = 0 to size - 1 do pp " exact spec_compare_%i." i; pp " intros n x y H;apply spec_opp_compare; apply spec_comparen_%i." i; pp " intros n x y H; exact (spec_comparen_%i (S n) x y)." i; - done; + done; pp " exact spec_compare_%i." size; pp " intros n x y;apply spec_opp_compare; apply spec_comparen_%i." size; pp " intros n; exact (spec_comparen_%i (S n))." size; @@ -1402,28 +1381,9 @@ let _ = pp " Qed."; pr ""; - pr " Definition eq_bool x y :="; - pr " match compare x y with"; - pr " | Eq => true"; - pr " | _ => false"; - pr " end."; - pr ""; - - - pr " Theorem spec_eq_bool: forall x y,"; - pr " if eq_bool x y then [x] = [y] else [x] <> [y]."; - pa " Admitted."; - pp " Proof."; - pp " intros x y; unfold eq_bool."; - pp " generalize (spec_compare x y); case compare; auto with zarith."; - pp " Qed."; - pr ""; - - - pr " (***************************************************************)"; pr " (* *)"; - pr " (* Multiplication *)"; + pr " (** * Multiplication *)"; pr " (* *)"; pr " (***************************************************************)"; pr ""; @@ -1461,7 +1421,7 @@ let _ = pr " match n return word w%i (S n) -> t_ with" i; for j = 0 to size - i do if (i + j) == size then - begin + begin pr " | %i%s => fun x => %sn 0 x" j "%nat" c; pr " | %i%s => fun x => %sn 1 x" (j + 1) "%nat" c end @@ -1471,7 +1431,7 @@ let _ = pr " | _ => fun _ => N0 w_0"; pr " end."; pr ""; - done; + done; for i = 0 to size - 1 do @@ -1486,7 +1446,7 @@ let _ = pp " repeat rewrite inj_S; unfold Zsucc; auto with zarith."; pp " Qed."; pp ""; - done; + done; for i = 0 to size do @@ -1497,8 +1457,8 @@ let _ = pr " if w%i_eq0 w then %sn n r" i c; pr " else %sn (S n) (WW (extend%i n w) r)." c i; end - else - begin + else + begin pr " if w%i_eq0 w then to_Z%i n r" i i; pr " else to_Z%i (S n) (WW (extend%i n w) r)." i i; end; @@ -1514,10 +1474,10 @@ let _ = pr " (castm (diff_l n m) (extend_tr y (fst d))))."; pr ""; - pr " Definition mul := Eval lazy beta delta [iter0] in "; - pr " (iter0 t_ "; + pr " Definition mul := Eval lazy beta delta [iter0] in"; + pr " (iter0 t_"; for i = 0 to size do - pr " (fun x y => reduce_%i (w%i_mul_c x y)) " (i + 1) i; + pr " (fun x y => reduce_%i (w%i_mul_c x y))" (i + 1) i; pr " (fun n x y => w%i_mul n y x)" i; pr " w%i_mul" i; done; @@ -1556,7 +1516,7 @@ let _ = pp " Qed."; pp ""; done; - + pp " Lemma nmake_op_WW: forall ww ww1 n x y,"; pp " znz_to_Z (nmake_op ww ww1 (S n)) (WW x y) ="; pp " znz_to_Z (nmake_op ww ww1 n) x * base (znz_digits (nmake_op ww ww1 n)) +"; @@ -1564,21 +1524,21 @@ let _ = pp " auto."; pp " Qed."; pp ""; - + for i = 0 to size do pp " Lemma extend%in_spec: forall n x1," i; - pp " znz_to_Z (nmake_op _ w%i_op (S n)) (extend%i n x1) = " i i; + pp " znz_to_Z (nmake_op _ w%i_op (S n)) (extend%i n x1) =" i i; pp " znz_to_Z w%i_op x1." i; pp " Proof."; pp " intros n1 x2; rewrite nmake_double."; pp " unfold extend%i." i; pp " rewrite DoubleBase.spec_extend; auto."; - if i == 0 then + if i == 0 then pp " intros l; simpl; unfold w_0; rewrite (spec_0 w0_spec); ring."; pp " Qed."; pp ""; done; - + pp " Lemma spec_muln:"; pp " forall n (x: word _ (S n)) y,"; pp " [%sn (S n) (znz_mul_c (make_op n) x y)] = [%sn n x] * [%sn n y]." c c c; @@ -1588,12 +1548,13 @@ let _ = pp " rewrite make_op_S."; pp " case znz_mul_c; auto."; pp " Qed."; + pr ""; pr " Theorem spec_mul: forall x y, [mul x y] = [x] * [y]."; pa " Admitted."; pp " Proof."; for i = 0 to size do - pp " assert(F%i: " i; + pp " assert(F%i:" i; pp " forall n x y,"; if i <> size then pp0 " Z_of_nat n <= %i -> " (size - i); @@ -1614,7 +1575,7 @@ let _ = pp " generalize (spec_w%i_eq0 x1); case w%i_eq0; intros HH." i i; pp " unfold to_Z in HH; rewrite HH."; if i == size then - begin + begin pp " rewrite spec_eval%in; unfold eval%in, nmake_op%i; auto." i i i; pp " rewrite spec_eval%in; unfold eval%in, nmake_op%i." i i i end @@ -1627,7 +1588,7 @@ let _ = done; pp " refine (spec_iter0 t_ (fun x y res => [res] = x * y)"; for i = 0 to size do - pp " (fun x y => reduce_%i (w%i_mul_c x y)) " (i + 1) i; + pp " (fun x y => reduce_%i (w%i_mul_c x y))" (i + 1) i; pp " (fun n x y => w%i_mul n y x)" i; pp " w%i_mul _ _ _" i; done; @@ -1643,12 +1604,12 @@ let _ = if i == size then begin pp " intros n x y; rewrite F%i; auto with zarith." i; - pp " intros n x y; rewrite F%i; auto with zarith. " i; + pp " intros n x y; rewrite F%i; auto with zarith." i; end else begin pp " intros n x y H; rewrite F%i; auto with zarith." i; - pp " intros n x y H; rewrite F%i; auto with zarith. " i; + pp " intros n x y H; rewrite F%i; auto with zarith." i; end; done; pp " intros n m x y; unfold mulnm."; @@ -1663,7 +1624,7 @@ let _ = pr " (***************************************************************)"; pr " (* *)"; - pr " (* Square *)"; + pr " (** * Square *)"; pr " (* *)"; pr " (***************************************************************)"; pr ""; @@ -1702,42 +1663,9 @@ let _ = pp "Qed."; pr ""; - pr " (***************************************************************)"; pr " (* *)"; - pr " (* Power *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - pr " Fixpoint power_pos (x:%s) (p:positive) {struct p} : %s :=" t t; - pr " match p with"; - pr " | xH => x"; - pr " | xO p => square (power_pos x p)"; - pr " | xI p => mul (square (power_pos x p)) x"; - pr " end."; - pr ""; - - pr " Theorem spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n."; - pa " Admitted."; - pp " Proof."; - pp " intros x n; generalize x; elim n; clear n x; simpl power_pos."; - pp " intros; rewrite spec_mul; rewrite spec_square; rewrite H."; - pp " rewrite Zpos_xI; rewrite Zpower_exp; auto with zarith."; - pp " rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith."; - pp " rewrite Zpower_2; rewrite Zpower_1_r; auto."; - pp " intros; rewrite spec_square; rewrite H."; - pp " rewrite Zpos_xO; auto with zarith."; - pp " rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith."; - pp " rewrite Zpower_2; auto."; - pp " intros; rewrite Zpower_1_r; auto."; - pp " Qed."; - pp ""; - pr ""; - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (* Square root *)"; + pr " (** * Square root *)"; pr " (* *)"; pr " (***************************************************************)"; pr ""; @@ -1772,26 +1700,26 @@ let _ = pr " (***************************************************************)"; pr " (* *)"; - pr " (* Division *)"; + pr " (** * Division *)"; pr " (* *)"; pr " (***************************************************************)"; - pr ""; + pr ""; for i = 0 to size do pr " Definition w%i_div_gt := w%i_op.(znz_div_gt)." i i done; pr ""; - pp " Let spec_divn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) := "; - pp " (spec_double_divn1 "; + pp " Let spec_divn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) :="; + pp " (spec_double_divn1"; pp " ww_op.(znz_zdigits) ww_op.(znz_0)"; pp " (znz_WW ww_op) ww_op.(znz_head0)"; pp " ww_op.(znz_add_mul_div) ww_op.(znz_div21)"; pp " ww_op.(znz_compare) ww_op.(znz_sub) (znz_to_Z ww_op)"; - pp " (spec_to_Z ww_spec) "; + pp " (spec_to_Z ww_spec)"; pp " (spec_zdigits ww_spec)"; pp " (spec_0 ww_spec) (spec_WW ww_spec) (spec_head0 ww_spec)"; - pp " (spec_add_mul_div ww_spec) (spec_div21 ww_spec) "; + pp " (spec_add_mul_div ww_spec) (spec_div21 ww_spec)"; pp " (CyclicAxioms.spec_compare ww_spec) (CyclicAxioms.spec_sub ww_spec))."; pp ""; @@ -1811,7 +1739,7 @@ let _ = for i = 0 to size do pp " Lemma spec_get_end%i: forall n x y," i; - pp " eval%in n x <= [%s%i y] -> " i c i; + pp " eval%in n x <= [%s%i y] ->" i c i; pp " [%s%i (DoubleBase.get_low %s n x)] = eval%in n x." c i (pz i) i; pp " Proof."; pp " intros n x y H."; @@ -1843,8 +1771,8 @@ let _ = pr ""; pr " Definition div_gt := Eval lazy beta delta [iter] in"; - pr " (iter _ "; - for i = 0 to size do + pr " (iter _"; + for i = 0 to size do pr " div_gt%i" i; pr " (fun n x y => div_gt%i x (DoubleBase.get_low %s (S n) y))" i (pz i); pr " w%i_divn1" i; @@ -1862,10 +1790,10 @@ let _ = pp " forall x y, [x] > [y] -> 0 < [y] ->"; pp " let (q,r) := div_gt x y in"; pp " [x] = [q] * [y] + [r] /\\ 0 <= [r] < [y])."; - pp " refine (spec_iter (t_*t_) (fun x y res => x > y -> 0 < y ->"; + pp " refine (spec_iter (t_*t_) (fun x y res => x > y -> 0 < y ->"; pp " let (q,r) := res in"; pp " x = [q] * y + [r] /\\ 0 <= [r] < y)"; - for i = 0 to size do + for i = 0 to size do pp " div_gt%i" i; pp " (fun n x y => div_gt%i x (DoubleBase.get_low %s (S n) y))" i (pz i); pp " w%i_divn1 _ _ _" i; @@ -1879,11 +1807,11 @@ let _ = pp " intros n x y H2 H3; unfold div_gt%i, w%i_div_gt." i i else pp " intros n x y H1 H2 H3; unfold div_gt%i, w%i_div_gt." i i; - pp " generalize (spec_div_gt w%i_spec x " i; + pp " generalize (spec_div_gt w%i_spec x" i; pp " (DoubleBase.get_low %s (S n) y))." (pz i); - pp0 " "; + pp0 ""; for j = 0 to i do - pp0 "unfold w%i; " (i-j); + pp0 "unfold w%i; " (i-j); done; pp "case znz_div_gt."; pp " intros xx yy H4; repeat rewrite spec_reduce_%i." i; @@ -1897,7 +1825,7 @@ let _ = pp " (spec_divn1 w%i w%i_op w%i_spec (S n) x y H3)." i i i; pp0 " unfold w%i_divn1; " i; for j = 0 to i do - pp0 "unfold w%i; " (i-j); + pp0 "unfold w%i; " (i-j); done; pp "case double_divn1."; pp " intros xx yy H4."; @@ -1936,61 +1864,12 @@ let _ = pp " Qed."; pr ""; - pr " Definition div_eucl x y :="; - pr " match compare x y with"; - pr " | Eq => (one, zero)"; - pr " | Lt => (zero, x)"; - pr " | Gt => div_gt x y"; - pr " end."; - pr ""; - - pr " Theorem spec_div_eucl: forall x y,"; - pr " 0 < [y] ->"; - pr " let (q,r) := div_eucl x y in"; - pr " ([q], [r]) = Zdiv_eucl [x] [y]."; - pa " Admitted."; - pp " Proof."; - pp " assert (F0: [zero] = 0)."; - pp " exact (spec_0 w0_spec)."; - pp " assert (F1: [one] = 1)."; - pp " exact (spec_1 w0_spec)."; - pp " intros x y H; generalize (spec_compare x y);"; - pp " unfold div_eucl; case compare; try rewrite F0;"; - pp " try rewrite F1; intros; auto with zarith."; - pp " rewrite H0; generalize (Z_div_same [y] (Zlt_gt _ _ H))"; - pp " (Z_mod_same [y] (Zlt_gt _ _ H));"; - pp " unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto."; - pp " assert (F2: 0 <= [x] < [y])."; - pp " generalize (spec_pos x); auto."; - pp " generalize (Zdiv_small _ _ F2)"; - pp " (Zmod_small _ _ F2);"; - pp " unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto."; - pp " generalize (spec_div_gt _ _ H0 H); auto."; - pp " unfold Zdiv, Zmod; case Zdiv_eucl; case div_gt."; - pp " intros a b c d (H1, H2); subst; auto."; - pp " Qed."; - pr ""; - - pr " Definition div x y := fst (div_eucl x y)."; - pr ""; - - pr " Theorem spec_div:"; - pr " forall x y, 0 < [y] -> [div x y] = [x] / [y]."; - pa " Admitted."; - pp " Proof."; - pp " intros x y H1; unfold div; generalize (spec_div_eucl x y H1);"; - pp " case div_eucl; simpl fst."; - pp " intros xx yy; unfold Zdiv; case Zdiv_eucl; intros qq rr H; "; - pp " injection H; auto."; - pp " Qed."; - pr ""; - pr " (***************************************************************)"; pr " (* *)"; - pr " (* Modulo *)"; + pr " (** * Modulo *)"; pr " (* *)"; pr " (***************************************************************)"; - pr ""; + pr ""; for i = 0 to size do pr " Definition w%i_mod_gt := w%i_op.(znz_mod_gt)." i i @@ -2015,7 +1894,7 @@ let _ = pr ""; pr " Definition mod_gt := Eval lazy beta delta[iter] in"; - pr " (iter _ "; + pr " (iter _"; for i = 0 to size do pr " (fun x y => reduce_%i (w%i_mod_gt x y))" i i; pr " (fun n x y => reduce_%i (w%i_mod_gt x (DoubleBase.get_low %s (S n) y)))" i i (pz i); @@ -2024,16 +1903,16 @@ let _ = pr " mod_gtnm)."; pr ""; - pp " Let spec_modn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) := "; - pp " (spec_double_modn1 "; + pp " Let spec_modn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) :="; + pp " (spec_double_modn1"; pp " ww_op.(znz_zdigits) ww_op.(znz_0)"; pp " (znz_WW ww_op) ww_op.(znz_head0)"; pp " ww_op.(znz_add_mul_div) ww_op.(znz_div21)"; pp " ww_op.(znz_compare) ww_op.(znz_sub) (znz_to_Z ww_op)"; - pp " (spec_to_Z ww_spec) "; + pp " (spec_to_Z ww_spec)"; pp " (spec_zdigits ww_spec)"; pp " (spec_0 ww_spec) (spec_WW ww_spec) (spec_head0 ww_spec)"; - pp " (spec_add_mul_div ww_spec) (spec_div21 ww_spec) "; + pp " (spec_add_mul_div ww_spec) (spec_div21 ww_spec)"; pp " (CyclicAxioms.spec_compare ww_spec) (CyclicAxioms.spec_sub ww_spec))."; pp ""; @@ -2063,7 +1942,7 @@ let _ = pp " rewrite <- (spec_get_end%i (S n) y x) in H3; auto with zarith." i; if i == size then pp " intros n x y H2 H3; rewrite spec_reduce_%i." i - else + else pp " intros n x y H1 H2 H3; rewrite spec_reduce_%i." i; pp " unfold w%i_modn1, to_Z; rewrite spec_double_eval%in." i i; pp " apply (spec_modn1 _ _ w%i_spec); auto." i; @@ -2079,39 +1958,9 @@ let _ = pp " Qed."; pr ""; - pr " Definition modulo x y := "; - pr " match compare x y with"; - pr " | Eq => zero"; - pr " | Lt => x"; - pr " | Gt => mod_gt x y"; - pr " end."; + pr " (** digits: a measure for gcd *)"; pr ""; - pr " Theorem spec_modulo:"; - pr " forall x y, 0 < [y] -> [modulo x y] = [x] mod [y]."; - pa " Admitted."; - pp " Proof."; - pp " assert (F0: [zero] = 0)."; - pp " exact (spec_0 w0_spec)."; - pp " assert (F1: [one] = 1)."; - pp " exact (spec_1 w0_spec)."; - pp " intros x y H; generalize (spec_compare x y);"; - pp " unfold modulo; case compare; try rewrite F0;"; - pp " try rewrite F1; intros; try split; auto with zarith."; - pp " rewrite H0; apply sym_equal; apply Z_mod_same; auto with zarith."; - pp " apply sym_equal; apply Zmod_small; auto with zarith."; - pp " generalize (spec_pos x); auto with zarith."; - pp " apply spec_mod_gt; auto."; - pp " Qed."; - pr ""; - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (* Gcd *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - pr " Definition digits x :="; pr " match x with"; for i = 0 to size do @@ -2134,189 +1983,18 @@ let _ = pp " Qed."; pr ""; - pr " Definition gcd_gt_body a b cont :="; - pr " match compare b zero with"; - pr " | Gt =>"; - pr " let r := mod_gt a b in"; - pr " match compare r zero with"; - pr " | Gt => cont r (mod_gt b r)"; - pr " | _ => b"; - pr " end"; - pr " | _ => a"; - pr " end."; - pr ""; - - pp " Theorem Zspec_gcd_gt_body: forall a b cont p,"; - pp " [a] > [b] -> [a] < 2 ^ p ->"; - pp " (forall a1 b1, [a1] < 2 ^ (p - 1) -> [a1] > [b1] ->"; - pp " Zis_gcd [a1] [b1] [cont a1 b1]) -> "; - pp " Zis_gcd [a] [b] [gcd_gt_body a b cont]."; - pp " Proof."; - pp " assert (F1: [zero] = 0)."; - pp " unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto."; - pp " intros a b cont p H2 H3 H4; unfold gcd_gt_body."; - pp " generalize (spec_compare b zero); case compare; try rewrite F1."; - pp " intros HH; rewrite HH; apply Zis_gcd_0."; - pp " intros HH; absurd (0 <= [b]); auto with zarith."; - pp " case (spec_digits b); auto with zarith."; - pp " intros H5; generalize (spec_compare (mod_gt a b) zero); "; - pp " case compare; try rewrite F1."; - pp " intros H6; rewrite <- (Zmult_1_r [b])."; - pp " rewrite (Z_div_mod_eq [a] [b]); auto with zarith."; - pp " rewrite <- spec_mod_gt; auto with zarith."; - pp " rewrite H6; rewrite Zplus_0_r."; - pp " apply Zis_gcd_mult; apply Zis_gcd_1."; - pp " intros; apply False_ind."; - pp " case (spec_digits (mod_gt a b)); auto with zarith."; - pp " intros H6; apply DoubleDiv.Zis_gcd_mod; auto with zarith."; - pp " apply DoubleDiv.Zis_gcd_mod; auto with zarith."; - pp " rewrite <- spec_mod_gt; auto with zarith."; - pp " assert (F2: [b] > [mod_gt a b])."; - pp " case (Z_mod_lt [a] [b]); auto with zarith."; - pp " repeat rewrite <- spec_mod_gt; auto with zarith."; - pp " assert (F3: [mod_gt a b] > [mod_gt b (mod_gt a b)])."; - pp " case (Z_mod_lt [b] [mod_gt a b]); auto with zarith."; - pp " rewrite <- spec_mod_gt; auto with zarith."; - pp " repeat rewrite <- spec_mod_gt; auto with zarith."; - pp " apply H4; auto with zarith."; - pp " apply Zmult_lt_reg_r with 2; auto with zarith."; - pp " apply Zle_lt_trans with ([b] + [mod_gt a b]); auto with zarith."; - pp " apply Zle_lt_trans with (([a]/[b]) * [b] + [mod_gt a b]); auto with zarith."; - pp " apply Zplus_le_compat_r."; - pp " pattern [b] at 1; rewrite <- (Zmult_1_l [b])."; - pp " apply Zmult_le_compat_r; auto with zarith."; - pp " case (Zle_lt_or_eq 0 ([a]/[b])); auto with zarith."; - pp " intros HH; rewrite (Z_div_mod_eq [a] [b]) in H2;"; - pp " try rewrite <- HH in H2; auto with zarith."; - pp " case (Z_mod_lt [a] [b]); auto with zarith."; - pp " rewrite Zmult_comm; rewrite spec_mod_gt; auto with zarith."; - pp " rewrite <- Z_div_mod_eq; auto with zarith."; - pp " pattern 2 at 2; rewrite <- (Zpower_1_r 2)."; - pp " rewrite <- Zpower_exp; auto with zarith."; - pp " ring_simplify (p - 1 + 1); auto."; - pp " case (Zle_lt_or_eq 0 p); auto with zarith."; - pp " generalize H3; case p; simpl Zpower; auto with zarith."; - pp " intros HH; generalize H3; rewrite <- HH; simpl Zpower; auto with zarith."; - pp " Qed."; - pp ""; - - pr " Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) {struct p} : t :="; - pr " gcd_gt_body a b"; - pr " (fun a b =>"; - pr " match p with"; - pr " | xH => cont a b"; - pr " | xO p => gcd_gt_aux p (gcd_gt_aux p cont) a b"; - pr " | xI p => gcd_gt_aux p (gcd_gt_aux p cont) a b"; - pr " end)."; - pr ""; - - pp " Theorem Zspec_gcd_gt_aux: forall p n a b cont,"; - pp " [a] > [b] -> [a] < 2 ^ (Zpos p + n) ->"; - pp " (forall a1 b1, [a1] < 2 ^ n -> [a1] > [b1] ->"; - pp " Zis_gcd [a1] [b1] [cont a1 b1]) ->"; - pp " Zis_gcd [a] [b] [gcd_gt_aux p cont a b]."; - pp " intros p; elim p; clear p."; - pp " intros p Hrec n a b cont H2 H3 H4."; - pp " unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xI p) + n); auto."; - pp " intros a1 b1 H6 H7."; - pp " apply Hrec with (Zpos p + n); auto."; - pp " replace (Zpos p + (Zpos p + n)) with"; - pp " (Zpos (xI p) + n - 1); auto."; - pp " rewrite Zpos_xI; ring."; - pp " intros a2 b2 H9 H10."; - pp " apply Hrec with n; auto."; - pp " intros p Hrec n a b cont H2 H3 H4."; - pp " unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xO p) + n); auto."; - pp " intros a1 b1 H6 H7."; - pp " apply Hrec with (Zpos p + n - 1); auto."; - pp " replace (Zpos p + (Zpos p + n - 1)) with"; - pp " (Zpos (xO p) + n - 1); auto."; - pp " rewrite Zpos_xO; ring."; - pp " intros a2 b2 H9 H10."; - pp " apply Hrec with (n - 1); auto."; - pp " replace (Zpos p + (n - 1)) with"; - pp " (Zpos p + n - 1); auto with zarith."; - pp " intros a3 b3 H12 H13; apply H4; auto with zarith."; - pp " apply Zlt_le_trans with (1 := H12)."; - pp " case (Zle_or_lt 1 n); intros HH."; - pp " apply Zpower_le_monotone; auto with zarith."; - pp " apply Zle_trans with 0; auto with zarith."; - pp " assert (HH1: n - 1 < 0); auto with zarith."; - pp " generalize HH1; case (n - 1); auto with zarith."; - pp " intros p1 HH2; discriminate."; - pp " intros n a b cont H H2 H3."; - pp " simpl gcd_gt_aux."; - pp " apply Zspec_gcd_gt_body with (n + 1); auto with zarith."; - pp " rewrite Zplus_comm; auto."; - pp " intros a1 b1 H5 H6; apply H3; auto."; - pp " replace n with (n + 1 - 1); auto; try ring."; - pp " Qed."; - pp ""; - - pr " Definition gcd_cont a b :="; - pr " match compare one b with"; - pr " | Eq => one"; - pr " | _ => a"; - pr " end."; - pr ""; - - pr " Definition gcd_gt a b := gcd_gt_aux (digits a) gcd_cont a b."; - pr ""; - - pr " Theorem spec_gcd_gt: forall a b,"; - pr " [a] > [b] -> [gcd_gt a b] = Zgcd [a] [b]."; - pa " Admitted."; - pp " Proof."; - pp " intros a b H2."; - pp " case (spec_digits (gcd_gt a b)); intros H3 H4."; - pp " case (spec_digits a); intros H5 H6."; - pp " apply sym_equal; apply Zis_gcd_gcd; auto with zarith."; - pp " unfold gcd_gt; apply Zspec_gcd_gt_aux with 0; auto with zarith."; - pp " intros a1 a2; rewrite Zpower_0_r."; - pp " case (spec_digits a2); intros H7 H8;"; - pp " intros; apply False_ind; auto with zarith."; - pp " Qed."; - pr ""; - - pr " Definition gcd a b :="; - pr " match compare a b with"; - pr " | Eq => a"; - pr " | Lt => gcd_gt b a"; - pr " | Gt => gcd_gt a b"; - pr " end."; - pr ""; - - pr " Theorem spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b]."; - pa " Admitted."; - pp " Proof."; - pp " intros a b."; - pp " case (spec_digits a); intros H1 H2."; - pp " case (spec_digits b); intros H3 H4."; - pp " unfold gcd; generalize (spec_compare a b); case compare."; - pp " intros HH; rewrite HH; apply sym_equal; apply Zis_gcd_gcd; auto."; - pp " apply Zis_gcd_refl."; - pp " intros; apply trans_equal with (Zgcd [b] [a])."; - pp " apply spec_gcd_gt; auto with zarith."; - pp " apply Zis_gcd_gcd; auto with zarith."; - pp " apply Zgcd_is_pos."; - pp " apply Zis_gcd_sym; apply Zgcd_is_gcd."; - pp " intros; apply spec_gcd_gt; auto."; - pp " Qed."; - pr ""; - - pr " (***************************************************************)"; pr " (* *)"; - pr " (* Conversion *)"; + pr " (** * Conversion *)"; pr " (* *)"; pr " (***************************************************************)"; pr ""; - pr " Definition pheight p := "; + pr " Definition pheight p :="; pr " Peano.pred (nat_of_P (get_height w0_op.(znz_digits) (plength p)))."; pr ""; - pr " Theorem pheight_correct: forall p, "; + pr " Theorem pheight_correct: forall p,"; pr " Zpos p < 2 ^ (Zpos (znz_digits w0_op) * 2 ^ (Z_of_nat (pheight p)))."; pr " Proof."; pr " intros p; unfold pheight."; @@ -2400,30 +2078,12 @@ let _ = pp " Qed."; pr ""; - pr " Definition of_N x :="; - pr " match x with"; - pr " | BinNat.N0 => zero"; - pr " | Npos p => of_pos p"; - pr " end."; - pr ""; - - pr " Theorem spec_of_N: forall x,"; - pr " [of_N x] = Z_of_N x."; - pa " Admitted."; - pp " Proof."; - pp " intros x; case x."; - pp " simpl of_N."; - pp " unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto."; - pp " intros p; exact (spec_of_pos p)."; - pp " Qed."; - pr ""; - pr " (***************************************************************)"; pr " (* *)"; - pr " (* Shift *)"; + pr " (** * Shift *)"; pr " (* *)"; pr " (***************************************************************)"; - pr ""; + pr ""; (* Head0 *) pr " Definition head0 w := match w with"; @@ -2443,21 +2103,21 @@ let _ = done; pp " intros n x; rewrite spec_reduce_n; exact (spec_head00 (wn_spec n) x)."; pp " Qed."; - pr " "; + pr ""; pr " Theorem spec_head0: forall x, 0 < [x] ->"; pr " 2 ^ (Zpos (digits x) - 1) <= 2 ^ [head0 x] * [x] < 2 ^ Zpos (digits x)."; pa " Admitted."; pp " Proof."; pp " assert (F0: forall x, (x - 1) + 1 = x)."; - pp " intros; ring. "; + pp " intros; ring."; pp " intros x; case x; unfold digits, head0; clear x."; for i = 0 to size do pp " intros x Hx; rewrite spec_reduce_%i." i; pp " assert (F1:= spec_more_than_1_digit w%i_spec)." i; pp " generalize (spec_head0 w%i_spec x Hx)." i; pp " unfold base."; - pp " pattern (Zpos (znz_digits w%i_op)) at 1; " i; + pp " pattern (Zpos (znz_digits w%i_op)) at 1;" i; pp " rewrite <- (fun x => (F0 (Zpos x)))."; pp " rewrite Zpower_exp; auto with zarith."; pp " rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith."; @@ -2466,7 +2126,7 @@ let _ = pp " assert (F1:= spec_more_than_1_digit (wn_spec n))."; pp " generalize (spec_head0 (wn_spec n) x Hx)."; pp " unfold base."; - pp " pattern (Zpos (znz_digits (make_op n))) at 1; "; + pp " pattern (Zpos (znz_digits (make_op n))) at 1;"; pp " rewrite <- (fun x => (F0 (Zpos x)))."; pp " rewrite Zpower_exp; auto with zarith."; pp " rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith."; @@ -2493,7 +2153,7 @@ let _ = done; pp " intros n x; rewrite spec_reduce_n; exact (spec_tail00 (wn_spec n) x)."; pp " Qed."; - pr " "; + pr ""; pr " Theorem spec_tail0: forall x,"; @@ -2513,7 +2173,7 @@ let _ = pr " Definition %sdigits x :=" c; pr " match x with"; pr " | %s0 _ => %s0 w0_op.(znz_zdigits)" c c; - for i = 1 to size do + for i = 1 to size do pr " | %s%i _ => reduce_%i w%i_op.(znz_zdigits)" c i i i; done; pr " | %sn n _ => reduce_n n (make_op n).(znz_zdigits)" c; @@ -2534,22 +2194,22 @@ let _ = (* Shiftr *) for i = 0 to size do - pr " Definition shiftr%i n x := w%i_op.(znz_add_mul_div) (w%i_op.(znz_sub) w%i_op.(znz_zdigits) n) w%i_op.(znz_0) x." i i i i i; + pr " Definition unsafe_shiftr%i n x := w%i_op.(znz_add_mul_div) (w%i_op.(znz_sub) w%i_op.(znz_zdigits) n) w%i_op.(znz_0) x." i i i i i; done; - pr " Definition shiftrn n p x := (make_op n).(znz_add_mul_div) ((make_op n).(znz_sub) (make_op n).(znz_zdigits) p) (make_op n).(znz_0) x."; + pr " Definition unsafe_shiftrn n p x := (make_op n).(znz_add_mul_div) ((make_op n).(znz_sub) (make_op n).(znz_zdigits) p) (make_op n).(znz_0) x."; pr ""; - pr " Definition shiftr := Eval lazy beta delta [same_level] in "; - pr " same_level _ (fun n x => %s0 (shiftr0 n x))" c; + pr " Definition unsafe_shiftr := Eval lazy beta delta [same_level] in"; + pr " same_level _ (fun n x => %s0 (unsafe_shiftr0 n x))" c; for i = 1 to size do - pr " (fun n x => reduce_%i (shiftr%i n x))" i i; + pr " (fun n x => reduce_%i (unsafe_shiftr%i n x))" i i; done; - pr " (fun n p x => reduce_n n (shiftrn n p x))."; + pr " (fun n p x => reduce_n n (unsafe_shiftrn n p x))."; pr ""; - pr " Theorem spec_shiftr: forall n x,"; - pr " [n] <= [Ndigits x] -> [shiftr n x] = [x] / 2 ^ [n]."; + pr " Theorem spec_unsafe_shiftr: forall n x,"; + pr " [n] <= [Ndigits x] -> [unsafe_shiftr n x] = [x] / 2 ^ [n]."; pa " Admitted."; pp " Proof."; pp " assert (F0: forall x y, x - (x - y) = y)."; @@ -2568,7 +2228,7 @@ let _ = pp " split; auto with zarith."; pp " apply Zle_lt_trans with xx; auto with zarith."; pp " apply Zpower2_lt_lin; auto with zarith."; - pp " assert (F4: forall ww ww1 ww2 "; + pp " assert (F4: forall ww ww1 ww2"; pp " (ww_op: znz_op ww) (ww1_op: znz_op ww1) (ww2_op: znz_op ww2)"; pp " xx yy xx1 yy1,"; pp " znz_to_Z ww2_op yy <= znz_to_Z ww1_op (znz_zdigits ww1_op) ->"; @@ -2586,7 +2246,7 @@ let _ = pp " rewrite <- Hy."; pp " generalize (spec_add_mul_div Hw"; pp " (znz_0 ww_op) xx1"; - pp " (znz_sub ww_op (znz_zdigits ww_op) "; + pp " (znz_sub ww_op (znz_zdigits ww_op)"; pp " yy1)"; pp " )."; pp " rewrite (spec_0 Hw)."; @@ -2612,11 +2272,11 @@ let _ = pp " rewrite Zpos_xO."; pp " assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith." size; pp " apply F5; auto with arith."; - pp " intros x; case x; clear x; unfold shiftr, same_level."; + pp " intros x; case x; clear x; unfold unsafe_shiftr, same_level."; for i = 0 to size do pp " intros x y; case y; clear y."; for j = 0 to i - 1 do - pp " intros y; unfold shiftr%i, Ndigits." i; + pp " intros y; unfold unsafe_shiftr%i, Ndigits." i; pp " repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i j; pp " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." i j i; pp " rewrite (spec_zdigits w%i_spec)." i; @@ -2628,25 +2288,25 @@ let _ = pp " try (apply sym_equal; exact (spec_extend%in%i y))." j i; done; - pp " intros y; unfold shiftr%i, Ndigits." i; + pp " intros y; unfold unsafe_shiftr%i, Ndigits." i; pp " repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i; pp " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." i i i; for j = i + 1 to size do - pp " intros y; unfold shiftr%i, Ndigits." j; + pp " intros y; unfold unsafe_shiftr%i, Ndigits." j; pp " repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i j; pp " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." j j i; pp " try (apply sym_equal; exact (spec_extend%in%i x))." i j; done; if i == size then begin - pp " intros m y; unfold shiftrn, Ndigits."; + pp " intros m y; unfold unsafe_shiftrn, Ndigits."; pp " repeat rewrite spec_reduce_n; unfold to_Z; intros H1."; pp " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." size; pp " try (apply sym_equal; exact (spec_extend%in m x))." size; end - else + else begin - pp " intros m y; unfold shiftrn, Ndigits."; + pp " intros m y; unfold unsafe_shiftrn, Ndigits."; pp " repeat rewrite spec_reduce_n; unfold to_Z; intros H1."; pp " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." i; pp " change ([Nn m (extend%i m (extend%i %i x))] = [N%i x])." size i (size - i - 1) i; @@ -2654,7 +2314,7 @@ let _ = end done; pp " intros n x y; case y; clear y;"; - pp " intros y; unfold shiftrn, Ndigits; try rewrite spec_reduce_n."; + pp " intros y; unfold unsafe_shiftrn, Ndigits; try rewrite spec_reduce_n."; for i = 0 to size do pp " try rewrite spec_reduce_%i; unfold to_Z; intros H1." i; pp " apply F4 with (3:=(wn_spec n))(4:=w%i_spec)(5:=wn_spec n); auto with zarith." i; @@ -2684,52 +2344,23 @@ let _ = pp " Qed."; pr ""; - pr " Definition safe_shiftr n x := "; - pr " match compare n (Ndigits x) with"; - pr " | Lt => shiftr n x "; - pr " | _ => %s0 w_0" c; - pr " end."; - pr ""; - - - pr " Theorem spec_safe_shiftr: forall n x,"; - pr " [safe_shiftr n x] = [x] / 2 ^ [n]."; - pa " Admitted."; - pp " Proof."; - pp " intros n x; unfold safe_shiftr;"; - pp " generalize (spec_compare n (Ndigits x)); case compare; intros H."; - pp " apply trans_equal with (1 := spec_0 w0_spec)."; - pp " apply sym_equal; apply Zdiv_small; rewrite H."; - pp " rewrite spec_Ndigits; exact (spec_digits x)."; - pp " rewrite <- spec_shiftr; auto with zarith."; - pp " apply trans_equal with (1 := spec_0 w0_spec)."; - pp " apply sym_equal; apply Zdiv_small."; - pp " rewrite spec_Ndigits in H; case (spec_digits x); intros H1 H2."; - pp " split; auto."; - pp " apply Zlt_le_trans with (1 := H2)."; - pp " apply Zpower_le_monotone; auto with zarith."; - pp " Qed."; - pr ""; - - pr ""; - - (* Shiftl *) + (* Unsafe_Shiftl *) for i = 0 to size do - pr " Definition shiftl%i n x := w%i_op.(znz_add_mul_div) n x w%i_op.(znz_0)." i i i + pr " Definition unsafe_shiftl%i n x := w%i_op.(znz_add_mul_div) n x w%i_op.(znz_0)." i i i done; - pr " Definition shiftln n p x := (make_op n).(znz_add_mul_div) p x (make_op n).(znz_0)."; - pr " Definition shiftl := Eval lazy beta delta [same_level] in"; - pr " same_level _ (fun n x => %s0 (shiftl0 n x))" c; + pr " Definition unsafe_shiftln n p x := (make_op n).(znz_add_mul_div) p x (make_op n).(znz_0)."; + pr " Definition unsafe_shiftl := Eval lazy beta delta [same_level] in"; + pr " same_level _ (fun n x => %s0 (unsafe_shiftl0 n x))" c; for i = 1 to size do - pr " (fun n x => reduce_%i (shiftl%i n x))" i i; + pr " (fun n x => reduce_%i (unsafe_shiftl%i n x))" i i; done; - pr " (fun n p x => reduce_n n (shiftln n p x))."; + pr " (fun n p x => reduce_n n (unsafe_shiftln n p x))."; pr ""; pr ""; - pr " Theorem spec_shiftl: forall n x,"; - pr " [n] <= [head0 x] -> [shiftl n x] = [x] * 2 ^ [n]."; + pr " Theorem spec_unsafe_shiftl: forall n x,"; + pr " [n] <= [head0 x] -> [unsafe_shiftl n x] = [x] * 2 ^ [n]."; pa " Admitted."; pp " Proof."; pp " assert (F0: forall x y, x - (x - y) = y)."; @@ -2748,7 +2379,7 @@ let _ = pp " split; auto with zarith."; pp " apply Zle_lt_trans with xx; auto with zarith."; pp " apply Zpower2_lt_lin; auto with zarith."; - pp " assert (F4: forall ww ww1 ww2 "; + pp " assert (F4: forall ww ww1 ww2"; pp " (ww_op: znz_op ww) (ww1_op: znz_op ww1) (ww2_op: znz_op ww2)"; pp " xx yy xx1 yy1,"; pp " znz_to_Z ww2_op yy <= znz_to_Z ww1_op (znz_head0 ww1_op xx) ->"; @@ -2788,7 +2419,7 @@ let _ = pp " rewrite Zmod_small; auto with zarith."; pp " intros HH; apply HH."; pp " rewrite Hy; apply Zle_trans with (1:= Hl)."; - pp " rewrite <- (spec_zdigits Hw). "; + pp " rewrite <- (spec_zdigits Hw)."; pp " apply Zle_trans with (2 := Hl1); auto."; pp " rewrite (spec_zdigits Hw1); auto with zarith."; pp " split; auto with zarith ."; @@ -2826,11 +2457,11 @@ let _ = pp " rewrite Zpos_xO."; pp " assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith." size; pp " apply F5; auto with arith."; - pp " intros x; case x; clear x; unfold shiftl, same_level."; + pp " intros x; case x; clear x; unfold unsafe_shiftl, same_level."; for i = 0 to size do pp " intros x y; case y; clear y."; for j = 0 to i - 1 do - pp " intros y; unfold shiftl%i, head0." i; + pp " intros y; unfold unsafe_shiftl%i, head0." i; pp " repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i j; pp " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." i j i; pp " rewrite (spec_zdigits w%i_spec)." i; @@ -2841,25 +2472,25 @@ let _ = pp " assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith." j; pp " try (apply sym_equal; exact (spec_extend%in%i y))." j i; done; - pp " intros y; unfold shiftl%i, head0." i; + pp " intros y; unfold unsafe_shiftl%i, head0." i; pp " repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i; pp " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." i i i; for j = i + 1 to size do - pp " intros y; unfold shiftl%i, head0." j; + pp " intros y; unfold unsafe_shiftl%i, head0." j; pp " repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i j; pp " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." j j i; pp " try (apply sym_equal; exact (spec_extend%in%i x))." i j; done; if i == size then begin - pp " intros m y; unfold shiftln, head0."; + pp " intros m y; unfold unsafe_shiftln, head0."; pp " repeat rewrite spec_reduce_n; unfold to_Z; intros H1."; pp " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." size; pp " try (apply sym_equal; exact (spec_extend%in m x))." size; end - else + else begin - pp " intros m y; unfold shiftln, head0."; + pp " intros m y; unfold unsafe_shiftln, head0."; pp " repeat rewrite spec_reduce_n; unfold to_Z; intros H1."; pp " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." i; pp " change ([Nn m (extend%i m (extend%i %i x))] = [N%i x])." size i (size - i - 1) i; @@ -2867,7 +2498,7 @@ let _ = end done; pp " intros n x y; case y; clear y;"; - pp " intros y; unfold shiftln, head0; try rewrite spec_reduce_n."; + pp " intros y; unfold unsafe_shiftln, head0; try rewrite spec_reduce_n."; for i = 0 to size do pp " try rewrite spec_reduce_%i; unfold to_Z; intros H1." i; pp " apply F4 with (3:=(wn_spec n))(4:=w%i_spec)(5:=wn_spec n); auto with zarith." i; @@ -2907,7 +2538,7 @@ let _ = pr " end."; pr ""; - pr " Theorem spec_double_size_digits: "; + pr " Theorem spec_double_size_digits:"; pr " forall x, digits (double_size x) = xO (digits x)."; pa " Admitted."; pp " Proof."; @@ -2922,7 +2553,7 @@ let _ = pp " Proof."; pp " intros x; case x; unfold double_size; clear x."; for i = 0 to size do - pp " intros x; unfold to_Z, make_op; "; + pp " intros x; unfold to_Z, make_op;"; pp " rewrite znz_to_Z_%i; rewrite (spec_0 w%i_spec); auto with zarith." (i + 1) i; done; pp " intros n x; unfold to_Z;"; @@ -2934,7 +2565,7 @@ let _ = pr ""; - pr " Theorem spec_double_size_head0: "; + pr " Theorem spec_double_size_head0:"; pr " forall x, 2 * [head0 x] <= [head0 (double_size x)]."; pa " Admitted."; pp " Proof."; @@ -2963,7 +2594,7 @@ let _ = pp " apply Zmult_le_compat_l; auto with zarith."; pp " rewrite Zpower_1_r; auto with zarith."; pp " apply Zpower_le_monotone; auto with zarith."; - pp " split; auto with zarith. "; + pp " split; auto with zarith."; pp " case (Zle_or_lt (Zpos (digits x)) [head0 x]); auto with zarith; intros HH6."; pp " absurd (2 ^ Zpos (digits x) <= 2 ^ [head0 x] * [x]); auto with zarith."; pp " rewrite <- HH5; rewrite Zmult_1_r."; @@ -2988,7 +2619,7 @@ let _ = pp " Qed."; pr ""; - pr " Theorem spec_double_size_head0_pos: "; + pr " Theorem spec_double_size_head0_pos:"; pr " forall x, 0 < [head0 (double_size x)]."; pa " Admitted."; pp " Proof."; @@ -3015,114 +2646,6 @@ let _ = pp " Qed."; pr ""; - - (* Safe shiftl *) - - pr " Definition safe_shiftl_aux_body cont n x :="; - pr " match compare n (head0 x) with"; - pr " Gt => cont n (double_size x)"; - pr " | _ => shiftl n x"; - pr " end."; - pr ""; - - pr " Theorem spec_safe_shift_aux_body: forall n p x cont,"; - pr " 2^ Zpos p <= [head0 x] ->"; - pr " (forall x, 2 ^ (Zpos p + 1) <= [head0 x]->"; - pr " [cont n x] = [x] * 2 ^ [n]) ->"; - pr " [safe_shiftl_aux_body cont n x] = [x] * 2 ^ [n]."; - pa " Admitted."; - pp " Proof."; - pp " intros n p x cont H1 H2; unfold safe_shiftl_aux_body."; - pp " generalize (spec_compare n (head0 x)); case compare; intros H."; - pp " apply spec_shiftl; auto with zarith."; - pp " apply spec_shiftl; auto with zarith."; - pp " rewrite H2."; - pp " rewrite spec_double_size; auto."; - pp " rewrite Zplus_comm; rewrite Zpower_exp; auto with zarith."; - pp " apply Zle_trans with (2 := spec_double_size_head0 x)."; - pp " rewrite Zpower_1_r; apply Zmult_le_compat_l; auto with zarith."; - pp " Qed."; - pr ""; - - pr " Fixpoint safe_shiftl_aux p cont n x {struct p} :="; - pr " safe_shiftl_aux_body "; - pr " (fun n x => match p with"; - pr " | xH => cont n x"; - pr " | xO p => safe_shiftl_aux p (safe_shiftl_aux p cont) n x"; - pr " | xI p => safe_shiftl_aux p (safe_shiftl_aux p cont) n x"; - pr " end) n x."; - pr ""; - - pr " Theorem spec_safe_shift_aux: forall p q n x cont,"; - pr " 2 ^ (Zpos q) <= [head0 x] ->"; - pr " (forall x, 2 ^ (Zpos p + Zpos q) <= [head0 x] ->"; - pr " [cont n x] = [x] * 2 ^ [n]) -> "; - pr " [safe_shiftl_aux p cont n x] = [x] * 2 ^ [n]."; - pa " Admitted."; - pp " Proof."; - pp " intros p; elim p; unfold safe_shiftl_aux; fold safe_shiftl_aux; clear p."; - pp " intros p Hrec q n x cont H1 H2."; - pp " apply spec_safe_shift_aux_body with (q); auto."; - pp " intros x1 H3; apply Hrec with (q + 1)%spositive; auto." "%"; - pp " intros x2 H4; apply Hrec with (p + q + 1)%spositive; auto." "%"; - pp " rewrite <- Pplus_assoc."; - pp " rewrite Zpos_plus_distr; auto."; - pp " intros x3 H5; apply H2."; - pp " rewrite Zpos_xI."; - pp " replace (2 * Zpos p + 1 + Zpos q) with (Zpos p + Zpos (p + q + 1));"; - pp " auto."; - pp " repeat rewrite Zpos_plus_distr; ring."; - pp " intros p Hrec q n x cont H1 H2."; - pp " apply spec_safe_shift_aux_body with (q); auto."; - pp " intros x1 H3; apply Hrec with (q); auto."; - pp " apply Zle_trans with (2 := H3); auto with zarith."; - pp " apply Zpower_le_monotone; auto with zarith."; - pp " intros x2 H4; apply Hrec with (p + q)%spositive; auto." "%"; - pp " intros x3 H5; apply H2."; - pp " rewrite (Zpos_xO p)."; - pp " replace (2 * Zpos p + Zpos q) with (Zpos p + Zpos (p + q));"; - pp " auto."; - pp " repeat rewrite Zpos_plus_distr; ring."; - pp " intros q n x cont H1 H2."; - pp " apply spec_safe_shift_aux_body with (q); auto."; - pp " rewrite Zplus_comm; auto."; - pp " Qed."; - pr ""; - - - pr " Definition safe_shiftl n x :="; - pr " safe_shiftl_aux_body"; - pr " (safe_shiftl_aux_body"; - pr " (safe_shiftl_aux (digits n) shiftl)) n x."; - pr ""; - - pr " Theorem spec_safe_shift: forall n x,"; - pr " [safe_shiftl n x] = [x] * 2 ^ [n]."; - pa " Admitted."; - pp " Proof."; - pp " intros n x; unfold safe_shiftl, safe_shiftl_aux_body."; - pp " generalize (spec_compare n (head0 x)); case compare; intros H."; - pp " apply spec_shiftl; auto with zarith."; - pp " apply spec_shiftl; auto with zarith."; - pp " rewrite <- (spec_double_size x)."; - pp " generalize (spec_compare n (head0 (double_size x))); case compare; intros H1."; - pp " apply spec_shiftl; auto with zarith."; - pp " apply spec_shiftl; auto with zarith."; - pp " rewrite <- (spec_double_size (double_size x))."; - pp " apply spec_safe_shift_aux with 1%spositive." "%"; - pp " apply Zle_trans with (2 := spec_double_size_head0 (double_size x))."; - pp " replace (2 ^ 1) with (2 * 1)."; - pp " apply Zmult_le_compat_l; auto with zarith."; - pp " generalize (spec_double_size_head0_pos x); auto with zarith."; - pp " rewrite Zpower_1_r; ring."; - pp " intros x1 H2; apply spec_shiftl."; - pp " apply Zle_trans with (2 := H2)."; - pp " apply Zle_trans with (2 ^ Zpos (digits n)); auto with zarith."; - pp " case (spec_digits n); auto with zarith."; - pp " apply Zpower_le_monotone; auto with zarith."; - pp " Qed."; - pr ""; - (* even *) pr " Definition is_even x :="; pr " match x with"; @@ -3146,20 +2669,6 @@ let _ = pp " Qed."; pr ""; - pr " Theorem spec_0: [zero] = 0."; - pa " Admitted."; - pp " Proof."; - pp " exact (spec_0 w0_spec)."; - pp " Qed."; - pr ""; - - pr " Theorem spec_1: [one] = 1."; - pa " Admitted."; - pp " Proof."; - pp " exact (spec_1 w0_spec)."; - pp " Qed."; - pr ""; - pr "End Make."; pr ""; diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v index ae2cfd30..d42db97d 100644 --- a/theories/Numbers/Natural/BigN/Nbasic.v +++ b/theories/Numbers/Natural/BigN/Nbasic.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: Nbasic.v 10964 2008-05-22 11:08:13Z letouzey $ i*) +(*i $Id$ i*) Require Import ZArith. Require Import BigNumPrelude. @@ -21,7 +21,7 @@ Require Import DoubleCyclic. (* To compute the necessary height *) Fixpoint plength (p: positive) : positive := - match p with + match p with xH => xH | xO p1 => Psucc (plength p1) | xI p1 => Psucc (plength p1) @@ -34,10 +34,10 @@ rewrite Zpower_exp; auto with zarith. rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith. intros p; elim p; simpl plength; auto. intros p1 Hp1; rewrite F; repeat rewrite Zpos_xI. -assert (tmp: (forall p, 2 * p = p + p)%Z); +assert (tmp: (forall p, 2 * p = p + p)%Z); try repeat rewrite tmp; auto with zarith. intros p1 Hp1; rewrite F; rewrite (Zpos_xO p1). -assert (tmp: (forall p, 2 * p = p + p)%Z); +assert (tmp: (forall p, 2 * p = p + p)%Z); try repeat rewrite tmp; auto with zarith. rewrite Zpower_1_r; auto with zarith. Qed. @@ -73,7 +73,7 @@ case (Z_mod_lt (Zpos p) (Zpos q) H1); auto with zarith. intros q1 H2. replace (Zpos p - Zpos q * Zpos q1) with (Zpos p mod Zpos q). 2: pattern (Zpos p) at 2; rewrite H2; auto with zarith. -generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2; +generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2; case Zmod. intros HH _; rewrite HH; auto with zarith. intros r1 HH (_,HH1); rewrite HH; rewrite Zpos_succ_morphism. @@ -121,9 +121,9 @@ Definition zn2z_word_comm : forall w n, zn2z (word w n) = word (zn2z w) n. Defined. Fixpoint extend (n:nat) {struct n} : forall w:Type, zn2z w -> word w (S n) := - match n return forall w:Type, zn2z w -> word w (S n) with + match n return forall w:Type, zn2z w -> word w (S n) with | O => fun w x => x - | S m => + | S m => let aux := extend m in fun w x => WW W0 (aux w x) end. @@ -169,7 +169,7 @@ Fixpoint diff_l (m n : nat) {struct m} : fst (diff m n) + n = max m n := | S n1 => let v := fst (diff m1 n1) + n1 in let v1 := fst (diff m1 n1) + S n1 in - eq_ind v (fun n => v1 = S n) + eq_ind v (fun n => v1 = S n) (eq_ind v1 (fun n => v1 = n) (refl_equal v1) (S v) (plusnS _ _)) _ (diff_l _ _) end @@ -182,7 +182,7 @@ Fixpoint diff_r (m n: nat) {struct m}: snd (diff m n) + m = max m n := | 0 => refl_equal _ | S _ => plusn0 _ end - | S m => + | S m => match n return (snd (diff (S m) n) + S m = max (S m) n) with | 0 => refl_equal (snd (diff (S m) 0) + S m) | S n1 => @@ -253,9 +253,9 @@ Section ReduceRec. | WW xh xl => match xh with | W0 => @reduce_n m xl - | _ => @c (S m) x + | _ => @c (S m) x end - end + end end. End ReduceRec. @@ -276,14 +276,14 @@ Section CompareRec. Variable compare_m : wm -> w -> comparison. Fixpoint compare0_mn (n:nat) : word wm n -> comparison := - match n return word wm n -> comparison with - | O => compare0_m + match n return word wm n -> comparison with + | O => compare0_m | S m => fun x => match x with | W0 => Eq - | WW xh xl => + | WW xh xl => match compare0_mn m xh with - | Eq => compare0_mn m xl + | Eq => compare0_mn m xl | r => Lt end end @@ -296,7 +296,7 @@ Section CompareRec. Variable spec_compare0_m: forall x, match compare0_m x with Eq => w_to_Z w_0 = wm_to_Z x - | Lt => w_to_Z w_0 < wm_to_Z x + | Lt => w_to_Z w_0 < wm_to_Z x | Gt => w_to_Z w_0 > wm_to_Z x end. Variable wm_to_Z_pos: forall x, 0 <= wm_to_Z x < base wm_base. @@ -341,14 +341,14 @@ Section CompareRec. Qed. Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison := - match n return word wm n -> w -> comparison with - | O => compare_m - | S m => fun x y => + match n return word wm n -> w -> comparison with + | O => compare_m + | S m => fun x y => match x with | W0 => compare w_0 y - | WW xh xl => + | WW xh xl => match compare0_mn m xh with - | Eq => compare_mn_1 m xl y + | Eq => compare_mn_1 m xl y | r => Gt end end @@ -366,7 +366,7 @@ Section CompareRec. | Lt => wm_to_Z x < w_to_Z y | Gt => wm_to_Z x > w_to_Z y end. - Variable wm_base_lt: forall x, + Variable wm_base_lt: forall x, 0 <= w_to_Z x < base (wm_base). Let double_wB_lt: forall n x, @@ -385,7 +385,7 @@ Section CompareRec. unfold Zpower_pos; simpl; ring. Qed. - + Lemma spec_compare_mn_1: forall n x y, match compare_mn_1 n x y with Eq => double_to_Z n x = w_to_Z y @@ -434,7 +434,7 @@ Section AddS. | C1 z => match incr hy with C0 z1 => C0 (WW z1 z) | C1 z1 => C1 (WW z1 z) - end + end end end. @@ -458,12 +458,12 @@ End AddS. Fixpoint length_pos x := match x with xH => O | xO x1 => S (length_pos x1) | xI x1 => S (length_pos x1) end. - + Theorem length_pos_lt: forall x y, (length_pos x < length_pos y)%nat -> Zpos x < Zpos y. Proof. intros x; elim x; clear x; [intros x1 Hrec | intros x1 Hrec | idtac]; - intros y; case y; clear y; intros y1 H || intros H; simpl length_pos; + intros y; case y; clear y; intros y1 H || intros H; simpl length_pos; try (rewrite (Zpos_xI x1) || rewrite (Zpos_xO x1)); try (rewrite (Zpos_xI y1) || rewrite (Zpos_xO y1)); try (inversion H; fail); @@ -492,20 +492,20 @@ End AddS. Qed. Theorem make_zop: forall w (x: znz_op w), - znz_to_Z (mk_zn2z_op x) = - fun z => match z with + znz_to_Z (mk_zn2z_op x) = + fun z => match z with W0 => 0 - | WW xh xl => znz_to_Z x xh * base (znz_digits x) + | WW xh xl => znz_to_Z x xh * base (znz_digits x) + znz_to_Z x xl end. intros ww x; auto. Qed. Theorem make_kzop: forall w (x: znz_op w), - znz_to_Z (mk_zn2z_op_karatsuba x) = - fun z => match z with + znz_to_Z (mk_zn2z_op_karatsuba x) = + fun z => match z with W0 => 0 - | WW xh xl => znz_to_Z x xh * base (znz_digits x) + | WW xh xl => znz_to_Z x xh * base (znz_digits x) + znz_to_Z x xl end. intros ww x; auto. diff --git a/theories/Numbers/Natural/Binary/NBinDefs.v b/theories/Numbers/Natural/Binary/NBinDefs.v deleted file mode 100644 index fc2bd2df..00000000 --- a/theories/Numbers/Natural/Binary/NBinDefs.v +++ /dev/null @@ -1,267 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* NZeq as NZsucc_wd. -Proof. -congruence. -Qed. - -Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd. -Proof. -congruence. -Qed. - -Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd. -Proof. -congruence. -Qed. - -Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd. -Proof. -congruence. -Qed. - -Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd. -Proof. -congruence. -Qed. - -Theorem NZinduction : - forall A : NZ -> Prop, predicate_wd NZeq A -> - A N0 -> (forall n, A n <-> A (NZsucc n)) -> forall n : NZ, A n. -Proof. -intros A A_wd A0 AS. apply Nrect. assumption. intros; now apply -> AS. -Qed. - -Theorem NZpred_succ : forall n : NZ, NZpred (NZsucc n) = n. -Proof. -destruct n as [| p]; simpl. reflexivity. -case_eq (Psucc p); try (intros q H; rewrite <- H; now rewrite Ppred_succ). -intro H; false_hyp H Psucc_not_one. -Qed. - -Theorem NZadd_0_l : forall n : NZ, N0 + n = n. -Proof. -reflexivity. -Qed. - -Theorem NZadd_succ_l : forall n m : NZ, (NZsucc n) + m = NZsucc (n + m). -Proof. -destruct n; destruct m. -simpl in |- *; reflexivity. -unfold NZsucc, NZadd, Nsucc, Nplus. rewrite <- Pplus_one_succ_l; reflexivity. -simpl in |- *; reflexivity. -simpl in |- *; rewrite Pplus_succ_permute_l; reflexivity. -Qed. - -Theorem NZsub_0_r : forall n : NZ, n - N0 = n. -Proof. -now destruct n. -Qed. - -Theorem NZsub_succ_r : forall n m : NZ, n - (NZsucc m) = NZpred (n - m). -Proof. -destruct n as [| p]; destruct m as [| q]; try reflexivity. -now destruct p. -simpl. rewrite Pminus_mask_succ_r, Pminus_mask_carry_spec. -now destruct (Pminus_mask p q) as [| r |]; [| destruct r |]. -Qed. - -Theorem NZmul_0_l : forall n : NZ, N0 * n = N0. -Proof. -destruct n; reflexivity. -Qed. - -Theorem NZmul_succ_l : forall n m : NZ, (NZsucc n) * m = n * m + m. -Proof. -destruct n as [| n]; destruct m as [| m]; simpl; try reflexivity. -now rewrite Pmult_Sn_m, Pplus_comm. -Qed. - -End NZAxiomsMod. - -Definition NZlt := Nlt. -Definition NZle := Nle. -Definition NZmin := Nmin. -Definition NZmax := Nmax. - -Add Morphism NZlt with signature NZeq ==> NZeq ==> iff as NZlt_wd. -Proof. -unfold NZeq; intros x1 x2 H1 y1 y2 H2; rewrite H1; now rewrite H2. -Qed. - -Add Morphism NZle with signature NZeq ==> NZeq ==> iff as NZle_wd. -Proof. -unfold NZeq; intros x1 x2 H1 y1 y2 H2; rewrite H1; now rewrite H2. -Qed. - -Add Morphism NZmin with signature NZeq ==> NZeq ==> NZeq as NZmin_wd. -Proof. -congruence. -Qed. - -Add Morphism NZmax with signature NZeq ==> NZeq ==> NZeq as NZmax_wd. -Proof. -congruence. -Qed. - -Theorem NZlt_eq_cases : forall n m : N, n <= m <-> n < m \/ n = m. -Proof. -intros n m. unfold Nle, Nlt. rewrite <- Ncompare_eq_correct. -destruct (n ?= m); split; intro H1; (try discriminate); try (now left); try now right. -now elim H1. destruct H1; discriminate. -Qed. - -Theorem NZlt_irrefl : forall n : NZ, ~ n < n. -Proof. -intro n; unfold Nlt; now rewrite Ncompare_refl. -Qed. - -Theorem NZlt_succ_r : forall n m : NZ, n < (NZsucc m) <-> n <= m. -Proof. -intros n m; unfold Nlt, Nle; destruct n as [| p]; destruct m as [| q]; simpl; -split; intro H; try reflexivity; try discriminate. -destruct p; simpl; intros; discriminate. elimtype False; now apply H. -apply -> Pcompare_p_Sq in H. destruct H as [H | H]. -now rewrite H. now rewrite H, Pcompare_refl. -apply <- Pcompare_p_Sq. case_eq ((p ?= q)%positive Eq); intro H1. -right; now apply Pcompare_Eq_eq. now left. elimtype False; now apply H. -Qed. - -Theorem NZmin_l : forall n m : N, n <= m -> NZmin n m = n. -Proof. -unfold NZmin, Nmin, Nle; intros n m H. -destruct (n ?= m); try reflexivity. now elim H. -Qed. - -Theorem NZmin_r : forall n m : N, m <= n -> NZmin n m = m. -Proof. -unfold NZmin, Nmin, Nle; intros n m H. -case_eq (n ?= m); intro H1; try reflexivity. -now apply -> Ncompare_eq_correct. -rewrite <- Ncompare_antisym, H1 in H; elim H; auto. -Qed. - -Theorem NZmax_l : forall n m : N, m <= n -> NZmax n m = n. -Proof. -unfold NZmax, Nmax, Nle; intros n m H. -case_eq (n ?= m); intro H1; try reflexivity. -symmetry; now apply -> Ncompare_eq_correct. -rewrite <- Ncompare_antisym, H1 in H; elim H; auto. -Qed. - -Theorem NZmax_r : forall n m : N, n <= m -> NZmax n m = m. -Proof. -unfold NZmax, Nmax, Nle; intros n m H. -destruct (n ?= m); try reflexivity. now elim H. -Qed. - -End NZOrdAxiomsMod. - -Definition recursion (A : Type) (a : A) (f : N -> A -> A) (n : N) := - Nrect (fun _ => A) a f n. -Implicit Arguments recursion [A]. - -Theorem pred_0 : Npred N0 = N0. -Proof. -reflexivity. -Qed. - -Theorem recursion_wd : -forall (A : Type) (Aeq : relation A), - forall a a' : A, Aeq a a' -> - forall f f' : N -> A -> A, fun2_eq NZeq Aeq Aeq f f' -> - forall x x' : N, x = x' -> - Aeq (recursion a f x) (recursion a' f' x'). -Proof. -unfold fun2_wd, NZeq, fun2_eq. -intros A Aeq a a' Eaa' f f' Eff'. -intro x; pattern x; apply Nrect. -intros x' H; now rewrite <- H. -clear x. -intros x IH x' H; rewrite <- H. -unfold recursion in *. do 2 rewrite Nrect_step. -now apply Eff'; [| apply IH]. -Qed. - -Theorem recursion_0 : - forall (A : Type) (a : A) (f : N -> A -> A), recursion a f N0 = a. -Proof. -intros A a f; unfold recursion; now rewrite Nrect_base. -Qed. - -Theorem recursion_succ : - forall (A : Type) (Aeq : relation A) (a : A) (f : N -> A -> A), - Aeq a a -> fun2_wd NZeq Aeq Aeq f -> - forall n : N, Aeq (recursion a f (Nsucc n)) (f n (recursion a f n)). -Proof. -unfold NZeq, recursion, fun2_wd; intros A Aeq a f EAaa f_wd n; pattern n; apply Nrect. -rewrite Nrect_step; rewrite Nrect_base; now apply f_wd. -clear n; intro n; do 2 rewrite Nrect_step; intro IH. apply f_wd; [reflexivity|]. -now rewrite Nrect_step. -Qed. - -End NBinaryAxiomsMod. - -Module Export NBinarySubPropMod := NSubPropFunct NBinaryAxiomsMod. - -(* Some fun comparing the efficiency of the generic log defined -by strong (course-of-value) recursion and the log defined by recursion -on notation *) -(* Time Eval compute in (log 100000). *) (* 98 sec *) - -(* -Fixpoint binposlog (p : positive) : N := -match p with -| xH => 0 -| xO p' => Nsucc (binposlog p') -| xI p' => Nsucc (binposlog p') -end. - -Definition binlog (n : N) : N := -match n with -| 0 => 0 -| Npos p => binposlog p -end. -*) -(* Eval compute in (binlog 1000000000000000000). *) (* Works very fast *) - diff --git a/theories/Numbers/Natural/Binary/NBinary.v b/theories/Numbers/Natural/Binary/NBinary.v index 2c99128d..e593f4a5 100644 --- a/theories/Numbers/Natural/Binary/NBinary.v +++ b/theories/Numbers/Natural/Binary/NBinary.v @@ -8,8 +8,175 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NBinary.v 10934 2008-05-15 21:58:20Z letouzey $ i*) +(*i $Id$ i*) -Require Export NBinDefs. -Require Export NArithRing. +Require Import BinPos. +Require Export BinNat. +Require Import NAxioms NProperties. +Local Open Scope N_scope. + +(** * Implementation of [NAxiomsSig] module type via [BinNat.N] *) + +Module NBinaryAxiomsMod <: NAxiomsSig. + +(** Bi-directional induction. *) + +Theorem bi_induction : + forall A : N -> Prop, Proper (eq==>iff) A -> + A N0 -> (forall n, A n <-> A (Nsucc n)) -> forall n : N, A n. +Proof. +intros A A_wd A0 AS. apply Nrect. assumption. intros; now apply -> AS. +Qed. + +(** Basic operations. *) + +Definition eq_equiv : Equivalence (@eq N) := eq_equivalence. +Local Obligation Tactic := simpl_relation. +Program Instance succ_wd : Proper (eq==>eq) Nsucc. +Program Instance pred_wd : Proper (eq==>eq) Npred. +Program Instance add_wd : Proper (eq==>eq==>eq) Nplus. +Program Instance sub_wd : Proper (eq==>eq==>eq) Nminus. +Program Instance mul_wd : Proper (eq==>eq==>eq) Nmult. + +Definition pred_succ := Npred_succ. +Definition add_0_l := Nplus_0_l. +Definition add_succ_l := Nplus_succ. +Definition sub_0_r := Nminus_0_r. +Definition sub_succ_r := Nminus_succ_r. +Definition mul_0_l := Nmult_0_l. +Definition mul_succ_l n m := eq_trans (Nmult_Sn_m n m) (Nplus_comm _ _). + +(** Order *) + +Program Instance lt_wd : Proper (eq==>eq==>iff) Nlt. + +Definition lt_eq_cases := Nle_lteq. +Definition lt_irrefl := Nlt_irrefl. + +Theorem lt_succ_r : forall n m, n < (Nsucc m) <-> n <= m. +Proof. +intros n m; unfold Nlt, Nle; destruct n as [| p]; destruct m as [| q]; simpl; +split; intro H; try reflexivity; try discriminate. +destruct p; simpl; intros; discriminate. exfalso; now apply H. +apply -> Pcompare_p_Sq in H. destruct H as [H | H]. +now rewrite H. now rewrite H, Pcompare_refl. +apply <- Pcompare_p_Sq. case_eq ((p ?= q)%positive Eq); intro H1. +right; now apply Pcompare_Eq_eq. now left. exfalso; now apply H. +Qed. + +Theorem min_l : forall n m, n <= m -> Nmin n m = n. +Proof. +unfold Nmin, Nle; intros n m H. +destruct (n ?= m); try reflexivity. now elim H. +Qed. + +Theorem min_r : forall n m, m <= n -> Nmin n m = m. +Proof. +unfold Nmin, Nle; intros n m H. +case_eq (n ?= m); intro H1; try reflexivity. +now apply -> Ncompare_eq_correct. +rewrite <- Ncompare_antisym, H1 in H; elim H; auto. +Qed. + +Theorem max_l : forall n m, m <= n -> Nmax n m = n. +Proof. +unfold Nmax, Nle; intros n m H. +case_eq (n ?= m); intro H1; try reflexivity. +symmetry; now apply -> Ncompare_eq_correct. +rewrite <- Ncompare_antisym, H1 in H; elim H; auto. +Qed. + +Theorem max_r : forall n m : N, n <= m -> Nmax n m = m. +Proof. +unfold Nmax, Nle; intros n m H. +destruct (n ?= m); try reflexivity. now elim H. +Qed. + +(** Part specific to natural numbers, not integers. *) + +Theorem pred_0 : Npred 0 = 0. +Proof. +reflexivity. +Qed. + +Definition recursion (A : Type) : A -> (N -> A -> A) -> N -> A := + Nrect (fun _ => A). +Implicit Arguments recursion [A]. + +Instance recursion_wd A (Aeq : relation A) : + Proper (Aeq==>(eq==>Aeq==>Aeq)==>eq==>Aeq) (@recursion A). +Proof. +intros a a' Eaa' f f' Eff'. +intro x; pattern x; apply Nrect. +intros x' H; now rewrite <- H. +clear x. +intros x IH x' H; rewrite <- H. +unfold recursion in *. do 2 rewrite Nrect_step. +now apply Eff'; [| apply IH]. +Qed. + +Theorem recursion_0 : + forall (A : Type) (a : A) (f : N -> A -> A), recursion a f N0 = a. +Proof. +intros A a f; unfold recursion; now rewrite Nrect_base. +Qed. + +Theorem recursion_succ : + forall (A : Type) (Aeq : relation A) (a : A) (f : N -> A -> A), + Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> + forall n : N, Aeq (recursion a f (Nsucc n)) (f n (recursion a f n)). +Proof. +unfold recursion; intros A Aeq a f EAaa f_wd n; pattern n; apply Nrect. +rewrite Nrect_step; rewrite Nrect_base; now apply f_wd. +clear n; intro n; do 2 rewrite Nrect_step; intro IH. apply f_wd; [reflexivity|]. +now rewrite Nrect_step. +Qed. + +(** The instantiation of operations. + Placing them at the very end avoids having indirections in above lemmas. *) + +Definition t := N. +Definition eq := @eq N. +Definition zero := N0. +Definition succ := Nsucc. +Definition pred := Npred. +Definition add := Nplus. +Definition sub := Nminus. +Definition mul := Nmult. +Definition lt := Nlt. +Definition le := Nle. +Definition min := Nmin. +Definition max := Nmax. + +End NBinaryAxiomsMod. + +Module Export NBinaryPropMod := NPropFunct NBinaryAxiomsMod. + +(* +Require Import NDefOps. +Module Import NBinaryDefOpsMod := NdefOpsPropFunct NBinaryAxiomsMod. + +(* Some fun comparing the efficiency of the generic log defined +by strong (course-of-value) recursion and the log defined by recursion +on notation *) + +Time Eval vm_compute in (log 500000). (* 11 sec *) + +Fixpoint binposlog (p : positive) : N := +match p with +| xH => 0 +| xO p' => Nsucc (binposlog p') +| xI p' => Nsucc (binposlog p') +end. + +Definition binlog (n : N) : N := +match n with +| 0 => 0 +| Npos p => binposlog p +end. + +Time Eval vm_compute in (binlog 500000). (* 0 sec *) +Time Eval vm_compute in (binlog 1000000000000000000000000000000). (* 0 sec *) + +*) diff --git a/theories/Numbers/Natural/Peano/NPeano.v b/theories/Numbers/Natural/Peano/NPeano.v index 1c83da45..becbd243 100644 --- a/theories/Numbers/Natural/Peano/NPeano.v +++ b/theories/Numbers/Natural/Peano/NPeano.v @@ -8,134 +8,73 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NPeano.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id$ i*) -Require Import Arith. -Require Import Min. -Require Import Max. -Require Import NSub. +Require Import Arith MinMax NAxioms NProperties. -Module NPeanoAxiomsMod <: NAxiomsSig. -Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig. -Module Export NZAxiomsMod <: NZAxiomsSig. - -Definition NZ := nat. -Definition NZeq := (@eq nat). -Definition NZ0 := 0. -Definition NZsucc := S. -Definition NZpred := pred. -Definition NZadd := plus. -Definition NZsub := minus. -Definition NZmul := mult. - -Theorem NZeq_equiv : equiv nat NZeq. -Proof (eq_equiv nat). - -Add Relation nat NZeq - reflexivity proved by (proj1 NZeq_equiv) - symmetry proved by (proj2 (proj2 NZeq_equiv)) - transitivity proved by (proj1 (proj2 NZeq_equiv)) -as NZeq_rel. - -(* If we say "Add Relation nat (@eq nat)" instead of "Add Relation nat NZeq" -then the theorem generated for succ_wd below is forall x, succ x = succ x, -which does not match the axioms in NAxiomsSig *) - -Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd. -Proof. -congruence. -Qed. - -Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd. -Proof. -congruence. -Qed. +(** * Implementation of [NAxiomsSig] by [nat] *) -Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd. -Proof. -congruence. -Qed. - -Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd. -Proof. -congruence. -Qed. +Module NPeanoAxiomsMod <: NAxiomsSig. -Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd. -Proof. -congruence. -Qed. +(** Bi-directional induction. *) -Theorem NZinduction : - forall A : nat -> Prop, predicate_wd (@eq nat) A -> +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. -Theorem NZpred_succ : forall n : nat, pred (S n) = n. +(** 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 NZadd_0_l : forall n : nat, 0 + n = n. +Theorem add_0_l : forall n : nat, 0 + n = n. Proof. reflexivity. Qed. -Theorem NZadd_succ_l : forall n m : nat, (S n) + m = S (n + m). +Theorem add_succ_l : forall n m : nat, (S n) + m = S (n + m). Proof. reflexivity. Qed. -Theorem NZsub_0_r : forall n : nat, n - 0 = n. +Theorem sub_0_r : forall n : nat, n - 0 = n. Proof. intro n; now destruct n. Qed. -Theorem NZsub_succ_r : forall n m : nat, n - (S m) = pred (n - m). +Theorem sub_succ_r : forall n m : nat, n - (S m) = pred (n - m). Proof. -intros n m; induction n m using nat_double_ind; simpl; auto. apply NZsub_0_r. +intros n m; induction n m using nat_double_ind; simpl; auto. apply sub_0_r. Qed. -Theorem NZmul_0_l : forall n : nat, 0 * n = 0. +Theorem mul_0_l : forall n : nat, 0 * n = 0. Proof. reflexivity. Qed. -Theorem NZmul_succ_l : forall n m : nat, S n * m = n * m + m. +Theorem mul_succ_l : forall n m : nat, S n * m = n * m + m. Proof. intros n m; now rewrite plus_comm. Qed. -End NZAxiomsMod. +(** Order on natural numbers *) -Definition NZlt := lt. -Definition NZle := le. -Definition NZmin := min. -Definition NZmax := max. +Program Instance lt_wd : Proper (eq==>eq==>iff) lt. -Add Morphism NZlt with signature NZeq ==> NZeq ==> iff as NZlt_wd. -Proof. -unfold NZeq; intros x1 x2 H1 y1 y2 H2; rewrite H1; now rewrite H2. -Qed. - -Add Morphism NZle with signature NZeq ==> NZeq ==> iff as NZle_wd. -Proof. -unfold NZeq; intros x1 x2 H1 y1 y2 H2; rewrite H1; now rewrite H2. -Qed. - -Add Morphism NZmin with signature NZeq ==> NZeq ==> NZeq as NZmin_wd. -Proof. -congruence. -Qed. - -Add Morphism NZmax with signature NZeq ==> NZeq ==> NZeq as NZmax_wd. -Proof. -congruence. -Qed. - -Theorem NZlt_eq_cases : forall n m : nat, n <= m <-> n < m \/ n = m. +Theorem lt_eq_cases : forall n m : nat, n <= m <-> n < m \/ n = m. Proof. intros n m; split. apply le_lt_or_eq. @@ -143,59 +82,52 @@ intro H; destruct H as [H | H]. now apply lt_le_weak. rewrite H; apply le_refl. Qed. -Theorem NZlt_irrefl : forall n : nat, ~ (n < n). +Theorem lt_irrefl : forall n : nat, ~ (n < n). Proof. exact lt_irrefl. Qed. -Theorem NZlt_succ_r : forall n m : nat, n < S m <-> n <= m. +Theorem lt_succ_r : forall n m : nat, n < S m <-> n <= m. Proof. intros n m; split; [apply lt_n_Sm_le | apply le_lt_n_Sm]. Qed. -Theorem NZmin_l : forall n m : nat, n <= m -> NZmin n m = n. +Theorem min_l : forall n m : nat, n <= m -> min n m = n. Proof. exact min_l. Qed. -Theorem NZmin_r : forall n m : nat, m <= n -> NZmin n m = m. +Theorem min_r : forall n m : nat, m <= n -> min n m = m. Proof. exact min_r. Qed. -Theorem NZmax_l : forall n m : nat, m <= n -> NZmax n m = n. +Theorem max_l : forall n m : nat, m <= n -> max n m = n. Proof. exact max_l. Qed. -Theorem NZmax_r : forall n m : nat, n <= m -> NZmax n m = m. +Theorem max_r : forall n m : nat, n <= m -> max n m = m. Proof. exact max_r. Qed. -End NZOrdAxiomsMod. - -Definition recursion : forall A : Type, A -> (nat -> A -> A) -> nat -> A := - fun A : Type => nat_rect (fun _ => A). -Implicit Arguments recursion [A]. - -Theorem succ_neq_0 : forall n : nat, S n <> 0. -Proof. -intros; discriminate. -Qed. +(** Facts specific to natural numbers, not integers. *) Theorem pred_0 : pred 0 = 0. Proof. reflexivity. Qed. -Theorem recursion_wd : forall (A : Type) (Aeq : relation A), - forall a a' : A, Aeq a a' -> - forall f f' : nat -> A -> A, fun2_eq (@eq nat) Aeq Aeq f f' -> - forall n n' : nat, n = n' -> - Aeq (recursion a f n) (recursion a' f' n'). +Definition recursion (A : Type) : A -> (nat -> A -> A) -> nat -> A := + nat_rect (fun _ => A). +Implicit Arguments recursion [A]. + +Instance recursion_wd (A : Type) (Aeq : relation A) : + Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A). Proof. -unfold fun2_eq; induction n; intros n' Enn'; rewrite <- Enn' in *; simpl; auto. +intros a a' Ha f f' Hf n n' Hn. subst n'. +induction n; simpl; auto. apply Hf; auto. Qed. Theorem recursion_0 : @@ -206,15 +138,100 @@ Qed. Theorem recursion_succ : forall (A : Type) (Aeq : relation A) (a : A) (f : nat -> A -> A), - Aeq a a -> fun2_wd (@eq nat) Aeq Aeq f -> + Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)). Proof. -induction n; simpl; auto. +unfold Proper, respectful in *; induction n; simpl; auto. Qed. -End NPeanoAxiomsMod. +(** The instantiation of operations. + Placing them at the very end avoids having indirections in above lemmas. *) -(* Now we apply the largest property functor *) +Definition t := nat. +Definition eq := @eq nat. +Definition zero := 0. +Definition succ := S. +Definition pred := pred. +Definition add := plus. +Definition sub := minus. +Definition mul := mult. +Definition lt := lt. +Definition le := le. +Definition min := min. +Definition max := max. -Module Export NPeanoSubPropMod := NSubPropFunct NPeanoAxiomsMod. +End NPeanoAxiomsMod. +(** Now we apply the largest property functor *) + +Module Export NPeanoPropMod := NPropFunct NPeanoAxiomsMod. + + + +(** Euclidean Division *) + +Definition divF div x y := if leb y x then S (div (x-y) y) else 0. +Definition modF mod x y := if leb y x then mod (x-y) y else x. +Definition initF (_ _ : nat) := 0. + +Fixpoint loop {A} (F:A->A)(i:A) (n:nat) : A := + match n with + | 0 => i + | S n => F (loop F i n) + end. + +Definition div x y := loop divF initF x x y. +Definition modulo x y := loop modF initF x x y. +Infix "/" := div : nat_scope. +Infix "mod" := modulo (at level 40, no associativity) : nat_scope. + +Lemma div_mod : forall x y, y<>0 -> x = y*(x/y) + x mod y. +Proof. + cut (forall n x y, y<>0 -> x<=n -> + x = y*(loop divF initF n x y) + (loop modF initF n x y)). + intros H x y Hy. apply H; auto. + induction n. + simpl; unfold initF; simpl. intros. nzsimpl. auto with arith. + simpl; unfold divF at 1, modF at 1. + intros. + destruct (leb y x) as [ ]_eqn:L; + [apply leb_complete in L | apply leb_complete_conv in L]. + rewrite mul_succ_r, <- add_assoc, (add_comm y), add_assoc. + rewrite <- IHn; auto. + symmetry; apply sub_add; auto. + rewrite <- NPeanoAxiomsMod.lt_succ_r. + apply lt_le_trans with x; auto. + apply lt_minus; auto. rewrite <- neq_0_lt_0; auto. + nzsimpl; auto. +Qed. + +Lemma mod_upper_bound : forall x y, y<>0 -> x mod y < y. +Proof. + cut (forall n x y, y<>0 -> x<=n -> loop modF initF n x y < y). + intros H x y Hy. apply H; auto. + induction n. + simpl; unfold initF. intros. rewrite <- neq_0_lt_0; auto. + simpl; unfold modF at 1. + intros. + destruct (leb y x) as [ ]_eqn:L; + [apply leb_complete in L | apply leb_complete_conv in L]; auto. + apply IHn; auto. + rewrite <- NPeanoAxiomsMod.lt_succ_r. + apply lt_le_trans with x; auto. + apply lt_minus; auto. rewrite <- neq_0_lt_0; auto. +Qed. + +Require Import NDiv. + +Module NDivMod <: NDivSig. + Include NPeanoAxiomsMod. + Definition div := div. + Definition modulo := modulo. + Definition div_mod := div_mod. + Definition mod_upper_bound := mod_upper_bound. + Local Obligation Tactic := simpl_relation. + Program Instance div_wd : Proper (eq==>eq==>eq) div. + Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. +End NDivMod. + +Module Export NDivPropMod := NDivPropFunct NDivMod NPeanoPropMod. diff --git a/theories/Numbers/Natural/SpecViaZ/NSig.v b/theories/Numbers/Natural/SpecViaZ/NSig.v index 0275d1e1..85639aa6 100644 --- a/theories/Numbers/Natural/SpecViaZ/NSig.v +++ b/theories/Numbers/Natural/SpecViaZ/NSig.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: NSig.v 11027 2008-06-01 13:28:59Z letouzey $ i*) +(*i $Id$ i*) Require Import ZArith Znumtheory. @@ -25,91 +25,76 @@ Module Type NType. Parameter t : Type. Parameter to_Z : t -> Z. - Notation "[ x ]" := (to_Z x). + Local Notation "[ x ]" := (to_Z x). Parameter spec_pos: forall x, 0 <= [x]. Parameter of_N : N -> t. Parameter spec_of_N: forall x, to_Z (of_N x) = Z_of_N x. Definition to_N n := Zabs_N (to_Z n). - Definition eq n m := ([n] = [m]). - - Parameter zero : t. - Parameter one : t. - - Parameter spec_0: [zero] = 0. - Parameter spec_1: [one] = 1. + Definition eq n m := [n] = [m]. + Definition lt n m := [n] < [m]. + Definition le n m := [n] <= [m]. Parameter compare : t -> t -> comparison. - - Parameter spec_compare: forall x y, - match compare x y with - | Eq => [x] = [y] - | Lt => [x] < [y] - | Gt => [x] > [y] - end. - - Definition lt n m := compare n m = Lt. - Definition le n m := compare n m <> Gt. - Definition min n m := match compare n m with Gt => m | _ => n end. - Definition max n m := match compare n m with Lt => m | _ => n end. - Parameter eq_bool : t -> t -> bool. - - Parameter spec_eq_bool: forall x y, - if eq_bool x y then [x] = [y] else [x] <> [y]. - + Parameter max : t -> t -> t. + Parameter min : t -> t -> t. + Parameter zero : t. + Parameter one : t. Parameter succ : t -> t. - - Parameter spec_succ: forall n, [succ n] = [n] + 1. - - Parameter add : t -> t -> t. - - Parameter spec_add: forall x y, [add x y] = [x] + [y]. - Parameter pred : t -> t. - - Parameter spec_pred: forall x, 0 < [x] -> [pred x] = [x] - 1. - Parameter spec_pred0: forall x, [x] = 0 -> [pred x] = 0. - + Parameter add : t -> t -> t. Parameter sub : t -> t -> t. - - Parameter spec_sub: forall x y, [y] <= [x] -> [sub x y] = [x] - [y]. - Parameter spec_sub0: forall x y, [x] < [y]-> [sub x y] = 0. - Parameter mul : t -> t -> t. - - Parameter spec_mul: forall x y, [mul x y] = [x] * [y]. - Parameter square : t -> t. - - Parameter spec_square: forall x, [square x] = [x] * [x]. - Parameter power_pos : t -> positive -> t. - - Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n. - + Parameter power : t -> N -> t. Parameter sqrt : t -> t. - - Parameter spec_sqrt: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. - Parameter div_eucl : t -> t -> t * t. - - Parameter spec_div_eucl: forall x y, - 0 < [y] -> - let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y]. - Parameter div : t -> t -> t. - - Parameter spec_div: forall x y, 0 < [y] -> [div x y] = [x] / [y]. - Parameter modulo : t -> t -> t. - - Parameter spec_modulo: - forall x y, 0 < [y] -> [modulo x y] = [x] mod [y]. - Parameter gcd : t -> t -> t. - - Parameter spec_gcd: forall a b, [gcd a b] = Zgcd (to_Z a) (to_Z b). + Parameter shiftr : t -> t -> t. + Parameter shiftl : t -> t -> t. + Parameter is_even : t -> bool. + + Parameter spec_compare: forall x y, compare x y = Zcompare [x] [y]. + Parameter spec_eq_bool: forall x y, eq_bool x y = Zeq_bool [x] [y]. + Parameter spec_max : forall x y, [max x y] = Zmax [x] [y]. + Parameter spec_min : forall x y, [min x y] = Zmin [x] [y]. + Parameter spec_0: [zero] = 0. + Parameter spec_1: [one] = 1. + Parameter spec_succ: forall n, [succ n] = [n] + 1. + Parameter spec_add: forall x y, [add x y] = [x] + [y]. + Parameter spec_pred: forall x, [pred x] = Zmax 0 ([x] - 1). + Parameter spec_sub: forall x y, [sub x y] = Zmax 0 ([x] - [y]). + Parameter spec_mul: forall x y, [mul x y] = [x] * [y]. + Parameter spec_square: forall x, [square x] = [x] * [x]. + Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n. + Parameter spec_power: forall x n, [power x n] = [x] ^ Z_of_N n. + Parameter spec_sqrt: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. + Parameter spec_div_eucl: forall x y, + let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y]. + Parameter spec_div: forall x y, [div x y] = [x] / [y]. + Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y]. + Parameter spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b]. + Parameter spec_shiftr: forall p x, [shiftr p x] = [x] / 2^[p]. + Parameter spec_shiftl: forall p x, [shiftl p x] = [x] * 2^[p]. + Parameter spec_is_even: forall x, + if is_even x then [x] mod 2 = 0 else [x] mod 2 = 1. End NType. + +Module Type NType_Notation (Import N:NType). + Notation "[ x ]" := (to_Z x). + Infix "==" := eq (at level 70). + Notation "0" := zero. + Infix "+" := add. + Infix "-" := sub. + Infix "*" := mul. + Infix "<=" := le. + Infix "<" := lt. +End NType_Notation. + +Module Type NType' := NType <+ NType_Notation. diff --git a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v index 84836268..ab749bd1 100644 --- a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v +++ b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v @@ -6,101 +6,47 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: NSigNAxioms.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id$ i*) -Require Import ZArith. -Require Import Nnat. -Require Import NAxioms. -Require Import NSig. +Require Import ZArith Nnat NAxioms NDiv NSig. (** * The interface [NSig.NType] implies the interface [NAxiomsSig] *) -Module NSig_NAxioms (N:NType) <: NAxiomsSig. - -Delimit Scope IntScope with Int. -Bind Scope IntScope with N.t. -Open Local Scope IntScope. -Notation "[ x ]" := (N.to_Z x) : IntScope. -Infix "==" := N.eq (at level 70) : IntScope. -Notation "0" := N.zero : IntScope. -Infix "+" := N.add : IntScope. -Infix "-" := N.sub : IntScope. -Infix "*" := N.mul : IntScope. - -Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig. -Module Export NZAxiomsMod <: NZAxiomsSig. - -Definition NZ := N.t. -Definition NZeq := N.eq. -Definition NZ0 := N.zero. -Definition NZsucc := N.succ. -Definition NZpred := N.pred. -Definition NZadd := N.add. -Definition NZsub := N.sub. -Definition NZmul := N.mul. - -Theorem NZeq_equiv : equiv N.t N.eq. -Proof. -repeat split; repeat red; intros; auto; congruence. -Qed. +Module NTypeIsNAxioms (Import N : NType'). -Add Relation N.t N.eq - reflexivity proved by (proj1 NZeq_equiv) - symmetry proved by (proj2 (proj2 NZeq_equiv)) - transitivity proved by (proj1 (proj2 NZeq_equiv)) - as NZeq_rel. +Hint Rewrite + spec_0 spec_succ spec_add spec_mul spec_pred spec_sub + spec_div spec_modulo spec_gcd spec_compare spec_eq_bool + spec_max spec_min spec_power_pos spec_power + : nsimpl. +Ltac nsimpl := autorewrite with nsimpl. +Ltac ncongruence := unfold eq; repeat red; intros; nsimpl; congruence. +Ltac zify := unfold eq, lt, le in *; nsimpl. -Add Morphism NZsucc with signature N.eq ==> N.eq as NZsucc_wd. -Proof. -unfold N.eq; intros; rewrite 2 N.spec_succ; f_equal; auto. -Qed. +Local Obligation Tactic := ncongruence. -Add Morphism NZpred with signature N.eq ==> N.eq as NZpred_wd. -Proof. -unfold N.eq; intros. -generalize (N.spec_pos y) (N.spec_pos x) (N.spec_eq_bool x 0). -destruct N.eq_bool; rewrite N.spec_0; intros. -rewrite 2 N.spec_pred0; congruence. -rewrite 2 N.spec_pred; f_equal; auto; try omega. -Qed. +Instance eq_equiv : Equivalence eq. +Proof. unfold eq. firstorder. Qed. -Add Morphism NZadd with signature N.eq ==> N.eq ==> N.eq as NZadd_wd. -Proof. -unfold N.eq; intros; rewrite 2 N.spec_add; f_equal; auto. -Qed. +Program Instance succ_wd : Proper (eq==>eq) succ. +Program Instance pred_wd : Proper (eq==>eq) pred. +Program Instance add_wd : Proper (eq==>eq==>eq) add. +Program Instance sub_wd : Proper (eq==>eq==>eq) sub. +Program Instance mul_wd : Proper (eq==>eq==>eq) mul. -Add Morphism NZsub with signature N.eq ==> N.eq ==> N.eq as NZsub_wd. +Theorem pred_succ : forall n, pred (succ n) == n. Proof. -unfold N.eq; intros x x' Hx y y' Hy. -destruct (Z_lt_le_dec [x] [y]). -rewrite 2 N.spec_sub0; f_equal; congruence. -rewrite 2 N.spec_sub; f_equal; congruence. +intros. zify. generalize (spec_pos n); omega with *. Qed. -Add Morphism NZmul with signature N.eq ==> N.eq ==> N.eq as NZmul_wd. -Proof. -unfold N.eq; intros; rewrite 2 N.spec_mul; f_equal; auto. -Qed. - -Theorem NZpred_succ : forall n, N.pred (N.succ n) == n. -Proof. -unfold N.eq; intros. -rewrite N.spec_pred; rewrite N.spec_succ. -omega. -generalize (N.spec_pos n); omega. -Qed. - -Definition N_of_Z z := N.of_N (Zabs_N z). +Definition N_of_Z z := of_N (Zabs_N z). Section Induction. Variable A : N.t -> Prop. -Hypothesis A_wd : predicate_wd N.eq A. +Hypothesis A_wd : Proper (eq==>iff) A. Hypothesis A0 : A 0. -Hypothesis AS : forall n, A n <-> A (N.succ n). - -Add Morphism A with signature N.eq ==> iff as A_morph. -Proof. apply A_wd. Qed. +Hypothesis AS : forall n, A n <-> A (succ n). Let B (z : Z) := A (N_of_Z z). @@ -108,17 +54,17 @@ Lemma B0 : B 0. Proof. unfold B, N_of_Z; simpl. rewrite <- (A_wd 0); auto. -red; rewrite N.spec_0, N.spec_of_N; auto. +red; rewrite spec_0, spec_of_N; auto. Qed. Lemma BS : forall z : Z, (0 <= z)%Z -> B z -> B (z + 1). Proof. intros z H1 H2. unfold B in *. apply -> AS in H2. -setoid_replace (N_of_Z (z + 1)) with (N.succ (N_of_Z z)); auto. -unfold N.eq. rewrite N.spec_succ. +setoid_replace (N_of_Z (z + 1)) with (succ (N_of_Z z)); auto. +unfold eq. rewrite spec_succ. unfold N_of_Z. -rewrite 2 N.spec_of_N, 2 Z_of_N_abs, 2 Zabs_eq; auto with zarith. +rewrite 2 spec_of_N, 2 Z_of_N_abs, 2 Zabs_eq; auto with zarith. Qed. Lemma B_holds : forall z : Z, (0 <= z)%Z -> B z. @@ -126,193 +72,144 @@ Proof. exact (natlike_ind B B0 BS). Qed. -Theorem NZinduction : forall n, A n. +Theorem bi_induction : forall n, A n. Proof. -intro n. setoid_replace n with (N_of_Z (N.to_Z n)). -apply B_holds. apply N.spec_pos. +intro n. setoid_replace n with (N_of_Z (to_Z n)). +apply B_holds. apply spec_pos. red; unfold N_of_Z. -rewrite N.spec_of_N, Z_of_N_abs, Zabs_eq; auto. -apply N.spec_pos. +rewrite spec_of_N, Z_of_N_abs, Zabs_eq; auto. +apply spec_pos. Qed. End Induction. -Theorem NZadd_0_l : forall n, 0 + n == n. +Theorem add_0_l : forall n, 0 + n == n. Proof. -intros; red; rewrite N.spec_add, N.spec_0; auto with zarith. +intros. zify. auto with zarith. Qed. -Theorem NZadd_succ_l : forall n m, (N.succ n) + m == N.succ (n + m). +Theorem add_succ_l : forall n m, (succ n) + m == succ (n + m). Proof. -intros; red; rewrite N.spec_add, 2 N.spec_succ, N.spec_add; auto with zarith. +intros. zify. auto with zarith. Qed. -Theorem NZsub_0_r : forall n, n - 0 == n. +Theorem sub_0_r : forall n, n - 0 == n. Proof. -intros; red; rewrite N.spec_sub; rewrite N.spec_0; auto with zarith. -apply N.spec_pos. +intros. zify. generalize (spec_pos n); omega with *. Qed. -Theorem NZsub_succ_r : forall n m, n - (N.succ m) == N.pred (n - m). +Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m). Proof. -intros; red. -destruct (Z_lt_le_dec [n] [N.succ m]) as [H|H]. -rewrite N.spec_sub0; auto. -rewrite N.spec_succ in H. -rewrite N.spec_pred0; auto. -destruct (Z_eq_dec [n] [m]). -rewrite N.spec_sub; auto with zarith. -rewrite N.spec_sub0; auto with zarith. - -rewrite N.spec_sub, N.spec_succ in *; auto. -rewrite N.spec_pred, N.spec_sub; auto with zarith. -rewrite N.spec_sub; auto with zarith. +intros. zify. omega with *. Qed. -Theorem NZmul_0_l : forall n, 0 * n == 0. +Theorem mul_0_l : forall n, 0 * n == 0. Proof. -intros; red. -rewrite N.spec_mul, N.spec_0; auto with zarith. +intros. zify. auto with zarith. Qed. -Theorem NZmul_succ_l : forall n m, (N.succ n) * m == n * m + m. +Theorem mul_succ_l : forall n m, (succ n) * m == n * m + m. Proof. -intros; red. -rewrite N.spec_add, 2 N.spec_mul, N.spec_succ; ring. +intros. zify. ring. Qed. -End NZAxiomsMod. - -Definition NZlt := N.lt. -Definition NZle := N.le. -Definition NZmin := N.min. -Definition NZmax := N.max. +(** Order *) -Infix "<=" := N.le : IntScope. -Infix "<" := N.lt : IntScope. - -Lemma spec_compare_alt : forall x y, N.compare x y = ([x] ?= [y])%Z. +Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). Proof. - intros; generalize (N.spec_compare x y). - destruct (N.compare x y); auto. - intros H; rewrite H; symmetry; apply Zcompare_refl. + intros. zify. destruct (Zcompare_spec [x] [y]); auto. Qed. -Lemma spec_lt : forall x y, (x ([x]<[y])%Z. -Proof. - intros; unfold N.lt, Zlt; rewrite spec_compare_alt; intuition. -Qed. +Definition eqb := eq_bool. -Lemma spec_le : forall x y, (x<=y) <-> ([x]<=[y])%Z. +Lemma eqb_eq : forall x y, eq_bool x y = true <-> x == y. Proof. - intros; unfold N.le, Zle; rewrite spec_compare_alt; intuition. + intros. zify. symmetry. apply Zeq_is_eq_bool. Qed. -Lemma spec_min : forall x y, [N.min x y] = Zmin [x] [y]. +Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare. Proof. - intros; unfold N.min, Zmin. - rewrite spec_compare_alt; destruct Zcompare; auto. +intros x x' Hx y y' Hy. rewrite 2 spec_compare, Hx, Hy; intuition. Qed. -Lemma spec_max : forall x y, [N.max x y] = Zmax [x] [y]. +Instance lt_wd : Proper (eq ==> eq ==> iff) lt. Proof. - intros; unfold N.max, Zmax. - rewrite spec_compare_alt; destruct Zcompare; auto. -Qed. - -Add Morphism N.compare with signature N.eq ==> N.eq ==> (@eq comparison) as compare_wd. -Proof. -intros x x' Hx y y' Hy. -rewrite 2 spec_compare_alt. unfold N.eq in *. rewrite Hx, Hy; intuition. +intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition. Qed. -Add Morphism N.lt with signature N.eq ==> N.eq ==> iff as NZlt_wd. +Theorem lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m. Proof. -intros x x' Hx y y' Hy; unfold N.lt; rewrite Hx, Hy; intuition. +intros. zify. omega. Qed. -Add Morphism N.le with signature N.eq ==> N.eq ==> iff as NZle_wd. +Theorem lt_irrefl : forall n, ~ n < n. Proof. -intros x x' Hx y y' Hy; unfold N.le; rewrite Hx, Hy; intuition. +intros. zify. omega. Qed. -Add Morphism N.min with signature N.eq ==> N.eq ==> N.eq as NZmin_wd. +Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m. Proof. -intros; red; rewrite 2 spec_min; congruence. +intros. zify. omega. Qed. -Add Morphism N.max with signature N.eq ==> N.eq ==> N.eq as NZmax_wd. +Theorem min_l : forall n m, n <= m -> min n m == n. Proof. -intros; red; rewrite 2 spec_max; congruence. +intros n m. zify. omega with *. Qed. -Theorem NZlt_eq_cases : forall n m, n <= m <-> n < m \/ n == m. +Theorem min_r : forall n m, m <= n -> min n m == m. Proof. -intros. -unfold N.eq; rewrite spec_lt, spec_le; omega. +intros n m. zify. omega with *. Qed. -Theorem NZlt_irrefl : forall n, ~ n < n. +Theorem max_l : forall n m, m <= n -> max n m == n. Proof. -intros; rewrite spec_lt; auto with zarith. +intros n m. zify. omega with *. Qed. -Theorem NZlt_succ_r : forall n m, n < (N.succ m) <-> n <= m. +Theorem max_r : forall n m, n <= m -> max n m == m. Proof. -intros; rewrite spec_lt, spec_le, N.spec_succ; omega. +intros n m. zify. omega with *. Qed. -Theorem NZmin_l : forall n m, n <= m -> N.min n m == n. -Proof. -intros n m; unfold N.eq; rewrite spec_le, spec_min. -generalize (Zmin_spec [n] [m]); omega. -Qed. +(** Properties specific to natural numbers, not integers. *) -Theorem NZmin_r : forall n m, m <= n -> N.min n m == m. +Theorem pred_0 : pred 0 == 0. Proof. -intros n m; unfold N.eq; rewrite spec_le, spec_min. -generalize (Zmin_spec [n] [m]); omega. +zify. auto. Qed. -Theorem NZmax_l : forall n m, m <= n -> N.max n m == n. -Proof. -intros n m; unfold N.eq; rewrite spec_le, spec_max. -generalize (Zmax_spec [n] [m]); omega. -Qed. +Program Instance div_wd : Proper (eq==>eq==>eq) div. +Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. -Theorem NZmax_r : forall n m, n <= m -> N.max n m == m. +Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b). Proof. -intros n m; unfold N.eq; rewrite spec_le, spec_max. -generalize (Zmax_spec [n] [m]); omega. +intros a b. zify. intros. apply Z_div_mod_eq_full; auto. Qed. -End NZOrdAxiomsMod. - -Theorem pred_0 : N.pred 0 == 0. +Theorem mod_upper_bound : forall a b, ~b==0 -> modulo a b < b. Proof. -red; rewrite N.spec_pred0; rewrite N.spec_0; auto. +intros a b. zify. intros. +destruct (Z_mod_lt [a] [b]); auto. +generalize (spec_pos b); auto with zarith. Qed. Definition recursion (A : Type) (a : A) (f : N.t -> A -> A) (n : N.t) := Nrect (fun _ => A) a (fun n a => f (N.of_N n) a) (N.to_N n). Implicit Arguments recursion [A]. -Theorem recursion_wd : -forall (A : Type) (Aeq : relation A), - forall a a' : A, Aeq a a' -> - forall f f' : N.t -> A -> A, fun2_eq N.eq Aeq Aeq f f' -> - forall x x' : N.t, x == x' -> - Aeq (recursion a f x) (recursion a' f' x'). +Instance recursion_wd (A : Type) (Aeq : relation A) : + Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A). Proof. -unfold fun2_wd, N.eq, fun2_eq. -intros A Aeq a a' Eaa' f f' Eff' x x' Exx'. +unfold eq. +intros a a' Eaa' f f' Eff' x x' Exx'. unfold recursion. unfold N.to_N. rewrite <- Exx'; clear x' Exx'. replace (Zabs_N [x]) with (N_of_nat (Zabs_nat [x])). induction (Zabs_nat [x]). simpl; auto. -rewrite N_of_S, 2 Nrect_step; auto. +rewrite N_of_S, 2 Nrect_step; auto. apply Eff'; auto. destruct [x]; simpl; auto. change (nat_of_P p) with (nat_of_N (Npos p)); apply N_of_nat_of_N. change (nat_of_P p) with (nat_of_N (Npos p)); apply N_of_nat_of_N. @@ -326,11 +223,11 @@ Qed. Theorem recursion_succ : forall (A : Type) (Aeq : relation A) (a : A) (f : N.t -> A -> A), - Aeq a a -> fun2_wd N.eq Aeq Aeq f -> - forall n, Aeq (recursion a f (N.succ n)) (f n (recursion a f n)). + Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> + forall n, Aeq (recursion a f (succ n)) (f n (recursion a f n)). Proof. -unfold N.eq, recursion, fun2_wd; intros A Aeq a f EAaa f_wd n. -replace (N.to_N (N.succ n)) with (Nsucc (N.to_N n)). +unfold N.eq, recursion; intros A Aeq a f EAaa f_wd n. +replace (N.to_N (succ n)) with (Nsucc (N.to_N n)). rewrite Nrect_step. apply f_wd; auto. unfold N.to_N. @@ -340,7 +237,6 @@ rewrite N.spec_of_N, Z_of_N_abs, Zabs_eq; auto. fold (recursion a f n). apply recursion_wd; auto. red; auto. -red; auto. unfold N.to_N. rewrite N.spec_succ. @@ -349,8 +245,12 @@ apply Z_of_N_eq_rev. rewrite Z_of_N_succ. rewrite 2 Z_of_N_abs. rewrite 2 Zabs_eq; auto. -generalize (N.spec_pos n); auto with zarith. -apply N.spec_pos; auto. +generalize (spec_pos n); auto with zarith. +apply spec_pos; auto. Qed. -End NSig_NAxioms. +End NTypeIsNAxioms. + +Module NType_NAxioms (N : NType) + <: NAxiomsSig <: NDivSig <: HasCompare N <: HasEqBool N <: HasMinMax N + := N <+ NTypeIsNAxioms. diff --git a/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v index 95d8b366..468b0613 100644 --- a/theories/Numbers/NumPrelude.v +++ b/theories/Numbers/NumPrelude.v @@ -8,9 +8,9 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NumPrelude.v 11674 2008-12-12 19:48:40Z letouzey $ i*) +(*i $Id$ i*) -Require Export Setoid. +Require Export Setoid Morphisms. Set Implicit Arguments. (* @@ -91,85 +91,31 @@ end. Tactic Notation "stepr" constr(t2') "in" hyp(H) "by" tactic(r) := stepr t2' in H; [| r]. -(** Extentional properties of predicates, relations and functions *) +(** Predicates, relations, functions *) Definition predicate (A : Type) := A -> Prop. -Section ExtensionalProperties. - -Variables A B C : Type. -Variable Aeq : relation A. -Variable Beq : relation B. -Variable Ceq : relation C. - -(* "wd" stands for "well-defined" *) - -Definition fun_wd (f : A -> B) := forall x y : A, Aeq x y -> Beq (f x) (f y). - -Definition fun2_wd (f : A -> B -> C) := - forall x x' : A, Aeq x x' -> forall y y' : B, Beq y y' -> Ceq (f x y) (f x' y'). - -Definition fun_eq : relation (A -> B) := - fun f f' => forall x x' : A, Aeq x x' -> Beq (f x) (f' x'). - -(* Note that reflexivity of fun_eq means that every function -is well-defined w.r.t. Aeq and Beq, i.e., -forall x x' : A, Aeq x x' -> Beq (f x) (f x') *) - -Definition fun2_eq (f f' : A -> B -> C) := - forall x x' : A, Aeq x x' -> forall y y' : B, Beq y y' -> Ceq (f x y) (f' x' y'). - -End ExtensionalProperties. - -(* The following definitions instantiate Beq or Ceq to iff; therefore, they -have to be outside the ExtensionalProperties section *) - -Definition predicate_wd (A : Type) (Aeq : relation A) := fun_wd Aeq iff. - -Definition relation_wd (A B : Type) (Aeq : relation A) (Beq : relation B) := - fun2_wd Aeq Beq iff. - -Definition relations_eq (A B : Type) (R1 R2 : A -> B -> Prop) := - forall (x : A) (y : B), R1 x y <-> R2 x y. - -Theorem relations_eq_equiv : - forall (A B : Type), equiv (A -> B -> Prop) (@relations_eq A B). -Proof. -intros A B; unfold equiv. split; [| split]; -unfold reflexive, symmetric, transitive, relations_eq. -reflexivity. -intros R1 R2 R3 H1 H2 x y; rewrite H1; apply H2. -now symmetry. -Qed. - -Add Parametric Relation (A B : Type) : (A -> B -> Prop) (@relations_eq A B) - reflexivity proved by (proj1 (relations_eq_equiv A B)) - symmetry proved by (proj2 (proj2 (relations_eq_equiv A B))) - transitivity proved by (proj1 (proj2 (relations_eq_equiv A B))) -as relations_eq_rel. - -Add Parametric Morphism (A : Type) : (@well_founded A) with signature (@relations_eq A A) ==> iff as well_founded_wd. +Instance well_founded_wd A : + Proper (@relation_equivalence A ==> iff) (@well_founded A). Proof. -unfold relations_eq, well_founded; intros R1 R2 H; -split; intros H1 a; induction (H1 a) as [x H2 H3]; constructor; -intros y H4; apply H3; [now apply <- H | now apply -> H]. +intros R1 R2 H. +split; intros WF a; induction (WF a) as [x _ WF']; constructor; +intros y Ryx; apply WF'; destruct (H y x); auto. Qed. -(* solve_predicate_wd solves the goal [predicate_wd P] for P consisting of -morhisms and quatifiers *) +(** [solve_predicate_wd] solves the goal [Proper (?==>iff) P] + for P consisting of morphisms and quantifiers *) Ltac solve_predicate_wd := -unfold predicate_wd; let x := fresh "x" in let y := fresh "y" in let H := fresh "H" in intros x y H; setoid_rewrite H; reflexivity. -(* solve_relation_wd solves the goal [relation_wd R] for R consisting of -morhisms and quatifiers *) +(** [solve_relation_wd] solves the goal [Proper (?==>?==>iff) R] + for R consisting of morphisms and quantifiers *) Ltac solve_relation_wd := -unfold relation_wd, fun2_wd; let x1 := fresh "x" in let y1 := fresh "y" in let H1 := fresh "H" in @@ -191,77 +137,3 @@ Ltac induction_maker n t := pattern n; t; clear n; [solve_predicate_wd | ..]. -(** Relations on cartesian product. Used in MiscFunct for defining -functions whose domain is a product of sets by primitive recursion *) - -Section RelationOnProduct. - -Variables A B : Set. -Variable Aeq : relation A. -Variable Beq : relation B. - -Hypothesis EA_equiv : equiv A Aeq. -Hypothesis EB_equiv : equiv B Beq. - -Definition prod_rel : relation (A * B) := - fun p1 p2 => Aeq (fst p1) (fst p2) /\ Beq (snd p1) (snd p2). - -Lemma prod_rel_refl : reflexive (A * B) prod_rel. -Proof. -unfold reflexive, prod_rel. -destruct x; split; [apply (proj1 EA_equiv) | apply (proj1 EB_equiv)]; simpl. -Qed. - -Lemma prod_rel_sym : symmetric (A * B) prod_rel. -Proof. -unfold symmetric, prod_rel. -destruct x; destruct y; -split; [apply (proj2 (proj2 EA_equiv)) | apply (proj2 (proj2 EB_equiv))]; simpl in *; tauto. -Qed. - -Lemma prod_rel_trans : transitive (A * B) prod_rel. -Proof. -unfold transitive, prod_rel. -destruct x; destruct y; destruct z; simpl. -intros; split; [apply (proj1 (proj2 EA_equiv)) with (y := a0) | -apply (proj1 (proj2 EB_equiv)) with (y := b0)]; tauto. -Qed. - -Theorem prod_rel_equiv : equiv (A * B) prod_rel. -Proof. -unfold equiv; split; [exact prod_rel_refl | split; [exact prod_rel_trans | exact prod_rel_sym]]. -Qed. - -End RelationOnProduct. - -Implicit Arguments prod_rel [A B]. -Implicit Arguments prod_rel_equiv [A B]. - -(** Miscellaneous *) - -(*Definition comp_bool (x y : comparison) : bool := -match x, y with -| Lt, Lt => true -| Eq, Eq => true -| Gt, Gt => true -| _, _ => false -end. - -Theorem comp_bool_correct : forall x y : comparison, - comp_bool x y <-> x = y. -Proof. -destruct x; destruct y; simpl; split; now intro. -Qed.*) - -Lemma eq_equiv : forall A : Set, equiv A (@eq A). -Proof. -intro A; unfold equiv, reflexive, symmetric, transitive. -repeat split; [exact (@trans_eq A) | exact (@sym_eq A)]. -(* It is interesting how the tactic split proves reflexivity *) -Qed. - -(*Add Relation (fun A : Set => A) LE_Set - reflexivity proved by (fun A : Set => (proj1 (eq_equiv A))) - symmetry proved by (fun A : Set => (proj2 (proj2 (eq_equiv A)))) - transitivity proved by (fun A : Set => (proj1 (proj2 (eq_equiv A)))) -as EA_rel.*) diff --git a/theories/Numbers/Rational/BigQ/BigQ.v b/theories/Numbers/Rational/BigQ/BigQ.v index f01cbbc5..0bc71166 100644 --- a/theories/Numbers/Rational/BigQ/BigQ.v +++ b/theories/Numbers/Rational/BigQ/BigQ.v @@ -5,12 +5,13 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) -(*i $Id: BigQ.v 12509 2009-11-12 15:52:50Z letouzey $ i*) +(** * BigQ: an efficient implementation of rational numbers *) + +(** Initial authors: Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -Require Import Field Qfield BigN BigZ QSig QMake. +Require Export BigZ. +Require Import Field Qfield QSig QMake Orders GenericMinMax. (** We choose for BigQ an implemention with multiple representation of 0: 0, 1/0, 2/0 etc. @@ -34,7 +35,9 @@ End BigN_BigZ. (** This allows to build [BigQ] out of [BigN] and [BigQ] via [QMake] *) -Module BigQ <: QSig.QType := QMake.Make BigN BigZ BigN_BigZ. +Module BigQ <: QType <: OrderedTypeFull <: TotalOrder := + QMake.Make BigN BigZ BigN_BigZ <+ !QProperties <+ HasEqBool2Dec + <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties. (** Notations about [BigQ] *) @@ -43,12 +46,40 @@ Notation bigQ := BigQ.t. Delimit Scope bigQ_scope with bigQ. Bind Scope bigQ_scope with bigQ. Bind Scope bigQ_scope with BigQ.t. - -(* Allow nice printing of rational numerals, either as (Qz 1234) - or as (Qq 1234 5678) *) +Bind Scope bigQ_scope with BigQ.t_. +(* Bind Scope has no retroactive effect, let's declare scopes by hand. *) Arguments Scope BigQ.Qz [bigZ_scope]. -Arguments Scope BigQ.Qq [bigZ_scope bigN_scope]. - +Arguments Scope BigQ.Qq [bigZ_scope bigN_scope]. +Arguments Scope BigQ.to_Q [bigQ_scope]. +Arguments Scope BigQ.red [bigQ_scope]. +Arguments Scope BigQ.opp [bigQ_scope]. +Arguments Scope BigQ.inv [bigQ_scope]. +Arguments Scope BigQ.square [bigQ_scope]. +Arguments Scope BigQ.add [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.sub [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.mul [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.div [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.eq [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.lt [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.le [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.eq [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.compare [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.min [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.max [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.eq_bool [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.power_pos [bigQ_scope positive_scope]. +Arguments Scope BigQ.power [bigQ_scope Z_scope]. +Arguments Scope BigQ.inv_norm [bigQ_scope]. +Arguments Scope BigQ.add_norm [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.sub_norm [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.mul_norm [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.div_norm [bigQ_scope bigQ_scope]. +Arguments Scope BigQ.power_norm [bigQ_scope bigQ_scope]. + +(** As in QArith, we use [#] to denote fractions *) +Notation "p # q" := (BigQ.Qq p q) (at level 55, no associativity) : bigQ_scope. +Local Notation "0" := BigQ.zero : bigQ_scope. +Local Notation "1" := BigQ.one : bigQ_scope. Infix "+" := BigQ.add : bigQ_scope. Infix "-" := BigQ.sub : bigQ_scope. Notation "- x" := (BigQ.opp x) : bigQ_scope. @@ -57,142 +88,102 @@ Infix "/" := BigQ.div : bigQ_scope. Infix "^" := BigQ.power : bigQ_scope. Infix "?=" := BigQ.compare : bigQ_scope. Infix "==" := BigQ.eq : bigQ_scope. +Notation "x != y" := (~x==y)%bigQ (at level 70, no associativity) : bigQ_scope. Infix "<" := BigQ.lt : bigQ_scope. Infix "<=" := BigQ.le : bigQ_scope. Notation "x > y" := (BigQ.lt y x)(only parsing) : bigQ_scope. Notation "x >= y" := (BigQ.le y x)(only parsing) : bigQ_scope. +Notation "x < y < z" := (x Qeq_refl [x]) - symmetry proved by (fun x y => Qeq_sym [x] [y]) - transitivity proved by (fun x y z => Qeq_trans [x] [y] [z]) -as BigQeq_rel. - -Add Morphism BigQ.add with signature BigQ.eq ==> BigQ.eq ==> BigQ.eq as BigQadd_wd. -Proof. - unfold BigQ.eq; intros; rewrite !BigQ.spec_add; rewrite H, H0; apply Qeq_refl. -Qed. - -Add Morphism BigQ.opp with signature BigQ.eq ==> BigQ.eq as BigQopp_wd. -Proof. - unfold BigQ.eq; intros; rewrite !BigQ.spec_opp; rewrite H; apply Qeq_refl. -Qed. - -Add Morphism BigQ.sub with signature BigQ.eq ==> BigQ.eq ==> BigQ.eq as BigQsub_wd. -Proof. - unfold BigQ.eq; intros; rewrite !BigQ.spec_sub; rewrite H, H0; apply Qeq_refl. -Qed. - -Add Morphism BigQ.mul with signature BigQ.eq ==> BigQ.eq ==> BigQ.eq as BigQmul_wd. -Proof. - unfold BigQ.eq; intros; rewrite !BigQ.spec_mul; rewrite H, H0; apply Qeq_refl. -Qed. - -Add Morphism BigQ.inv with signature BigQ.eq ==> BigQ.eq as BigQinv_wd. -Proof. - unfold BigQ.eq; intros; rewrite !BigQ.spec_inv; rewrite H; apply Qeq_refl. -Qed. - -Add Morphism BigQ.div with signature BigQ.eq ==> BigQ.eq ==> BigQ.eq as BigQdiv_wd. -Proof. - unfold BigQ.eq; intros; rewrite !BigQ.spec_div; rewrite H, H0; apply Qeq_refl. -Qed. - -(* TODO : fix this. For the moment it's useless (horribly slow) -Hint Rewrite - BigQ.spec_0 BigQ.spec_1 BigQ.spec_m1 BigQ.spec_compare - BigQ.spec_red BigQ.spec_add BigQ.spec_sub BigQ.spec_opp - BigQ.spec_mul BigQ.spec_inv BigQ.spec_div BigQ.spec_power_pos - BigQ.spec_square : bigq. *) - +Local Open Scope bigQ_scope. (** [BigQ] is a field *) Lemma BigQfieldth : - field_theory BigQ.zero BigQ.one BigQ.add BigQ.mul BigQ.sub BigQ.opp BigQ.div BigQ.inv BigQ.eq. + field_theory 0 1 BigQ.add BigQ.mul BigQ.sub BigQ.opp + BigQ.div BigQ.inv BigQ.eq. Proof. constructor. -constructor; intros; red. -rewrite BigQ.spec_add, BigQ.spec_0; ring. -rewrite ! BigQ.spec_add; ring. -rewrite ! BigQ.spec_add; ring. -rewrite BigQ.spec_mul, BigQ.spec_1; ring. -rewrite ! BigQ.spec_mul; ring. -rewrite ! BigQ.spec_mul; ring. -rewrite BigQ.spec_add, ! BigQ.spec_mul, BigQ.spec_add; ring. -unfold BigQ.sub; apply Qeq_refl. -rewrite BigQ.spec_add, BigQ.spec_0, BigQ.spec_opp; ring. -compute; discriminate. -intros; red. -unfold BigQ.div; apply Qeq_refl. -intros; red. -rewrite BigQ.spec_mul, BigQ.spec_inv, BigQ.spec_1; field. -rewrite <- BigQ.spec_0; auto. -Qed. - -Lemma BigQpowerth : - power_theory BigQ.one BigQ.mul BigQ.eq Z_of_N BigQ.power. -Proof. constructor. -intros; red. -rewrite BigQ.spec_power. -replace ([r] ^ Z_of_N n)%Q with (pow_N 1 Qmult [r] n)%Q. -destruct n. -simpl; compute; auto. -induction p; simpl; auto; try rewrite !BigQ.spec_mul, !IHp; apply Qeq_refl. -destruct n; reflexivity. -Qed. - -Lemma BigQ_eq_bool_correct : - forall x y, BigQ.eq_bool x y = true -> x==y. -Proof. -intros; generalize (BigQ.spec_eq_bool x y); rewrite H; auto. +exact BigQ.add_0_l. exact BigQ.add_comm. exact BigQ.add_assoc. +exact BigQ.mul_1_l. exact BigQ.mul_comm. exact BigQ.mul_assoc. +exact BigQ.mul_add_distr_r. exact BigQ.sub_add_opp. +exact BigQ.add_opp_diag_r. exact BigQ.neq_1_0. +exact BigQ.div_mul_inv. exact BigQ.mul_inv_diag_l. Qed. -Lemma BigQ_eq_bool_complete : - forall x y, x==y -> BigQ.eq_bool x y = true. +Lemma BigQpowerth : + power_theory 1 BigQ.mul BigQ.eq Z_of_N BigQ.power. Proof. -intros; generalize (BigQ.spec_eq_bool x y). -destruct BigQ.eq_bool; auto. +constructor. intros. BigQ.qify. +replace ([r] ^ Z_of_N n)%Q with (pow_N 1 Qmult [r] n)%Q by (now destruct n). +destruct n. reflexivity. +induction p; simpl; auto; rewrite ?BigQ.spec_mul, ?IHp; reflexivity. Qed. -(* TODO : improve later the detection of constants ... *) +Ltac isBigQcst t := + match t with + | BigQ.Qz ?t => isBigZcst t + | BigQ.Qq ?n ?d => match isBigZcst n with + | true => isBigNcst d + | false => constr:false + end + | BigQ.zero => constr:true + | BigQ.one => constr:true + | BigQ.minus_one => constr:true + | _ => constr:false + end. Ltac BigQcst t := - match t with - | BigQ.zero => BigQ.zero - | BigQ.one => BigQ.one - | BigQ.minus_one => BigQ.minus_one - | _ => NotConstant + match isBigQcst t with + | true => constr:t + | false => constr:NotConstant end. Add Field BigQfield : BigQfieldth - (decidable BigQ_eq_bool_correct, - completeness BigQ_eq_bool_complete, + (decidable BigQ.eqb_correct, + completeness BigQ.eqb_complete, constants [BigQcst], power_tac BigQpowerth [Qpow_tac]). -Section Examples. +Section TestField. Let ex1 : forall x y z, (x+y)*z == (x*z)+(y*z). intros. ring. Qed. -Let ex8 : forall x, x ^ 1 == x. +Let ex8 : forall x, x ^ 2 == x*x. intro. ring. Qed. -Let ex10 : forall x y, ~(y==BigQ.zero) -> (x/y)*y == x. +Let ex10 : forall x y, y!=0 -> (x/y)*y == x. intros. field. auto. Qed. -End Examples. \ No newline at end of file +End TestField. + +(** [BigQ] can also benefit from an "order" tactic *) + +Module BigQ_Order := !OrdersTac.MakeOrderTac BigQ. +Ltac bigQ_order := BigQ_Order.order. + +Section TestOrder. +Let test : forall x y : bigQ, x<=y -> y<=x -> x==y. +Proof. bigQ_order. Qed. +End TestOrder. + +(** We can also reason by switching to QArith thanks to tactic + BigQ.qify. *) + +Section TestQify. +Let test : forall x : bigQ, 0+x == 1*x. +Proof. intro x. BigQ.qify. ring. Qed. +End TestQify. diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v index 494420bd..407f7b90 100644 --- a/theories/Numbers/Rational/BigQ/QMake.v +++ b/theories/Numbers/Rational/BigQ/QMake.v @@ -5,15 +5,20 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) -(*i $Id: QMake.v 11208 2008-07-04 16:57:46Z letouzey $ i*) +(** * QMake : a generic efficient implementation of rational numbers *) + +(** Initial authors : Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) Require Import BigNumPrelude ROmega. -Require Import QArith Qcanon Qpower. +Require Import QArith Qcanon Qpower Qminmax. Require Import NSig ZSig QSig. +(** We will build rationals out of an implementation of integers [ZType] + for numerators and an implementation of natural numbers [NType] for + denominators. But first we will need some glue between [NType] and + [ZType]. *) + Module Type NType_ZType (N:NType)(Z:ZType). Parameter Z_of_N : N.t -> Z.t. Parameter spec_Z_of_N : forall n, Z.to_Z (Z_of_N n) = N.to_Z n. @@ -28,27 +33,27 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. number y interpreted as x/y. The pairs (x,0) and (0,y) are all interpreted as 0. *) - Inductive t_ := + Inductive t_ := | Qz : Z.t -> t_ | Qq : Z.t -> N.t -> t_. Definition t := t_. - (** Specification with respect to [QArith] *) + (** Specification with respect to [QArith] *) - Open Local Scope Q_scope. + Local Open Scope Q_scope. Definition of_Z x: t := Qz (Z.of_Z x). - Definition of_Q (q:Q) : t := - let (x,y) := q in - match y with + Definition of_Q (q:Q) : t := + let (x,y) := q in + match y with | 1%positive => Qz (Z.of_Z x) | _ => Qq (Z.of_Z x) (N.of_N (Npos y)) end. - Definition to_Q (q: t) := - match q with + Definition to_Q (q: t) := + match q with | Qz x => Z.to_Z x # 1 | Qq x y => if N.eq_bool y N.zero then 0 else Z.to_Z x # Z2P (N.to_Z y) @@ -56,17 +61,56 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Notation "[ x ]" := (to_Q x). + Lemma N_to_Z_pos : + forall x, (N.to_Z x <> N.to_Z N.zero)%Z -> (0 < N.to_Z x)%Z. + Proof. + intros x; rewrite N.spec_0; generalize (N.spec_pos x). romega. + Qed. +(* + Lemma if_fun_commut : forall A B (f:A->B)(b:bool) a a', + f (if b then a else a') = if b then f a else f a'. + Proof. now destruct b. Qed. + + Lemma if_fun_commut' : forall A B C D (f:A->B)(b:{C}+{D}) a a', + f (if b then a else a') = if b then f a else f a'. + Proof. now destruct b. Qed. +*) + Ltac destr_eqb := + match goal with + | |- context [Z.eq_bool ?x ?y] => + rewrite (Z.spec_eq_bool x y); + generalize (Zeq_bool_if (Z.to_Z x) (Z.to_Z y)); + case (Zeq_bool (Z.to_Z x) (Z.to_Z y)); + destr_eqb + | |- context [N.eq_bool ?x ?y] => + rewrite (N.spec_eq_bool x y); + generalize (Zeq_bool_if (N.to_Z x) (N.to_Z y)); + case (Zeq_bool (N.to_Z x) (N.to_Z y)); + [ | let H:=fresh "H" in + try (intro H;generalize (N_to_Z_pos _ H); clear H)]; + destr_eqb + | _ => idtac + end. + + Hint Rewrite + Zplus_0_r Zplus_0_l Zmult_0_r Zmult_0_l Zmult_1_r Zmult_1_l + Z.spec_0 N.spec_0 Z.spec_1 N.spec_1 Z.spec_m1 Z.spec_opp + Z.spec_compare N.spec_compare + Z.spec_add N.spec_add Z.spec_mul N.spec_mul Z.spec_div N.spec_div + Z.spec_gcd N.spec_gcd Zgcd_Zabs Zgcd_1 + spec_Z_of_N spec_Zabs_N + : nz. + Ltac nzsimpl := autorewrite with nz in *. + + Ltac qsimpl := try red; unfold to_Q; simpl; intros; + destr_eqb; simpl; nzsimpl; intros; + rewrite ?Z2P_correct by auto; + auto. + Theorem strong_spec_of_Q: forall q: Q, [of_Q q] = q. Proof. - intros(x,y); destruct y; simpl; rewrite Z.spec_of_Z; auto. - generalize (N.spec_eq_bool (N.of_N (Npos y~1)) N.zero); - case N.eq_bool; auto; rewrite N.spec_0. - rewrite N.spec_of_N; intros; discriminate. - rewrite N.spec_of_N; auto. - generalize (N.spec_eq_bool (N.of_N (Npos y~0)) N.zero); - case N.eq_bool; auto; rewrite N.spec_0. - rewrite N.spec_of_N; intros; discriminate. - rewrite N.spec_of_N; auto. + intros(x,y); destruct y; simpl; rewrite ?Z.spec_of_Z; auto; + destr_eqb; now rewrite ?N.spec_0, ?N.spec_of_N. Qed. Theorem spec_of_Q: forall q: Q, [of_Q q] == q. @@ -82,131 +126,96 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Lemma spec_0: [zero] == 0. Proof. - simpl; rewrite Z.spec_0; reflexivity. + simpl. nzsimpl. reflexivity. Qed. Lemma spec_1: [one] == 1. Proof. - simpl; rewrite Z.spec_1; reflexivity. + simpl. nzsimpl. reflexivity. Qed. Lemma spec_m1: [minus_one] == -(1). Proof. - simpl; rewrite Z.spec_m1; reflexivity. + simpl. nzsimpl. reflexivity. Qed. Definition compare (x y: t) := match x, y with | Qz zx, Qz zy => Z.compare zx zy - | Qz zx, Qq ny dy => + | Qz zx, Qq ny dy => if N.eq_bool dy N.zero then Z.compare zx Z.zero else Z.compare (Z.mul zx (Z_of_N dy)) ny - | Qq nx dx, Qz zy => - if N.eq_bool dx N.zero then Z.compare Z.zero zy + | Qq nx dx, Qz zy => + if N.eq_bool dx N.zero then Z.compare Z.zero zy else Z.compare nx (Z.mul zy (Z_of_N dx)) | Qq nx dx, Qq ny dy => match N.eq_bool dx N.zero, N.eq_bool dy N.zero with | true, true => Eq | true, false => Z.compare Z.zero ny | false, true => Z.compare nx Z.zero - | false, false => Z.compare (Z.mul nx (Z_of_N dy)) + | false, false => Z.compare (Z.mul nx (Z_of_N dy)) (Z.mul ny (Z_of_N dx)) end end. - Lemma Zcompare_spec_alt : - forall z z', Z.compare z z' = (Z.to_Z z ?= Z.to_Z z')%Z. + Theorem spec_compare: forall q1 q2, (compare q1 q2) = ([q1] ?= [q2]). Proof. - intros; generalize (Z.spec_compare z z'); destruct Z.compare; auto. - intro H; rewrite H; symmetry; apply Zcompare_refl. + intros [z1 | x1 y1] [z2 | x2 y2]; + unfold Qcompare, compare; qsimpl. Qed. - - Lemma Ncompare_spec_alt : - forall n n', N.compare n n' = (N.to_Z n ?= N.to_Z n')%Z. + + Definition lt n m := [n] < [m]. + Definition le n m := [n] <= [m]. + + Definition min n m := match compare n m with Gt => m | _ => n end. + Definition max n m := match compare n m with Lt => m | _ => n end. + + Lemma spec_min : forall n m, [min n m] == Qmin [n] [m]. Proof. - intros; generalize (N.spec_compare n n'); destruct N.compare; auto. - intro H; rewrite H; symmetry; apply Zcompare_refl. + unfold min, Qmin, GenericMinMax.gmin. intros. + rewrite spec_compare; destruct Qcompare; auto with qarith. Qed. - Lemma N_to_Z2P : forall n, N.to_Z n <> 0%Z -> - Zpos (Z2P (N.to_Z n)) = N.to_Z n. + Lemma spec_max : forall n m, [max n m] == Qmax [n] [m]. Proof. - intros; apply Z2P_correct. - generalize (N.spec_pos n); romega. + unfold max, Qmax, GenericMinMax.gmax. intros. + rewrite spec_compare; destruct Qcompare; auto with qarith. Qed. - Hint Rewrite - Zplus_0_r Zplus_0_l Zmult_0_r Zmult_0_l Zmult_1_r Zmult_1_l - Z.spec_0 N.spec_0 Z.spec_1 N.spec_1 Z.spec_m1 Z.spec_opp - Zcompare_spec_alt Ncompare_spec_alt - Z.spec_add N.spec_add Z.spec_mul N.spec_mul - Z.spec_gcd N.spec_gcd Zgcd_Zabs - spec_Z_of_N spec_Zabs_N - : nz. - Ltac nzsimpl := autorewrite with nz in *. - - Ltac destr_neq_bool := repeat - (match goal with |- context [N.eq_bool ?x ?y] => - generalize (N.spec_eq_bool x y); case N.eq_bool - end). - - Ltac destr_zeq_bool := repeat - (match goal with |- context [Z.eq_bool ?x ?y] => - generalize (Z.spec_eq_bool x y); case Z.eq_bool - end). - - Ltac simpl_ndiv := rewrite N.spec_div by (nzsimpl; romega). - Tactic Notation "simpl_ndiv" "in" "*" := - rewrite N.spec_div in * by (nzsimpl; romega). - - Ltac simpl_zdiv := rewrite Z.spec_div by (nzsimpl; romega). - Tactic Notation "simpl_zdiv" "in" "*" := - rewrite Z.spec_div in * by (nzsimpl; romega). - - Ltac qsimpl := try red; unfold to_Q; simpl; intros; - destr_neq_bool; destr_zeq_bool; simpl; nzsimpl; auto; intros. + Definition eq_bool n m := + match compare n m with Eq => true | _ => false end. - Theorem spec_compare: forall q1 q2, (compare q1 q2) = ([q1] ?= [q2]). + Theorem spec_eq_bool: forall x y, eq_bool x y = Qeq_bool [x] [y]. Proof. - intros [z1 | x1 y1] [z2 | x2 y2]; - unfold Qcompare, compare; qsimpl; rewrite ! N_to_Z2P; auto. + intros. unfold eq_bool. rewrite spec_compare. reflexivity. Qed. - Definition lt n m := compare n m = Lt. - Definition le n m := compare n m <> Gt. - Definition min n m := match compare n m with Gt => m | _ => n end. - Definition max n m := match compare n m with Lt => m | _ => n end. + (** [check_int] : is a reduced fraction [n/d] in fact a integer ? *) - Definition eq_bool n m := - match compare n m with Eq => true | _ => false end. + Definition check_int n d := + match N.compare N.one d with + | Lt => Qq n d + | Eq => Qz n + | Gt => zero (* n/0 encodes 0 *) + end. - Theorem spec_eq_bool: forall x y, - if eq_bool x y then [x] == [y] else ~([x] == [y]). + Theorem strong_spec_check_int : forall n d, [check_int n d] = [Qq n d]. Proof. - intros. - unfold eq_bool. - rewrite spec_compare. - generalize (Qeq_alt [x] [y]). - destruct Qcompare. - intros H; rewrite H; auto. - intros H H'; rewrite H in H'; discriminate. - intros H H'; rewrite H in H'; discriminate. + intros; unfold check_int. + nzsimpl. + destr_zcompare. + simpl. rewrite <- H; qsimpl. congruence. + reflexivity. + qsimpl. exfalso; romega. Qed. (** Normalisation function *) Definition norm n d : t := - let gcd := N.gcd (Zabs_N n) d in + let gcd := N.gcd (Zabs_N n) d in match N.compare N.one gcd with - | Lt => - let n := Z.div n (Z_of_N gcd) in - let d := N.div d gcd in - match N.compare d N.one with - | Gt => Qq n d - | Eq => Qz n - | Lt => zero - end - | Eq => Qq n d + | Lt => check_int (Z.div n (Z_of_N gcd)) (N.div d gcd) + | Eq => check_int n d | Gt => zero (* gcd = 0 => both numbers are 0 *) end. @@ -217,29 +226,16 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. assert (Hq := N.spec_pos q). nzsimpl. destr_zcompare. + (* Eq *) + rewrite strong_spec_check_int; reflexivity. + (* Lt *) + rewrite strong_spec_check_int. qsimpl. - - simpl_ndiv. - destr_zcompare. - qsimpl. - rewrite H1 in *; rewrite Zdiv_0_l in H0; discriminate. - rewrite N_to_Z2P; auto. - simpl_zdiv; nzsimpl. - rewrite Zgcd_div_swap0, H0; romega. - - qsimpl. - assert (0 < N.to_Z q / Zgcd (Z.to_Z p) (N.to_Z q))%Z. - apply Zgcd_div_pos; romega. - romega. - - qsimpl. - simpl_ndiv in *; nzsimpl; romega. - simpl_ndiv in *. - rewrite H1, Zdiv_0_l in H2; elim H2; auto. - rewrite 2 N_to_Z2P; auto. - simpl_ndiv; simpl_zdiv; nzsimpl. + generalize (Zgcd_div_pos (Z.to_Z p) (N.to_Z q)). romega. + replace (N.to_Z q) with 0%Z in * by assumption. + rewrite Zdiv_0_l in *; auto with zarith. apply Zgcd_div_swap0; romega. - + (* Gt *) qsimpl. assert (H' : Zgcd (Z.to_Z p) (N.to_Z q) = 0%Z). generalize (Zgcd_is_pos (Z.to_Z p) (N.to_Z q)); romega. @@ -249,48 +245,37 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem strong_spec_norm : forall p q, [norm p q] = Qred [Qq p q]. Proof. intros. - replace (Qred [Qq p q]) with (Qred [norm p q]) by + replace (Qred [Qq p q]) with (Qred [norm p q]) by (apply Qred_complete; apply spec_norm). symmetry; apply Qred_identity. unfold norm. assert (Hp := N.spec_pos (Zabs_N p)). assert (Hq := N.spec_pos q). nzsimpl. - destr_zcompare. + destr_zcompare; rewrite ?strong_spec_check_int. (* Eq *) - simpl. - destr_neq_bool; nzsimpl; simpl; auto. - intros. - rewrite N_to_Z2P; auto. - (* Lt *) - simpl_ndiv. - destr_zcompare. - qsimpl; auto. qsimpl. + (* Lt *) qsimpl. - simpl_zdiv; nzsimpl. - rewrite N_to_Z2P; auto. - clear H1. - simpl_ndiv; nzsimpl. rewrite Zgcd_1_rel_prime. destruct (Z_lt_le_dec 0 (N.to_Z q)). apply Zis_gcd_rel_prime; auto with zarith. apply Zgcd_is_gcd. replace (N.to_Z q) with 0%Z in * by romega. - rewrite Zdiv_0_l in H0; discriminate. + rewrite Zdiv_0_l in *; romega. (* Gt *) - simpl; auto. + simpl; auto with zarith. Qed. - (** Reduction function : producing irreducible fractions *) + (** Reduction function : producing irreducible fractions *) - Definition red (x : t) : t := - match x with + Definition red (x : t) : t := + match x with | Qz z => x | Qq n d => norm n d end. - Definition Reduced x := [red x] = [x]. + Class Reduced x := is_reduced : [red x] = [x]. Theorem spec_red : forall x, [red x] == [x]. Proof. @@ -304,21 +289,21 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Proof. intros [ z | n d ]. unfold red. - symmetry; apply Qred_identity; simpl; auto. + symmetry; apply Qred_identity; simpl; auto with zarith. unfold red; apply strong_spec_norm. Qed. - + Definition add (x y: t): t := match x with | Qz zx => match y with | Qz zy => Qz (Z.add zx zy) - | Qq ny dy => - if N.eq_bool dy N.zero then x + | Qq ny dy => + if N.eq_bool dy N.zero then x else Qq (Z.add (Z.mul zx (Z_of_N dy)) ny) dy end | Qq nx dx => - if N.eq_bool dx N.zero then y + if N.eq_bool dx N.zero then y else match y with | Qz zy => Qq (Z.add nx (Z.mul zy (Z_of_N dx))) dx | Qq ny dy => @@ -332,19 +317,12 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_add : forall x y, [add x y] == [x] + [y]. Proof. - intros [x | nx dx] [y | ny dy]; unfold Qplus; qsimpl. - intuition. - rewrite N_to_Z2P; auto. - intuition. - rewrite Pmult_1_r, N_to_Z2P; auto. - intuition. - rewrite Pmult_1_r, N_to_Z2P; auto. - destruct (Zmult_integral _ _ H); intuition. - rewrite Zpos_mult_morphism, 2 N_to_Z2P; auto. - rewrite (Z2P_correct (N.to_Z dx * N.to_Z dy)); auto. - apply Zmult_lt_0_compat. - generalize (N.spec_pos dx); romega. - generalize (N.spec_pos dy); romega. + intros [x | nx dx] [y | ny dy]; unfold Qplus; qsimpl; + auto with zarith. + rewrite Pmult_1_r, Z2P_correct; auto. + rewrite Pmult_1_r, Z2P_correct; auto. + destruct (Zmult_integral (N.to_Z dx) (N.to_Z dy)); intuition. + rewrite Zpos_mult_morphism, 2 Z2P_correct; auto. Qed. Definition add_norm (x y: t): t := @@ -352,12 +330,12 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. | Qz zx => match y with | Qz zy => Qz (Z.add zx zy) - | Qq ny dy => - if N.eq_bool dy N.zero then x + | Qq ny dy => + if N.eq_bool dy N.zero then x else norm (Z.add (Z.mul zx (Z_of_N dy)) ny) dy end | Qq nx dx => - if N.eq_bool dx N.zero then y + if N.eq_bool dx N.zero then y else match y with | Qz zy => norm (Z.add nx (Z.mul zy (Z_of_N dx))) dx | Qq ny dy => @@ -372,26 +350,20 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_add_norm : forall x y, [add_norm x y] == [x] + [y]. Proof. intros x y; rewrite <- spec_add. - destruct x; destruct y; unfold add_norm, add; - destr_neq_bool; auto using Qeq_refl, spec_norm. + destruct x; destruct y; unfold add_norm, add; + destr_eqb; auto using Qeq_refl, spec_norm. Qed. - Theorem strong_spec_add_norm : forall x y : t, - Reduced x -> Reduced y -> Reduced (add_norm x y). + Instance strong_spec_add_norm x y + `(Reduced x, Reduced y) : Reduced (add_norm x y). Proof. unfold Reduced; intros. rewrite strong_spec_red. - rewrite <- (Qred_complete [add x y]); + rewrite <- (Qred_complete [add x y]); [ | rewrite spec_add, spec_add_norm; apply Qeq_refl ]. rewrite <- strong_spec_red. - destruct x as [zx|nx dx]; destruct y as [zy|ny dy]. - simpl in *; auto. - simpl; intros. - destr_neq_bool; nzsimpl; simpl; auto. - simpl; intros. - destr_neq_bool; nzsimpl; simpl; auto. - simpl; intros. - destr_neq_bool; nzsimpl; simpl; auto. + destruct x as [zx|nx dx]; destruct y as [zy|ny dy]; + simpl; destr_eqb; nzsimpl; simpl; auto. Qed. Definition opp (x: t): t := @@ -404,7 +376,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Proof. intros [z | x y]; simpl. rewrite Z.spec_opp; auto. - match goal with |- context[N.eq_bool ?X ?Y] => + match goal with |- context[N.eq_bool ?X ?Y] => generalize (N.spec_eq_bool X Y); case N.eq_bool end; auto; rewrite N.spec_0. rewrite Z.spec_opp; auto. @@ -415,7 +387,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. intros; rewrite strong_spec_opp; red; auto. Qed. - Theorem strong_spec_opp_norm : forall q, Reduced q -> Reduced (opp q). + Instance strong_spec_opp_norm q `(Reduced q) : Reduced (opp q). Proof. unfold Reduced; intros. rewrite strong_spec_opp, <- H, !strong_spec_red, <- Qred_opp. @@ -438,8 +410,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite spec_opp; ring. Qed. - Theorem strong_spec_sub_norm : forall x y, - Reduced x -> Reduced y -> Reduced (sub_norm x y). + Instance strong_spec_sub_norm x y + `(Reduced x, Reduced y) : Reduced (sub_norm x y). Proof. intros. unfold sub_norm. @@ -458,35 +430,34 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_mul : forall x y, [mul x y] == [x] * [y]. Proof. intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl; qsimpl. - rewrite Pmult_1_r, N_to_Z2P; auto. - destruct (Zmult_integral _ _ H1); intuition. - rewrite H0 in H1; elim H1; auto. - rewrite H0 in H1; elim H1; auto. - rewrite H in H1; nzsimpl; elim H1; auto. - rewrite Zpos_mult_morphism, 2 N_to_Z2P; auto. - rewrite (Z2P_correct (N.to_Z dx * N.to_Z dy)); auto. - apply Zmult_lt_0_compat. - generalize (N.spec_pos dx); omega. - generalize (N.spec_pos dy); omega. + rewrite Pmult_1_r, Z2P_correct; auto. + destruct (Zmult_integral (N.to_Z dx) (N.to_Z dy)); intuition. + rewrite H0 in H1; auto with zarith. + rewrite H0 in H1; auto with zarith. + rewrite H in H1; nzsimpl; auto with zarith. + rewrite Zpos_mult_morphism, 2 Z2P_correct; auto. Qed. - Lemma norm_denum : forall n d, - [if N.eq_bool d N.one then Qz n else Qq n d] == [Qq n d]. + Definition norm_denum n d := + if N.eq_bool d N.one then Qz n else Qq n d. + + Lemma spec_norm_denum : forall n d, + [norm_denum n d] == [Qq n d]. Proof. - intros; simpl; qsimpl. - rewrite H0 in H; discriminate. - rewrite N_to_Z2P, H0; auto with zarith. + unfold norm_denum; intros; simpl; qsimpl. + congruence. + rewrite H0 in *; auto with zarith. Qed. - Definition irred n d := + Definition irred n d := let gcd := N.gcd (Zabs_N n) d in - match N.compare gcd N.one with + match N.compare gcd N.one with | Gt => (Z.div n (Z_of_N gcd), N.div d gcd) | _ => (n, d) end. - Lemma spec_irred : forall n d, exists g, - let (n',d') := irred n d in + Lemma spec_irred : forall n d, exists g, + let (n',d') := irred n d in (Z.to_Z n' * g = Z.to_Z n)%Z /\ (N.to_Z d' * g = N.to_Z d)%Z. Proof. intros. @@ -503,15 +474,15 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. exists (Zgcd (Z.to_Z n) (N.to_Z d)). simpl. split. - simpl_zdiv; nzsimpl. + nzsimpl. destruct (Zgcd_is_gcd (Z.to_Z n) (N.to_Z d)). rewrite Zmult_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith. - simpl_ndiv; nzsimpl. + nzsimpl. destruct (Zgcd_is_gcd (Z.to_Z n) (N.to_Z d)). rewrite Zmult_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith. Qed. - Lemma spec_irred_zero : forall n d, + Lemma spec_irred_zero : forall n d, (N.to_Z d = 0)%Z <-> (N.to_Z (snd (irred n d)) = 0)%Z. Proof. intros. @@ -520,10 +491,10 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. nzsimpl; intros. destr_zcompare; auto. simpl. - simpl_ndiv; nzsimpl. + nzsimpl. rewrite H, Zdiv_0_l; auto. nzsimpl; destr_zcompare; simpl; auto. - simpl_ndiv; nzsimpl. + nzsimpl. intros. generalize (N.spec_pos d); intros. destruct (N.to_Z d); auto. @@ -535,8 +506,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. compute in H1; elim H1; auto. Qed. - Lemma strong_spec_irred : forall n d, - (N.to_Z d <> 0%Z) -> + Lemma strong_spec_irred : forall n d, + (N.to_Z d <> 0%Z) -> let (n',d') := irred n d in Zgcd (Z.to_Z n') (N.to_Z d') = 1%Z. Proof. unfold irred; intros. @@ -546,7 +517,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply (Zgcd_inv_0_r (Z.to_Z n)). generalize (Zgcd_is_pos (Z.to_Z n) (N.to_Z d)); romega. - simpl_ndiv; simpl_zdiv; nzsimpl. + nzsimpl. rewrite Zgcd_1_rel_prime. apply Zis_gcd_rel_prime. generalize (N.spec_pos d); romega. @@ -554,89 +525,81 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply Zgcd_is_gcd; auto. Qed. - Definition mul_norm_Qz_Qq z n d := - if Z.eq_bool z Z.zero then zero + Definition mul_norm_Qz_Qq z n d := + if Z.eq_bool z Z.zero then zero else let gcd := N.gcd (Zabs_N z) d in match N.compare gcd N.one with - | Gt => + | Gt => let z := Z.div z (Z_of_N gcd) in let d := N.div d gcd in - if N.eq_bool d N.one then Qz (Z.mul z n) else Qq (Z.mul z n) d + norm_denum (Z.mul z n) d | _ => Qq (Z.mul z n) d end. - Definition mul_norm (x y: t): t := + Definition mul_norm (x y: t): t := match x, y with | Qz zx, Qz zy => Qz (Z.mul zx zy) | Qz zx, Qq ny dy => mul_norm_Qz_Qq zx ny dy | Qq nx dx, Qz zy => mul_norm_Qz_Qq zy nx dx - | Qq nx dx, Qq ny dy => - let (nx, dy) := irred nx dy in - let (ny, dx) := irred ny dx in - let d := N.mul dx dy in - if N.eq_bool d N.one then Qz (Z.mul ny nx) else Qq (Z.mul ny nx) d + | Qq nx dx, Qq ny dy => + let (nx, dy) := irred nx dy in + let (ny, dx) := irred ny dx in + norm_denum (Z.mul ny nx) (N.mul dx dy) end. - Lemma spec_mul_norm_Qz_Qq : forall z n d, + Lemma spec_mul_norm_Qz_Qq : forall z n d, [mul_norm_Qz_Qq z n d] == [Qq (Z.mul z n) d]. Proof. intros z n d; unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt. - destr_zeq_bool; intros Hz; nzsimpl. + destr_eqb; nzsimpl; intros Hz. qsimpl; rewrite Hz; auto. - assert (Hd := N.spec_pos d). - destruct Z_le_gt_dec. + destruct Z_le_gt_dec; intros. qsimpl. - rewrite norm_denum. + rewrite spec_norm_denum. qsimpl. - simpl_ndiv in *; nzsimpl. - rewrite (Zdiv_gcd_zero _ _ H0 H) in z0; discriminate. - simpl_ndiv in *; nzsimpl. - rewrite H, Zdiv_0_l in H0; elim H0; auto. - rewrite 2 N_to_Z2P; auto. - simpl_ndiv; simpl_zdiv; nzsimpl. - rewrite (Zmult_comm (Z.to_Z z)), <- 2 Zmult_assoc. - rewrite <- Zgcd_div_swap0; auto with zarith; ring. + rewrite Zdiv_gcd_zero in z0; auto with zarith. + rewrite H in *. rewrite Zdiv_0_l in *; discriminate. + rewrite <- Zmult_assoc, (Zmult_comm (Z.to_Z n)), Zmult_assoc. + rewrite Zgcd_div_swap0; try romega. + ring. Qed. - Lemma strong_spec_mul_norm_Qz_Qq : forall z n d, - Reduced (Qq n d) -> Reduced (mul_norm_Qz_Qq z n d). + Instance strong_spec_mul_norm_Qz_Qq z n d : + forall `(Reduced (Qq n d)), Reduced (mul_norm_Qz_Qq z n d). Proof. - unfold Reduced; intros z n d. + unfold Reduced. rewrite 2 strong_spec_red, 2 Qred_iff. simpl; nzsimpl. - destr_neq_bool; intros Hd H; simpl in *; nzsimpl. - + destr_eqb; intros Hd H; simpl in *; nzsimpl. + unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt. - destr_zeq_bool; intros Hz; simpl; nzsimpl; simpl; auto. + destr_eqb; intros Hz; simpl; nzsimpl; simpl; auto. destruct Z_le_gt_dec. simpl; nzsimpl. - destr_neq_bool; simpl; nzsimpl; auto. - intros H'; elim H'; auto. - destr_neq_bool; simpl; nzsimpl. - simpl_ndiv; nzsimpl; rewrite Hd, Zdiv_0_l; intros; discriminate. + destr_eqb; simpl; nzsimpl; auto with zarith. + unfold norm_denum. destr_eqb; simpl; nzsimpl. + rewrite Hd, Zdiv_0_l; discriminate. intros _. - destr_neq_bool; simpl; nzsimpl; auto. - simpl_ndiv; nzsimpl; rewrite Hd, Zdiv_0_l; intro H'; elim H'; auto. + destr_eqb; simpl; nzsimpl; auto. + nzsimpl; rewrite Hd, Zdiv_0_l; auto with zarith. - rewrite N_to_Z2P in H; auto. + rewrite Z2P_correct in H; auto. unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt. - destr_zeq_bool; intros Hz; simpl; nzsimpl; simpl; auto. + destr_eqb; intros Hz; simpl; nzsimpl; simpl; auto. destruct Z_le_gt_dec as [H'|H']. simpl; nzsimpl. - destr_neq_bool; simpl; nzsimpl; auto. + destr_eqb; simpl; nzsimpl; auto. intros. - rewrite N_to_Z2P; auto. + rewrite Z2P_correct; auto. apply Zgcd_mult_rel_prime; auto. generalize (Zgcd_inv_0_l (Z.to_Z z) (N.to_Z d)) (Zgcd_is_pos (Z.to_Z z) (N.to_Z d)); romega. - destr_neq_bool; simpl; nzsimpl; auto. - simpl_ndiv; simpl_zdiv; nzsimpl. - intros. - destr_neq_bool; simpl; nzsimpl; auto. - simpl_ndiv in *; nzsimpl. - intros. - rewrite Z2P_correct. + destr_eqb; simpl; nzsimpl; auto. + unfold norm_denum. + destr_eqb; nzsimpl; simpl; destr_eqb; simpl; auto. + intros; nzsimpl. + rewrite Z2P_correct; auto. apply Zgcd_mult_rel_prime. rewrite Zgcd_1_rel_prime. apply Zis_gcd_rel_prime. @@ -652,9 +615,6 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite <- Huv; rewrite Hd0 at 2; ring. rewrite Hd0 at 1. symmetry; apply Z_div_mult_full; auto with zarith. - apply Zgcd_div_pos. - generalize (N.spec_pos d); romega. - generalize (Zgcd_is_pos (Z.to_Z z) (N.to_Z d)); romega. Qed. Theorem spec_mul_norm : forall x y, [mul_norm x y] == [x] * [y]. @@ -670,37 +630,31 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. destruct (spec_irred ny dx) as (g' & Hg'). assert (Hz := spec_irred_zero nx dy). assert (Hz':= spec_irred_zero ny dx). - destruct irred as (n1,d1); destruct irred as (n2,d2). + destruct irred as (n1,d1); destruct irred as (n2,d2). simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. - rewrite norm_denum. + rewrite spec_norm_denum. qsimpl. - elim H; destruct (Zmult_integral _ _ H0) as [Eq|Eq]. - rewrite <- Hz' in Eq; rewrite Eq; simpl; auto. - rewrite <- Hz in Eq; rewrite Eq; nzsimpl; auto. + destruct (Zmult_integral _ _ H0) as [Eq|Eq]. + rewrite Eq in *; simpl in *. + rewrite <- Hg2' in *; auto with zarith. + rewrite Eq in *; simpl in *. + rewrite <- Hg2 in *; auto with zarith. - elim H0; destruct (Zmult_integral _ _ H) as [Eq|Eq]. - rewrite Hz' in Eq; rewrite Eq; simpl; auto. - rewrite Hz in Eq; rewrite Eq; nzsimpl; auto. + destruct (Zmult_integral _ _ H) as [Eq|Eq]. + rewrite Hz' in Eq; rewrite Eq in *; auto with zarith. + rewrite Hz in Eq; rewrite Eq in *; auto with zarith. - rewrite 2 Z2P_correct. rewrite <- Hg1, <- Hg2, <- Hg1', <- Hg2'; ring. - - assert (0 <= N.to_Z d2 * N.to_Z d1)%Z - by (apply Zmult_le_0_compat; apply N.spec_pos). - romega. - assert (0 <= N.to_Z dx * N.to_Z dy)%Z - by (apply Zmult_le_0_compat; apply N.spec_pos). - romega. Qed. - Theorem strong_spec_mul_norm : forall x y, - Reduced x -> Reduced y -> Reduced (mul_norm x y). + Instance strong_spec_mul_norm x y : + forall `(Reduced x, Reduced y), Reduced (mul_norm x y). Proof. unfold Reduced; intros. rewrite strong_spec_red, Qred_iff. destruct x as [zx|nx dx]; destruct y as [zy|ny dy]. - simpl in *; auto. + simpl in *; auto with zarith. simpl. rewrite <- Qred_iff, <- strong_spec_red, strong_spec_mul_norm_Qz_Qq; auto. simpl. @@ -712,26 +666,27 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. assert (Hz':= spec_irred_zero ny dx). assert (Hgc := strong_spec_irred nx dy). assert (Hgc' := strong_spec_irred ny dx). - destruct irred as (n1,d1); destruct irred as (n2,d2). + destruct irred as (n1,d1); destruct irred as (n2,d2). simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. - destr_neq_bool; simpl; nzsimpl; intros. - apply Zis_gcd_gcd; auto with zarith; apply Zis_gcd_1. - destr_neq_bool; simpl; nzsimpl; intros. - auto. + + unfold norm_denum; qsimpl. + + assert (NEQ : N.to_Z dy <> 0%Z) by + (rewrite Hz; intros EQ; rewrite EQ in *; romega). + specialize (Hgc NEQ). + + assert (NEQ' : N.to_Z dx <> 0%Z) by + (rewrite Hz'; intro EQ; rewrite EQ in *; romega). + specialize (Hgc' NEQ'). revert H H0. rewrite 2 strong_spec_red, 2 Qred_iff; simpl. - destr_neq_bool; simpl; nzsimpl; intros. - rewrite Hz in H; rewrite H in H2; nzsimpl; elim H2; auto. - rewrite Hz' in H0; rewrite H0 in H2; nzsimpl; elim H2; auto. - rewrite Hz in H; rewrite H in H2; nzsimpl; elim H2; auto. + destr_eqb; simpl; nzsimpl; try romega; intros. + rewrite Z2P_correct in *; auto. - rewrite N_to_Z2P in *; auto. - rewrite Z2P_correct. + apply Zgcd_mult_rel_prime; rewrite Zgcd_comm; + apply Zgcd_mult_rel_prime; rewrite Zgcd_comm; auto. - apply Zgcd_mult_rel_prime; rewrite Zgcd_sym; - apply Zgcd_mult_rel_prime; rewrite Zgcd_sym; auto. - rewrite Zgcd_1_rel_prime in *. apply bezout_rel_prime. destruct (rel_prime_bezout _ _ H4) as [u v Huv]. @@ -743,21 +698,17 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. destruct (rel_prime_bezout _ _ H3) as [u v Huv]. apply Bezout_intro with (u*g)%Z (v*g')%Z. rewrite <- Huv, <- Hg2', <- Hg1. ring. - - assert (0 <= N.to_Z d2 * N.to_Z d1)%Z. - apply Zmult_le_0_compat; apply N.spec_pos. - romega. Qed. - Definition inv (x: t): t := + Definition inv (x: t): t := match x with - | Qz z => - match Z.compare Z.zero z with + | Qz z => + match Z.compare Z.zero z with | Eq => zero | Lt => Qq Z.one (Zabs_N z) | Gt => Qq Z.minus_one (Zabs_N z) end - | Qq n d => + | Qq n d => match Z.compare Z.zero n with | Eq => zero | Lt => Qq (Z_of_N d) (Zabs_N n) @@ -770,13 +721,13 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. destruct x as [ z | n d ]. (* Qz z *) simpl. - rewrite Zcompare_spec_alt; destr_zcompare. + rewrite Z.spec_compare; destr_zcompare. (* 0 = z *) rewrite <- H. simpl; nzsimpl; compute; auto. (* 0 < z *) simpl. - destr_neq_bool; nzsimpl; [ intros; rewrite Zabs_eq in *; romega | intros _ ]. + destr_eqb; nzsimpl; [ intros; rewrite Zabs_eq in *; romega | intros _ ]. set (z':=Z.to_Z z) in *; clearbody z'. red; simpl. rewrite Zabs_eq by romega. @@ -784,7 +735,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. unfold Qinv; simpl; destruct z'; simpl; auto; discriminate. (* 0 > z *) simpl. - destr_neq_bool; nzsimpl; [ intros; rewrite Zabs_non_eq in *; romega | intros _ ]. + destr_eqb; nzsimpl; [ intros; rewrite Zabs_non_eq in *; romega | intros _ ]. set (z':=Z.to_Z z) in *; clearbody z'. red; simpl. rewrite Zabs_non_eq by romega. @@ -792,14 +743,14 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. unfold Qinv; simpl; destruct z'; simpl; auto; discriminate. (* Qq n d *) simpl. - rewrite Zcompare_spec_alt; destr_zcompare. + rewrite Z.spec_compare; destr_zcompare. (* 0 = n *) rewrite <- H. simpl; nzsimpl. - destr_neq_bool; intros; compute; auto. + destr_eqb; intros; compute; auto. (* 0 < n *) simpl. - destr_neq_bool; nzsimpl; intros. + destr_eqb; nzsimpl; intros. intros; rewrite Zabs_eq in *; romega. intros; rewrite Zabs_eq in *; romega. clear H1. @@ -811,10 +762,10 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. red; simpl. rewrite Z2P_correct by auto. unfold Qinv; simpl; destruct n'; simpl; auto; try discriminate. - rewrite Zpos_mult_morphism, N_to_Z2P; auto. + rewrite Zpos_mult_morphism, Z2P_correct; auto. (* 0 > n *) simpl. - destr_neq_bool; nzsimpl; intros. + destr_eqb; nzsimpl; intros. intros; rewrite Zabs_non_eq in *; romega. intros; rewrite Zabs_non_eq in *; romega. clear H1. @@ -826,28 +777,28 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite Z2P_correct by romega. unfold Qinv; simpl; destruct n'; simpl; auto; try discriminate. assert (T : forall x, Zneg x = Zopp (Zpos x)) by auto. - rewrite T, Zpos_mult_morphism, N_to_Z2P; auto; ring. + rewrite T, Zpos_mult_morphism, Z2P_correct; auto; ring. Qed. - Definition inv_norm (x: t): t := + Definition inv_norm (x: t): t := match x with - | Qz z => - match Z.compare Z.zero z with + | Qz z => + match Z.compare Z.zero z with | Eq => zero | Lt => Qq Z.one (Zabs_N z) | Gt => Qq Z.minus_one (Zabs_N z) end - | Qq n d => - if N.eq_bool d N.zero then zero else - match Z.compare Z.zero n with + | Qq n d => + if N.eq_bool d N.zero then zero else + match Z.compare Z.zero n with | Eq => zero - | Lt => - match Z.compare n Z.one with + | Lt => + match Z.compare n Z.one with | Gt => Qq (Z_of_N d) (Zabs_N n) | _ => Qz (Z_of_N d) end - | Gt => - match Z.compare n Z.minus_one with + | Gt => + match Z.compare n Z.minus_one with | Lt => Qq (Z.opp (Z_of_N d)) (Zabs_N n) | _ => Qz (Z.opp (Z_of_N d)) end @@ -861,74 +812,72 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. destruct x as [ z | n d ]. (* Qz z *) simpl. - rewrite Zcompare_spec_alt; destr_zcompare; auto with qarith. + rewrite Z.spec_compare; destr_zcompare; auto with qarith. (* Qq n d *) - simpl; nzsimpl; destr_neq_bool. + simpl; nzsimpl; destr_eqb. destr_zcompare; simpl; auto with qarith. - destr_neq_bool; nzsimpl; auto with qarith. + destr_eqb; nzsimpl; auto with qarith. intros _ Hd; rewrite Hd; auto with qarith. - destr_neq_bool; nzsimpl; auto with qarith. + destr_eqb; nzsimpl; auto with qarith. intros _ Hd; rewrite Hd; auto with qarith. (* 0 < n *) destr_zcompare; auto with qarith. destr_zcompare; nzsimpl; simpl; auto with qarith; intros. - destr_neq_bool; nzsimpl; [ intros; rewrite Zabs_eq in *; romega | intros _ ]. + destr_eqb; nzsimpl; [ intros; rewrite Zabs_eq in *; romega | intros _ ]. rewrite H0; auto with qarith. romega. (* 0 > n *) destr_zcompare; nzsimpl; simpl; auto with qarith. - destr_neq_bool; nzsimpl; [ intros; rewrite Zabs_non_eq in *; romega | intros _ ]. + destr_eqb; nzsimpl; [ intros; rewrite Zabs_non_eq in *; romega | intros _ ]. rewrite H0; auto with qarith. romega. Qed. - Theorem strong_spec_inv_norm : forall x, Reduced x -> Reduced (inv_norm x). + Instance strong_spec_inv_norm x : Reduced x -> Reduced (inv_norm x). Proof. - unfold Reduced. + unfold Reduced. intros. destruct x as [ z | n d ]. (* Qz *) simpl; nzsimpl. rewrite strong_spec_red, Qred_iff. destr_zcompare; simpl; nzsimpl; auto. - destr_neq_bool; nzsimpl; simpl; auto. - destr_neq_bool; nzsimpl; simpl; auto. + destr_eqb; nzsimpl; simpl; auto. + destr_eqb; nzsimpl; simpl; auto. (* Qq n d *) rewrite strong_spec_red, Qred_iff in H; revert H. simpl; nzsimpl. - destr_neq_bool; nzsimpl; auto with qarith. + destr_eqb; nzsimpl; auto with qarith. destr_zcompare; simpl; nzsimpl; auto; intros. (* 0 < n *) destr_zcompare; simpl; nzsimpl; auto. - destr_neq_bool; nzsimpl; simpl; auto. + destr_eqb; nzsimpl; simpl; auto. rewrite Zabs_eq; romega. intros _. rewrite strong_spec_norm; simpl; nzsimpl. - destr_neq_bool; nzsimpl. + destr_eqb; nzsimpl. rewrite Zabs_eq; romega. intros _. rewrite Qred_iff. simpl. rewrite Zabs_eq; auto with zarith. - rewrite N_to_Z2P in *; auto. - rewrite Z2P_correct; auto with zarith. - rewrite Zgcd_sym; auto. + rewrite Z2P_correct in *; auto. + rewrite Zgcd_comm; auto. (* 0 > n *) - destr_neq_bool; nzsimpl; simpl; auto; intros. + destr_eqb; nzsimpl; simpl; auto; intros. destr_zcompare; simpl; nzsimpl; auto. - destr_neq_bool; nzsimpl. + destr_eqb; nzsimpl. rewrite Zabs_non_eq; romega. intros _. rewrite strong_spec_norm; simpl; nzsimpl. - destr_neq_bool; nzsimpl. + destr_eqb; nzsimpl. rewrite Zabs_non_eq; romega. intros _. rewrite Qred_iff. simpl. - rewrite N_to_Z2P in *; auto. - rewrite Z2P_correct; auto with zarith. + rewrite Z2P_correct in *; auto. intros. - rewrite Zgcd_sym, Zgcd_Zabs, Zgcd_sym. + rewrite Zgcd_comm, Zgcd_Zabs, Zgcd_comm. apply Zis_gcd_gcd; auto with zarith. apply Zis_gcd_minus. rewrite Zopp_involutive, <- H1; apply Zgcd_is_gcd. @@ -939,7 +888,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_div x y: [div x y] == [x] / [y]. Proof. - intros x y; unfold div; rewrite spec_mul; auto. + unfold div; rewrite spec_mul; auto. unfold Qdiv; apply Qmult_comp. apply Qeq_refl. apply spec_inv; auto. @@ -949,14 +898,14 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_div_norm x y: [div_norm x y] == [x] / [y]. Proof. - intros x y; unfold div_norm; rewrite spec_mul_norm; auto. + unfold div_norm; rewrite spec_mul_norm; auto. unfold Qdiv; apply Qmult_comp. apply Qeq_refl. apply spec_inv_norm; auto. Qed. - - Theorem strong_spec_div_norm : forall x y, - Reduced x -> Reduced y -> Reduced (div_norm x y). + + Instance strong_spec_div_norm x y + `(Reduced x, Reduced y) : Reduced (div_norm x y). Proof. intros; unfold div_norm. apply strong_spec_mul_norm; auto. @@ -974,15 +923,13 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. destruct x as [ z | n d ]. simpl; rewrite Z.spec_square; red; auto. simpl. - destr_neq_bool; nzsimpl; intros. + destr_eqb; nzsimpl; intros. apply Qeq_refl. rewrite N.spec_square in *; nzsimpl. - contradict H; elim (Zmult_integral _ _ H0); auto. + elim (Zmult_integral _ _ H0); romega. rewrite N.spec_square in *; nzsimpl. - rewrite H in H0; simpl in H0; elim H0; auto. - assert (0 < N.to_Z d)%Z by (generalize (N.spec_pos d); romega). - clear H H0. - rewrite Z.spec_square, N.spec_square. + rewrite H in H0; romega. + rewrite Z.spec_square, N.spec_square. red; simpl. rewrite Zpos_mult_morphism; rewrite !Z2P_correct; auto. apply Zmult_lt_0_compat; auto. @@ -993,7 +940,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. | Qz zx => Qz (Z.power_pos zx p) | Qq nx dx => Qq (Z.power_pos nx p) (N.power_pos dx p) end. - + Theorem spec_power_pos : forall x p, [power_pos x p] == [x] ^ Zpos p. Proof. intros [ z | n d ] p; unfold power_pos. @@ -1006,44 +953,42 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. (* Qq *) simpl. rewrite Z.spec_power_pos. - destr_neq_bool; nzsimpl; intros. + destr_eqb; nzsimpl; intros. apply Qeq_sym; apply Qpower_positive_0. rewrite N.spec_power_pos in *. - assert (0 < N.to_Z d ^ ' p)%Z. - apply Zpower_gt_0; auto with zarith. - generalize (N.spec_pos d); romega. + assert (0 < N.to_Z d ^ ' p)%Z by + (apply Zpower_gt_0; auto with zarith). romega. rewrite N.spec_power_pos, H in *. - rewrite Zpower_0_l in H0; [ elim H0; auto | discriminate ]. + rewrite Zpower_0_l in H0; [romega|discriminate]. rewrite Qpower_decomp. red; simpl; do 3 f_equal. rewrite Z2P_correct by (generalize (N.spec_pos d); romega). rewrite N.spec_power_pos. auto. Qed. - Theorem strong_spec_power_pos : forall x p, - Reduced x -> Reduced (power_pos x p). + Instance strong_spec_power_pos x p `(Reduced x) : Reduced (power_pos x p). Proof. destruct x as [z | n d]; simpl; intros. red; simpl; auto. red; simpl; intros. rewrite strong_spec_norm; simpl. - destr_neq_bool; nzsimpl; intros. + destr_eqb; nzsimpl; intros. simpl; auto. rewrite Qred_iff. revert H. unfold Reduced; rewrite strong_spec_red, Qred_iff; simpl. - destr_neq_bool; nzsimpl; simpl; intros. + destr_eqb; nzsimpl; simpl; intros. rewrite N.spec_power_pos in H0. - elim H0; rewrite H; rewrite Zpower_0_l; auto; discriminate. - rewrite N_to_Z2P in *; auto. + rewrite H, Zpower_0_l in *; [romega|discriminate]. + rewrite Z2P_correct in *; auto. rewrite N.spec_power_pos, Z.spec_power_pos; auto. rewrite Zgcd_1_rel_prime in *. apply rel_prime_Zpower; auto with zarith. Qed. - Definition power (x : t) (z : Z) : t := - match z with + Definition power (x : t) (z : Z) : t := + match z with | Z0 => one | Zpos p => power_pos x p | Zneg p => inv (power_pos x p) @@ -1058,8 +1003,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite spec_inv, spec_power_pos; apply Qeq_refl. Qed. - Definition power_norm (x : t) (z : Z) : t := - match z with + Definition power_norm (x : t) (z : Z) : t := + match z with | Z0 => one | Zpos p => power_pos x p | Zneg p => inv_norm (power_pos x p) @@ -1074,7 +1019,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite spec_inv_norm, spec_power_pos; apply Qeq_refl. Qed. - Theorem strong_spec_power_norm : forall x z, + Instance strong_spec_power_norm x z : Reduced x -> Reduced (power_norm x z). Proof. destruct z; simpl. @@ -1087,7 +1032,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. (** Interaction with [Qcanon.Qc] *) - + Open Scope Qc_scope. Definition of_Qc q := of_Q (this q). @@ -1102,7 +1047,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. unfold of_Qc; rewrite strong_spec_of_Q; auto. Qed. - Lemma strong_spec_of_Qc_bis : forall q, Reduced (of_Qc q). + Instance strong_spec_of_Qc_bis q : Reduced (of_Qc q). Proof. intros; red; rewrite strong_spec_red, strong_spec_of_Qc. destruct q; simpl; auto. @@ -1143,7 +1088,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_addc x y: [[add x y]] = [[x]] + [[y]]. Proof. - intros x y; unfold to_Qc. + unfold to_Qc. apply trans_equal with (!! ([x] + [y])). unfold Q2Qc. apply Qc_decomp; intros _ _; unfold this. @@ -1157,7 +1102,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_add_normc x y: [[add_norm x y]] = [[x]] + [[y]]. Proof. - intros x y; unfold to_Qc. + unfold to_Qc. apply trans_equal with (!! ([x] + [y])). unfold Q2Qc. apply Qc_decomp; intros _ _; unfold this. @@ -1168,7 +1113,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply Qplus_comp; apply Qeq_sym; apply Qred_correct. Qed. - Theorem spec_add_normc_bis : forall x y : Qc, + Theorem spec_add_normc_bis : forall x y : Qc, [add_norm (of_Qc x) (of_Qc y)] = x+y. Proof. intros. @@ -1180,18 +1125,18 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_subc x y: [[sub x y]] = [[x]] - [[y]]. Proof. - intros x y; unfold sub; rewrite spec_addc; auto. + unfold sub; rewrite spec_addc; auto. rewrite spec_oppc; ring. Qed. Theorem spec_sub_normc x y: [[sub_norm x y]] = [[x]] - [[y]]. Proof. - intros x y; unfold sub_norm; rewrite spec_add_normc; auto. + unfold sub_norm; rewrite spec_add_normc; auto. rewrite spec_oppc; ring. Qed. - Theorem spec_sub_normc_bis : forall x y : Qc, + Theorem spec_sub_normc_bis : forall x y : Qc, [sub_norm (of_Qc x) (of_Qc y)] = x-y. Proof. intros. @@ -1199,13 +1144,13 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite strong_spec_red. symmetry; apply (Qred_complete (x+(-y)%Qc)%Q). rewrite spec_sub_norm, ! strong_spec_of_Qc. - unfold Qcopp, Q2Qc; rewrite Qred_correct; auto with qarith. + unfold Qcopp, Q2Qc, this. rewrite Qred_correct ; auto with qarith. Qed. Theorem spec_mulc x y: [[mul x y]] = [[x]] * [[y]]. Proof. - intros x y; unfold to_Qc. + unfold to_Qc. apply trans_equal with (!! ([x] * [y])). unfold Q2Qc. apply Qc_decomp; intros _ _; unfold this. @@ -1219,7 +1164,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_mul_normc x y: [[mul_norm x y]] = [[x]] * [[y]]. Proof. - intros x y; unfold to_Qc. + unfold to_Qc. apply trans_equal with (!! ([x] * [y])). unfold Q2Qc. apply Qc_decomp; intros _ _; unfold this. @@ -1230,7 +1175,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply Qmult_comp; apply Qeq_sym; apply Qred_correct. Qed. - Theorem spec_mul_normc_bis : forall x y : Qc, + Theorem spec_mul_normc_bis : forall x y : Qc, [mul_norm (of_Qc x) (of_Qc y)] = x*y. Proof. intros. @@ -1243,7 +1188,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_invc x: [[inv x]] = /[[x]]. Proof. - intros x; unfold to_Qc. + unfold to_Qc. apply trans_equal with (!! (/[x])). unfold Q2Qc. apply Qc_decomp; intros _ _; unfold this. @@ -1257,7 +1202,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_inv_normc x: [[inv_norm x]] = /[[x]]. Proof. - intros x; unfold to_Qc. + unfold to_Qc. apply trans_equal with (!! (/[x])). unfold Q2Qc. apply Qc_decomp; intros _ _; unfold this. @@ -1268,7 +1213,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply Qinv_comp; apply Qeq_sym; apply Qred_correct. Qed. - Theorem spec_inv_normc_bis : forall x : Qc, + Theorem spec_inv_normc_bis : forall x : Qc, [inv_norm (of_Qc x)] = /x. Proof. intros. @@ -1280,19 +1225,19 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]]. Proof. - intros x y; unfold div; rewrite spec_mulc; auto. + unfold div; rewrite spec_mulc; auto. unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. + apply spec_invc; auto. Qed. Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]]. Proof. - intros x y; unfold div_norm; rewrite spec_mul_normc; auto. + unfold div_norm; rewrite spec_mul_normc; auto. unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. apply spec_inv_normc; auto. Qed. - Theorem spec_div_normc_bis : forall x y : Qc, + Theorem spec_div_normc_bis : forall x y : Qc, [div_norm (of_Qc x) (of_Qc y)] = x/y. Proof. intros. @@ -1300,12 +1245,12 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite strong_spec_red. symmetry; apply (Qred_complete (x*(/y)%Qc)%Q). rewrite spec_div_norm, ! strong_spec_of_Qc. - unfold Qcinv, Q2Qc; rewrite Qred_correct; auto with qarith. + unfold Qcinv, Q2Qc, this; rewrite Qred_correct; auto with qarith. Qed. - Theorem spec_squarec x: [[square x]] = [[x]]^2. + Theorem spec_squarec x: [[square x]] = [[x]]^2. Proof. - intros x; unfold to_Qc. + unfold to_Qc. apply trans_equal with (!! ([x]^2)). unfold Q2Qc. apply Qc_decomp; intros _ _; unfold this. @@ -1322,7 +1267,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_power_posc x p: [[power_pos x p]] = [[x]] ^ nat_of_P p. Proof. - intros x p; unfold to_Qc. + unfold to_Qc. apply trans_equal with (!! ([x]^Zpos p)). unfold Q2Qc. apply Qc_decomp; intros _ _; unfold this. diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v index be9b2d4e..10d0189a 100644 --- a/theories/Numbers/Rational/SpecViaQ/QSig.v +++ b/theories/Numbers/Rational/SpecViaQ/QSig.v @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: QSig.v 11207 2008-07-04 16:50:32Z letouzey $ i*) +(*i $Id$ i*) -Require Import QArith Qpower. +Require Import QArith Qpower Qminmax Orders RelationPairs GenericMinMax. Open Scope Q_scope. @@ -23,75 +23,203 @@ Module Type QType. Parameter t : Type. Parameter to_Q : t -> Q. - Notation "[ x ]" := (to_Q x). + Local Notation "[ x ]" := (to_Q x). Definition eq x y := [x] == [y]. + Definition lt x y := [x] < [y]. + Definition le x y := [x] <= [y]. Parameter of_Q : Q -> t. Parameter spec_of_Q: forall x, to_Q (of_Q x) == x. + Parameter red : t -> t. + Parameter compare : t -> t -> comparison. + Parameter eq_bool : t -> t -> bool. + Parameter max : t -> t -> t. + Parameter min : t -> t -> t. Parameter zero : t. Parameter one : t. Parameter minus_one : t. + Parameter add : t -> t -> t. + Parameter sub : t -> t -> t. + Parameter opp : t -> t. + Parameter mul : t -> t -> t. + Parameter square : t -> t. + Parameter inv : t -> t. + Parameter div : t -> t -> t. + Parameter power : t -> Z -> t. + Parameter spec_red : forall x, [red x] == [x]. + Parameter strong_spec_red : forall x, [red x] = Qred [x]. + Parameter spec_compare : forall x y, compare x y = ([x] ?= [y]). + Parameter spec_eq_bool : forall x y, eq_bool x y = Qeq_bool [x] [y]. + Parameter spec_max : forall x y, [max x y] == Qmax [x] [y]. + Parameter spec_min : forall x y, [min x y] == Qmin [x] [y]. Parameter spec_0: [zero] == 0. Parameter spec_1: [one] == 1. Parameter spec_m1: [minus_one] == -(1). + Parameter spec_add: forall x y, [add x y] == [x] + [y]. + Parameter spec_sub: forall x y, [sub x y] == [x] - [y]. + Parameter spec_opp: forall x, [opp x] == - [x]. + Parameter spec_mul: forall x y, [mul x y] == [x] * [y]. + Parameter spec_square: forall x, [square x] == [x] ^ 2. + Parameter spec_inv : forall x, [inv x] == / [x]. + Parameter spec_div: forall x y, [div x y] == [x] / [y]. + Parameter spec_power: forall x z, [power x z] == [x] ^ z. - Parameter compare : t -> t -> comparison. +End QType. - Parameter spec_compare : forall x y, compare x y = ([x] ?= [y]). +(** NB: several of the above functions come with [..._norm] variants + that expect reduced arguments and return reduced results. *) - Definition lt n m := compare n m = Lt. - Definition le n m := compare n m <> Gt. - Definition min n m := match compare n m with Gt => m | _ => n end. - Definition max n m := match compare n m with Lt => m | _ => n end. +(** TODO : also speak of specifications via Qcanon ... *) - Parameter eq_bool : t -> t -> bool. - - Parameter spec_eq_bool : forall x y, - if eq_bool x y then [x]==[y] else ~([x]==[y]). +Module Type QType_Notation (Import Q : QType). + Notation "[ x ]" := (to_Q x). + Infix "==" := eq (at level 70). + Notation "x != y" := (~x==y) (at level 70). + Infix "<=" := le. + Infix "<" := lt. + Notation "0" := zero. + Notation "1" := one. + Infix "+" := add. + Infix "-" := sub. + Infix "*" := mul. + Notation "- x" := (opp x). + Infix "/" := div. + Notation "/ x" := (inv x). + Infix "^" := power. +End QType_Notation. - Parameter red : t -> t. - - Parameter spec_red : forall x, [red x] == [x]. - Parameter strong_spec_red : forall x, [red x] = Qred [x]. +Module Type QType' := QType <+ QType_Notation. - Parameter add : t -> t -> t. - Parameter spec_add: forall x y, [add x y] == [x] + [y]. +Module QProperties (Import Q : QType'). - Parameter sub : t -> t -> t. +(** Conversion to Q *) - Parameter spec_sub: forall x y, [sub x y] == [x] - [y]. +Hint Rewrite + spec_red spec_compare spec_eq_bool spec_min spec_max + spec_add spec_sub spec_opp spec_mul spec_square spec_inv spec_div + spec_power : qsimpl. +Ltac qify := unfold eq, lt, le in *; autorewrite with qsimpl; + try rewrite spec_0 in *; try rewrite spec_1 in *; try rewrite spec_m1 in *. - Parameter opp : t -> t. +(** NB: do not add [spec_0] in the autorewrite database. Otherwise, + after instanciation in BigQ, this lemma become convertible to 0=0, + and autorewrite loops. Idem for [spec_1] and [spec_m1] *) - Parameter spec_opp: forall x, [opp x] == - [x]. +(** Morphisms *) - Parameter mul : t -> t -> t. +Ltac solve_wd1 := intros x x' Hx; qify; now rewrite Hx. +Ltac solve_wd2 := intros x x' Hx y y' Hy; qify; now rewrite Hx, Hy. - Parameter spec_mul: forall x y, [mul x y] == [x] * [y]. +Local Obligation Tactic := solve_wd2 || solve_wd1. - Parameter square : t -> t. +Instance : Measure to_Q. +Instance eq_equiv : Equivalence eq. - Parameter spec_square: forall x, [square x] == [x] ^ 2. +Program Instance lt_wd : Proper (eq==>eq==>iff) lt. +Program Instance le_wd : Proper (eq==>eq==>iff) le. +Program Instance red_wd : Proper (eq==>eq) red. +Program Instance compare_wd : Proper (eq==>eq==>Logic.eq) compare. +Program Instance eq_bool_wd : Proper (eq==>eq==>Logic.eq) eq_bool. +Program Instance min_wd : Proper (eq==>eq==>eq) min. +Program Instance max_wd : Proper (eq==>eq==>eq) max. +Program Instance add_wd : Proper (eq==>eq==>eq) add. +Program Instance sub_wd : Proper (eq==>eq==>eq) sub. +Program Instance opp_wd : Proper (eq==>eq) opp. +Program Instance mul_wd : Proper (eq==>eq==>eq) mul. +Program Instance square_wd : Proper (eq==>eq) square. +Program Instance inv_wd : Proper (eq==>eq) inv. +Program Instance div_wd : Proper (eq==>eq==>eq) div. +Program Instance power_wd : Proper (eq==>Logic.eq==>eq) power. - Parameter inv : t -> t. +(** Let's implement [HasCompare] *) - Parameter spec_inv : forall x, [inv x] == / [x]. +Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). +Proof. intros. qify. destruct (Qcompare_spec [x] [y]); auto. Qed. - Parameter div : t -> t -> t. +(** Let's implement [TotalOrder] *) - Parameter spec_div: forall x y, [div x y] == [x] / [y]. +Definition lt_compat := lt_wd. +Instance lt_strorder : StrictOrder lt. - Parameter power : t -> Z -> t. +Lemma le_lteq : forall x y, x<=y <-> x x == y. +Proof. intros. qify. apply Qeq_bool_iff. Qed. + +Lemma eqb_correct : forall x y, eq_bool x y = true -> x == y. +Proof. now apply eqb_eq. Qed. + +Lemma eqb_complete : forall x y, x == y -> eq_bool x y = true. +Proof. now apply eqb_eq. Qed. + +(** Let's implement [HasMinMax] *) + +Lemma max_l : forall x y, y<=x -> max x y == x. +Proof. intros x y. qify. apply Qminmax.Q.max_l. Qed. + +Lemma max_r : forall x y, x<=y -> max x y == y. +Proof. intros x y. qify. apply Qminmax.Q.max_r. Qed. + +Lemma min_l : forall x y, x<=y -> min x y == x. +Proof. intros x y. qify. apply Qminmax.Q.min_l. Qed. + +Lemma min_r : forall x y, y<=x -> min x y == y. +Proof. intros x y. qify. apply Qminmax.Q.min_r. Qed. + +(** Q is a ring *) + +Lemma add_0_l : forall x, 0+x == x. +Proof. intros. qify. apply Qplus_0_l. Qed. + +Lemma add_comm : forall x y, x+y == y+x. +Proof. intros. qify. apply Qplus_comm. Qed. + +Lemma add_assoc : forall x y z, x+(y+z) == x+y+z. +Proof. intros. qify. apply Qplus_assoc. Qed. + +Lemma mul_1_l : forall x, 1*x == x. +Proof. intros. qify. apply Qmult_1_l. Qed. + +Lemma mul_comm : forall x y, x*y == y*x. +Proof. intros. qify. apply Qmult_comm. Qed. + +Lemma mul_assoc : forall x y z, x*(y*z) == x*y*z. +Proof. intros. qify. apply Qmult_assoc. Qed. + +Lemma mul_add_distr_r : forall x y z, (x+y)*z == x*z + y*z. +Proof. intros. qify. apply Qmult_plus_distr_l. Qed. + +Lemma sub_add_opp : forall x y, x-y == x+(-y). +Proof. intros. qify. now unfold Qminus. Qed. + +Lemma add_opp_diag_r : forall x, x+(-x) == 0. +Proof. intros. qify. apply Qplus_opp_r. Qed. + +(** Q is a field *) + +Lemma neq_1_0 : 1!=0. +Proof. intros. qify. apply Q_apart_0_1. Qed. + +Lemma div_mul_inv : forall x y, x/y == x*(/y). +Proof. intros. qify. now unfold Qdiv. Qed. + +Lemma mul_inv_diag_l : forall x, x!=0 -> /x * x == 1. +Proof. intros x. qify. rewrite Qmult_comm. apply Qmult_inv_r. Qed. + +End QProperties. + +Module QTypeExt (Q : QType) + <: QType <: TotalOrder <: HasCompare Q <: HasMinMax Q <: HasEqBool Q + := Q <+ QProperties. \ No newline at end of file diff --git a/theories/Numbers/vo.itarget b/theories/Numbers/vo.itarget new file mode 100644 index 00000000..175a15e9 --- /dev/null +++ b/theories/Numbers/vo.itarget @@ -0,0 +1,70 @@ +BigNumPrelude.vo +Cyclic/Abstract/CyclicAxioms.vo +Cyclic/Abstract/NZCyclic.vo +Cyclic/DoubleCyclic/DoubleAdd.vo +Cyclic/DoubleCyclic/DoubleBase.vo +Cyclic/DoubleCyclic/DoubleCyclic.vo +Cyclic/DoubleCyclic/DoubleDivn1.vo +Cyclic/DoubleCyclic/DoubleDiv.vo +Cyclic/DoubleCyclic/DoubleLift.vo +Cyclic/DoubleCyclic/DoubleMul.vo +Cyclic/DoubleCyclic/DoubleSqrt.vo +Cyclic/DoubleCyclic/DoubleSub.vo +Cyclic/DoubleCyclic/DoubleType.vo +Cyclic/Int31/Int31.vo +Cyclic/Int31/Cyclic31.vo +Cyclic/Int31/Ring31.vo +Cyclic/ZModulo/ZModulo.vo +Integer/Abstract/ZAddOrder.vo +Integer/Abstract/ZAdd.vo +Integer/Abstract/ZAxioms.vo +Integer/Abstract/ZBase.vo +Integer/Abstract/ZLt.vo +Integer/Abstract/ZMulOrder.vo +Integer/Abstract/ZMul.vo +Integer/Abstract/ZSgnAbs.vo +Integer/Abstract/ZProperties.vo +Integer/Abstract/ZDivFloor.vo +Integer/Abstract/ZDivTrunc.vo +Integer/Abstract/ZDivEucl.vo +Integer/BigZ/BigZ.vo +Integer/BigZ/ZMake.vo +Integer/Binary/ZBinary.vo +Integer/NatPairs/ZNatPairs.vo +Integer/SpecViaZ/ZSig.vo +Integer/SpecViaZ/ZSigZAxioms.vo +NaryFunctions.vo +NatInt/NZAddOrder.vo +NatInt/NZAdd.vo +NatInt/NZAxioms.vo +NatInt/NZBase.vo +NatInt/NZMulOrder.vo +NatInt/NZMul.vo +NatInt/NZOrder.vo +NatInt/NZProperties.vo +NatInt/NZDomain.vo +NatInt/NZDiv.vo +Natural/Abstract/NAddOrder.vo +Natural/Abstract/NAdd.vo +Natural/Abstract/NAxioms.vo +Natural/Abstract/NBase.vo +Natural/Abstract/NDefOps.vo +Natural/Abstract/NIso.vo +Natural/Abstract/NMulOrder.vo +Natural/Abstract/NOrder.vo +Natural/Abstract/NStrongRec.vo +Natural/Abstract/NSub.vo +Natural/Abstract/NProperties.vo +Natural/Abstract/NDiv.vo +Natural/BigN/BigN.vo +Natural/BigN/Nbasic.vo +Natural/BigN/NMake_gen.vo +Natural/BigN/NMake.vo +Natural/Binary/NBinary.vo +Natural/Peano/NPeano.vo +Natural/SpecViaZ/NSigNAxioms.vo +Natural/SpecViaZ/NSig.vo +NumPrelude.vo +Rational/BigQ/BigQ.vo +Rational/BigQ/QMake.vo +Rational/SpecViaQ/QSig.vo diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index 29494069..0a4b15d2 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* C) (f : A -> B) := +Definition compose {A B C} (g : B -> C) (f : A -> B) := fun x : A => g (f x). Hint Unfold compose. -Notation " g ∘ f " := (compose g f) +Notation " g ∘ f " := (compose g f) (at level 40, left associativity) : program_scope. Open Local Scope program_scope. diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v index ae9749de..31661b9d 100644 --- a/theories/Program/Combinators.v +++ b/theories/Program/Combinators.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* B) (g : B -> C) (h : C -> D), +Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D), h ∘ g ∘ f = h ∘ (g ∘ f). Proof. intros. diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index 9681d543..79c9bec5 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-name: "~/research/coq/trunk/bin/coqtop.byte"; coq-prog-args: ("-emacs-U"); compile-command: "make -C ../.. TIME='time'" -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* is_ground T + end. + +(** Try to find a contradiction. *) + +Hint Extern 10 => is_ground_goal ; progress exfalso : exfalso. + +(** We will use the [block] definition to separate the goal from the + equalities generated by the tactic. *) + +Definition block {A : Type} (a : A) := a. + +Ltac block_goal := match goal with [ |- ?T ] => change (block T) end. +Ltac unblock_goal := unfold block in *. + (** Notation for heterogenous equality. *) -Notation " [ x : X ] = [ y : Y ] " := (@JMeq X x Y y) (at level 0, X at next level, Y at next level). +Notation " x ~= y " := (@JMeq _ x _ y) (at level 70, no associativity). -(** Notation for the single element of [x = x] *) +(** Notation for the single element of [x = x] and [x ~= x]. *) -Notation "'refl'" := (@refl_equal _ _). +Implicit Arguments eq_refl [[A] [x]]. +Implicit Arguments JMeq_refl [[A] [x]]. (** Do something on an heterogeneous equality appearing in the context. *) -Ltac on_JMeq tac := +Ltac on_JMeq tac := match goal with | [ H : @JMeq ?x ?X ?y ?Y |- _ ] => tac H end. @@ -44,17 +61,17 @@ Ltac simpl_JMeq := repeat simpl_one_JMeq. Ltac simpl_one_dep_JMeq := on_JMeq - ltac:(fun H => let H' := fresh "H" in + ltac:(fun H => let H' := fresh "H" in assert (H' := JMeq_eq H)). Require Import Eqdep. -(** Simplify dependent equality using sigmas to equality of the second projections if possible. +(** Simplify dependent equality using sigmas to equality of the second projections if possible. Uses UIP. *) Ltac simpl_existT := match goal with - [ H : existT _ ?x _ = existT _ ?x _ |- _ ] => + [ H : existT _ ?x _ = existT _ ?x _ |- _ ] => let Hi := fresh H in assert(Hi:=inj_pairT2 _ _ _ _ _ H) ; clear H end. @@ -64,20 +81,20 @@ Ltac simpl_existTs := repeat simpl_existT. Ltac elim_eq_rect := match goal with - | [ |- ?t ] => + | [ |- ?t ] => match t with - | context [ @eq_rect _ _ _ _ _ ?p ] => - let P := fresh "P" in - set (P := p); simpl in P ; + | context [ @eq_rect _ _ _ _ _ ?p ] => + let P := fresh "P" in + set (P := p); simpl in P ; ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) - | context [ @eq_rect _ _ _ _ _ ?p _ ] => - let P := fresh "P" in - set (P := p); simpl in P ; + | context [ @eq_rect _ _ _ _ _ ?p _ ] => + let P := fresh "P" in + set (P := p); simpl in P ; ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) end end. -(** Rewrite using uniqueness of indentity proofs [H = refl_equal X]. *) +(** Rewrite using uniqueness of indentity proofs [H = eq_refl]. *) Ltac simpl_uip := match goal with @@ -90,18 +107,18 @@ Ltac simpl_eq := simpl ; unfold eq_rec_r, eq_rec ; repeat (elim_eq_rect ; simpl) (** Try to abstract a proof of equality, if no proof of the same equality is present in the context. *) -Ltac abstract_eq_hyp H' p := +Ltac abstract_eq_hyp H' p := let ty := type of p in let tyred := eval simpl in ty in - match tyred with - ?X = ?Y => - match goal with + match tyred with + ?X = ?Y => + match goal with | [ H : X = Y |- _ ] => fail 1 | _ => set (H':=p) ; try (change p with H') ; clearbody H' ; simpl in H' end end. -(** Apply the tactic tac to proofs of equality appearing as coercion arguments. +(** Apply the tactic tac to proofs of equality appearing as coercion arguments. Just redefine this tactic (using [Ltac on_coerce_proof tac ::=]) to handle custom coercion operators. *) @@ -109,7 +126,7 @@ Ltac on_coerce_proof tac T := match T with | context [ eq_rect _ _ _ _ ?p ] => tac p end. - + Ltac on_coerce_proof_gl tac := match goal with [ |- ?T ] => on_coerce_proof tac T @@ -120,17 +137,17 @@ Ltac on_coerce_proof_gl tac := Ltac abstract_eq_proof := on_coerce_proof_gl ltac:(fun p => let H := fresh "eqH" in abstract_eq_hyp H p). Ltac abstract_eq_proofs := repeat abstract_eq_proof. - -(** Factorize proofs, by using proof irrelevance so that two proofs of the same equality + +(** Factorize proofs, by using proof irrelevance so that two proofs of the same equality in the goal become convertible. *) Ltac pi_eq_proof_hyp p := let ty := type of p in let tyred := eval simpl in ty in match tyred with - ?X = ?Y => - match goal with - | [ H : X = Y |- _ ] => + ?X = ?Y => + match goal with + | [ H : X = Y |- _ ] => match p with | H => fail 2 | _ => rewrite (proof_irrelevance (X = Y) p H) @@ -152,8 +169,21 @@ Ltac clear_eq_proofs := Hint Rewrite <- eq_rect_eq : refl_id. -(** The refl_id database should be populated with lemmas of the form - [coerce_* t (refl_equal _) = t]. *) +(** The [refl_id] database should be populated with lemmas of the form + [coerce_* t eq_refl = t]. *) + +Lemma JMeq_eq_refl {A} (x : A) : JMeq_eq (@JMeq_refl _ x) = eq_refl. +Proof. intros. apply proof_irrelevance. Qed. + +Lemma UIP_refl_refl : Π A (x : A), + Eqdep.EqdepTheory.UIP_refl A x eq_refl = eq_refl. +Proof. intros. apply UIP_refl. Qed. + +Lemma inj_pairT2_refl : Π A (x : A) (P : A -> Type) (p : P x), + Eqdep.EqdepTheory.inj_pairT2 A P x p p eq_refl = eq_refl. +Proof. intros. apply UIP_refl. Qed. + +Hint Rewrite @JMeq_eq_refl @UIP_refl_refl @inj_pairT2_refl : refl_id. Ltac rewrite_refl_id := autorewrite with refl_id. @@ -162,82 +192,49 @@ Ltac rewrite_refl_id := autorewrite with refl_id. Ltac clear_eq_ctx := rewrite_refl_id ; clear_eq_proofs. -(** Reapeated elimination of [eq_rect] applications. +(** Reapeated elimination of [eq_rect] applications. Abstracting equalities makes it run much faster than an naive implementation. *) -Ltac simpl_eqs := +Ltac simpl_eqs := repeat (elim_eq_rect ; simpl ; clear_eq_ctx). (** Clear unused reflexivity proofs. *) -Ltac clear_refl_eq := +Ltac clear_refl_eq := match goal with [ H : ?X = ?X |- _ ] => clear H end. Ltac clear_refl_eqs := repeat clear_refl_eq. (** Clear unused equality proofs. *) -Ltac clear_eq := +Ltac clear_eq := match goal with [ H : _ = _ |- _ ] => clear H end. Ltac clear_eqs := repeat clear_eq. (** Combine all the tactics to simplify goals containing coercions. *) -Ltac simplify_eqs := - simpl ; simpl_eqs ; clear_eq_ctx ; clear_refl_eqs ; +Ltac simplify_eqs := + simpl ; simpl_eqs ; clear_eq_ctx ; clear_refl_eqs ; try subst ; simpl ; repeat simpl_uip ; rewrite_refl_id. (** A tactic that tries to remove trivial equality guards in induction hypotheses coming from [dependent induction]/[generalize_eqs] invocations. *) -Ltac simpl_IH_eq H := - match type of H with - | @JMeq _ ?x _ _ -> _ => - refine_hyp (H (JMeq_refl x)) - | _ -> @JMeq _ ?x _ _ -> _ => - refine_hyp (H _ (JMeq_refl x)) - | _ -> _ -> @JMeq _ ?x _ _ -> _ => - refine_hyp (H _ _ (JMeq_refl x)) - | _ -> _ -> _ -> @JMeq _ ?x _ _ -> _ => - refine_hyp (H _ _ _ (JMeq_refl x)) - | _ -> _ -> _ -> _ -> @JMeq _ ?x _ _ -> _ => - refine_hyp (H _ _ _ _ (JMeq_refl x)) - | _ -> _ -> _ -> _ -> _ -> @JMeq _ ?x _ _ -> _ => - refine_hyp (H _ _ _ _ _ (JMeq_refl x)) - | ?x = _ -> _ => - refine_hyp (H (refl_equal x)) - | _ -> ?x = _ -> _ => - refine_hyp (H _ (refl_equal x)) - | _ -> _ -> ?x = _ -> _ => - refine_hyp (H _ _ (refl_equal x)) - | _ -> _ -> _ -> ?x = _ -> _ => - refine_hyp (H _ _ _ (refl_equal x)) - | _ -> _ -> _ -> _ -> ?x = _ -> _ => - refine_hyp (H _ _ _ _ (refl_equal x)) - | _ -> _ -> _ -> _ -> _ -> ?x = _ -> _ => - refine_hyp (H _ _ _ _ _ (refl_equal x)) - end. - -Ltac simpl_IH_eqs H := repeat simpl_IH_eq H. - -Ltac do_simpl_IHs_eqs := +Ltac simplify_IH_hyps := repeat match goal with - | [ H : context [ @JMeq _ _ _ _ -> _ ] |- _ ] => progress (simpl_IH_eqs H) - | [ H : context [ _ = _ -> _ ] |- _ ] => progress (simpl_IH_eqs H) + | [ hyp : _ |- _ ] => specialize_eqs hyp end. -Ltac simpl_IHs_eqs := repeat do_simpl_IHs_eqs. - (** We split substitution tactics in the two directions depending on which names we want to keep corresponding to the generalization performed by the [generalize_eqs] tactic. *) Ltac subst_left_no_fail := - repeat (match goal with + repeat (match goal with [ H : ?X = ?Y |- _ ] => subst X end). Ltac subst_right_no_fail := - repeat (match goal with + repeat (match goal with [ H : ?X = ?Y |- _ ] => subst Y end). @@ -251,32 +248,15 @@ Ltac autoinjections_left := repeat autoinjection ltac:inject_left. Ltac autoinjections_right := repeat autoinjection ltac:inject_right. Ltac simpl_depind := subst_no_fail ; autoinjections ; try discriminates ; - simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. + simpl_JMeq ; simpl_existTs ; simplify_IH_hyps. Ltac simpl_depind_l := subst_left_no_fail ; autoinjections_left ; try discriminates ; - simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. + simpl_JMeq ; simpl_existTs ; simplify_IH_hyps. Ltac simpl_depind_r := subst_right_no_fail ; autoinjections_right ; try discriminates ; - simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. - -(** Support for the [Equations] command. - These tactics implement the necessary machinery to solve goals produced by the - [Equations] command relative to dependent pattern-matching. - It is completely inspired from the "Eliminating Dependent Pattern-Matching" paper by - Goguen, McBride and McKinna. *) - - -(** The NoConfusionPackage class provides a method for making progress on proving a property - [P] implied by an equality on an inductive type [I]. The type of [noConfusion] for a given - [P] should be of the form [ Π Δ, (x y : I Δ) (x = y) -> NoConfusion P x y ], where - [NoConfusion P x y] for constructor-headed [x] and [y] will give a formula ending in [P]. - This gives a general method for simplifying by discrimination or injectivity of constructors. - - Some actual instances are defined later in the file using the more primitive [discriminate] and - [injection] tactics on which we can always fall back. - *) - -Class NoConfusionPackage (I : Type) := { NoConfusion : Π P : Prop, Type ; noConfusion : Π P, NoConfusion P }. + simpl_JMeq ; simpl_existTs ; simplify_IH_hyps. + +Ltac blocked t := block_goal ; t ; unblock_goal. (** The [DependentEliminationPackage] provides the default dependent elimination principle to be used by the [equations] resolver. It is especially useful to register the dependent elimination @@ -287,30 +267,18 @@ Class DependentEliminationPackage (A : Type) := (** A higher-order tactic to apply a registered eliminator. *) -Ltac elim_tac tac p := +Ltac elim_tac tac p := let ty := type of p in let eliminator := eval simpl in (elim (A:=ty)) in tac p eliminator. -(** Specialization to do case analysis or induction. - Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register +(** Specialization to do case analysis or induction. + Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register generated induction principles. *) Ltac elim_case p := elim_tac ltac:(fun p el => destruct p using el) p. Ltac elim_ind p := elim_tac ltac:(fun p el => induction p using el) p. -(** The [BelowPackage] class provides the definition of a [Below] predicate for some datatype, - allowing to talk about course-of-value recursion on it. *) - -Class BelowPackage (A : Type) := { - Below : A -> Type ; - below : Π (a : A), Below a }. - -(** The [Recursor] class defines a recursor on a type, based on some definition of [Below]. *) - -Class Recursor (A : Type) (BP : BelowPackage A) := - { rec_type : A -> Type ; rec : Π (a : A), rec_type a }. - (** Lemmas used by the simplifier, mainly rephrasings of [eq_rect], [eq_ind]. *) Lemma solution_left : Π A (B : A -> Type) (t : A), B t -> (Π x, x = t -> B x). @@ -333,57 +301,43 @@ Lemma simplification_existT1 : Π A (P : A -> Type) B (p q : A) (x : P p) (y : P (p = q -> existT P p x = existT P q y -> B) -> (existT P p x = existT P q y -> B). Proof. intros. injection H. intros ; auto. Defined. -Lemma simplification_K : Π A (x : A) (B : x = x -> Type), B (refl_equal x) -> (Π p : x = x, B p). +Lemma simplification_K : Π A (x : A) (B : x = x -> Type), B eq_refl -> (Π p : x = x, B p). Proof. intros. rewrite (UIP_refl A). assumption. Defined. -(** This hint database and the following tactic can be used with [autosimpl] to +(** This hint database and the following tactic can be used with [autounfold] to unfold everything to [eq_rect]s. *) Hint Unfold solution_left solution_right deletion simplification_heq - simplification_existT1 simplification_existT2 - eq_rect_r eq_rec eq_ind : equations. - -(** Simply unfold as much as possible. *) - -Ltac unfold_equations := repeat progress autosimpl with equations. - -(** The tactic [simplify_equations] is to be used when a program generated using [Equations] - is in the goal. It simplifies it as much as possible, possibly using [K] if needed. *) - -Ltac simplify_equations := repeat (unfold_equations ; simplify_eqs). - -(** We will use the [block_induction] definition to separate the goal from the - equalities generated by the tactic. *) - -Definition block_dep_elim {A : Type} (a : A) := a. + simplification_existT1 simplification_existT2 simplification_K + eq_rect_r eq_rec eq_ind : dep_elim. -(** Using these we can make a simplifier that will perform the unification +(** Using these we can make a simplifier that will perform the unification steps needed to put the goal in normalised form (provided there are only constructor forms). Compare with the lemma 16 of the paper. - We don't have a [noCycle] procedure yet. *) + We don't have a [noCycle] procedure yet. *) Ltac simplify_one_dep_elim_term c := match c with | @JMeq _ _ _ _ -> _ => refine (simplification_heq _ _ _ _ _) | ?t = ?t -> _ => intros _ || refine (simplification_K _ t _ _) - | eq (existT _ _ _) (existT _ _ _) -> _ => + | eq (existT _ _ _) (existT _ _ _) -> _ => refine (simplification_existT2 _ _ _ _ _ _ _) || refine (simplification_existT1 _ _ _ _ _ _ _ _) | ?x = ?y -> _ => (* variables case *) (let hyp := fresh in intros hyp ; - move hyp before x ; - generalize dependent x ; refine (solution_left _ _ _ _) ; intros until 0) || + move hyp before x ; revert_until hyp ; generalize dependent x ; + refine (solution_left _ _ _ _)(* ; intros until 0 *)) || (let hyp := fresh in intros hyp ; - move hyp before y ; - generalize dependent y ; refine (solution_right _ _ _ _) ; intros until 0) - | @eq ?A ?t ?u -> ?P => apply (noConfusion (I:=A) P) + move hyp before y ; revert_until hyp ; generalize dependent y ; + refine (solution_right _ _ _ _)(* ; intros until 0 *)) | ?f ?x = ?g ?y -> _ => let H := fresh in progress (intros H ; injection H ; clear H) | ?t = ?u -> _ => let hyp := fresh in - intros hyp ; elimtype False ; discriminate + intros hyp ; exfalso ; discriminate | ?x = ?y -> _ => let hyp := fresh in intros hyp ; (try (clear hyp ; (* If non dependent, don't clear it! *) fail 1)) ; case hyp ; clear hyp - | block_dep_elim ?T => fail 1 (* Do not put any part of the rhs in the hyps *) + | block ?T => fail 1 (* Do not put any part of the rhs in the hyps *) + | forall x, _ => intro x || (let H := fresh x in rename x into H ; intro x) (* Try to keep original names *) | _ => intro end. @@ -397,176 +351,103 @@ Ltac simplify_one_dep_elim := Ltac simplify_dep_elim := repeat simplify_one_dep_elim. -(** To dependent elimination on some hyp. *) - -Ltac depelim id := - generalize_eqs id ; destruct id ; simplify_dep_elim. - (** Do dependent elimination of the last hypothesis, but not simplifying yet (used internally). *) Ltac destruct_last := on_last_hyp ltac:(fun id => simpl in id ; generalize_eqs id ; destruct id). -(** The rest is support tactics for the [Equations] command. *) - -(** Notation for inaccessible patterns. *) - -Definition inaccessible_pattern {A : Type} (t : A) := t. - -Notation "?( t )" := (inaccessible_pattern t). - -(** To handle sections, we need to separate the context in two parts: - variables introduced by the section and the rest. We introduce a dummy variable - between them to indicate that. *) - -CoInductive end_of_section := the_end_of_the_section. - -Ltac set_eos := let eos := fresh "eos" in - assert (eos:=the_end_of_the_section). +Ltac introduce p := first [ + match p with _ => (* Already there, generalize dependent hyps *) + generalize dependent p ; intros p + end + | intros until p | intros until 1 | intros ]. -(** We have a specialized [reverse_local] tactic to reverse the goal until the begining of the - section variables *) - -Ltac reverse_local := - match goal with - | [ H : ?T |- _ ] => - match T with - | end_of_section => idtac | _ => revert H ; reverse_local end - | _ => idtac - end. - -(** Do as much as possible to apply a method, trying to get the arguments right. - !!Unsafe!! We use [auto] for the [_nocomp] variant of [Equations], in which case some - non-dependent arguments of the method can remain after [apply]. *) - -Ltac simpl_intros m := ((apply m || refine m) ; auto) || (intro ; simpl_intros m). - -(** Hopefully the first branch suffices. *) - -Ltac try_intros m := - solve [ intros ; unfold block_dep_elim ; refine m || apply m ] || - solve [ unfold block_dep_elim ; simpl_intros m ]. - -(** To solve a goal by inversion on a particular target. *) +Ltac do_case p := introduce p ; (destruct p || elim_case p || (case p ; clear p)). +Ltac do_ind p := introduce p ; (induction p || elim_ind p). -Ltac solve_empty target := - do_nat target intro ; elimtype False ; destruct_last ; simplify_dep_elim. +(** The following tactics allow to do induction on an already instantiated inductive predicate + by first generalizing it and adding the proper equalities to the context, in a maner similar to + the BasicElim tactic of "Elimination with a motive" by Conor McBride. *) -Ltac simplify_method tac := repeat (tac || simplify_one_dep_elim) ; reverse_local. +(** The [do_depelim] higher-order tactic takes an elimination tactic as argument and an hypothesis + and starts a dependent elimination using this tactic. *) -(** Solving a method call: we can solve it by splitting on an empty family member - or we must refine the goal until the body can be applied. *) - -Ltac solve_method rec := +Ltac is_introduced H := match goal with - | [ H := ?body : nat |- _ ] => subst H ; clear ; abstract (simplify_method idtac ; solve_empty body) - | [ H := [ ?body ] : ?T |- _ ] => clear H ; simplify_method ltac:(exact body) ; rec ; try_intros (body:T) + | [ H' : _ |- _ ] => match H' with H => idtac end end. -(** Impossible cases, by splitting on a given target. *) - -Ltac solve_split := - match goal with - | [ |- let split := ?x : nat in _ ] => clear ; abstract (intros _ ; solve_empty x) - end. +Tactic Notation "intro_block" hyp(H) := + (is_introduced H ; block_goal ; revert_until H) || + (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal). -(** If defining recursive functions, the prototypes come first. *) +Tactic Notation "intro_block_id" ident(H) := + (is_introduced H ; block_goal ; revert_until H) || + (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal). -Ltac intro_prototypes := - match goal with - | [ |- Π x : _, _ ] => intro ; intro_prototypes - | _ => idtac - end. - -Ltac introduce p := - first [ match p with _ => idtac end (* Already there *) - | intros until p | intros ]. - -Ltac do_case p := introduce p ; (destruct p || elim_case p || (case p ; clear p)). -Ltac do_ind p := introduce p ; (induction p || elim_ind p). +Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_goal. -Ltac dep_elimify := match goal with [ |- ?T ] => change (block_dep_elim T) end. +Ltac do_intros H := + (try intros until H) ; (intro_block_id H || intro_block H). -Ltac un_dep_elimify := unfold block_dep_elim in *. +Ltac do_depelim_nosimpl tac H := do_intros H ; generalize_eqs H ; tac H. -Ltac case_last := dep_elimify ; - on_last_hyp ltac:(fun p => - let ty := type of p in - match ty with - | ?x = ?x => revert p ; refine (simplification_K _ x _ _) - | ?x = ?y => revert p - | _ => simpl in p ; generalize_eqs p ; do_case p - end). +Ltac do_depelim tac H := do_depelim_nosimpl tac H ; simpl_dep_elim. -Ltac nonrec_equations := - solve [solve_equations (case_last) (solve_method idtac)] || solve [ solve_split ] - || fail "Unnexpected equations goal". +Ltac do_depind tac H := + (try intros until H) ; intro_block H ; + generalize_eqs_vars H ; tac H ; simplify_dep_elim ; simplify_IH_hyps ; unblock_goal. -Ltac recursive_equations := - solve [solve_equations (case_last) (solve_method ltac:intro)] || solve [ solve_split ] - || fail "Unnexpected recursive equations goal". +(** To dependent elimination on some hyp. *) -(** The [equations] tactic is the toplevel tactic for solving goals generated - by [Equations]. *) +Ltac depelim id := do_depelim ltac:(fun hyp => do_case hyp) id. -Ltac equations := set_eos ; - match goal with - | [ |- Π x : _, _ ] => intro ; recursive_equations - | _ => nonrec_equations - end. +(** Used internally. *) -(** The following tactics allow to do induction on an already instantiated inductive predicate - by first generalizing it and adding the proper equalities to the context, in a maner similar to - the BasicElim tactic of "Elimination with a motive" by Conor McBride. *) +Ltac depelim_nosimpl id := do_depelim_nosimpl ltac:(fun hyp => do_case hyp) id. -(** The [do_depind] higher-order tactic takes an induction tactic as argument and an hypothesis - and starts a dependent induction using this tactic. *) +(** To dependent induction on some hyp. *) -Ltac do_depind tac H := - (try intros until H) ; dep_elimify ; generalize_eqs_vars H ; tac H ; simplify_dep_elim ; un_dep_elimify. +Ltac depind id := do_depind ltac:(fun hyp => do_ind hyp) id. (** A variant where generalized variables should be given by the user. *) -Ltac do_depind' tac H := - (try intros until H) ; dep_elimify ; generalize_eqs H ; tac H ; simplify_dep_elim ; un_dep_elimify. +Ltac do_depelim' tac H := + (try intros until H) ; block_goal ; generalize_eqs H ; tac H ; simplify_dep_elim ; + simplify_IH_hyps ; unblock_goal. (** Calls [destruct] on the generalized hypothesis, results should be similar to inversion. By default, we don't try to generalize the hyp by its variable indices. *) Tactic Notation "dependent" "destruction" ident(H) := - do_depind' ltac:(fun hyp => do_case hyp) H. + do_depelim' ltac:(fun hyp => do_case hyp) H. Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) := - do_depind' ltac:(fun hyp => destruct hyp using c) H. + do_depelim' ltac:(fun hyp => destruct hyp using c) H. -(** This tactic also generalizes the goal by the given variables before the induction. *) +(** This tactic also generalizes the goal by the given variables before the elimination. *) Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) := - do_depind' ltac:(fun hyp => revert l ; do_case hyp) H. + do_depelim' ltac:(fun hyp => revert l ; do_case hyp) H. Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := - do_depind' ltac:(fun hyp => revert l ; destruct hyp using c) H. + do_depelim' ltac:(fun hyp => revert l ; destruct hyp using c) H. (** Then we have wrappers for usual calls to induction. One can customize the induction tactic by - writting another wrapper calling do_depind. We suppose the hyp has to be generalized before + writting another wrapper calling do_depelim. We suppose the hyp has to be generalized before calling [induction]. *) -Tactic Notation "dependent" "induction" ident(H) := +Tactic Notation "dependent" "induction" ident(H) := do_depind ltac:(fun hyp => do_ind hyp) H. -Tactic Notation "dependent" "induction" ident(H) "using" constr(c) := +Tactic Notation "dependent" "induction" ident(H) "using" constr(c) := do_depind ltac:(fun hyp => induction hyp using c) H. (** This tactic also generalizes the goal by the given variables before the induction. *) Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) := - do_depind' ltac:(fun hyp => generalize l ; clear l ; do_ind hyp) H. + do_depelim' ltac:(fun hyp => generalize l ; clear l ; do_ind hyp) H. Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := - do_depind' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c) H. - -Ltac simplify_IH_hyps := repeat - match goal with - | [ hyp : _ |- _ ] => specialize_hypothesis hyp - end. \ No newline at end of file + do_depelim' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c) H. diff --git a/theories/Program/Program.v b/theories/Program/Program.v index 7d0c3948..cdfc7858 100644 --- a/theories/Program/Program.v +++ b/theories/Program/Program.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Program.v 11709 2008-12-20 11:42:15Z msozeau $ *) +(* $Id$ *) Require Export Coq.Program.Utils. Require Export Coq.Program.Wf. diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v index 3d551281..89f477d8 100644 --- a/theories/Program/Subset.v +++ b/theories/Program/Subset.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Subset.v 11709 2008-12-20 11:42:15Z msozeau $ *) +(* $Id$ *) (** Tactics related to subsets and proof irrelevance. *) @@ -14,7 +14,7 @@ Require Import Coq.Program.Equality. Open Local Scope program_scope. -(** The following tactics implement a poor-man's solution for proof-irrelevance: it tries to +(** The following tactics implement a poor-man's solution for proof-irrelevance: it tries to factorize every proof of the same proposition in a goal so that equality of such proofs becomes trivial. *) Ltac on_subset_proof_aux tac T := @@ -27,25 +27,25 @@ Ltac on_subset_proof tac := [ |- ?T ] => on_subset_proof_aux tac T end. -Ltac abstract_any_hyp H' p := +Ltac abstract_any_hyp H' p := match type of p with - ?X => - match goal with + ?X => + match goal with | [ H : X |- _ ] => fail 1 | _ => set (H':=p) ; try (change p with H') ; clearbody H' end end. -Ltac abstract_subset_proof := +Ltac abstract_subset_proof := on_subset_proof ltac:(fun p => let H := fresh "eqH" in abstract_any_hyp H p ; simpl in H). Ltac abstract_subset_proofs := repeat abstract_subset_proof. Ltac pi_subset_proof_hyp p := match type of p with - ?X => - match goal with - | [ H : X |- _ ] => + ?X => + match goal with + | [ H : X |- _ ] => match p with | H => fail 2 | _ => rewrite (proof_irrelevance X p H) @@ -78,16 +78,16 @@ Proof. pi. Qed. -(* Somewhat trivial definition, but not unfolded automatically hence we can match on [match_eq ?A ?B ?x ?f] +(* 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 := - fn (exist _ x (refl_equal x)). + fn (exist _ x eq_refl). -(* This is what we want to be able to do: replace the originaly matched object by a new, +(* 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) +Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : forall (y : A | y = x), B) (y : A | y = x), match_eq A B x fn = fn y. Proof. @@ -103,9 +103,9 @@ Qed. (** Now we make a tactic to be able to rewrite a term [t] which is applied to a [match_eq] using an arbitrary equality [t = u], and [u] is now the subject of the [match]. *) -Ltac rewrite_match_eq H := +Ltac rewrite_match_eq H := match goal with - [ |- ?T ] => + [ |- ?T ] => match T with context [ match_eq ?A ?B ?t ?f ] => rewrite (match_eq_rewrite A B t f (exist _ _ (sym_eq H))) diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v index 222b5c8d..2064977f 100644 --- a/theories/Program/Syntax.v +++ b/theories/Program/Syntax.v @@ -5,15 +5,15 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Syntax.v 11823 2009-01-21 15:32:37Z msozeau $ *) +(* $Id$ *) (** Custom notations and implicits for Coq prelude definitions. Author: Matthieu Sozeau - Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud - 91405 Orsay, France *) + Institution: LRI, CNRS UMR 8623 - University Paris Sud +*) -(** Notations for the unit type and value à la Haskell. *) +(** Haskell-style notations for the unit type and value. *) Notation " () " := Datatypes.unit : type_scope. Notation " () " := tt. @@ -31,6 +31,10 @@ Implicit Arguments inr [[A] [B]]. Implicit Arguments left [[A] [B]]. Implicit Arguments right [[A] [B]]. +Implicit Arguments pair [[A] [B]]. +Implicit Arguments fst [[A] [B]]. +Implicit Arguments snd [[A] [B]]. + Require Import Coq.Lists.List. Implicit Arguments nil [[A]]. @@ -42,6 +46,13 @@ Notation " [ ] " := nil : list_scope. Notation " [ x ] " := (cons x nil) : list_scope. Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope. +(** Implicit arguments for vectors. *) + +Require Import Bvector. + +Implicit Arguments Vnil [[A]]. +Implicit Arguments Vcons [[A] [n]]. + (** Treating n-ary exists *) Notation " 'exists' x y , p" := (ex (fun x => (ex (fun y => p)))) diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index 499629a6..e692876d 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -6,11 +6,32 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Tactics.v 11709 2008-12-20 11:42:15Z msozeau $ i*) +(*i $Id$ i*) (** This module implements various tactics used to simplify the goals produced by Program, which are also generally useful. *) +(** Debugging tactics to show the goal during evaluation. *) + +Ltac show_goal := match goal with [ |- ?T ] => idtac T end. + +Ltac show_hyp id := + match goal with + | [ H := ?b : ?T |- _ ] => + match H with + | id => idtac id ":=" b ":" T + end + | [ H : ?T |- _ ] => + match H with + | id => idtac id ":" T + end + end. + +Ltac show_hyps := + try match reverse goal with + | [ H : ?T |- _ ] => show_hyp H ; fail + end. + (** The [do] tactic but using a Coq-side nat. *) Ltac do_nat n tac := @@ -22,7 +43,7 @@ Ltac do_nat n tac := (** Do something on the last hypothesis, or fail *) Ltac on_last_hyp tac := - match goal with [ H : _ |- _ ] => tac H || fail 1 end. + match goal with [ H : _ |- _ ] => first [ tac H | fail 1 ] end. (** Destructs one pair, without care regarding naming. *) @@ -56,7 +77,7 @@ Ltac destruct_exists := repeat (destruct_one_ex). Ltac destruct_conjs := repeat (destruct_one_pair || destruct_one_ex). -(** Destruct an existential hypothesis [t] keeping its name for the first component +(** Destruct an existential hypothesis [t] keeping its name for the first component and using [Ht] for the second *) Tactic Notation "destruct" "exist" ident(t) ident(Ht) := destruct t as [t Ht]. @@ -75,7 +96,7 @@ Ltac discriminates := (** Revert the last hypothesis. *) -Ltac revert_last := +Ltac revert_last := match goal with [ H : _ |- _ ] => revert H end. @@ -84,11 +105,20 @@ Ltac revert_last := Ltac reverse := repeat revert_last. +(** Reverse everything up to hypothesis id (not included). *) + +Ltac revert_until id := + on_last_hyp ltac:(fun id' => + match id' with + | id => idtac + | _ => revert id' ; revert_until id + end). + (** Clear duplicated hypotheses *) Ltac clear_dup := - match goal with - | [ H : ?X |- _ ] => + match goal with + | [ H : ?X |- _ ] => match goal with | [ H' : ?Y |- _ ] => match H with @@ -100,10 +130,20 @@ Ltac clear_dup := Ltac clear_dups := repeat clear_dup. +(** Try to clear everything except some hyp *) + +Ltac clear_except hyp := + repeat match goal with [ H : _ |- _ ] => + match H with + | hyp => fail 1 + | _ => clear H + end + end. + (** A non-failing subst that substitutes as much as possible. *) Ltac subst_no_fail := - repeat (match goal with + repeat (match goal with [ H : ?X = ?Y |- _ ] => subst X || subst Y end). @@ -118,13 +158,13 @@ Ltac on_application f tac T := | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v) | context [f ?x ?y ?z ?w] => tac (f x y z w) | context [f ?x ?y ?z] => tac (f x y z) - | context [f ?x ?y] => tac (f x y) + | context [f ?x ?y] => tac (f x y) | context [f ?x] => tac (f x) end. (** A variant of [apply] using [refine], doing as much conversion as necessary. *) -Ltac rapply p := +Ltac rapply p := refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) || @@ -141,7 +181,7 @@ Ltac rapply p := refine (p _ _) || refine (p _) || refine p. - + (** Tactical [on_call f tac] applies [tac] on any application of [f] in the hypothesis or goal. *) Ltac on_call f tac := @@ -174,17 +214,29 @@ Tactic Notation "destruct_call" constr(f) := destruct_call f. (** Permit to name the results of destructing the call to [f]. *) -Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) := +Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) := destruct_call_as f l. (** Specify the hypothesis in which the call occurs as well. *) -Tactic Notation "destruct_call" constr(f) "in" hyp(id) := +Tactic Notation "destruct_call" constr(f) "in" hyp(id) := destruct_call_in f id. -Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) "in" hyp(id) := +Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) "in" hyp(id) := destruct_call_as_in f l id. +(** A marker for prototypes to destruct. *) + +Definition fix_proto {A : Type} (a : A) := a. + +Ltac destruct_rec_calls := + match goal with + | [ H : fix_proto _ |- _ ] => destruct_calls H ; clear H + end. + +Ltac destruct_all_rec_calls := + repeat destruct_rec_calls ; unfold fix_proto in *. + (** Try to inject any potential constructor equality hypothesis. *) Ltac autoinjection tac := @@ -204,23 +256,23 @@ Ltac destruct_nondep H := let H0 := fresh "H" in assert(H0 := H); destruct H0. Ltac bang := match goal with - | |- ?x => + | |- ?x => match x with - | context [False_rect _ ?p] => elim p + | appcontext [False_rect _ ?p] => elim p end end. - + (** A tactic to show contradiction by first asserting an automatically provable hypothesis. *) -Tactic Notation "contradiction" "by" constr(t) := +Tactic Notation "contradiction" "by" constr(t) := let H := fresh in assert t as H by auto with * ; contradiction. (** A tactic that adds [H:=p:typeof(p)] to the context if no hypothesis of the same type appears in the goal. Useful to do saturation using tactics. *) -Ltac add_hypothesis H' p := +Ltac add_hypothesis H' p := match type of p with - ?X => - match goal with + ?X => + match goal with | [ H : X |- _ ] => fail 1 | _ => set (H':=p) ; try (change p with H') ; clearbody H' end @@ -248,13 +300,19 @@ Ltac refine_hyp c := end. (** The default simplification tactic used by Program is defined by [program_simpl], sometimes [auto] - is not enough, better rebind using [Obligation Tactic := tac] in this case, + is not enough, better rebind using [Obligation Tactic := tac] in this case, possibly using [program_simplify] to use standard goal-cleaning tactics. *) Ltac program_simplify := - simpl ; intros ; destruct_conjs ; simpl proj1_sig in * ; subst* ; autoinjections ; try discriminates ; + simpl in |- *; intros ; destruct_all_rec_calls ; repeat (destruct_conjs; simpl proj1_sig in *); + subst*; autoinjections ; try discriminates ; try (solve [ red ; intros ; destruct_conjs ; autoinjections ; discriminates ]). -Ltac program_simpl := program_simplify ; auto. +Ltac program_solve_wf := + match goal with + |- well_founded _ => auto with * + end. + +Ltac program_simpl := program_simplify ; auto; try program_solve_wf. -Ltac obligation_tactic := program_simpl. +Obligation Tactic := program_simpl. diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v index b08093bf..fbf0b03c 100644 --- a/theories/Program/Utils.v +++ b/theories/Program/Utils.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Utils.v 11709 2008-12-20 11:42:15Z msozeau $ i*) +(*i $Id$ i*) (** Various syntaxic shortands that are useful with [Program]. *) diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index 2083e530..98b1c619 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Wf.v 12187 2009-06-13 19:36:59Z msozeau $ *) +(* $Id$ *) (** Reformulation of the Wf module using subsets where possible, providing the support for [Program]'s treatment of well-founded definitions. *) @@ -22,140 +22,57 @@ Section Well_founded. Variable A : Type. Variable R : A -> A -> Prop. Hypothesis Rwf : well_founded R. - - Section Acc. - - Variable P : A -> Type. - - Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x. - - Fixpoint Fix_F_sub (x : A) (r : Acc R x) {struct r} : P x := - F_sub x (fun y: { y : A | R y x} => Fix_F_sub (proj1_sig y) - (Acc_inv r (proj2_sig y))). - - Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x). - End Acc. - - Section FixPoint. - Variable P : A -> Type. - - Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x. - - Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) - - Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x). - - Hypothesis - F_ext : - forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)), - (forall (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 (`y) (Acc_inv r (proj2_sig y))) = Fix_F x r. - Proof. - destruct r using Acc_inv_dep; auto. - Qed. - - Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F x r = Fix_F x s. - Proof. - intro x; induction (Rwf x); intros. - rewrite (proof_irrelevance (Acc R x) r s) ; auto. - Qed. - - Lemma Fix_eq : forall x:A, Fix x = F_sub x (fun (y:A|R y x) => Fix (proj1_sig y)). - Proof. - intro x; unfold Fix in |- *. - rewrite <- (Fix_F_eq ). - apply F_ext; intros. - apply Fix_F_inv. - Qed. - - Lemma fix_sub_eq : - forall x : A, - Fix_sub P F_sub x = - let f_sub := F_sub in - f_sub x (fun (y : A | R y x) => Fix (`y)). - exact Fix_eq. - Qed. - - End FixPoint. -End Well_founded. + Variable P : A -> Type. -Extraction Inline Fix_F_sub Fix_sub. + Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x. -Require Import Wf_nat. -Require Import Lt. + Fixpoint Fix_F_sub (x : A) (r : Acc R x) : P x := + F_sub x (fun y: { y : A | R y x} => Fix_F_sub (proj1_sig y) + (Acc_inv r (proj2_sig y))). -Section Well_founded_measure. - Variable A : Type. - Variable m : A -> nat. - - Section Acc. - - Variable P : A -> Type. - - Variable F_sub : forall x:A, (forall y: { y : A | m y < m x }, P (proj1_sig y)) -> P x. - - Program Fixpoint Fix_measure_F_sub (x : A) (r : Acc lt (m x)) {struct r} : P x := - F_sub x (fun (y : A | m y < m x) => Fix_measure_F_sub y - (@Acc_inv _ _ _ r (m y) (proj2_sig y))). - - Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (m x)). - - End Acc. - - Section FixPoint. - Variable P : A -> Type. - - Program Variable F_sub : forall x:A, (forall (y : A | m y < m x), P y) -> P x. - - Notation Fix_F := (Fix_measure_F_sub P F_sub) (only parsing). (* alias *) - - Definition Fix_measure (x:A) := Fix_measure_F_sub P F_sub x (lt_wf (m x)). - - Hypothesis - F_ext : - forall (x:A) (f g:forall y : { y : A | m y < m x}, P (`y)), - (forall y : { y : A | m y < m x}, f y = g y) -> F_sub x f = F_sub x g. - - Program Lemma Fix_measure_F_eq : - forall (x:A) (r:Acc lt (m x)), - F_sub x (fun (y:A | m y < m x) => Fix_F y (Acc_inv r (proj2_sig y))) = Fix_F x r. - Proof. - intros x. - set (y := m x). - unfold Fix_measure_F_sub. - intros r ; case r ; auto. - Qed. - - Lemma Fix_measure_F_inv : forall (x:A) (r s:Acc lt (m x)), Fix_F x r = Fix_F x s. - Proof. - intros x r s. - rewrite (proof_irrelevance (Acc lt (m x)) r s) ; auto. - Qed. - - Lemma Fix_measure_eq : forall x:A, Fix_measure x = F_sub x (fun (y:{y:A| m y < m x}) => Fix_measure (proj1_sig y)). - Proof. - intro x; unfold Fix_measure in |- *. - rewrite <- (Fix_measure_F_eq ). - apply F_ext; intros. - apply Fix_measure_F_inv. - Qed. - - Lemma fix_measure_sub_eq : forall x : A, - Fix_measure_sub P F_sub x = - let f_sub := F_sub in - f_sub x (fun (y : A | m y < m x) => Fix_measure (`y)). - exact Fix_measure_eq. - Qed. - - End FixPoint. - -End Well_founded_measure. - -Extraction Inline Fix_measure_F_sub Fix_measure_sub. + Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x). + + (* Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) *) + (* Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x). *) + + Hypothesis + F_ext : + forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)), + (forall (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. + Proof. + destruct r using Acc_inv_dep; auto. + Qed. + + Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F_sub x r = Fix_F_sub x s. + Proof. + intro x; induction (Rwf x); intros. + 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)). + Proof. + intro x; unfold Fix_sub in |- *. + rewrite <- (Fix_F_eq ). + apply F_ext; intros. + apply Fix_F_inv. + Qed. + + Lemma fix_sub_eq : + forall x : A, + Fix_sub x = + let f_sub := F_sub in + f_sub x (fun (y : A | R y x) => Fix_sub (`y)). + exact Fix_eq. + Qed. + +End Well_founded. + +Extraction Inline Fix_F_sub Fix_sub. Set Implicit Arguments. @@ -189,38 +106,40 @@ Section Measure_well_founded. End Measure_well_founded. -Section Fix_measure_rects. +Hint Resolve measure_wf. + +Section Fix_rects. Variable A: Type. - Variable m: A -> nat. Variable P: A -> Type. - Variable f: forall (x : A), (forall y: { y: A | m y < m x }, P (proj1_sig y)) -> P x. - + Variable R : A -> A -> Prop. + Variable Rwf : well_founded R. + Variable f: forall (x : A), (forall y: { y: A | R y x }, P (proj1_sig y)) -> P x. + Lemma F_unfold x r: - Fix_measure_F_sub A m P f x r = - f (fun y => Fix_measure_F_sub A m P f (proj1_sig y) (Acc_inv r (proj2_sig y))). + Fix_F_sub A R P f x r = + f (fun y => Fix_F_sub A R P f (proj1_sig y) (Acc_inv r (proj2_sig y))). Proof. intros. case r; auto. Qed. - (* Fix_measure_F_sub_rect lets one prove a property of - functions defined using Fix_measure_F_sub by showing + (* Fix_F_sub_rect lets one prove a property of + functions defined using Fix_F_sub by showing that property to be invariant over single application of the function body (f in our case). *) - Lemma Fix_measure_F_sub_rect + Lemma Fix_F_sub_rect (Q: forall x, P x -> Type) (inv: forall x: A, - (forall (y: A) (H: MR lt m y x) (a: Acc lt (m y)), - Q y (Fix_measure_F_sub A m P f y a)) -> - forall (a: Acc lt (m x)), - Q x (f (fun y: {y: A | m y < m x} => - Fix_measure_F_sub A m P f (proj1_sig y) (Acc_inv a (proj2_sig y))))) - : forall x a, Q _ (Fix_measure_F_sub A m P f x a). + (forall (y: A) (H: R y x) (a: Acc R y), + Q y (Fix_F_sub A R P f y a)) -> + forall (a: Acc R x), + Q x (f (fun y: {y: A | R y x} => + Fix_F_sub A R P f (proj1_sig y) (Acc_inv a (proj2_sig y))))) + : forall x a, Q _ (Fix_F_sub A R P f x a). Proof with auto. - intros Q inv. - set (R := fun (x: A) => forall a, Q _ (Fix_measure_F_sub A m P f x a)). - cut (forall x, R x)... - apply (well_founded_induction_type (measure_wf lt_wf m)). - subst R. + set (R' := fun (x: A) => forall a, Q _ (Fix_F_sub A R P f x a)). + cut (forall x, R' x)... + apply (well_founded_induction_type Rwf). + subst R'. simpl. intros. rewrite F_unfold... @@ -229,29 +148,29 @@ Section Fix_measure_rects. (* Let's call f's second parameter its "lowers" function, since it provides it access to results for inputs with a lower measure. - In preparation of lemma similar to Fix_measure_F_sub_rect, but - for Fix_measure_sub, we first + In preparation of lemma similar to Fix_F_sub_rect, but + for Fix_sub, we first need an extra hypothesis stating that the function body has the same result for different "lowers" functions (g and h below) as long as those produce the same results for lower inputs, regardless of the lt proofs. *) Hypothesis equiv_lowers: - forall x0 (g h: forall x: {y: A | m y < m x0}, P (proj1_sig x)), - (forall x p p', g (exist (fun y: A => m y < m x0) x p) = h (exist _ x p')) -> + 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')) -> f g = f h. (* From equiv_lowers, it follows that - [Fix_measure_F_sub A m P f x] applications do not not + [Fix_F_sub A R P f x] applications do not not depend on the Acc proofs. *) - Lemma eq_Fix_measure_F_sub x (a a': Acc lt (m x)): - Fix_measure_F_sub A m P f x a = - Fix_measure_F_sub A m P f x a'. + Lemma eq_Fix_F_sub x (a a': Acc R x): + Fix_F_sub A R P f x a = + Fix_F_sub A R P f x a'. Proof. - intros x a. - pattern x, (Fix_measure_F_sub A m P f x a). - apply Fix_measure_F_sub_rect. + revert a'. + pattern x, (Fix_F_sub A R P f x a). + apply Fix_F_sub_rect. intros. rewrite F_unfold. apply equiv_lowers. @@ -260,40 +179,42 @@ Section Fix_measure_rects. assumption. Qed. - (* Finally, Fix_measure_F_rect lets one prove a property of - functions defined using Fix_measure_F by showing that + (* Finally, Fix_F_rect lets one prove a property of + functions defined using Fix_F_sub by showing that property to be invariant over single application of the function body (f). *) - Lemma Fix_measure_sub_rect + Lemma Fix_sub_rect (Q: forall x, P x -> Type) (inv: forall (x: A) - (H: forall (y: A), MR lt m y x -> Q y (Fix_measure_sub A m P f y)) - (a: Acc lt (m x)), - Q x (f (fun y: {y: A | m y < m x} => Fix_measure_sub A m P f (proj1_sig y)))) - : forall x, Q _ (Fix_measure_sub A m P f x). + (H: forall (y: A), R y x -> Q y (Fix_sub A R Rwf P f y)) + (a: Acc R x), + Q x (f (fun y: {y: A | R y x} => Fix_sub A R Rwf P f (proj1_sig y)))) + : forall x, Q _ (Fix_sub A R Rwf P f x). Proof with auto. - unfold Fix_measure_sub. + unfold Fix_sub. intros. - apply Fix_measure_F_sub_rect. + apply Fix_F_sub_rect. intros. - assert (forall y: A, MR lt m y x0 -> Q y (Fix_measure_F_sub A m P f y (lt_wf (m y))))... + assert (forall y: A, R y x0 -> Q y (Fix_F_sub A R P f y (Rwf y)))... set (inv x0 X0 a). clearbody q. - rewrite <- (equiv_lowers (fun y: {y: A | m y < m x0} => Fix_measure_F_sub A m P f (proj1_sig y) (lt_wf (m (proj1_sig y)))) (fun y: {y: A | m y < m x0} => Fix_measure_F_sub A m P f (proj1_sig y) (Acc_inv a (proj2_sig y))))... + rewrite <- (equiv_lowers (fun y: {y: A | R y x0} => + Fix_F_sub A R P f (proj1_sig y) (Rwf (proj1_sig y))) + (fun y: {y: A | R y x0} => Fix_F_sub A R P f (proj1_sig y) (Acc_inv a (proj2_sig y))))... intros. - apply eq_Fix_measure_F_sub. + apply eq_Fix_F_sub. Qed. -End Fix_measure_rects. +End Fix_rects. (** Tactic to fold a definition based on [Fix_measure_sub]. *) Ltac fold_sub f := match goal with - | [ |- ?T ] => + | [ |- ?T ] => match T with - appcontext C [ @Fix_measure_sub _ _ _ _ ?arg ] => + appcontext C [ @Fix_sub _ _ _ _ ?arg ] => let app := context C [ f arg ] in change app end @@ -308,7 +229,7 @@ Module WfExtensionality. (** The two following lemmas allow to unfold a well-founded fixpoint definition without restriction using the functional extensionality axiom. *) - + (** For a function defined with Program using a well-founded order. *) Program Lemma fix_sub_eq_ext : @@ -317,7 +238,7 @@ Module WfExtensionality. (F_sub : forall x : A, (forall (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 A R Rwf P F_sub y). + F_sub x (fun (y : A | R y x) => Fix_sub A R Rwf P F_sub y). Proof. intros ; apply Fix_eq ; auto. intros. @@ -326,26 +247,10 @@ Module WfExtensionality. rewrite H0 ; auto. Qed. - (** For a function defined with Program using a measure. *) - - Program Lemma fix_sub_measure_eq_ext : - forall (A : Type) (f : A -> nat) (P : A -> Type) - (F_sub : forall x : A, (forall (y : A | f y < f x), P y) -> P x), - forall x : A, - Fix_measure_sub A f P F_sub x = - F_sub x (fun (y : A | f y < f x) => Fix_measure_sub A f P F_sub y). - Proof. - intros ; apply Fix_measure_eq ; auto. - intros. - assert(f0 = g). - extensionality y ; apply H. - rewrite H0 ; auto. - Qed. - - (** Tactic to unfold once a definition based on [Fix_measure_sub]. *) - - Ltac unfold_sub f fargs := - set (call:=fargs) ; unfold f in call ; unfold call ; clear call ; - rewrite fix_sub_measure_eq_ext ; repeat fold_sub fargs ; simpl proj1_sig. + (** Tactic to unfold once a definition based on [Fix_sub]. *) + + Ltac unfold_sub f fargs := + set (call:=fargs) ; unfold f in call ; unfold call ; clear call ; + rewrite fix_sub_eq_ext ; repeat fold_sub fargs ; simpl proj1_sig. End WfExtensionality. diff --git a/theories/Program/vo.itarget b/theories/Program/vo.itarget new file mode 100644 index 00000000..864c815a --- /dev/null +++ b/theories/Program/vo.itarget @@ -0,0 +1,9 @@ +Basics.vo +Combinators.vo +Equality.vo +Program.vo +Subset.vo +Syntax.vo +Tactics.vo +Utils.vo +Wf.vo diff --git a/theories/QArith/QArith.v b/theories/QArith/QArith.v index 2af65320..f7a28598 100644 --- a/theories/QArith/QArith.v +++ b/theories/QArith/QArith.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: QArith.v 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id$ i*) Require Export QArith_base. Require Export Qring. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 0b6d1cfe..54d2a295 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -6,11 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: QArith_base.v 13215 2010-06-29 09:31:45Z letouzey $ i*) +(*i $Id$ i*) Require Export ZArith. Require Export ZArithRing. -Require Export Setoid Bool. +Require Export Morphisms Setoid Bool. (** * Definition of [Q] and basic properties *) @@ -87,6 +87,19 @@ Qed. Hint Unfold Qeq Qlt Qle : qarith. Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith. +Lemma Qcompare_antisym : forall x y, CompOpp (x ?= y) = (y ?= x). +Proof. + unfold "?=". intros. apply Zcompare_antisym. +Qed. + +Lemma Qcompare_spec : forall x y, CompSpec Qeq Qlt x y (x ?= y). +Proof. + intros. + destruct (x ?= y) as [ ]_eqn:H; constructor; auto. + rewrite Qeq_alt; auto. + rewrite Qlt_alt, <- Qcompare_antisym, H; auto. +Qed. + (** * Properties of equality. *) Theorem Qeq_refl : forall x, x == x. @@ -101,7 +114,7 @@ Qed. Theorem Qeq_trans : forall x y z, x == y -> y == z -> x == z. Proof. -unfold Qeq in |- *; intros. +unfold Qeq; intros. apply Zmult_reg_l with (QDen y). auto with qarith. transitivity (Qnum x * QDen y * QDen z)%Z; try ring. @@ -110,6 +123,15 @@ transitivity (Qnum y * QDen z * QDen x)%Z; try ring. rewrite H0; ring. Qed. +Hint Resolve Qeq_refl : qarith. +Hint Resolve Qeq_sym : qarith. +Hint Resolve Qeq_trans : qarith. + +(** In a word, [Qeq] is a setoid equality. *) + +Instance Q_Setoid : Equivalence Qeq. +Proof. split; red; eauto with qarith. Qed. + (** Furthermore, this equality is decidable: *) Theorem Qeq_dec : forall x y, {x==y} + {~ x==y}. @@ -120,12 +142,12 @@ Defined. Definition Qeq_bool x y := (Zeq_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z. -Definition Qle_bool x y := +Definition Qle_bool x y := (Zle_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z. Lemma Qeq_bool_iff : forall x y, Qeq_bool x y = true <-> x == y. Proof. - unfold Qeq_bool, Qeq; intros. + unfold Qeq_bool, Qeq; intros. symmetry; apply Zeq_is_eq_bool. Qed. @@ -155,18 +177,6 @@ Proof. intros; rewrite <- Qle_bool_iff; auto. Qed. -(** We now consider [Q] seen as a setoid. *) - -Add Relation Q Qeq - reflexivity proved by Qeq_refl - symmetry proved by Qeq_sym - transitivity proved by Qeq_trans -as Q_Setoid. - -Hint Resolve Qeq_refl : qarith. -Hint Resolve Qeq_sym : qarith. -Hint Resolve Qeq_trans : qarith. - Theorem Qnot_eq_sym : forall x y, ~x == y -> ~y == x. Proof. auto with qarith. @@ -218,7 +228,7 @@ Qed. (** * Setoid compatibility results *) -Add Morphism Qplus : Qplus_comp. +Instance Qplus_comp : Proper (Qeq==>Qeq==>Qeq) Qplus. Proof. unfold Qeq, Qplus; simpl. Open Scope Z_scope. @@ -232,24 +242,23 @@ Proof. Close Scope Z_scope. Qed. -Add Morphism Qopp : Qopp_comp. +Instance Qopp_comp : Proper (Qeq==>Qeq) Qopp. Proof. unfold Qeq, Qopp; simpl. Open Scope Z_scope. - intros. + intros x y H; simpl. replace (- Qnum x * ' Qden y) with (- (Qnum x * ' Qden y)) by ring. - rewrite H in |- *; ring. + rewrite H; ring. Close Scope Z_scope. Qed. -Add Morphism Qminus : Qminus_comp. +Instance Qminus_comp : Proper (Qeq==>Qeq==>Qeq) Qminus. Proof. - intros. - unfold Qminus. - rewrite H; rewrite H0; auto with qarith. + intros x x' Hx y y' Hy. + unfold Qminus. rewrite Hx, Hy; auto with qarith. Qed. -Add Morphism Qmult : Qmult_comp. +Instance Qmult_comp : Proper (Qeq==>Qeq==>Qeq) Qmult. Proof. unfold Qeq; simpl. Open Scope Z_scope. @@ -263,7 +272,7 @@ Proof. Close Scope Z_scope. Qed. -Add Morphism Qinv : Qinv_comp. +Instance Qinv_comp : Proper (Qeq==>Qeq) Qinv. Proof. unfold Qeq, Qinv; simpl. Open Scope Z_scope. @@ -281,83 +290,49 @@ Proof. Close Scope Z_scope. Qed. -Add Morphism Qdiv : Qdiv_comp. -Proof. - intros; unfold Qdiv. - rewrite H; rewrite H0; auto with qarith. -Qed. - -Add Morphism Qle with signature Qeq ==> Qeq ==> iff as Qle_comp. +Instance Qdiv_comp : Proper (Qeq==>Qeq==>Qeq) Qdiv. Proof. - cut (forall x1 x2, x1==x2 -> forall x3 x4, x3==x4 -> x1<=x3 -> x2<=x4). - split; apply H; assumption || (apply Qeq_sym ; assumption). - - unfold Qeq, Qle; simpl. - Open Scope Z_scope. - intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0 H1; simpl in *. - apply Zmult_le_reg_r with ('p2). - unfold Zgt; auto. - replace (q1 * 's2 * 'p2) with (q1 * 'p2 * 's2) by ring. - rewrite <- H. - apply Zmult_le_reg_r with ('r2). - unfold Zgt; auto. - replace (s1 * 'q2 * 'p2 * 'r2) with (s1 * 'r2 * 'q2 * 'p2) by ring. - rewrite <- H0. - replace (p1 * 'q2 * 's2 * 'r2) with ('q2 * 's2 * (p1 * 'r2)) by ring. - replace (r1 * 's2 * 'q2 * 'p2) with ('q2 * 's2 * (r1 * 'p2)) by ring. - auto with zarith. - Close Scope Z_scope. + intros x x' Hx y y' Hy; unfold Qdiv. + rewrite Hx, Hy; auto with qarith. Qed. -Add Morphism Qlt with signature Qeq ==> Qeq ==> iff as Qlt_comp. +Instance Qcompare_comp : Proper (Qeq==>Qeq==>eq) Qcompare. Proof. - cut (forall x1 x2, x1==x2 -> forall x3 x4, x3==x4 -> x1 x2 Qeq ==> (@eq bool) as Qeqb_comp. +Instance Qle_comp : Proper (Qeq==>Qeq==>iff) Qle. Proof. - intros; apply eq_true_iff_eq. - rewrite 2 Qeq_bool_iff, H, H0; split; auto with qarith. + intros p q H r s H'. rewrite 2 Qle_alt, H, H'; auto with *. Qed. -Add Morphism Qle_bool with signature Qeq ==> Qeq ==> (@eq bool) as Qleb_comp. +Instance Qlt_compat : Proper (Qeq==>Qeq==>iff) Qlt. Proof. - intros; apply eq_true_iff_eq. - rewrite 2 Qle_bool_iff, H, H0. - split; auto with qarith. + intros p q H r s H'. rewrite 2 Qlt_alt, H, H'; auto with *. Qed. -Lemma Qcompare_egal_dec: forall n m p q : Q, - (n p (n==m -> p==q) -> (n>m -> p>q) -> ((n?=m) = (p?=q)). +Instance Qeqb_comp : Proper (Qeq==>Qeq==>eq) Qeq_bool. Proof. - intros. - do 2 rewrite Qeq_alt in H0. - unfold Qeq, Qlt, Qcompare in *. - apply Zcompare_egal_dec; auto. - omega. + intros p q H r s H'; apply eq_true_iff_eq. + rewrite 2 Qeq_bool_iff, H, H'; split; auto with qarith. Qed. -Add Morphism Qcompare : Qcompare_comp. +Instance Qleb_comp : Proper (Qeq==>Qeq==>eq) Qle_bool. Proof. - intros; apply Qcompare_egal_dec; rewrite H; rewrite H0; auto. + intros p q H r s H'; apply eq_true_iff_eq. + rewrite 2 Qle_bool_iff, H, H'; split; auto with qarith. Qed. @@ -554,6 +529,11 @@ Qed. Hint Resolve Qle_trans : qarith. +Lemma Qlt_irrefl : forall x, ~x ~ x==y. Proof. unfold Qlt, Qeq; auto with zarith. @@ -561,6 +541,13 @@ Qed. (** Large = strict or equal *) +Lemma Qle_lteq : forall x y, x<=y <-> x x<=y. Proof. unfold Qle, Qlt; auto with zarith. @@ -632,15 +619,8 @@ Proof. unfold Qle, Qlt, Qeq; intros; apply Zle_lt_or_eq; auto. Qed. -(** These hints were meant to be added to the qarith database, - but a typo prevented that. This will be fixed in 8.3. - Concerning 8.2, for maximal compatibility , we - leave them in a separate database, in order to preserve - the strength of both [auto with qarith] and [auto with *]. - (see bug #2346). *) - Hint Resolve Qle_not_lt Qlt_not_le Qnot_le_lt Qnot_lt_le - Qlt_le_weak Qlt_not_eq Qle_antisym Qle_refl: qarith_extra. + Qlt_le_weak Qlt_not_eq Qle_antisym Qle_refl: qarith. (** Some decidability results about orders. *) @@ -842,9 +822,9 @@ Qed. Definition Qpower_positive (q:Q)(p:positive) : Q := pow_pos Qmult q p. -Add Morphism Qpower_positive with signature Qeq ==> @eq _ ==> Qeq as Qpower_positive_comp. +Instance Qpower_positive_comp : Proper (Qeq==>eq==>Qeq) Qpower_positive. Proof. -intros x1 x2 Hx y. +intros x x' Hx y y' Hy. rewrite <-Hy; clear y' Hy. unfold Qpower_positive. induction y; simpl; try rewrite IHy; @@ -861,8 +841,8 @@ Definition Qpower (q:Q) (z:Z) := Notation " q ^ z " := (Qpower q z) : Q_scope. -Add Morphism Qpower with signature Qeq ==> @eq _ ==> Qeq as Qpower_comp. +Instance Qpower_comp : Proper (Qeq==>eq==>Qeq) Qpower. Proof. -intros x1 x2 Hx [|y|y]; try reflexivity; -simpl; rewrite Hx; reflexivity. +intros x x' Hx y y' Hy. rewrite <- Hy; clear y' Hy. +destruct y; simpl; rewrite ?Hx; auto with *. Qed. diff --git a/theories/QArith/QOrderedType.v b/theories/QArith/QOrderedType.v new file mode 100644 index 00000000..692bfd92 --- /dev/null +++ b/theories/QArith/QOrderedType.v @@ -0,0 +1,58 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Qeq==>iff) Qlt. + Proof. auto with *. Qed. + + Definition le_lteq := Qle_lteq. + Definition compare_spec := Qcompare_spec. + +End Q_as_OT. + + +(** * An [order] tactic for [Q] numbers *) + +Module QOrder := OTF_to_OrderTac Q_as_OT. +Ltac q_order := QOrder.order. + +(** Note that [q_order] is domain-agnostic: it will not prove + [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x==y]. *) diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index 42522468..34d6267e 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -6,14 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qcanon.v 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id$ i*) Require Import Field. Require Import QArith. Require Import Znumtheory. Require Import Eqdep_dec. -(** [Qc] : A canonical representation of rational numbers. +(** [Qc] : A canonical representation of rational numbers. based on the setoid representation [Q]. *) Record Qc : Set := Qcmake { this :> Q ; canon : Qred this = this }. @@ -23,7 +23,7 @@ Bind Scope Qc_scope with Qc. Arguments Scope Qcmake [Q_scope]. Open Scope Qc_scope. -Lemma Qred_identity : +Lemma Qred_identity : forall q:Q, Zgcd (Qnum q) (QDen q) = 1%Z -> Qred q = q. Proof. unfold Qred; intros (a,b); simpl. @@ -36,7 +36,7 @@ Proof. subst; simpl; auto. Qed. -Lemma Qred_identity2 : +Lemma Qred_identity2 : forall q:Q, Qred q = q -> Zgcd (Qnum q) (QDen q) = 1%Z. Proof. unfold Qred; intros (a,b); simpl. @@ -50,7 +50,7 @@ Proof. destruct g as [|g|g]; destruct bb as [|bb|bb]; simpl in *; try discriminate. f_equal. apply Pmult_reg_r with bb. - injection H2; intros. + injection H2; intros. rewrite <- H0. rewrite H; simpl; auto. elim H1; auto. @@ -70,7 +70,7 @@ Proof. apply Qred_correct. Qed. -Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). +Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). Arguments Scope Q2Qc [Q_scope]. Notation " !! " := Q2Qc : Qc_scope. @@ -82,7 +82,7 @@ Proof. assert (H0:=Qred_complete _ _ H). assert (q = q') by congruence. subst q'. - assert (proof_q = proof_q'). + assert (proof_q = proof_q'). apply eq_proofs_unicity; auto; intros. repeat decide equality. congruence. @@ -98,8 +98,8 @@ Notation Qcgt := (fun x y : Qc => Qlt y x). Notation Qcge := (fun x y : Qc => Qle y x). Infix "<" := Qclt : Qc_scope. Infix "<=" := Qcle : Qc_scope. -Infix ">" := Qcgt : Qc_scope. -Infix ">=" := Qcge : Qc_scope. +Infix ">" := Qcgt : Qc_scope. +Infix ">=" := Qcge : Qc_scope. Notation "x <= y <= z" := (x<=y/\y<=z) : Qc_scope. Notation "x < y < z" := (x destruct q; qc +Ltac qc := match goal with + | q:Qc |- _ => destruct q; qc | _ => apply Qc_is_canon; simpl; repeat rewrite Qred_correct end. @@ -191,7 +191,7 @@ Qed. Lemma Qcplus_0_r : forall x, x+0 = x. Proof. intros; qc; apply Qplus_0_r. -Qed. +Qed. (** Commutativity of addition: *) @@ -265,13 +265,13 @@ Qed. Theorem Qcmult_integral_l : forall x y, ~ x = 0 -> x*y = 0 -> y = 0. Proof. intros; destruct (Qcmult_integral _ _ H0); tauto. -Qed. +Qed. -(** Inverse and division. *) +(** Inverse and division. *) Theorem Qcmult_inv_r : forall x, x<>0 -> x*(/x) = 1. Proof. - intros; qc; apply Qmult_inv_r; auto. + intros; qc; apply Qmult_inv_r; auto. Qed. Theorem Qcmult_inv_l : forall x, x<>0 -> (/x)*x = 1. @@ -436,24 +436,24 @@ 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 * |-. + repeat progress 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 *. + repeat progress rewrite Qred_correct in *. eapply Qmult_lt_compat_r; eauto. Qed. (** Rational to the n-th power *) -Fixpoint Qcpower (q:Qc)(n:nat) { struct n } : Qc := - match n with +Fixpoint Qcpower (q:Qc)(n:nat) : Qc := + match n with | O => 1 | S n => q * (Qcpower q n) - end. + end. Notation " q ^ n " := (Qcpower q n) : Qc_scope. @@ -467,7 +467,7 @@ Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0. Proof. destruct n; simpl. destruct 1; auto. - intros. + intros. apply Qc_is_canon. simpl. compute; auto. @@ -537,7 +537,7 @@ Proof. intros (q, Hq) (q', Hq'); simpl; intros H. assert (H1 := H Hq Hq'). subst q'. - assert (Hq = Hq'). + assert (Hq = Hq'). apply Eqdep_dec.eq_proofs_unicity; auto; intros. repeat decide equality. congruence. diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v index 9841ef89..fbfae55c 100644 --- a/theories/QArith/Qfield.v +++ b/theories/QArith/Qfield.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qfield.v 11208 2008-07-04 16:57:46Z letouzey $ i*) +(*i $Id$ i*) Require Export Field. Require Export QArith_base. @@ -73,15 +73,15 @@ Ltac Qpow_tac t := | _ => NotConstant end. -Add Field Qfield : Qsft - (decidable Qeq_bool_eq, +Add Field Qfield : Qsft + (decidable Qeq_bool_eq, completeness Qeq_eq_bool, - constants [Qcst], + constants [Qcst], power_tac Qpower_theory [Qpow_tac]). (** Exemple of use: *) -Section Examples. +Section Examples. Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). intros. @@ -89,7 +89,7 @@ Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). Qed. Let ex2 : forall x y : Q, x+y == y+x. - intros. + intros. ring. Qed. diff --git a/theories/QArith/Qminmax.v b/theories/QArith/Qminmax.v new file mode 100644 index 00000000..d05a8594 --- /dev/null +++ b/theories/QArith/Qminmax.v @@ -0,0 +1,67 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* g). intro; subst g; discriminate. - + assert (0 < dd). apply Zmult_gt_0_lt_0_reg_r with g. omega. @@ -68,10 +68,10 @@ Proof. intros (a,b) (c,d). unfold Qred, Qeq in *; simpl in *. Open Scope Z_scope. - generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b)) + generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b)) (Zgcd_is_pos a ('b)) (Zggcd_correct_divisors a ('b)). destruct (Zggcd a (Zpos b)) as (g,(aa,bb)). - generalize (Zggcd_gcd c ('d)) (Zgcd_is_gcd c ('d)) + generalize (Zggcd_gcd c ('d)) (Zgcd_is_gcd c ('d)) (Zgcd_is_pos c ('d)) (Zggcd_correct_divisors c ('d)). destruct (Zggcd c (Zpos d)) as (g',(cc,dd)). simpl. @@ -136,7 +136,7 @@ Proof. Close Scope Z_scope. Qed. -Add Morphism Qred : Qred_comp. +Add Morphism Qred : Qred_comp. Proof. intros q q' H. rewrite (Qred_correct q); auto. @@ -144,7 +144,7 @@ Proof. Qed. Definition Qplus' (p q : Q) := Qred (Qplus p q). -Definition Qmult' (p q : Q) := Qred (Qmult p q). +Definition Qmult' (p q : Q) := Qred (Qmult p q). Definition Qminus' x y := Qred (Qminus x y). Lemma Qplus'_correct : forall p q : Q, (Qplus' p q)==(Qplus p q). diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v index 2d45d537..8c9e2dfa 100644 --- a/theories/QArith/Qring.v +++ b/theories/QArith/Qring.v @@ -6,6 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qring.v 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id$ i*) Require Export Qfield. diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v index 3f191c75..8162a702 100644 --- a/theories/QArith/Qround.v +++ b/theories/QArith/Qround.v @@ -122,7 +122,7 @@ Qed. Hint Resolve Qceiling_resp_le : qarith. -Add Morphism Qfloor with signature Qeq ==> @eq _ as Qfloor_comp. +Add Morphism Qfloor with signature Qeq ==> eq as Qfloor_comp. Proof. intros x y H. apply Zle_antisym. @@ -130,7 +130,7 @@ apply Zle_antisym. symmetry in H; auto with *. Qed. -Add Morphism Qceiling with signature Qeq ==> @eq _ as Qceiling_comp. +Add Morphism Qceiling with signature Qeq ==> eq as Qceiling_comp. Proof. intros x y H. apply Zle_antisym. diff --git a/theories/QArith/vo.itarget b/theories/QArith/vo.itarget new file mode 100644 index 00000000..b3faef88 --- /dev/null +++ b/theories/QArith/vo.itarget @@ -0,0 +1,12 @@ +Qabs.vo +QArith_base.vo +QArith.vo +Qcanon.vo +Qfield.vo +Qpower.vo +Qreals.vo +Qreduction.vo +Qring.vo +Qround.vo +QOrderedType.vo +Qminmax.vo \ No newline at end of file diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index 7625cce6..6e2488f5 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -5,8 +5,8 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - -(*i $Id: Alembert.v 10710 2008-03-23 09:24:09Z herbelin $ i*) + +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -198,7 +198,7 @@ Proof. replace (Wn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Wn (S n)); [ idtac | ring ]; replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with - (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); + (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); [ idtac | ring ]; apply Rmult_le_compat_l. left; apply Rmult_lt_0_compat. prove_sup0. @@ -273,7 +273,7 @@ Proof. replace (Vn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Vn (S n)); [ idtac | ring ]; replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with - (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); + (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); [ idtac | ring ]; apply Rmult_le_compat_l. left; apply Rmult_lt_0_compat. prove_sup0. @@ -304,8 +304,8 @@ Proof. pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double; rewrite Rplus_assoc; apply Rplus_le_compat_l. apply Rplus_le_reg_l with (- An n); rewrite Rplus_0_r; - rewrite <- (Rplus_comm (An n)); rewrite <- Rplus_assoc; - rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite <- Rabs_Ropp; + rewrite <- (Rplus_comm (An n)); rewrite <- Rplus_assoc; + rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite <- Rabs_Ropp; apply RRle_abs. unfold Vn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc; apply Rmult_le_compat_l. @@ -318,7 +318,7 @@ Proof. 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 in |- *; - rewrite (Rplus_comm (An n)); rewrite Rplus_assoc; + rewrite (Rplus_comm (An n)); rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rle_lt_trans with (Rabs (An n)). apply RRle_abs. @@ -328,7 +328,7 @@ Proof. 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 in |- *; - rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc; + rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_r; apply Rle_lt_trans with (Rabs (An n)). rewrite <- Rabs_Ropp; apply RRle_abs. @@ -352,7 +352,7 @@ Proof. unfold Un_cv in |- *; 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 in |- *; unfold Rminus in |- *; - rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; + rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Bn in |- *; replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x). rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs x). @@ -363,13 +363,13 @@ Proof. replace (Rabs (An (S n) / An n)) with (R_dist (Rabs (An (S n) * / An n)) 0). apply H5; assumption. unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0; - rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv in |- *; + rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv in |- *; reflexivity. apply Rabs_no_R0; assumption. replace (S n) with (n + 1)%nat; [ idtac | ring ]; rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr. replace (An (n + 1)%nat * (x ^ n * x ^ 1) * (/ An n * / x ^ n)) with - (An (n + 1)%nat * x ^ 1 * / An n * (x ^ n * / x ^ n)); + (An (n + 1)%nat * x ^ 1 * / An n * (x ^ n * / x ^ n)); [ idtac | ring ]; rewrite <- Rinv_r_sym. simpl in |- *; ring. apply pow_nonzero; assumption. @@ -638,7 +638,7 @@ Lemma Alembert_C6 : rewrite Rmult_1_r. rewrite Rinv_mult_distr. replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with - (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); + (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); [ idtac | ring ]. rewrite <- Rinv_r_sym. rewrite Rmult_1_r; reflexivity. @@ -713,7 +713,7 @@ Lemma Alembert_C6 : rewrite Rmult_1_r. rewrite Rinv_mult_distr. replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with - (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); + (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); [ idtac | ring ]. rewrite <- Rinv_r_sym. rewrite Rmult_1_r; reflexivity. diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v index 5c4bbd6a..cccc8cee 100644 --- a/theories/Reals/AltSeries.v +++ b/theories/Reals/AltSeries.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: AltSeries.v 10710 2008-03-23 09:24:09Z herbelin $ i*) + (*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -69,7 +69,7 @@ Lemma CV_ALT_step2 : forall (Un:nat -> R) (N:nat), Un_decreasing Un -> positivity_seq Un -> - sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0. + sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0. Proof. intros; induction N as [| N HrecN]. simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r. @@ -101,7 +101,7 @@ Qed. Lemma CV_ALT_step3 : forall (Un:nat -> R) (N:nat), Un_decreasing Un -> - positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0. + positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0. Proof. intros; induction N as [| N HrecN]. simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r. @@ -184,7 +184,7 @@ Proof. rewrite H12; apply H7; assumption. rewrite Rabs_Ropp; unfold tg_alt in |- *; rewrite Rabs_mult; rewrite pow_1_abs; rewrite Rmult_1_l; unfold Rminus in H6; - rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n))); + rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n))); apply H6. unfold ge in |- *; apply le_trans with n. apply le_trans with N; [ unfold N in |- *; apply le_max_r | assumption ]. @@ -246,7 +246,7 @@ Proof. apply CV_ALT_step1; assumption. assumption. unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1; - unfold R_dist in H1; intros. + unfold R_dist in H1; intros. elim (H1 eps H2); intros. exists x; intros. apply H3. @@ -254,20 +254,20 @@ Proof. apply le_trans with n. assumption. assert (H5 := mult_O_le n 2). - elim H5; intro. + elim H5; intro. cut (0%nat <> 2%nat); [ intro; elim H7; symmetry in |- *; assumption | discriminate ]. assumption. apply le_n_Sn. unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1; - unfold R_dist in H1; intros. + unfold R_dist in H1; intros. elim (H1 eps H2); intros. exists x; intros. apply H3. unfold ge in |- *; apply le_trans with n. assumption. assert (H5 := mult_O_le n 2). - elim H5; intro. + elim H5; intro. cut (0%nat <> 2%nat); [ intro; elim H7; symmetry in |- *; assumption | discriminate ]. assumption. diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index 7327c64c..f22ff5cb 100644 --- a/theories/Reals/ArithProp.v +++ b/theories/Reals/ArithProp.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: ArithProp.v 9454 2006-12-15 15:30:59Z bgregoir $ i*) + (*i $Id$ i*) Require Import Rbase. Require Import Rbasic_fun. @@ -124,7 +124,7 @@ Proof. rewrite <- Ropp_inv_permute; [ idtac | assumption ]. replace (IZR (up (x * / - y)) - x * - / y + - (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1; + (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1; [ idtac | ring ]. elim H0; intros _ H1; unfold Rdiv in H1; exact H1. rewrite (Rabs_left _ r); apply Rmult_lt_reg_l with (/ - y). @@ -153,11 +153,11 @@ Proof. rewrite Rmult_0_r; rewrite (Rmult_comm (/ y)); rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ]; - apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y); + apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y); rewrite Rplus_0_r; unfold Rdiv in |- *; replace (IZR (up (x * / y)) - x * / y + (x * / y + (1 - IZR (up (x * / y))))) with - 1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2; + 1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2; exact H2. rewrite (Rabs_right _ r); apply Rmult_lt_reg_l with (/ y). apply Rinv_0_lt_compat; assumption. @@ -165,10 +165,10 @@ Proof. rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ]; apply Rplus_lt_reg_r with (IZR (up (x / y)) - 1); - replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y))); + replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y))); [ idtac | ring ]; replace (IZR (up (x / y)) - 1 + (x * / y + (1 - IZR (up (x / y))))) with - (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv in |- *; + (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv in |- *; intros H2 _; exact H2. case (total_order_T 0 y); intro. elim s; intro. diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v index 5be34e71..0d34d22c 100644 --- a/theories/Reals/Binomial.v +++ b/theories/Reals/Binomial.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: Binomial.v 9245 2006-10-17 12:53:34Z notin $ i*) + (*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -194,7 +194,7 @@ Proof. apply minus_Sn_m; assumption. rewrite <- (Rmult_comm x); rewrite scal_sum; apply sum_eq. intros; replace (S i) with (i + 1)%nat; [ idtac | ring ]; rewrite pow_add; - replace (x ^ 1) with x; [ idtac | simpl in |- *; ring ]; + replace (x ^ 1) with x; [ idtac | simpl in |- *; ring ]; ring. intro; unfold C in |- *. replace (INR (fact 0)) with 1; [ idtac | reflexivity ]. diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v index 37429a90..6ea0767d 100644 --- a/theories/Reals/Cauchy_prod.v +++ b/theories/Reals/Cauchy_prod.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: Cauchy_prod.v 9245 2006-10-17 12:53:34Z notin $ i*) + (*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -47,7 +47,7 @@ Theorem cauchy_finite : sum_f_R0 (fun k:nat => sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) - (pred (N - k))) (pred N). + (pred (N - k))) (pred N). Proof. intros; induction N as [| N HrecN]. elim (lt_irrefl _ H). @@ -124,7 +124,7 @@ Proof. (fun k:nat => sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) (pred (pred (N - k)))) (pred (pred N))); - set (Z2 := sum_f_R0 (fun i:nat => Bn (S i)) (pred N)); + set (Z2 := sum_f_R0 (fun i:nat => Bn (S i)) (pred N)); ring. rewrite (sum_N_predN diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v index 0de639e8..6c08356a 100644 --- a/theories/Reals/Cos_plus.v +++ b/theories/Reals/Cos_plus.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: Cos_plus.v 10710 2008-03-23 09:24:09Z herbelin $ i*) + (*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -111,7 +111,7 @@ Proof. (Rsum_abs (fun l:nat => (-1) ^ S (l + n) / INR (fact (2 * S (l + n))) * x ^ (2 * S (l + n)) * - ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * + ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * y ^ (2 * (N - l))) (pred (N - n))). apply Rle_trans with (sum_f_R0 @@ -745,42 +745,42 @@ Proof. exact H. Qed. -Theorem cos_plus : forall x y:R, cos (x + y) = cos x * cos y - sin x * sin y. +Theorem cos_plus : forall x y:R, cos (x + y) = cos x * cos y - sin x * sin y. Proof. - intros. - cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)). - cut (Un_cv (C1 x y) (cos (x + y))). - intros. - apply UL_sequence with (C1 x y); assumption. - apply C1_cvg. - unfold Un_cv in |- *; unfold R_dist in |- *. - intros. - assert (H0 := A1_cvg x). - assert (H1 := A1_cvg y). - assert (H2 := B1_cvg x). - assert (H3 := B1_cvg y). - assert (H4 := CV_mult _ _ _ _ H0 H1). - assert (H5 := CV_mult _ _ _ _ H2 H3). + intros. + cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)). + cut (Un_cv (C1 x y) (cos (x + y))). + intros. + apply UL_sequence with (C1 x y); assumption. + apply C1_cvg. + unfold Un_cv in |- *; unfold R_dist in |- *. + intros. + assert (H0 := A1_cvg x). + assert (H1 := A1_cvg y). + assert (H2 := B1_cvg x). + assert (H3 := B1_cvg y). + assert (H4 := CV_mult _ _ _ _ H0 H1). + assert (H5 := CV_mult _ _ _ _ H2 H3). assert (H6 := reste_cv_R0 x y). unfold Un_cv in H4; unfold Un_cv in H5; unfold Un_cv in H6. - unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6. + unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6. cut (0 < eps / 3); [ intro | unfold Rdiv in |- *; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. - elim (H4 (eps / 3) H7); intros N1 H8. - elim (H5 (eps / 3) H7); intros N2 H9. + [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. + elim (H4 (eps / 3) H7); intros N1 H8. + elim (H5 (eps / 3) H7); intros N2 H9. elim (H6 (eps / 3) H7); intros N3 H10. - set (N := S (S (max (max N1 N2) N3))). - exists N. - intros. - cut (n = S (pred n)). - intro; rewrite H12. - rewrite <- cos_plus_form. - rewrite <- H12. + set (N := S (S (max (max N1 N2) N3))). + exists N. + intros. + cut (n = S (pred n)). + intro; rewrite H12. + rewrite <- cos_plus_form. + rewrite <- H12. apply Rle_lt_trans with (Rabs (A1 x n * A1 y n - cos x * cos y) + - Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))). + Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))). replace (A1 x n * A1 y n - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n) - (cos x * cos y - sin x * sin y)) with @@ -788,28 +788,28 @@ Proof. (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))); [ apply Rabs_triang | ring ]. replace eps with (eps / 3 + (eps / 3 + eps / 3)). - apply Rplus_lt_compat. - apply H8. - unfold ge in |- *; apply le_trans with N. - unfold N in |- *. - apply le_trans with (max N1 N2). - apply le_max_l. + apply Rplus_lt_compat. + apply H8. + unfold ge in |- *; apply le_trans with N. + unfold N in |- *. + apply le_trans with (max N1 N2). + apply le_max_l. apply le_trans with (max (max N1 N2) N3). apply le_max_l. apply le_trans with (S (max (max N1 N2) N3)); apply le_n_Sn. - assumption. + assumption. apply Rle_lt_trans with (Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n)) + Rabs (Reste x y (pred n))). apply Rabs_triang. apply Rplus_lt_compat. - rewrite <- Rabs_Ropp. - rewrite Ropp_minus_distr. - apply H9. - unfold ge in |- *; apply le_trans with (max N1 N2). - apply le_max_r. - apply le_S_n. - rewrite <- H12. + rewrite <- Rabs_Ropp. + rewrite Ropp_minus_distr. + apply H9. + unfold ge in |- *; apply le_trans with (max N1 N2). + apply le_max_r. + apply le_S_n. + rewrite <- H12. apply le_trans with N. unfold N in |- *. apply le_n_S. @@ -843,11 +843,11 @@ Proof. replace (S (pred N)) with N. assumption. unfold N in |- *; simpl in |- *; reflexivity. - cut (0 < N)%nat. - intro. - cut (0 < n)%nat. - intro. + cut (0 < N)%nat. + intro. + cut (0 < n)%nat. + intro. apply S_pred with 0%nat; assumption. - apply lt_le_trans with N; assumption. + apply lt_le_trans with N; assumption. unfold N in |- *; apply lt_O_Sn. Qed. diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v index aed481c7..7a893c53 100644 --- a/theories/Reals/Cos_rel.v +++ b/theories/Reals/Cos_rel.v @@ -5,8 +5,8 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - -(*i $Id: Cos_rel.v 10710 2008-03-23 09:24:09Z herbelin $ i*) + +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -15,15 +15,15 @@ Require Import Rtrigo_def. Open Local Scope R_scope. Definition A1 (x:R) (N:nat) : R := - sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N. - + sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N. + Definition B1 (x:R) (N:nat) : R := sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1)) - N. - + N. + Definition C1 (x y:R) (N:nat) : R := - sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) N. - + sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) N. + Definition Reste1 (x y:R) (N:nat) : R := sum_f_R0 (fun k:nat => @@ -50,7 +50,7 @@ Definition Reste (x y:R) (N:nat) : R := Reste2 x y N - Reste1 x y (S N). Theorem cos_plus_form : forall (x y:R) (n:nat), (0 < n)%nat -> - A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n). + A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n). intros. unfold A1, B1 in |- *. rewrite @@ -244,152 +244,152 @@ apply INR_fact_neq_0. apply INR_fact_neq_0. unfold Reste2 in |- *; apply sum_eq; intros. apply sum_eq; intros. -unfold Rdiv in |- *; ring. +unfold Rdiv in |- *; ring. unfold Reste1 in |- *; apply sum_eq; intros. apply sum_eq; intros. unfold Rdiv in |- *; ring. apply lt_O_Sn. Qed. -Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i. -intros. +Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i. +intros. assert (H := pow_Rsqr x i). unfold Rsqr in H; exact H. -Qed. - -Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x). -intro. -assert (H := exist_cos (x * x)). -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 = x0). -intro. -rewrite H0. -unfold Un_cv in |- *; unfold R_dist in |- *; intros. -elim (p eps H1); intros. -exists x1; intros. -unfold A1 in |- *. +Qed. + +Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x). +intro. +assert (H := exist_cos (x * x)). +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 = x0). +intro. +rewrite H0. +unfold Un_cv in |- *; unfold R_dist in |- *; intros. +elim (p eps H1); intros. +exists x1; intros. +unfold A1 in |- *. replace (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with - (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n). -apply H2; assumption. -apply sum_eq. -intros. -replace ((x * x) ^ i) with (x ^ (2 * i)). -reflexivity. -apply pow_sqr. -unfold cos in |- *. -case (exist_cos (Rsqr x)). -unfold Rsqr in |- *; 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 in |- *; unfold R_dist in |- *; intros. -elim (p eps H1); intros. -exists x1; intros. -unfold C1 in |- *. + (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n). +apply H2; assumption. +apply sum_eq. +intros. +replace ((x * x) ^ i) with (x ^ (2 * i)). +reflexivity. +apply pow_sqr. +unfold cos in |- *. +case (exist_cos (Rsqr x)). +unfold Rsqr in |- *; 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 in |- *; unfold R_dist in |- *; intros. +elim (p eps H1); intros. +exists x1; intros. +unfold C1 in |- *. replace (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) n) with (sum_f_R0 - (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n). -apply H2; assumption. -apply sum_eq. -intros. -replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)). -reflexivity. -apply pow_sqr. -unfold cos in |- *. -case (exist_cos (Rsqr (x + y))). -unfold Rsqr in |- *; intros. -unfold cos_in in p_i. -unfold cos_in in c. + (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n). +apply H2; assumption. +apply sum_eq. +intros. +replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)). +reflexivity. +apply pow_sqr. +unfold cos in |- *. +case (exist_cos (Rsqr (x + y))). +unfold Rsqr in |- *; 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). -intro. -case (Req_dec x 0); intro. -rewrite H. -rewrite sin_0. -unfold B1 in |- *. -unfold Un_cv in |- *; unfold R_dist in |- *; intros; exists 0%nat; intros. + assumption. +Qed. + +Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x). +intro. +case (Req_dec x 0); intro. +rewrite H. +rewrite sin_0. +unfold B1 in |- *. +unfold Un_cv in |- *; unfold R_dist in |- *; intros; exists 0%nat; intros. replace (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k + 1)) - n) with 0. -unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. -induction n as [| n Hrecn]. -simpl in |- *; ring. -rewrite tech5; rewrite <- Hrecn. -simpl in |- *; ring. -unfold ge in |- *; 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 in |- *; unfold R_dist in |- *; intros. + n) with 0. +unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. +induction n as [| n Hrecn]. +simpl in |- *; ring. +rewrite tech5; rewrite <- Hrecn. +simpl in |- *; ring. +unfold ge in |- *; 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 in |- *; unfold R_dist in |- *; intros. cut (0 < eps / Rabs x); [ intro | unfold Rdiv in |- *; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ]. -elim (p (eps / Rabs x) H3); intros. -exists x1; intros. -unfold B1 in |- *. + [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ]. +elim (p (eps / Rabs x) H3); intros. +exists x1; intros. +unfold B1 in |- *. replace (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1)) n) with (x * - sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n). + sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n). replace (x * sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n - x * x0) with (x * (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n - - x0)); [ idtac | ring ]. -rewrite Rabs_mult. -apply Rmult_lt_reg_l with (/ Rabs x). -apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. -rewrite <- Rmult_assoc. -rewrite <- Rinv_l_sym. + x0)); [ idtac | ring ]. +rewrite Rabs_mult. +apply Rmult_lt_reg_l with (/ Rabs x). +apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. +rewrite <- Rmult_assoc. +rewrite <- Rinv_l_sym. rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H4; apply H4; - assumption. -apply Rabs_no_R0; assumption. -rewrite scal_sum. -apply sum_eq. -intros. -rewrite pow_add. -rewrite pow_sqr. -simpl in |- *. -ring. -unfold sin in |- *. -case (exist_sin (Rsqr x)). -unfold Rsqr in |- *; intros. -unfold sin_in in p_i. -unfold sin_in in s. + assumption. +apply Rabs_no_R0; assumption. +rewrite scal_sum. +apply sum_eq. +intros. +rewrite pow_add. +rewrite pow_sqr. +simpl in |- *. +ring. +unfold sin in |- *. +case (exist_sin (Rsqr x)). +unfold Rsqr in |- *; 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. + (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 22a52e67..e037c77b 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: DiscrR.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import RIneq. Require Import Omega. @@ -16,14 +16,7 @@ Lemma Rlt_R0_R2 : 0 < 2. change 2 with (INR 2); apply lt_INR_0; apply lt_O_Sn. Qed. -Lemma Rplus_lt_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x + y. -intros. -apply Rlt_trans with x. -assumption. -pattern x at 1 in |- *; rewrite <- Rplus_0_r. -apply Rplus_lt_compat_l. -assumption. -Qed. +Notation Rplus_lt_pos := Rplus_lt_0_compat (only parsing). Lemma IZR_eq : forall z1 z2:Z, z1 = z2 -> IZR z1 = IZR z2. intros; rewrite H; reflexivity. @@ -63,9 +56,9 @@ Ltac omega_sup := change 0 with (IZR 0); repeat rewrite <- plus_IZR || - rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; + rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; apply IZR_lt; omega. - + Ltac prove_sup := match goal with | |- (?X1 > ?X2) => change (X2 < X1) in |- *; prove_sup @@ -83,5 +76,5 @@ Ltac Rcompute := change 0 with (IZR 0); repeat rewrite <- plus_IZR || - rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; + rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; apply IZR_eq; try reflexivity. diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index bf729526..1c74f55a 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Exp_prop.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -46,7 +46,7 @@ Proof. intros; unfold E1 in |- *. rewrite cauchy_finite. unfold Reste_E in |- *; unfold Rminus in |- *; rewrite Rplus_assoc; - rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq; + rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq; intros. rewrite binomial. rewrite scal_sum; apply sum_eq; intros. @@ -125,7 +125,7 @@ Proof. sum_f_R0 (fun k:nat => sum_f_R0 (fun l:nat => / Rsqr (INR (fact (div2 (S N))))) - (pred (N - k))) (pred N)). + (pred (N - k))) (pred N)). unfold Reste_E in |- *. apply Rle_trans with (sum_f_R0 @@ -473,7 +473,7 @@ Proof. apply lt_n_S; apply H. cut (1 < S N)%nat. intro; unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; intro; - assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4; + assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4; elim (lt_n_O _ H4). apply lt_n_S; apply H. assert (H1 := even_odd_cor N). diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v index d4f3a8ec..774a0bd5 100644 --- a/theories/Reals/Integration.v +++ b/theories/Reals/Integration.v @@ -5,8 +5,8 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - -(*i $Id: Integration.v 5920 2004-07-16 20:01:26Z herbelin $ i*) + +(*i $Id$ i*) Require Export NewtonInt. Require Export RiemannInt_SF. diff --git a/theories/Reals/LegacyRfield.v b/theories/Reals/LegacyRfield.v index 3f76e77a..b33274af 100644 --- a/theories/Reals/LegacyRfield.v +++ b/theories/Reals/LegacyRfield.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: LegacyRfield.v 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id$ i*) Require Export Raxioms. Require Export LegacyField. diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v index f22e49e1..4037e3de 100644 --- a/theories/Reals/MVT.v +++ b/theories/Reals/MVT.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: MVT.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -115,7 +115,7 @@ Proof. (derivable_pt_mult _ _ _ (derivable_pt_const (f b - f a) c) (pr2 c P)))); [ idtac | apply pr_nu ]. rewrite derive_pt_minus; do 2 rewrite derive_pt_mult; - do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l; + do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l; do 2 rewrite Rplus_0_l; reflexivity. unfold h in |- *; ring. intros; unfold h in |- *; @@ -180,7 +180,7 @@ Proof. cut (derive_pt id x (X2 x x0) = 1). cut (derive_pt f x (X0 x x0) = 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 in |- *; + rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry in |- *; assumption. apply derive_pt_eq_0; apply H0; elim x0; intros; split; left; assumption. apply derive_pt_eq_0; apply derivable_pt_lim_id. @@ -258,7 +258,7 @@ Lemma nonpos_derivative_0 : decreasing f -> forall x:R, derive_pt f x (pr x) <= 0. Proof. intros f pr H x; assert (H0 := H); unfold decreasing in H0; - generalize (derivable_derive f x (pr x)); intro; elim H1; + generalize (derivable_derive f x (pr x)); intro; elim H1; intros l H2. rewrite H2; case (Rtotal_order l 0); intro. left; assumption. @@ -282,7 +282,7 @@ Proof. intro. generalize (Ropp_lt_gt_contravar (- ((f (x + delta / 2) + - f x) / (delta / 2))) - (- (l / 2)) H15). + (- (l / 2)) H15). repeat rewrite Ropp_involutive. intro. generalize @@ -432,7 +432,7 @@ Lemma strictincreasing_strictdecreasing_opp : forall f:R -> R, strict_increasing f -> strict_decreasing (- f)%F. Proof. unfold strict_increasing, strict_decreasing, opp_fct in |- *; intros; - generalize (H x y H0); intro; apply Ropp_lt_gt_contravar; + generalize (H x y H0); intro; apply Ropp_lt_gt_contravar; assumption. Qed. @@ -467,14 +467,14 @@ Qed. (**********) Lemma null_derivative_0 : forall (f:R -> R) (pr:derivable f), - constant f -> forall x:R, derive_pt f x (pr x) = 0. + constant f -> forall x:R, derive_pt f x (pr x) = 0. Proof. intros. unfold constant in H. apply derive_pt_eq_0. intros; exists (mkposreal 1 Rlt_0_1); simpl in |- *; intros. rewrite (H x (x + h)); unfold Rminus in |- *; unfold Rdiv in |- *; - rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r; + rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. Qed. @@ -576,7 +576,7 @@ Lemma derive_increasing_interv_var : forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y. Proof. intros a b f pr H H0 x y H1 H2 H3; - generalize (derive_increasing_interv_ax a b f pr H); + generalize (derive_increasing_interv_ax a b f pr H); intro; elim H4; intros _ H5; apply (H5 H0 x y H1 H2 H3). Qed. @@ -618,7 +618,7 @@ Proof. cut (derivable (g - f)). intro X. cut (forall c:R, a <= c <= b -> derive_pt (g - f) c (X c) <= 0). - intro. + intro. assert (H2 := IAF (g - f)%F a b 0 X H H1). rewrite Rmult_0_l in H2; unfold minus_fct in H2. apply Rplus_le_reg_l with (- f b + f a). @@ -697,11 +697,11 @@ Proof. clear H0; intros H0 _; exists (g1 a - g2 a); intros; assert (H3 : forall x:R, a <= x <= b -> derivable_pt g1 x). intros; unfold derivable_pt in |- *; exists (f x0); elim (H x0 H3); - intros; eapply derive_pt_eq_1; symmetry in |- *; + intros; eapply derive_pt_eq_1; symmetry in |- *; apply H4. assert (H4 : forall x:R, a <= x <= b -> derivable_pt g2 x). intros; unfold derivable_pt in |- *; exists (f x0); - elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry in |- *; + elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry in |- *; apply H5. assert (H5 : forall x:R, a < x < b -> derivable_pt (g1 - g2) x). intros; elim H5; intros; apply derivable_pt_minus; @@ -717,6 +717,6 @@ Proof. apply derivable_pt_lim_minus; [ elim (H _ H9) | elim (H0 _ H9) ]; intros; eapply derive_pt_eq_1; symmetry in |- *; apply H10. assert (H8 := null_derivative_loc (g1 - g2)%F a b H5 H6 H7); - unfold constant_D_eq in H8; assert (H9 := H8 _ H2); + unfold constant_D_eq in H8; assert (H9 := H8 _ H2); unfold minus_fct in H9; rewrite <- H9; ring. Qed. diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v index 47ae149e..74bcf7dc 100644 --- a/theories/Reals/NewtonInt.v +++ b/theories/Reals/NewtonInt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: NewtonInt.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -31,7 +31,7 @@ Lemma FTCN_step1 : Newton_integrable (fun x:R => derive_pt f x (cond_diff f x)) a b. Proof. intros f a b; unfold Newton_integrable in |- *; exists (d1 f); - unfold antiderivative in |- *; intros; case (Rle_dec a b); + unfold antiderivative in |- *; intros; case (Rle_dec a b); intro; [ left; split; [ intros; exists (cond_diff f x); reflexivity | assumption ] | right; split; @@ -229,15 +229,15 @@ 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 in |- *; - case (NewtonInt_P5 f g l a b pr1 pr2); intros; case pr1; - intros; case pr2; intros; case (total_order_T a b); + 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. elim o; intro. elim o0; intro. elim o1; intro. assert (H2 := antiderivative_P1 f g x0 x1 l a b H0 H1); - assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); + assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); elim H3; intros; assert (H5 : a <= a <= b). split; [ right; reflexivity | left; assumption ]. assert (H6 : a <= b <= b). @@ -260,7 +260,7 @@ Proof. unfold antiderivative in H1; elim H1; intros; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 r)). assert (H2 := antiderivative_P1 f g x0 x1 l b a H0 H1); - assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); + assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); elim H3; intros; assert (H5 : b <= a <= a). split; [ left; assumption | right; reflexivity ]. assert (H6 : b <= b <= a). @@ -313,7 +313,7 @@ Proof. 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 in |- *; + rewrite Rplus_0_l; rewrite Rplus_comm; unfold D in |- *; apply Rmin_r. elim n; left; assumption. assert @@ -396,7 +396,7 @@ Proof. 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); - [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b); + [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b); [ idtac | ring ]; apply Rle_lt_trans with (Rabs h). rewrite <- Rabs_Ropp; apply RRle_abs. apply Rlt_le_trans with D. diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v index e122a26a..97793386 100644 --- a/theories/Reals/PSeries_reg.v +++ b/theories/Reals/PSeries_reg.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PSeries_reg.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -19,13 +19,13 @@ Open Local Scope R_scope. Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r. (** Uniform convergence *) -Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R) +Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R) (r:posreal) : Prop := forall eps:R, 0 < eps -> exists N : nat, (forall (n:nat) (y:R), - (N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps). + (N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps). (** Normal convergence *) Definition CVN_r (fn:nat -> R -> R) (r:posreal) : Type := @@ -37,7 +37,7 @@ Definition CVN_r (fn:nat -> R -> R) (r:posreal) : Type := Definition CVN_R (fn:nat -> R -> R) : Type := forall r:posreal, CVN_r fn r. Definition SFL (fn:nat -> R -> R) - (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }) + (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }) (y:R) : R := let (a,_) := cv y in a. (** In a complete space, normal convergence implies uniform convergence *) @@ -94,7 +94,7 @@ Lemma CVU_continuity : forall y:R, Boule x r y -> continuity_pt f y. Proof. intros; unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; intros. unfold CVU in H. cut (0 < eps / 3); @@ -219,11 +219,11 @@ Proof. intros; apply (H n y). apply H1. unfold Boule in |- *; simpl in |- *; rewrite Rminus_0_r; - pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; + pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1. Qed. -(** As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *) +(** As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *) Lemma CVN_R_CVS : forall fn:nat -> R -> R, CVN_R fn -> forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }. @@ -256,7 +256,7 @@ Proof. intro; apply Rle_trans with (Rabs (An n)). apply Rabs_pos. unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *; - rewrite Rminus_0_r; pattern (Rabs x) at 1 in |- *; + rewrite Rminus_0_r; pattern (Rabs x) at 1 in |- *; 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. diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v index d5ae2aca..6a33b809 100644 --- a/theories/Reals/PartSum.v +++ b/theories/Reals/PartSum.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PartSum.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -31,7 +31,7 @@ Lemma tech2 : forall (An:nat -> R) (m n:nat), (m < n)%nat -> sum_f_R0 An n = - sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m). + sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m). Proof. intros; induction n as [| n Hrecn]. elim (lt_n_O _ H). @@ -155,7 +155,7 @@ Lemma tech12 : Proof. intros; unfold Pser in |- *; unfold infinite_sum in |- *; unfold Un_cv in H; assumption. -Qed. +Qed. Lemma scal_sum : forall (An:nat -> R) (N:nat) (x:R), @@ -256,12 +256,12 @@ Qed. Lemma minus_sum : forall (An Bn:nat -> R) (N:nat), - sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N. + sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N. Proof. - intros; induction N as [| N HrecN]. - simpl in |- *; ring. - do 3 rewrite tech5; rewrite HrecN; ring. -Qed. + intros; induction N as [| N HrecN]. + simpl in |- *; ring. + do 3 rewrite tech5; rewrite HrecN; ring. +Qed. Lemma sum_decomposition : forall (An:nat -> R) (N:nat), @@ -346,7 +346,7 @@ Qed. (**********) Lemma Rabs_triang_gen : forall (An:nat -> R) (N:nat), - Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N. + Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N. Proof. intros. induction N as [| N HrecN]. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index c07b86a6..2b6af10e 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* 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 3. Qed. Hint Resolve Req_dec: real. @@ -129,7 +130,7 @@ Hint Immediate Rge_le: rorders. (**********) Lemma Rlt_gt : forall r1 r2, r1 < r2 -> r2 > r1. -Proof. +Proof. trivial. Qed. Hint Resolve Rlt_gt: rorders. @@ -291,7 +292,7 @@ Proof. eauto using Rlt_trans with rorders. Qed. (**********) Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3. Proof. - generalize Rlt_trans Rlt_eq_compat. + generalize Rlt_trans Rlt_eq_compat. unfold Rle in |- *. intuition eauto 2. Qed. @@ -456,7 +457,7 @@ Proof. rewrite Rplus_comm; auto with real. Qed. -(*********************************************************) +(*********************************************************) (** ** Multiplication *) (*********************************************************) @@ -515,6 +516,13 @@ Qed. (*i Old i*)Hint Resolve Rmult_eq_compat_l: v62. +Lemma Rmult_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 * r = r2 * r. +Proof. + intros. + rewrite <- 2!(Rmult_comm r). + now apply Rmult_eq_compat_l. +Qed. + (**********) Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 = r * r2 -> r <> 0 -> r1 = r2. Proof. @@ -525,6 +533,13 @@ Proof. field; trivial. Qed. +Lemma Rmult_eq_reg_r : forall r r1 r2, r1 * r = r2 * r -> r <> 0 -> r1 = r2. +Proof. + intros. + apply Rmult_eq_reg_l with (2 := H0). + now rewrite 2!(Rmult_comm r). +Qed. + (**********) Lemma Rmult_integral : forall r1 r2, r1 * r2 = 0 -> r1 = 0 \/ r2 = 0. Proof. @@ -554,13 +569,13 @@ Proof. auto with real. Qed. -(**********) +(**********) Lemma Rmult_neq_0_reg : forall r1 r2, r1 * r2 <> 0 -> r1 <> 0 /\ r2 <> 0. Proof. intros r1 r2 H; split; red in |- *; intro; apply H; auto with real. Qed. -(**********) +(**********) Lemma Rmult_integral_contrapositive : forall r1 r2, r1 <> 0 /\ r2 <> 0 -> r1 * r2 <> 0. Proof. @@ -569,11 +584,11 @@ Proof. Qed. Hint Resolve Rmult_integral_contrapositive: real. -Lemma Rmult_integral_contrapositive_currified : +Lemma Rmult_integral_contrapositive_currified : forall r1 r2, r1 <> 0 -> r2 <> 0 -> r1 * r2 <> 0. Proof. auto using Rmult_integral_contrapositive. Qed. -(**********) +(**********) Lemma Rmult_plus_distr_r : forall r1 r2 r3, (r1 + r2) * r3 = r1 * r3 + r2 * r3. Proof. @@ -743,7 +758,7 @@ Lemma Rminus_not_eq_right : forall r1 r2, r2 - r1 <> 0 -> r1 <> r2. Proof. red in |- *; intros; elim H; rewrite H0; ring. Qed. -Hint Resolve Rminus_not_eq_right: real. +Hint Resolve Rminus_not_eq_right: real. (**********) Lemma Rmult_minus_distr_l : @@ -973,6 +988,13 @@ Proof. right; apply (Rplus_eq_reg_l r r1 r2 H0). Qed. +Lemma Rplus_le_reg_r : forall r r1 r2, r1 + r <= r2 + r -> r1 <= r2. +Proof. + intros. + apply (Rplus_le_reg_l r). + now rewrite 2!(Rplus_comm r). +Qed. + Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2. Proof. unfold Rgt in |- *; intros; apply (Rplus_lt_reg_r r r2 r1 H). @@ -1261,12 +1283,20 @@ Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. Proof. intros z x y H H0. case (Rtotal_order x y); intros Eq0; auto; elim Eq0; clear Eq0; intros Eq0. - rewrite Eq0 in H0; elimtype False; apply (Rlt_irrefl (z * y)); auto. - generalize (Rmult_lt_compat_l z y x H Eq0); intro; elimtype False; - generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1); + rewrite Eq0 in H0; exfalso; apply (Rlt_irrefl (z * y)); auto. + generalize (Rmult_lt_compat_l z y x H Eq0); intro; exfalso; + generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1); intro; apply (Rlt_irrefl (z * x)); auto. Qed. +Lemma Rmult_lt_reg_r : forall r r1 r2 : R, 0 < r -> r1 * r < r2 * r -> r1 < r2. +Proof. + intros. + apply Rmult_lt_reg_l with r. + exact H. + now rewrite 2!(Rmult_comm r). +Qed. + Lemma Rmult_gt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. Proof. eauto using Rmult_lt_reg_l with rorders. Qed. @@ -1282,6 +1312,14 @@ Proof. rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. Qed. +Lemma Rmult_le_reg_r : forall r r1 r2, 0 < r -> r1 * r <= r2 * r -> r1 <= r2. +Proof. + intros. + apply Rmult_le_reg_l with r. + exact H. + now rewrite 2!(Rmult_comm r). +Qed. + (*********************************************************) (** ** Order and substraction *) (*********************************************************) @@ -1296,7 +1334,7 @@ Qed. Hint Resolve Rlt_minus: real. Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0. -Proof. +Proof. intros; apply (Rplus_lt_reg_r r2). replace (r2 + (r1 - r2)) with r1. replace (r2 + 0) with r2; auto with real. @@ -1310,7 +1348,7 @@ Proof. Qed. Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0. -Proof. +Proof. destruct 1. auto using Rgt_minus, Rgt_ge. right; auto using Rminus_diag_eq with rorders. @@ -1463,7 +1501,7 @@ Proof. Qed. Hint Resolve Rinv_1_lt_contravar: real. -(*********************************************************) +(*********************************************************) (** ** Miscellaneous *) (*********************************************************) @@ -1491,7 +1529,7 @@ Proof. pattern r1 at 2 in |- *; replace r1 with (r1 + 0); auto with real. Qed. -(*********************************************************) +(*********************************************************) (** ** Injection from [N] to [R] *) (*********************************************************) @@ -1508,7 +1546,7 @@ Proof. Qed. (**********) -Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m. +Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m. Proof. intros n m; induction n as [| n Hrecn]. simpl in |- *; auto with real. @@ -1581,11 +1619,11 @@ Hint Resolve pos_INR: real. Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat. Proof. double induction n m; intros. - simpl in |- *; elimtype False; apply (Rlt_irrefl 0); auto. + simpl in |- *; exfalso; apply (Rlt_irrefl 0); auto. auto with arith. generalize (pos_INR (S n0)); intro; cut (INR 0 = 0); - [ intro H2; rewrite H2 in H0; idtac | simpl in |- *; trivial ]. - generalize (Rle_lt_trans 0 (INR (S n0)) 0 H1 H0); intro; elimtype False; + [ intro H2; rewrite H2 in H0; idtac | simpl in |- *; trivial ]. + generalize (Rle_lt_trans 0 (INR (S n0)) 0 H1 H0); intro; exfalso; 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. @@ -1627,7 +1665,7 @@ Proof. intros n m H; case (le_or_lt n m); intros H1. case (le_lt_or_eq _ _ H1); intros H2. apply Rlt_dichotomy_converse; auto with real. - elimtype False; auto. + exfalso; auto. apply sym_not_eq; apply Rlt_dichotomy_converse; auto with real. Qed. Hint Resolve not_INR: real. @@ -1637,10 +1675,10 @@ Proof. intros; case (le_or_lt n m); intros H1. case (le_lt_or_eq _ _ H1); intros H2; auto. cut (n <> m). - intro H3; generalize (not_INR n m H3); intro H4; elimtype False; auto. + intro H3; generalize (not_INR n m H3); intro H4; exfalso; auto. omega. symmetry in |- *; cut (m <> n). - intro H3; generalize (not_INR m n H3); intro H4; elimtype False; auto. + intro H3; generalize (not_INR m n H3); intro H4; exfalso; auto. omega. Qed. Hint Resolve INR_eq: real. @@ -1659,7 +1697,7 @@ Proof. Qed. Hint Resolve not_1_INR: real. -(*********************************************************) +(*********************************************************) (** ** Injection from [Z] to [R] *) (*********************************************************) @@ -1741,17 +1779,26 @@ Proof. Qed. (**********) -Lemma Ropp_Ropp_IZR : forall n:Z, IZR (- n) = - IZR n. +Lemma opp_IZR : forall n:Z, IZR (- n) = - IZR n. Proof. intro z; case z; simpl in |- *; auto with real. Qed. +Definition Ropp_Ropp_IZR := opp_IZR. + +Lemma minus_IZR : forall n m:Z, IZR (n - m) = IZR n - IZR m. +Proof. + intros; unfold Zminus, Rminus. + rewrite <- opp_IZR. + apply plus_IZR. +Qed. + (**********) Lemma Z_R_minus : forall n m:Z, IZR n - IZR m = IZR (n - m). Proof. intros z1 z2; unfold Rminus in |- *; unfold Zminus in |- *. rewrite <- (Ropp_Ropp_IZR z2); symmetry in |- *; apply plus_IZR. -Qed. +Qed. (**********) Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. @@ -1766,7 +1813,7 @@ Qed. (**********) Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z. Proof. - intros z1 z2 H; apply Zlt_0_minus_lt. + intros z1 z2 H; apply Zlt_0_minus_lt. apply lt_0_IZR. rewrite <- Z_R_minus. exact (Rgt_minus (IZR z2) (IZR z1) H). @@ -1785,7 +1832,7 @@ Qed. Lemma eq_IZR : forall n m:Z, IZR n = IZR m -> n = m. Proof. intros z1 z2 H; generalize (Rminus_diag_eq (IZR z1) (IZR z2) H); - rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0); + rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0); intro; omega. Qed. @@ -1837,7 +1884,7 @@ Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m. Proof. intros m n H; cut (m <= n)%Z. intro H0; elim (IZR_le m n H0); intro; auto. - generalize (eq_IZR m n H1); intro; elimtype False; omega. + generalize (eq_IZR m n H1); intro; exfalso; omega. omega. Qed. @@ -1935,7 +1982,7 @@ Proof. rewrite <- Rinv_l_sym. rewrite Rmult_1_r; replace (2 * x) with (x + x). rewrite (Rplus_comm y); intro H5; apply Rplus_le_reg_l with x; assumption. - ring. + ring. replace 2 with (INR 2); [ apply not_0_INR; discriminate | reflexivity ]. pattern y at 2 in |- *; replace y with (y / 2 + y / 2). unfold Rminus, Rdiv in |- *. diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v index 19f2b4ff..545bd68b 100644 --- a/theories/Reals/RList.v +++ b/theories/Reals/RList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RList.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -16,7 +16,7 @@ Inductive Rlist : Type := | nil : Rlist | cons : R -> Rlist -> Rlist. -Fixpoint In (x:R) (l:Rlist) {struct l} : Prop := +Fixpoint In (x:R) (l:Rlist) : Prop := match l with | nil => False | cons a l' => x = a \/ In x l' @@ -70,7 +70,7 @@ Proof. reflexivity. Qed. -Fixpoint AbsList (l:Rlist) (x:R) {struct l} : Rlist := +Fixpoint AbsList (l:Rlist) (x:R) : Rlist := match l with | nil => nil | cons a l' => cons (Rabs (a - x) / 2) (AbsList l' x) @@ -144,13 +144,13 @@ Proof. induction l as [| r0 l Hrecl0]. simpl in |- *; left; reflexivity. change (In (Rmax r (MaxRlist (cons r0 l))) (cons r (cons r0 l))) in |- *; - unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); + unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); intro. right; apply Hrecl; exists r0; left; reflexivity. left; reflexivity. Qed. -Fixpoint pos_Rl (l:Rlist) (i:nat) {struct l} : R := +Fixpoint pos_Rl (l:Rlist) (i:nat) : R := match l with | nil => 0 | cons a l' => match i with @@ -221,7 +221,7 @@ Qed. Definition ordered_Rlist (l:Rlist) : Prop := forall i:nat, (i < pred (Rlength l))%nat -> pos_Rl l i <= pos_Rl l (S i). -Fixpoint insert (l:Rlist) (x:R) {struct l} : Rlist := +Fixpoint insert (l:Rlist) (x:R) : Rlist := match l with | nil => cons x nil | cons a l' => @@ -231,25 +231,25 @@ Fixpoint insert (l:Rlist) (x:R) {struct l} : Rlist := end end. -Fixpoint cons_Rlist (l k:Rlist) {struct l} : Rlist := +Fixpoint cons_Rlist (l k:Rlist) : Rlist := match l with | nil => k | cons a l' => cons a (cons_Rlist l' k) end. -Fixpoint cons_ORlist (k l:Rlist) {struct k} : Rlist := +Fixpoint cons_ORlist (k l:Rlist) : Rlist := match k with | nil => l | cons a k' => cons_ORlist k' (insert l a) end. -Fixpoint app_Rlist (l:Rlist) (f:R -> R) {struct l} : Rlist := +Fixpoint app_Rlist (l:Rlist) (f:R -> R) : Rlist := match l with | nil => nil | cons a l' => cons (f a) (app_Rlist l' f) end. -Fixpoint mid_Rlist (l:Rlist) (x:R) {struct l} : Rlist := +Fixpoint mid_Rlist (l:Rlist) (x:R) : Rlist := match l with | nil => nil | cons a l' => cons ((x + a) / 2) (mid_Rlist l' a) @@ -395,8 +395,8 @@ Lemma RList_P7 : ordered_Rlist l -> In x l -> x <= pos_Rl l (pred (Rlength l)). Proof. intros; assert (H1 := RList_P6 l); elim H1; intros H2 _; assert (H3 := H2 H); - clear H1 H2; assert (H1 := RList_P3 l x); elim H1; - clear H1; intros; assert (H4 := H1 H0); elim H4; clear H4; + clear H1 H2; assert (H1 := RList_P3 l x); elim H1; + clear H1; intros; assert (H4 := H1 H0); elim H4; clear H4; intros; elim H4; clear H4; intros; rewrite H4; assert (H6 : Rlength l = S (pred (Rlength l))). apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro; @@ -468,7 +468,7 @@ Proof. simple induction l1; [ intro; reflexivity | intros; simpl in |- *; rewrite (H (insert l2 r)); rewrite RList_P10; - apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; + apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; rewrite S_INR; ring ]. Qed. @@ -495,7 +495,7 @@ Proof. reflexivity. change (pos_Rl (mid_Rlist (cons r1 r2) r) (S i) = - (pos_Rl (cons r1 r2) i + pos_Rl (cons r1 r2) (S i)) / 2) + (pos_Rl (cons r1 r2) i + pos_Rl (cons r1 r2) (S i)) / 2) in |- *; apply H0; simpl in |- *; apply lt_S_n; assumption. Qed. @@ -528,7 +528,7 @@ Proof. In (pos_Rl (cons_ORlist (cons r l1) l2) 0) (cons_ORlist (cons r l1) l2)); [ elim (RList_P3 (cons_ORlist (cons r l1) l2) - (pos_Rl (cons_ORlist (cons r l1) l2) 0)); + (pos_Rl (cons_ORlist (cons r l1) l2) 0)); intros; apply H3; exists 0%nat; split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ] | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons_ORlist (cons r l1) l2) 0)); @@ -547,7 +547,7 @@ Lemma RList_P16 : Proof. intros; apply Rle_antisym. induction l1 as [| r l1 Hrecl1]. - simpl in |- *; simpl in H1; right; symmetry in |- *; assumption. + simpl in |- *; simpl in H1; right; symmetry in |- *; assumption. assert (H2 : In @@ -557,13 +557,13 @@ Proof. [ elim (RList_P3 (cons_ORlist (cons r l1) l2) (pos_Rl (cons_ORlist (cons r l1) l2) - (pred (Rlength (cons_ORlist (cons r l1) l2))))); + (pred (Rlength (cons_ORlist (cons r l1) l2))))); intros; apply H3; exists (pred (Rlength (cons_ORlist (cons r l1) l2))); split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ] | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons_ORlist (cons r l1) l2) - (pred (Rlength (cons_ORlist (cons r l1) l2))))); + (pred (Rlength (cons_ORlist (cons r l1) l2))))); intros; assert (H5 := H3 H2); elim H5; intro; [ apply RList_P7; assumption | rewrite H1; apply RList_P7; assumption ] ]. induction l1 as [| r l1 Hrecl1]. @@ -576,19 +576,19 @@ Proof. In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) (cons r l1) \/ In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) l2); [ left; change (In (pos_Rl (cons r l1) (Rlength l1)) (cons r l1)) in |- *; - elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (Rlength l1))); + elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (Rlength l1))); intros; apply H5; exists (Rlength l1); split; [ reflexivity | simpl in |- *; apply lt_n_Sn ] | assert (H5 := H3 H4); apply RList_P7; [ apply RList_P2; assumption | elim (RList_P9 (cons r l1) l2 - (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); + (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); intros; apply H7; left; elim (RList_P3 (cons r l1) - (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); - intros; apply H9; exists (pred (Rlength (cons r l1))); + (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); + intros; apply H9; exists (pred (Rlength (cons r l1))); split; [ reflexivity | simpl in |- *; apply lt_n_Sn ] ] ]. Qed. @@ -643,7 +643,7 @@ Lemma RList_P20 : forall l:Rlist, (2 <= Rlength l)%nat -> exists r : R, - (exists r1 : R, (exists l' : Rlist, l = cons r (cons r1 l'))). + (exists r1 : R, (exists l' : Rlist, l = cons r (cons r1 l'))). Proof. intros; induction l as [| r l Hrecl]; [ simpl in H; elim (le_Sn_O _ H) @@ -720,7 +720,7 @@ Proof. simpl in |- *; apply (H1 0%nat); simpl in |- *; apply lt_O_Sn. change (pos_Rl (cons_Rlist (cons r1 r2) l2) i <= - pos_Rl (cons_Rlist (cons r1 r2) l2) (S i)) in |- *; + pos_Rl (cons_Rlist (cons r1 r2) l2) (S i)) in |- *; apply (H i); simpl in |- *; apply lt_S_n; assumption. Qed. diff --git a/theories/Reals/ROrderedType.v b/theories/Reals/ROrderedType.v new file mode 100644 index 00000000..2b302386 --- /dev/null +++ b/theories/Reals/ROrderedType.v @@ -0,0 +1,95 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* r2}. +Proof. + intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse; + intuition eauto 3. +Qed. + +Definition Reqb r1 r2 := if Req_dec r1 r2 then true else false. +Lemma Reqb_eq : forall r1 r2, Reqb r1 r2 = true <-> r1=r2. +Proof. + intros; unfold Reqb; destruct Req_dec as [EQ|NEQ]; auto with *. + split; try discriminate. intro EQ; elim NEQ; auto. +Qed. + +Module R_as_UBE <: UsualBoolEq. + Definition t := R. + Definition eq := @eq R. + Definition eqb := Reqb. + Definition eqb_eq := Reqb_eq. +End R_as_UBE. + +Module R_as_DT <: UsualDecidableTypeFull := Make_UDTF R_as_UBE. + +(** Note that the last module fulfills by subtyping many other + interfaces, such as [DecidableType] or [EqualityType]. *) + + + +(** Note that [R_as_DT] can also be seen as a [DecidableType] + and a [DecidableTypeOrig]. *) + + + +(** * OrderedType structure for binary integers *) + + + +Definition Rcompare x y := + match total_order_T x y with + | inleft (left _) => Lt + | inleft (right _) => Eq + | inright _ => Gt + end. + +Lemma Rcompare_spec : forall x y, CompSpec eq Rlt x y (Rcompare x y). +Proof. + intros. unfold Rcompare. + destruct total_order_T as [[H|H]|H]; auto. +Qed. + +Module R_as_OT <: OrderedTypeFull. + Include R_as_DT. + Definition lt := Rlt. + Definition le := Rle. + Definition compare := Rcompare. + + Instance lt_strorder : StrictOrder Rlt. + Proof. split; [ exact Rlt_irrefl | exact Rlt_trans ]. Qed. + + Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) Rlt. + Proof. repeat red; intros; subst; auto. Qed. + + Lemma le_lteq : forall x y, x <= y <-> x < y \/ x = y. + Proof. unfold Rle; auto with *. Qed. + + Definition compare_spec := Rcompare_spec. + +End R_as_OT. + +(** Note that [R_as_OT] can also be seen as a [UsualOrderedType] + and a [OrderedType] (and also as a [DecidableType]). *) + + + +(** * An [order] tactic for real numbers *) + +Module ROrder := OTF_to_OrderTac R_as_OT. +Ltac r_order := ROrder.order. + +(** Note that [r_order] is domain-agnostic: it will not prove + [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) + diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index 82d7bebd..57b2c767 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: R_Ifp.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) (**********************************************************) (** Complements for the reals.Integer and fractional part *) @@ -32,10 +32,10 @@ Lemma tech_up : forall (r:R) (z:Z), r < IZR z -> IZR z <= r + 1 -> z = up r. Proof. intros; generalize (archimed r); intro; elim H1; intros; clear H1; unfold Rgt in H2; unfold Rminus in H3; - generalize (Rplus_le_compat_l r (IZR (up r) + - r) 1 H3); + generalize (Rplus_le_compat_l r (IZR (up r) + - r) 1 H3); intro; clear H3; rewrite (Rplus_comm (IZR (up r)) (- r)) in H1; rewrite <- (Rplus_assoc r (- r) (IZR (up r))) in H1; - rewrite (Rplus_opp_r r) in H1; elim (Rplus_ne (IZR (up r))); + rewrite (Rplus_opp_r r) in H1; elim (Rplus_ne (IZR (up r))); intros a b; rewrite b in H1; clear a b; apply (single_z_r_R1 r z (up r)); auto with zarith real. Qed. @@ -56,15 +56,15 @@ Qed. Lemma fp_R0 : frac_part 0 = 0. Proof. unfold frac_part in |- *; unfold Int_part in |- *; elim (archimed 0); intros; - unfold Rminus in |- *; elim (Rplus_ne (- IZR (up 0 - 1))); - intros a b; rewrite b; clear a b; rewrite <- Z_R_minus; + unfold Rminus in |- *; elim (Rplus_ne (- IZR (up 0 - 1))); + intros a b; rewrite b; clear a b; rewrite <- Z_R_minus; cut (up 0 = 1%Z). intro; rewrite H1; - rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (refl_equal (IZR 1))); - apply Ropp_0. + rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (refl_equal (IZR 1))); + apply Ropp_0. elim (archimed 0); intros; clear H2; unfold Rgt in H1; rewrite (Rminus_0_r (IZR (up 0))) in H0; generalize (lt_O_IZR (up 0) H1); - intro; clear H1; generalize (le_IZR_R1 (up 0) H0); + intro; clear H1; generalize (le_IZR_R1 (up 0) H0); intro; clear H H0; omega. Qed. @@ -92,12 +92,12 @@ Proof. apply Rge_minus; auto with zarith real. rewrite <- Ropp_minus_distr; apply Ropp_le_ge_contravar; elim (for_base_fp r); auto with zarith real. - (*inf a 1*) + (*inf a 1*) cut (r - IZR (up r) < 0). rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; - fold (r - IZR (up r)) in |- *; rewrite Ropp_involutive; - elim (Rplus_ne 1); intros a b; pattern 1 at 2 in |- *; + fold (r - IZR (up r)) in |- *; rewrite Ropp_involutive; + elim (Rplus_ne 1); intros a b; pattern 1 at 2 in |- *; rewrite <- a; clear a b; rewrite (Rplus_comm (r - IZR (up r)) 1); apply Rplus_lt_compat_l; auto with zarith real. elim (for_base_fp r); intros; rewrite <- Ropp_0; rewrite <- Ropp_minus_distr; @@ -110,7 +110,7 @@ Qed. (**********) Lemma base_Int_part : - forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1. + forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1. Proof. intro; unfold Int_part in |- *; elim (archimed r); intros. split; rewrite <- (Z_R_minus (up r) 1); simpl in |- *. @@ -122,13 +122,13 @@ Proof. apply Rminus_le; auto with zarith real. generalize (Rplus_gt_compat_l (-1) (IZR (up r)) r H); intro; rewrite (Rplus_comm (-1) (IZR (up r))) in H1; - generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1); + generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1); intro; clear H H0 H1; rewrite (Rplus_comm (- r) (IZR (up r) + -1)) in H2; fold (IZR (up r) - 1) in H2; fold (IZR (up r) - 1 - r) in H2; rewrite (Rplus_comm (- r) (-1 + r)) in H2; rewrite (Rplus_assoc (-1) r (- r)) in H2; rewrite (Rplus_opp_r r) in H2; - elim (Rplus_ne (-1)); intros a b; rewrite a in H2; - clear a b; auto with zarith real. + elim (Rplus_ne (-1)); intros a b; rewrite a in H2; + clear a b; auto with zarith real. Qed. (**********) @@ -168,19 +168,19 @@ Lemma Rminus_Int_part1 : Proof. intros; elim (base_fp r1); elim (base_fp r2); intros; generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0; - generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); + generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); intro; clear H4; rewrite Ropp_0 in H0; - generalize (Rge_le 0 (- frac_part r2) H0); intro; - clear H0; generalize (Rge_le (frac_part r1) 0 H2); + generalize (Rge_le 0 (- frac_part r2) H0); intro; + clear H0; generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1); intro; clear H1; unfold Rgt in H2; generalize (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4); - intro; elim H1; intros; clear H1; elim (Rplus_ne 1); + intro; elim H1; intros; clear H1; elim (Rplus_ne 1); intros a b; rewrite a in H6; clear a b H5; - generalize (Rge_minus (frac_part r1) (frac_part r2) H); + generalize (Rge_minus (frac_part r1) (frac_part r2) H); intro; clear H; fold (frac_part r1 - frac_part r2) in H6; - generalize (Rge_le (frac_part r1 - frac_part r2) 0 H1); + generalize (Rge_le (frac_part r1 - frac_part r2) 0 H1); intro; clear H1 H3 H4 H0 H2; unfold frac_part in H6, H; unfold Rminus in H6, H; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H; @@ -195,7 +195,7 @@ Proof. fold (r1 - r2) in H; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H; generalize (Rplus_le_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) 0 - (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H); + (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H); intro; clear H; rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0; rewrite <- @@ -209,9 +209,9 @@ Proof. (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2)) (- IZR (Int_part r1))) in H0; rewrite (Rplus_opp_l (IZR (Int_part r2))) in H0; - elim (Rplus_ne (- IZR (Int_part r1))); intros a b; + elim (Rplus_ne (- IZR (Int_part r1))); intros a b; rewrite b in H0; clear a b; - elim (Rplus_ne (IZR (Int_part r1) + - IZR (Int_part r2))); + elim (Rplus_ne (IZR (Int_part r1) + - IZR (Int_part r2))); intros a b; rewrite a in H0; clear a b; rewrite (Rplus_opp_r (IZR (Int_part r1))) in H0; elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; clear a b; @@ -229,7 +229,7 @@ Proof. fold (r1 - r2) in H6; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H6; generalize (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) - (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 1 H6); + (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 1 H6); intro; clear H6; rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H; rewrite <- @@ -238,14 +238,14 @@ Proof. in H; rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H; rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H; - elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; + elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0; - rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; + rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; cut (1 = IZR 1); auto with zarith real. intro; rewrite H1 in H; clear H1; rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H; - generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); - intros; clear H H0; unfold Int_part at 1 in |- *; + generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); + intros; clear H H0; unfold Int_part at 1 in |- *; omega. Qed. @@ -257,18 +257,18 @@ Lemma Rminus_Int_part2 : Proof. intros; elim (base_fp r1); elim (base_fp r2); intros; generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0; - generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); + generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); intro; clear H4; rewrite Ropp_0 in H0; - generalize (Rge_le 0 (- frac_part r2) H0); intro; - clear H0; generalize (Rge_le (frac_part r1) 0 H2); + generalize (Rge_le 0 (- frac_part r2) H0); intro; + clear H0; generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1); intro; clear H1; unfold Rgt in H2; generalize (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4); - intro; elim H1; intros; clear H1; elim (Rplus_ne (-1)); + intro; elim H1; intros; clear H1; elim (Rplus_ne (-1)); intros a b; rewrite b in H5; clear a b H6; - generalize (Rlt_minus (frac_part r1) (frac_part r2) H); - intro; clear H; fold (frac_part r1 - frac_part r2) in H5; + generalize (Rlt_minus (frac_part r1) (frac_part r2) H); + intro; clear H; fold (frac_part r1 - frac_part r2) in H5; clear H3 H4 H0 H2; unfold frac_part in H5, H1; unfold Rminus in H5, H1; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H5; rewrite (Ropp_involutive (IZR (Int_part r2))) in H5; @@ -283,7 +283,7 @@ Proof. fold (r1 - r2) in H5; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H5; generalize (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) (-1) - (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H5); + (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H5); intro; clear H5; rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H; rewrite <- @@ -297,9 +297,9 @@ Proof. (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2)) (- IZR (Int_part r1))) in H; rewrite (Rplus_opp_l (IZR (Int_part r2))) in H; - elim (Rplus_ne (- IZR (Int_part r1))); intros a b; + elim (Rplus_ne (- IZR (Int_part r1))); intros a b; rewrite b in H; clear a b; rewrite (Rplus_opp_r (IZR (Int_part r1))) in H; - elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; + elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; clear a b; fold (IZR (Int_part r1) - IZR (Int_part r2)) in H; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H1; @@ -315,7 +315,7 @@ Proof. fold (r1 - r2) in H1; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H1; generalize (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) - (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 0 H1); + (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 0 H1); intro; clear H1; rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0; rewrite <- @@ -324,21 +324,21 @@ Proof. in H0; rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0; - elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; + elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; clear a b; rewrite <- (Rplus_opp_l 1) in H0; rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1) in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0; - rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; + rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; cut (1 = IZR 1); auto with zarith real. intro; rewrite H1 in H; rewrite H1 in H0; clear H1; rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H; rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0; rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0; - generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H); + generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H); intro; clear H; - generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0); - intros; clear H0 H1; unfold Int_part at 1 in |- *; + generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0); + intros; clear H0 H1; unfold Int_part at 1 in |- *; omega. Qed. @@ -358,7 +358,7 @@ Proof. rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2))); rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))); rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2))); - rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); + rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); auto with zarith real. Qed. @@ -370,7 +370,7 @@ Lemma Rminus_fp2 : Proof. intros; unfold frac_part in |- *; generalize (Rminus_Int_part2 r1 r2 H); intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1 - Int_part r2) 1); - rewrite <- (Z_R_minus (Int_part r1) (Int_part r2)); + rewrite <- (Z_R_minus (Int_part r1) (Int_part r2)); unfold Rminus in |- *; rewrite (Ropp_plus_distr (IZR (Int_part r1) + - IZR (Int_part r2)) (- IZR 1)) @@ -385,7 +385,7 @@ Proof. rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2))); rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))); rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2))); - rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); + rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); auto with zarith real. Qed. @@ -397,11 +397,11 @@ Lemma plus_Int_part1 : Proof. intros; generalize (Rge_le (frac_part r1 + frac_part r2) 1 H); intro; clear H; elim (base_fp r1); elim (base_fp r2); intros; clear H H2; - generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3); - intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1); + generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3); + intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1); intro; clear H1; rewrite (Rplus_comm 1 (frac_part r2)) in H2; generalize - (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2); + (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2); intro; clear H H2; rewrite (Rplus_comm (frac_part r2) (frac_part r1)) in H1; unfold frac_part in H0, H1; unfold Rminus in H0, H1; rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2))) @@ -422,11 +422,11 @@ Proof. rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0; generalize (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 1 - (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0); + (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0); intro; clear H0; generalize (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) - (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1); + (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1); intro; clear H1; rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2)))) in H; @@ -434,7 +434,7 @@ Proof. (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2)) in H; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H; - elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H; + elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H; clear a b; rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2)))) in H0; @@ -442,7 +442,7 @@ Proof. (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2)) in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0; - elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; + elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; clear a b; rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0; cut (1 = IZR 1); auto with zarith real. @@ -452,7 +452,7 @@ Proof. rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0; rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0; - generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0); + generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0); intro; clear H H0; unfold Int_part at 1 in |- *; omega. Qed. @@ -465,8 +465,8 @@ Proof. intros; elim (base_fp r1); elim (base_fp r2); intros; clear H1 H3; generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0; generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2; - generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1); - intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b; + generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1); + intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b; rewrite a in H2; clear a b; generalize (Rle_trans 0 (frac_part r1) (frac_part r1 + frac_part r2) H0 H2); intro; clear H0 H2; unfold frac_part in H, H1; unfold Rminus in H, H1; @@ -487,11 +487,11 @@ Proof. rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H; generalize (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 0 - (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1); + (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1); intro; clear H1; generalize (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) - (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H); + (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H); intro; clear H; rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2)))) in H1; @@ -499,7 +499,7 @@ Proof. (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2)) in H1; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H1; - elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1; + elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1; clear a b; rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2)))) in H0; @@ -507,7 +507,7 @@ Proof. (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2)) in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0; - elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2))); + elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2))); intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1); auto with zarith real. @@ -515,8 +515,8 @@ Proof. rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1; - generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1); - intro; clear H0 H1; unfold Int_part at 1 in |- *; + generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1); + intro; clear H0 H1; unfold Int_part at 1 in |- *; omega. Qed. diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v index 17b6c60d..6460a927 100644 --- a/theories/Reals/R_sqr.v +++ b/theories/Reals/R_sqr.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: R_sqr.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rbasic_fun. @@ -61,7 +61,7 @@ Proof. | elim H0; intro; [ elim H; symmetry in |- *; exact H1 | rewrite Rsqr_neg; generalize (Ropp_lt_gt_contravar x 0 H1); - rewrite Ropp_0; intro; unfold Rsqr in |- *; + rewrite Ropp_0; intro; unfold Rsqr in |- *; apply Rmult_lt_0_compat; assumption ] ]. Qed. @@ -103,8 +103,8 @@ Proof. [ assumption | cut (y < x); [ intro; unfold Rsqr in H; - generalize (Rmult_le_0_lt_compat y x y x H1 H1 H2 H2); - intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H3); + generalize (Rmult_le_0_lt_compat y x y x H1 H1 H2 H2); + intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H3); intro; elim (Rlt_irrefl (x * x) H4) | auto with real ] ]. Qed. @@ -115,8 +115,8 @@ Proof. [ assumption | cut (y < x); [ intro; unfold Rsqr in H; - generalize (Rmult_le_0_lt_compat y x y x H0 H0 H1 H1); - intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H2); + generalize (Rmult_le_0_lt_compat y x y x H0 H0 H1 H1); + intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H2); intro; elim (Rlt_irrefl (x * x) H3) | auto with real ] ]. Qed. @@ -152,7 +152,7 @@ Proof. generalize (Ropp_lt_gt_contravar x 0 r); 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; + rewrite <- (Ropp_involutive x); apply Ropp_ge_le_contravar; apply Rle_ge; assumption. apply Rle_trans with 0; [ rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption @@ -165,7 +165,7 @@ 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; + 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. @@ -175,9 +175,9 @@ 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; + 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; + 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. @@ -225,16 +225,16 @@ Proof. intros; unfold Rabs in |- *; 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; + generalize (Ropp_lt_gt_contravar x 0 r0); 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; - intro; generalize (Rlt_le 0 (- x) H1); intro; apply Rsqr_inj; + generalize (Ropp_lt_gt_contravar x 0 r0); 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; - intro; generalize (Rlt_le 0 (- y) H1); intro; apply Rsqr_inj; + generalize (Ropp_lt_gt_contravar y 0 r); 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. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index 63b8940b..2c43ee9b 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: R_sqrt.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -20,15 +20,21 @@ Definition sqrt (x:R) : R := | right a => Rsqrt (mknonnegreal x (Rge_le _ _ a)) end. -Lemma sqrt_positivity : forall x:R, 0 <= x -> 0 <= sqrt x. +Lemma sqrt_pos : forall x : R, 0 <= sqrt x. Proof. - intros. - unfold sqrt in |- *. - case (Rcase_abs x); intro. - elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ r H)). + intros x. + unfold sqrt. + destruct (Rcase_abs x) as [H|H]. + apply Rle_refl. apply Rsqrt_positivity. Qed. +Lemma sqrt_positivity : forall x:R, 0 <= x -> 0 <= sqrt x. +Proof. + intros x _. + apply sqrt_pos. +Qed. + Lemma sqrt_sqrt : forall x:R, 0 <= x -> sqrt x * sqrt x = x. Proof. intros. @@ -40,7 +46,7 @@ Qed. Lemma sqrt_0 : sqrt 0 = 0. Proof. - apply Rsqr_eq_0; unfold Rsqr in |- *; apply sqrt_sqrt; right; reflexivity. + apply Rsqr_eq_0; unfold Rsqr in |- *; apply sqrt_sqrt; right; reflexivity. Qed. Lemma sqrt_1 : sqrt 1 = 1. @@ -48,7 +54,7 @@ Proof. apply (Rsqr_inj (sqrt 1) 1); [ apply sqrt_positivity; left | left - | unfold Rsqr in |- *; rewrite sqrt_sqrt; [ ring | left ] ]; + | unfold Rsqr in |- *; rewrite sqrt_sqrt; [ ring | left ] ]; apply Rlt_0_1. Qed. @@ -100,17 +106,41 @@ Proof. intros x H1; unfold Rsqr in |- *; apply (sqrt_sqrt x H1). Qed. +Lemma sqrt_mult_alt : + forall x y : R, 0 <= x -> sqrt (x * y) = sqrt x * sqrt y. +Proof. + intros x y Hx. + unfold sqrt at 3. + destruct (Rcase_abs y) as [Hy|Hy]. + rewrite Rmult_0_r. + destruct Hx as [Hx'|Hx']. + unfold sqrt. + destruct (Rcase_abs (x * y)) as [Hxy|Hxy]. + apply eq_refl. + elim Rge_not_lt with (1 := Hxy). + rewrite <- (Rmult_0_r x). + now apply Rmult_lt_compat_l. + rewrite <- Hx', Rmult_0_l. + exact sqrt_0. + apply Rsqr_inj. + apply sqrt_pos. + apply Rmult_le_pos. + apply sqrt_pos. + apply Rsqrt_positivity. + rewrite Rsqr_mult, 2!Rsqr_sqrt. + unfold Rsqr. + now rewrite Rsqrt_Rsqrt. + exact Hx. + apply Rmult_le_pos. + exact Hx. + now apply Rge_le. +Qed. + Lemma sqrt_mult : forall x y:R, 0 <= x -> 0 <= y -> sqrt (x * y) = sqrt x * sqrt y. Proof. - intros x y H1 H2; - apply - (Rsqr_inj (sqrt (x * y)) (sqrt x * sqrt y) - (sqrt_positivity (x * y) (Rmult_le_pos x y H1 H2)) - (Rmult_le_pos (sqrt x) (sqrt y) (sqrt_positivity x H1) - (sqrt_positivity y H2))); rewrite Rsqr_mult; - repeat rewrite Rsqr_sqrt; - [ ring | assumption | assumption | apply (Rmult_le_pos x y H1 H2) ]. + intros x y Hx _. + now apply sqrt_mult_alt. Qed. Lemma sqrt_lt_R0 : forall x:R, 0 < x -> 0 < sqrt x. @@ -121,46 +151,90 @@ Proof. | apply (sqrt_positivity x (Rlt_le 0 x H1)) ]. Qed. +Lemma sqrt_div_alt : + forall x y : R, 0 < y -> sqrt (x / y) = sqrt x / sqrt y. +Proof. + intros x y Hy. + unfold sqrt at 2. + destruct (Rcase_abs x) as [Hx|Hx]. + unfold Rdiv. + rewrite Rmult_0_l. + unfold sqrt. + destruct (Rcase_abs (x * / y)) as [Hxy|Hxy]. + apply eq_refl. + elim Rge_not_lt with (1 := Hxy). + apply Rmult_lt_reg_r with y. + exact Hy. + rewrite Rmult_assoc, Rinv_l, Rmult_1_r, Rmult_0_l. + exact Hx. + now apply Rgt_not_eq. + set (Hx' := Rge_le x 0 Hx). + clearbody Hx'. clear Hx. + apply Rsqr_inj. + apply sqrt_pos. + apply Fourier_util.Rle_mult_inv_pos. + apply Rsqrt_positivity. + now apply sqrt_lt_R0. + rewrite Rsqr_div, 2!Rsqr_sqrt. + unfold Rsqr. + now rewrite Rsqrt_Rsqrt. + now apply Rlt_le. + now apply Fourier_util.Rle_mult_inv_pos. + apply Rgt_not_eq. + now apply sqrt_lt_R0. +Qed. + Lemma sqrt_div : forall x y:R, 0 <= x -> 0 < y -> sqrt (x / y) = sqrt x / sqrt y. Proof. - intros x y H1 H2; apply Rsqr_inj; - [ apply sqrt_positivity; apply (Rmult_le_pos x (/ y)); - [ assumption - | generalize (Rinv_0_lt_compat y H2); clear H2; intro H2; left; - assumption ] - | apply (Rmult_le_pos (sqrt x) (/ sqrt y)); - [ apply (sqrt_positivity x H1) - | generalize (sqrt_lt_R0 y H2); clear H2; intro H2; - generalize (Rinv_0_lt_compat (sqrt y) H2); clear H2; - intro H2; left; assumption ] - | rewrite Rsqr_div; repeat rewrite Rsqr_sqrt; - [ reflexivity - | left; assumption - | assumption - | generalize (Rinv_0_lt_compat y H2); intro H3; - generalize (Rlt_le 0 (/ y) H3); intro H4; - apply (Rmult_le_pos x (/ y) H1 H4) - | red in |- *; intro H3; generalize (Rlt_le 0 y H2); intro H4; - generalize (sqrt_eq_0 y H4 H3); intro H5; rewrite H5 in H2; - elim (Rlt_irrefl 0 H2) ] ]. + intros x y _ H. + now apply sqrt_div_alt. +Qed. + +Lemma sqrt_lt_0_alt : + forall x y : R, sqrt x < sqrt y -> x < y. +Proof. + intros x y. + unfold sqrt at 2. + destruct (Rcase_abs y) as [Hy|Hy]. + intros Hx. + elim Rlt_not_le with (1 := Hx). + apply sqrt_pos. + set (Hy' := Rge_le y 0 Hy). + clearbody Hy'. clear Hy. + unfold sqrt. + destruct (Rcase_abs x) as [Hx|Hx]. + intros _. + now apply Rlt_le_trans with R0. + intros Hxy. + apply Rsqr_incrst_1 in Hxy ; try apply Rsqrt_positivity. + unfold Rsqr in Hxy. + now rewrite 2!Rsqrt_Rsqrt in Hxy. Qed. Lemma sqrt_lt_0 : forall x y:R, 0 <= x -> 0 <= y -> sqrt x < sqrt y -> x < y. Proof. - intros x y H1 H2 H3; - generalize - (Rsqr_incrst_1 (sqrt x) (sqrt y) H3 (sqrt_positivity x H1) - (sqrt_positivity y H2)); intro H4; rewrite (Rsqr_sqrt x H1) in H4; - rewrite (Rsqr_sqrt y H2) in H4; assumption. + intros x y _ _. + apply sqrt_lt_0_alt. +Qed. + +Lemma sqrt_lt_1_alt : + forall x y : R, 0 <= x < y -> sqrt x < sqrt y. +Proof. + intros x y (Hx, Hxy). + apply Rsqr_incrst_0 ; try apply sqrt_pos. + rewrite 2!Rsqr_sqrt. + exact Hxy. + apply Rlt_le. + now apply Rle_lt_trans with x. + exact Hx. Qed. Lemma sqrt_lt_1 : forall x y:R, 0 <= x -> 0 <= y -> x < y -> sqrt x < sqrt y. Proof. - intros x y H1 H2 H3; apply Rsqr_incrst_0; - [ rewrite (Rsqr_sqrt x H1); rewrite (Rsqr_sqrt y H2); assumption - | apply (sqrt_positivity x H1) - | apply (sqrt_positivity y H2) ]. + intros x y Hx _ Hxy. + apply sqrt_lt_1_alt. + now split. Qed. Lemma sqrt_le_0 : @@ -173,13 +247,27 @@ Proof. rewrite (Rsqr_sqrt y H2) in H4; assumption. Qed. +Lemma sqrt_le_1_alt : + forall x y : R, x <= y -> sqrt x <= sqrt y. +Proof. + intros x y [Hxy|Hxy]. + destruct (Rle_or_lt 0 x) as [Hx|Hx]. + apply Rlt_le. + apply sqrt_lt_1_alt. + now split. + unfold sqrt at 1. + destruct (Rcase_abs x) as [Hx'|Hx']. + apply sqrt_pos. + now elim Rge_not_lt with (1 := Hx'). + rewrite Hxy. + apply Rle_refl. +Qed. + Lemma sqrt_le_1 : forall x y:R, 0 <= x -> 0 <= y -> x <= y -> sqrt x <= sqrt y. Proof. - intros x y H1 H2 H3; apply Rsqr_incr_0; - [ rewrite (Rsqr_sqrt x H1); rewrite (Rsqr_sqrt y H2); assumption - | apply (sqrt_positivity x H1) - | apply (sqrt_positivity y H2) ]. + intros x y _ _ Hxy. + now apply sqrt_le_1_alt. Qed. Lemma sqrt_inj : forall x y:R, 0 <= x -> 0 <= y -> sqrt x = sqrt y -> x = y. @@ -190,22 +278,30 @@ Proof. rewrite H1; reflexivity. Qed. +Lemma sqrt_less_alt : + forall x : R, 1 < x -> sqrt x < x. +Proof. + intros x Hx. + assert (Hx1 := Rle_lt_trans _ _ _ Rle_0_1 Hx). + assert (Hx2 := Rlt_le _ _ Hx1). + apply Rsqr_incrst_0 ; trivial. + rewrite Rsqr_sqrt ; trivial. + rewrite <- (Rmult_1_l x) at 1. + now apply Rmult_lt_compat_r. + apply sqrt_pos. +Qed. + Lemma sqrt_less : forall x:R, 0 <= x -> 1 < x -> sqrt x < x. Proof. - intros x H1 H2; generalize (sqrt_lt_1 1 x (Rlt_le 0 1 Rlt_0_1) H1 H2); - intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); - intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 2 in |- *; - rewrite <- (sqrt_def x H1); - apply - (Rmult_lt_compat_l (sqrt x) 1 (sqrt x) - (sqrt_lt_R0 x (Rlt_trans 0 1 x Rlt_0_1 H2)) H3). + intros x _. + apply sqrt_less_alt. Qed. Lemma sqrt_more : forall x:R, 0 < x -> x < 1 -> x < sqrt x. Proof. intros x H1 H2; - generalize (sqrt_lt_1 x 1 (Rlt_le 0 x H1) (Rlt_le 0 1 Rlt_0_1) H2); - intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); + generalize (sqrt_lt_1 x 1 (Rlt_le 0 x H1) (Rlt_le 0 1 Rlt_0_1) H2); + intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 1 in |- *; rewrite <- (sqrt_def x (Rlt_le 0 x H1)); apply (Rmult_lt_compat_l (sqrt x) (sqrt x) 1 (sqrt_lt_R0 x H1) H3). @@ -338,7 +434,7 @@ Proof. (b * (- b * (/ 2 * / a)) + c). repeat rewrite <- Rplus_assoc; replace (b * b + b * b) with (2 * (b * b)). rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; + rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc. rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index f48ce563..500dd529 100644 --- a/theories/Reals/Ranalysis.v +++ b/theories/Reals/Ranalysis.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -85,7 +85,7 @@ Ltac intro_hyp_glob trm := match goal with | _:(forall x0:R, aux x0 <> 0) |- (derivable _) => intro_hyp_glob X1 - | _:(forall x0:R, aux x0 <> 0) |- (continuity _) => + | _:(forall x0:R, aux x0 <> 0) |- (continuity _) => intro_hyp_glob X1 | |- (derivable _) => cut (forall x0:R, aux x0 <> 0); @@ -277,7 +277,7 @@ Ltac intro_hyp_pt trm pt := Ltac is_diff_pt := match goal with | |- (derivable_pt Rsqr _) => - + (* fonctions de base *) apply derivable_pt_Rsqr | |- (derivable_pt id ?X1) => apply (derivable_pt_id X1) @@ -326,7 +326,7 @@ Ltac is_diff_pt := unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, comp, pow_fct, id, fct_cte in |- * ] | |- (derivable_pt (/ ?X1) ?X2) => - + (* INVERSION *) apply (derivable_pt_inv X1 X2); [ assumption || @@ -334,7 +334,7 @@ Ltac is_diff_pt := comp, pow_fct, id, fct_cte in |- * | is_diff_pt ] | |- (derivable_pt (comp ?X1 ?X2) ?X3) => - + (* COMPOSITION *) apply (derivable_pt_comp X2 X1 X3); is_diff_pt | _:(derivable_pt ?X1 ?X2) |- (derivable_pt ?X1 ?X2) => @@ -352,7 +352,7 @@ Ltac is_diff_pt := (**********) Ltac is_diff_glob := match goal with - | |- (derivable Rsqr) => + | |- (derivable Rsqr) => (* fonctions de base *) apply derivable_Rsqr | |- (derivable id) => apply derivable_id @@ -392,7 +392,7 @@ Ltac is_diff_glob := unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id, fct_cte, comp, pow_fct in |- * ] | |- (derivable (/ ?X1)) => - + (* INVERSION *) apply (derivable_inv X1); [ try @@ -401,7 +401,7 @@ Ltac is_diff_glob := id, fct_cte, comp, pow_fct in |- * | is_diff_glob ] | |- (derivable (comp sqrt _)) => - + (* COMPOSITION *) unfold derivable in |- *; intro; try is_diff_pt | |- (derivable (comp Rabs _)) => @@ -421,7 +421,7 @@ Ltac is_diff_glob := Ltac is_cont_pt := match goal with | |- (continuity_pt Rsqr _) => - + (* fonctions de base *) apply derivable_continuous_pt; apply derivable_pt_Rsqr | |- (continuity_pt id ?X1) => @@ -475,7 +475,7 @@ Ltac is_cont_pt := unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, comp, id, fct_cte, pow_fct in |- * ] | |- (continuity_pt (/ ?X1) ?X2) => - + (* INVERSION *) apply (continuity_pt_inv X1 X2); [ is_cont_pt @@ -483,7 +483,7 @@ Ltac is_cont_pt := unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, comp, id, fct_cte, pow_fct in |- * ] | |- (continuity_pt (comp ?X1 ?X2) ?X3) => - + (* COMPOSITION *) apply (continuity_pt_comp X2 X1 X3); is_cont_pt | _:(continuity_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) => @@ -508,7 +508,7 @@ Ltac is_cont_pt := Ltac is_cont_glob := match goal with | |- (continuity Rsqr) => - + (* fonctions de base *) apply derivable_continuous; apply derivable_Rsqr | |- (continuity id) => apply derivable_continuous; apply derivable_id @@ -559,7 +559,7 @@ Ltac is_cont_glob := unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id, fct_cte, pow_fct in |- * ] | |- (continuity (comp sqrt _)) => - + (* COMPOSITION *) unfold continuity_pt in |- *; intro; try is_cont_pt | |- (continuity (comp ?X1 ?X2)) => diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v index 9414f7c9..1516b338 100644 --- a/theories/Reals/Ranalysis1.v +++ b/theories/Reals/Ranalysis1.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis1.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -61,7 +61,7 @@ Definition strict_increasing f : Prop := forall x y:R, x < y -> f x < f y. Definition strict_decreasing f : Prop := forall x y:R, x < y -> f y < f x. Definition constant f : Prop := forall x y:R, f x = f y. -(**********) +(**********) Definition no_cond (x:R) : Prop := True. (**********) @@ -114,7 +114,7 @@ Qed. Lemma continuity_pt_const : forall f (x0:R), constant f -> continuity_pt f x0. Proof. unfold constant, continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; intros; exists 1; split; [ apply Rlt_0_1 | intros; generalize (H x x0); intro; rewrite H2; simpl in |- *; @@ -196,7 +196,7 @@ Proof. elim H5; intros; assumption. Qed. -(**********) +(**********) Lemma continuity_plus : forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 + f2). Proof. @@ -322,18 +322,18 @@ Proof. prove_sup0. rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ]; rewrite Rmult_1_r; rewrite double; - pattern alp at 1 in |- *; replace alp with (alp + 0); + pattern alp at 1 in |- *; replace alp with (alp + 0); [ idtac | ring ]; apply Rplus_lt_compat_l; assumption. symmetry in |- *; apply Rabs_right; left; assumption. symmetry in |- *; apply Rabs_right; left; change (0 < / 2) in |- *; - apply Rinv_0_lt_compat; prove_sup0. + apply Rinv_0_lt_compat; prove_sup0. Qed. Lemma uniqueness_step2 : forall f (x l:R), derivable_pt_lim f x l -> limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0. -Proof. +Proof. unfold derivable_pt_lim in |- *; intros; unfold limit1_in in |- *; unfold limit_in in |- *; intros. assert (H1 := H eps H0). @@ -418,10 +418,10 @@ Proof. intros; split. unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; intros. - apply derive_pt_eq_0. + apply derive_pt_eq_0. unfold derivable_pt_lim in |- *. intros; elim (H eps H0); intros alpha H1; elim H1; intros; - exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); + exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); intro; cut (x + h - x = h); [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha); [ intro; generalize (H6 H8); rewrite H7; intro; assumption @@ -434,7 +434,7 @@ Proof. intro. assert (H0 := derive_pt_eq_1 f x (df x) pr H). unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *; - unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; + unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; intros. elim (H0 eps H1); intros alpha H2; exists (pos alpha); split. apply (cond_pos alpha). @@ -454,7 +454,7 @@ Proof. simpl in |- *; unfold R_dist in |- *; intros. unfold derivable_pt_lim in |- *. intros; elim (H eps H0); intros alpha H1; elim H1; intros; - exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); + exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); intro; cut (x + h - x = h); [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha); [ intro; generalize (H6 H8); rewrite H7; intro; assumption @@ -467,7 +467,7 @@ Proof. intro. unfold derivable_pt_lim in H. unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *; - unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; + unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; intros. elim (H eps H0); intros alpha H2; exists (pos alpha); split. apply (cond_pos alpha). @@ -548,7 +548,7 @@ Qed. Lemma derivable_pt_lim_opp : forall f (x l:R), derivable_pt_lim f x l -> derivable_pt_lim (- f) x (- l). -Proof. +Proof. intros. apply uniqueness_step3. assert (H1 := uniqueness_step2 _ _ _ H). @@ -1066,7 +1066,7 @@ Qed. Lemma pr_nu : forall f (x:R) (pr1 pr2:derivable_pt f x), - derive_pt f x pr1 = derive_pt f x pr2. + derive_pt f x pr1 = derive_pt f x pr2. Proof. intros. unfold derivable_pt in pr1. @@ -1141,7 +1141,7 @@ Proof. - ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) / Rmin (delta / 2) ((b + - c) / 2))) (l / 2) H19); - repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; + repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; replace (- l + l / 2) with (- (l / 2)). intro; generalize @@ -1168,7 +1168,7 @@ Proof. Rge_le ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) / Rmin (delta / 2) ((b + - c) / 2) + - l) 0 r). - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)). + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)). assumption. rewrite <- Ropp_0; replace @@ -1260,7 +1260,7 @@ Proof. prove_sup0. rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym. rewrite Rmult_1_l. - replace (2 * delta) with (delta + delta). + replace (2 * delta) with (delta + delta). pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta); apply Rplus_lt_compat_l. rewrite Rplus_0_r; apply (cond_pos delta). @@ -1270,7 +1270,7 @@ Proof. intro; generalize (Rmin_stable_in_posreal (mkposreal (delta / 2) H9) - (mkposreal ((b - c) / 2) H8)); simpl in |- *; + (mkposreal ((b - c) / 2) H8)); simpl in |- *; intro; red in |- *; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10). unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ]. @@ -1307,7 +1307,7 @@ Proof. cut (Rabs ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) / - Rmax (- (delta / 2)) ((a + - c) / 2) + - l) < + Rmax (- (delta / 2)) ((a + - c) / 2) + - l) < - (l / 2)). unfold Rabs in |- *; case @@ -1332,7 +1332,7 @@ Proof. generalize (Rlt_trans ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) / - Rmax (- (delta / 2)) ((a + - c) / 2)) (l / 2) 0 H22 H21); + Rmax (- (delta / 2)) ((a + - c) / 2)) (l / 2) 0 H22 H21); intro; elim (Rlt_irrefl 0 @@ -1369,7 +1369,7 @@ Proof. reflexivity. unfold Rdiv in H11; assumption. generalize (Rplus_lt_compat_l c (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H10); - rewrite Rplus_0_r; intro; apply Rlt_trans with c; + rewrite Rplus_0_r; intro; apply Rlt_trans with c; assumption. generalize (RmaxLess2 (- (delta / 2)) ((a - c) / 2)); intro; generalize @@ -1390,21 +1390,21 @@ Proof. generalize (Rge_le (delta / 2) (- Rmax (- (delta / 2)) ((a - c) / 2)) H13); intro; apply Rle_lt_trans with (delta / 2). assumption. - apply Rmult_lt_reg_l with 2. + apply Rmult_lt_reg_l with 2. prove_sup0. unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym. rewrite Rmult_1_l; rewrite double. pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta); apply Rplus_lt_compat_l; rewrite Rplus_0_r; apply (cond_pos delta). - discrR. + discrR. cut (- (delta / 2) < 0). cut ((a - c) / 2 < 0). intros; generalize (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H13) - (mknegreal ((a - c) / 2) H12)); simpl in |- *; - intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 r); + (mknegreal ((a - c) / 2) H12)); simpl in |- *; + intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 r); intro; elim (Rlt_irrefl 0 @@ -1413,7 +1413,7 @@ Proof. apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2). assumption. unfold Rdiv in |- *. - rewrite <- Ropp_mult_distr_l_reverse. + rewrite <- Ropp_mult_distr_l_reverse. rewrite (Ropp_minus_distr a c). reflexivity. rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv in |- *; @@ -1435,7 +1435,7 @@ Proof. apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2). assumption. unfold Rdiv in |- *. - rewrite <- Ropp_mult_distr_l_reverse. + rewrite <- Ropp_mult_distr_l_reverse. rewrite (Ropp_minus_distr a c). reflexivity. unfold Rdiv in |- *; apply Rmult_lt_0_compat; @@ -1532,7 +1532,7 @@ Proof. generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H12); rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption. pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l; - left; assumption. + left; assumption. left; apply Rinv_0_lt_compat; assumption. split. unfold Rdiv in |- *; apply prod_neq_R0. diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index 54801eb7..1d44b3e7 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis2.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -36,29 +36,27 @@ Proof. replace (l1 * (/ f2 x * / f2 (x + h)) * - f2 (x + h)) with (- (l1 * / f2 x * (f2 (x + h) * / f2 (x + h)))); [ idtac | ring ]. replace (f1 x * (/ f2 x * / f2 (x + h)) * (f2 (x + h) * / h)) with - (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h))); + (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h))); [ idtac | ring ]. replace (f1 x * (/ f2 x * / f2 (x + h)) * (- f2 x * / h)) with - (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x))); + (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x))); [ idtac | ring ]. replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * f2 (x + h)) with (l2 * f1 x * / f2 x * / f2 x * (f2 (x + h) * / f2 (x + h))); [ idtac | ring ]. replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * - f2 x) with - (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x))); + (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x))); [ idtac | ring ]. repeat rewrite <- Rinv_r_sym; try assumption || ring. apply prod_neq_R0; assumption. Qed. -Lemma Rmin_pos : forall x y:R, 0 < x -> 0 < y -> 0 < Rmin x y. -Proof. - intros; unfold Rmin in |- *. - case (Rle_dec x y); intro; assumption. -Qed. +(* begin hide *) +Notation Rmin_pos := Rmin_pos (only parsing). (* compat *) +(* end hide *) Lemma maj_term1 : - forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal) + forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal) (f1 f2:R -> R), 0 < eps -> f2 x <> 0 -> @@ -105,7 +103,7 @@ Proof. Qed. Lemma maj_term2 : - forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal) + forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal) (f2:R -> R), 0 < eps -> f2 x <> 0 -> @@ -143,7 +141,7 @@ Proof. replace (Rabs 2) with 2. rewrite (Rmult_comm 2). replace (Rabs l1 * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with - (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); + (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); [ idtac | ring ]. repeat apply Rmult_lt_compat_l. apply Rabs_pos_lt; assumption. @@ -176,7 +174,7 @@ Proof. Qed. Lemma maj_term3 : - forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal) + forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal) (f1 f2:R -> R), 0 < eps -> f2 x <> 0 -> @@ -218,7 +216,7 @@ Proof. replace (Rabs 2) with 2. rewrite (Rmult_comm 2). replace (Rabs (f1 x) * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with - (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); + (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); [ idtac | ring ]. repeat apply Rmult_lt_compat_l. apply Rabs_pos_lt; assumption. @@ -251,7 +249,7 @@ Proof. Qed. Lemma maj_term4 : - forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal) + forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal) (f1 f2:R -> R), 0 < eps -> f2 x <> 0 -> @@ -386,10 +384,9 @@ Proof. apply Rplus_lt_compat_l; assumption. Qed. -Lemma Rmin_2 : forall a b c:R, a < b -> a < c -> a < Rmin b c. -Proof. - intros; unfold Rmin in |- *; case (Rle_dec b c); intro; assumption. -Qed. +(* begin hide *) +Notation Rmin_2 := Rmin_glb_lt (only parsing). +(* end hide *) Lemma quadruple : forall x:R, 4 * x = x + x + x + x. Proof. @@ -431,7 +428,7 @@ Proof. assert (Hyp : 0 < 2). prove_sup0. intro; rewrite H11 in H10; assert (H12 := Rmult_lt_compat_l 2 _ _ Hyp H10); - rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12; + rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12; [ idtac | discrR ]. cut (IZR 1 < IZR 2). unfold IZR in |- *; unfold INR, nat_of_P in |- *; simpl in |- *; intro; diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v index 180cf9d6..3b685cd8 100644 --- a/theories/Reals/Ranalysis3.v +++ b/theories/Reals/Ranalysis3.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis3.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -60,7 +60,7 @@ Proof. case (Req_dec (f1 x) 0); intro. case (Req_dec l1 0); intro. (***********************************) -(* Cas n 1 *) +(* First case *) (* (f1 x)=0 l1 =0 *) (***********************************) cut (0 < Rmin eps_f2 (Rmin alp_f2 alp_f1d)); @@ -118,7 +118,7 @@ Proof. apply Rmin_2; assumption. right; symmetry in |- *; apply quadruple_var. (***********************************) -(* Cas n 2 *) +(* Second case *) (* (f1 x)=0 l1<>0 *) (***********************************) assert (H10 := derivable_continuous_pt _ _ X). @@ -213,12 +213,12 @@ Proof. apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc; repeat apply prod_neq_R0. red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6). - assumption. + assumption. assumption. apply Rinv_neq_0_compat; repeat apply prod_neq_R0; [ discrR | discrR | discrR | assumption ]. (***********************************) -(* Cas n 3 *) +(* Third case *) (* (f1 x)<>0 l1=0 l2=0 *) (***********************************) case (Req_dec l1 0); intro. @@ -291,7 +291,7 @@ Proof. apply (cond_pos alp_f1d). apply (cond_pos alp_f2d). (***********************************) -(* Cas n 4 *) +(* Fourth case *) (* (f1 x)<>0 l1=0 l2<>0 *) (***********************************) elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); @@ -380,7 +380,7 @@ Proof. unfold Rdiv, Rsqr in |- *. repeat rewrite Rinv_mult_distr; try assumption. repeat apply prod_neq_R0; try assumption. - red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). + red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; discrR. @@ -408,20 +408,20 @@ Proof. unfold Rsqr, Rdiv in |- *. repeat rewrite Rinv_mult_distr; try assumption || discrR. repeat apply prod_neq_R0; try assumption. - red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6). + red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; assumption. apply Rinv_neq_0_compat; assumption. apply prod_neq_R0; [ discrR | assumption ]. - red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6). + red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; assumption. (***********************************) -(* Cas n 5 *) +(* Fifth case *) (* (f1 x)<>0 l1<>0 l2=0 *) (***********************************) case (Req_dec l2 0); intro. @@ -519,7 +519,7 @@ Proof. repeat apply Rmin_pos. apply (cond_pos eps_f2). elim H3; intros; assumption. - apply (cond_pos alp_f1d). + apply (cond_pos alp_f1d). apply (cond_pos alp_f2d). elim H11; intros; assumption. apply Rabs_pos_lt. @@ -538,7 +538,7 @@ Proof. (apply Rinv_neq_0_compat; discrR) || (red in |- *; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)). (***********************************) -(* Cas n 6 *) +(* Sixth case *) (* (f1 x)<>0 l1<>0 l2<>0 *) (***********************************) elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))). @@ -776,7 +776,7 @@ Proof. Qed. Lemma derive_pt_div : - forall (f1 f2:R -> R) (x:R) (pr1:derivable_pt f1 x) + forall (f1 f2:R -> R) (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x) (na:f2 x <> 0), derive_pt (f1 / f2) x (derivable_pt_div _ _ _ pr1 pr2 na) = (derive_pt f1 x pr1 * f2 x - derive_pt f2 x pr2 * f1 x) / Rsqr (f2 x). diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v index 95f6d27e..1ed3fb71 100644 --- a/theories/Reals/Ranalysis4.v +++ b/theories/Reals/Ranalysis4.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis4.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -31,8 +31,8 @@ Proof. unfold div_fct, inv_fct, fct_cte in |- *; intro X0; elim X0; intros; unfold derivable_pt in |- *; exists x0; unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *; - unfold derivable_pt_abs in p; unfold derivable_pt_lim in p; - intros; elim (p eps H0); intros; exists x1; intros; + unfold derivable_pt_abs in p; unfold derivable_pt_lim in p; + intros; elim (p eps H0); intros; exists x1; intros; unfold Rdiv in H1; unfold Rdiv in |- *; rewrite <- (Rmult_1_l (/ f x)); rewrite <- (Rmult_1_l (/ f (x + h))). apply H1; assumption. @@ -60,14 +60,14 @@ Proof. elim pr1; intros. elim pr2; intros. simpl in |- *. - assert (H0 := uniqueness_step2 _ _ _ p). - assert (H1 := uniqueness_step2 _ _ _ p0). + assert (H0 := uniqueness_step2 _ _ _ p). + assert (H1 := uniqueness_step2 _ _ _ p0). 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; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2). assumption. unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; unfold limit1_in in H1; - unfold limit_in in H1; unfold dist in H1; simpl in H1; + unfold limit_in in H1; unfold dist in H1; simpl in H1; unfold R_dist in H1. intros; elim (H1 eps H2); intros. elim H3; intros. @@ -122,7 +122,7 @@ Proof. 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; - rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; + rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; apply H2. apply Rplus_le_le_0_compat. left; apply H. @@ -178,12 +178,12 @@ Proof. unfold continuity in |- *; intro. case (Req_dec x 0); intro. unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; - simpl in |- *; unfold R_dist in |- *; intros; exists eps; + unfold limit1_in in |- *; unfold limit_in in |- *; + simpl in |- *; unfold R_dist in |- *; intros; exists eps; split. apply H0. intros; rewrite H; rewrite Rabs_R0; unfold Rminus in |- *; rewrite Ropp_0; - rewrite Rplus_0_r; rewrite Rabs_Rabsolu; elim H1; + rewrite Rplus_0_r; rewrite Rabs_Rabsolu; elim H1; intros; rewrite H in H3; unfold Rminus in H3; rewrite Ropp_0 in H3; rewrite Rplus_0_r in H3; apply H3. apply derivable_continuous_pt; apply (Rderivable_pt_abs x H). @@ -297,7 +297,7 @@ Proof. induction N as [| N HrecN]. exists 0; apply H. exists - (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N))); + (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N))); apply H. Qed. @@ -317,7 +317,7 @@ Proof. ((exp + comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ]. replace ((exp x - exp (- x)) * / 2) with ((exp x + exp (- x) * -1) * fct_cte (/ 2) x + - (exp + comp exp (- id))%F x * 0). + (exp + comp exp (- id))%F x * 0). apply derivable_pt_lim_mult. apply derivable_pt_lim_plus. apply derivable_pt_lim_exp. @@ -337,7 +337,7 @@ Proof. ((exp - comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ]. replace ((exp x + exp (- x)) * / 2) with ((exp x - exp (- x) * -1) * fct_cte (/ 2) x + - (exp - comp exp (- id))%F x * 0). + (exp - comp exp (- id))%F x * 0). apply derivable_pt_lim_mult. apply derivable_pt_lim_minus. apply derivable_pt_lim_exp. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 6667d2ec..9715414f 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Raxioms.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) (*********************************************************) (** Axiomatisation of the classical reals *) @@ -40,13 +40,13 @@ Hint Resolve Rplus_opp_r: real v62. Axiom Rplus_0_l : forall r:R, 0 + r = r. Hint Resolve Rplus_0_l: real. -(***********************************************************) +(***********************************************************) (** ** Multiplication *) (***********************************************************) (**********) Axiom Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1. -Hint Resolve Rmult_comm: real v62. +Hint Resolve Rmult_comm: real v62. (**********) Axiom Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3). @@ -102,7 +102,7 @@ Axiom Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real. -(**********************************************************) +(**********************************************************) (** * Injection from N to R *) (**********************************************************) @@ -112,11 +112,11 @@ Boxed Fixpoint INR (n:nat) : R := | O => 0 | S O => 1 | S n => INR n + 1 - end. + end. Arguments Scope INR [nat_scope]. -(**********************************************************) +(**********************************************************) (** * Injection from [Z] to [R] *) (**********************************************************) @@ -126,7 +126,7 @@ Definition IZR (z:Z) : R := | Z0 => 0 | Zpos n => INR (nat_of_P n) | Zneg n => - INR (nat_of_P n) - end. + end. Arguments Scope IZR [Z_scope]. (**********************************************************) diff --git a/theories/Reals/Rbase.v b/theories/Reals/Rbase.v index 5bee0f82..ab1c0747 100644 --- a/theories/Reals/Rbase.v +++ b/theories/Reals/Rbase.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rbase.v 9178 2006-09-26 11:18:22Z barras $ i*) +(*i $Id$ i*) Require Export Rdefinitions. Require Export Raxioms. diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index a5cc9f19..7588020c 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rbasic_fun.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) (*********************************************************) (** Complements for the real numbers *) @@ -16,7 +16,7 @@ Require Import Rbase. Require Import R_Ifp. Require Import Fourier. -Open Local Scope R_scope. +Local Open Scope R_scope. Implicit Type r : R. @@ -31,6 +31,19 @@ Definition Rmin (x y:R) : R := | right _ => y end. +(*********) +Lemma Rmin_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmin r1 r2). +Proof. + intros r1 r2 P H1 H2; unfold Rmin; case (Rle_dec r1 r2); auto. +Qed. + +(*********) +Lemma Rmin_case_strong : forall r1 r2 (P:R -> Type), + (r1 <= r2 -> P r1) -> (r2 <= r1 -> P r2) -> P (Rmin r1 r2). +Proof. + intros r1 r2 P H1 H2; unfold Rmin; destruct (Rle_dec r1 r2); auto with real. +Qed. + (*********) Lemma Rmin_Rgt_l : forall r1 r2 r, Rmin r1 r2 > r -> r1 > r /\ r2 > r. Proof. @@ -73,9 +86,33 @@ Proof. Qed. (*********) -Lemma Rmin_comm : forall a b:R, Rmin a b = Rmin b a. +Lemma Rmin_left : forall x y, x <= y -> Rmin x y = x. +Proof. + intros; apply Rmin_case_strong; auto using Rle_antisym. +Qed. + +(*********) +Lemma Rmin_right : forall x y, y <= x -> Rmin x y = y. +Proof. + intros; apply Rmin_case_strong; auto using Rle_antisym. +Qed. + +(*********) +Lemma Rle_min_compat_r : forall x y z, x <= y -> Rmin x z <= Rmin y z. +Proof. + intros; do 2 (apply Rmin_case_strong; intro); eauto using Rle_trans, Rle_refl. +Qed. + +(*********) +Lemma Rle_min_compat_l : forall x y z, x <= y -> Rmin z x <= Rmin z y. +Proof. + intros; do 2 (apply Rmin_case_strong; intro); eauto using Rle_trans, Rle_refl. +Qed. + +(*********) +Lemma Rmin_comm : forall x y:R, Rmin x y = Rmin y x. Proof. - intros; unfold Rmin in |- *; case (Rle_dec a b); case (Rle_dec b a); intros; + intros; unfold Rmin; case (Rle_dec x y); case (Rle_dec y x); intros; try reflexivity || (apply Rle_antisym; assumption || auto with real). Qed. @@ -85,6 +122,25 @@ Proof. intros; apply Rmin_Rgt_r; split; [ apply (cond_pos x) | apply (cond_pos y) ]. Qed. +(*********) +Lemma Rmin_pos : forall x y:R, 0 < x -> 0 < y -> 0 < Rmin x y. +Proof. + intros; unfold Rmin in |- *. + case (Rle_dec x y); intro; assumption. +Qed. + +(*********) +Lemma Rmin_glb : forall x y z:R, z <= x -> z <= y -> z <= Rmin x y. +Proof. + intros; unfold Rmin in |- *; case (Rle_dec x y); intro; assumption. +Qed. + +(*********) +Lemma Rmin_glb_lt : forall x y z:R, z < x -> z < y -> z < Rmin x y. +Proof. + intros; unfold Rmin in |- *; case (Rle_dec x y); intro; assumption. +Qed. + (*******************************) (** * Rmax *) (*******************************) @@ -96,6 +152,19 @@ Definition Rmax (x y:R) : R := | right _ => x end. +(*********) +Lemma Rmax_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmax r1 r2). +Proof. + intros r1 r2 P H1 H2; unfold Rmax; case (Rle_dec r1 r2); auto. +Qed. + +(*********) +Lemma Rmax_case_strong : forall r1 r2 (P:R -> Type), + (r2 <= r1 -> P r1) -> (r1 <= r2 -> P r2) -> P (Rmax r1 r2). +Proof. + intros r1 r2 P H1 H2; unfold Rmax; case (Rle_dec r1 r2); auto with real. +Qed. + (*********) Lemma Rmax_Rle : forall r1 r2 r, r <= Rmax r1 r2 <-> r <= r1 \/ r <= r2. Proof. @@ -108,24 +177,60 @@ Proof. apply (Rlt_le r r1 (Rle_lt_trans r r2 r1 H H0)). Qed. -Lemma RmaxLess1 : forall r1 r2, r1 <= Rmax r1 r2. +Lemma Rmax_comm : forall x y:R, Rmax x y = Rmax y x. Proof. - intros r1 r2; unfold Rmax in |- *; case (Rle_dec r1 r2); auto with real. + intros p q; unfold Rmax in |- *; case (Rle_dec p q); case (Rle_dec q p); auto; + intros H1 H2; apply Rle_antisym; auto with real. Qed. -Lemma RmaxLess2 : forall r1 r2, r2 <= Rmax r1 r2. +(* begin hide *) +Notation RmaxSym := Rmax_comm (only parsing). +(* end hide *) + +(*********) +Lemma Rmax_l : forall x y:R, x <= Rmax x y. Proof. - intros r1 r2; unfold Rmax in |- *; case (Rle_dec r1 r2); auto with real. + intros; unfold Rmax in |- *; case (Rle_dec x y); intro H1; + [ assumption | auto with real ]. Qed. -Lemma Rmax_comm : forall p q:R, Rmax p q = Rmax q p. +(*********) +Lemma Rmax_r : forall x y:R, y <= Rmax x y. Proof. - intros p q; unfold Rmax in |- *; case (Rle_dec p q); case (Rle_dec q p); auto; - intros H1 H2; apply Rle_antisym; auto with real. + intros; unfold Rmax in |- *; case (Rle_dec x y); intro H1; + [ right; reflexivity | auto with real ]. Qed. -Notation RmaxSym := Rmax_comm (only parsing). +(* begin hide *) +Notation RmaxLess1 := Rmax_l (only parsing). +Notation RmaxLess2 := Rmax_r (only parsing). +(* end hide *) +(*********) +Lemma Rmax_left : forall x y, y <= x -> Rmax x y = x. +Proof. + intros; apply Rmax_case_strong; auto using Rle_antisym. +Qed. + +(*********) +Lemma Rmax_right : forall x y, x <= y -> Rmax x y = y. +Proof. + intros; apply Rmax_case_strong; auto using Rle_antisym. +Qed. + +(*********) +Lemma Rle_max_compat_r : forall x y z, x <= y -> Rmax x z <= Rmax y z. +Proof. + intros; do 2 (apply Rmax_case_strong; intro); eauto using Rle_trans, Rle_refl. +Qed. + +(*********) +Lemma Rle_max_compat_l : forall x y z, x <= y -> Rmax z x <= Rmax z y. +Proof. + intros; do 2 (apply Rmax_case_strong; intro); eauto using Rle_trans, Rle_refl. +Qed. + +(*********) Lemma RmaxRmult : forall (p q:R) r, 0 <= r -> Rmax (r * p) (r * q) = r * Rmax p q. Proof. @@ -140,18 +245,38 @@ Proof. rewrite <- E1; repeat rewrite Rmult_0_l; auto. Qed. +(*********) Lemma Rmax_stable_in_negreal : forall x y:negreal, Rmax x y < 0. Proof. intros; unfold Rmax in |- *; case (Rle_dec x y); intro; [ apply (cond_neg y) | apply (cond_neg x) ]. Qed. +(*********) +Lemma Rmax_lub : forall x y z:R, x <= z -> y <= z -> Rmax x y <= z. +Proof. + intros; unfold Rmax; case (Rle_dec x y); intro; assumption. +Qed. + +(*********) +Lemma Rmax_lub_lt : forall x y z:R, x < z -> y < z -> Rmax x y < z. +Proof. + intros; unfold Rmax; case (Rle_dec x y); intro; assumption. +Qed. + +(*********) +Lemma Rmax_neg : forall x y:R, x < 0 -> y < 0 -> Rmax x y < 0. +Proof. + intros; unfold Rmax in |- *. + case (Rle_dec x y); intro; assumption. +Qed. + (*******************************) (** * Rabsolu *) (*******************************) (*********) -Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}. +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). @@ -169,7 +294,7 @@ Definition Rabs r : R := Lemma Rabs_R0 : Rabs 0 = 0. Proof. unfold Rabs in |- *; case (Rcase_abs 0); auto; intro. - generalize (Rlt_irrefl 0); intro; elimtype False; auto. + generalize (Rlt_irrefl 0); intro; exfalso; auto. Qed. Lemma Rabs_R1 : Rabs 1 = 1. @@ -220,16 +345,18 @@ Proof. apply Rge_le; assumption. Qed. -Lemma RRle_abs : forall x:R, x <= Rabs x. +Lemma Rle_abs : forall x:R, x <= Rabs x. Proof. intro; unfold Rabs in |- *; case (Rcase_abs x); intros; fourier. Qed. +Definition RRle_abs := Rle_abs. + (*********) Lemma Rabs_pos_eq : forall x:R, 0 <= x -> Rabs x = x. Proof. intros; unfold Rabs in |- *; case (Rcase_abs x); intro; - [ generalize (Rgt_not_le 0 x r); intro; elimtype False; auto | trivial ]. + [ generalize (Rgt_not_le 0 x r); intro; exfalso; auto | trivial ]. Qed. (*********) @@ -243,10 +370,10 @@ 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. - elimtype False; clear H0; elim H; clear H; generalize H1; unfold Rabs in |- *; + exfalso; clear H0; elim H; clear H; generalize H1; unfold Rabs in |- *; 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); + rewrite (let (H1, H2) := Rplus_ne x in H1); rewrite (Rplus_opp_r x); trivial. Qed. @@ -256,14 +383,14 @@ Proof. intros; unfold Rabs in |- *; 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; elimtype False; + generalize (Rlt_asym x y H); intro; exfalso; auto. 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; elimtype False; auto. + 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. @@ -275,47 +402,47 @@ Proof. intros; unfold Rabs in |- *; 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; elimtype False; rewrite (Rmult_comm y x) in H; + 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. - rewrite (Ropp_mult_distr_l_reverse x y); trivial. + 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; elimtype False; + 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; elimtype False; auto. + intro; exfalso; auto. rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0); - intro; elimtype False; auto. + intro; exfalso; auto. rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0); - intro; elimtype False; auto. + intro; exfalso; auto. 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; elimtype False; + 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; elimtype False; auto. + 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; elimtype False; + 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; elimtype False; + 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; elimtype False; auto. + 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; elimtype False; + generalize (Rlt_irrefl 0); intro; exfalso; auto. rewrite H0; rewrite (Rmult_0_l y); rewrite (Rmult_0_l (- y)); trivial. Qed. @@ -327,15 +454,15 @@ Proof. 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; elimtype False; + 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; - elimtype False; auto. + 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; elimtype False; auto. - elimtype False; auto. -Qed. + intro; exfalso; auto. + exfalso; auto. +Qed. Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x. Proof. @@ -351,7 +478,7 @@ Proof. generalize (Ropp_le_ge_contravar 0 (-1) H1). rewrite Ropp_involutive; rewrite Ropp_0. intro; generalize (Rgt_not_le 1 0 Rlt_0_1); intro; generalize (Rge_le 0 1 H2); - intro; elimtype False; auto. + intro; exfalso; auto. ring. Qed. @@ -366,7 +493,7 @@ Proof. rewrite (Ropp_plus_distr a b); apply (Rplus_le_compat_l (- a) (- b) b); unfold Rle in |- *; unfold Rge in r; elim r; 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; + elim (Rplus_ne (- b)); intros v w; rewrite v in H0; clear v w; rewrite (Rplus_opp_l b) in H0; apply (Rlt_trans (- b) 0 b H0 H). right; rewrite H; apply Ropp_0. (**) @@ -374,21 +501,21 @@ Proof. rewrite (Rplus_comm a (- b)); apply (Rplus_le_compat_l (- b) (- a) a); unfold Rle in |- *; unfold Rge in r0; elim r0; 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; + 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. (**) - elimtype False; generalize (Rplus_ge_compat_l a b 0 r); intro; + exfalso; generalize (Rplus_ge_compat_l a b 0 r); 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 r0); 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. absurd (a + b = 0); auto. apply (Rlt_dichotomy_converse (a + b) 0); left; assumption. (**) - elimtype False; generalize (Rplus_lt_compat_l a b 0 r); intro; + exfalso; generalize (Rplus_lt_compat_l a b 0 r); 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; + generalize (Rlt_trans (a + b) a 0 H r0); intro; clear H; unfold Rge in r1; elim r1; clear r1; intro. unfold Rgt in H; generalize (Rlt_trans (a + b) 0 (a + b) H0 H); intro; apply (Rlt_irrefl (a + b)); assumption. @@ -397,16 +524,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 in |- *; rewrite (Ropp_involutive a); - generalize (Rplus_lt_compat_l a a 0 r0); clear r r1; - intro; elim (Rplus_ne a); intros v w; rewrite v in H; - clear v w; generalize (Rlt_trans (a + a) a 0 H r0); + generalize (Rplus_lt_compat_l a a 0 r0); clear r r1; + intro; elim (Rplus_ne a); intros v w; rewrite v in H; + clear v w; generalize (Rlt_trans (a + a) a 0 H r0); intro; apply (Rlt_le (a + a) 0 H0). (**) apply (Rplus_le_compat_l a b (- b)); apply (Rminus_le b (- b)); unfold Rminus in |- *; rewrite (Ropp_involutive b); - generalize (Rplus_lt_compat_l b b 0 r); clear r0 r1; - intro; elim (Rplus_ne b); intros v w; rewrite v in H; - clear v w; generalize (Rlt_trans (b + b) b 0 H r); + generalize (Rplus_lt_compat_l b b 0 r); clear r0 r1; + intro; elim (Rplus_ne b); intros v w; rewrite v in H; + clear v w; generalize (Rlt_trans (b + b) b 0 H r); intro; apply (Rlt_le (b + b) 0 H0). (**) unfold Rle in |- *; right; reflexivity. @@ -428,25 +555,25 @@ Proof. Qed. (* ||a|-|b||<=|a-b| *) -Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b). +Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b). Proof. cut - (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)). + (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)). intros; destruct (Rtotal_order (Rabs a) (Rabs b)) as [Hlt| [Heq| Hgt]]. rewrite <- (Rabs_Ropp (Rabs a - Rabs b)); rewrite <- (Rabs_Ropp (a - b)); - do 2 rewrite Ropp_minus_distr. - apply H; left; assumption. + do 2 rewrite Ropp_minus_distr. + apply H; left; assumption. rewrite Heq; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; - apply Rabs_pos. - apply H; left; assumption. - intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b). - apply Rabs_triang_inv. + apply Rabs_pos. + apply H; left; assumption. + intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b). + apply Rabs_triang_inv. rewrite (Rabs_right (Rabs a - Rabs b)); [ reflexivity | apply Rle_ge; apply Rplus_le_reg_l with (Rabs b); rewrite Rplus_0_r; - replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a); - [ assumption | ring ] ]. -Qed. + replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a); + [ assumption | ring ] ]. +Qed. (*********) Lemma Rabs_def1 : forall x a:R, x < a -> - a < x -> Rabs x < a. @@ -462,13 +589,13 @@ Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x. Proof. unfold Rabs in |- *; intro x; case (Rcase_abs x); intros. generalize (Ropp_gt_lt_0_contravar x r); unfold Rgt in |- *; intro; - generalize (Rlt_trans 0 (- x) a H0 H); intro; split. + generalize (Rlt_trans 0 (- x) a H0 H); intro; split. apply (Rlt_trans x 0 a r H1). generalize (Ropp_lt_gt_contravar (- x) a H); rewrite (Ropp_involutive x); unfold Rgt in |- *; trivial. fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H r); intro; generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a) in |- *; - generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt in |- *; + generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt in |- *; intro; split; assumption. Qed. @@ -506,4 +633,9 @@ Proof. intros p0; rewrite Rabs_Ropp. apply Rabs_right; auto with real zarith. Qed. - + +Lemma abs_IZR : forall z, IZR (Zabs z) = Rabs (IZR z). +Proof. + intros. + now rewrite Rabs_Zabs. +Qed. diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v index d7fee9c5..27d5c49e 100644 --- a/theories/Reals/Rcomplete.v +++ b/theories/Reals/Rcomplete.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rcomplete.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index 002ce8d6..023cfc93 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -5,13 +5,14 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rdefinitions.v 10751 2008-04-04 10:23:35Z herbelin $ i*) +(*i $Id$ i*) (*********************************************************) (** Definitions for the axiomatization *) (*********************************************************) +Declare ML Module "r_syntax_plugin". Require Export ZArith_base. Parameter R : Set. @@ -29,8 +30,8 @@ Parameter R1 : R. Parameter Rplus : R -> R -> R. Parameter Rmult : R -> R -> R. Parameter Ropp : R -> R. -Parameter Rinv : R -> R. -Parameter Rlt : R -> R -> Prop. +Parameter Rinv : R -> R. +Parameter Rlt : R -> R -> Prop. Parameter up : R -> Z. Infix "+" := Rplus : R_scope. diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v index ba42bad9..55982aa5 100644 --- a/theories/Reals/Rderiv.v +++ b/theories/Reals/Rderiv.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rderiv.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) (*********************************************************) (** Definition of the derivative,continuity *) @@ -39,15 +39,15 @@ Lemma cont_deriv : D_in f d D x0 -> continue_in f D x0. Proof. unfold continue_in in |- *; unfold D_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; unfold Rdiv in |- *; simpl in |- *; - intros; elim (H eps H0); clear H; intros; elim H; + unfold limit_in in |- *; unfold Rdiv in |- *; simpl in |- *; + intros; elim (H eps H0); clear H; intros; elim H; clear H; intros; elim (Req_dec (d x0) 0); intro. split with (Rmin 1 x); split. elim (Rmin_Rgt 1 x 0); intros a b; apply (b (conj Rlt_0_1 H)). intros; elim H3; clear H3; intros; generalize (let (H1, H2) := Rmin_Rgt 1 x (R_dist x1 x0) in H1); - unfold Rgt in |- *; intro; elim (H5 H4); clear H5; - intros; generalize (H1 x1 (conj H3 H6)); clear H1; + unfold Rgt in |- *; intro; elim (H5 H4); clear H5; + intros; generalize (H1 x1 (conj H3 H6)); clear H1; intro; unfold D_x in H3; elim H3; intros. rewrite H2 in H1; unfold R_dist in |- *; unfold R_dist in H1; cut (Rabs (f x1 - f x0) < eps * Rabs (x1 - x0)). @@ -84,10 +84,10 @@ Proof. generalize (let (H1, H2) := Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) (R_dist x1 x0) in - H1); unfold Rgt in |- *; intro; elim (H5 H4); clear H5; + H1); unfold Rgt in |- *; intro; elim (H5 H4); clear H5; intros; generalize (let (H1, H2) := Rmin_Rgt (/ 2) x (R_dist x1 x0) in H1); - unfold Rgt in |- *; intro; elim (H7 H5); clear H7; - intros; clear H4 H5; generalize (H1 x1 (conj H3 H8)); + unfold Rgt in |- *; intro; elim (H7 H5); clear H7; + intros; clear H4 H5; generalize (H1 x1 (conj H3 H8)); clear H1; intro; unfold D_x in H3; elim H3; intros; generalize (sym_not_eq H5); clear H5; intro H5; generalize (Rminus_eq_contra x1 x0 H5); intro; generalize H1; @@ -114,11 +114,11 @@ Proof. rewrite (Rinv_r (Rabs (x1 - x0)) (Rabs_no_R0 (x1 - x0) H9)); rewrite (let (H1, H2) := Rmult_ne (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) in H2) - ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0)); + ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0)); intro; rewrite (Rmult_comm (x1 - x0) (- d x0)); rewrite (Ropp_mult_distr_l_reverse (d x0) (x1 - x0)); fold (f x1 - f x0 - d x0 * (x1 - x0)) in |- *; - rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1; + rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1; intro; generalize (Rle_lt_trans (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0))) @@ -132,15 +132,15 @@ Proof. rewrite <- (Rplus_assoc (Rabs (d x0 * (x1 - x0))) (- Rabs (d x0 * (x1 - x0))) (Rabs (f x1 - f x0))); rewrite (Rplus_opp_r (Rabs (d x0 * (x1 - x0)))); - rewrite (let (H1, H2) := Rplus_ne (Rabs (f x1 - f x0)) in H2); + rewrite (let (H1, H2) := Rplus_ne (Rabs (f x1 - f x0)) in H2); clear H1; intro; cut (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps < eps). intro; apply (Rlt_trans (Rabs (f x1 - f x0)) - (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps) eps H1 H11). + (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps) eps H1 H11). clear H1 H5 H3 H10; generalize (Rabs_pos_lt (d x0) H2); intro; unfold Rgt in H0; - generalize (Rmult_lt_compat_l eps (R_dist x1 x0) (/ 2) H0 H7); + generalize (Rmult_lt_compat_l eps (R_dist x1 x0) (/ 2) H0 H7); clear H7; intro; generalize (Rmult_lt_compat_l (Rabs (d x0)) (R_dist x1 x0) ( @@ -164,11 +164,11 @@ Proof. intro; rewrite H7 in H5; generalize (Rplus_lt_compat (Rabs (d x0 * (x1 - x0))) (eps * / 2) - (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro; + (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro; rewrite eps2 in H10; assumption. unfold Rabs in |- *; case (Rcase_abs 2); auto. intro; cut (0 < 2). - intro; generalize (Rlt_asym 0 2 H7); intro; elimtype False; auto. + intro; generalize (Rlt_asym 0 2 H7); intro; exfalso; auto. fourier. apply Rabs_no_R0. discrR. @@ -180,7 +180,7 @@ Lemma Dconst : forall (D:R -> Prop) (y x0:R), D_in (fun x:R => y) (fun x:R => 0) D x0. Proof. unfold D_in in |- *; intros; unfold limit1_in in |- *; - unfold limit_in in |- *; unfold Rdiv in |- *; intros; + unfold limit_in in |- *; unfold Rdiv in |- *; intros; simpl in |- *; split with eps; split; auto. intros; rewrite (Rminus_diag_eq y y (refl_equal y)); rewrite Rmult_0_l; unfold R_dist in |- *; rewrite (Rminus_diag_eq 0 0 (refl_equal 0)); @@ -195,7 +195,7 @@ Lemma Dx : forall (D:R -> Prop) (x0:R), D_in (fun x:R => x) (fun x:R => 1) D x0. Proof. unfold D_in in |- *; unfold Rdiv in |- *; intros; unfold limit1_in in |- *; - unfold limit_in in |- *; intros; simpl in |- *; split with eps; + unfold limit_in in |- *; intros; simpl in |- *; split with eps; split; auto. intros; elim H0; clear H0; intros; unfold D_x in H0; elim H0; intros; rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (sym_not_eq H3))); @@ -204,7 +204,7 @@ Proof. absurd (0 < 0); auto. red in |- *; intro; apply (Rlt_irrefl 0 r). unfold Rgt in H; assumption. -Qed. +Qed. (*********) Lemma Dadd : @@ -218,9 +218,9 @@ Proof. (limit_plus (fun x:R => (f x - f x0) * / (x - x0)) (fun x:R => (g x - g x0) * / (x - x0)) (D_x D x0) ( df x0) (dg x0) x0 H H0); clear H H0; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; intros; elim (H eps H0); - clear H; intros; elim H; clear H; intros; split with x; - split; auto; intros; generalize (H1 x1 H2); clear H1; + unfold limit_in in |- *; simpl in |- *; intros; elim (H eps H0); + clear H; intros; elim H; clear H; intros; split with x; + split; auto; intros; generalize (H1 x1 H2); clear H1; intro; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1; rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1; rewrite <- (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) (g x1 - g x0)) @@ -239,11 +239,11 @@ Lemma Dmult : D_in (fun x:R => f x * g x) (fun x:R => df x * g x + f x * dg x) D x0. Proof. intros; unfold D_in in |- *; generalize H H0; intros; unfold D_in in H, H0; - generalize (cont_deriv f df D x0 H1); unfold continue_in in |- *; + generalize (cont_deriv f df D x0 H1); unfold continue_in in |- *; intro; generalize (limit_mul (fun x:R => (g x - g x0) * / (x - x0)) ( - fun x:R => f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3); + fun x:R => f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3); intro; cut (limit1_in (fun x:R => g x0) (D_x D x0) (g x0) x0). intro; generalize @@ -253,11 +253,11 @@ Proof. generalize (limit_plus (fun x:R => (f x - f x0) * / (x - x0) * g x0) (fun x:R => (g x - g x0) * / (x - x0) * f x) ( - D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4); - clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H; - simpl in H; unfold limit1_in in |- *; unfold limit_in in |- *; - simpl in |- *; intros; elim (H eps H0); clear H; intros; - elim H; clear H; intros; split with x; split; auto; + D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4); + clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H; + simpl in H; unfold limit1_in in |- *; unfold limit_in in |- *; + simpl in |- *; intros; elim (H eps H0); clear H; intros; + elim H; clear H; intros; split with x; split; auto; intros; generalize (H1 x1 H2); clear H1; intro; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1; rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1; @@ -275,7 +275,7 @@ Proof. ring. unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; split with eps; split; auto; intros; elim (R_dist_refl (g x0) (g x0)); - intros a b; rewrite (b (refl_equal (g x0))); unfold Rgt in H; + intros a b; rewrite (b (refl_equal (g x0))); unfold Rgt in H; assumption. Qed. @@ -287,7 +287,7 @@ Proof. intros; generalize (Dmult D (fun _:R => 0) df (fun _:R => a) f x0 (Dconst D a x0) H); unfold D_in in |- *; intros; rewrite (Rmult_0_l (f x0)) in H0; - rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0; + rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0; assumption. Qed. @@ -297,9 +297,9 @@ Lemma Dopp : D_in f df D x0 -> D_in (fun x:R => - f x) (fun x:R => - df x) D x0. Proof. intros; generalize (Dmult_const D f df x0 (-1) H); unfold D_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; - intros; generalize (H0 eps H1); clear H0; intro; elim H0; - clear H0; intros; elim H0; clear H0; simpl in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; + intros; generalize (H0 eps H1); clear H0; intro; elim H0; + clear H0; intros; elim H0; clear H0; simpl in |- *; intros; split with x; split; auto. intros; generalize (H2 x1 H3); clear H2; intro; rewrite Ropp_mult_distr_l_reverse in H2; @@ -307,7 +307,7 @@ Proof. rewrite Ropp_mult_distr_l_reverse in H2; rewrite (let (H1, H2) := Rmult_ne (f x1) in H2) in H2; rewrite (let (H1, H2) := Rmult_ne (f x0) in H2) in H2; - rewrite (let (H1, H2) := Rmult_ne (df x0) in H2) in H2; + rewrite (let (H1, H2) := Rmult_ne (df x0) in H2) in H2; assumption. Qed. @@ -319,8 +319,8 @@ Lemma Dminus : D_in (fun x:R => f x - g x) (fun x:R => df x - dg x) D x0. Proof. unfold Rminus in |- *; intros; generalize (Dopp D g dg x0 H0); intro; - apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0); - assumption. + apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0); + assumption. Qed. (*********) @@ -336,8 +336,8 @@ Proof. (Dmult D (fun _:R => 1) (fun x:R => INR n0 * x ^ (n0 - 1)) ( fun x:R => x) (fun x:R => x ^ n0) x0 (Dx D x0) ( H D x0)); unfold D_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; intros; elim (H0 eps H1); - clear H0; intros; elim H0; clear H0; intros; split with x; + unfold limit_in in |- *; simpl in |- *; intros; elim (H0 eps H1); + clear H0; intros; elim H0; clear H0; intros; split with x; split; auto. intros; generalize (H2 x1 H3); clear H2 H3; intro; rewrite (let (H1, H2) := Rmult_ne (x0 ^ n0) in H2) in H2; @@ -365,9 +365,9 @@ Proof. unfold Rdiv in |- *; intros; generalize (limit_comp f (fun x:R => (g x - g (f x0)) * / (x - f x0)) ( - D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0); - intro; generalize (cont_deriv f df Df x0 H); intro; - unfold continue_in in H4; generalize (H3 H4 H2); clear H3; + D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0); + intro; generalize (cont_deriv f df Df x0 H); intro; + unfold continue_in in H4; generalize (H3 H4 H2); clear H3; intro; generalize (limit_mul (fun x:R => (g (f x) - g (f x0)) * / (f x - f x0)) @@ -381,16 +381,16 @@ Proof. generalize (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) ( fun x:R => dg (f x0)) (D_x Df x0) (df x0) (dg (f x0)) x0 H1 - (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0)); - intro; unfold limit1_in in |- *; unfold limit_in in |- *; + (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0)); + intro; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; unfold limit1_in in H5, H7; unfold limit_in in H5, H7; - simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8); - clear H5 H7; intros; elim H5; elim H7; clear H5 H7; + simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8); + clear H5 H7; intros; elim H5; elim H7; clear H5 H7; intros; split with (Rmin x x1); split. elim (Rmin_Rgt x x1 0); intros a b; apply (b (conj H9 H5)); clear a b. intros; elim H11; clear H11; intros; elim (Rmin_Rgt x x1 (R_dist x2 x0)); - intros a b; clear b; unfold Rgt in a; elim (a H12); - clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10; + intros a b; clear b; unfold Rgt in a; elim (a H12); + clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10; clear H12; elim (classic (f x2 = f x0)); intro. elim H11; clear H11; intros; elim H11; clear H11; intros; generalize (H10 x2 (conj (conj H11 H14) H5)); intro; @@ -412,12 +412,12 @@ Proof. rewrite (let (H1, H2) := Rmult_ne (/ (x2 - x0)) in H2) in H15; rewrite (Rmult_comm (df x0) (dg (f x0))); assumption. clear H5 H3 H4 H2; unfold limit1_in in |- *; unfold limit_in in |- *; - simpl in |- *; unfold limit1_in in H1; unfold limit_in in H1; - simpl in H1; intros; elim (H1 eps H2); clear H1; intros; - elim H1; clear H1; intros; split with x; split; auto; - intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4; + simpl in |- *; unfold limit1_in in H1; unfold limit_in in H1; + simpl in H1; intros; elim (H1 eps H2); clear H1; intros; + elim H1; clear H1; intros; split with x; split; auto; + intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4; intros; elim H4; clear H4; intros; exact (H3 x1 (conj H4 H5)). -Qed. +Qed. (*********) Lemma D_pow_n : @@ -430,11 +430,11 @@ Proof. intros n D x0 expr dexpr H; generalize (Dcomp D D dexpr (fun x:R => INR n * x ^ (n - 1)) expr ( - fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0))); + fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0))); intro; unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; unfold D_in in H0; - unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; - elim (H0 eps H1); clear H0; intros; elim H0; clear H0; + unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; + elim (H0 eps H1); clear H0; intros; elim H0; clear H0; intros; split with x; split; intros; auto. cut (dexpr x0 * (INR n * expr x0 ^ (n - 1)) = diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v index 906f4977..d18213db 100644 --- a/theories/Reals/Reals.v +++ b/theories/Reals/Reals.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Reals.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) (** The library REALS is divided in 6 parts : - Rbase: basic lemmas on R @@ -23,7 +23,7 @@ - Sup: for goals like ``?1 0. Proof. intro; red in |- *; intro; apply (not_O_INR (fact n) (fact_neq_0 n)); assumption. -Qed. +Qed. (*********) Lemma fact_simpl : forall n:nat, fact (S n) = (S n * fact n)%nat. Proof. intro; reflexivity. -Qed. +Qed. (*********) Lemma simpl_fact : @@ -113,7 +113,7 @@ Hint Resolve pow_lt: real. Lemma Rlt_pow_R1 : forall (x:R) (n:nat), 1 < x -> (0 < n)%nat -> 1 < x ^ n. Proof. intros x n; elim n; simpl in |- *; auto with real. - intros H' H'0; elimtype False; omega. + intros H' H'0; exfalso; omega. intros n0; case n0. simpl in |- *; rewrite Rmult_1_r; auto. intros n1 H' H'0 H'1. @@ -160,7 +160,7 @@ Proof. rewrite <- (let (H1, H2) := Rmult_ne (x ^ a) in H1); rewrite (Rmult_comm (INR n) (x ^ a)); rewrite <- (Rmult_plus_distr_l (x ^ a) 1 (INR n)); - rewrite (Rplus_comm 1 (INR n)); rewrite <- (S_INR n); + rewrite (Rplus_comm 1 (INR n)); rewrite <- (S_INR n); apply Rmult_comm. Qed. @@ -185,7 +185,7 @@ Proof. fold (x > 0) in H; apply (Rlt_0_sqr x (Rlt_dichotomy_converse x 0 (or_intror (x < 0) H))). rewrite (S_INR n0); ring. - unfold Rle in H0; elim H0; intro. + unfold Rle in H0; elim H0; intro. unfold Rle in |- *; left; apply Rmult_lt_compat_l. rewrite Rplus_comm; apply (Rle_lt_0_plus_1 x (Rlt_le 0 x H)). assumption. @@ -288,7 +288,7 @@ Lemma pow_lt_1_zero : 0 < y -> exists N : nat, (forall n:nat, (n >= N)%nat -> Rabs (x ^ n) < y). Proof. - intros; elim (Req_dec x 0); intro. + intros; elim (Req_dec x 0); intro. exists 1%nat; rewrite H1; intros n GE; rewrite pow_ne_zero. rewrite Rabs_R0; assumption. inversion GE; auto. @@ -619,6 +619,18 @@ Proof. unfold Zpower_nat in |- *; auto. Qed. +Lemma Zpower_pos_powerRZ : + forall n m, IZR (Zpower_pos n m) = IZR n ^Z Zpos m. +Proof. + intros. + rewrite Zpower_pos_nat; simpl. + induction (nat_of_P m). + easy. + unfold Zpower_nat; simpl. + rewrite mult_IZR. + now rewrite <- IHn0. +Qed. + Lemma powerRZ_lt : forall (x:R) (z:Z), 0 < x -> 0 < x ^Z z. Proof. intros x z; case z; simpl in |- *; auto with real. @@ -664,7 +676,7 @@ Definition decimal_exp (r:R) (z:Z) : R := (r * 10 ^Z z). (** * Sum of n first naturals *) (*******************************) (*********) -Boxed Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) {struct n} : nat := +Boxed Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) : nat := match n with | O => f 0%nat | S n' => (sum_nat_f_O f n' + f (S n'))%nat @@ -684,7 +696,7 @@ Definition sum_nat (s n:nat) : nat := sum_nat_f s n (fun x:nat => x). (** * Sum *) (*******************************) (*********) -Fixpoint sum_f_R0 (f:nat -> R) (N:nat) {struct N} : R := +Fixpoint sum_f_R0 (f:nat -> R) (N:nat) : R := match N with | O => f 0%nat | S i => sum_f_R0 f i + f (S i) @@ -744,9 +756,9 @@ Proof. unfold R_dist in |- *; 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); - intro; unfold Rgt in H; elimtype False; auto. + intro; unfold Rgt in H; exfalso; auto. generalize (minus_Rge y x r); intro; generalize (minus_Rge x y r0); intro; - generalize (Rge_antisym x y H0 H); intro; rewrite H1; + generalize (Rge_antisym x y H0 H); intro; rewrite H1; ring. Qed. @@ -759,7 +771,7 @@ Proof. rewrite (Ropp_minus_distr x y); generalize (sym_eq H); intro; apply (Rminus_diag_eq y x H0). apply (Rminus_diag_uniq x y H). - apply (Rminus_diag_eq x y H). + apply (Rminus_diag_eq x y H). Qed. Lemma R_dist_eq : forall x:R, R_dist x x = 0. diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v index c96ae5d6..8890cbb5 100644 --- a/theories/Reals/Rgeom.v +++ b/theories/Reals/Rgeom.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rgeom.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -32,7 +32,7 @@ Proof. Qed. Lemma distance_symm : - forall x0 y0 x1 y1:R, dist_euc x0 y0 x1 y1 = dist_euc x1 y1 x0 y0. + forall x0 y0 x1 y1:R, dist_euc x0 y0 x1 y1 = dist_euc x1 y1 x0 y0. Proof. intros x0 y0 x1 y1; unfold dist_euc in |- *; apply Rsqr_inj; [ apply sqrt_positivity; apply Rplus_le_le_0_compat @@ -187,7 +187,7 @@ Lemma isometric_rot_trans : forall x1 y1 x2 y2 tx ty theta:R, Rsqr (x1 - x2) + Rsqr (y1 - y2) = Rsqr (xr (xt x1 tx) (yt y1 ty) theta - xr (xt x2 tx) (yt y2 ty) theta) + - Rsqr (yr (xt x1 tx) (yt y1 ty) theta - yr (xt x2 tx) (yt y2 ty) theta). + Rsqr (yr (xt x1 tx) (yt y1 ty) theta - yr (xt x2 tx) (yt y2 ty) theta). Proof. intros; rewrite <- isometric_rotation_0; apply isometric_translation. Qed. @@ -196,7 +196,7 @@ Lemma isometric_trans_rot : forall x1 y1 x2 y2 tx ty theta:R, Rsqr (x1 - x2) + Rsqr (y1 - y2) = Rsqr (xt (xr x1 y1 theta) tx - xt (xr x2 y2 theta) tx) + - Rsqr (yt (yr x1 y1 theta) ty - yt (yr x2 y2 theta) ty). + Rsqr (yt (yr x1 y1 theta) ty - yt (yr x2 y2 theta) ty). Proof. intros; rewrite <- isometric_translation; apply isometric_rotation_0. Qed. diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index 8d069e2d..ae2c3d77 100644 --- a/theories/Reals/RiemannInt.v +++ b/theories/Reals/RiemannInt.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* R) (a b:R) : Type := Rmin a b <= t <= Rmax a b -> Rabs (f t - phi t) <= psi t) /\ Rabs (RiemannInt_SF psi) < eps } }. -Definition phi_sequence (un:nat -> posreal) (f:R -> R) - (a b:R) (pr:Riemann_integrable f a b) (n:nat) := +Definition phi_sequence (un:nat -> posreal) (f:R -> R) + (a b:R) (pr:Riemann_integrable f a b) (n:nat) := projT1 (pr (un n)). Lemma phi_sequence_prop : @@ -54,7 +55,7 @@ Lemma RiemannInt_P1 : Proof. unfold Riemann_integrable in |- *; intros; elim (X eps); clear X; intros; elim p; clear p; intros; exists (mkStepFun (StepFun_P6 (pre x))); - exists (mkStepFun (StepFun_P6 (pre x0))); + exists (mkStepFun (StepFun_P6 (pre x0))); elim p; clear p; intros; split. intros; apply (H t); elim H1; clear H1; intros; split; [ apply Rle_trans with (Rmin b a); try assumption; right; @@ -97,7 +98,7 @@ Proof. elim (H _ H3); intros N0 H4; exists N0; intros; unfold R_dist in |- *; unfold R_dist in H4; elim (H1 n); elim (H1 m); intros; replace (RiemannInt_SF (vn n) - RiemannInt_SF (vn m)) with - (RiemannInt_SF (vn n) + -1 * RiemannInt_SF (vn m)); + (RiemannInt_SF (vn n) + -1 * RiemannInt_SF (vn m)); [ idtac | ring ]; rewrite <- StepFun_P30; apply Rle_lt_trans with (RiemannInt_SF @@ -131,7 +132,7 @@ Proof. apply Rplus_le_compat; apply RRle_abs. replace (pos (un n)) with (un n - 0); [ idtac | ring ]; replace (pos (un m)) with (un m - 0); [ idtac | ring ]; - rewrite (double_var eps); apply Rplus_lt_compat; apply H4; + rewrite (double_var eps); apply Rplus_lt_compat; apply H4; assumption. Qed. @@ -179,8 +180,8 @@ Proof. rewrite Rabs_Ropp in H4; apply H4. apply H4. assert (H3 := RiemannInt_P2 _ _ _ _ H H1 H2); elim H3; intros; - exists (- x); unfold Un_cv in |- *; unfold Un_cv in p; - intros; elim (p _ H4); intros; exists x0; intros; + exists (- x); unfold Un_cv in |- *; unfold Un_cv in p; + intros; elim (p _ H4); intros; exists x0; intros; generalize (H5 _ H6); unfold R_dist, RiemannInt_SF in |- *; case (Rle_dec b a); case (Rle_dec a b); intros. elim n; assumption. @@ -189,7 +190,7 @@ Proof. (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (vn n0))))) (subdivision (mkStepFun (StepFun_P6 (pre (vn n0)))))); [ unfold Rminus in |- *; rewrite Ropp_involutive; rewrite <- Rabs_Ropp; - rewrite Ropp_plus_distr; rewrite Ropp_involutive; + rewrite Ropp_plus_distr; rewrite Ropp_involutive; apply H7 | symmetry in |- *; apply StepFun_P17 with (fe (vn n0)) a b; [ apply StepFun_P1 @@ -200,7 +201,7 @@ Proof. Qed. Lemma RiemannInt_exists : - forall (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) + forall (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) (un:nat -> posreal), Un_cv un 0 -> { l:R | Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr N)) l }. @@ -281,7 +282,7 @@ Proof. assumption. replace (pos (un n)) with (Rabs (un n - 0)); [ apply H; unfold ge in |- *; apply le_trans with N; try assumption; - unfold N in |- *; apply le_trans with (max N0 N1); + unfold N in |- *; apply le_trans with (max N0 N1); apply le_max_l | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; left; apply (cond_pos (un n)) ]. @@ -346,7 +347,7 @@ Proof. unfold N in |- *; apply le_trans with (max N0 N1); [ apply le_max_r | apply le_max_l ] | unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; + rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; left; apply (cond_pos (vn n)) ]. apply Rlt_trans with (pos (un n)). elim H6; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_un)). @@ -354,7 +355,7 @@ Proof. assumption. replace (pos (un n)) with (Rabs (un n - 0)); [ apply H; unfold ge in |- *; apply le_trans with N; try assumption; - unfold N in |- *; apply le_trans with (max N0 N1); + unfold N in |- *; apply le_trans with (max N0 N1); apply le_max_l | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; left; apply (cond_pos (un n)) ]. @@ -382,7 +383,7 @@ Proof. apply le_IZR; left; apply Rlt_trans with (/ eps); [ apply Rinv_0_lt_compat; assumption | assumption ]. elim (IZN _ H2); intros; exists x; intros; unfold R_dist in |- *; - simpl in |- *; unfold Rminus in |- *; rewrite Ropp_0; + simpl in |- *; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; assert (H5 : 0 < INR n + 1). apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ]. rewrite Rabs_right; @@ -406,7 +407,7 @@ Proof. red in |- *; intro; rewrite H6 in H; elim (Rlt_irrefl _ H). 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. @@ -416,14 +417,14 @@ Lemma RiemannInt_P5 : Proof. intros; unfold RiemannInt in |- *; case (RiemannInt_exists pr1 RinvN RinvN_cv); - case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; + case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; eapply UL_sequence; [ apply u0 | apply RiemannInt_P4 with pr2 RinvN; apply RinvN_cv || assumption ]. Qed. (***************************************) -(** C([a,b]) is included in L1([a,b]) *) +(** C°([a,b]) is included in L1([a,b]) *) (***************************************) Lemma maxN : @@ -452,8 +453,8 @@ Proof. apply le_IZR; simpl in |- *; left; apply Rle_lt_trans with ((b - a) / del); assumption. assert (H5 := IZN _ H4); elim H5; clear H5; intros N H5; - unfold Nbound in |- *; exists N; intros; unfold I in H6; - apply INR_le; rewrite H5 in H2; rewrite <- INR_IZR_INZ in H2; + unfold Nbound in |- *; exists N; intros; unfold I in H6; + apply INR_le; rewrite H5 in H2; rewrite <- INR_IZR_INZ in H2; left; apply Rle_lt_trans with ((b - a) / del); try assumption; apply Rmult_le_reg_l with (pos del); [ apply (cond_pos del) @@ -465,7 +466,7 @@ Proof. elim (Rlt_irrefl _ H7) ] ]. Qed. -Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) {struct N} : Rlist := +Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) : Rlist := match N with | O => cons y nil | S p => cons x (SubEquiN p (x + del) y del) @@ -498,11 +499,11 @@ Proof. a <= y <= b -> Rabs (x - y) < l -> Rabs (f x - f y) < eps)); assert (H1 : bound E). unfold bound in |- *; exists (b - a); unfold is_upper_bound in |- *; intros; - unfold E in H1; elim H1; clear H1; intros H1 _; elim H1; + unfold E in H1; elim H1; clear H1; intros H1 _; elim H1; intros; assumption. assert (H2 : exists x : R, E x). assert (H2 := Heine f (fun x:R => a <= x <= b) (compact_P3 a b) H0 eps); - elim H2; intros; exists (Rmin x (b - a)); unfold E in |- *; + elim H2; intros; exists (Rmin x (b - a)); unfold E in |- *; split; [ split; [ unfold Rmin in |- *; case (Rle_dec x (b - a)); intro; @@ -530,7 +531,7 @@ Proof. unfold is_lub in p; unfold is_upper_bound in p; elim p; clear p; intros; split. elim H2; intros; assert (H7 := H4 _ H6); unfold E in H6; elim H6; clear H6; - intros H6 _; elim H6; intros; apply Rlt_le_trans with x0; + intros H6 _; elim H6; intros; apply Rlt_le_trans with x0; assumption. apply H5; intros; unfold E in H6; elim H6; clear H6; intros H6 _; elim H6; intros; assumption. @@ -579,7 +580,7 @@ Proof. | intros; change (pos_Rl (SubEquiN (S n) (a0 + del0) b del0) - (pred (Rlength (SubEquiN (S n) (a0 + del0) b del0))) = b) + (pred (Rlength (SubEquiN (S n) (a0 + del0) b del0))) = b) in |- *; apply H ] ]. Qed. @@ -633,7 +634,7 @@ Proof. 2: apply le_lt_n_Sm; assumption. apply Rplus_le_compat_l; rewrite S_INR; rewrite Rmult_plus_distr_r; pattern (INR i * del) at 1 in |- *; rewrite <- Rplus_0_r; - apply Rplus_le_compat_l; rewrite Rmult_1_l; left; + apply Rplus_le_compat_l; rewrite Rmult_1_l; left; apply (cond_pos del). Qed. @@ -686,7 +687,7 @@ Proof. [ reflexivity | elim n; left; assumption ]. elim (Heine_cor2 H0 (mkposreal _ H1)); intros del H4; elim (SubEqui_P9 del f H); intros phi [H5 H6]; split with phi; - split with (mkStepFun (StepFun_P4 a b (eps / (2 * (b - a))))); + split with (mkStepFun (StepFun_P4 a b (eps / (2 * (b - a))))); split. 2: rewrite StepFun_P18; unfold Rdiv in |- *; rewrite Rinv_mult_distr. 2: do 2 rewrite Rmult_assoc; rewrite <- Rinv_l_sym. @@ -731,7 +732,7 @@ Proof. apply Rplus_lt_reg_r 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; + (t - pos_Rl (SubEqui del H) (max_N del H))) with t; [ idtac | ring ]; apply Rlt_le_trans with b. rewrite H14 in H12; assert (H13 : S (max_N del H) = pred (Rlength (SubEqui del H))). @@ -760,20 +761,20 @@ Proof. intros; assumption. assert (H4 : Nbound I). unfold Nbound in |- *; exists (S (max_N del H)); intros; unfold max_N in |- *; - case (maxN del H); intros; elim a0; clear a0; intros _ H5; + case (maxN del H); intros; elim a0; clear a0; intros _ H5; apply INR_le; apply Rmult_le_reg_l with (pos del). apply (cond_pos del). apply Rplus_le_reg_l with a; do 2 rewrite (Rmult_comm del); apply Rle_trans with t0; unfold I in H4; try assumption; - apply Rle_trans with b; try assumption; elim H8; intros; + 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 in |- *; case (maxN del H); intros; 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 Rle_lt_trans with t0; unfold I in H5; try assumption; - elim a0; intros; apply Rlt_le_trans with b; try assumption; + apply Rle_lt_trans with t0; unfold I in H5; try assumption; + elim a0; intros; apply Rlt_le_trans with b; try assumption; elim H8; intros. elim H11; intro. assumption. @@ -1027,7 +1028,7 @@ Proof. unfold Riemann_integrable in |- *; 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; + intros; split; try assumption; rewrite e; intros; rewrite Rmult_0_l; rewrite Rplus_0_r; apply H; assumption. assert (H : 0 < eps / 2). unfold Rdiv in |- *; apply Rmult_lt_0_compat; @@ -1038,8 +1039,8 @@ Proof. | 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; - split with (mkStepFun (StepFun_P28 l x x0)); elim p0; - elim p; intros; split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2)); + split with (mkStepFun (StepFun_P28 l x x0)); elim p0; + elim p; intros; split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2)); elim p1; elim p2; clear p1 p2 p0 p X X0; intros; split. intros; simpl in |- *; apply Rle_trans with (Rabs (f t - x t) + Rabs (l * (g t - x0 t))). @@ -1098,7 +1099,7 @@ Proof. replace eps with (2 * (eps / 3) + eps / 3). apply Rplus_lt_compat. replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with - (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); + (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); [ idtac | ring ]. rewrite <- StepFun_P30. apply Rle_lt_trans with @@ -1146,7 +1147,7 @@ Proof. apply H; unfold ge in |- *; apply le_trans with N; try assumption; unfold N in |- *; apply le_max_l. unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; + rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; left; apply (cond_pos (un n)). unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N; try assumption; unfold N in |- *; apply le_max_r. @@ -1172,7 +1173,7 @@ Proof. replace eps with (2 * (eps / 3) + eps / 3). apply Rplus_lt_compat. replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with - (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); + (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); [ idtac | ring ]. rewrite <- StepFun_P30. rewrite StepFun_P39. @@ -1238,7 +1239,7 @@ Proof. apply H; unfold ge in |- *; apply le_trans with N; try assumption; unfold N in |- *; apply le_max_l. unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; + rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; left; apply (cond_pos (un n)). unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N; try assumption; unfold N in |- *; apply le_max_r. @@ -1258,7 +1259,7 @@ Proof. intro f; intros; case (Req_dec l 0); intro. pattern l at 2 in |- *; rewrite H0; rewrite Rmult_0_l; rewrite Rplus_0_r; unfold RiemannInt in |- *; case (RiemannInt_exists pr3 RinvN RinvN_cv); - case (RiemannInt_exists pr1 RinvN RinvN_cv); intros; + case (RiemannInt_exists pr1 RinvN RinvN_cv); intros; eapply UL_sequence; [ apply u0 | set (psi1 := fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); @@ -1283,13 +1284,13 @@ Proof. intros; apply u. unfold Un_cv in |- *; intros; unfold RiemannInt in |- *; case (RiemannInt_exists pr1 RinvN RinvN_cv); - case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv in |- *; + case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv in |- *; intros; assert (H2 : 0 < eps / 5). unfold Rdiv in |- *; 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); unfold Un_cv in H4; elim (H4 _ H2); clear H4 H2; intros N1 H4; - assert (H5 : 0 < eps / (5 * Rabs l)). + assert (H5 : 0 < eps / (5 * Rabs l)). unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; @@ -1380,7 +1381,7 @@ Proof. (RiemannInt_SF (phi_sequence RinvN pr3 n) + -1 * (RiemannInt_SF (phi_sequence RinvN pr1 n) + - l * RiemannInt_SF (phi_sequence RinvN pr2 n))); + l * RiemannInt_SF (phi_sequence RinvN pr2 n))); [ idtac | ring ]; do 2 rewrite <- StepFun_P30; assert (H10 : Rmin a b = a). unfold Rmin in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n0; assumption ]. @@ -1421,7 +1422,7 @@ Proof. rewrite Rplus_assoc; apply Rplus_le_compat. elim (H9 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H13. - elim H12; intros; split; left; assumption. + elim H12; intros; split; left; assumption. apply Rle_trans with (Rabs (f x1 - phi_sequence RinvN pr1 n x1) + Rabs l * Rabs (g x1 - phi_sequence RinvN pr2 n x1)). @@ -1487,7 +1488,7 @@ Proof. [ unfold Rdiv in |- *; do 2 rewrite Rmult_plus_distr_l; do 3 rewrite (Rmult_comm 5); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ ring | discrR ] - | discrR ]. + | discrR ]. Qed. Lemma RiemannInt_P13 : @@ -1517,7 +1518,7 @@ Proof. split with (mkStepFun (StepFun_P4 a b c)); split with (mkStepFun (StepFun_P4 a b 0)); split; [ intros; simpl in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r; - rewrite Rabs_R0; unfold fct_cte in |- *; right; + rewrite Rabs_R0; unfold fct_cte in |- *; right; reflexivity | rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0; apply (cond_pos eps) ]. @@ -1546,12 +1547,12 @@ Proof. elim H1; clear H1; intros psi1 H1; set (phi2 := fun n:nat => mkStepFun (StepFun_P4 a b c)); set (psi2 := fun n:nat => mkStepFun (StepFun_P4 a b 0)); - apply RiemannInt_P11 with f RinvN phi2 psi2 psi1; + apply RiemannInt_P11 with f RinvN phi2 psi2 psi1; try assumption. apply RinvN_cv. intro; split. intros; unfold f in |- *; simpl in |- *; unfold Rminus in |- *; - rewrite Rplus_opp_r; rewrite Rabs_R0; unfold fct_cte in |- *; + rewrite Rplus_opp_r; rewrite Rabs_R0; unfold fct_cte in |- *; right; reflexivity. unfold psi2 in |- *; rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0; apply (cond_pos (RinvN n)). @@ -1594,7 +1595,7 @@ Proof. apply Rmult_eq_reg_l with 2; [ unfold Rdiv in |- *; do 2 rewrite (Rmult_comm 2); rewrite (Rmult_plus_distr_r (- l2) ((l1 + l2) * / 2) 2); - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; + repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ ring | discrR ] | discrR ]. apply Ropp_lt_cancel; apply Rplus_lt_reg_r with l1; @@ -1637,7 +1638,7 @@ Proof. Rabs (Rabs (f t) - phi3 n t) <= psi3 n t) /\ Rabs (RiemannInt_SF (psi3 n)) < RinvN n)). split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). assert (H1 : exists psi2 : nat -> StepFun a b, @@ -1674,7 +1675,7 @@ Lemma RiemannInt_P18 : Proof. intro f; intros; unfold RiemannInt in |- *; case (RiemannInt_exists pr1 RinvN RinvN_cv); - case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; + case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; eapply UL_sequence. apply u0. set (phi1 := fun N:nat => phi_sequence RinvN pr1 N); @@ -1688,7 +1689,7 @@ Proof. Rabs (f t - phi1 n t) <= psi1 n t) /\ Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). elim H1; clear H1; intros psi1 H1; set (phi2 := fun N:nat => phi_sequence RinvN pr2 N). set @@ -1712,10 +1713,10 @@ Proof. Rmin a b <= t /\ t <= Rmax a b -> Rabs (g t - phi2 n t) <= psi2 n t) /\ Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). elim H2; clear H2; intros psi2 H2; - apply RiemannInt_P11 with f RinvN phi2_m psi2 psi1; - try assumption. + apply RiemannInt_P11 with f RinvN phi2_m psi2 psi1; + try assumption. apply RinvN_cv. intro; elim (H2 n); intros; split; try assumption. intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *; @@ -1764,11 +1765,11 @@ Proof. right; reflexivity. intro; assert (H2 := pre (phi2 N)); unfold IsStepFun in H2; unfold is_subdivision in H2; elim H2; clear H2; intros l [lf H2]; - split with l; split with lf; unfold adapted_couple in H2; - decompose [and] H2; clear H2; unfold adapted_couple in |- *; + split with l; split with lf; unfold adapted_couple in H2; + decompose [and] H2; clear H2; unfold adapted_couple in |- *; repeat split; try assumption. intros; assert (H9 := H8 i H2); unfold constant_D_eq, open_interval in H9; - unfold constant_D_eq, open_interval in |- *; intros; + unfold constant_D_eq, open_interval in |- *; intros; rewrite <- (H9 x1 H7); assert (H10 : a <= pos_Rl l i). replace a with (Rmin a b). rewrite <- H5; elim (RList_P6 l); intros; apply H10. @@ -1808,7 +1809,7 @@ Proof. (RiemannInt (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))). apply (RiemannInt_P17 (RiemannInt_P10 (-1) pr2 pr1) - (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))); + (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))); assumption. replace (RiemannInt pr2 + - RiemannInt pr1) with (RiemannInt (RiemannInt_P10 (-1) pr2 pr1)). @@ -1833,7 +1834,7 @@ Proof. Qed. Definition primitive (f:R -> R) (a b:R) (h:a <= b) - (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x) + (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x) (x:R) : R := match Rle_dec a x with | left r => @@ -1977,20 +1978,20 @@ Proof. | elim n0; 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; - split with lf1; unfold adapted_couple in H3; decompose [and] H3; - clear H3; unfold adapted_couple in |- *; repeat split; + elim H3; clear H3; intros l1 [lf1 H3]; split with l1; + split with lf1; unfold adapted_couple in H3; decompose [and] H3; + clear H3; unfold adapted_couple in |- *; repeat split; try assumption. intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *; - unfold constant_D_eq, open_interval in H9; intros; + unfold constant_D_eq, open_interval in H9; intros; rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x). apply Rle_lt_trans with (pos_Rl l1 i). replace b with (Rmin b c). rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption. apply le_O_n. apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; - apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; - discriminate. + apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; + discriminate. unfold Rmin in |- *; case (Rle_dec b c); intro; [ reflexivity | elim n; assumption ]. elim H7; intros; assumption. @@ -2000,19 +2001,19 @@ Proof. | elim n; apply Rle_trans with b; [ assumption | left; assumption ] | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ]. assert (H3 := pre psi1); unfold IsStepFun in H3; unfold is_subdivision in H3; - elim H3; clear H3; intros l1 [lf1 H3]; split with l1; - split with lf1; unfold adapted_couple in H3; decompose [and] H3; - clear H3; unfold adapted_couple in |- *; repeat split; + elim H3; clear H3; intros l1 [lf1 H3]; split with l1; + split with lf1; unfold adapted_couple in H3; decompose [and] H3; + clear H3; unfold adapted_couple in |- *; repeat split; try assumption. intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *; - unfold constant_D_eq, open_interval in H9; intros; + unfold constant_D_eq, open_interval in H9; intros; rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b). apply Rle_trans with (pos_Rl l1 (S i)). elim H7; intros; left; assumption. replace b with (Rmax a b). rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption. apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; - discriminate. + discriminate. unfold Rmax in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. assert (H11 : a <= x). @@ -2021,8 +2022,8 @@ Proof. rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption. apply le_O_n. apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; - apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; - discriminate. + apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; + discriminate. unfold Rmin in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. left; elim H7; intros; assumption. @@ -2030,19 +2031,19 @@ Proof. assumption. apply StepFun_P46 with b. assert (H3 := pre phi1); unfold IsStepFun in H3; unfold is_subdivision in H3; - elim H3; clear H3; intros l1 [lf1 H3]; split with l1; - split with lf1; unfold adapted_couple in H3; decompose [and] H3; - clear H3; unfold adapted_couple in |- *; repeat split; + elim H3; clear H3; intros l1 [lf1 H3]; split with l1; + split with lf1; unfold adapted_couple in H3; decompose [and] H3; + clear H3; unfold adapted_couple in |- *; repeat split; try assumption. intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *; - unfold constant_D_eq, open_interval in H9; intros; + unfold constant_D_eq, open_interval in H9; intros; rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b). apply Rle_trans with (pos_Rl l1 (S i)). elim H7; intros; left; assumption. replace b with (Rmax a b). rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption. apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; - discriminate. + discriminate. unfold Rmax in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. assert (H11 : a <= x). @@ -2051,28 +2052,28 @@ Proof. rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption. apply le_O_n. apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; - apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; - discriminate. + apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; + discriminate. unfold Rmin in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. left; elim H7; intros; assumption. unfold phi3 in |- *; case (Rle_dec a x); case (Rle_dec x b); intros; reflexivity || elim n; assumption. assert (H3 := pre phi2); unfold IsStepFun in H3; unfold is_subdivision in H3; - elim H3; clear H3; intros l1 [lf1 H3]; split with l1; - split with lf1; unfold adapted_couple in H3; decompose [and] H3; - clear H3; unfold adapted_couple in |- *; repeat split; + elim H3; clear H3; intros l1 [lf1 H3]; split with l1; + split with lf1; unfold adapted_couple in H3; decompose [and] H3; + clear H3; unfold adapted_couple in |- *; repeat split; try assumption. intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *; - unfold constant_D_eq, open_interval in H9; intros; + unfold constant_D_eq, open_interval in H9; intros; rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x). apply Rle_lt_trans with (pos_Rl l1 i). replace b with (Rmin b c). rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption. apply le_O_n. apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; - apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; - discriminate. + apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; + discriminate. unfold Rmin in |- *; case (Rle_dec b c); intro; [ reflexivity | elim n; assumption ]. elim H7; intros; assumption. @@ -2088,7 +2089,7 @@ Lemma RiemannInt_P22 : Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f a c. Proof. unfold Riemann_integrable in |- *; intros; elim (X eps); clear X; - intros phi [psi H0]; elim H; elim H0; clear H H0; + intros phi [psi H0]; elim H; elim H0; clear H H0; intros; assert (H3 : IsStepFun phi a c). apply StepFun_P44 with b. apply (pre phi). @@ -2178,7 +2179,7 @@ Lemma RiemannInt_P23 : Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f c b. Proof. unfold Riemann_integrable in |- *; intros; elim (X eps); clear X; - intros phi [psi H0]; elim H; elim H0; clear H H0; + intros phi [psi H0]; elim H; elim H0; clear H H0; intros; assert (H3 : IsStepFun phi c b). apply StepFun_P45 with a. apply (pre phi). @@ -2294,7 +2295,7 @@ Proof. intros f a b c pr1 pr2 pr3 Hyp1 Hyp2; unfold RiemannInt in |- *; 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 pr3 RinvN RinvN_cv); intros; symmetry in |- *; eapply UL_sequence. apply u. unfold Un_cv in |- *; intros; assert (H0 : 0 < eps / 3). @@ -2309,7 +2310,7 @@ Proof. (RiemannInt_SF (phi_sequence RinvN pr1 n) + RiemannInt_SF (phi_sequence RinvN pr2 n))) 0). intro; elim (H3 _ H0); clear H3; intros N3 H3; - set (N0 := max (max N1 N2) N3); exists N0; intros; + set (N0 := max (max N1 N2) N3); exists N0; intros; unfold R_dist in |- *; apply Rle_lt_trans with (Rabs @@ -2368,7 +2369,7 @@ Proof. Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\ Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). assert (H2 : exists psi2 : nat -> StepFun b c, @@ -2378,7 +2379,7 @@ Proof. Rabs (f t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\ Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). assert (H3 : exists psi3 : nat -> StepFun a c, @@ -2388,9 +2389,9 @@ Proof. Rabs (f t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\ Rabs (RiemannInt_SF (psi3 n)) < RinvN n)). split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr3 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr3 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr3 n)). elim H1; clear H1; intros psi1 H1; elim H2; clear H2; intros psi2 H2; elim H3; - clear H3; intros psi3 H3; assert (H := RinvN_cv); + clear H3; intros psi3 H3; assert (H := RinvN_cv); unfold Un_cv in |- *; intros; assert (H4 : 0 < eps / 3). unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. @@ -2401,14 +2402,14 @@ Proof. (R_dist (mkposreal (/ (INR n + 1)) (RinvN_pos n)) 0). apply H; assumption. unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; + rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; left; apply (cond_pos (RinvN n)). exists N0; intros; elim (H1 n); elim (H2 n); elim (H3 n); clear H1 H2 H3; - intros; unfold R_dist in |- *; unfold Rminus in |- *; - rewrite Ropp_0; rewrite Rplus_0_r; + intros; unfold R_dist in |- *; unfold Rminus in |- *; + rewrite Ropp_0; rewrite Rplus_0_r; set (phi1 := phi_sequence RinvN pr1 n) in H8 |- *; - set (phi2 := phi_sequence RinvN pr2 n) in H3 |- *; - set (phi3 := phi_sequence RinvN pr3 n) in H1 |- *; + set (phi2 := phi_sequence RinvN pr2 n) in H3 |- *; + set (phi3 := phi_sequence RinvN pr3 n) in H1 |- *; assert (H10 : IsStepFun phi3 a b). apply StepFun_P44 with c. apply (pre phi3). @@ -2832,7 +2833,7 @@ Proof. (derivable_pt_lim ((fct_cte (f b) * (id - fct_cte b))%F + fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b ( - f b + 0)) in |- *. + f b + 0)) in |- *. apply derivable_pt_lim_plus. pattern (f b) at 2 in |- *; replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1). @@ -2899,7 +2900,7 @@ Proof. apply (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))) (RiemannInt_P16 - (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))); + (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))); left; assumption. apply Rle_lt_trans with (RiemannInt (RiemannInt_P14 (b + h0) b (eps / 2)) * Rabs (/ h0)). @@ -2953,13 +2954,13 @@ Proof. rewrite RiemannInt_P15. rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_eq_reg_l with h0; [ repeat rewrite (Rmult_comm h0); unfold Rdiv in |- *; - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; + repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ ring | assumption ] | assumption ]. cut (a <= b + h0). cut (b + h0 <= b). intros; unfold primitive in |- *; case (Rle_dec a (b + h0)); - case (Rle_dec (b + h0) b); case (Rle_dec a b); case (Rle_dec b b); + 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. @@ -3083,7 +3084,7 @@ Proof. apply (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))) (RiemannInt_P16 - (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))); + (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))); left; assumption. apply Rle_lt_trans with (RiemannInt (RiemannInt_P14 a (a + h0) (eps / 2)) * Rabs (/ h0)). @@ -3138,7 +3139,7 @@ Proof. cut (a <= a + h0). cut (a + h0 <= b). intros; unfold primitive in |- *; case (Rle_dec a (a + h0)); - case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); + 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). rewrite RiemannInt_P9; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply RiemannInt_P5. @@ -3174,7 +3175,7 @@ Proof. (derivable_pt_lim ((fct_cte (f b) * (id - fct_cte b))%F + fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b ( - f b + 0)) in |- *. + f b + 0)) in |- *. apply derivable_pt_lim_plus. pattern (f b) at 2 in |- *; replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1). @@ -3198,7 +3199,7 @@ Proof. pattern a at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; assumption. rewrite H1; unfold primitive in |- *; case (Rle_dec a (a + h0)); - case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); + 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)). @@ -3216,7 +3217,7 @@ Proof. assumption. elim H8; symmetry in |- *; assumption. rewrite H0 in H1; rewrite H1; unfold primitive in |- *; - case (Rle_dec a (b + h0)); case (Rle_dec (b + h0) b); + 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)). @@ -3286,7 +3287,7 @@ Proof. intros; apply (cont1 f). rewrite (RiemannInt_P20 H (FTC_P1 H H0) pr); assert (H1 := RiemannInt_P29 H H0); assert (H2 := RiemannInt_P31 f H); - elim (antiderivative_Ucte (derive f (diff0 f)) _ _ _ _ H1 H2); + elim (antiderivative_Ucte (derive f (diff0 f)) _ _ _ _ H1 H2); intros C H3; repeat rewrite H3; [ ring | split; [ right; reflexivity | assumption ] diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index 7a02544e..f9b1b890 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RiemannInt_SF.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -36,8 +36,8 @@ Proof. intros I H H0; set (E := fun x:R => exists i : nat, I i /\ INR i = x); assert (H1 : bound E). unfold Nbound in H0; elim H0; intros N H1; unfold bound in |- *; - exists (INR N); unfold is_upper_bound in |- *; intros; - unfold E in H2; elim H2; intros; elim H3; intros; + exists (INR N); unfold is_upper_bound in |- *; intros; + unfold E in H2; elim H2; intros; elim H3; intros; rewrite <- H5; apply le_INR; apply H1; assumption. assert (H2 : exists x : R, E x). elim H; intros; exists (INR x); unfold E in |- *; exists x; split; @@ -54,13 +54,13 @@ Proof. assert (H9 : x <= IZR (up x) - 1). apply H5; intros; assert (H10 := H4 _ H9); unfold E in H9; elim H9; intros; elim H11; intros; rewrite <- H13; apply Rplus_le_reg_l with 1; - replace (1 + (IZR (up x) - 1)) with (IZR (up x)); + replace (1 + (IZR (up x) - 1)) with (IZR (up x)); [ idtac | ring ]; replace (1 + INR x1) with (INR (S x1)); [ idtac | rewrite S_INR; ring ]. assert (H14 : (0 <= up x)%Z). apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ]. assert (H15 := IZN _ H14); elim H15; clear H15; intros; rewrite H15; - rewrite <- INR_IZR_INZ; apply le_INR; apply lt_le_S; + rewrite <- INR_IZR_INZ; apply le_INR; apply lt_le_S; apply INR_lt; rewrite H13; apply Rle_lt_trans with x; [ assumption | rewrite INR_IZR_INZ; rewrite <- H15; assumption ]. assert (H10 : x = IZR (up x) - 1). @@ -68,7 +68,7 @@ Proof. [ assumption | apply Rplus_le_reg_l with (- x + 1); replace (- x + 1 + (IZR (up x) - 1)) with (IZR (up x) - x); - [ idtac | ring ]; replace (- x + 1 + x) with 1; + [ idtac | ring ]; replace (- x + 1 + x) with 1; [ assumption | ring ] ]. assert (H11 : (0 <= up x)%Z). apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ]. @@ -104,7 +104,7 @@ Proof. simpl in |- *; split. assumption. intros; apply INR_le; rewrite H15; rewrite <- H15; elim H12; intros; - rewrite H20; apply H4; unfold E in |- *; exists i; + rewrite H20; apply H4; unfold E in |- *; exists i; split; [ assumption | reflexivity ]. Qed. @@ -113,7 +113,7 @@ Qed. (*******************************************) Definition open_interval (a b x:R) : Prop := a < x < b. -Definition co_interval (a b x:R) : Prop := a <= x < b. +Definition co_interval (a b x:R) : Prop := a <= x < b. Definition adapted_couple (f:R -> R) (a b:R) (l lf:Rlist) : Prop := ordered_Rlist l /\ @@ -149,7 +149,7 @@ Definition subdivision_val (a b:R) (f:StepFun a b) : Rlist := | existT a b => a end. -Boxed Fixpoint Int_SF (l k:Rlist) {struct l} : R := +Boxed Fixpoint Int_SF (l k:Rlist) : R := match l with | nil => 0 | cons a l' => @@ -174,7 +174,7 @@ Definition RiemannInt_SF (a b:R) (f:StepFun a b) : R := Lemma StepFun_P1 : forall (a b:R) (f:StepFun a b), adapted_couple f a b (subdivision f) (subdivision_val f). -Proof. +Proof. intros a b f; unfold subdivision_val in |- *; case (projT2 (pre f)); intros; apply a0. Qed. @@ -182,7 +182,7 @@ Qed. Lemma StepFun_P2 : forall (a b:R) (f:R -> R) (l lf:Rlist), adapted_couple f a b l lf -> adapted_couple f b a l lf. -Proof. +Proof. unfold adapted_couple in |- *; intros; decompose [and] H; clear H; repeat split; try assumption. rewrite H2; unfold Rmin in |- *; case (Rle_dec a b); intro; @@ -199,7 +199,7 @@ Lemma StepFun_P3 : forall a b c:R, a <= b -> adapted_couple (fct_cte c) a b (cons a (cons b nil)) (cons c nil). -Proof. +Proof. intros; unfold adapted_couple in |- *; repeat split. unfold ordered_Rlist in |- *; intros; simpl in H0; inversion H0; [ simpl in |- *; assumption | elim (le_Sn_O _ H2) ]. @@ -212,19 +212,19 @@ Proof. Qed. Lemma StepFun_P4 : forall a b c:R, IsStepFun (fct_cte c) a b. -Proof. +Proof. intros; unfold IsStepFun in |- *; case (Rle_dec a b); intro. apply existT with (cons a (cons b nil)); unfold is_subdivision in |- *; apply existT with (cons c nil); apply (StepFun_P3 c r). apply existT with (cons b (cons a nil)); unfold is_subdivision in |- *; - apply existT with (cons c nil); apply StepFun_P2; + apply existT with (cons c nil); apply StepFun_P2; apply StepFun_P3; auto with real. Qed. Lemma StepFun_P5 : forall (a b:R) (f:R -> R) (l:Rlist), is_subdivision f a b l -> is_subdivision f b a l. -Proof. +Proof. destruct 1 as (x,(H0,(H1,(H2,(H3,H4))))); exists x; repeat split; try assumption. rewrite H1; apply Rmin_comm. @@ -233,7 +233,7 @@ Qed. Lemma StepFun_P6 : forall (f:R -> R) (a b:R), IsStepFun f a b -> IsStepFun f b a. -Proof. +Proof. unfold IsStepFun in |- *; intros; elim X; intros; apply existT with x; apply StepFun_P5; assumption. Qed. @@ -243,7 +243,7 @@ Lemma StepFun_P7 : a <= b -> adapted_couple f a b (cons r1 (cons r2 l)) (cons r3 lf) -> adapted_couple f r2 b (cons r2 l) lf. -Proof. +Proof. unfold adapted_couple in |- *; intros; decompose [and] H0; clear H0; assert (H5 : Rmax a b = b). unfold Rmax in |- *; case (Rle_dec a b); intro; @@ -258,7 +258,7 @@ Proof. unfold Rmax in |- *; case (Rle_dec r2 b); intro; [ rewrite H5 in H2; rewrite <- H2; reflexivity | elim n; assumption ]. simpl in H4; simpl in |- *; apply INR_eq; apply Rplus_eq_reg_l with 1; - do 2 rewrite (Rplus_comm 1); do 2 rewrite <- S_INR; + do 2 rewrite (Rplus_comm 1); do 2 rewrite <- S_INR; rewrite H4; reflexivity. intros; unfold constant_D_eq, open_interval in |- *; intros; unfold constant_D_eq, open_interval in H6; @@ -270,7 +270,7 @@ Qed. Lemma StepFun_P8 : forall (f:R -> R) (l1 lf1:Rlist) (a b:R), adapted_couple f a b l1 lf1 -> a = b -> Int_SF lf1 l1 = 0. -Proof. +Proof. simple induction l1. intros; induction lf1 as [| r lf1 Hreclf1]; reflexivity. simple induction r0. @@ -285,7 +285,7 @@ Proof. ring. rewrite H3; apply StepFun_P7 with a r r3; [ right; assumption | assumption ]. clear H H0 Hreclf1 r0; unfold adapted_couple in H1; decompose [and] H1; - intros; simpl in H4; rewrite H4; unfold Rmin in |- *; + intros; simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intro; [ assumption | reflexivity ]. unfold adapted_couple in H1; decompose [and] H1; intros; apply Rle_antisym. apply (H3 0%nat); simpl in |- *; apply lt_O_Sn. @@ -299,14 +299,14 @@ Qed. Lemma StepFun_P9 : forall (a b:R) (f:R -> R) (l lf:Rlist), adapted_couple f a b l lf -> a <> b -> (2 <= Rlength l)%nat. -Proof. +Proof. intros; unfold adapted_couple in H; decompose [and] H; clear H; induction l as [| r l Hrecl]; [ simpl in H4; discriminate | induction l as [| r0 l Hrecl0]; [ simpl in H3; simpl in H2; generalize H3; generalize H2; - unfold Rmin, Rmax in |- *; case (Rle_dec a b); - intros; elim H0; rewrite <- H5; rewrite <- H7; + unfold Rmin, Rmax in |- *; case (Rle_dec a b); + intros; elim H0; rewrite <- H5; rewrite <- H7; reflexivity | simpl in |- *; do 2 apply le_n_S; apply le_O_n ] ]. Qed. @@ -317,13 +317,13 @@ Lemma StepFun_P10 : adapted_couple f a b l lf -> exists l' : Rlist, (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). -Proof. +Proof. simple induction l. intros; unfold adapted_couple in H0; decompose [and] H0; simpl in H4; discriminate. intros; case (Req_dec a b); intro. exists (cons a nil); exists nil; unfold adapted_couple_opt in |- *; - unfold adapted_couple in |- *; unfold ordered_Rlist in |- *; + unfold adapted_couple in |- *; unfold ordered_Rlist in |- *; repeat split; try (intros; simpl in H3; elim (lt_n_O _ H3)). simpl in |- *; rewrite <- H2; unfold Rmin in |- *; case (Rle_dec a a); intro; reflexivity. @@ -341,7 +341,7 @@ Proof. replace a with t2. apply H6. rewrite <- Hyp_eq; rewrite H3 in H1; unfold adapted_couple in H1; - decompose [and] H1; clear H1; simpl in H9; rewrite H9; + decompose [and] H1; clear H1; simpl in H9; rewrite H9; unfold Rmin in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. elim H6; clear H6; intros l' [lf' H6]; case (Req_dec t2 b); intro. @@ -360,7 +360,7 @@ Proof. decompose [and] H1; apply (H16 0%nat). simpl in |- *; apply lt_O_Sn. unfold open_interval in |- *; simpl in |- *; rewrite H7; simpl in H13; - rewrite H13; unfold Rmin in |- *; case (Rle_dec a b); + rewrite H13; unfold Rmin in |- *; case (Rle_dec a b); intro; [ assumption | elim n; assumption ]. elim (le_Sn_O _ H10). intros; simpl in H8; elim (lt_n_O _ H8). @@ -377,7 +377,7 @@ Proof. clear Hreclf'; case (Req_dec r1 r2); intro. case (Req_dec (f t2) r1); intro. exists (cons t1 (cons s2 s3)); exists (cons r1 lf'); rewrite H3 in H1; - rewrite H9 in H6; unfold adapted_couple in H6, H1; + rewrite H9 in H6; unfold adapted_couple in H6, H1; decompose [and] H1; decompose [and] H6; clear H1 H6; unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; repeat split. @@ -417,7 +417,7 @@ Proof. change (pos_Rl (cons r2 lf') i <> pos_Rl (cons r2 lf') (S i) \/ f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r2 lf') i) - in |- *; rewrite <- H9; elim H8; intros; apply H6; + in |- *; rewrite <- H9; elim H8; intros; apply H6; simpl in |- *; apply H1. intros; induction i as [| i Hreci]. simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym. @@ -427,7 +427,7 @@ Proof. elim H8; intros; rewrite H9 in H21; apply (H21 (S i)); simpl in |- *; simpl in H1; apply H1. exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6; - rewrite H3 in H1; unfold adapted_couple in H1, H6; + rewrite H3 in H1; unfold adapted_couple in H1, H6; decompose [and] H6; decompose [and] H1; clear H6 H1; unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; repeat split. @@ -438,7 +438,7 @@ Proof. simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity. change (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i)) - in |- *; apply (H12 i); simpl in |- *; apply lt_S_n; + in |- *; apply (H12 i); simpl in |- *; apply lt_S_n; assumption. simpl in |- *; simpl in H19; apply H19. rewrite H9; simpl in |- *; simpl in H13; rewrite H13; unfold Rmax in |- *; @@ -470,7 +470,7 @@ Proof. elim H8; intros; rewrite <- H9; apply (H21 i); rewrite H9; rewrite H9 in H1; simpl in |- *; simpl in H1; apply lt_S_n; apply H1. exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6; - rewrite H3 in H1; unfold adapted_couple in H1, H6; + rewrite H3 in H1; unfold adapted_couple in H1, H6; decompose [and] H6; decompose [and] H1; clear H6 H1; unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; repeat split. @@ -481,7 +481,7 @@ Proof. simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity. change (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i)) - in |- *; apply (H11 i); simpl in |- *; apply lt_S_n; + in |- *; apply (H11 i); simpl in |- *; apply lt_S_n; assumption. simpl in |- *; simpl in H18; apply H18. rewrite H9; simpl in |- *; simpl in H12; rewrite H12; unfold Rmax in |- *; @@ -518,14 +518,14 @@ Proof. Qed. Lemma StepFun_P11 : - forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) + forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) (f:R -> R), a < b -> adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) -> adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2. -Proof. +Proof. intros; unfold adapted_couple_opt in H1; elim H1; clear H1; intros; - unfold adapted_couple in H0, H1; decompose [and] H0; + unfold adapted_couple in H0, H1; decompose [and] H0; decompose [and] H1; clear H0 H1; assert (H12 : r = s1). simpl in H10; simpl in H5; rewrite H10; rewrite H5; reflexivity. assert (H14 := H3 0%nat (lt_O_Sn _)); simpl in H14; elim H14; intro. @@ -542,7 +542,7 @@ Proof. clear Hreclf2; assert (H17 : r3 = r4). set (x := (r + s2) / 2); assert (H17 := H8 0%nat (lt_O_Sn _)); assert (H18 := H13 0%nat (lt_O_Sn _)); - unfold constant_D_eq, open_interval in H17, H18; simpl in H17; + unfold constant_D_eq, open_interval in H17, H18; simpl in H17; simpl in H18; rewrite <- (H17 x). rewrite <- (H18 x). reflexivity. @@ -582,7 +582,7 @@ Proof. | unfold open_interval in |- *; simpl in |- *; split; assumption ]. assert (H19 : r3 = r5). assert (H19 := H7 1%nat); simpl in H19; - assert (H20 := H19 (lt_n_S _ _ (lt_O_Sn _))); elim H20; + assert (H20 := H19 (lt_n_S _ _ (lt_O_Sn _))); elim H20; intro. set (x := (s2 + Rmin r1 r0) / 2); assert (H22 := H8 0%nat); assert (H23 := H13 1%nat); simpl in H22; simpl in H23; @@ -595,7 +595,7 @@ Proof. | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym; [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; - unfold Rmin in |- *; case (Rle_dec r1 r0); intro; + unfold Rmin in |- *; case (Rle_dec r1 r0); intro; assumption | discrR ] ]. apply Rmult_lt_reg_l with 2; @@ -616,7 +616,7 @@ Proof. | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym; [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; - unfold Rmin in |- *; case (Rle_dec r1 r0); + unfold Rmin in |- *; case (Rle_dec r1 r0); intro; assumption | discrR ] ] ]. apply Rmult_lt_reg_l with 2; @@ -630,7 +630,7 @@ Proof. | apply Rplus_le_compat_l; apply Rmin_l ] | discrR ] ]. elim H2; clear H2; intros; assert (H23 := H22 1%nat); simpl in H23; - assert (H24 := H23 (lt_n_S _ _ (lt_O_Sn _))); elim H24; + assert (H24 := H23 (lt_n_S _ _ (lt_O_Sn _))); elim H24; assumption. elim H2; intros; assert (H22 := H20 0%nat); simpl in H22; assert (H23 := H22 (lt_O_Sn _)); elim H23; intro; @@ -644,7 +644,7 @@ Qed. Lemma StepFun_P12 : forall (a b:R) (f:R -> R) (l lf:Rlist), adapted_couple_opt f a b l lf -> adapted_couple_opt f b a l lf. -Proof. +Proof. unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; intros; decompose [and] H; clear H; repeat split; try assumption. rewrite H0; unfold Rmin in |- *; case (Rle_dec a b); intro; @@ -658,12 +658,12 @@ Proof. Qed. Lemma StepFun_P13 : - forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) + forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) (f:R -> R), a <> b -> adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) -> adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2. -Proof. +Proof. intros; case (total_order_T a b); intro. elim s; intro. eapply StepFun_P11; [ apply a0 | apply H0 | apply H1 ]. @@ -677,7 +677,7 @@ Lemma StepFun_P14 : a <= b -> adapted_couple f a b l1 lf1 -> adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2. -Proof. +Proof. simple induction l1. intros l2 lf1 lf2 a b Hyp H H0; unfold adapted_couple in H; decompose [and] H; clear H H0 H2 H3 H1 H6; simpl in H4; discriminate. @@ -705,7 +705,7 @@ Proof. clear H H2 H4 H5 H3 H6 H8 H7 H11; simpl in H9; discriminate. clear Hreclf2; assert (H6 : r = s1). unfold adapted_couple in H, H2; decompose [and] H; decompose [and] H2; - clear H H2; simpl in H13; simpl in H8; rewrite H13; + clear H H2; simpl in H13; simpl in H8; rewrite H13; rewrite H8; reflexivity. assert (H7 : r3 = r4 \/ r = r1). case (Req_dec r r1); intro. @@ -718,7 +718,7 @@ Proof. rewrite <- (H20 (lt_O_Sn _) x). reflexivity. assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21; intro; - [ idtac | elim H7; assumption ]; unfold x in |- *; + [ idtac | elim H7; assumption ]; unfold x in |- *; split. apply Rmult_lt_reg_l with 2; [ prove_sup0 @@ -734,7 +734,7 @@ Proof. apply Rplus_lt_compat_l; apply H | discrR ] ]. rewrite <- H6; assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21; - intro; [ idtac | elim H7; assumption ]; unfold x in |- *; + intro; [ idtac | elim H7; assumption ]; unfold x in |- *; split. apply Rmult_lt_reg_l with 2; [ prove_sup0 @@ -884,7 +884,7 @@ Lemma StepFun_P15 : forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R), adapted_couple f a b l1 lf1 -> adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2. -Proof. +Proof. intros; case (Rle_dec a b); intro; [ apply (StepFun_P14 r H H0) | assert (H1 : b <= a); @@ -897,8 +897,8 @@ Lemma StepFun_P16 : forall (f:R -> R) (l lf:Rlist) (a b:R), adapted_couple f a b l lf -> exists l' : Rlist, - (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). -Proof. + (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). +Proof. intros; case (Rle_dec a b); intro; [ apply (StepFun_P10 r H) | assert (H1 : b <= a); @@ -912,14 +912,14 @@ Lemma StepFun_P17 : forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R), adapted_couple f a b l1 lf1 -> adapted_couple f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2. -Proof. +Proof. intros; elim (StepFun_P16 H); intros l' [lf' H1]; rewrite (StepFun_P15 H H1); rewrite (StepFun_P15 H0 H1); reflexivity. Qed. Lemma StepFun_P18 : forall a b c:R, RiemannInt_SF (mkStepFun (StepFun_P4 a b c)) = c * (b - a). -Proof. +Proof. intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro. replace (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c))) @@ -943,7 +943,7 @@ Lemma StepFun_P19 : forall (l1:Rlist) (f g:R -> R) (l:R), Int_SF (FF l1 (fun x:R => f x + l * g x)) l1 = Int_SF (FF l1 f) l1 + l * Int_SF (FF l1 g) l1. -Proof. +Proof. intros; induction l1 as [| r l1 Hrecl1]; [ simpl in |- *; ring | induction l1 as [| r0 l1 Hrecl0]; simpl in |- *; @@ -953,7 +953,7 @@ Qed. Lemma StepFun_P20 : forall (l:Rlist) (f:R -> R), (0 < Rlength l)%nat -> Rlength l = S (Rlength (FF l f)). -Proof. +Proof. intros l f H; induction l; [ elim (lt_irrefl _ H) | simpl in |- *; rewrite RList_P18; rewrite RList_P14; reflexivity ]. @@ -962,9 +962,9 @@ Qed. 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. +Proof. intros; unfold adapted_couple in |- *; unfold is_subdivision in X; - unfold adapted_couple in X; elim X; clear X; intros; + unfold adapted_couple in X; elim X; clear X; intros; decompose [and] p; clear p; 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; @@ -974,7 +974,7 @@ Proof. unfold FF in |- *; rewrite RList_P12. simpl in |- *; change (f x0 = f (pos_Rl (mid_Rlist (cons r l) r) (S i))) in |- *; - rewrite RList_P13; try assumption; rewrite (H5 x0 H6); + rewrite RList_P13; try assumption; rewrite (H5 x0 H6); rewrite H5. reflexivity. split. @@ -990,7 +990,7 @@ Proof. | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym; [ rewrite Rmult_1_l; rewrite double; - rewrite (Rplus_comm (pos_Rl (cons r l) i)); + rewrite (Rplus_comm (pos_Rl (cons r l) i)); apply Rplus_lt_compat_l; elim H6; intros; apply Rlt_trans with x0; assumption | discrR ] ]. @@ -1002,7 +1002,7 @@ Lemma StepFun_P22 : a <= b -> is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg). -Proof. +Proof. unfold is_subdivision in |- *; 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 in |- *; case (Rle_dec a b); intro; @@ -1011,9 +1011,9 @@ Proof. unfold Rmax in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. apply existT with (FF (cons_ORlist lf lg) f); unfold adapted_couple in p, p0; - decompose [and] p; decompose [and] p0; clear p p0; + decompose [and] p; decompose [and] p0; clear p p0; rewrite Hyp_min in H6; rewrite Hyp_min in H1; rewrite Hyp_max in H0; - rewrite Hyp_max in H5; unfold adapted_couple in |- *; + rewrite Hyp_max in H5; unfold adapted_couple in |- *; repeat split. apply RList_P2; assumption. rewrite Hyp_min; symmetry in |- *; apply Rle_antisym. @@ -1024,25 +1024,25 @@ Proof. In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)). elim (RList_P3 (cons_ORlist (cons r lf) lg) - (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; + (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; apply H10; exists 0%nat; split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ]. elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H12 _; assert (H13 := H12 H10); elim H13; intro. elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0)); - intros H11 _; assert (H14 := H11 H8); elim H14; intros; + intros H11 _; assert (H14 := H11 H8); elim H14; intros; elim H15; clear H15; intros; rewrite H15; rewrite <- H6; elim (RList_P6 (cons r lf)); intros; apply H17; [ assumption | apply le_O_n | assumption ]. elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _; - assert (H14 := H11 H8); elim H14; intros; elim H15; - clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); + assert (H14 := H11 H8); elim H14; intros; elim H15; + clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); intros; apply H17; [ assumption | apply le_O_n | assumption ]. induction lf as [| r lf Hreclf]. simpl in |- *; right; assumption. assert (H8 : In a (cons_ORlist (cons r lf) lg)). elim (RList_P9 (cons r lf) lg a); intros; apply H10; left; - elim (RList_P3 (cons r lf) a); intros; apply H12; + elim (RList_P3 (cons r lf) a); intros; apply H12; exists 0%nat; split; [ symmetry in |- *; assumption | simpl in |- *; apply lt_O_Sn ]. apply RList_P5; [ apply RList_P2; assumption | assumption ]. @@ -1058,21 +1058,21 @@ Proof. elim (RList_P3 (cons_ORlist (cons r lf) lg) (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (Rlength (cons_ORlist (cons r lf) lg))))); intros _ H10; apply H10; - exists (pred (Rlength (cons_ORlist (cons r lf) lg))); + exists (pred (Rlength (cons_ORlist (cons r lf) lg))); split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ]. elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (Rlength (cons_ORlist (cons r lf) lg))))); intros H10 _. assert (H11 := H10 H8); elim H11; intro. elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); - intros H13 _; assert (H14 := H13 H12); elim H14; intros; + (pred (Rlength (cons_ORlist (cons r lf) lg))))); + intros H13 _; assert (H14 := H13 H12); elim H14; intros; elim H15; clear H15; intros; rewrite H15; rewrite <- H5; elim (RList_P6 (cons r lf)); intros; apply H17; [ assumption @@ -1081,8 +1081,8 @@ Proof. elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); - intros H13 _; assert (H14 := H13 H12); elim H14; intros; + (pred (Rlength (cons_ORlist (cons r lf) lg))))); + intros H13 _; assert (H14 := H13 H12); elim H14; intros; elim H15; clear H15; intros. rewrite H15; assert (H17 : Rlength lg = S (pred (Rlength lg))). apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro; @@ -1187,7 +1187,7 @@ Proof. apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H5; rewrite <- H6 in H11; rewrite <- H5 in H11; elim (Rlt_irrefl _ H11). assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14; - exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval in |- *; + exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval in |- *; intros; assert (H16 := H9 x0); assert (H17 : (x0 < pred (Rlength lf))%nat). elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros; apply lt_S_n; replace (S (pred (Rlength lf))) with (Rlength lf). @@ -1232,7 +1232,7 @@ Proof. clear b0; 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; + elim (RList_P3 lf (pos_Rl lf (S x0))); intros; apply H27; exists (S x0); split; [ reflexivity | apply H22 ]. Qed. @@ -1240,7 +1240,7 @@ Lemma StepFun_P23 : forall (a b:R) (f g:R -> R) (lf lg:Rlist), is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg). -Proof. +Proof. intros; case (Rle_dec a b); intro; [ apply StepFun_P22 with g; assumption | apply StepFun_P5; apply StepFun_P22 with g; @@ -1254,7 +1254,7 @@ Lemma StepFun_P24 : a <= b -> is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg). -Proof. +Proof. unfold is_subdivision in |- *; 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 in |- *; case (Rle_dec a b); intro; @@ -1263,9 +1263,9 @@ Proof. unfold Rmax in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. apply existT with (FF (cons_ORlist lf lg) g); unfold adapted_couple in p, p0; - decompose [and] p; decompose [and] p0; clear p p0; + decompose [and] p; decompose [and] p0; clear p p0; rewrite Hyp_min in H1; rewrite Hyp_min in H6; rewrite Hyp_max in H0; - rewrite Hyp_max in H5; unfold adapted_couple in |- *; + rewrite Hyp_max in H5; unfold adapted_couple in |- *; repeat split. apply RList_P2; assumption. rewrite Hyp_min; symmetry in |- *; apply Rle_antisym. @@ -1276,25 +1276,25 @@ Proof. In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)). elim (RList_P3 (cons_ORlist (cons r lf) lg) - (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; + (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; apply H10; exists 0%nat; split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ]. elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H12 _; assert (H13 := H12 H10); elim H13; intro. elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0)); - intros H11 _; assert (H14 := H11 H8); elim H14; intros; + intros H11 _; assert (H14 := H11 H8); elim H14; intros; elim H15; clear H15; intros; rewrite H15; rewrite <- H6; elim (RList_P6 (cons r lf)); intros; apply H17; [ assumption | apply le_O_n | assumption ]. elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _; - assert (H14 := H11 H8); elim H14; intros; elim H15; - clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); + assert (H14 := H11 H8); elim H14; intros; elim H15; + clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); intros; apply H17; [ assumption | apply le_O_n | assumption ]. induction lf as [| r lf Hreclf]. simpl in |- *; right; assumption. assert (H8 : In a (cons_ORlist (cons r lf) lg)). elim (RList_P9 (cons r lf) lg a); intros; apply H10; left; - elim (RList_P3 (cons r lf) a); intros; apply H12; + elim (RList_P3 (cons r lf) a); intros; apply H12; exists 0%nat; split; [ symmetry in |- *; assumption | simpl in |- *; apply lt_O_Sn ]. apply RList_P5; [ apply RList_P2; assumption | assumption ]. @@ -1310,20 +1310,20 @@ Proof. elim (RList_P3 (cons_ORlist (cons r lf) lg) (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (Rlength (cons_ORlist (cons r lf) lg))))); intros _ H10; apply H10; - exists (pred (Rlength (cons_ORlist (cons r lf) lg))); + exists (pred (Rlength (cons_ORlist (cons r lf) lg))); split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ]. elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (Rlength (cons_ORlist (cons r lf) lg))))); intros H10 _; assert (H11 := H10 H8); elim H11; intro. elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); - intros H13 _; assert (H14 := H13 H12); elim H14; intros; + (pred (Rlength (cons_ORlist (cons r lf) lg))))); + intros H13 _; assert (H14 := H13 H12); elim H14; intros; elim H15; clear H15; intros; rewrite H15; rewrite <- H5; elim (RList_P6 (cons r lf)); intros; apply H17; [ assumption @@ -1332,8 +1332,8 @@ Proof. elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); - intros H13 _; assert (H14 := H13 H12); elim H14; intros; + (pred (Rlength (cons_ORlist (cons r lf) lg))))); + intros H13 _; assert (H14 := H13 H12); elim H14; intros; elim H15; clear H15; intros; rewrite H15; assert (H17 : Rlength lg = S (pred (Rlength lg))). apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro; @@ -1436,7 +1436,7 @@ Proof. apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H0; rewrite <- H1 in H11; rewrite <- H0 in H11; elim (Rlt_irrefl _ H11). assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14; - exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval in |- *; + exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval in |- *; intros; assert (H16 := H4 x0); assert (H17 : (x0 < pred (Rlength lg))%nat). elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros; apply lt_S_n; replace (S (pred (Rlength lg))) with (Rlength lg). @@ -1481,7 +1481,7 @@ Proof. clear b0; 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; + elim (RList_P3 lg (pos_Rl lg (S x0))); intros; apply H27; exists (S x0); split; [ reflexivity | apply H22 ] ]. Qed. @@ -1489,7 +1489,7 @@ Lemma StepFun_P25 : forall (a b:R) (f g:R -> R) (lf lg:Rlist), is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg). -Proof. +Proof. intros a b f g lf lg H H0; case (Rle_dec a b); intro; [ apply StepFun_P24 with f; assumption | apply StepFun_P5; apply StepFun_P24 with f; @@ -1504,12 +1504,12 @@ Lemma StepFun_P26 : is_subdivision g a b l1 -> is_subdivision (fun x:R => f x + l * g x) a b l1. Proof. - intros a b l f g l1 (x0,(H0,(H1,(H2,(H3,H4))))) + intros a b l f g l1 (x0,(H0,(H1,(H2,(H3,H4))))) (x,(_,(_,(_,(_,H9))))). exists (FF l1 (fun x:R => f x + l * g x)); repeat split; try assumption. apply StepFun_P20; rewrite H3; auto with arith. - intros i H8 x1 H10; unfold open_interval in H10, H9, H4; - rewrite (H9 _ H8 _ H10); rewrite (H4 _ H8 _ H10); + intros i H8 x1 H10; unfold open_interval in H10, H9, H4; + rewrite (H9 _ H8 _ H10); rewrite (H4 _ H8 _ H10); assert (H11 : l1 <> nil). red in |- *; intro H11; rewrite H11 in H8; elim (lt_n_O _ H8). destruct (RList_P19 _ H11) as (r,(r0,H12)); @@ -1548,7 +1548,7 @@ Lemma StepFun_P27 : is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision (fun x:R => f x + l * g x) a b (cons_ORlist lf lg). -Proof. +Proof. intros a b l f g lf lg H H0; apply StepFun_P26; [ apply StepFun_P23 with g; assumption | apply StepFun_P25 with f; assumption ]. @@ -1557,16 +1557,16 @@ Qed. (** The set of step functions on [a,b] is a vectorial space *) Lemma StepFun_P28 : forall (a b l:R) (f g:StepFun a b), IsStepFun (fun x:R => f x + l * g x) a b. -Proof. +Proof. intros a b l f g; unfold IsStepFun in |- *; assert (H := pre f); - assert (H0 := pre g); unfold IsStepFun in H, H0; elim H; - elim H0; intros; apply existT with (cons_ORlist x0 x); + assert (H0 := pre g); unfold IsStepFun in H, H0; elim H; + elim H0; intros; apply existT with (cons_ORlist x0 x); apply StepFun_P27; assumption. Qed. Lemma StepFun_P29 : forall (a b:R) (f:StepFun a b), is_subdivision f a b (subdivision f). -Proof. +Proof. intros a b f; unfold is_subdivision in |- *; apply existT with (subdivision_val f); apply StepFun_P1. Qed. @@ -1575,7 +1575,7 @@ Lemma StepFun_P30 : forall (a b l:R) (f g:StepFun a b), RiemannInt_SF (mkStepFun (StepFun_P28 l f g)) = RiemannInt_SF f + l * RiemannInt_SF g. -Proof. +Proof. intros a b l f g; unfold RiemannInt_SF in |- *; case (Rle_dec a b); (intro; replace @@ -1612,29 +1612,29 @@ Lemma StepFun_P31 : forall (a b:R) (f:R -> R) (l lf:Rlist), adapted_couple f a b l lf -> adapted_couple (fun x:R => Rabs (f x)) a b l (app_Rlist lf Rabs). -Proof. +Proof. unfold adapted_couple in |- *; intros; decompose [and] H; clear H; repeat split; try assumption. symmetry in |- *; rewrite H3; rewrite RList_P18; reflexivity. intros; unfold constant_D_eq, open_interval in |- *; - unfold constant_D_eq, open_interval in H5; intros; + unfold constant_D_eq, open_interval in H5; intros; rewrite (H5 _ H _ H4); rewrite RList_P12; [ reflexivity | rewrite H3 in H; simpl in H; apply H ]. Qed. Lemma StepFun_P32 : forall (a b:R) (f:StepFun a b), IsStepFun (fun x:R => Rabs (f x)) a b. -Proof. +Proof. intros a b f; unfold IsStepFun in |- *; apply existT with (subdivision f); unfold is_subdivision in |- *; - apply existT with (app_Rlist (subdivision_val f) Rabs); + apply existT with (app_Rlist (subdivision_val f) Rabs); apply StepFun_P31; apply StepFun_P1. Qed. Lemma StepFun_P33 : forall l2 l1:Rlist, ordered_Rlist l1 -> Rabs (Int_SF l2 l1) <= Int_SF (app_Rlist l2 Rabs) l1. -Proof. +Proof. simple induction l2; intros. simpl in |- *; rewrite Rabs_R0; right; reflexivity. simpl in |- *; induction l1 as [| r1 l1 Hrecl1]. @@ -1653,14 +1653,14 @@ Lemma StepFun_P34 : forall (a b:R) (f:StepFun a b), a <= b -> Rabs (RiemannInt_SF f) <= RiemannInt_SF (mkStepFun (StepFun_P32 f)). -Proof. +Proof. intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro. replace (Int_SF (subdivision_val (mkStepFun (StepFun_P32 f))) (subdivision (mkStepFun (StepFun_P32 f)))) with (Int_SF (app_Rlist (subdivision_val f) Rabs) (subdivision f)). apply StepFun_P33; assert (H0 := StepFun_P29 f); unfold is_subdivision in H0; - elim H0; intros; unfold adapted_couple in p; decompose [and] p; + elim H0; intros; unfold adapted_couple in p; decompose [and] p; assumption. apply StepFun_P17 with (fun x:R => Rabs (f x)) a b; [ apply StepFun_P31; apply StepFun_P1 @@ -1675,7 +1675,7 @@ Lemma StepFun_P35 : pos_Rl l (pred (Rlength l)) = b -> (forall x:R, a < x < b -> f x <= g x) -> Int_SF (FF l f) l <= Int_SF (FF l g) l. -Proof. +Proof. simple induction l; intros. right; reflexivity. simpl in |- *; induction r0 as [| r0 r1 Hrecr0]. @@ -1742,7 +1742,7 @@ Lemma StepFun_P36 : is_subdivision g a b l -> (forall x:R, a < x < b -> f x <= g x) -> RiemannInt_SF f <= RiemannInt_SF g. -Proof. +Proof. intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro. 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). @@ -1768,7 +1768,7 @@ Lemma StepFun_P37 : a <= b -> (forall x:R, a < x < b -> f x <= g x) -> RiemannInt_SF f <= RiemannInt_SF g. -Proof. +Proof. intros; eapply StepFun_P36; try assumption. eapply StepFun_P25; apply StepFun_P29. eapply StepFun_P23; apply StepFun_P29. @@ -1785,8 +1785,8 @@ Lemma StepFun_P38 : (i < pred (Rlength l))%nat -> constant_D_eq g (co_interval (pos_Rl l i) (pos_Rl l (S i))) (f (pos_Rl l i))) }. -Proof. - intros l a b f; generalize a; clear a; induction l. +Proof. + intros l a b f; generalize a; clear a; induction l. intros a H H0 H1; simpl in H0; simpl in H1; exists (mkStepFun (StepFun_P4 a b (f b))); split. reflexivity. @@ -1812,7 +1812,7 @@ Proof. rewrite <- H4; apply RList_P7; [ assumption | left; reflexivity ]. assert (H8 : IsStepFun g' a b). unfold IsStepFun in |- *; assert (H8 := pre g); unfold IsStepFun in H8; - elim H8; intros lg H9; unfold is_subdivision in H9; + elim H8; intros lg H9; unfold is_subdivision in H9; elim H9; clear H9; intros lg2 H9; split with (cons a lg); unfold is_subdivision in |- *; split with (cons (f a) lg2); unfold adapted_couple in H9; decompose [and] H9; clear H9; @@ -1896,7 +1896,7 @@ Proof. assert (H11 : (i < pred (Rlength (cons r1 l)))%nat). simpl in |- *; apply lt_S_n; assumption. assert (H12 := H10 H11); unfold constant_D_eq, co_interval in H12; - unfold constant_D_eq, co_interval in |- *; intros; + unfold constant_D_eq, co_interval in |- *; intros; rewrite <- (H12 _ H13); simpl in |- *; unfold g' in |- *; case (Rle_dec r1 x); intro. reflexivity. @@ -1913,7 +1913,7 @@ Qed. Lemma StepFun_P39 : forall (a b:R) (f:StepFun a b), RiemannInt_SF f = - RiemannInt_SF (mkStepFun (StepFun_P6 (pre f))). -Proof. +Proof. intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); case (Rle_dec b a); intros. assert (H : adapted_couple f a b (subdivision f) (subdivision_val f)); @@ -1931,12 +1931,12 @@ Proof. rewrite Ropp_involutive; eapply StepFun_P17; [ apply StepFun_P1 | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H; - elim H; intros; unfold is_subdivision in |- *; + elim H; intros; unfold is_subdivision in |- *; elim p; intros; apply p0 ]. apply Ropp_eq_compat; eapply StepFun_P17; [ apply StepFun_P1 | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H; - elim H; intros; unfold is_subdivision in |- *; + elim H; intros; unfold is_subdivision in |- *; elim p; intros; apply p0 ]. assert (H : a < b); [ auto with real @@ -1951,9 +1951,9 @@ Lemma StepFun_P40 : adapted_couple f a b l1 lf1 -> adapted_couple f b c l2 lf2 -> adapted_couple f a c (cons_Rlist l1 l2) (FF (cons_Rlist l1 l2) f). -Proof. +Proof. intros f a b c l1 l2 lf1 lf2 H H0 H1 H2; unfold adapted_couple in H1, H2; - unfold adapted_couple in |- *; decompose [and] H1; + unfold adapted_couple in |- *; decompose [and] H1; decompose [and] H2; clear H1 H2; repeat split. apply RList_P25; try assumption. rewrite H10; rewrite H4; unfold Rmin, Rmax in |- *; case (Rle_dec a b); @@ -2030,7 +2030,7 @@ Proof. pos_Rl (cons r1 (cons r2 r3)) (S i)) in H14; rewrite H14; change (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) = - pos_Rl (cons r1 (cons r2 r3)) (S (S i))) in H15; + pos_Rl (cons r1 (cons r2 r3)) (S (S i))) in H15; rewrite H15; assert (H18 := H8 (S i)); unfold constant_D_eq, open_interval in H18; assert (H19 : (S i < pred (Rlength l1))%nat). @@ -2112,11 +2112,11 @@ Proof. rewrite H19 in H16; rewrite H19 in H17; change (pos_Rl (cons_Rlist (cons r2 r3) l2) i = - pos_Rl l2 (S i - Rlength (cons r1 (cons r2 r3)))) + pos_Rl l2 (S i - Rlength (cons r1 (cons r2 r3)))) in H16; rewrite H16; change (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) = - pos_Rl l2 (S (S i - Rlength (cons r1 (cons r2 r3))))) + pos_Rl l2 (S (S i - Rlength (cons r1 (cons r2 r3))))) in H17; rewrite H17; assert (H20 := H13 (S i - Rlength l1)%nat); unfold constant_D_eq, open_interval in H20; assert (H21 : (S i - Rlength l1 < pred (Rlength l2))%nat). @@ -2154,7 +2154,7 @@ Proof. rewrite double; apply Rplus_lt_compat_l; assumption | discrR ] ]. rewrite <- H19 in H16; rewrite <- H19 in H17; elim H2; intros; - rewrite H19 in H25; rewrite H19 in H26; simpl in H25; + rewrite H19 in H25; rewrite H19 in H26; simpl in H25; simpl in H16; rewrite H16 in H25; simpl in H26; simpl in H17; rewrite H17 in H26; simpl in H24; rewrite H24 in H25; elim (Rlt_irrefl _ (Rlt_trans _ _ _ H25 H26)). @@ -2189,7 +2189,7 @@ Lemma StepFun_P42 : pos_Rl l1 (pred (Rlength l1)) = pos_Rl l2 0 -> Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2) = Int_SF (FF l1 f) l1 + Int_SF (FF l2 f) l2. -Proof. +Proof. intros l1 l2 f; induction l1 as [| r l1 IHl1]; intros H; [ simpl in |- *; ring | destruct l1 as [| r0 r1]; @@ -2200,11 +2200,11 @@ Proof. Qed. Lemma StepFun_P43 : - forall (f:R -> R) (a b c:R) (pr1:IsStepFun f a b) + forall (f:R -> R) (a b c:R) (pr1:IsStepFun f a b) (pr2:IsStepFun f b c) (pr3:IsStepFun f a c), RiemannInt_SF (mkStepFun pr1) + RiemannInt_SF (mkStepFun pr2) = RiemannInt_SF (mkStepFun pr3). -Proof. +Proof. intros f; intros. pose proof pr1 as (l1,(lf1,H1)). pose proof pr2 as (l2,(lf2,H2)). @@ -2441,7 +2441,7 @@ Qed. Lemma StepFun_P44 : forall (f:R -> R) (a b c:R), IsStepFun f a b -> a <= c <= b -> IsStepFun f a c. -Proof. +Proof. intros f; intros; assert (H0 : a <= b). elim H; intros; apply Rle_trans with c; assumption. elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X; @@ -2479,7 +2479,7 @@ Proof. case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ]. elim H1; intro. split with (cons r (cons c nil)); split with (cons r3 nil); - unfold adapted_couple in H; decompose [and] H; clear H; + unfold adapted_couple in H; decompose [and] H; clear H; assert (H6 : r = a). simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intro; [ reflexivity @@ -2497,7 +2497,7 @@ Proof. assert (H12 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat). simpl in |- *; apply lt_O_Sn. apply (H10 H12); unfold open_interval in |- *; simpl in |- *; - rewrite H11 in H9; simpl in H9; elim H9; clear H9; + rewrite H11 in H9; simpl in H9; elim H9; clear H9; intros; split; try assumption. apply Rlt_le_trans with c; assumption. elim (le_Sn_O _ H11). @@ -2505,8 +2505,8 @@ Proof. cut (r1 <= c <= b). intros. elim (X0 _ _ _ _ _ H3 H2); intros l1' [lf1' H4]; split with (cons r l1'); - split with (cons r3 lf1'); unfold adapted_couple in H, H4; - decompose [and] H; decompose [and] H4; clear H H4 X0; + split with (cons r3 lf1'); unfold adapted_couple in H, H4; + decompose [and] H; decompose [and] H4; clear H H4 X0; assert (H14 : a <= b). elim H0; intros; apply Rle_trans with c; assumption. assert (H16 : r = a). @@ -2538,7 +2538,7 @@ Proof. assert (H18 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat). simpl in |- *; apply lt_O_Sn. apply (H17 H18); unfold open_interval in |- *; simpl in |- *; simpl in H4; - elim H4; clear H4; intros; split; try assumption; + elim H4; clear H4; intros; split; try assumption; replace r1 with r4. assumption. simpl in H12; rewrite H12; unfold Rmin in |- *; case (Rle_dec r1 c); intro; @@ -2557,7 +2557,7 @@ Qed. Lemma StepFun_P45 : forall (f:R -> R) (a b c:R), IsStepFun f a b -> a <= c <= b -> IsStepFun f c b. -Proof. +Proof. intros f; intros; assert (H0 : a <= b). elim H; intros; apply Rle_trans with c; assumption. elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X; @@ -2614,7 +2614,7 @@ Proof. apply (H7 0%nat). simpl in |- *; apply lt_O_Sn. unfold open_interval in |- *; simpl in |- *; simpl in H6; elim H6; clear H6; - intros; split; try assumption; apply Rle_lt_trans with c; + 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 in |- *; case (Rle_dec a b); intros; @@ -2634,7 +2634,7 @@ Qed. Lemma StepFun_P46 : forall (f:R -> R) (a b c:R), IsStepFun f a b -> IsStepFun f b c -> IsStepFun f a c. -Proof. +Proof. intros f; intros; case (Rle_dec a b); case (Rle_dec b c); intros. apply StepFun_P41 with b; assumption. case (Rle_dec a c); intro. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index 1a2fa03a..be7895f5 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rlimit.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) (*********************************************************) (** Definition of the limit *) @@ -85,7 +85,7 @@ Proof. fourier. discrR. ring. -Qed. +Qed. (*********) Lemma prop_eps : forall r:R, (forall eps:R, eps > 0 -> r < eps) -> r <= 0. @@ -95,7 +95,7 @@ Proof. elim H0; intro. apply Req_le; assumption. clear H0; generalize (H r H1); intro; generalize (Rlt_irrefl r); intro; - elimtype False; auto. + exfalso; auto. Qed. (*********) @@ -148,7 +148,7 @@ Qed. (*******************************) (*********) -Record Metric_Space : Type := +Record Metric_Space : Type := {Base : Type; dist : Base -> Base -> R; dist_pos : forall x y:Base, dist x y >= 0; @@ -167,7 +167,7 @@ Definition limit_in (X X':Metric_Space) (f:Base X -> 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 /\ dist X x x0 < alp -> dist X' (f x) l < eps). (*******************************) (** ** R is a metric space *) @@ -214,7 +214,7 @@ Qed. Lemma lim_x : forall (D:R -> Prop) (x0:R), limit1_in (fun x:R => x) D x0 x0. Proof. unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; - split with eps; split; auto; intros; elim H0; intros; + split with eps; split; auto; intros; elim H0; intros; auto. Qed. @@ -226,7 +226,7 @@ Lemma limit_plus : Proof. intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; elim (H (eps * / 2) (eps2_Rgt_R0 eps H1)); - elim (H0 (eps * / 2) (eps2_Rgt_R0 eps H1)); simpl in |- *; + elim (H0 (eps * / 2) (eps2_Rgt_R0 eps H1)); simpl in |- *; clear H H0; intros; elim H; elim H0; clear H H0; intros; split with (Rmin x1 x); split. exact (Rmin_Rgt_r x1 x 0 (conj H H2)). @@ -248,11 +248,11 @@ Lemma limit_Ropp : limit1_in f D l x0 -> limit1_in (fun x:R => - f x) D (- l) x0. Proof. unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; - elim (H eps H0); clear H; intros; elim H; clear H; - intros; split with x; split; auto; intros; generalize (H1 x1 H2); + elim (H eps H0); clear H; intros; elim H; clear H; + intros; split with x; split; auto; intros; generalize (H1 x1 H2); clear H1; intro; unfold R_dist in |- *; unfold Rminus in |- *; rewrite (Ropp_involutive l); rewrite (Rplus_comm (- f x1) l); - fold (l - f x1) in |- *; fold (R_dist l (f x1)) in |- *; + fold (l - f x1) in |- *; fold (R_dist l (f x1)) in |- *; rewrite R_dist_sym; assumption. Qed. @@ -273,7 +273,7 @@ Lemma limit_free : Proof. unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; split with eps; split; auto; intros; elim (R_dist_refl (f x) (f x)); - intros a b; rewrite (b (refl_equal (f x))); unfold Rgt in H; + intros a b; rewrite (b (refl_equal (f x))); unfold Rgt in H; assumption. Qed. @@ -286,13 +286,13 @@ Proof. intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; elim (H (Rmin 1 (eps * mul_factor l l')) (mul_factor_gt_f eps l l' H1)); - elim (H0 (eps * mul_factor l l') (mul_factor_gt eps l l' H1)); - clear H H0; simpl in |- *; intros; elim H; elim H0; + elim (H0 (eps * mul_factor l l') (mul_factor_gt eps l l' H1)); + clear H H0; simpl in |- *; intros; elim H; elim H0; clear H H0; intros; split with (Rmin x1 x); split. exact (Rmin_Rgt_r x1 x 0 (conj H H2)). intros; elim H4; clear H4; intros; unfold R_dist in |- *; replace (f x2 * g x2 - l * l') with (f x2 * (g x2 - l') + l' * (f x2 - l)). - cut (Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l)) < eps). + cut (Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l)) < eps). cut (Rabs (f x2 * (g x2 - l') + l' * (f x2 - l)) <= Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l))). @@ -353,19 +353,19 @@ Proof. unfold Rabs in |- *; case (Rcase_abs (l - l')); 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; - unfold Rgt in H3; generalize (Rgt_not_le (- (l - l')) 0 H3); - intro; elimtype False; auto. + generalize (Ropp_gt_lt_0_contravar (l - l') r); intro; + unfold Rgt in H3; generalize (Rgt_not_le (- (l - l')) 0 H3); + intro; exfalso; auto. intros; cut (eps * / 2 > 0). intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2)); rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2). elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial. apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro; - unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); - intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; + unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); + intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; clear a b; apply (Rlt_trans 0 1 2 H3 H4). unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2)); - rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); + rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); auto. apply (Rinv_0_lt_compat 2); cut (1 < 2). intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2). @@ -374,7 +374,7 @@ Proof. (**) cut (forall eps:R, eps > 0 -> l - l' < eps). intro; generalize (prop_eps (l - l') H1); intro; elim (Rle_le_eq (l - l') 0); - intros a b; clear b; apply (Rminus_diag_uniq l l'); + intros a b; clear b; apply (Rminus_diag_uniq l l'); apply a; split. assumption. apply (Rge_le (l - l') 0 r). @@ -383,11 +383,11 @@ Proof. rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2). elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial. apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro; - unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); - intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; + unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); + intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; clear a b; apply (Rlt_trans 0 1 2 H3 H4). unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2)); - rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); + rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); auto. apply (Rinv_0_lt_compat 2); cut (1 < 2). intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2). @@ -395,21 +395,21 @@ Proof. rewrite a; clear a b; trivial. (**) intros; unfold adhDa in H; elim (H0 eps H2); intros; elim (H1 eps H2); intros; - clear H0 H1; elim H3; elim H4; clear H3 H4; intros; - simpl in |- *; simpl in H1, H4; generalize (Rmin_Rgt x x1 0); + clear H0 H1; elim H3; elim H4; clear H3 H4; intros; + simpl in |- *; simpl in H1, H4; generalize (Rmin_Rgt x x1 0); intro; elim H5; intros; clear H5; elim (H (Rmin x x1) (H7 (conj H3 H0))); intros; elim H5; intros; clear H5 H H6 H7; - generalize (Rmin_Rgt x x1 (R_dist x2 x0)); intro; - elim H; intros; clear H H6; unfold Rgt in H5; elim (H5 H9); + generalize (Rmin_Rgt x x1 (R_dist x2 x0)); intro; + elim H; intros; clear H H6; unfold Rgt in H5; elim (H5 H9); intros; clear H5 H9; generalize (H1 x2 (conj H8 H6)); - generalize (H4 x2 (conj H8 H)); clear H8 H H6 H1 H4 H0 H3; + generalize (H4 x2 (conj H8 H)); clear H8 H H6 H1 H4 H0 H3; intros; generalize (Rplus_lt_compat (R_dist (f x2) l) eps (R_dist (f x2) l') eps H H0); unfold R_dist in |- *; intros; rewrite (Rabs_minus_sym (f x2) l) in H1; rewrite (Rmult_comm 2 eps); rewrite (Rmult_plus_distr_l eps 1 1); elim (Rmult_ne eps); intros a b; rewrite a; clear a b; - generalize (R_dist_tri l l' (f x2)); unfold R_dist in |- *; + generalize (R_dist_tri l l' (f x2)); unfold R_dist in |- *; intros; apply (Rle_lt_trans (Rabs (l - l')) (Rabs (l - f x2) + Rabs (f x2 - l')) @@ -449,7 +449,7 @@ Proof. intro H7; intro H10; elim H10; intros; cut (D x /\ Rabs (x - x0) < delta1). cut (D x /\ Rabs (x - x0) < delta2). intros; generalize (H5 H11); clear H5; intro H5; generalize (H7 H12); - clear H7; intro H7; generalize (Rabs_triang_inv l (f x)); + clear H7; intro H7; generalize (Rabs_triang_inv l (f x)); intro; rewrite Rabs_minus_sym in H7; generalize (Rle_lt_trans (Rabs l - Rabs (f x)) (Rabs (l - f x)) (Rabs l / 2) H13 H7); diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v index 8aadf8f5..379d3495 100644 --- a/theories/Reals/Rlogic.v +++ b/theories/Reals/Rlogic.v @@ -34,7 +34,7 @@ Require Import PartSum. Require Import SeqSeries. Require Import RiemannInt. Require Import Fourier. - + Section Arithmetical_dec. Variable P : nat -> Prop. @@ -108,7 +108,7 @@ rewrite Rabs_pos_eq. intro i. unfold f, g. elim (HP i); intro; ring_simplify; auto with *. - cut (sum_f_R0 g m <= sum_f_R0 g n). + 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. @@ -177,9 +177,9 @@ assert (Z: Un_cv (fun N : nat => sum_f_R0 g N) ((1/2)^n)). split; intros H; simpl; unfold g; - destruct (eq_nat_dec 0 n); try reflexivity. + destruct (eq_nat_dec 0 n) as [t|f]; try reflexivity. elim f; auto with *. - elimtype False; omega. + exfalso; omega. destruct IHa as [IHa0 IHa1]. split; intros H; @@ -191,7 +191,7 @@ assert (Z: Un_cv (fun N : nat => sum_f_R0 g N) ((1/2)^n)). ring_simplify. apply IHa0. omega. - elimtype False; omega. + exfalso; omega. ring_simplify. apply IHa1. omega. diff --git a/theories/Reals/Rminmax.v b/theories/Reals/Rminmax.v new file mode 100644 index 00000000..373f30dd --- /dev/null +++ b/theories/Reals/Rminmax.v @@ -0,0 +1,123 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Rmax x y = x. +Proof. + unfold Rmax. intros. + destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; + unfold Rle in *; intuition. +Qed. + +Lemma Rmax_r : forall x y, x<=y -> Rmax x y = y. +Proof. + unfold Rmax. intros. + destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; + unfold Rle in *; intuition. +Qed. + +Lemma Rmin_l : forall x y, x<=y -> Rmin x y = x. +Proof. + unfold Rmin. intros. + destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; + unfold Rle in *; intuition. +Qed. + +Lemma Rmin_r : forall x y, y<=x -> Rmin x y = y. +Proof. + unfold Rmin. intros. + destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ]; + unfold Rle in *; intuition. +Qed. + +Module RHasMinMax <: HasMinMax R_as_OT. + Definition max := Rmax. + Definition min := Rmin. + Definition max_l := Rmax_l. + Definition max_r := Rmax_r. + Definition min_l := Rmin_l. + Definition min_r := Rmin_r. +End RHasMinMax. + +Module R. + +(** We obtain hence all the generic properties of max and min. *) + +Include UsualMinMaxProperties R_as_OT RHasMinMax. + +(** * Properties specific to the [R] domain *) + +(** Compatibilities (consequences of monotonicity) *) + +Lemma plus_max_distr_l : forall n m p, Rmax (p + n) (p + m) = p + Rmax n m. +Proof. + intros. apply max_monotone. + intros x y. apply Rplus_le_compat_l. +Qed. + +Lemma plus_max_distr_r : forall n m p, Rmax (n + p) (m + p) = Rmax n m + p. +Proof. + intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p). + apply plus_max_distr_l. +Qed. + +Lemma plus_min_distr_l : forall n m p, Rmin (p + n) (p + m) = p + Rmin n m. +Proof. + intros. apply min_monotone. + intros x y. apply Rplus_le_compat_l. +Qed. + +Lemma plus_min_distr_r : forall n m p, Rmin (n + p) (m + p) = Rmin n m + p. +Proof. + intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p). + apply plus_min_distr_l. +Qed. + +(** Anti-monotonicity swaps the role of [min] and [max] *) + +Lemma opp_max_distr : forall n m : R, -(Rmax n m) = Rmin (- n) (- m). +Proof. + intros. symmetry. apply min_max_antimonotone. + do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto. +Qed. + +Lemma opp_min_distr : forall n m : R, - (Rmin n m) = Rmax (- n) (- m). +Proof. + intros. symmetry. apply max_min_antimonotone. + do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto. +Qed. + +Lemma minus_max_distr_l : forall n m p, Rmax (p - n) (p - m) = p - Rmin n m. +Proof. + unfold Rminus. intros. rewrite opp_min_distr. apply plus_max_distr_l. +Qed. + +Lemma minus_max_distr_r : forall n m p, Rmax (n - p) (m - p) = Rmax n m - p. +Proof. + unfold Rminus. intros. apply plus_max_distr_r. +Qed. + +Lemma minus_min_distr_l : forall n m p, Rmin (p - n) (p - m) = p - Rmax n m. +Proof. + unfold Rminus. intros. rewrite opp_max_distr. apply plus_min_distr_l. +Qed. + +Lemma minus_min_distr_r : forall n m p, Rmin (n - p) (m - p) = Rmin n m - p. +Proof. + unfold Rminus. intros. apply plus_min_distr_r. +Qed. + +End R. diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v index 90ea9726..c7d1893b 100644 --- a/theories/Reals/Rpow_def.v +++ b/theories/Reals/Rpow_def.v @@ -6,11 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Rpow_def.v 10923 2008-05-12 18:25:06Z herbelin $ *) +(* $Id$ *) Require Import Rdefinitions. -Fixpoint pow (r:R) (n:nat) {struct n} : R := +Fixpoint pow (r:R) (n:nat) : R := match n with | O => R1 | S n => Rmult r (pow r n) diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index adf53ef9..a4feed8f 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rpower.v 10710 2008-03-23 09:24:09Z herbelin $ i*) -(*i Due to L.Thery i*) +(*i $Id$ i*) +(*i Due to L.Thery i*) (************************************************************) (* Definitions of log and Rpower : R->R->R; main properties *) @@ -86,7 +86,7 @@ Proof. apply INR_fact_neq_0. apply INR_fact_neq_0. assert (H0 := cv_speed_pow_fact 1); unfold Un_cv in |- *; unfold Un_cv in H0; - intros; elim (H0 _ H1); intros; exists x0; intros; + intros; elim (H0 _ H1); intros; exists x0; intros; unfold R_dist in H2; unfold R_dist in |- *; replace (/ INR (fact n)) with (1 ^ n / INR (fact n)). apply (H2 _ H3). @@ -139,8 +139,8 @@ 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)); - assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0; - intros; elim H1; intros; unfold Rminus in H2; rewrite H2; + 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; replace (derive_pt exp x0 (derivable_exp x0)) with (exp x0). rewrite exp_0; rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; @@ -162,7 +162,7 @@ Proof. pose proof (IVT_cor f 0 y H2 (Rlt_le _ _ H0) H4) as (t,(_,H7)); exists t; unfold f in H7; apply Rminus_diag_uniq_sym; exact H7. pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y)); - rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l; + rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l; assumption. unfold f in |- *; apply Rplus_le_reg_l with y; left; apply Rlt_trans with (1 + y). @@ -191,7 +191,7 @@ Proof. apply Rmult_eq_reg_l with (exp x / y). unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite <- Rinv_l_sym. rewrite Rmult_1_r; rewrite <- (Rmult_comm (/ y)); rewrite Rmult_assoc; - rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0; + rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0; rewrite Rmult_1_r; symmetry in |- *; apply p. red in |- *; intro H3; rewrite H3 in H; elim (Rlt_irrefl _ H). unfold Rdiv in |- *; apply prod_neq_R0. @@ -216,7 +216,7 @@ Lemma exp_ln : forall x:R, 0 < x -> exp (ln x) = x. Proof. intros; unfold ln in |- *; case (Rlt_dec 0 x); intro. unfold Rln in |- *; - case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r))); + case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r))); intros. simpl in e; symmetry in |- *; apply e. elim n; apply H. @@ -248,7 +248,7 @@ Qed. Theorem ln_increasing : forall x y:R, 0 < x -> x < y -> ln x < ln y. Proof. intros x y H H0; apply exp_lt_inv. - repeat rewrite exp_ln. + repeat rewrite exp_ln. apply H0. apply Rlt_trans with x; assumption. apply H. @@ -270,7 +270,7 @@ Theorem ln_lt_inv : forall x y:R, 0 < x -> 0 < y -> ln x < ln y -> x < y. Proof. intros x y H H0 H1; rewrite <- (exp_ln x); try rewrite <- (exp_ln y). apply exp_increasing; apply H1. - assumption. + assumption. assumption. Qed. @@ -299,7 +299,7 @@ Theorem ln_Rinv : forall x:R, 0 < x -> ln (/ x) = - ln x. Proof. intros x H; apply exp_inv; repeat rewrite exp_ln || rewrite exp_Ropp. reflexivity. - assumption. + assumption. apply Rinv_0_lt_compat; assumption. Qed. @@ -325,7 +325,7 @@ Proof. unfold dist, R_met, R_dist in |- *; simpl in |- *. intros x [[H3 H4] H5]. cut (y * (x * / y) = x). - intro Hxyy. + intro Hxyy. replace (ln x - ln y) with (ln (x * / y)). case (Rtotal_order x y); [ intros Hxy | intros [Hxy| Hxy] ]. rewrite Rabs_left. @@ -470,7 +470,7 @@ Proof. apply Rmult_eq_reg_l with (INR 2). apply exp_inv. fold Rpower in |- *. - cut ((x ^R (/ 2)) ^R INR 2 = sqrt x ^R INR 2). + cut ((x ^R (/ INR 2)) ^R INR 2 = sqrt x ^R INR 2). unfold Rpower in |- *; auto. rewrite Rpower_mult. rewrite Rinv_l. @@ -580,8 +580,8 @@ Proof. (l := ln y) (g := fun x:R => (exp x - exp (ln y)) / (x - ln y)) (f := ln). apply ln_continue; auto. assert (H0 := derivable_pt_lim_exp (ln y)); unfold derivable_pt_lim in H0; - unfold limit1_in in |- *; unfold limit_in in |- *; - simpl in |- *; unfold R_dist in |- *; intros; elim (H0 _ H); + unfold limit1_in in |- *; unfold limit_in in |- *; + simpl in |- *; unfold R_dist in |- *; intros; elim (H0 _ H); intros; exists (pos x); split. apply (cond_pos x). intros; pattern y at 3 in |- *; rewrite <- exp_ln. @@ -589,7 +589,7 @@ Proof. [ idtac | ring ]. apply H1. elim H2; intros H3 _; unfold D_x in H3; elim H3; clear H3; intros _ H3; - apply Rminus_eq_contra; apply (sym_not_eq (A:=R)); + apply Rminus_eq_contra; apply (sym_not_eq (A:=R)); apply H3. elim H2; clear H2; intros _ H2; apply H2. assumption. @@ -600,7 +600,7 @@ Lemma derivable_pt_lim_ln : forall x:R, 0 < x -> derivable_pt_lim ln x (/ x). Proof. intros; assert (H0 := Dln x H); unfold D_in in H0; unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; unfold R_dist in H0; - unfold derivable_pt_lim in |- *; intros; elim (H0 _ H1); + unfold derivable_pt_lim in |- *; intros; elim (H0 _ H1); intros; elim H2; clear H2; intros; set (alp := Rmin x0 (x / 2)); assert (H4 : 0 < alp). unfold alp in |- *; unfold Rmin in |- *; case (Rle_dec x0 (x / 2)); intro. diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v index 2113cc8f..bb3df6bb 100644 --- a/theories/Reals/Rprod.v +++ b/theories/Reals/Rprod.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rprod.v 10146 2007-09-27 12:28:12Z herbelin $ i*) +(*i $Id$ i*) Require Import Compare. Require Import Rbase. @@ -17,7 +17,7 @@ Require Import Binomial. Open Local Scope R_scope. (** TT Ak; 0<=k<=N *) -Boxed Fixpoint prod_f_R0 (f:nat -> R) (N:nat) {struct N} : R := +Boxed Fixpoint prod_f_R0 (f:nat -> R) (N:nat) : R := match N with | O => f O | S p => prod_f_R0 f p * f (S p) @@ -43,7 +43,7 @@ Proof. rewrite Hrecn; [ ring | assumption ]. omega. omega. -Qed. +Qed. (**********) Lemma prod_SO_pos : @@ -80,9 +80,9 @@ Qed. (** Application to factorial *) Lemma fact_prodSO : - forall n:nat, INR (fact n) = prod_f_R0 (fun k:nat => - (match (eq_nat_dec k 0) with - | left _ => 1%R + forall n:nat, INR (fact n) = prod_f_R0 (fun k:nat => + (match (eq_nat_dec k 0) with + | left _ => 1%R | right _ => INR k end)) n. Proof. @@ -102,7 +102,7 @@ Proof. replace (S (S (2 * n0))) with (2 * n0 + 2)%nat; [ idtac | ring ]. replace (S n0) with (n0 + 1)%nat; [ idtac | ring ]. ring. -Qed. +Qed. (** We prove that (N!)^2<=(2N-k)!*k! forall k in [|O;2N|] *) Lemma RfactN_fact2N_factk : @@ -112,7 +112,7 @@ Lemma RfactN_fact2N_factk : Proof. assert (forall (n:nat), 0 <= (if eq_nat_dec n 0 then 1 else INR n)). intros; case (eq_nat_dec n 0); auto with real. - assert (forall (n:nat), (0 < n)%nat -> + assert (forall (n:nat), (0 < n)%nat -> (if eq_nat_dec n 0 then 1 else INR n) = INR n). intros n; case (eq_nat_dec n 0); auto with real. intros; absurd (0 < n)%nat; omega. @@ -125,7 +125,7 @@ Proof. rewrite Rmult_assoc; apply Rmult_le_compat_l. apply prod_SO_pos; intros; auto. replace (2 * N - k - N-1)%nat with (N - k-1)%nat. - rewrite Rmult_comm; rewrite (prod_SO_split + rewrite Rmult_comm; rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) N k). apply Rmult_le_compat_l. apply prod_SO_pos; intros; auto. @@ -138,14 +138,14 @@ Proof. assumption. omega. omega. - rewrite <- (Rmult_comm (prod_f_R0 (fun l:nat => + rewrite <- (Rmult_comm (prod_f_R0 (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) k)); - rewrite (prod_SO_split (fun l:nat => + rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) k N). rewrite Rmult_assoc; apply Rmult_le_compat_l. apply prod_SO_pos; intros; auto. rewrite Rmult_comm; - rewrite (prod_SO_split (fun l:nat => + rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) N (2 * N - k)). apply Rmult_le_compat_l. apply prod_SO_pos; intros; auto. @@ -160,7 +160,7 @@ Proof. omega. assumption. omega. -Qed. +Qed. (**********) diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v index 702aafa4..33b7c8d1 100644 --- a/theories/Reals/Rseries.v +++ b/theories/Reals/Rseries.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rseries.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -71,7 +71,7 @@ Section sequence. forall x:R, (forall n:nat, Un n <= x) -> is_upper_bound EUn x. Proof. intros; unfold is_upper_bound in |- *; intros; unfold EUn in H0; elim H0; - clear H0; intros; generalize (H x1); intro; rewrite <- H0 in H1; + clear H0; intros; generalize (H x1); intro; rewrite <- H0 in H1; trivial. Qed. @@ -81,7 +81,7 @@ Section sequence. Proof. double induction n m; intros. unfold Rge in |- *; right; trivial. - elimtype False; unfold ge in H1; generalize (le_Sn_O n0); intro; auto. + exfalso; unfold ge in H1; generalize (le_Sn_O n0); intro; auto. cut (n0 >= 0)%nat. generalize H0; intros; unfold Un_growing in H0; apply @@ -91,7 +91,7 @@ Section sequence. elim (lt_eq_lt_dec n1 n0); intro y. elim y; clear y; intro y. unfold ge in H2; generalize (le_not_lt n0 n1 (le_S_n n0 n1 H2)); intro; - elimtype False; auto. + exfalso; auto. rewrite y; unfold Rge in |- *; right; trivial. unfold ge in H0; generalize (H0 (S n0) H1 (lt_le_S n0 n1 y)); intro; unfold Un_growing in H1; @@ -106,11 +106,11 @@ Section sequence. Lemma Un_cv_crit : Un_growing -> bound EUn -> exists l : R, Un_cv l. Proof. unfold Un_growing, Un_cv in |- *; intros; - generalize (completeness_weak EUn H0 EUn_noempty); - intro; elim H1; clear H1; intros; split with x; intros; + generalize (completeness_weak EUn H0 EUn_noempty); + intro; elim H1; clear H1; intros; split with x; intros; unfold is_lub in H1; unfold bound in H0; unfold is_upper_bound in H0, H1; - elim H0; clear H0; intros; elim H1; clear H1; intros; - generalize (H3 x0 H0); intro; cut (forall n:nat, Un n <= x); + elim H0; clear H0; intros; elim H1; clear H1; intros; + generalize (H3 x0 H0); intro; cut (forall n:nat, Un n <= x); intro. cut (exists N : nat, x - eps < Un N). intro; elim H6; clear H6; intros; split with x1. @@ -131,10 +131,10 @@ Section sequence. apply (Rnot_lt_ge (x - eps) (Un N) (H7 N)). red in |- *; intro; cut (forall N:nat, Un N <= x - eps). intro; generalize (Un_bound_imp (x - eps) H7); intro; - unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); + unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); intro; generalize (Rle_minus x (x - eps) H9); unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r; - rewrite (let (H1, H2) := Rplus_ne (- - eps) in H2); + rewrite (let (H1, H2) := Rplus_ne (- - eps) in H2); rewrite Ropp_involutive; intro; unfold Rgt in H2; generalize (Rgt_not_le eps 0 H2); intro; auto. intro; elim (H6 N); intro; unfold Rle in |- *. @@ -151,7 +151,7 @@ Section sequence. split with (Un 0); intros; rewrite (le_n_O_eq n H); apply (Req_le (Un n) (Un n) (refl_equal (Un n))). elim HrecN; clear HrecN; intros; split with (Rmax (Un (S N)) x); intros; - elim (Rmax_Rle (Un (S N)) x (Un n)); intros; clear H1; + elim (Rmax_Rle (Un (S N)) x (Un n)); intros; clear H1; inversion H0. rewrite <- H1; rewrite <- H1 in H2; apply @@ -163,21 +163,21 @@ Section sequence. Lemma cauchy_bound : Cauchy_crit -> bound EUn. Proof. unfold Cauchy_crit, bound in |- *; intros; unfold is_upper_bound in |- *; - unfold Rgt in H; elim (H 1 Rlt_0_1); clear H; intros; + unfold Rgt in H; elim (H 1 Rlt_0_1); clear H; intros; generalize (H x); intro; generalize (le_dec x); intro; - elim (finite_greater x); intros; split with (Rmax x0 (Un x + 1)); - clear H; intros; unfold EUn in H; elim H; clear H; + elim (finite_greater x); intros; split with (Rmax x0 (Un x + 1)); + clear H; intros; unfold EUn in H; elim H; clear H; intros; elim (H1 x2); clear H1; intro y. unfold ge in H0; generalize (H0 x2 (le_n x) y); clear H0; intro; rewrite <- H in H0; unfold R_dist in H0; elim (Rabs_def2 (Un x - x1) 1 H0); - clear H0; intros; elim (Rmax_Rle x0 (Un x + 1) x1); + clear H0; intros; elim (Rmax_Rle x0 (Un x + 1) x1); intros; apply H4; clear H3 H4; right; clear H H0 y; apply (Rlt_le x1 (Un x + 1)); generalize (Rlt_minus (-1) (Un x - x1) H1); clear H1; intro; apply (Rminus_lt x1 (Un x + 1)); cut (-1 - (Un x - x1) = x1 - (Un x + 1)); [ intro; rewrite H0 in H; assumption | ring ]. generalize (H2 x2 y); clear H2 H0; intro; rewrite <- H in H0; - elim (Rmax_Rle x0 (Un x + 1) x1); intros; clear H1; + elim (Rmax_Rle x0 (Un x + 1) x1); intros; clear H1; apply H2; left; assumption. Qed. @@ -248,7 +248,7 @@ Proof. cut (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x))) = Rabs x * Rabs (/ x) * (eps * Rabs (1 - x))). - clear H8; intros; rewrite H8; rewrite <- Rabs_mult; rewrite Rinv_r. + clear H8; intros; rewrite H8; rewrite <- Rabs_mult; rewrite Rinv_r. rewrite Rabs_R1; cut (1 * (eps * Rabs (1 - x)) = Rabs (1 - x) * eps). intros; rewrite H9; unfold Rle in |- *; right; reflexivity. ring. diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v index 7cdd4d02..91759270 100644 --- a/theories/Reals/Rsigma.v +++ b/theories/Reals/Rsigma.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rsigma.v 9454 2006-12-15 15:30:59Z bgregoir $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v index 0a3af6ca..33c20355 100644 --- a/theories/Reals/Rsqrt_def.v +++ b/theories/Reals/Rsqrt_def.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rsqrt_def.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Sumbool. Require Import Rbase. @@ -23,7 +23,7 @@ Boxed Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R := let up := Dichotomy_ub x y P n in let z := (down + up) / 2 in if P z then down else z end - + with Dichotomy_ub (x y:R) (P:R -> bool) (N:nat) {struct N} : R := match N with | O => y @@ -471,8 +471,8 @@ 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). + 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. @@ -667,7 +667,7 @@ Proof. apply Ropp_0_gt_lt_contravar; assumption. Qed. -(** We can now define the square root function as the reciprocal +(** We can now define the square root function as the reciprocal transformation of the square root function *) Lemma Rsqrt_exists : forall y:R, 0 <= y -> { z:R | 0 <= z /\ y = Rsqr z }. @@ -698,7 +698,7 @@ Proof. rewrite Rsqr_1. apply Rplus_le_reg_l with y. rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *; - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; + rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; left; assumption. exists 1. split. diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index 9501bc1e..5b55896b 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtopology.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -33,8 +33,8 @@ Definition interior (D:R -> Prop) (x:R) : Prop := neighbourhood D x. Lemma interior_P1 : forall D:R -> Prop, included (interior D) D. Proof. intros; unfold included in |- *; unfold interior in |- *; intros; - unfold neighbourhood in H; elim H; intros; unfold included in H0; - apply H0; unfold disc in |- *; unfold Rminus in |- *; + unfold neighbourhood in H; elim H; intros; unfold included in H0; + apply H0; unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; apply (cond_pos x0). Qed. @@ -98,7 +98,7 @@ Lemma complementary_P1 : ~ (exists y : R, intersection_domain D (complementary D) y). Proof. intro; red in |- *; intro; elim H; intros; - unfold intersection_domain, complementary in H0; elim H0; + unfold intersection_domain, complementary in H0; elim H0; intros; elim H2; assumption. Qed. @@ -110,23 +110,23 @@ Proof. elim H1; intro. assumption. assert (H3 := H _ H2); assert (H4 := H0 _ H3); elim H4; intros; - unfold intersection_domain in H5; elim H5; intros; + unfold intersection_domain in H5; elim H5; intros; elim H6; assumption. Qed. Lemma adherence_P3 : forall D:R -> Prop, closed_set (adherence D). Proof. intro; unfold closed_set, adherence in |- *; - unfold open_set, complementary, point_adherent in |- *; + unfold open_set, complementary, point_adherent in |- *; intros; set (P := fun V:R -> Prop => neighbourhood V x -> exists y : R, intersection_domain V D y); - assert (H0 := not_all_ex_not _ P H); elim H0; intros V0 H1; + assert (H0 := not_all_ex_not _ P H); elim H0; intros V0 H1; unfold P in H1; assert (H2 := imply_to_and _ _ H1); unfold neighbourhood in |- *; elim H2; intros; unfold neighbourhood in H3; - elim H3; intros; exists x0; unfold included in |- *; + elim H3; intros; exists x0; unfold included in |- *; intros; red in |- *; intro. assert (H8 := H7 V0); cut (exists delta : posreal, (forall x:R, disc x1 delta x -> V0 x)). @@ -170,7 +170,7 @@ Proof. apply adherence_P2; assumption. unfold eq_Dom in |- *; unfold included in |- *; intros; assert (H0 := adherence_P3 D); unfold closed_set in H0; - unfold closed_set in |- *; unfold open_set in |- *; + unfold closed_set in |- *; unfold open_set in |- *; unfold open_set in H0; intros; assert (H2 : complementary (adherence D) x). unfold complementary in |- *; unfold complementary in H1; red in |- *; intro; elim H; clear H; intros _ H; elim H1; apply (H _ H2). @@ -178,7 +178,7 @@ Proof. unfold neighbourhood in H3; elim H3; intros; exists x0; unfold included in |- *; unfold included in H4; intros; assert (H6 := H4 _ H5); unfold complementary in H6; - unfold complementary in |- *; red in |- *; intro; + unfold complementary in |- *; red in |- *; intro; elim H; clear H; intros H _; elim H6; apply (H _ H7). Qed. @@ -187,7 +187,7 @@ Lemma neighbourhood_P1 : included D1 D2 -> neighbourhood D1 x -> neighbourhood D2 x. Proof. unfold included, neighbourhood in |- *; intros; elim H0; intros; exists x0; - intros; unfold included in |- *; unfold included in H1; + intros; unfold included in |- *; unfold included in H1; intros; apply (H _ (H1 _ H2)). Qed. @@ -211,8 +211,8 @@ Proof. unfold open_set in |- *; intros; unfold intersection_domain in H1; elim H1; intros. assert (H4 := H _ H2); assert (H5 := H0 _ H3); - unfold intersection_domain in |- *; unfold neighbourhood in H4, H5; - elim H4; clear H; intros del1 H; elim H5; clear H0; + unfold intersection_domain in |- *; unfold neighbourhood in H4, H5; + elim H4; clear H; intros del1 H; elim H5; clear H0; intros del2 H0; cut (0 < Rmin del1 del2). intro; set (del := mkposreal _ H6). exists del; unfold included in |- *; intros; unfold included in H, H0; @@ -292,7 +292,7 @@ Proof. apply (sym_not_eq (A:=R)); apply H7. unfold disc in H6; apply H6. intros; unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; intros. assert (H1 := H (disc (f x) (mkposreal eps H0))). cut (neighbourhood (disc (f x) (mkposreal eps H0)) (f x)). @@ -317,8 +317,8 @@ Proof. intros; unfold open_set in H0; unfold open_set in |- *; intros; assert (H2 := continuity_P1 f x); elim H2; intros H3 _; assert (H4 := H3 (H x)); unfold neighbourhood, image_rec in |- *; - unfold image_rec in H1; assert (H5 := H4 D (H0 (f x) H1)); - elim H5; intros V0 H6; elim H6; intros; unfold neighbourhood in H7; + unfold image_rec in H1; assert (H5 := H4 D (H0 (f x) H1)); + elim H5; intros V0 H6; elim H6; intros; unfold neighbourhood in H7; elim H7; intros del H9; exists del; unfold included in H9; unfold included in |- *; intros; apply (H8 _ (H9 _ H10)). Qed. @@ -333,7 +333,7 @@ Proof. intros; apply continuity_P2; assumption. intros; unfold continuity in |- *; unfold continuity_pt in |- *; unfold continue_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; + unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; intros; cut (open_set (disc (f x) (mkposreal _ H0))). intro; assert (H2 := H _ H1). unfold open_set, image_rec in H2; cut (disc (f x) (mkposreal _ H0) (f x)). @@ -466,7 +466,7 @@ Proof. cut (covering_open_set X f0). intro; assert (H3 := H1 H2); elim H3; intros D' H4; unfold covering_finite in H4; elim H4; intros; unfold family_finite in H6; - unfold domain_finite in H6; elim H6; intros l H7; + unfold domain_finite in H6; elim H6; intros l H7; unfold bounded in |- *; set (r := MaxRlist l). exists (- r); exists r; intros. unfold covering in H5; assert (H9 := H5 _ H8); elim H9; intros; @@ -538,9 +538,9 @@ Proof. intro; assert (H10 := H0 (disc x (mkposreal _ H9))); cut (neighbourhood (disc x (mkposreal alp H9)) x). intro; assert (H12 := H10 H11); elim H12; clear H12; intros y H12; - unfold intersection_domain in H12; elim H12; clear H12; - intros; assert (H14 := H7 _ H13); elim H14; clear H14; - intros y0 H14; elim H14; clear H14; intros; unfold g in H14; + unfold intersection_domain in H12; elim H12; clear H12; + intros; assert (H14 := H7 _ H13); elim H14; clear H14; + intros y0 H14; elim H14; clear H14; intros; unfold g in H14; elim H14; clear H14; intros; unfold disc in H12; simpl in H12; cut (alp <= Rabs (y0 - x) / 2). intro; assert (H18 := Rlt_le_trans _ _ _ H12 H17); @@ -557,10 +557,10 @@ Proof. unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; apply H9. unfold alp in |- *; apply MinRlist_P2; intros; - assert (H10 := AbsList_P2 _ _ _ H9); elim H10; clear H10; - intros z H10; elim H10; clear H10; intros; rewrite H11; + assert (H10 := AbsList_P2 _ _ _ H9); elim H10; clear H10; + intros z H10; elim H10; clear H10; intros; rewrite H11; apply H2; elim (H8 z); clear H8; intros; assert (H13 := H12 H10); - unfold intersection_domain, D in H13; elim H13; clear H13; + unfold intersection_domain, D in H13; elim H13; clear H13; intros; assumption. unfold covering_open_set in |- *; split. unfold covering in |- *; intros; exists x0; simpl in |- *; unfold g in |- *; @@ -577,7 +577,7 @@ Proof. rewrite <- (Rabs_Ropp (x0 - x1)); rewrite Ropp_minus_distr; apply H6. apply H5. unfold included, disc in |- *; simpl in |- *; intros; elim H6; intros; - rewrite <- (Rabs_Ropp (x1 - x0)); rewrite Ropp_minus_distr; + rewrite <- (Rabs_Ropp (x1 - x0)); rewrite Ropp_minus_distr; apply H7. apply open_set_P6 with (fun z:R => False). apply open_set_P4. @@ -639,8 +639,8 @@ Proof. 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; + 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). @@ -651,11 +651,11 @@ Proof. set (Db := fun x:R => Dx x \/ x = y0); exists Db; unfold covering_finite in |- *; split. unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12; - intros; unfold covering in H12; case (Rle_dec x0 x); + 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 in |- *; unfold Db in |- *; elim H16; + simpl in H16; simpl in |- *; unfold Db in |- *; elim H16; clear H16; intros; split; [ apply H16 | left; apply H17 ]. split. elim H14; intros; assumption. @@ -672,9 +672,9 @@ Proof. apply Rge_minus; apply Rle_ge; elim H14; intros _ H15; apply H15. unfold Db in |- *; right; reflexivity. unfold family_finite in |- *; unfold domain_finite in |- *; - 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 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); intro; split. intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0); clear H13; intros; case (Req_dec x0 y0); intro. @@ -723,7 +723,7 @@ Proof. set (Db := fun x:R => Dx x \/ x = y0); exists Db; unfold covering_finite in |- *; split. unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12; - intros; unfold covering in H12; case (Rle_dec x0 x); + 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; @@ -758,15 +758,15 @@ Proof. ring. unfold Db in |- *; right; reflexivity. unfold family_finite in |- *; unfold domain_finite in |- *; - 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 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); intro; split. intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0); clear H13; intros; case (Req_dec x0 y0); intro. simpl in |- *; left; apply H16. simpl in |- *; right; apply H13; simpl in |- *; - unfold intersection_domain in |- *; unfold Db in H14; + unfold intersection_domain in |- *; unfold Db in H14; decompose [and or] H14. split; assumption. elim H16; assumption. @@ -793,7 +793,7 @@ Proof. 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 in |- *; intros; - assert (H14 := not_and_or _ _ (H12 x)); elim H14; + assert (H14 := not_and_or _ _ (H12 x)); elim H14; intro. elim H15; apply H13. elim (not_and_or _ _ H15); intro. @@ -806,11 +806,11 @@ Proof. split. apply (H3 _ H0). apply (H4 b); unfold is_upper_bound in |- *; intros; unfold A in H5; elim H5; - clear H5; intros H5 _; elim H5; clear H5; intros _ H5; + clear H5; intros H5 _; elim H5; clear H5; intros _ H5; apply H5. exists a; apply H0. unfold bound in |- *; exists b; unfold is_upper_bound in |- *; intros; - unfold A in H1; elim H1; clear H1; intros H1 _; elim H1; + unfold A in H1; elim H1; clear H1; intros H1 _; elim H1; clear H1; intros _ H1; apply H1. unfold A in |- *; split. split; [ right; reflexivity | apply r ]. @@ -862,15 +862,15 @@ Proof. elim H10; intros H11 _; unfold complementary in H11; elim H11; apply H7. apply H9. unfold family_finite in |- *; unfold domain_finite in |- *; - unfold family_finite in H6; unfold domain_finite in H6; + unfold family_finite in H6; unfold domain_finite in H6; elim H6; clear H6; intros l H6; exists l; intro; assert (H7 := H6 x); elim H7; clear H7; intros. split. intro; apply H7; simpl in |- *; unfold intersection_domain in |- *; - simpl in H9; unfold intersection_domain in H9; unfold D' in |- *; + simpl in H9; unfold intersection_domain in H9; unfold D' in |- *; apply H9. intro; assert (H10 := H8 H9); simpl in H10; unfold intersection_domain in H10; - simpl in |- *; unfold intersection_domain in |- *; + simpl in |- *; unfold intersection_domain in |- *; unfold D' in H10; apply H10. unfold covering_open_set in |- *; unfold covering_open_set in H2; elim H2; clear H2; intros. @@ -964,14 +964,14 @@ Proof. simpl in H11; elim H11; intros z H12; exists z; unfold g in H12; unfold image_rec in H12; rewrite H9; apply H12. unfold family_finite in H6; unfold domain_finite in H6; - unfold family_finite in |- *; unfold domain_finite in |- *; - elim H6; intros l H7; exists l; intro; elim (H7 x); + unfold family_finite in |- *; unfold domain_finite in |- *; + elim H6; intros l H7; exists l; intro; elim (H7 x); intros; split; intro. apply H8; simpl in H10; simpl in |- *; apply H10. apply (H9 H10). unfold covering_open_set in |- *; split. unfold covering in |- *; intros; simpl in |- *; unfold covering in H1; - unfold image_dir in H1; unfold g in |- *; unfold image_rec in |- *; + unfold image_dir in H1; unfold g in |- *; unfold image_rec in |- *; apply H1. exists x; split; [ reflexivity | apply H4 ]. unfold family_open_set in |- *; unfold family_open_set in H2; intro; @@ -1014,8 +1014,8 @@ Proof. exists h; split. unfold continuity in |- *; intro; case (Rtotal_order x a); intro. unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; - simpl in |- *; unfold R_dist in |- *; intros; exists (a - x); + unfold limit1_in in |- *; unfold limit_in in |- *; + simpl in |- *; unfold R_dist in |- *; intros; exists (a - x); split. change (0 < a - x) in |- *; apply Rlt_Rminus; assumption. intros; elim H5; clear H5; intros _ H5; unfold h in |- *. @@ -1034,8 +1034,8 @@ Proof. unfold limit1_in in H6; unfold limit_in in H6; simpl in H6; unfold R_dist in H6; unfold continuity_pt in |- *; unfold continue_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; - intros; elim (H6 _ H7); intros; exists (Rmin x0 (b - a)); + unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; + intros; elim (H6 _ H7); intros; exists (Rmin x0 (b - a)); split. unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro. elim H8; intros; assumption. @@ -1067,8 +1067,8 @@ Proof. unfold limit1_in in H7; unfold limit_in in H7; simpl in H7; unfold R_dist in H7; unfold continuity_pt in |- *; unfold continue_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; - intros; elim (H7 _ H8); intros; elim H9; clear H9; + unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; + intros; elim (H7 _ H8); intros; elim H9; clear H9; intros. assert (H11 : 0 < x - a). apply Rlt_Rminus; assumption. @@ -1119,8 +1119,8 @@ Proof. unfold limit1_in in H8; unfold limit_in in H8; simpl in H8; unfold R_dist in H8; unfold continuity_pt in |- *; unfold continue_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; - intros; elim (H8 _ H9); intros; exists (Rmin x0 (b - a)); + unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; + intros; elim (H8 _ H9); intros; exists (Rmin x0 (b - a)); split. unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro. elim H10; intros; assumption. @@ -1152,8 +1152,8 @@ Proof. assumption. apply Rmin_r. unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; - simpl in |- *; unfold R_dist in |- *; intros; exists (x - b); + unfold limit1_in in |- *; unfold limit_in in |- *; + simpl in |- *; unfold R_dist in |- *; intros; exists (x - b); split. change (0 < x - b) in |- *; apply Rlt_Rminus; assumption. intros; elim H8; clear H8; intros. @@ -1210,8 +1210,8 @@ Proof. intro; unfold image_dir in H8; elim H8; clear H8; intros Mxx H8; elim H8; clear H8; intros; exists Mxx; split. intros; rewrite <- (Heq c H10); rewrite <- (Heq Mxx H9); intros; - rewrite <- H8; unfold is_lub in H7; elim H7; clear H7; - intros H7 _; unfold is_upper_bound in H7; apply H7; + rewrite <- H8; unfold is_lub in H7; elim H7; clear H7; + intros H7 _; unfold is_upper_bound in H7; apply H7; unfold image_dir in |- *; exists c; split; [ reflexivity | apply H10 ]. apply H9. elim (classic (image_dir g (fun c:R => a <= c <= b) M)); intro. @@ -1298,7 +1298,7 @@ Proof. intro; assert (H2 := continuity_ab_maj (- f0)%F a b H H1); elim H2; intros x0 H3; exists x0; intros; split. intros; rewrite <- (Ropp_involutive (f0 x0)); - rewrite <- (Ropp_involutive (f0 c)); apply Ropp_le_contravar; + rewrite <- (Ropp_involutive (f0 c)); apply Ropp_le_contravar; elim H3; intros; unfold opp_fct in H5; apply H5; apply H4. elim H3; intros; assumption. intros. @@ -1348,10 +1348,10 @@ Lemma ValAdh_un_prop : Proof. intros; split; intro. unfold ValAdh in H; unfold ValAdh_un in |- *; - unfold intersection_family in |- *; simpl in |- *; + unfold intersection_family in |- *; simpl in |- *; intros; elim H0; intros N H1; unfold adherence in |- *; - unfold point_adherent in |- *; intros; elim (H V N H2); - intros; exists (un x0); unfold intersection_domain in |- *; + unfold point_adherent in |- *; intros; elim (H V N H2); + intros; exists (un x0); unfold intersection_domain in |- *; elim H3; clear H3; intros; split. assumption. split. @@ -1367,9 +1367,9 @@ Proof. (exists n : nat, INR N = INR n)) x). apply H; exists N; reflexivity. unfold adherence in H1; unfold point_adherent in H1; assert (H2 := H1 _ H0); - elim H2; intros; unfold intersection_domain in H3; - elim H3; clear H3; intros; elim H4; clear H4; intros; - elim H4; clear H4; intros; elim H4; clear H4; intros; + elim H2; intros; unfold intersection_domain in H3; + elim H3; clear H3; intros; elim H4; clear H4; intros; + elim H4; clear H4; intros; elim H4; clear H4; intros; exists x1; split. apply (INR_le _ _ H6). rewrite H4 in H3; apply H3. @@ -1379,7 +1379,7 @@ Lemma adherence_P4 : forall F G:R -> Prop, included F G -> included (adherence F) (adherence G). Proof. unfold adherence, included in |- *; unfold point_adherent in |- *; intros; - elim (H0 _ H1); unfold intersection_domain in |- *; + elim (H0 _ H1); unfold intersection_domain in |- *; intros; elim H2; clear H2; intros; exists x0; split; [ assumption | apply (H _ H3) ]. Qed. @@ -1392,7 +1392,7 @@ Definition intersection_vide_in (D:R -> Prop) (f:family) : Prop := (ind f x -> included (f x) D) /\ ~ (exists y : R, intersection_family f y). -Definition intersection_vide_finite_in (D:R -> Prop) +Definition intersection_vide_finite_in (D:R -> Prop) (f:family) : Prop := intersection_vide_in D f /\ family_finite f. (**********) @@ -1417,9 +1417,9 @@ Proof. elim (H1 x); intros; unfold intersection_family in H5; assert (H6 := not_ex_all_not _ (fun y:R => forall y0:R, ind g y0 -> g y0 y) H5 x); - assert (H7 := not_all_ex_not _ (fun y0:R => ind g y0 -> g y0 x) H6); - elim H7; intros; exists x0; elim (imply_to_and _ _ H8); - intros; unfold f0 in |- *; simpl in |- *; unfold f' in |- *; + assert (H7 := not_all_ex_not _ (fun y0:R => ind g y0 -> g y0 x) H6); + elim H7; intros; exists x0; elim (imply_to_and _ _ H8); + intros; unfold f0 in |- *; simpl in |- *; unfold f' in |- *; split; [ apply H10 | apply H9 ]. unfold family_open_set in |- *; intro; elim (classic (D' x)); intro. apply open_set_P6 with (complementary (g x)). @@ -1448,7 +1448,7 @@ Proof. unfold covering in H4; elim (H4 x0 H7); intros; simpl in H8; unfold intersection_domain in H6; cut (ind g x1 /\ SF x1). intro; assert (H10 := H6 x1 H9); elim H10; clear H10; intros H10 _; elim H8; - clear H8; intros H8 _; unfold f' in H8; unfold complementary in H8; + clear H8; intros H8 _; unfold f' in H8; unfold complementary in H8; elim H8; clear H8; intros H8 _; elim H8; assumption. split. apply (cond_fam f0). @@ -1463,15 +1463,15 @@ Proof. unfold covering_finite in H4; elim H4; clear H4; intros H4 _; cut (exists z : R, X z). intro; elim H5; clear H5; intros; unfold covering in H4; elim (H4 x0 H5); - intros; simpl in H6; elim Hyp'; exists x1; elim H6; + intros; simpl in H6; elim Hyp'; exists x1; elim H6; intros; unfold intersection_domain in |- *; split. apply (cond_fam f0); exists x0; apply H7. apply H8. apply Hyp. unfold covering_finite in H4; elim H4; clear H4; intros; unfold family_finite in H5; unfold domain_finite in H5; - unfold family_finite in |- *; unfold domain_finite in |- *; - elim H5; clear H5; intros l H5; exists l; intro; elim (H5 x); + unfold family_finite in |- *; unfold domain_finite in |- *; + elim H5; clear H5; intros l H5; exists l; intro; elim (H5 x); intros; split; intro; [ apply H6; simpl in |- *; simpl in H8; apply H8 | apply (H7 H8) ]. Qed. @@ -1506,7 +1506,7 @@ Proof. intro; cut (intersection_vide_in X f0). intro; assert (H7 := H3 H5 H6). elim H7; intros SF H8; unfold intersection_vide_finite_in in H8; elim H8; - clear H8; intros; unfold intersection_vide_in in H8; + clear H8; intros; unfold intersection_vide_in in H8; elim (H8 0); intros _ H10; elim H10; unfold family_finite in H9; unfold domain_finite in H9; elim H9; clear H9; intros l H9; set (r := MaxRlist l); cut (D r). @@ -1536,7 +1536,7 @@ Proof. assert (H17 := not_ex_all_not _ (fun z:R => intersection_domain (ind f0) SF z) H13); - assert (H18 := H16 x); unfold intersection_family in H18; + assert (H18 := H16 x); unfold intersection_family in H18; simpl in H18; assert (H19 := @@ -1598,17 +1598,17 @@ Theorem Heine : (forall x:R, X x -> continuity_pt f x) -> uniform_continuity f X. Proof. intros f0 X H0 H; elim (domain_P1 X); intro Hyp. -(* X est vide *) +(* X is empty *) unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1); intros; elim Hyp; exists x; assumption. elim Hyp; clear Hyp; intro Hyp. -(* X possde un seul lment *) +(* X has only one element *) unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1); - intros; elim Hyp; clear Hyp; intros; elim H4; clear H4; - intros; assert (H6 := H5 _ H1); assert (H7 := H5 _ H2); + intros; elim Hyp; clear Hyp; intros; elim H4; clear H4; + intros; assert (H6 := H5 _ H1); assert (H7 := H5 _ H2); rewrite H6; rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; apply (cond_pos eps). -(* X possde au moins deux lments distincts *) +(* X has at least two distinct elements *) assert (X_enc : exists m : R, (exists M : R, (forall x:R, X x -> m <= x <= M) /\ m < M)). @@ -1616,8 +1616,8 @@ Proof. elim H2; intros; exists x; exists x0; split. apply H3. elim Hyp; intros; elim H4; intros; decompose [and] H5; - assert (H10 := H3 _ H6); assert (H11 := H3 _ H8); - elim H10; intros; elim H11; intros; case (total_order_T x x0); + assert (H10 := H3 _ H6); assert (H11 := H3 _ H8); + elim H10; intros; elim H11; intros; case (total_order_T x x0); intro. elim s; intro. assumption. @@ -1652,7 +1652,7 @@ Proof. assumption. assert (H4 := H _ H3); unfold continuity_pt in H4; unfold continue_in in H4; unfold limit1_in in H4; unfold limit_in in H4; simpl in H4; - unfold R_dist in H4; elim (H4 (eps / 2) (H1 eps)); + unfold R_dist in H4; elim (H4 (eps / 2) (H1 eps)); intros; set (E := @@ -1661,7 +1661,7 @@ Proof. (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2)); assert (H6 : bound E). unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *; - unfold E in |- *; intros; elim H6; clear H6; intros H6 _; + unfold E in |- *; intros; elim H6; clear H6; intros H6 _; elim H6; clear H6; intros _ H6; apply H6. assert (H7 : exists x : R, E x). elim H5; clear H5; intros; exists (Rmin x0 (M - m)); unfold E in |- *; intros; @@ -1693,14 +1693,14 @@ Proof. intro; assert (H16 := H14 _ H15); elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H16)). unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H13; - assert (H16 := H13 _ H15); case (Rle_dec x2 (Rabs (z - x))); + assert (H16 := H13 _ H15); case (Rle_dec x2 (Rabs (z - x))); intro. assumption. elim (H12 x2); split; [ split; [ auto with real | assumption ] | assumption ]. split. apply p. unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r; - rewrite Rabs_R0; simpl in |- *; unfold Rdiv in |- *; + rewrite Rabs_R0; simpl in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ apply H8 | apply Rinv_0_lt_compat; prove_sup0 ]. elim H7; intros; unfold E in H8; elim H8; intros H9 _; elim H9; intros H10 _; unfold is_lub in p; elim p; intros; unfold is_upper_bound in H12; @@ -1711,8 +1711,8 @@ Proof. unfold family_open_set in |- *; intro; simpl in |- *; elim (classic (X x)); intro. unfold g in |- *; unfold open_set in |- *; intros; elim H4; clear H4; - intros _ H4; elim H4; clear H4; intros; elim H4; clear H4; - intros; unfold neighbourhood in |- *; case (Req_dec x x0); + intros _ H4; elim H4; clear H4; intros; elim H4; clear H4; + intros; unfold neighbourhood in |- *; case (Req_dec x x0); intro. exists (mkposreal _ (H1 x1)); rewrite <- H6; unfold included in |- *; intros; split. @@ -1745,7 +1745,7 @@ Proof. intros; unfold g in H4; elim H4; clear H4; intros H4 _; elim H3; apply H4. elim (H0 _ H3); intros DF H4; unfold covering_finite in H4; elim H4; clear H4; intros; unfold family_finite in H5; unfold domain_finite in H5; - unfold covering in H4; simpl in H4; simpl in H5; elim H5; + unfold covering in H4; simpl in H4; simpl in H5; elim H5; clear H5; intros l H5; unfold intersection_domain in H5; cut (forall x:R, @@ -1761,8 +1761,8 @@ Proof. (fun x del:R => 0 < del /\ (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\ - included (g x) (fun z:R => Rabs (z - x) < del / 2)) H6); - elim H7; clear H7; intros l' H7; elim H7; clear H7; + included (g x) (fun z:R => Rabs (z - x) < del / 2)) H6); + elim H7; clear H7; intros l' H7; elim H7; clear H7; intros; set (D := MinRlist l'); cut (0 < D / 2). intro; exists (mkposreal _ H9); intros; assert (H13 := H4 _ H10); elim H13; clear H13; intros xi H13; assert (H14 : In xi l). @@ -1785,8 +1785,8 @@ Proof. rewrite double; apply Rplus_lt_compat_l; apply H19. discrR. assert (H19 := H8 i H17); elim H19; clear H19; intros; rewrite <- H18 in H20; - elim H20; clear H20; intros; rewrite <- Rabs_Ropp; - rewrite Ropp_minus_distr; apply H20; unfold included in H21; + elim H20; clear H20; intros; rewrite <- Rabs_Ropp; + rewrite Ropp_minus_distr; apply H20; unfold included in H21; elim H13; intros; assert (H24 := H21 x H22); apply Rle_lt_trans with (Rabs (y - x) + Rabs (x - xi)). replace (y - xi) with (y - x + (x - xi)); [ apply Rabs_triang | ring ]. @@ -1803,7 +1803,7 @@ Proof. unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ unfold D in |- *; apply MinRlist_P2; intros; elim (pos_Rl_P2 l' y); intros; elim (H10 H9); intros; elim H12; intros; rewrite H14; - rewrite <- H7 in H13; elim (H8 x H13); intros; + rewrite <- H7 in H13; elim (H8 x H13); intros; apply H15 | apply Rinv_0_lt_compat; prove_sup0 ]. intros; elim (H5 x); intros; elim (H8 H6); intros; @@ -1814,14 +1814,14 @@ Proof. (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2)); assert (H11 : bound E). unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *; - unfold E in |- *; intros; elim H11; clear H11; intros H11 _; + unfold E in |- *; intros; elim H11; clear H11; intros H11 _; elim H11; clear H11; intros _ H11; apply H11. assert (H12 : exists x : R, E x). assert (H13 := H _ H9); unfold continuity_pt in H13; - unfold continue_in in H13; unfold limit1_in in H13; + unfold continue_in in H13; unfold limit1_in in H13; unfold limit_in in H13; simpl in H13; unfold R_dist in H13; - elim (H13 _ (H1 eps)); intros; elim H12; clear H12; - intros; exists (Rmin x0 (M - m)); unfold E in |- *; + elim (H13 _ (H1 eps)); intros; elim H12; clear H12; + intros; exists (Rmin x0 (M - m)); unfold E in |- *; intros; split. split; [ unfold Rmin in |- *; case (Rle_dec x0 (M - m)); intro; @@ -1850,7 +1850,7 @@ Proof. intro; assert (H21 := H19 _ H20); elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H15 H21)). unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H18; - assert (H21 := H18 _ H20); case (Rle_dec x1 (Rabs (z - x))); + assert (H21 := H18 _ H20); case (Rle_dec x1 (Rabs (z - x))); intro. assumption. elim (H17 x1); split. @@ -1864,7 +1864,7 @@ Proof. apply H21. elim H12; intros; unfold E in H13; elim H13; intros H14 _; elim H14; intros H15 _; unfold is_lub in p; elim p; intros; - unfold is_upper_bound in H16; unfold is_upper_bound in H17; + unfold is_upper_bound in H16; unfold is_upper_bound in H17; split. apply Rlt_le_trans with x1; [ assumption | apply (H16 _ H13) ]. apply H17; intros; unfold E in H18; elim H18; intros; elim H19; intros; diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v index 0baece39..c637b7ab 100644 --- a/theories/Reals/Rtrigo.v +++ b/theories/Reals/Rtrigo.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo.v 9454 2006-12-15 15:30:59Z bgregoir $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -19,8 +19,8 @@ Require Export Cos_plus. Require Import ZArith_base. Require Import Zcomplements. Require Import Classical_Prop. -Open Local Scope nat_scope. -Open Local Scope R_scope. +Local Open Scope nat_scope. +Local Open Scope R_scope. (** sin_PI2 is the only remaining axiom **) Axiom sin_PI2 : sin (PI / 2) = 1. @@ -32,7 +32,7 @@ Proof. elim (Rlt_irrefl _ H0). Qed. -(**********) +(**********) Lemma cos_minus : forall x y:R, cos (x - y) = cos x * cos y + sin x * sin y. Proof. intros; unfold Rminus in |- *; rewrite cos_plus. @@ -50,7 +50,7 @@ Lemma cos2 : forall x:R, Rsqr (cos x) = 1 - Rsqr (sin x). Proof. intro x; generalize (sin2_cos2 x); intro H1; rewrite <- H1; unfold Rminus in |- *; rewrite <- (Rplus_comm (Rsqr (cos x))); - rewrite Rplus_assoc; rewrite Rplus_opp_r; symmetry in |- *; + rewrite Rplus_assoc; rewrite Rplus_opp_r; symmetry in |- *; apply Rplus_0_r. Qed. @@ -151,7 +151,7 @@ Proof. rewrite <- Rinv_r_sym. rewrite Rmult_1_l; rewrite (Rmult_comm (sin x)); rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite Rmult_assoc; - apply Rmult_eq_compat_l; rewrite (Rmult_comm (/ cos y)); + apply Rmult_eq_compat_l; rewrite (Rmult_comm (/ cos y)); rewrite Rmult_assoc; rewrite <- Rinv_r_sym. apply Rmult_1_r. assumption. @@ -185,7 +185,7 @@ Qed. Lemma cos_2a_cos : forall x:R, cos (2 * x) = 2 * cos x * cos x - 1. Proof. intro x; rewrite double; unfold Rminus in |- *; rewrite Rmult_assoc; - rewrite cos_plus; generalize (sin2_cos2 x); rewrite double; + rewrite cos_plus; generalize (sin2_cos2 x); rewrite double; intro H1; rewrite <- H1; ring_Rsqr. Qed. @@ -219,7 +219,7 @@ Qed. Lemma tan_0 : tan 0 = 0. Proof. unfold tan in |- *; rewrite sin_0; rewrite cos_0. - unfold Rdiv in |- *; apply Rmult_0_l. + unfold Rdiv in |- *; apply Rmult_0_l. Qed. Lemma tan_neg : forall x:R, tan (- x) = - tan x. @@ -320,7 +320,7 @@ Lemma PI2_RGT_0 : 0 < PI / 2. Proof. unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup ]. -Qed. +Qed. Lemma SIN_bound : forall x:R, -1 <= sin x <= 1. Proof. @@ -331,13 +331,13 @@ Proof. intro; generalize (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1) - (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H))); + (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H))); rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0; generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0); - repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; + repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); - repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); + repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)). auto with real. cut (sin x < -1). @@ -346,13 +346,13 @@ Proof. generalize (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1) (Rlt_le 0 (- sin x) (Rlt_trans 0 1 (- sin x) Rlt_0_1 H))); - rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0; + rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0; rewrite sin2 in H0; unfold Rminus in H0; generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0); - repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; + repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); - repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); + repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)). auto with real. Qed. @@ -366,7 +366,7 @@ Lemma cos_sin_0 : forall x:R, ~ (cos x = 0 /\ sin x = 0). Proof. intro; red in |- *; intro; elim H; intros; generalize (sin2_cos2 x); intro; rewrite H0 in H2; rewrite H1 in H2; repeat rewrite Rsqr_0 in H2; - rewrite Rplus_0_r in H2; generalize Rlt_0_1; intro; + rewrite Rplus_0_r in H2; generalize Rlt_0_1; intro; rewrite <- H2 in H3; elim (Rlt_irrefl 0 H3). Qed. @@ -399,18 +399,18 @@ Proof. repeat rewrite Rmult_1_l; repeat rewrite Rmult_1_r; replace (-1 * Un 1%nat) with (- Un 1%nat); [ idtac | ring ]; replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ]; - replace (-1 * (-1 * -1) * Un 3%nat) with (- Un 3%nat); + replace (-1 * (-1 * -1) * Un 3%nat) with (- Un 3%nat); [ idtac | ring ]; replace (Un 0%nat + - Un 1%nat + Un 2%nat + - Un 3%nat) with (Un 0%nat - Un 1%nat + (Un 2%nat - Un 3%nat)); [ idtac | ring ]. apply Rplus_lt_0_compat. unfold Rminus in |- *; apply Rplus_lt_reg_r 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; + 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); - rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat)); - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; + rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat)); + rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; apply H1. intro; unfold Un in |- *. cut ((2 * S n + 1)%nat = (2 * n + 1 + 2)%nat). @@ -533,7 +533,7 @@ Proof. (SIN (PI - x) (Rlt_le 0 (PI - x) H7) (Rlt_le (PI - x) PI (Rlt_trans (PI - x) (PI / 2) PI H5 PI2_Rlt_PI))); intros H8 _; - generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5)); + generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5)); intro H9; apply (Rlt_le_trans 0 (sin_lb (PI - x)) (sin (PI - x)) H9 H8). reflexivity. pattern PI at 2 in |- *; rewrite double_var; ring. @@ -545,7 +545,7 @@ Proof. intros; rewrite cos_sin; generalize (Rplus_lt_compat_l (PI / 2) (- (PI / 2)) x H). rewrite Rplus_opp_r; intro H1; - generalize (Rplus_lt_compat_l (PI / 2) x (PI / 2) H0); + generalize (Rplus_lt_compat_l (PI / 2) x (PI / 2) H0); rewrite <- double_var; intro H2; apply (sin_gt_0 (PI / 2 + x) H1 H2). Qed. @@ -599,7 +599,7 @@ Proof. replace (PI / 2) with (- PI + 3 * (PI / 2)). apply Rplus_le_compat_l; assumption. pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr; - ring. + ring. unfold INR in |- *; ring. Qed. @@ -625,7 +625,7 @@ Proof. intros; generalize (Rplus_lt_compat_l (2 * PI) (- PI) x H); replace (2 * PI + - PI) with PI; [ intro H1; rewrite Rplus_comm in H1; - generalize (Rplus_lt_compat_l (2 * PI) x 0 H0); + generalize (Rplus_lt_compat_l (2 * PI) x 0 H0); intro H2; rewrite (Rplus_comm (2 * PI)) in H2; rewrite <- (Rplus_comm 0) in H2; rewrite Rplus_0_l in H2; rewrite <- (sin_period x 1); unfold INR in |- *; @@ -644,12 +644,12 @@ Proof. unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_lt_compat_l; assumption. pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr; - ring. + ring. unfold Rminus in |- *; rewrite Rplus_comm; replace (PI / 2) with (- PI + 3 * (PI / 2)). apply Rplus_lt_compat_l; assumption. pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr; - ring. + ring. unfold INR in |- *; ring. Qed. @@ -658,7 +658,7 @@ Proof. intros x H1 H2; unfold tan in |- *; generalize _PI2_RLT_0; generalize (Rlt_trans 0 x (PI / 2) H1 H2); intros; generalize (Rlt_trans (- (PI / 2)) 0 x H0 H1); intro H5; - generalize (Rlt_trans x (PI / 2) PI H2 PI2_Rlt_PI); + generalize (Rlt_trans x (PI / 2) PI H2 PI2_Rlt_PI); intro H7; unfold Rdiv in |- *; apply Rmult_lt_0_compat. apply sin_gt_0; assumption. apply Rinv_0_lt_compat; apply cos_gt_0; assumption. @@ -667,7 +667,7 @@ Qed. Lemma tan_lt_0 : forall x:R, - (PI / 2) < x -> x < 0 -> tan x < 0. Proof. intros x H1 H2; unfold tan in |- *; - generalize (cos_gt_0 x H1 (Rlt_trans x 0 (PI / 2) H2 PI2_RGT_0)); + generalize (cos_gt_0 x H1 (Rlt_trans x 0 (PI / 2) H2 PI2_RGT_0)); intro H3; rewrite <- Ropp_0; replace (sin x / cos x) with (- (- sin x / cos x)). rewrite <- sin_neg; apply Ropp_gt_lt_contravar; @@ -688,11 +688,11 @@ Proof. intros; rewrite <- cos_neg; rewrite <- (cos_period (- x) 1); unfold INR in |- *; replace (- x + 2 * 1 * PI) with (2 * PI - x). generalize (Ropp_le_ge_contravar x (2 * PI) H0); intro H1; - generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1; + generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1; intro H1; generalize (Rplus_le_compat_l (2 * PI) (- (2 * PI)) (- x) H1). - rewrite Rplus_opp_r. + rewrite Rplus_opp_r. intro H2; generalize (Ropp_le_ge_contravar (3 * (PI / 2)) x H); intro H3; - generalize (Rge_le (- (3 * (PI / 2))) (- x) H3); clear H3; + generalize (Rge_le (- (3 * (PI / 2))) (- x) H3); clear H3; intro H3; generalize (Rplus_le_compat_l (2 * PI) (- x) (- (3 * (PI / 2))) H3). replace (2 * PI + - (3 * (PI / 2))) with (PI / 2). @@ -780,11 +780,11 @@ Proof. generalize (Rmult_le_compat_l (/ 2) (x - y) PI (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H8). - repeat rewrite (Rmult_comm (/ 2)). + repeat rewrite (Rmult_comm (/ 2)). intro H9; generalize (sin_gt_0 ((x - y) / 2) H6 - (Rle_lt_trans ((x - y) / 2) (PI / 2) PI H9 PI2_Rlt_PI)); + (Rle_lt_trans ((x - y) / 2) (PI / 2) PI H9 PI2_Rlt_PI)); intro H10; elim (Rlt_irrefl (sin ((x - y) / 2)) @@ -799,7 +799,7 @@ Proof. generalize (Rmult_le_compat_l (/ 2) (x + y) PI (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H4). - repeat rewrite (Rmult_comm (/ 2)). + repeat rewrite (Rmult_comm (/ 2)). clear H4; intro H4; generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) y H H1); replace (- (PI / 2) + - (PI / 2)) with (- PI). @@ -813,7 +813,7 @@ Proof. elim H5; intro H50. generalize (cos_gt_0 ((x + y) / 2) H50 H40); intro H6; generalize (Rmult_lt_compat_l 2 0 (cos ((x + y) / 2)) Hyp H6). - rewrite Rmult_0_r. + rewrite Rmult_0_r. clear H6; intro H6; case (Rcase_abs (sin ((x - y) / 2))); intro H7. assumption. generalize (Rge_le (sin ((x - y) / 2)) 0 H7); clear H7; intro H7; @@ -824,7 +824,7 @@ Proof. (Rle_lt_trans 0 (2 * cos ((x + y) / 2) * sin ((x - y) / 2)) 0 H8 H3); intro H9; elim (Rlt_irrefl 0 H9). rewrite <- H50 in H3; rewrite cos_neg in H3; rewrite cos_PI2 in H3; - rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3; + rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3; elim (Rlt_irrefl 0 H3). unfold Rdiv in H3. rewrite H40 in H3; assert (H50 := cos_PI2); unfold Rdiv in H50; @@ -865,8 +865,8 @@ Proof. clear H5 H6 H7; intro H5; generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1); rewrite Ropp_involutive; clear H1; intro H1; generalize (Rge_le (PI / 2) (- y) H1); clear H1; intro H1; - generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2; - intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2); + generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2; + intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2); clear H2; intro H2; generalize (Rplus_lt_compat_l (- y) x y H3); replace (- y + x) with (x - y). rewrite Rplus_opp_l. @@ -885,12 +885,12 @@ Proof. replace (/ 2 * (x - y)) with ((x - y) / 2). clear H7; intro H7; clear H H0 H1 H2; apply Rminus_lt; rewrite form4; generalize (cos_gt_0 ((x + y) / 2) H4 H5); intro H8; - generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8); + generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8); clear H8; intro H8; cut (- PI < - (PI / 2)). intro H9; generalize (sin_lt_0_var ((x - y) / 2) - (Rlt_le_trans (- PI) (- (PI / 2)) ((x - y) / 2) H9 H7) H6); + (Rlt_le_trans (- PI) (- (PI / 2)) ((x - y) / 2) H9 H7) H6); intro H10; generalize (Rmult_lt_gt_compat_neg_l (sin ((x - y) / 2)) 0 ( @@ -1012,21 +1012,21 @@ Proof. 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). unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. + rewrite Ropp_mult_distr_l_reverse. + apply Rplus_comm. unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. + rewrite Ropp_mult_distr_l_reverse. + apply Rplus_comm. pattern PI at 3 in |- *; rewrite double_var. ring. rewrite double; pattern PI at 3 4 in |- *; rewrite double_var. ring. unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. + rewrite Ropp_mult_distr_l_reverse. + apply Rplus_comm. unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. + rewrite Ropp_mult_distr_l_reverse. + apply Rplus_comm. rewrite Rmult_1_r. rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var. ring. @@ -1110,7 +1110,7 @@ Lemma tan_diff : cos x <> 0 -> cos y <> 0 -> tan x - tan y = sin (x - y) / (cos x * cos y). Proof. intros; unfold tan in |- *; rewrite sin_minus. - unfold Rdiv in |- *. + unfold Rdiv in |- *. unfold Rminus in |- *. rewrite Rmult_plus_distr_r. rewrite Rinv_mult_distr. @@ -1143,7 +1143,7 @@ Lemma tan_increasing_0 : x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x < tan y -> x < y. Proof. intros; generalize PI4_RLT_PI2; intro H4; - generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); + generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); intro H5; change (- (PI / 2) < - (PI / 4)) in H5; generalize (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H) @@ -1155,20 +1155,20 @@ Proof. (sym_not_eq (Rlt_not_eq 0 (cos x) (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H) - (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); + (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); intro H6; generalize (sym_not_eq (Rlt_not_eq 0 (cos y) (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1) - (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); + (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); intro H7; generalize (tan_diff x y H6 H7); intro H8; - generalize (Rlt_minus (tan x) (tan y) H3); clear H3; + generalize (Rlt_minus (tan x) (tan y) H3); clear H3; intro H3; rewrite H8 in H3; cut (sin (x - y) < 0). intro H9; generalize (Ropp_le_ge_contravar (- (PI / 4)) y H1); rewrite Ropp_involutive; intro H10; generalize (Rge_le (PI / 4) (- y) H10); clear H10; intro H10; generalize (Ropp_le_ge_contravar y (PI / 4) H2); - intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); + intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); clear H11; intro H11; generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11); generalize (Rplus_le_compat x (PI / 4) (- y) (PI / 4) H0 H10); @@ -1180,7 +1180,7 @@ Proof. (sin_gt_0 (x - y) H14 (Rle_lt_trans (x - y) (PI / 2) PI H12 PI2_Rlt_PI)); intro H15; elim (Rlt_irrefl 0 (Rlt_trans 0 (sin (x - y)) 0 H15 H9)). elim H14; intro H15. - rewrite <- H15 in H9; rewrite sin_0 in H9; elim (Rlt_irrefl 0 H9). + rewrite <- H15 in H9; rewrite sin_0 in H9; elim (Rlt_irrefl 0 H9). apply Rminus_lt; assumption. pattern PI at 1 in |- *; rewrite double_var. unfold Rdiv in |- *. @@ -1218,7 +1218,7 @@ Proof. elim (Rlt_irrefl 0 (Rle_lt_trans 0 (sin (x - y) * / (cos x * cos y)) 0 H13 H3)). rewrite Rinv_mult_distr. - reflexivity. + reflexivity. assumption. assumption. Qed. @@ -1229,7 +1229,7 @@ Lemma tan_increasing_1 : x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x < y -> tan x < tan y. Proof. intros; apply Rminus_lt; generalize PI4_RLT_PI2; intro H4; - generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); + generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); intro H5; change (- (PI / 2) < - (PI / 4)) in H5; generalize (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H) @@ -1241,27 +1241,27 @@ Proof. (sym_not_eq (Rlt_not_eq 0 (cos x) (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H) - (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); + (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); intro H6; generalize (sym_not_eq (Rlt_not_eq 0 (cos y) (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1) - (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); + (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); intro H7; rewrite (tan_diff x y H6 H7); generalize (Rinv_0_lt_compat (cos x) HP1); intro H10; generalize (Rinv_0_lt_compat (cos y) HP2); intro H11; generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11); replace (/ cos x * / cos y) with (/ (cos x * cos y)). clear H10 H11; intro H8; generalize (Ropp_le_ge_contravar y (PI / 4) H2); - intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); + intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); clear H11; intro H11; generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11); replace (x + - y) with (x - y). replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)). clear H11; intro H9; generalize (Rlt_minus x y H3); clear H3; intro H3; - clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI; - intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1); + clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI; + intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1); clear H1; intro H1; generalize (sin_lt_0_var (x - y) (Rlt_le_trans (- PI) (- (PI / 2)) (x - y) H1 H9) H3); @@ -1576,13 +1576,13 @@ Proof. Qed. Lemma cos_eq_0_0 : - forall x:R, cos x = 0 -> exists k : Z, x = IZR k * PI + PI / 2. + forall x:R, cos x = 0 -> exists k : Z, x = IZR k * PI + PI / 2. Proof. intros x H; rewrite cos_sin in H; generalize (sin_eq_0_0 (PI / INR 2 + x) H); intro H2; elim H2; intros x0 H3; exists (x0 - Z_of_nat 1)%Z; rewrite <- Z_R_minus; simpl. unfold INR in H3. field_simplify [(sym_eq H3)]. field. -(** +(** ring_simplify. (* rewrite (Rmult_comm PI);*) (* old ring compat *) rewrite <- H3; simpl; @@ -1618,7 +1618,7 @@ Proof. (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H0); repeat rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym. repeat rewrite Rmult_1_r; intro; - generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H5); + generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H5); rewrite <- plus_IZR. replace (IZR (-2) + 1) with (-1). intro; generalize (Rplus_le_compat_l (IZR (-2)) (IZR k0) 2 H6); @@ -1710,7 +1710,7 @@ Proof. apply Rplus_le_le_0_compat. left; unfold Rdiv in |- *; apply Rmult_lt_0_compat. apply PI_RGT_0. - apply Rinv_0_lt_compat; prove_sup0. + apply Rinv_0_lt_compat; prove_sup0. assumption. elim H2; intro. right; assumption. diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index d82bafc6..fe2da839 100644 --- a/theories/Reals/Rtrigo_alt.v +++ b/theories/Reals/Rtrigo_alt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_alt.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -48,9 +48,9 @@ Theorem sin_bound : Proof. intros; case (Req_dec a 0); intro Hyp_a. rewrite Hyp_a; rewrite sin_0; split; right; unfold sin_approx in |- *; - apply sum_eq_R0 || (symmetry in |- *; apply sum_eq_R0); - intros; unfold sin_term in |- *; rewrite pow_add; - simpl in |- *; unfold Rdiv in |- *; rewrite Rmult_0_l; + apply sum_eq_R0 || (symmetry in |- *; apply sum_eq_R0); + intros; unfold sin_term in |- *; rewrite pow_add; + simpl in |- *; unfold Rdiv in |- *; rewrite Rmult_0_l; ring. unfold sin_approx in |- *; cut (0 < a). intro Hyp_a_pos. @@ -123,7 +123,7 @@ Proof. simpl in |- *; ring. ring. assert (H3 := cv_speed_pow_fact a); unfold Un in |- *; unfold Un_cv in H3; - unfold R_dist in H3; unfold Un_cv in |- *; unfold R_dist in |- *; + unfold R_dist in H3; unfold Un_cv in |- *; unfold R_dist in |- *; intros; elim (H3 eps H4); intros N H5. exists N; intros; apply H5. replace (2 * S n0 + 1)%nat with (S (2 * S n0)). @@ -138,7 +138,7 @@ Proof. 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 in |- *; unfold R_dist in |- *; + unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; intros. cut (0 < eps / Rabs a). intro; elim (p _ H5); intros N H6. @@ -146,9 +146,9 @@ Proof. replace (sum_f_R0 (tg_alt Un) n0) with (a * (1 - sum_f_R0 (fun i:nat => sin_n i * Rsqr a ^ i) (S n0))). unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r; - rewrite Ropp_plus_distr; rewrite Ropp_involutive; + rewrite Ropp_plus_distr; rewrite Ropp_involutive; repeat rewrite Rplus_assoc; rewrite (Rplus_comm a); - rewrite (Rplus_comm (- a)); repeat rewrite Rplus_assoc; + rewrite (Rplus_comm (- a)); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rmult_lt_reg_l with (/ Rabs a). apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. pattern (/ Rabs a) at 1 in |- *; rewrite <- (Rabs_Rinv a Hyp_a). @@ -163,7 +163,7 @@ Proof. simpl in |- *; rewrite Rmult_1_r; unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_l; rewrite Ropp_mult_distr_r_reverse; - rewrite <- Ropp_mult_distr_l_reverse; rewrite scal_sum; + rewrite <- Ropp_mult_distr_l_reverse; rewrite scal_sum; apply sum_eq. intros; unfold sin_n, Un, tg_alt in |- *; replace ((-1) ^ S i) with (- (-1) ^ i). @@ -230,7 +230,7 @@ Lemma cos_bound : forall (a:R) (n:nat), - PI / 2 <= a -> a <= PI / 2 -> - cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)). + cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)). Proof. cut ((forall (a:R) (n:nat), @@ -318,7 +318,7 @@ Proof. simpl in |- *; ring. ring. assert (H4 := cv_speed_pow_fact a0); unfold Un in |- *; unfold Un_cv in H4; - unfold R_dist in H4; unfold Un_cv in |- *; unfold R_dist in |- *; + unfold R_dist in H4; unfold Un_cv in |- *; unfold R_dist in |- *; intros; elim (H4 eps H5); intros N H6; exists N; intros. apply H6; unfold ge in |- *; apply le_trans with (2 * S N)%nat. apply le_trans with (2 * N)%nat. @@ -328,7 +328,7 @@ Proof. 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 in |- *; unfold R_dist in |- *; + unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; intros. elim (p _ H5); intros N H6. exists N; intros. @@ -336,9 +336,9 @@ Proof. (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)). unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite Ropp_involutive; repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1); - rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc; + rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp; - rewrite Ropp_plus_distr; rewrite Ropp_involutive; + rewrite Ropp_plus_distr; rewrite Ropp_involutive; unfold Rminus in H6; apply H6. unfold ge in |- *; apply le_trans with n1. exact H7. @@ -351,7 +351,7 @@ Proof. replace (- sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1) with (-1 * sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1); - [ idtac | ring ]; rewrite scal_sum; apply sum_eq; + [ idtac | ring ]; rewrite scal_sum; apply sum_eq; intros; unfold cos_n, Un, tg_alt in |- *. replace ((-1) ^ S i) with (- (-1) ^ i). replace (a0 ^ (2 * S i)) with (Rsqr a0 * Rsqr a0 ^ i). diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v index baf0fa4b..a7fddb47 100644 --- a/theories/Reals/Rtrigo_calc.v +++ b/theories/Reals/Rtrigo_calc.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_calc.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -18,7 +18,7 @@ Open Local Scope R_scope. Lemma tan_PI : tan PI = 0. Proof. unfold tan in |- *; rewrite sin_PI; rewrite cos_PI; unfold Rdiv in |- *; - apply Rmult_0_l. + apply Rmult_0_l. Qed. Lemma sin_3PI2 : sin (3 * (PI / 2)) = -1. @@ -129,7 +129,7 @@ Qed. Lemma R1_sqrt2_neq_0 : 1 / sqrt 2 <> 0. Proof. generalize (Rinv_neq_0_compat (sqrt 2) sqrt2_neq_0); intro H; - generalize (prod_neq_R0 1 (/ sqrt 2) R1_neq_R0 H); + generalize (prod_neq_R0 1 (/ sqrt 2) R1_neq_R0 H); intro H0; assumption. Qed. @@ -163,9 +163,9 @@ Proof. | generalize (Rlt_le 0 2 Hyp); intro H1; assert (Hyp2 : 0 < 3); [ prove_sup0 | generalize (Rlt_le 0 3 Hyp2); intro H2; - generalize (lt_INR_0 1 (neq_O_lt 1 H0)); + generalize (lt_INR_0 1 (neq_O_lt 1 H0)); unfold INR in |- *; intro H3; - generalize (Rplus_lt_compat_l 2 0 1 H3); + generalize (Rplus_lt_compat_l 2 0 1 H3); rewrite Rplus_comm; rewrite Rplus_0_l; replace (2 + 1) with 3; [ intro H4; generalize (sqrt_lt_1 2 3 H1 H2 H4); clear H3; intro H3; apply (Rlt_trans 0 (sqrt 2) (sqrt 3) Rlt_sqrt2_0 H3) @@ -303,7 +303,7 @@ Lemma sin_2PI3 : sin (2 * (PI / 3)) = sqrt 3 / 2. Proof. rewrite double; rewrite sin_plus; rewrite sin_PI3; rewrite cos_PI3; unfold Rdiv in |- *; repeat rewrite Rmult_1_l; rewrite (Rmult_comm (/ 2)); - repeat rewrite <- Rmult_assoc; rewrite double_var; + repeat rewrite <- Rmult_assoc; rewrite double_var; reflexivity. Qed. @@ -385,7 +385,7 @@ Proof. replace (PI + PI / 2) with (3 * (PI / 2)). rewrite Rplus_0_r; intro H2; assumption. pattern PI at 2 in |- *; rewrite double_var; ring. -Qed. +Qed. Lemma Rlt_3PI2_2PI : 3 * (PI / 2) < 2 * PI. Proof. @@ -450,7 +450,7 @@ Proof. left; apply sin_lb_gt_0; assumption. elim H1; intro. rewrite <- H2; unfold sin_lb in |- *; unfold sin_approx in |- *; - unfold sum_f_R0 in |- *; unfold sin_term in |- *; + unfold sum_f_R0 in |- *; unfold sin_term in |- *; repeat rewrite pow_ne_zero. unfold Rdiv in |- *; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r; right; reflexivity. diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v index e94d7448..9588e443 100644 --- a/theories/Reals/Rtrigo_def.v +++ b/theories/Reals/Rtrigo_def.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_def.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -63,7 +63,7 @@ Proof. Defined. (* Value of [exp 0] *) -Lemma exp_0 : exp 0 = 1. +Lemma exp_0 : exp 0 = 1. Proof. cut (exp_in 0 (exp 0)). cut (exp_in 0 1). @@ -96,7 +96,7 @@ Qed. Definition cos_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n)). Lemma simpl_cos_n : - forall n:nat, cos_n (S n) / cos_n n = - / INR (2 * S n * (2 * n + 1)). + forall n:nat, cos_n (S n) / cos_n n = - / INR (2 * S n * (2 * n + 1)). Proof. intro; unfold cos_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ]. rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr. @@ -176,7 +176,7 @@ Proof. assert (H0 := archimed_cor1 eps H). elim H0; intros; exists x. intros; rewrite simpl_cos_n; unfold R_dist in |- *; unfold Rminus in |- *; - rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; + rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; rewrite Rabs_Ropp; rewrite Rabs_right. rewrite mult_INR; rewrite Rinv_mult_distr. cut (/ INR (2 * S n) < 1). @@ -250,7 +250,7 @@ Definition cos (x:R) : R := let (a,_) := exist_cos (Rsqr x) in a. Definition sin_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n + 1)). Lemma simpl_sin_n : - forall n:nat, sin_n (S n) / sin_n n = - / INR ((2 * S n + 1) * (2 * S n)). + forall n:nat, sin_n (S n) / sin_n n = - / INR ((2 * S n + 1) * (2 * S n)). Proof. intro; unfold sin_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ]. rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr. @@ -300,7 +300,7 @@ Proof. unfold Un_cv in |- *; intros; assert (H0 := archimed_cor1 eps H). elim H0; intros; exists x. intros; rewrite simpl_sin_n; unfold R_dist in |- *; unfold Rminus in |- *; - rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; + rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; rewrite Rabs_Ropp; rewrite Rabs_right. rewrite mult_INR; rewrite Rinv_mult_distr. cut (/ INR (2 * S n) < 1). @@ -382,7 +382,7 @@ Qed. Lemma sin_antisym : forall x:R, sin (- x) = - sin x. Proof. intro; unfold sin in |- *; replace (Rsqr (- x)) with (Rsqr x); - [ idtac | apply Rsqr_neg ]. + [ idtac | apply Rsqr_neg ]. case (exist_sin (Rsqr x)); intros; ring. Qed. diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v index 6eec0329..cb53b534 100644 --- a/theories/Reals/Rtrigo_fun.v +++ b/theories/Reals/Rtrigo_fun.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_fun.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -33,7 +33,7 @@ Proof. 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); + 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; @@ -42,11 +42,11 @@ Proof. 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) (sym_not_equal (O_S n)))) in H4; - rewrite (let (H1, H2) := Rmult_ne eps in H1) 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; + rewrite (let (H1, H2) := Rmult_ne eps in H2); unfold Rgt in H; assumption. unfold Rgt in H1; apply Rlt_le; assumption. unfold Rgt in |- *; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn. @@ -61,12 +61,12 @@ Proof. intro ; generalize (Rlt_le_trans (/ eps - 1) (INR x) (INR n) H4 - (le_INR x n H2)); + (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); + 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; @@ -75,7 +75,7 @@ Proof. 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) (sym_not_equal (O_S n)))) in H6; - rewrite (let (H1, H2) := Rmult_ne eps in H1) 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 ]. @@ -92,8 +92,8 @@ Proof. rewrite (Rinv_l eps (sym_not_eq (Rlt_dichotomy_converse 0 eps (or_introl (0 > eps) H)))) - ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1); - intro; fold (/ eps - 1 > 0) in |- *; apply Rgt_minus; + ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1); + intro; fold (/ eps - 1 > 0) in |- *; apply Rgt_minus; unfold Rgt in |- *; assumption. right; rewrite H0; rewrite Rinv_1; apply sym_eq; apply Rminus_diag_eq; auto. elim (archimed (/ eps - 1)); intros; clear H1; unfold Rgt in H0; apply Rlt_le; diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v index 139563bf..5b731488 100644 --- a/theories/Reals/Rtrigo_reg.v +++ b/theories/Reals/Rtrigo_reg.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_reg.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -131,7 +131,7 @@ Proof. apply SFL_continuity; assumption. unfold continuity in |- *; unfold continuity_pt in |- *; unfold continue_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; + unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; intros. elim (H1 x _ H2); intros. exists x0; intros. @@ -172,7 +172,7 @@ Proof. unfold continuity_pt in H0; unfold continue_in in H0; unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; unfold R_dist in H0; unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; intros. elim (H0 _ H); intros. exists x0; intros. @@ -186,7 +186,7 @@ Proof. trivial. red in |- *; intro; unfold D_x, no_cond in H5; elim H5; intros _ H8; elim H8; rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive x1); - apply Ropp_eq_compat; apply Rplus_eq_reg_l with (PI / 2); + apply Ropp_eq_compat; apply Rplus_eq_reg_l with (PI / 2); apply H7. replace (PI / 2 - x1 - (PI / 2 - x)) with (x - x1); [ idtac | ring ]; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply H6. @@ -420,7 +420,7 @@ Proof. elim H9; intros; assumption. cut (Rabs (h / 2) < del). intro; cut (h / 2 <> 0). - intro; assert (H11 := H2 _ H10 H9). + intro; assert (H11 := H2 _ H10 H9). rewrite Rplus_0_l in H11; rewrite sin_0 in H11. rewrite Rminus_0_r in H11; apply H11. unfold Rdiv in |- *; apply prod_neq_R0. @@ -436,7 +436,7 @@ Proof. unfold delta in |- *; simpl in |- *; apply Rmin_l. apply Rle_ge; left; apply Rinv_0_lt_compat; prove_sup0. rewrite <- (Rplus_0_r (del / 2)); pattern del at 1 in |- *; - rewrite (double_var del); apply Rplus_lt_compat_l; + rewrite (double_var del); apply Rplus_lt_compat_l; unfold Rdiv in |- *; apply Rmult_lt_0_compat. apply (cond_pos del). apply Rinv_0_lt_compat; prove_sup0. diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v index 56088a2e..a84a1cc9 100644 --- a/theories/Reals/SeqProp.v +++ b/theories/Reals/SeqProp.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: SeqProp.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v index 9680b75e..dbfc85bb 100644 --- a/theories/Reals/SeqSeries.v +++ b/theories/Reals/SeqSeries.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: SeqSeries.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. @@ -25,7 +25,7 @@ Open Local Scope R_scope. (**********) Lemma sum_maj1 : - forall (fn:nat -> R -> R) (An:nat -> R) (x l1 l2:R) + forall (fn:nat -> R -> R) (An:nat -> R) (x l1 l2:R) (N:nat), Un_cv (fun n:nat => SP fn n x) l1 -> Un_cv (fun n:nat => sum_f_R0 An n) l2 -> @@ -92,7 +92,7 @@ Proof. (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with (sum_f_R0 (fun k:nat => fn k x) N + - sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); + sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); [ idtac | ring ]. replace (sum_f_R0 (fun k:nat => fn k x) N + @@ -170,7 +170,7 @@ Proof. (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with (sum_f_R0 (fun k:nat => fn k x) N + - sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); + sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); [ idtac | ring ]. replace (sum_f_R0 (fun k:nat => fn k x) N + @@ -241,13 +241,13 @@ Proof. apply Rle_ge; apply cond_pos_sum; intro. elim (H (S n + n0)%nat); intros; assumption. rewrite b; unfold R_dist in |- *; unfold Rminus in |- *; - do 2 rewrite Rplus_opp_r; rewrite Rabs_R0; right; + 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 in |- *; unfold Rminus in |- *; 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_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. diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v index 08dbd67b..5882f953 100644 --- a/theories/Reals/SplitAbsolu.v +++ b/theories/Reals/SplitAbsolu.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: SplitAbsolu.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Import Rbasic_fun. diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v index 4f3fab24..51e54860 100644 --- a/theories/Reals/SplitRmult.v +++ b/theories/Reals/SplitRmult.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: SplitRmult.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) (*i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*) diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v index 13be46da..4f336648 100644 --- a/theories/Reals/Sqrt_reg.v +++ b/theories/Reals/Sqrt_reg.v @@ -6,12 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Sqrt_reg.v 10710 2008-03-23 09:24:09Z herbelin $ i*) +(*i $Id$ i*) Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. -Require Import R_sqrt. +Require Import R_sqrt. Open Local Scope R_scope. (**********) @@ -104,8 +104,8 @@ Qed. Lemma sqrt_continuity_pt_R1 : continuity_pt sqrt 1. Proof. unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; - unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; + unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; intros. set (alpha := Rmin eps 1). exists alpha; intros. @@ -129,8 +129,8 @@ Lemma sqrt_continuity_pt : forall x:R, 0 < x -> continuity_pt sqrt x. Proof. intros; generalize sqrt_continuity_pt_R1. unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; - unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; + unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; intros. cut (0 < eps / sqrt x). intro; elim (H0 _ H2); intros alp_1 H3. @@ -153,7 +153,7 @@ Proof. unfold Rdiv in H5. case (Req_dec x x0); intro. rewrite H7; unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r; - rewrite Rmult_0_l; rewrite Rplus_0_r; rewrite Rplus_opp_r; + rewrite Rmult_0_l; rewrite Rplus_0_r; rewrite Rplus_opp_r; rewrite Rabs_R0. apply Rmult_lt_0_compat. assumption. @@ -238,7 +238,7 @@ Proof. intro; cut (g 0 <> 0). intro; assert (H2 := continuity_pt_inv g 0 H0 H1). unfold derivable_pt_lim in |- *; intros; unfold continuity_pt in H2; - unfold continue_in in H2; unfold limit1_in in H2; + unfold continue_in in H2; unfold limit1_in in H2; unfold limit_in in H2; simpl in H2; unfold R_dist in H2. elim (H2 eps H3); intros alpha H4. elim H4; intros. @@ -333,7 +333,7 @@ Proof. apply (sqrt_continuity_pt x H0). elim H0; intro. unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; intros. exists (Rsqr eps); intros. split. diff --git a/theories/Reals/vo.itarget b/theories/Reals/vo.itarget new file mode 100644 index 00000000..bcd47a0b --- /dev/null +++ b/theories/Reals/vo.itarget @@ -0,0 +1,58 @@ +Alembert.vo +AltSeries.vo +ArithProp.vo +Binomial.vo +Cauchy_prod.vo +Cos_plus.vo +Cos_rel.vo +DiscrR.vo +Exp_prop.vo +Integration.vo +LegacyRfield.vo +MVT.vo +NewtonInt.vo +PartSum.vo +PSeries_reg.vo +Ranalysis1.vo +Ranalysis2.vo +Ranalysis3.vo +Ranalysis4.vo +Ranalysis.vo +Raxioms.vo +Rbase.vo +Rbasic_fun.vo +Rcomplete.vo +Rdefinitions.vo +Rderiv.vo +Reals.vo +Rfunctions.vo +Rgeom.vo +RiemannInt_SF.vo +RiemannInt.vo +R_Ifp.vo +RIneq.vo +Rlimit.vo +RList.vo +Rlogic.vo +Rpow_def.vo +Rpower.vo +Rprod.vo +Rseries.vo +Rsigma.vo +Rsqrt_def.vo +R_sqrt.vo +R_sqr.vo +Rtopology.vo +Rtrigo_alt.vo +Rtrigo_calc.vo +Rtrigo_def.vo +Rtrigo_fun.vo +Rtrigo_reg.vo +Rtrigo.vo +SeqProp.vo +SeqSeries.vo +SplitAbsolu.vo +SplitRmult.vo +Sqrt_reg.vo +ROrderedType.vo +Rminmax.vo diff --git a/theories/Relations/Newman.v b/theories/Relations/Newman.v deleted file mode 100644 index e7bb66eb..00000000 --- a/theories/Relations/Newman.v +++ /dev/null @@ -1,121 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* A -> Prop. - -Let Rstar := Rstar A R. -Let Rstar_reflexive := Rstar_reflexive A R. -Let Rstar_transitive := Rstar_transitive A R. -Let Rstar_Rstar' := Rstar_Rstar' A R. - -Definition coherence (x y:A) := ex2 (Rstar x) (Rstar y). - -Theorem coherence_intro : - forall x y z:A, Rstar x z -> Rstar y z -> coherence x y. -Proof fun (x y z:A) (h1:Rstar x z) (h2:Rstar y z) => - ex_intro2 (Rstar x) (Rstar y) z h1 h2. - -(** A very simple case of coherence : *) - -Lemma Rstar_coherence : forall x y:A, Rstar x y -> coherence x y. -Proof - fun (x y:A) (h:Rstar x y) => coherence_intro x y y h (Rstar_reflexive y). - -(** coherence is symmetric *) -Lemma coherence_sym : forall x y:A, coherence x y -> coherence y x. -Proof - fun (x y:A) (h:coherence x y) => - ex2_ind - (fun (w:A) (h1:Rstar x w) (h2:Rstar y w) => - coherence_intro y x w h2 h1) h. - -Definition confluence (x:A) := - forall y z:A, Rstar x y -> Rstar x z -> coherence y z. - -Definition local_confluence (x:A) := - forall y z:A, R x y -> R x z -> coherence y z. - -Definition noetherian := - forall (x:A) (P:A -> Prop), - (forall y:A, (forall z:A, R y z -> P z) -> P y) -> P x. - -Section Newman_section. - - (** The general hypotheses of the theorem *) - - Hypothesis Hyp1 : noetherian. - Hypothesis Hyp2 : forall x:A, local_confluence x. - - (** The induction hypothesis *) - - Section Induct. - Variable x : A. - Hypothesis hyp_ind : forall u:A, R x u -> confluence u. - - (** Confluence in [x] *) - - Variables y z : A. - Hypothesis h1 : Rstar x y. - Hypothesis h2 : Rstar x z. - - (** particular case [x->u] and [u->*y] *) - Section Newman_. - Variable u : A. - Hypothesis t1 : R x u. - Hypothesis t2 : Rstar u y. - - (** In the usual diagram, we assume also [x->v] and [v->*z] *) - - Theorem Diagram : forall (v:A) (u1:R x v) (u2:Rstar v z), coherence y z. - Proof - (* We draw the diagram ! *) - fun (v:A) (u1:R x v) (u2:Rstar v z) => - ex2_ind - (* local confluence in x for u,v *) - (* gives w, u->*w and v->*w *) - (fun (w:A) (s1:Rstar u w) (s2:Rstar v w) => - ex2_ind - (* confluence in u => coherence(y,w) *) - (* gives a, y->*a and z->*a *) - (fun (a:A) (v1:Rstar y a) (v2:Rstar w a) => - ex2_ind - (* confluence in v => coherence(a,z) *) - (* gives b, a->*b and z->*b *) - (fun (b:A) (w1:Rstar a b) (w2:Rstar z b) => - coherence_intro y z b (Rstar_transitive y a b v1 w1) w2) - (hyp_ind v u1 a z (Rstar_transitive v w a s2 v2) u2)) - (hyp_ind u t1 y w t2 s1)) (Hyp2 x u v t1 u1). - - Theorem caseRxy : coherence y z. - Proof - Rstar_Rstar' x z h2 (fun v w:A => coherence y w) - (coherence_sym x y (Rstar_coherence x y h1)) (*i case x=z i*) - Diagram. (*i case x->v->*z i*) - End Newman_. - - Theorem Ind_proof : coherence y z. - Proof - Rstar_Rstar' x y h1 (fun u v:A => coherence v z) - (Rstar_coherence x z h2) (*i case x=y i*) - caseRxy. (*i case x->u->*z i*) - End Induct. - - Theorem Newman : forall x:A, confluence x. - Proof fun x:A => Hyp1 x confluence Ind_proof. - -End Newman_section. - - -End Newman. diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index d0916b09..1976b435 100644 --- a/theories/Relations/Operators_Properties.v +++ b/theories/Relations/Operators_Properties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Operators_Properties.v 11481 2008-10-20 19:23:51Z herbelin $ i*) +(*i $Id$ i*) (************************************************************************) (** * Some properties of the operators on relations *) @@ -16,31 +16,41 @@ Require Import Relation_Definitions. Require Import Relation_Operators. -Require Import Setoid. Section Properties. + Implicit Arguments clos_refl_trans [A]. + Implicit Arguments clos_refl_trans_1n [A]. + Implicit Arguments clos_refl_trans_n1 [A]. + Implicit Arguments clos_refl_sym_trans [A]. + Implicit Arguments clos_refl_sym_trans_1n [A]. + Implicit Arguments clos_refl_sym_trans_n1 [A]. + Implicit Arguments clos_trans [A]. + Implicit Arguments clos_trans_1n [A]. + Implicit Arguments clos_trans_n1 [A]. + Implicit Arguments inclusion [A]. + Implicit Arguments preorder [A]. + Variable A : Type. Variable R : relation A. - Let incl (R1 R2:relation A) : Prop := forall x y:A, R1 x y -> R2 x y. - Section Clos_Refl_Trans. + Local Notation "R *" := (clos_refl_trans R) (at level 8, left associativity). + (** Correctness of the reflexive-transitive closure operator *) - Lemma clos_rt_is_preorder : preorder A (clos_refl_trans A R). + Lemma clos_rt_is_preorder : preorder R*. Proof. apply Build_preorder. exact (rt_refl A R). - + exact (rt_trans A R). Qed. (** Idempotency of the reflexive-transitive closure operator *) - Lemma clos_rt_idempotent : - incl (clos_refl_trans A (clos_refl_trans A R)) (clos_refl_trans A R). + Lemma clos_rt_idempotent : inclusion (R*)* R*. Proof. red in |- *. induction 1; auto with sets. @@ -56,7 +66,7 @@ Section Properties. reflexive-symmetric-transitive closure *) Lemma clos_rt_clos_rst : - inclusion A (clos_refl_trans A R) (clos_refl_sym_trans A R). + inclusion (clos_refl_trans R) (clos_refl_sym_trans R). Proof. red in |- *. induction 1; auto with sets. @@ -65,7 +75,7 @@ Section Properties. (** Correctness of the reflexive-symmetric-transitive closure *) - Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans A R). + Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans R). Proof. apply Build_equivalence. exact (rst_refl A R). @@ -76,8 +86,8 @@ Section Properties. (** Idempotency of the reflexive-symmetric-transitive closure operator *) Lemma clos_rst_idempotent : - incl (clos_refl_sym_trans A (clos_refl_sym_trans A R)) - (clos_refl_sym_trans A R). + inclusion (clos_refl_sym_trans (clos_refl_sym_trans R)) + (clos_refl_sym_trans R). Proof. red in |- *. induction 1; auto with sets. @@ -91,11 +101,11 @@ Section Properties. (** *** Equivalences between the different definition of the reflexive, symmetric, transitive closures *) - (** *** Contributed by P. Casteran *) + (** *** Contributed by P. Castéran *) (** Direct transitive closure vs left-step extension *) - Lemma t1n_trans : forall x y, clos_trans_1n A R x y -> clos_trans A R x y. + Lemma clos_t1n_trans : forall x y, clos_trans_1n R x y -> clos_trans R x y. Proof. induction 1. left; assumption. @@ -103,7 +113,7 @@ Section Properties. left; auto. Qed. - Lemma trans_t1n : forall x y, clos_trans A R x y -> clos_trans_1n A R x y. + Lemma clos_trans_t1n : forall x y, clos_trans R x y -> clos_trans_1n R x y. Proof. induction 1. left; assumption. @@ -111,20 +121,20 @@ Section Properties. right with y; auto. right with y; auto. eapply IHIHclos_trans1; auto. - apply t1n_trans; auto. + apply clos_t1n_trans; auto. Qed. - Lemma t1n_trans_equiv : forall x y, - clos_trans A R x y <-> clos_trans_1n A R x y. + Lemma clos_trans_t1n_iff : forall x y, + clos_trans R x y <-> clos_trans_1n R x y. Proof. split. - apply trans_t1n. - apply t1n_trans. + apply clos_trans_t1n. + apply clos_t1n_trans. Qed. (** Direct transitive closure vs right-step extension *) - Lemma tn1_trans : forall x y, clos_trans_n1 A R x y -> clos_trans A R x y. + Lemma clos_tn1_trans : forall x y, clos_trans_n1 R x y -> clos_trans R x y. Proof. induction 1. left; assumption. @@ -132,7 +142,7 @@ Section Properties. left; assumption. Qed. - Lemma trans_tn1 : forall x y, clos_trans A R x y -> clos_trans_n1 A R x y. + Lemma clos_trans_tn1 : forall x y, clos_trans R x y -> clos_trans_n1 R x y. Proof. induction 1. left; assumption. @@ -144,31 +154,31 @@ Section Properties. right with y0; auto. Qed. - Lemma tn1_trans_equiv : forall x y, - clos_trans A R x y <-> clos_trans_n1 A R x y. + Lemma clos_trans_tn1_iff : forall x y, + clos_trans R x y <-> clos_trans_n1 R x y. Proof. split. - apply trans_tn1. - apply tn1_trans. + apply clos_trans_tn1. + apply clos_tn1_trans. Qed. - (** Direct reflexive-transitive closure is equivalent to + (** Direct reflexive-transitive closure is equivalent to transitivity by left-step extension *) - Lemma R_rt1n : forall x y, R x y -> clos_refl_trans_1n A R x y. + Lemma clos_rt1n_step : forall x y, R x y -> clos_refl_trans_1n R x y. Proof. intros x y H. right with y;[assumption|left]. Qed. - Lemma R_rtn1 : forall x y, R x y -> clos_refl_trans_n1 A R x y. + Lemma clos_rtn1_step : forall x y, R x y -> clos_refl_trans_n1 R x y. Proof. intros x y H. right with x;[assumption|left]. Qed. - Lemma rt1n_trans : forall x y, - clos_refl_trans_1n A R x y -> clos_refl_trans A R x y. + Lemma clos_rt1n_rt : forall x y, + clos_refl_trans_1n R x y -> clos_refl_trans R x y. Proof. induction 1. constructor 2. @@ -176,33 +186,33 @@ Section Properties. constructor 1; auto. Qed. - Lemma trans_rt1n : forall x y, - clos_refl_trans A R x y -> clos_refl_trans_1n A R x y. + Lemma clos_rt_rt1n : forall x y, + clos_refl_trans R x y -> clos_refl_trans_1n R x y. Proof. induction 1. - apply R_rt1n; assumption. + apply clos_rt1n_step; assumption. left. generalize IHclos_refl_trans2; clear IHclos_refl_trans2; induction IHclos_refl_trans1; auto. right with y; auto. eapply IHIHclos_refl_trans1; auto. - apply rt1n_trans; auto. + apply clos_rt1n_rt; auto. Qed. - Lemma rt1n_trans_equiv : forall x y, - clos_refl_trans A R x y <-> clos_refl_trans_1n A R x y. + Lemma clos_rt_rt1n_iff : forall x y, + clos_refl_trans R x y <-> clos_refl_trans_1n R x y. Proof. split. - apply trans_rt1n. - apply rt1n_trans. + apply clos_rt_rt1n. + apply clos_rt1n_rt. Qed. - (** Direct reflexive-transitive closure is equivalent to + (** Direct reflexive-transitive closure is equivalent to transitivity by right-step extension *) - Lemma rtn1_trans : forall x y, - clos_refl_trans_n1 A R x y -> clos_refl_trans A R x y. + Lemma clos_rtn1_rt : forall x y, + clos_refl_trans_n1 R x y -> clos_refl_trans R x y. Proof. induction 1. constructor 2. @@ -210,37 +220,37 @@ Section Properties. constructor 1; assumption. Qed. - Lemma trans_rtn1 : forall x y, - clos_refl_trans A R x y -> clos_refl_trans_n1 A R x y. + Lemma clos_rt_rtn1 : forall x y, + clos_refl_trans R x y -> clos_refl_trans_n1 R x y. Proof. induction 1. - apply R_rtn1; auto. + apply clos_rtn1_step; auto. left. elim IHclos_refl_trans2; auto. intros. right with y0; auto. Qed. - Lemma rtn1_trans_equiv : forall x y, - clos_refl_trans A R x y <-> clos_refl_trans_n1 A R x y. + Lemma clos_rt_rtn1_iff : forall x y, + clos_refl_trans R x y <-> clos_refl_trans_n1 R x y. Proof. split. - apply trans_rtn1. - apply rtn1_trans. + apply clos_rt_rtn1. + apply clos_rtn1_rt. Qed. (** Induction on the left transitive step *) Lemma clos_refl_trans_ind_left : forall (x:A) (P:A -> Prop), P x -> - (forall y z:A, clos_refl_trans A R x y -> P y -> R y z -> P z) -> - forall z:A, clos_refl_trans A R x z -> P z. + (forall y z:A, clos_refl_trans R x y -> P y -> R y z -> P z) -> + forall z:A, clos_refl_trans R x z -> P z. Proof. intros. revert H H0. induction H1; intros; auto with sets. apply H1 with x; auto with sets. - + apply IHclos_refl_trans2. apply IHclos_refl_trans1; auto with sets. @@ -253,28 +263,30 @@ Section Properties. Lemma rt1n_ind_right : forall (P : A -> Prop) (z:A), P z -> - (forall x y, R x y -> clos_refl_trans_1n A R y z -> P y -> P x) -> - forall x, clos_refl_trans_1n A R x z -> P x. + (forall x y, R x y -> clos_refl_trans_1n R y z -> P y -> P x) -> + forall x, clos_refl_trans_1n R x z -> P x. induction 3; auto. apply H0 with y; auto. Qed. Lemma clos_refl_trans_ind_right : forall (P : A -> Prop) (z:A), P z -> - (forall x y, R x y -> P y -> clos_refl_trans A R y z -> P x) -> - forall x, clos_refl_trans A R x z -> P x. - intros. - rewrite rt1n_trans_equiv in H1. - elim H1 using rt1n_ind_right; auto. - intros; rewrite <- rt1n_trans_equiv in *. + (forall x y, R x y -> P y -> clos_refl_trans R y z -> P x) -> + forall x, clos_refl_trans R x z -> P x. + intros P z Hz IH x Hxz. + apply clos_rt_rt1n_iff in Hxz. + elim Hxz using rt1n_ind_right; auto. + clear x Hxz. + intros x y Hxy Hyz Hy. + apply clos_rt_rt1n_iff in Hyz. eauto. Qed. - (** Direct reflexive-symmetric-transitive closure is equivalent to + (** Direct reflexive-symmetric-transitive closure is equivalent to transitivity by symmetric left-step extension *) - Lemma rts1n_rts : forall x y, - clos_refl_sym_trans_1n A R x y -> clos_refl_sym_trans A R x y. + Lemma clos_rst1n_rst : forall x y, + clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans R x y. Proof. induction 1. constructor 2. @@ -282,48 +294,47 @@ Section Properties. case H;[constructor 1|constructor 3; constructor 1]; auto. Qed. - Lemma rts_1n_trans : forall x y, clos_refl_sym_trans_1n A R x y -> - forall z, clos_refl_sym_trans_1n A R y z -> - clos_refl_sym_trans_1n A R x z. + Lemma clos_rst1n_trans : forall x y z, clos_refl_sym_trans_1n R x y -> + clos_refl_sym_trans_1n R y z -> clos_refl_sym_trans_1n R x z. induction 1. auto. intros; right with y; eauto. Qed. - Lemma rts1n_sym : forall x y, clos_refl_sym_trans_1n A R x y -> - clos_refl_sym_trans_1n A R y x. + Lemma clos_rst1n_sym : forall x y, clos_refl_sym_trans_1n R x y -> + clos_refl_sym_trans_1n R y x. Proof. intros x y H; elim H. constructor 1. - intros x0 y0 z D H0 H1; apply rts_1n_trans with y0; auto. + intros x0 y0 z D H0 H1; apply clos_rst1n_trans with y0; auto. right with x0. tauto. left. Qed. - Lemma rts_rts1n : forall x y, - clos_refl_sym_trans A R x y -> clos_refl_sym_trans_1n A R x y. + Lemma clos_rst_rst1n : forall x y, + clos_refl_sym_trans R x y -> clos_refl_sym_trans_1n R x y. induction 1. constructor 2 with y; auto. constructor 1. constructor 1. - apply rts1n_sym; auto. - eapply rts_1n_trans; eauto. + apply clos_rst1n_sym; auto. + eapply clos_rst1n_trans; eauto. Qed. - Lemma rts_rts1n_equiv : forall x y, - clos_refl_sym_trans A R x y <-> clos_refl_sym_trans_1n A R x y. + Lemma clos_rst_rst1n_iff : forall x y, + clos_refl_sym_trans R x y <-> clos_refl_sym_trans_1n R x y. Proof. split. - apply rts_rts1n. - apply rts1n_rts. + apply clos_rst_rst1n. + apply clos_rst1n_rst. Qed. - (** Direct reflexive-symmetric-transitive closure is equivalent to + (** Direct reflexive-symmetric-transitive closure is equivalent to transitivity by symmetric right-step extension *) - Lemma rtsn1_rts : forall x y, - clos_refl_sym_trans_n1 A R x y -> clos_refl_sym_trans A R x y. + Lemma clos_rstn1_rst : forall x y, + clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans R x y. Proof. induction 1. constructor 2. @@ -331,46 +342,79 @@ Section Properties. case H;[constructor 1|constructor 3; constructor 1]; auto. Qed. - Lemma rtsn1_trans : forall y z, clos_refl_sym_trans_n1 A R y z-> - forall x, clos_refl_sym_trans_n1 A R x y -> - clos_refl_sym_trans_n1 A R x z. + Lemma clos_rstn1_trans : forall x y z, clos_refl_sym_trans_n1 R x y -> + clos_refl_sym_trans_n1 R y z -> clos_refl_sym_trans_n1 R x z. Proof. - induction 1. + intros x y z H1 H2. + induction H2. auto. intros. right with y0; eauto. Qed. - Lemma rtsn1_sym : forall x y, clos_refl_sym_trans_n1 A R x y -> - clos_refl_sym_trans_n1 A R y x. + Lemma clos_rstn1_sym : forall x y, clos_refl_sym_trans_n1 R x y -> + clos_refl_sym_trans_n1 R y x. Proof. intros x y H; elim H. constructor 1. - intros y0 z D H0 H1. apply rtsn1_trans with y0; auto. + intros y0 z D H0 H1. apply clos_rstn1_trans with y0; auto. right with z. tauto. left. Qed. - Lemma rts_rtsn1 : forall x y, - clos_refl_sym_trans A R x y -> clos_refl_sym_trans_n1 A R x y. + Lemma clos_rst_rstn1 : forall x y, + clos_refl_sym_trans R x y -> clos_refl_sym_trans_n1 R x y. Proof. induction 1. constructor 2 with x; auto. constructor 1. constructor 1. - apply rtsn1_sym; auto. - eapply rtsn1_trans; eauto. + apply clos_rstn1_sym; auto. + eapply clos_rstn1_trans; eauto. Qed. - Lemma rts_rtsn1_equiv : forall x y, - clos_refl_sym_trans A R x y <-> clos_refl_sym_trans_n1 A R x y. + Lemma clos_rst_rstn1_iff : forall x y, + clos_refl_sym_trans R x y <-> clos_refl_sym_trans_n1 R x y. Proof. split. - apply rts_rtsn1. - apply rtsn1_rts. + apply clos_rst_rstn1. + apply clos_rstn1_rst. Qed. End Equivalences. End Properties. + +(* begin hide *) +(* Compatibility *) +Notation trans_tn1 := clos_trans_tn1 (only parsing). +Notation tn1_trans := clos_tn1_trans (only parsing). +Notation tn1_trans_equiv := clos_trans_tn1_iff (only parsing). + +Notation trans_t1n := clos_trans_t1n (only parsing). +Notation t1n_trans := clos_t1n_trans (only parsing). +Notation t1n_trans_equiv := clos_trans_t1n_iff (only parsing). + +Notation R_rtn1 := clos_rtn1_step (only parsing). +Notation trans_rt1n := clos_rt_rt1n (only parsing). +Notation rt1n_trans := clos_rt1n_rt (only parsing). +Notation rt1n_trans_equiv := clos_rt_rt1n_iff (only parsing). + +Notation R_rt1n := clos_rt1n_step (only parsing). +Notation trans_rtn1 := clos_rt_rtn1 (only parsing). +Notation rtn1_trans := clos_rtn1_rt (only parsing). +Notation rtn1_trans_equiv := clos_rt_rtn1_iff (only parsing). + +Notation rts1n_rts := clos_rst1n_rst (only parsing). +Notation rts_1n_trans := clos_rst1n_trans (only parsing). +Notation rts1n_sym := clos_rst1n_sym (only parsing). +Notation rts_rts1n := clos_rst_rst1n (only parsing). +Notation rts_rts1n_equiv := clos_rst_rst1n_iff (only parsing). + +Notation rtsn1_rts := clos_rstn1_rst (only parsing). +Notation rtsn1_trans := clos_rstn1_trans (only parsing). +Notation rtsn1_sym := clos_rstn1_sym (only parsing). +Notation rts_rtsn1 := clos_rst_rstn1 (only parsing). +Notation rts_rtsn1_equiv := clos_rst_rstn1_iff (only parsing). +(* end hide *) diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v index 762da1ff..c03c4b95 100644 --- a/theories/Relations/Relation_Definitions.v +++ b/theories/Relations/Relation_Definitions.v @@ -6,19 +6,19 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Relation_Definitions.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Section Relation_Definition. Variable A : Type. - + Definition relation := A -> A -> Prop. Variable R : relation. - + Section General_Properties_of_Relations. - + Definition reflexive : Prop := forall x:A, R x x. Definition transitive : Prop := forall x y z:A, R x y -> R y z -> R x z. Definition symmetric : Prop := forall x y:A, R x y -> R y x. @@ -32,33 +32,33 @@ Section Relation_Definition. Section Sets_of_Relations. - - Record preorder : Prop := + + Record preorder : Prop := { preord_refl : reflexive; preord_trans : transitive}. - - Record order : Prop := + + Record order : Prop := { ord_refl : reflexive; ord_trans : transitive; ord_antisym : antisymmetric}. - - Record equivalence : Prop := + + Record equivalence : Prop := { equiv_refl : reflexive; equiv_trans : transitive; equiv_sym : symmetric}. - + Record PER : Prop := {per_sym : symmetric; per_trans : transitive}. End Sets_of_Relations. Section Relations_of_Relations. - + Definition inclusion (R1 R2:relation) : Prop := forall x y:A, R1 x y -> R2 x y. - + Definition same_relation (R1 R2:relation) : Prop := inclusion R1 R2 /\ inclusion R2 R1. - + Definition commut (R1 R2:relation) : Prop := forall x y:A, R1 y x -> forall z:A, R2 z y -> exists2 y' : A, R2 y' x & R1 z y'. diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index 027a9e6c..39e0331d 100644 --- a/theories/Relations/Relation_Operators.v +++ b/theories/Relations/Relation_Operators.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Relation_Operators.v 11481 2008-10-20 19:23:51Z herbelin $ i*) +(*i $Id$ i*) (************************************************************************) (** * Bruno Barras, Cristina Cornes *) @@ -17,7 +17,6 @@ (************************************************************************) Require Import Relation_Definitions. -Require Import List. (** * Some operators to build relations *) @@ -65,7 +64,7 @@ Section Reflexive_Transitive_Closure. Inductive clos_refl_trans_1n (x: A) : A -> Prop := | rt1n_refl : clos_refl_trans_1n x x - | rt1n_trans (y z:A) : + | rt1n_trans (y z:A) : R x y -> clos_refl_trans_1n y z -> clos_refl_trans_1n x z. (** Alternative definition by transitive extension on the right *) @@ -79,10 +78,10 @@ End Reflexive_Transitive_Closure. (** ** Reflexive-symmetric-transitive closure *) -Section Reflexive_Symetric_Transitive_Closure. +Section Reflexive_Symmetric_Transitive_Closure. Variable A : Type. Variable R : relation A. - + (** Definition by direct reflexive-symmetric-transitive closure *) Inductive clos_refl_sym_trans : relation A := @@ -96,18 +95,18 @@ Section Reflexive_Symetric_Transitive_Closure. (** Alternative definition by symmetric-transitive extension on the left *) Inductive clos_refl_sym_trans_1n (x: A) : A -> Prop := - | rts1n_refl : clos_refl_sym_trans_1n x x - | rts1n_trans (y z:A) : R x y \/ R y x -> + | rst1n_refl : clos_refl_sym_trans_1n x x + | rst1n_trans (y z:A) : R x y \/ R y x -> clos_refl_sym_trans_1n y z -> clos_refl_sym_trans_1n x z. (** Alternative definition by symmetric-transitive extension on the right *) Inductive clos_refl_sym_trans_n1 (x: A) : A -> Prop := - | rtsn1_refl : clos_refl_sym_trans_n1 x x - | rtsn1_trans (y z:A) : R y z \/ R z y -> + | rstn1_refl : clos_refl_sym_trans_n1 x x + | rstn1_trans (y z:A) : R y z \/ R z y -> clos_refl_sym_trans_n1 x y -> clos_refl_sym_trans_n1 x z. -End Reflexive_Symetric_Transitive_Closure. +End Reflexive_Symmetric_Transitive_Closure. (** ** Converse of a relation *) @@ -139,7 +138,7 @@ Inductive le_AsB : A + B -> A + B -> Prop := | le_ab (x:A) (y:B) : le_AsB (inl _ x) (inr _ y) | le_bb (x y:B) : leB x y -> le_AsB (inr _ x) (inr _ y). -End Disjoint_Union. +End Disjoint_Union. (** ** Lexicographic order on dependent pairs *) @@ -187,14 +186,15 @@ Section Swap. | sp_swap x y (p:A * A) : symprod A A R R (x, y) p -> swapprod (y, x) p. End Swap. +Local Open Scope list_scope. Section Lexicographic_Exponentiation. - + Variable A : Set. Variable leA : A -> A -> Prop. Let Nil := nil (A:=A). Let List := list A. - + Inductive Ltl : List -> List -> Prop := | Lt_nil (a:A) (x:List) : Ltl Nil (a :: x) | Lt_hd (a b:A) : leA a b -> forall x y:list A, Ltl (a :: x) (b :: y) @@ -207,7 +207,7 @@ Section Lexicographic_Exponentiation. leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil). Definition Pow : Set := sig Desc. - + Definition lex_exp (a b:Pow) : Prop := Ltl (proj1_sig a) (proj1_sig b). End Lexicographic_Exponentiation. @@ -215,3 +215,11 @@ End Lexicographic_Exponentiation. Hint Unfold transp union: sets v62. Hint Resolve t_step rt_step rt_refl rst_step rst_refl: sets v62. Hint Immediate rst_sym: sets v62. + +(* begin hide *) +(* Compatibility *) +Notation rts1n_refl := rst1n_refl (only parsing). +Notation rts1n_trans := rst1n_trans (only parsing). +Notation rtsn1_refl := rstn1_refl (only parsing). +Notation rtsn1_trans := rstn1_trans (only parsing). +(* end hide *) diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v index 6368ae25..1c6df08a 100644 --- a/theories/Relations/Relations.v +++ b/theories/Relations/Relations.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Relations.v 9598 2007-02-06 19:45:52Z herbelin $ i*) +(*i $Id$ i*) Require Export Relation_Definitions. Require Export Relation_Operators. diff --git a/theories/Relations/Rstar.v b/theories/Relations/Rstar.v deleted file mode 100644 index 82668006..00000000 --- a/theories/Relations/Rstar.v +++ /dev/null @@ -1,94 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* A -> Prop. - - (** Definition of the reflexive-transitive closure [R*] of [R] *) - (** Smallest reflexive [P] containing [R o P] *) - - Definition Rstar (x y:A) := - forall P:A -> A -> Prop, - (forall u:A, P u u) -> (forall u v w:A, R u v -> P v w -> P u w) -> P x y. - - Theorem Rstar_reflexive : forall x:A, Rstar x x. - Proof. - unfold Rstar. intros x P P_refl RoP. apply P_refl. - Qed. - - Theorem Rstar_R : forall x y z:A, R x y -> Rstar y z -> Rstar x z. - Proof. - intros x y z R_xy Rstar_yz. - unfold Rstar. - intros P P_refl RoP. apply RoP with (v:=y). - assumption. - apply Rstar_yz; assumption. - Qed. - - (** We conclude with transitivity of [Rstar] : *) - - Theorem Rstar_transitive : - forall x y z:A, Rstar x y -> Rstar y z -> Rstar x z. - Proof. - intros x y z Rstar_xy; unfold Rstar in Rstar_xy. - apply Rstar_xy; trivial. - intros u v w R_uv fz Rstar_wz. - apply Rstar_R with (y:=v); auto. - Qed. - - (** Another characterization of [R*] *) - (** Smallest reflexive [P] containing [R o R*] *) - - Definition Rstar' (x y:A) := - forall P:A -> A -> Prop, - P x x -> (forall u:A, R x u -> Rstar u y -> P x y) -> P x y. - - Theorem Rstar'_reflexive : forall x:A, Rstar' x x. - Proof. - unfold Rstar'; intros; assumption. - Qed. - - Theorem Rstar'_R : forall x y z:A, R x z -> Rstar z y -> Rstar' x y. - Proof. - unfold Rstar'. intros x y z Rxz Rstar_zy P Pxx RoP. - apply RoP with (u:=z); trivial. - Qed. - - (** Equivalence of the two definitions: *) - - Theorem Rstar'_Rstar : forall x y:A, Rstar' x y -> Rstar x y. - Proof. - intros x z Rstar'_xz; unfold Rstar' in Rstar'_xz. - apply Rstar'_xz. - exact (Rstar_reflexive x). - intro y; generalize x y z; exact Rstar_R. - Qed. - - Theorem Rstar_Rstar' : forall x y:A, Rstar x y -> Rstar' x y. - Proof. - intros. - apply H. - exact Rstar'_reflexive. - intros u v w R_uv Rs'_vw. apply Rstar'_R with (z:=v). - assumption. - apply Rstar'_Rstar; assumption. - Qed. - - (** Property of Commutativity of two relations *) - - Definition commut (A:Type) (R1 R2:A -> A -> Prop) := - forall x y:A, - R1 y x -> forall z:A, R2 z y -> exists2 y' : A, R2 y' x & R1 z y'. - -End Rstar. diff --git a/theories/Relations/vo.itarget b/theories/Relations/vo.itarget new file mode 100644 index 00000000..9d81dd07 --- /dev/null +++ b/theories/Relations/vo.itarget @@ -0,0 +1,4 @@ +Operators_Properties.vo +Relation_Definitions.vo +Relation_Operators.vo +Relations.vo diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index a187a7c6..db4d699f 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -6,11 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Setoid.v 12187 2009-06-13 19:36:59Z msozeau $: i*) +(*i $Id$: i*) Require Export Coq.Classes.SetoidTactics. -Export Morphisms.MorphismNotations. +Export Morphisms.ProperNotations. (** For backward compatibility *) @@ -18,46 +18,46 @@ Definition Setoid_Theory := @Equivalence. Definition Build_Setoid_Theory := @Build_Equivalence. Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x. - unfold Setoid_Theory. intros ; reflexivity. + unfold Setoid_Theory in s. intros ; reflexivity. Defined. Definition Seq_sym A Aeq (s : Setoid_Theory A Aeq) : forall x y:A, Aeq x y -> Aeq y x. - unfold Setoid_Theory. intros ; symmetry ; assumption. + 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. - unfold Setoid_Theory. intros ; transitivity y ; assumption. + unfold Setoid_Theory in s. intros ; transitivity y ; assumption. Defined. -(** Some tactics for manipulating Setoid Theory not officially +(** Some tactics for manipulating Setoid Theory not officially declared as Setoid. *) Ltac trans_st x := idtac "trans_st on Setoid_Theory is OBSOLETE"; idtac "use transitivity on Equivalence instead"; match goal with - | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => apply (Seq_trans _ _ H) with x; auto end. Ltac sym_st := idtac "sym_st on Setoid_Theory is OBSOLETE"; idtac "use symmetry on Equivalence instead"; - match goal with - | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => apply (Seq_sym _ _ H); auto end. Ltac refl_st := idtac "refl_st on Setoid_Theory is OBSOLETE"; idtac "use reflexivity on Equivalence instead"; - match goal with - | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => apply (Seq_refl _ _ H); auto end. Definition gen_st : forall A : Set, Setoid_Theory _ (@eq A). -Proof. - constructor; congruence. +Proof. + constructor; congruence. Qed. - + diff --git a/theories/Setoids/vo.itarget b/theories/Setoids/vo.itarget new file mode 100644 index 00000000..8d608cf7 --- /dev/null +++ b/theories/Setoids/vo.itarget @@ -0,0 +1 @@ +Setoid.vo \ No newline at end of file diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v index e6755898..5f686099 100644 --- a/theories/Sets/Classical_sets.v +++ b/theories/Sets/Classical_sets.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Classical_sets.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Export Ensembles. Require Export Constructive_sets. @@ -56,7 +56,7 @@ Section Ensembles_classical. forall X Y:Ensemble U, Included U X Y -> ~ Included U Y X -> Inhabited U (Setminus U Y X). Proof. - intros X Y I NI. + intros X Y I NI. elim (not_all_ex_not U (fun x:U => In U Y x -> In U X x) NI). intros x YX. apply Inhabited_intro with x. @@ -78,7 +78,7 @@ Section Ensembles_classical. unfold Subtract at 1 in |- *; auto with sets. Qed. Hint Resolve Subtract_intro : sets. - + Lemma Subtract_inv : forall (A:Ensemble U) (x y:U), In U (Subtract U A x) y -> In U A y /\ x <> y. Proof. diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v index ad81316d..0719365f 100644 --- a/theories/Sets/Constructive_sets.v +++ b/theories/Sets/Constructive_sets.v @@ -24,13 +24,13 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Constructive_sets.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Export Ensembles. Section Ensembles_facts. Variable U : Type. - + Lemma Extension : forall B C:Ensemble U, B = C -> Same_set U B C. Proof. intros B C H'; rewrite H'; auto with sets. @@ -52,7 +52,7 @@ Section Ensembles_facts. Proof. unfold Add at 1 in |- *; auto with sets. Qed. - + Lemma Add_intro2 : forall (A:Ensemble U) (x:U), In U (Add U A x) x. Proof. unfold Add at 1 in |- *; auto with sets. @@ -98,15 +98,15 @@ Section Ensembles_facts. Proof. intros B C x H'; elim H'; auto with sets. Qed. - + Lemma Add_inv : forall (A:Ensemble U) (x y:U), In U (Add U A x) y -> In U A y \/ x = y. Proof. - intros A x y H'; induction H'. + intros A x y H'; induction H'. left; assumption. right; apply Singleton_inv; assumption. Qed. - + Lemma Intersection_inv : forall (B C:Ensemble U) (x:U), In U (Intersection U B C) x -> In U B x /\ In U C x. @@ -125,7 +125,7 @@ Section Ensembles_facts. Proof. unfold Setminus at 1 in |- *; red in |- *; auto with sets. Qed. - + Lemma Strict_Included_intro : forall X Y:Ensemble U, Included U X Y /\ X <> Y -> Strict_Included U X Y. Proof. diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index 1e1b70d5..8c69e687 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Cpo.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Export Ensembles. Require Export Relations_1. @@ -35,7 +35,7 @@ Section Bounds. Variable D : PO U. Let C := Carrier_of U D. - + Let R := Rel_of U D. Inductive Upper_Bound (B:Ensemble U) (x:U) : Prop := @@ -45,7 +45,7 @@ Section Bounds. Inductive Lower_Bound (B:Ensemble U) (x:U) : Prop := Lower_Bound_definition : In U C x -> (forall y:U, In U B y -> R x y) -> Lower_Bound B x. - + Inductive Lub (B:Ensemble U) (x:U) : Prop := Lub_definition : Upper_Bound B x -> (forall y:U, Upper_Bound B y -> R x y) -> Lub B x. @@ -57,7 +57,7 @@ Section Bounds. Inductive Bottom (bot:U) : Prop := Bottom_definition : In U C bot -> (forall y:U, In U C y -> R bot y) -> Bottom bot. - + Inductive Totally_ordered (B:Ensemble U) : Prop := Totally_ordered_definition : (Included U B C -> @@ -77,7 +77,7 @@ Section Bounds. Included U (Couple U x1 x2) X -> exists x3 : _, In U X x3 /\ Upper_Bound (Couple U x1 x2) x3) -> Directed X. - + Inductive Complete : Prop := Definition_of_Complete : (exists bot : _, Bottom bot) -> @@ -102,7 +102,7 @@ Section Specific_orders. Record Cpo : Type := Definition_of_cpo {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}. - + Record Chain : Type := Definition_of_chain {PO_of_chain : PO U; Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}. diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v index c38a2fe1..0fa9c74a 100644 --- a/theories/Sets/Ensembles.v +++ b/theories/Sets/Ensembles.v @@ -24,27 +24,27 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Ensembles.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Section Ensembles. Variable U : Type. - - Definition Ensemble := U -> Prop. + + Definition Ensemble := U -> Prop. Definition In (A:Ensemble) (x:U) : Prop := A x. - + Definition Included (B C:Ensemble) : Prop := forall x:U, In B x -> In C x. - + Inductive Empty_set : Ensemble :=. - + Inductive Full_set : Ensemble := Full_intro : forall x:U, In Full_set x. -(** NB: The following definition builds-in equality of elements in [U] as - Leibniz equality. +(** NB: The following definition builds-in equality of elements in [U] as + Leibniz equality. - This may have to be changed if we replace [U] by a Setoid on [U] - with its own equality [eqs], with + This may have to be changed if we replace [U] by a Setoid on [U] + with its own equality [eqs], with [In_singleton: (y: U)(eqs x y) -> (In (Singleton x) y)]. *) Inductive Singleton (x:U) : Ensemble := @@ -55,7 +55,7 @@ Section Ensembles. | Union_intror : forall x:U, In C x -> In (Union B C) x. Definition Add (B:Ensemble) (x:U) : Ensemble := Union B (Singleton x). - + Inductive Intersection (B C:Ensemble) : Ensemble := Intersection_intro : forall x:U, In B x -> In C x -> In (Intersection B C) x. @@ -63,29 +63,29 @@ Section Ensembles. Inductive Couple (x y:U) : Ensemble := | Couple_l : In (Couple x y) x | Couple_r : In (Couple x y) y. - + Inductive Triple (x y z:U) : Ensemble := | Triple_l : In (Triple x y z) x | Triple_m : In (Triple x y z) y | Triple_r : In (Triple x y z) z. - + Definition Complement (A:Ensemble) : Ensemble := fun x:U => ~ In A x. - + Definition Setminus (B C:Ensemble) : Ensemble := fun x:U => In B x /\ ~ In C x. - + Definition Subtract (B:Ensemble) (x:U) : Ensemble := Setminus B (Singleton x). - + Inductive Disjoint (B C:Ensemble) : Prop := Disjoint_intro : (forall x:U, ~ In (Intersection B C) x) -> Disjoint B C. Inductive Inhabited (B:Ensemble) : Prop := Inhabited_intro : forall x:U, In B x -> Inhabited B. - + Definition Strict_Included (B C:Ensemble) : Prop := Included B C /\ B <> C. - + Definition Same_set (B C:Ensemble) : Prop := Included B C /\ Included C B. - + (** Extensionality Axiom *) Axiom Extensionality_Ensembles : forall A B:Ensemble, Same_set A B -> A = B. diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v index f5eae4ed..019c25a5 100644 --- a/theories/Sets/Finite_sets.v +++ b/theories/Sets/Finite_sets.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Finite_sets.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Import Ensembles. @@ -52,7 +52,7 @@ Require Import Constructive_sets. Section Ensembles_finis_facts. Variable U : Type. - + Lemma cardinal_invert : forall (X:Ensemble U) (p:nat), cardinal U X p -> diff --git a/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v index 91717f9e..fdcc4150 100644 --- a/theories/Sets/Finite_sets_facts.v +++ b/theories/Sets/Finite_sets_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Finite_sets_facts.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Export Finite_sets. Require Export Constructive_sets. @@ -72,7 +72,7 @@ Section Finite_sets_facts. Proof. intros X Y H; induction H as [|A Fin_A Hind x]. rewrite (Empty_set_zero U Y). trivial. - intros. + intros. rewrite (Union_commutative U (Add U A x) Y). rewrite <- (Union_add U Y A x). rewrite (Union_commutative U Y A). @@ -98,7 +98,7 @@ Section Finite_sets_facts. Proof. intros A H' X; apply Finite_downward_closed with A; auto with sets. Qed. - + Lemma cardinalO_empty : forall X:Ensemble U, cardinal U X 0 -> X = Empty_set U. Proof. @@ -212,7 +212,7 @@ Section Finite_sets_facts. Proof. intros; apply cardinal_is_functional with X X; auto with sets. Qed. - + Lemma card_Add_gen : forall (A:Ensemble U) (x:U) (n n':nat), cardinal U A n -> cardinal U (Add U A x) n' -> n' <= S n. @@ -279,7 +279,7 @@ Section Finite_sets_facts. intro E; rewrite E; auto with sets arith. apply cardinal_unicity with X; auto with sets arith. Qed. - + Lemma G_aux : forall P:Ensemble U -> Prop, (forall X:Ensemble U, diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v index d3591acf..64c341bd 100644 --- a/theories/Sets/Image.v +++ b/theories/Sets/Image.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Image.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Export Finite_sets. Require Export Constructive_sets. @@ -40,10 +40,10 @@ Require Export Finite_sets_facts. Section Image. Variables U V : Type. - + Inductive Im (X:Ensemble U) (f:U -> V) : Ensemble V := Im_intro : forall x:U, In _ X x -> forall y:V, y = f x -> In _ (Im X f) y. - + Lemma Im_def : forall (X:Ensemble U) (f:U -> V) (x:U), In _ X x -> In _ (Im X f) (f x). Proof. @@ -62,13 +62,13 @@ Section Image. rewrite H0. elim Add_inv with U X x x1; auto using Im_def with sets. destruct 1; auto using Im_def with sets. - elim Add_inv with V (Im X f) (f x) x0. + elim Add_inv with V (Im X f) (f x) x0. destruct 1 as [x0 H y H0]. rewrite H0; auto using Im_def with sets. destruct 1; auto using Im_def with sets. trivial. Qed. - + Lemma image_empty : forall f:U -> V, Im (Empty_set U) f = Empty_set V. Proof. intro f; try assumption. @@ -88,7 +88,7 @@ Section Image. rewrite (Im_add A x f); auto with sets. apply Add_preserves_Finite; auto with sets. Qed. - + Lemma Im_inv : forall (X:Ensemble U) (f:U -> V) (y:V), In _ (Im X f) y -> exists x : U, In _ X x /\ f x = y. @@ -97,9 +97,9 @@ Section Image. intros x H'0 y0 H'1; rewrite H'1. exists x; auto with sets. Qed. - + Definition injective (f:U -> V) := forall x y:U, f x = f y -> x = y. - + Lemma not_injective_elim : forall f:U -> V, ~ injective f -> exists x : _, (exists y : _, f x = f y /\ x <> y). @@ -115,7 +115,7 @@ Section Image. destruct 1 as [y D]; exists y. apply imply_to_and; trivial with sets. Qed. - + Lemma cardinal_Im_intro : forall (A:Ensemble U) (f:U -> V) (n:nat), cardinal _ A n -> exists p : nat, cardinal _ (Im A f) p. @@ -124,7 +124,7 @@ Section Image. apply finite_cardinal; apply finite_image. apply cardinal_finite with n; trivial with sets. Qed. - + Lemma In_Image_elim : forall (A:Ensemble U) (f:U -> V), injective f -> forall x:U, In _ (Im A f) (f x) -> In _ A x. @@ -134,7 +134,7 @@ Section Image. intros z C; elim C; intros InAz E. elim (H z x E); trivial with sets. Qed. - + Lemma injective_preserves_cardinal : forall (A:Ensemble U) (f:U -> V) (n:nat), injective f -> @@ -158,7 +158,7 @@ Section Image. red in |- *; intro; apply H'2. apply In_Image_elim with f; trivial with sets. Qed. - + Lemma cardinal_decreases : forall (A:Ensemble U) (f:U -> V) (n:nat), cardinal U A n -> forall n':nat, cardinal V (Im A f) n' -> n' <= n. @@ -188,7 +188,7 @@ Section Image. apply injective_preserves_cardinal with (A := A) (f := f) (n := n); trivial with sets. Qed. - + Lemma Pigeonhole_principle : forall (A:Ensemble U) (f:U -> V) (n:nat), cardinal _ A n -> diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v index ae2143c8..b63ec1d4 100644 --- a/theories/Sets/Infinite_sets.v +++ b/theories/Sets/Infinite_sets.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Infinite_sets.v 10637 2008-03-07 23:52:56Z letouzey $ i*) +(*i $Id$ i*) Require Export Finite_sets. Require Export Constructive_sets. @@ -50,7 +50,7 @@ Hint Resolve Defn_of_Approximant. Section Infinite_sets. Variable U : Type. - + Lemma make_new_approximant : forall A X:Ensemble U, ~ Finite U A -> Approximant U A X -> Inhabited U (Setminus U A X). @@ -61,7 +61,7 @@ Section Infinite_sets. red in |- *; intro H'3; apply H'. rewrite <- H'3; auto with sets. Qed. - + Lemma approximants_grow : forall A X:Ensemble U, ~ Finite U A -> @@ -101,7 +101,7 @@ Section Infinite_sets. apply Defn_of_Approximant; auto with sets. apply cardinal_finite with (n := S n0); auto with sets. Qed. - + Lemma approximants_grow' : forall A X:Ensemble U, ~ Finite U A -> @@ -121,7 +121,7 @@ Section Infinite_sets. apply cardinal_finite with (n := S n); auto with sets. apply approximants_grow with (X := X); auto with sets. Qed. - + Lemma approximant_can_be_any_size : forall A X:Ensemble U, ~ Finite U A -> @@ -135,7 +135,7 @@ Section Infinite_sets. Qed. Variable V : Type. - + Theorem Image_set_continuous : forall (A:Ensemble U) (f:U -> V) (X:Ensemble V), Finite V X -> @@ -230,7 +230,7 @@ Section Infinite_sets. rewrite H'4; auto with sets. elim H'3; auto with sets. Qed. - + Theorem Pigeonhole_ter : forall (A:Ensemble U) (f:U -> V) (n:nat), injective U V f -> Finite V (Im U V A f) -> Finite U A. diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v index 1786edf1..15c1b665 100644 --- a/theories/Sets/Integers.v +++ b/theories/Sets/Integers.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Integers.v 10637 2008-03-07 23:52:56Z letouzey $ i*) +(*i $Id$ i*) Require Export Finite_sets. Require Export Constructive_sets. @@ -45,7 +45,7 @@ Require Export Partial_Order. Require Export Cpo. Section Integers_sect. - + Inductive Integers : Ensemble nat := Integers_defn : forall x:nat, In nat Integers x. @@ -53,7 +53,7 @@ Section Integers_sect. Proof. red in |- *; auto with arith. Qed. - + Lemma le_antisym : Antisymmetric nat le. Proof. red in |- *; intros x y H H'; rewrite (le_antisym x y); auto. @@ -63,12 +63,12 @@ Section Integers_sect. Proof. red in |- *; intros; apply le_trans with y; auto. Qed. - + Lemma le_Order : Order nat le. Proof. - split; [exact le_reflexive | exact le_trans | exact le_antisym]. + split; [exact le_reflexive | exact le_trans | exact le_antisym]. Qed. - + Lemma triv_nat : forall n:nat, In nat Integers n. Proof. exact Integers_defn. @@ -77,11 +77,11 @@ Section Integers_sect. Definition nat_po : PO nat. apply Definition_of_PO with (Carrier_of := Integers) (Rel_of := le); auto with sets arith. - apply Inhabited_intro with (x := 0). + apply Inhabited_intro with (x := 0). apply Integers_defn. - exact le_Order. + exact le_Order. Defined. - + Lemma le_total_order : Totally_ordered nat nat_po Integers. Proof. apply Totally_ordered_definition. @@ -92,7 +92,7 @@ Section Integers_sect. intro H'1; right. cut (y <= x); auto with sets arith. Qed. - + Lemma Finite_subset_has_lub : forall X:Ensemble nat, Finite nat X -> exists m : nat, Upper_Bound nat nat_po X m. @@ -124,7 +124,7 @@ Section Integers_sect. apply H'4 with (y := x0). elim H'3; simpl in |- *; auto with sets arith. trivial. intros x1 H'4; elim H'4. unfold nat_po; simpl; trivial. exists x0. - apply Upper_Bound_definition. + apply Upper_Bound_definition. unfold nat_po. simpl. apply triv_nat. intros y H'1; elim H'1. intros x1 H'4; try assumption. @@ -148,7 +148,7 @@ Section Integers_sect. absurd (S x <= x); auto with arith. apply triv_nat. Qed. - + Lemma Integers_infinite : ~ Finite nat Integers. Proof. generalize Integers_has_no_ub. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index d2bff488..7216ae33 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -6,11 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Multiset.v 10616 2008-03-04 17:33:35Z letouzey $ i*) +(*i $Id$ i*) (* G. Huet 1-9-95 *) -Require Import Permut. +Require Import Permut Setoid. Set Implicit Arguments. @@ -18,11 +18,12 @@ Section multiset_defs. Variable A : Type. Variable eqA : A -> A -> Prop. + Hypothesis eqA_equiv : Equivalence eqA. Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}. Inductive multiset : Type := Bag : (A -> nat) -> multiset. - + Definition EmptyBag := Bag (fun a:A => 0). Definition SingletonBag (a:A) := Bag (fun a':A => match Aeq_dec a a' with @@ -31,23 +32,23 @@ Section multiset_defs. end). Definition multiplicity (m:multiset) (a:A) : nat := let (f) := m in f a. - + (** multiset equality *) Definition meq (m1 m2:multiset) := forall a:A, multiplicity m1 a = multiplicity m2 a. - + Lemma meq_refl : forall x:multiset, meq x x. Proof. destruct x; unfold meq; reflexivity. Qed. - + Lemma meq_trans : forall x y z:multiset, meq x y -> meq y z -> meq x z. Proof. unfold meq in |- *. destruct x; destruct y; destruct z. intros; rewrite H; auto. Qed. - + Lemma meq_sym : forall x y:multiset, meq x y -> meq y x. Proof. unfold meq in |- *. @@ -62,7 +63,7 @@ Section multiset_defs. Proof. unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto. Qed. - + Lemma munion_empty_right : forall x:multiset, meq x (munion x EmptyBag). Proof. unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto. @@ -70,7 +71,7 @@ Section multiset_defs. Require Plus. (* comm. and ass. of plus *) - + Lemma munion_comm : forall x y:multiset, meq (munion x y) (munion y x). Proof. unfold meq in |- *; unfold multiplicity in |- *; unfold munion in |- *. @@ -106,28 +107,28 @@ Section multiset_defs. Lemma munion_rotate : forall x y z:multiset, meq (munion x (munion y z)) (munion z (munion x y)). Proof. - intros; apply (op_rotate multiset munion meq). + intros; apply (op_rotate multiset munion meq). apply munion_comm. apply munion_ass. exact meq_trans. exact meq_sym. trivial. Qed. - + Lemma meq_congr : forall x y z t:multiset, meq x y -> meq z t -> meq (munion x z) (munion y t). Proof. intros; apply (cong_congr multiset munion meq); auto using meq_left, meq_right. exact meq_trans. Qed. - + Lemma munion_perm_left : forall x y z:multiset, meq (munion x (munion y z)) (munion y (munion x z)). Proof. intros; apply (perm_left multiset munion meq); auto using munion_comm, munion_ass, meq_left, meq_right, meq_sym. exact meq_trans. Qed. - + Lemma multiset_twist1 : forall x y z t:multiset, meq (munion x (munion (munion y z) t)) (munion (munion y (munion x t)) z). @@ -156,7 +157,7 @@ Section multiset_defs. apply meq_right; apply meq_left; trivial. apply multiset_twist1. Qed. - + Lemma treesort_twist2 : forall x y z t u:multiset, meq u (munion y z) -> @@ -167,8 +168,17 @@ Section multiset_defs. apply multiset_twist2. Qed. + (** SingletonBag *) + + Lemma meq_singleton : forall a a', + eqA a a' -> meq (SingletonBag a) (SingletonBag a'). + Proof. + intros; red; simpl; intro a0. + destruct (Aeq_dec a a0) as [Ha|Ha]; rewrite H in Ha; + decide (Aeq_dec a' a0) with Ha; reflexivity. + Qed. -(*i theory of minter to do similarly +(*i theory of minter to do similarly Require Min. (* multiset intersection *) Definition minter := [m1,m2:multiset] diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 6210913c..4fe8f4f6 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -24,27 +24,27 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Partial_Order.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Export Ensembles. Require Export Relations_1. Section Partial_orders. Variable U : Type. - + Definition Carrier := Ensemble U. - + Definition Rel := Relation U. - + Record PO : Type := Definition_of_PO { Carrier_of : Ensemble U; Rel_of : Relation U; PO_cond1 : Inhabited U Carrier_of; PO_cond2 : Order U Rel_of }. Variable p : PO. - + Definition Strict_Rel_of : Rel := fun x y:U => Rel_of p x y /\ x <> y. - + Inductive covers (y x:U) : Prop := Definition_of_covers : Strict_Rel_of x y -> @@ -60,7 +60,7 @@ Hint Resolve Definition_of_covers: sets v62. Section Partial_order_facts. Variable U : Type. Variable D : PO U. - + Lemma Strict_Rel_Transitive_with_Rel : forall x y z:U, Strict_Rel_of U D x y -> Rel_of U D y z -> Strict_Rel_of U D x z. diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v index 4380f10c..f593031a 100644 --- a/theories/Sets/Permut.v +++ b/theories/Sets/Permut.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Permut.v 10616 2008-03-04 17:33:35Z letouzey $ i*) +(*i $Id$ i*) (* G. Huet 1-9-95 *) @@ -36,23 +36,23 @@ Section Axiomatisation. apply cong_left; trivial. apply cong_right; trivial. Qed. - + Lemma comm_right : forall x y z:U, cong (op x (op y z)) (op x (op z y)). Proof. intros; apply cong_right; apply op_comm. Qed. - + Lemma comm_left : forall x y z:U, cong (op (op x y) z) (op (op y x) z). Proof. intros; apply cong_left; apply op_comm. Qed. - + Lemma perm_right : forall x y z:U, cong (op (op x y) z) (op (op x z) y). Proof. intros. apply cong_trans with (op x (op y z)). apply op_ass. - apply cong_trans with (op x (op z y)). + apply cong_trans with (op x (op z y)). apply cong_right; apply op_comm. apply cong_sym; apply op_ass. Qed. @@ -66,7 +66,7 @@ Section Axiomatisation. apply cong_left; apply op_comm. apply op_ass. Qed. - + Lemma op_rotate : forall x y z t:U, cong (op x (op y z)) (op z (op x y)). Proof. intros; apply cong_trans with (op (op x y) z). diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index c9a52ac2..c323ca35 100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Powerset.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id$ i*) Require Export Ensembles. Require Export Relations_1. diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v index 34c49409..36d2150c 100644 --- a/theories/Sets/Powerset_Classical_facts.v +++ b/theories/Sets/Powerset_Classical_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Powerset_Classical_facts.v 10855 2008-04-27 11:16:15Z msozeau $ i*) +(*i $Id$ i*) Require Export Ensembles. Require Export Constructive_sets. @@ -40,7 +40,7 @@ Require Export Classical_sets. Section Sets_as_an_algebra. Variable U : Type. - + Lemma sincl_add_x : forall (A B:Ensemble U) (x:U), ~ In U A x -> @@ -63,7 +63,7 @@ Section Sets_as_an_algebra. intros X x H'; red in |- *. intros x0 H'0; elim H'0; auto with sets. Qed. - + Lemma incl_soustr : forall (X Y:Ensemble U) (x:U), Included U X Y -> Included U (Subtract U X x) (Subtract U Y x). @@ -73,7 +73,7 @@ Section Sets_as_an_algebra. intros H'1 H'2. apply Subtract_intro; auto with sets. Qed. - + Lemma incl_soustr_add_l : forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X. Proof. @@ -93,7 +93,7 @@ Section Sets_as_an_algebra. red in |- *; intro H'1; apply H'; rewrite H'1; auto with sets. Qed. Hint Resolve incl_soustr_add_r: sets v62. - + Lemma add_soustr_2 : forall (X:Ensemble U) (x:U), In U X x -> Included U X (Add U (Subtract U X x) x). @@ -103,7 +103,7 @@ Section Sets_as_an_algebra. elim (classic (x = x0)); intro K; auto with sets. elim K; auto with sets. Qed. - + Lemma add_soustr_1 : forall (X:Ensemble U) (x:U), In U X x -> Included U (Add U (Subtract U X x) x) X. @@ -114,7 +114,7 @@ Section Sets_as_an_algebra. intros t H'1; try assumption. rewrite <- (Singleton_inv U x t); auto with sets. Qed. - + Lemma add_soustr_xy : forall (X:Ensemble U) (x y:U), x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x. @@ -133,7 +133,7 @@ Section Sets_as_an_algebra. intro H'0; elim H'0; auto with sets. intro H'0; rewrite <- H'0; auto with sets. Qed. - + Lemma incl_st_add_soustr : forall (X Y:Ensemble U) (x:U), ~ In U X x -> @@ -151,13 +151,13 @@ Section Sets_as_an_algebra. red in |- *; intro H'0; apply H'2. rewrite H'0; auto 8 using add_soustr_xy, add_soustr_1, add_soustr_2 with sets. Qed. - + Lemma Sub_Add_new : forall (X:Ensemble U) (x:U), ~ In U X x -> X = Subtract U (Add U X x) x. Proof. auto using incl_soustr_add_l with sets. Qed. - + Lemma Simplify_add : forall (X X0:Ensemble U) (x:U), ~ In U X x -> ~ In U X0 x -> Add U X x = Add U X0 x -> X = X0. @@ -167,7 +167,7 @@ Section Sets_as_an_algebra. rewrite (Sub_Add_new X0 x); auto with sets. rewrite H'1; auto with sets. Qed. - + Lemma Included_Add : forall (X A:Ensemble U) (x:U), Included U X (Add U A x) -> @@ -201,7 +201,7 @@ Section Sets_as_an_algebra. absurd (In U X x0); auto with sets. rewrite <- H'5; auto with sets. Qed. - + Lemma setcover_inv : forall A x y:Ensemble U, covers (Ensemble U) (Power_set_PO U A) y x -> @@ -219,7 +219,7 @@ Section Sets_as_an_algebra. elim H'1. exists z; auto with sets. Qed. - + Theorem Add_covers : forall A a:Ensemble U, Included U a A -> @@ -255,7 +255,7 @@ Section Sets_as_an_algebra. intros x1 H'10; elim H'10; auto with sets. intros x2 H'11; elim H'11; auto with sets. Qed. - + Theorem covers_Add : forall A a a':Ensemble U, Included U a A -> @@ -301,7 +301,7 @@ Section Sets_as_an_algebra. intros x H'1; elim H'1; intros H'2 H'3; rewrite H'2; clear H'1. apply Add_covers; intuition. Qed. - + Theorem Singleton_atomic : forall (x:U) (A:Ensemble U), In U A x -> @@ -311,7 +311,7 @@ Section Sets_as_an_algebra. rewrite <- (Empty_set_zero' U x). apply Add_covers; auto with sets. Qed. - + Lemma less_than_singleton : forall (X:Ensemble U) (x:U), Strict_Included U X (Singleton U x) -> X = Empty_set U. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index edb6a215..76f7f1ec 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Powerset_facts.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) Require Export Ensembles. Require Export Constructive_sets. @@ -41,34 +41,34 @@ Section Sets_as_an_algebra. Proof. auto 6 with sets. Qed. - + Theorem Empty_set_zero' : forall x:U, Add U (Empty_set U) x = Singleton U x. Proof. unfold Add at 1 in |- *; auto using Empty_set_zero with sets. Qed. - + Lemma less_than_empty : forall X:Ensemble U, Included U X (Empty_set U) -> X = Empty_set U. Proof. auto with sets. Qed. - + Theorem Union_commutative : forall A B:Ensemble U, Union U A B = Union U B A. Proof. auto with sets. Qed. - + Theorem Union_associative : forall A B C:Ensemble U, Union U (Union U A B) C = Union U A (Union U B C). Proof. auto 9 with sets. Qed. - + Theorem Union_idempotent : forall A:Ensemble U, Union U A A = A. Proof. auto 7 with sets. Qed. - + Lemma Union_absorbs : forall A B:Ensemble U, Included U B A -> Union U A B = A. Proof. @@ -82,7 +82,7 @@ Section Sets_as_an_algebra. intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets). intros x0 H'; elim H'; auto with sets. Qed. - + Theorem Triple_as_union : forall x y z:U, Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z) = @@ -94,7 +94,7 @@ Section Sets_as_an_algebra. intros x1 H'0; elim H'0; auto with sets. intros x0 H'; elim H'; auto with sets. Qed. - + Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y. Proof. intros x y. @@ -102,7 +102,7 @@ Section Sets_as_an_algebra. rewrite <- (Union_idempotent (Singleton U x)). apply Triple_as_union. Qed. - + Theorem Triple_as_Couple_Singleton : forall x y z:U, Triple U x y z = Union U (Couple U x y) (Singleton U z). Proof. @@ -110,7 +110,7 @@ Section Sets_as_an_algebra. rewrite <- (Triple_as_union x y z). rewrite <- (Couple_as_union x y); auto with sets. Qed. - + Theorem Intersection_commutative : forall A B:Ensemble U, Intersection U A B = Intersection U B A. Proof. @@ -118,7 +118,7 @@ Section Sets_as_an_algebra. apply Extensionality_Ensembles. split; red in |- *; intros x H'; elim H'; auto with sets. Qed. - + Theorem Distributivity : forall A B C:Ensemble U, Intersection U A (Union U B C) = @@ -132,7 +132,7 @@ Section Sets_as_an_algebra. elim H'1; auto with sets. elim H'; intros x0 H'0; elim H'0; auto with sets. Qed. - + Theorem Distributivity' : forall A B C:Ensemble U, Union U A (Intersection U B C) = @@ -149,13 +149,13 @@ Section Sets_as_an_algebra. generalize H'1. elim H'2; auto with sets. Qed. - + Theorem Union_add : forall (A B:Ensemble U) (x:U), Add U (Union U A B) x = Union U A (Add U B x). Proof. unfold Add in |- *; auto using Union_associative with sets. Qed. - + Theorem Non_disjoint_union : forall (X:Ensemble U) (x:U), In U X x -> Add U X x = X. Proof. @@ -165,7 +165,7 @@ Section Sets_as_an_algebra. intros x0 H'0; elim H'0; auto with sets. intros t H'1; elim H'1; auto with sets. Qed. - + Theorem Non_disjoint_union' : forall (X:Ensemble U) (x:U), ~ In U X x -> Subtract U X x = X. Proof. @@ -178,12 +178,12 @@ Section Sets_as_an_algebra. lapply (Singleton_inv U x x0); auto with sets. intro H'4; apply H'; rewrite H'4; auto with sets. Qed. - + Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y. Proof. intro x; rewrite (Empty_set_zero' x); auto with sets. Qed. - + Lemma incl_add : forall (A B:Ensemble U) (x:U), Included U A B -> Included U (Add U A x) (Add U B x). @@ -209,7 +209,7 @@ Section Sets_as_an_algebra. absurd (In U A x0); auto with sets. rewrite <- H'4; auto with sets. Qed. - + Lemma Add_commutative : forall (A:Ensemble U) (x y:U), Add U (Add U A x) y = Add U (Add U A y) x. Proof. @@ -220,7 +220,7 @@ Section Sets_as_an_algebra. rewrite <- (Union_associative A (Singleton U y) (Singleton U x)); auto with sets. Qed. - + Lemma Add_commutative' : forall (A:Ensemble U) (x y z:U), Add U (Add U (Add U A x) y) z = Add U (Add U (Add U A z) x) y. @@ -229,7 +229,7 @@ Section Sets_as_an_algebra. rewrite (Add_commutative (Add U A x) y z). rewrite (Add_commutative A x z); auto with sets. Qed. - + Lemma Add_distributes : forall (A B:Ensemble U) (x y:U), Included U B A -> Add U (Add U A x) y = Union U (Add U A x) (Add U B y). diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v index 64c4c654..85d0cffc 100644 --- a/theories/Sets/Relations_1.v +++ b/theories/Sets/Relations_1.v @@ -24,42 +24,42 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_1.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id$ i*) Section Relations_1. Variable U : Type. - + Definition Relation := U -> U -> Prop. Variable R : Relation. - + Definition Reflexive : Prop := forall x:U, R x x. - + Definition Transitive : Prop := forall x y z:U, R x y -> R y z -> R x z. - + Definition Symmetric : Prop := forall x y:U, R x y -> R y x. - + Definition Antisymmetric : Prop := forall x y:U, R x y -> R y x -> x = y. - + Definition contains (R R':Relation) : Prop := forall x y:U, R' x y -> R x y. - + Definition same_relation (R R':Relation) : Prop := contains R R' /\ contains R' R. - + Inductive Preorder : Prop := Definition_of_preorder : Reflexive -> Transitive -> Preorder. - + Inductive Order : Prop := Definition_of_order : Reflexive -> Transitive -> Antisymmetric -> Order. - + Inductive Equivalence : Prop := Definition_of_equivalence : Reflexive -> Transitive -> Symmetric -> Equivalence. - + Inductive PER : Prop := Definition_of_PER : Symmetric -> Transitive -> PER. - + End Relations_1. Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains same_relation: sets v62. diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v index 6ee7f5e2..fd83b0e0 100644 --- a/theories/Sets/Relations_1_facts.v +++ b/theories/Sets/Relations_1_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_1_facts.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id$ i*) Require Export Relations_1. diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v index a74102fd..11ac85e8 100644 --- a/theories/Sets/Relations_2.v +++ b/theories/Sets/Relations_2.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_2.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id$ i*) Require Export Relations_1. diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v index 2374c2bf..3554901b 100644 --- a/theories/Sets/Relations_2_facts.v +++ b/theories/Sets/Relations_2_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_2_facts.v 10637 2008-03-07 23:52:56Z letouzey $ i*) +(*i $Id$ i*) Require Export Relations_1. Require Export Relations_1_facts. @@ -140,7 +140,7 @@ intros U R H' x b H'0; elim H'0. intros x0 a H'1; exists a; auto with sets. intros x0 y z H'1 H'2 H'3 a H'4. red in H'. -specialize H' with (x := x0) (a := a) (b := y); lapply H'; +specialize H' with (x := x0) (a := a) (b := y); lapply H'; [ intro H'8; lapply H'8; [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ] | clear H' ]; auto with sets. diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v index b8c65148..970db182 100644 --- a/theories/Sets/Relations_3.v +++ b/theories/Sets/Relations_3.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_3.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id$ i*) Require Export Relations_1. Require Export Relations_2. @@ -32,26 +32,26 @@ Require Export Relations_2. Section Relations_3. Variable U : Type. Variable R : Relation U. - + Definition coherent (x y:U) : Prop := exists z : _, Rstar U R x z /\ Rstar U R y z. - + Definition locally_confluent (x:U) : Prop := forall y z:U, R x y -> R x z -> coherent y z. - + Definition Locally_confluent : Prop := forall x:U, locally_confluent x. - + Definition confluent (x:U) : Prop := forall y z:U, Rstar U R x y -> Rstar U R x z -> coherent y z. - + Definition Confluent : Prop := forall x:U, confluent x. - + Inductive noetherian (x: U) : Prop := definition_of_noetherian : (forall y:U, R x y -> noetherian y) -> noetherian x. - + Definition Noetherian : Prop := forall x:U, noetherian x. - + End Relations_3. Hint Unfold coherent: sets v62. Hint Unfold locally_confluent: sets v62. diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v index 38ff9eae..d8bf7dc3 100644 --- a/theories/Sets/Relations_3_facts.v +++ b/theories/Sets/Relations_3_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_3_facts.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id$ i*) Require Export Relations_1. Require Export Relations_1_facts. diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 42c96191..909c7983 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Uniset.v 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id$ i*) (** Sets as characteristic functions *) @@ -90,10 +90,10 @@ Qed. Definition union (m1 m2:uniset) := Charac (fun a:A => orb (charac m1 a) (charac m2 a)). -Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x). -Proof. -unfold seq in |- *; unfold union in |- *; simpl in |- *; auto. -Qed. +Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x). +Proof. +unfold seq in |- *; unfold union in |- *; simpl in |- *; auto. +Qed. Hint Resolve union_empty_left. Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset). @@ -203,7 +203,7 @@ apply uniset_twist2. Qed. -(*i theory of minter to do similarly +(*i theory of minter to do similarly Require Min. (* uniset intersection *) Definition minter := [m1,m2:uniset] diff --git a/theories/Sets/vo.itarget b/theories/Sets/vo.itarget new file mode 100644 index 00000000..9ebe92f5 --- /dev/null +++ b/theories/Sets/vo.itarget @@ -0,0 +1,22 @@ +Classical_sets.vo +Constructive_sets.vo +Cpo.vo +Ensembles.vo +Finite_sets_facts.vo +Finite_sets.vo +Image.vo +Infinite_sets.vo +Integers.vo +Multiset.vo +Partial_Order.vo +Permut.vo +Powerset_Classical_facts.vo +Powerset_facts.vo +Powerset.vo +Relations_1_facts.vo +Relations_1.vo +Relations_2_facts.vo +Relations_2.vo +Relations_3_facts.vo +Relations_3.vo +Uniset.vo diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index fe7902aa..4124ef98 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -6,13 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Heap.v 10698 2008-03-19 18:46:59Z letouzey $ i*) +(*i $Id$ i*) -(** A development of Treesort on Heap trees *) +(** This file is deprecated, for a tree on list, use [Mergesort.v]. *) + +(** A development of Treesort on Heap trees. It has an average + complexity of O(n.log n) but of O(n²) in the worst case (e.g. if + the list is already sorted) *) (* G. Huet 1-9-95 uses Multiset *) -Require Import List Multiset Permutation Relations Sorting. +Require Import List Multiset PermutSetoid Relations Sorting. Section defs. @@ -25,7 +29,7 @@ Section defs. Variable eqA : relation A. Let gtA (x y:A) := ~ leA x y. - + Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}. Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y. @@ -37,7 +41,7 @@ Section defs. Let emptyBag := EmptyBag A. Let singletonBag := SingletonBag _ eqA_dec. - + Inductive Tree := | Tree_Leaf : Tree | Tree_Node : A -> Tree -> Tree -> Tree. @@ -92,7 +96,7 @@ Section defs. forall T:Tree, is_heap T -> P T. Proof. simple induction T; auto with datatypes. - intros a G PG D PD PN. + intros a G PG D PD PN. elim (invert_heap a G D); auto with datatypes. intros H1 H2; elim H2; intros H3 H4; elim H4; intros. apply X0; auto with datatypes. @@ -109,7 +113,7 @@ Section defs. forall T:Tree, is_heap T -> P T. Proof. simple induction T; auto with datatypes. - intros a G PG D PD PN. + intros a G PG D PD PN. elim (invert_heap a G D); auto with datatypes. intros H1 H2; elim H2; intros H3 H4; elim H4; intros. apply X; auto with datatypes. @@ -122,6 +126,54 @@ Section defs. intros; simpl in |- *; apply leA_trans with b; auto with datatypes. Qed. + (** ** Merging two sorted lists *) + + Inductive merge_lem (l1 l2:list A) : Type := + merge_exist : + forall l:list A, + Sorted leA l -> + meq (list_contents _ eqA_dec l) + (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) -> + (forall a, HdRel leA a l1 -> HdRel leA a l2 -> HdRel leA a l) -> + merge_lem l1 l2. + + Lemma merge : + forall l1:list A, Sorted leA l1 -> + forall l2:list A, Sorted leA l2 -> merge_lem l1 l2. + Proof. + simple induction 1; intros. + apply merge_exist with l2; auto with datatypes. + elim H2; intros. + apply merge_exist with (a :: l); simpl in |- *; auto using cons_sort with datatypes. + elim (leA_dec a a0); intros. + + (* 1 (leA a a0) *) + cut (merge_lem l (a0 :: l0)); auto using cons_sort with datatypes. + intros [l3 l3sorted l3contents Hrec]. + apply merge_exist with (a :: l3); simpl in |- *; + auto using cons_sort, cons_leA with datatypes. + apply meq_trans with + (munion (singletonBag a) + (munion (list_contents _ eqA_dec l) + (list_contents _ eqA_dec (a0 :: l0)))). + apply meq_right; trivial with datatypes. + apply meq_sym; apply munion_ass. + intros; apply cons_leA. + apply (@HdRel_inv _ leA) with l; trivial with datatypes. + + (* 2 (leA a0 a) *) + elim X0; simpl in |- *; intros. + apply merge_exist with (a0 :: l3); simpl in |- *; + auto using cons_sort, cons_leA with datatypes. + apply meq_trans with + (munion (singletonBag a0) + (munion (munion (singletonBag a) (list_contents _ eqA_dec l)) + (list_contents _ eqA_dec l0))). + apply meq_right; trivial with datatypes. + apply munion_perm_left. + intros; apply cons_leA; apply HdRel_inv with (l:=l0); trivial with datatypes. + Qed. + (** ** From trees to multisets *) @@ -167,15 +219,15 @@ Section defs. elim (X a0); intros. apply insert_exist with (Tree_Node a T2 T0); auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. - simpl in |- *; apply treesort_twist1; trivial with datatypes. + simpl in |- *; apply treesort_twist1; trivial with datatypes. elim (X a); intros T3 HeapT3 ConT3 LeA. - apply insert_exist with (Tree_Node a0 T2 T3); + apply insert_exist with (Tree_Node a0 T2 T3); auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. apply node_is_heap; auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. - apply low_trans with a; auto with datatypes. + apply low_trans with a; auto with datatypes. apply LeA; auto with datatypes. apply low_trans with a; auto with datatypes. - simpl in |- *; apply treesort_twist2; trivial with datatypes. + simpl in |- *; apply treesort_twist2; trivial with datatypes. Qed. @@ -186,7 +238,7 @@ Section defs. forall T:Tree, is_heap T -> meq (list_contents _ eqA_dec l) (contents T) -> build_heap l. - + Lemma list_to_heap : forall l:list A, build_heap l. Proof. simple induction l. @@ -204,12 +256,12 @@ Section defs. (** ** Building the sorted list *) - + Inductive flat_spec (T:Tree) : Type := flat_exist : forall l:list A, - sort leA l -> - (forall a:A, leA_Tree a T -> lelistA leA a l) -> + Sorted leA l -> + (forall a:A, leA_Tree a T -> HdRel leA a l) -> meq (contents T) (list_contents _ eqA_dec l) -> flat_spec T. Lemma heap_to_list : forall T:Tree, is_heap T -> flat_spec T. @@ -217,7 +269,7 @@ Section defs. intros T h; elim h; intros. apply flat_exist with (nil (A:=A)); auto with datatypes. elim X; intros l1 s1 i1 m1; elim X0; intros l2 s2 i2 m2. - elim (merge _ leA_dec eqA_dec s1 s2); intros. + elim (merge _ s1 _ s2); intros. apply flat_exist with (a :: l); simpl in |- *; auto with datatypes. apply meq_trans with (munion (list_contents _ eqA_dec l1) @@ -234,7 +286,8 @@ Section defs. (** * Specification of treesort *) Theorem treesort : - forall l:list A, {m : list A | sort leA m & permutation _ eqA_dec l m}. + forall l:list A, + {m : list A | Sorted leA m & permutation _ eqA_dec l m}. Proof. intro l; unfold permutation in |- *. elim (list_to_heap l). @@ -245,4 +298,4 @@ Section defs. apply meq_trans with (contents T); trivial with datatypes. Qed. -End defs. \ No newline at end of file +End defs. diff --git a/theories/Sorting/Mergesort.v b/theories/Sorting/Mergesort.v new file mode 100644 index 00000000..238013b8 --- /dev/null +++ b/theories/Sorting/Mergesort.v @@ -0,0 +1,271 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* -> Sortclass. + +(** The main module defining [mergesort] on a given boolean + order [<=?]. We require minimal hypotheses : this boolean + order should only be total: [forall x y, (x<=?y) \/ (y<=?x)]. + Transitivity is not mandatory, but without it one can + only prove [LocallySorted] and not [StronglySorted]. +*) + +Module Sort (Import X:Orders.TotalLeBool'). + +Fixpoint merge l1 l2 := + let fix merge_aux l2 := + match l1, l2 with + | [], _ => l2 + | _, [] => l1 + | a1::l1', a2::l2' => + if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2' + end + in merge_aux l2. + +(** We implement mergesort using an explicit stack of pending mergings. + Pending merging are represented like a binary number where digits are + either None (denoting 0) or Some list to merge (denoting 1). The n-th + digit represents the pending list to be merged at level n, if any. + Merging a list to a stack is like adding 1 to the binary number + represented by the stack but the carry is propagated by merging the + lists. In practice, when used in mergesort, the n-th digit, if non 0, + carries a list of length 2^n. For instance, adding singleton list + [3] to the stack Some [4]::Some [2;6]::None::Some [1;3;5;5] + reduces to propagate the carry [3;4] (resulting of the merge of [3] + and [4]) to the list Some [2;6]::None::Some [1;3;5;5], which reduces + to propagating the carry [2;3;4;6] (resulting of the merge of [3;4] and + [2;6]) to the list None::Some [1;3;5;5], which locally produces + Some [2;3;4;6]::Some [1;3;5;5], i.e. which produces the final result + None::None::Some [2;3;4;6]::Some [1;3;5;5]. + + For instance, here is how [6;2;3;1;5] is sorted: + + operation stack list + iter_merge [] [6;2;3;1;5] + = append_list_to_stack [ + [6]] [2;3;1;5] + -> iter_merge [[6]] [2;3;1;5] + = append_list_to_stack [[6] + [2]] [3;1;5] + = append_list_to_stack [ + [2;6];] [3;1;5] + -> iter_merge [[2;6];] [3;1;5] + = append_list_to_stack [[2;6]; + [3]] [1;5] + -> merge_list [[2;6];[3]] [1;5] + = append_list_to_stack [[2;6];[3] + [1] [5] + = append_list_to_stack [[2;6] + [1;3];] [5] + = append_list_to_stack [ + [1;2;3;6];;] [5] + -> merge_list [[1;2;3;6];;] [5] + = append_list_to_stack [[1;2;3;6];; + [5]] [] + -> merge_stack [[1;2;3;6];;[5]] + = [1;2;3;5;6] + + The complexity of the algorithm is n*log n, since there are + 2^(p-1) mergings to do of length 2, 2^(p-2) of length 4, ..., 2^0 + of length 2^p for a list of length 2^p. The algorithm does not need + explicitly cutting the list in 2 parts at each step since it the + successive accumulation of fragments on the stack which ensures + that lists are merged on a dichotomic basis. +*) + +Fixpoint merge_list_to_stack stack l := + match stack with + | [] => [Some l] + | None :: stack' => Some l :: stack' + | Some l' :: stack' => None :: merge_list_to_stack stack' (merge l' l) + end. + +Fixpoint merge_stack stack := + match stack with + | [] => [] + | None :: stack' => merge_stack stack' + | Some l :: stack' => merge l (merge_stack stack') + end. + +Fixpoint iter_merge stack l := + match l with + | [] => merge_stack stack + | a::l' => iter_merge (merge_list_to_stack stack [a]) l' + end. + +Definition sort := iter_merge []. + +(** The proof of correctness *) + +Local Notation Sorted := (LocallySorted leb) (only parsing). + +Fixpoint SortedStack stack := + match stack with + | [] => True + | None :: stack' => SortedStack stack' + | Some l :: stack' => Sorted l /\ SortedStack stack' + end. + +Local Ltac invert H := inversion H; subst; clear H. + +Fixpoint flatten_stack (stack : list (option (list t))) := + match stack with + | [] => [] + | None :: stack' => flatten_stack stack' + | Some l :: stack' => l ++ flatten_stack stack' + end. + +Theorem Sorted_merge : forall l1 l2, + Sorted l1 -> Sorted l2 -> Sorted (merge l1 l2). +Proof. +induction l1; induction l2; intros; simpl; auto. + destruct (a <=? a0) as ()_eqn:Heq1. + invert H. + simpl. constructor; trivial; rewrite Heq1; constructor. + assert (Sorted (merge (b::l) (a0::l2))) by (apply IHl1; auto). + clear H0 H3 IHl1; simpl in *. + destruct (b <=? a0); constructor; auto || rewrite Heq1; constructor. + assert (a0 <=? a) by + (destruct (leb_total a0 a) as [H'|H']; trivial || (rewrite Heq1 in H'; inversion H')). + invert H0. + constructor; trivial. + assert (Sorted (merge (a::l1) (b::l))) by auto using IHl1. + clear IHl2; simpl in *. + destruct (a <=? b); constructor; auto. +Qed. + +Theorem Permuted_merge : forall l1 l2, Permutation (l1++l2) (merge l1 l2). +Proof. + induction l1; simpl merge; intro. + assert (forall l, (fix merge_aux (l0 : list t) : list t := l0) l = l) + as -> by (destruct l; trivial). (* Technical lemma *) + apply Permutation_refl. + induction l2. + rewrite app_nil_r. apply Permutation_refl. + destruct (a <=? a0). + constructor; apply IHl1. + apply Permutation_sym, Permutation_cons_app, Permutation_sym, IHl2. +Qed. + +Theorem Sorted_merge_list_to_stack : forall stack l, + SortedStack stack -> Sorted l -> SortedStack (merge_list_to_stack stack l). +Proof. + induction stack as [|[|]]; intros; simpl. + auto. + apply IHstack. destruct H as (_,H1). fold SortedStack in H1. auto. + apply Sorted_merge; auto; destruct H; auto. + auto. +Qed. + +Theorem Permuted_merge_list_to_stack : forall stack l, + Permutation (l ++ flatten_stack stack) (flatten_stack (merge_list_to_stack stack l)). +Proof. + induction stack as [|[]]; simpl; intros. + reflexivity. + rewrite app_assoc. + etransitivity. + apply Permutation_app_tail. + etransitivity. + apply Permutation_app_comm. + apply Permuted_merge. + apply IHstack. + reflexivity. +Qed. + +Theorem Sorted_merge_stack : forall stack, + SortedStack stack -> Sorted (merge_stack stack). +Proof. +induction stack as [|[|]]; simpl; intros. + constructor; auto. + apply Sorted_merge; tauto. + auto. +Qed. + +Theorem Permuted_merge_stack : forall stack, + Permutation (flatten_stack stack) (merge_stack stack). +Proof. +induction stack as [|[]]; simpl. + trivial. + transitivity (l ++ merge_stack stack). + apply Permutation_app_head; trivial. + apply Permuted_merge. + assumption. +Qed. + +Theorem Sorted_iter_merge : forall stack l, + SortedStack stack -> Sorted (iter_merge stack l). +Proof. + intros stack l H; induction l in stack, H |- *; simpl. + auto using Sorted_merge_stack. + assert (Sorted [a]) by constructor. + auto using Sorted_merge_list_to_stack. +Qed. + +Theorem Permuted_iter_merge : forall l stack, + Permutation (flatten_stack stack ++ l) (iter_merge stack l). +Proof. + induction l; simpl; intros. + rewrite app_nil_r. apply Permuted_merge_stack. + change (a::l) with ([a]++l). + rewrite app_assoc. + etransitivity. + apply Permutation_app_tail. + etransitivity. + apply Permutation_app_comm. + apply Permuted_merge_list_to_stack. + apply IHl. +Qed. + +Theorem Sorted_sort : forall l, Sorted (sort l). +Proof. +intro; apply Sorted_iter_merge. constructor. +Qed. + +Corollary LocallySorted_sort : forall l, Sorted.Sorted leb (sort l). +Proof. intro; eapply Sorted_LocallySorted_iff, Sorted_sort; auto. Qed. + +Theorem Permuted_sort : forall l, Permutation l (sort l). +Proof. +intro; apply (Permuted_iter_merge l []). +Qed. + +Corollary StronglySorted_sort : forall l, + Transitive leb -> StronglySorted leb (sort l). +Proof. auto using Sorted_StronglySorted, LocallySorted_sort. Qed. + +End Sort. + +(** An example *) + +Module NatOrder <: TotalLeBool. + Definition t := nat. + Fixpoint leb x y := + match x, y with + | 0, _ => true + | _, 0 => false + | S x', S y' => leb x' y' + end. + Infix "<=?" := leb (at level 35). + Theorem leb_total : forall a1 a2, a1 <=? a2 \/ a2 <=? a1. + Proof. + induction a1; destruct a2; simpl; auto. + Qed. +End NatOrder. + +Module Import NatSort := Sort NatOrder. + +Example SimpleMergeExample := Eval compute in sort [5;3;6;1;8;6;0]. + diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v index 084aae92..8e6aa6dc 100644 --- a/theories/Sorting/PermutEq.v +++ b/theories/Sorting/PermutEq.v @@ -6,61 +6,51 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PermutEq.v 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id$ i*) -Require Import Omega Relations Setoid List Multiset Permutation. +Require Import Relations Setoid SetoidList List Multiset PermutSetoid Permutation. Set Implicit Arguments. (** This file is similar to [PermutSetoid], except that the equality used here - is Coq usual one instead of a setoid equality. In particular, we can then - prove the equivalence between [List.Permutation] and + is Coq usual one instead of a setoid equality. In particular, we can then + prove the equivalence between [List.Permutation] and [Permutation.permutation]. *) Section Perm. - + Variable A : Type. Hypothesis eq_dec : forall x y:A, {x=y} + {~ x=y}. - + Notation permutation := (permutation _ eq_dec). Notation list_contents := (list_contents _ eq_dec). (** we can use [multiplicity] to define [In] and [NoDup]. *) - Lemma multiplicity_In : + Lemma multiplicity_In : forall l a, In a l <-> 0 < multiplicity (list_contents l) a. Proof. - induction l. - simpl. - split; inversion 1. - simpl. - split; intros. - inversion_clear H. - subst a0. - destruct (eq_dec a a) as [_|H]; auto with arith; destruct H; auto. - destruct (eq_dec a a0) as [H1|H1]; auto with arith; simpl. - rewrite <- IHl; auto. - destruct (eq_dec a a0); auto. - simpl in H. - right; rewrite IHl; auto. + intros; split; intro H. + eapply In_InA, multiplicity_InA in H; eauto with typeclass_instances. + eapply multiplicity_InA, InA_alt in H as (y & -> & H); eauto with typeclass_instances. Qed. Lemma multiplicity_In_O : forall l a, ~ In a l -> multiplicity (list_contents l) a = 0. Proof. - intros l a; rewrite multiplicity_In; + intros l a; rewrite multiplicity_In; destruct (multiplicity (list_contents l) a); auto. destruct 1; auto with arith. Qed. - + Lemma multiplicity_In_S : forall l a, In a l -> multiplicity (list_contents l) a >= 1. Proof. intros l a; rewrite multiplicity_In; auto. Qed. - Lemma multiplicity_NoDup : + Lemma multiplicity_NoDup : forall l, NoDup l <-> (forall a, multiplicity (list_contents l) a <= 1). Proof. induction l. @@ -78,7 +68,7 @@ Section Perm. generalize (H a). destruct (eq_dec a a) as [H0|H0]. destruct (multiplicity (list_contents l) a); auto with arith. - simpl; inversion 1. + simpl; inversion 1. inversion H3. destruct H0; auto. rewrite IHl; intros. @@ -86,13 +76,13 @@ Section Perm. destruct (eq_dec a a0); simpl; auto with arith. Qed. - Lemma NoDup_permut : - forall l l', NoDup l -> NoDup l' -> + Lemma NoDup_permut : + forall l l', NoDup l -> NoDup l' -> (forall x, In x l <-> In x l') -> permutation l l'. Proof. intros. red; unfold meq; intros. - rewrite multiplicity_NoDup in H, H0. + rewrite multiplicity_NoDup in H, H0. generalize (H a) (H0 a) (H1 a); clear H H0 H1. do 2 rewrite multiplicity_In. destruct 3; omega. @@ -102,7 +92,7 @@ Section Perm. Lemma permut_In_In : forall l1 l2 e, permutation l1 l2 -> In e l1 -> In e l2. Proof. - unfold Permutation.permutation, meq; intros l1 l2 e P IN. + unfold PermutSetoid.permutation, meq; intros l1 l2 e P IN. generalize (P e); clear P. destruct (In_dec eq_dec e l2) as [H|H]; auto. rewrite (multiplicity_In_O _ _ H). @@ -128,11 +118,11 @@ Section Perm. intro Abs; generalize (permut_In_In _ Abs H). inversion 1. Qed. - - (** When used with [eq], this permutation notion is equivalent to + + (** When used with [eq], this permutation notion is equivalent to the one defined in [List.v]. *) - Lemma permutation_Permutation : + Lemma permutation_Permutation : forall l l', Permutation l l' <-> permutation l l'. Proof. split. @@ -141,7 +131,7 @@ Section Perm. apply permut_cons; auto. change (permutation (y::x::l) ((x::nil)++y::l)). apply permut_add_cons_inside; simpl; apply permut_refl. - apply permut_tran with l'; auto. + apply permut_trans with l'; auto. revert l'. induction l. intros. @@ -152,7 +142,7 @@ Section Perm. subst l'. apply Permutation_cons_app. apply IHl. - apply permut_remove_hd with a; auto. + apply permut_remove_hd with a; auto with typeclass_instances. Qed. (** Permutation for short lists. *) @@ -160,12 +150,12 @@ Section Perm. Lemma permut_length_1: forall a b, permutation (a :: nil) (b :: nil) -> a=b. Proof. - intros a b; unfold Permutation.permutation, meq; intro P; + intros a b; unfold PermutSetoid.permutation, meq; intro P; generalize (P b); clear P; simpl. destruct (eq_dec b b) as [H|H]; [ | destruct H; auto]. destruct (eq_dec a b); simpl; auto; intros; discriminate. Qed. - + Lemma permut_length_2 : forall a1 b1 a2 b2, permutation (a1 :: b1 :: nil) (a2 :: b2 :: nil) -> (a1=a2) /\ (b1=b2) \/ (a1=b2) /\ (a2=b1). @@ -177,7 +167,7 @@ Section Perm. apply permut_length_1. red; red; intros. generalize (P a); clear P; simpl. - destruct (eq_dec a1 a) as [H2|H2]; + destruct (eq_dec a1 a) as [H2|H2]; destruct (eq_dec a2 a) as [H3|H3]; auto. destruct H3; transitivity a1; auto. destruct H2; transitivity a2; auto. @@ -187,7 +177,7 @@ Section Perm. apply permut_length_1. red; red; intros. generalize (P a); clear P; simpl. - destruct (eq_dec a1 a) as [H2|H2]; + destruct (eq_dec a1 a) as [H2|H2]; destruct (eq_dec b2 a) as [H3|H3]; auto. simpl; rewrite <- plus_n_Sm; inversion 1; auto. destruct H3; transitivity a1; auto. @@ -206,17 +196,17 @@ Section Perm. simpl; rewrite <- plus_n_Sm; f_equal. rewrite <- app_length. apply IHl1. - apply permut_remove_hd with a; auto. + apply permut_remove_hd with a; auto with typeclass_instances. Qed. Variable B : Type. - Variable eqB_dec : forall x y:B, { x=y }+{ ~x=y }. + Variable eqB_dec : forall x y:B, { x=y }+{ ~x=y }. (** Permutation is compatible with map. *) Lemma permutation_map : - forall f l1 l2, permutation l1 l2 -> - Permutation.permutation _ eqB_dec (map f l1) (map f l2). + forall f l1 l2, permutation l1 l2 -> + PermutSetoid.permutation _ eqB_dec (map f l1) (map f l2). Proof. intros f; induction l1. intros l2 P; rewrite (permut_nil (permut_sym P)); apply permut_refl. @@ -229,7 +219,7 @@ Section Perm. apply permut_add_cons_inside. rewrite <- map_app. apply IHl1; auto. - apply permut_remove_hd with a; auto. + apply permut_remove_hd with a; auto with typeclass_instances. Qed. End Perm. diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v index c3888cfa..a9fdfd12 100644 --- a/theories/Sorting/PermutSetoid.v +++ b/theories/Sorting/PermutSetoid.v @@ -6,55 +6,316 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PermutSetoid.v 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id$ i*) -Require Import Omega Relations Multiset Permutation SetoidList. +Require Import Omega Relations Multiset SetoidList. -Set Implicit Arguments. +(** This file is deprecated, use [Permutation.v] instead. + + Indeed, this file defines a notion of permutation based on + multisets (there exists a permutation between two lists iff every + elements have the same multiplicity in the two lists) which + requires a more complex apparatus (the equipment of the domain + with a decidable equality) than [Permutation] in [Permutation.v]. -(** This file contains additional results about permutations - with respect to an setoid equality (i.e. an equivalence relation). + The relation between the two relations are in lemma + [permutation_Permutation]. + + File [PermutEq] concerns Leibniz equality : it shows in particular + that [List.Permutation] and [permutation] are equivalent in this context. *) -Section Perm. +Set Implicit Arguments. + +Local Notation "[ ]" := nil. +Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..). + +Section Permut. + +(** * From lists to multisets *) Variable A : Type. Variable eqA : relation A. +Hypothesis eqA_equiv : Equivalence eqA. Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. -Notation permutation := (permutation _ eqA_dec). -Notation list_contents := (list_contents _ eqA_dec). +Let emptyBag := EmptyBag A. +Let singletonBag := SingletonBag _ eqA_dec. + +(** contents of a list *) + +Fixpoint list_contents (l:list A) : multiset A := + match l with + | [] => emptyBag + | a :: l => munion (singletonBag a) (list_contents l) + end. + +Lemma list_contents_app : + forall l m:list A, + meq (list_contents (l ++ m)) (munion (list_contents l) (list_contents m)). +Proof. + simple induction l; simpl in |- *; auto with datatypes. + intros. + apply meq_trans with + (munion (singletonBag a) (munion (list_contents l0) (list_contents m))); + auto with datatypes. +Qed. + +(** * [permutation]: definition and basic properties *) + +Definition permutation (l m:list A) := meq (list_contents l) (list_contents m). + +Lemma permut_refl : forall l:list A, permutation l l. +Proof. + unfold permutation in |- *; auto with datatypes. +Qed. + +Lemma permut_sym : + forall l1 l2 : list A, permutation l1 l2 -> permutation l2 l1. +Proof. + unfold permutation, meq; intros; apply sym_eq; trivial. +Qed. + +Lemma permut_trans : + forall l m n:list A, permutation l m -> permutation m n -> permutation l n. +Proof. + unfold permutation in |- *; intros. + apply meq_trans with (list_contents m); auto with datatypes. +Qed. + +Lemma permut_cons_eq : + forall l m:list A, + permutation l m -> forall a a', eqA a a' -> permutation (a :: l) (a' :: m). +Proof. + unfold permutation; simpl; intros. + apply meq_trans with (munion (singletonBag a') (list_contents l)). + apply meq_left, meq_singleton; auto. + auto with datatypes. +Qed. + +Lemma permut_cons : + forall l m:list A, + permutation l m -> forall a:A, permutation (a :: l) (a :: m). +Proof. + unfold permutation; simpl; auto with datatypes. +Qed. + +Lemma permut_app : + forall l l' m m':list A, + permutation l l' -> permutation m m' -> permutation (l ++ m) (l' ++ m'). +Proof. + unfold permutation in |- *; intros. + apply meq_trans with (munion (list_contents l) (list_contents m)); + auto using permut_cons, list_contents_app with datatypes. + apply meq_trans with (munion (list_contents l') (list_contents m')); + auto using permut_cons, list_contents_app with datatypes. + apply meq_trans with (munion (list_contents l') (list_contents m)); + auto using permut_cons, list_contents_app with datatypes. +Qed. + +Lemma permut_add_inside_eq : + forall a a' l1 l2 l3 l4, eqA a a' -> + permutation (l1 ++ l2) (l3 ++ l4) -> + permutation (l1 ++ a :: l2) (l3 ++ a' :: l4). +Proof. + unfold permutation, meq in *; intros. + specialize H0 with a0. + repeat rewrite list_contents_app in *; simpl in *. + destruct (eqA_dec a a0) as [Ha|Ha]; rewrite H in Ha; + decide (eqA_dec a' a0) with Ha; simpl; auto with arith. + do 2 rewrite <- plus_n_Sm; f_equal; auto. +Qed. + +Lemma permut_add_inside : + forall a l1 l2 l3 l4, + permutation (l1 ++ l2) (l3 ++ l4) -> + permutation (l1 ++ a :: l2) (l3 ++ a :: l4). +Proof. + unfold permutation, meq in *; intros. + generalize (H a0); clear H. + do 4 rewrite list_contents_app. + simpl. + destruct (eqA_dec a a0); simpl; auto with arith. + do 2 rewrite <- plus_n_Sm; f_equal; auto. +Qed. + +Lemma permut_add_cons_inside_eq : + forall a a' l l1 l2, eqA a a' -> + permutation l (l1 ++ l2) -> + permutation (a :: l) (l1 ++ a' :: l2). +Proof. + intros; + replace (a :: l) with ([] ++ a :: l); trivial; + apply permut_add_inside_eq; trivial. +Qed. -(** The following lemmas need some knowledge on [eqA] *) +Lemma permut_add_cons_inside : + forall a l l1 l2, + permutation l (l1 ++ l2) -> + permutation (a :: l) (l1 ++ a :: l2). +Proof. + intros; + replace (a :: l) with ([] ++ a :: l); trivial; + apply permut_add_inside; trivial. +Qed. -Variable eqA_refl : forall x, eqA x x. -Variable eqA_sym : forall x y, eqA x y -> eqA y x. -Variable eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z. +Lemma permut_middle : + forall (l m:list A) (a:A), permutation (a :: l ++ m) (l ++ a :: m). +Proof. + intros; apply permut_add_cons_inside; auto using permut_sym, permut_refl. +Qed. + +Lemma permut_sym_app : + forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1). +Proof. + intros l1 l2; + unfold permutation, meq; + intro a; do 2 rewrite list_contents_app; simpl; + auto with arith. +Qed. + +Lemma permut_rev : + forall l, permutation l (rev l). +Proof. + induction l. + simpl; trivial using permut_refl. + simpl. + apply permut_add_cons_inside. + rewrite <- app_nil_end. trivial. +Qed. + +(** * Some inversion results. *) +Lemma permut_conv_inv : + forall e l1 l2, permutation (e :: l1) (e :: l2) -> permutation l1 l2. +Proof. + intros e l1 l2; unfold permutation, meq; simpl; intros H a; + generalize (H a); apply plus_reg_l. +Qed. + +Lemma permut_app_inv1 : + forall l l1 l2, permutation (l1 ++ l) (l2 ++ l) -> permutation l1 l2. +Proof. + intros l l1 l2; unfold permutation, meq; simpl; + intros H a; generalize (H a); clear H. + do 2 rewrite list_contents_app. + simpl. + intros; apply plus_reg_l with (multiplicity (list_contents l) a). + rewrite plus_comm; rewrite H; rewrite plus_comm. + trivial. +Qed. (** we can use [multiplicity] to define [InA] and [NoDupA]. *) -Lemma multiplicity_InA : +Fact if_eqA_then : forall a a' (B:Type)(b b':B), + eqA a a' -> (if eqA_dec a a' then b else b') = b. +Proof. + intros. destruct eqA_dec as [_|NEQ]; auto. + contradict NEQ; auto. +Qed. + +Lemma permut_app_inv2 : + forall l l1 l2, permutation (l ++ l1) (l ++ l2) -> permutation l1 l2. +Proof. + intros l l1 l2; unfold permutation, meq; simpl; + intros H a; generalize (H a); clear H. + do 2 rewrite list_contents_app. + simpl. + intros; apply plus_reg_l with (multiplicity (list_contents l) a). + trivial. +Qed. + +Lemma permut_remove_hd_eq : + forall l l1 l2 a b, eqA a b -> + permutation (a :: l) (l1 ++ b :: l2) -> permutation l (l1 ++ l2). +Proof. + unfold permutation, meq; simpl; intros l l1 l2 a b Heq H a0. + specialize H with a0. + rewrite list_contents_app in *; simpl in *. + apply plus_reg_l with (if eqA_dec a a0 then 1 else 0). + rewrite H; clear H. + symmetry; rewrite plus_comm, <- ! plus_assoc; f_equal. + rewrite plus_comm. + destruct (eqA_dec a a0) as [Ha|Ha]; rewrite Heq in Ha; + decide (eqA_dec b a0) with Ha; reflexivity. +Qed. + +Lemma permut_remove_hd : + forall l l1 l2 a, + permutation (a :: l) (l1 ++ a :: l2) -> permutation l (l1 ++ l2). +Proof. + eauto using permut_remove_hd_eq, Equivalence_Reflexive. +Qed. + +Fact if_eqA_else : forall a a' (B:Type)(b b':B), + ~eqA a a' -> (if eqA_dec a a' then b else b') = b'. +Proof. + intros. decide (eqA_dec a a') with H; auto. +Qed. + +Fact if_eqA_refl : forall a (B:Type)(b b':B), + (if eqA_dec a a then b else b') = b. +Proof. + intros; apply (decide_left (eqA_dec a a)); auto with *. +Qed. + +(** PL: Inutilisable dans un rewrite sans un change prealable. *) + +Global Instance if_eqA (B:Type)(b b':B) : + Proper (eqA==>eqA==>@eq _) (fun x y => if eqA_dec x y then b else b'). +Proof. + intros x x' Hxx' y y' Hyy'. + intros; destruct (eqA_dec x y) as [H|H]; + destruct (eqA_dec x' y') as [H'|H']; auto. + contradict H'; transitivity x; auto with *; transitivity y; auto with *. + contradict H; transitivity x'; auto with *; transitivity y'; auto with *. +Qed. + +Fact if_eqA_rewrite_l : forall a1 a1' a2 (B:Type)(b b':B), + eqA a1 a1' -> (if eqA_dec a1 a2 then b else b') = + (if eqA_dec a1' a2 then b else b'). +Proof. + intros; destruct (eqA_dec a1 a2) as [A1|A1]; + destruct (eqA_dec a1' a2) as [A1'|A1']; auto. + contradict A1'; transitivity a1; eauto with *. + contradict A1; transitivity a1'; eauto with *. +Qed. + +Fact if_eqA_rewrite_r : forall a1 a2 a2' (B:Type)(b b':B), + eqA a2 a2' -> (if eqA_dec a1 a2 then b else b') = + (if eqA_dec a1 a2' then b else b'). +Proof. + intros; destruct (eqA_dec a1 a2) as [A2|A2]; + destruct (eqA_dec a1 a2') as [A2'|A2']; auto. + contradict A2'; transitivity a2; eauto with *. + contradict A2; transitivity a2'; eauto with *. +Qed. + + +Global Instance multiplicity_eqA (l:list A) : + Proper (eqA==>@eq _) (multiplicity (list_contents l)). +Proof. + intros x x' Hxx'. + induction l as [|y l Hl]; simpl; auto. + rewrite (@if_eqA_rewrite_r y x x'); auto. +Qed. + +Lemma multiplicity_InA : forall l a, InA eqA a l <-> 0 < multiplicity (list_contents l) a. Proof. induction l. simpl. split; inversion 1. simpl. - split; intros. - inversion_clear H. - destruct (eqA_dec a a0) as [_|H1]; auto with arith. - destruct H1; auto. - destruct (eqA_dec a a0); auto with arith. - simpl; rewrite <- IHl; auto. - destruct (eqA_dec a a0) as [H0|H0]; auto. - simpl in H. - constructor 2; rewrite IHl; auto. + intros a'; split; intros H. inversion_clear H. + apply (decide_left (eqA_dec a a')); auto with *. + destruct (eqA_dec a a'); auto with *. simpl; rewrite <- IHl; auto. + destruct (eqA_dec a a'); auto with *. right. rewrite IHl; auto. Qed. Lemma multiplicity_InA_O : forall l a, ~ InA eqA a l -> multiplicity (list_contents l) a = 0. Proof. - intros l a; rewrite multiplicity_InA; + intros l a; rewrite multiplicity_InA; destruct (multiplicity (list_contents l) a); auto with arith. destruct 1; auto with arith. Qed. @@ -65,7 +326,7 @@ Proof. intros l a; rewrite multiplicity_InA; auto with arith. Qed. -Lemma multiplicity_NoDupA : forall l, +Lemma multiplicity_NoDupA : forall l, NoDupA eqA l <-> (forall a, multiplicity (list_contents l) a <= 1). Proof. induction l. @@ -74,46 +335,41 @@ Proof. split; simpl. inversion_clear 1. rewrite IHl in H1. - intros; destruct (eqA_dec a a0) as [H2|H2]; simpl; auto. + intros; destruct (eqA_dec a a0) as [EQ|NEQ]; simpl; auto with *. + rewrite <- EQ. rewrite multiplicity_InA_O; auto. - contradict H0. - apply InA_eqA with a0; auto. intros; constructor. rewrite multiplicity_InA. - generalize (H a). - destruct (eqA_dec a a) as [H0|H0]. - destruct (multiplicity (list_contents l) a); auto with arith. - simpl; inversion 1. - inversion H3. - destruct H0; auto. + specialize (H a). + rewrite if_eqA_refl in H. + clear IHl; omega. rewrite IHl; intros. - generalize (H a0); auto with arith. - destruct (eqA_dec a a0); simpl; auto with arith. + specialize (H a0); auto with *. + destruct (eqA_dec a a0); simpl; auto with *. Qed. - (** Permutation is compatible with InA. *) Lemma permut_InA_InA : forall l1 l2 e, permutation l1 l2 -> InA eqA e l1 -> InA eqA e l2. Proof. intros l1 l2 e. do 2 rewrite multiplicity_InA. - unfold Permutation.permutation, meq. + unfold permutation, meq. intros H;rewrite H; auto. Qed. Lemma permut_cons_InA : forall l1 l2 e, permutation (e :: l1) l2 -> InA eqA e l2. Proof. - intros; apply (permut_InA_InA (e:=e) H); auto. + intros; apply (permut_InA_InA (e:=e) H); auto with *. Qed. (** Permutation of an empty list. *) Lemma permut_nil : - forall l, permutation l nil -> l = nil. + forall l, permutation l [] -> l = []. Proof. intro l; destruct l as [ | e l ]; trivial. - assert (InA eqA e (e::l)) by auto. + assert (InA eqA e (e::l)) by (auto with *). intro Abs; generalize (permut_InA_InA Abs H). inversion 1. Qed. @@ -121,16 +377,16 @@ Qed. (** Permutation for short lists. *) Lemma permut_length_1: - forall a b, permutation (a :: nil) (b :: nil) -> eqA a b. + forall a b, permutation [a] [b] -> eqA a b. Proof. - intros a b; unfold Permutation.permutation, meq; intro P; - generalize (P b); clear P; simpl. - destruct (eqA_dec b b) as [H|H]; [ | destruct H; auto]. - destruct (eqA_dec a b); simpl; auto; intros; discriminate. + intros a b; unfold permutation, meq. + intro P; specialize (P b); simpl in *. + rewrite if_eqA_refl in *. + destruct (eqA_dec a b); simpl; auto; discriminate. Qed. Lemma permut_length_2 : - forall a1 b1 a2 b2, permutation (a1 :: b1 :: nil) (a2 :: b2 :: nil) -> + forall a1 b1 a2 b2, permutation [a1; b1] [a2; b2] -> (eqA a1 a2) /\ (eqA b1 b2) \/ (eqA a1 b2) /\ (eqA a2 b1). Proof. intros a1 b1 a2 b2 P. @@ -139,22 +395,19 @@ Proof. left; split; auto. apply permut_length_1. red; red; intros. - generalize (P a); clear P; simpl. - destruct (eqA_dec a1 a) as [H2|H2]; - destruct (eqA_dec a2 a) as [H3|H3]; auto. - destruct H3; apply eqA_trans with a1; auto. - destruct H2; apply eqA_trans with a2; auto. + specialize (P a). simpl in *. + rewrite (@if_eqA_rewrite_l a1 a2 a) in P by auto. + (** Bug omega: le "set" suivant ne devrait pas etre necessaire *) + set (u:= if eqA_dec a2 a then 1 else 0) in *; omega. right. inversion_clear H0; [|inversion H]. split; auto. apply permut_length_1. red; red; intros. - generalize (P a); clear P; simpl. - destruct (eqA_dec a1 a) as [H2|H2]; - destruct (eqA_dec b2 a) as [H3|H3]; auto. - simpl; rewrite <- plus_n_Sm; inversion 1; auto. - destruct H3; apply eqA_trans with a1; auto. - destruct H2; apply eqA_trans with b2; auto. + specialize (P a); simpl in *. + rewrite (@if_eqA_rewrite_l a1 b2 a) in P by auto. + (** Bug omega: idem *) + set (u:= if eqA_dec b2 a then 1 else 0) in *; omega. Qed. (** Permutation is compatible with length. *) @@ -171,68 +424,131 @@ Proof. rewrite <- app_length. apply IHl1. apply permut_remove_hd with b. - apply permut_tran with (a::l1); auto. - revert H1; unfold Permutation.permutation, meq; simpl. + apply permut_trans with (a::l1); auto. + revert H1; unfold permutation, meq; simpl. intros; f_equal; auto. - destruct (eqA_dec b a0) as [H2|H2]; - destruct (eqA_dec a a0) as [H3|H3]; auto. - destruct H3; apply eqA_trans with b; auto. - destruct H2; apply eqA_trans with a; auto. + rewrite (@if_eqA_rewrite_l a b a0); auto. Qed. -Lemma NoDupA_equivlistA_permut : - forall l l', NoDupA eqA l -> NoDupA eqA l' -> +Lemma NoDupA_equivlistA_permut : + forall l l', NoDupA eqA l -> NoDupA eqA l' -> equivlistA eqA l l' -> permutation l l'. Proof. intros. red; unfold meq; intros. - rewrite multiplicity_NoDupA in H, H0. + rewrite multiplicity_NoDupA in H, H0. generalize (H a) (H0 a) (H1 a); clear H H0 H1. do 2 rewrite multiplicity_InA. destruct 3; omega. Qed. +End Permut. + +Section Permut_map. + +Variables A B : Type. + +Variable eqA : relation A. +Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. +Hypothesis eqA_equiv : Equivalence eqA. -Variable B : Type. Variable eqB : B->B->Prop. -Variable eqB_dec : forall x y:B, { eqB x y }+{ ~eqB x y }. -Variable eqB_trans : forall x y z, eqB x y -> eqB y z -> eqB x z. +Hypothesis eqB_dec : forall x y:B, { eqB x y }+{ ~eqB x y }. +Hypothesis eqB_trans : Transitive eqB. (** Permutation is compatible with map. *) Lemma permut_map : - forall f, - (forall x y, eqA x y -> eqB (f x) (f y)) -> - forall l1 l2, permutation l1 l2 -> - Permutation.permutation _ eqB_dec (map f l1) (map f l2). + forall f, + (Proper (eqA==>eqB) f) -> + forall l1 l2, permutation _ eqA_dec l1 l2 -> + permutation _ eqB_dec (map f l1) (map f l2). Proof. intros f; induction l1. - intros l2 P; rewrite (permut_nil (permut_sym P)); apply permut_refl. + intros l2 P; rewrite (permut_nil eqA_equiv (permut_sym P)); apply permut_refl. intros l2 P. simpl. - assert (H0:=permut_cons_InA P). + assert (H0:=permut_cons_InA eqA_equiv P). destruct (InA_split H0) as (h2,(b,(t2,(H1,H2)))). subst l2. rewrite map_app. simpl. - apply permut_tran with (f b :: map f l1). - revert H1; unfold Permutation.permutation, meq; simpl. + apply permut_trans with (f b :: map f l1). + revert H1; unfold permutation, meq; simpl. intros; f_equal; auto. - destruct (eqB_dec (f b) a0) as [H2|H2]; + destruct (eqB_dec (f b) a0) as [H2|H2]; destruct (eqB_dec (f a) a0) as [H3|H3]; auto. - destruct H3; apply eqB_trans with (f b); auto. - destruct H2; apply eqB_trans with (f a); auto. + destruct H3; transitivity (f b); auto with *. + destruct H2; transitivity (f a); auto with *. apply permut_add_cons_inside. rewrite <- map_app. apply IHl1; auto. - apply permut_remove_hd with b. - apply permut_tran with (a::l1); auto. - revert H1; unfold Permutation.permutation, meq; simpl. + apply permut_remove_hd with b; trivial. + apply permut_trans with (a::l1); auto. + revert H1; unfold permutation, meq; simpl. intros; f_equal; auto. - destruct (eqA_dec b a0) as [H2|H2]; - destruct (eqA_dec a a0) as [H3|H3]; auto. - destruct H3; apply eqA_trans with b; auto. - destruct H2; apply eqA_trans with a; auto. + rewrite (@if_eqA_rewrite_l _ _ eqA_equiv eqA_dec a b a0); auto. Qed. -End Perm. +End Permut_map. + +Require Import Permutation TheoryList. + +Section Permut_permut. + +Variable A : Type. + +Variable eqA : relation A. +Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. +Hypothesis eqA_equiv : Equivalence eqA. + +Lemma Permutation_impl_permutation : forall l l', + Permutation l l' -> permutation _ eqA_dec l l'. +Proof. + induction 1. + apply permut_refl. + apply permut_cons; auto using Equivalence_Reflexive. + change (x :: y :: l) with ([x] ++ y :: l); + apply permut_add_cons_inside; simpl; + apply permut_cons_eq; auto using Equivalence_Reflexive, permut_refl. + apply permut_trans with l'; trivial. +Qed. + +Lemma permut_eqA : forall l l', Forall2 eqA l l' -> permutation _ eqA_dec l l'. +Proof. + induction 1. + apply permut_refl. + apply permut_cons_eq; trivial. +Qed. + +Lemma permutation_Permutation : forall l l', + permutation _ eqA_dec l l' <-> + exists l'', Permutation l l'' /\ Forall2 eqA l'' l'. +Proof. + split; intro H. + (* -> *) + induction l in l', H |- *. + exists []; apply permut_sym, permut_nil in H as ->; auto using Forall2. + pose proof H as H'. + apply permut_cons_InA, InA_split in H + as (l1 & y & l2 & Heq & ->); trivial. + apply permut_remove_hd_eq, IHl in H' + as (l'' & IHP & IHA); clear IHl; trivial. + apply Forall2_app_inv_r in IHA as (l1'' & l2'' & Hl1 & Hl2 & ->). + exists (l1'' ++ a :: l2''); split. + apply Permutation_cons_app; trivial. + apply Forall2_app, Forall2_cons; trivial. + (* <- *) + destruct H as (l'' & H & Heq). + apply permut_trans with l''. + apply Permutation_impl_permutation; trivial. + apply permut_eqA; trivial. +Qed. + +End Permut_permut. + +(* begin hide *) +(** For compatibilty *) +Notation permut_right := permut_cons (only parsing). +Notation permut_tran := permut_trans (only parsing). +(* end hide *) diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 82294b70..f3e62632 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -6,199 +6,373 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Permutation.v 10698 2008-03-19 18:46:59Z letouzey $ i*) +(*i $Id$ i*) -Require Import Relations List Multiset Arith. +(*********************************************************************) +(** ** List permutations as a composition of adjacent transpositions *) +(*********************************************************************) -(** This file define a notion of permutation for lists, based on multisets: - there exists a permutation between two lists iff every elements have - the same multiplicities in the two lists. +(* Adapted in May 2006 by Jean-Marc Notin from initial contents by + Laurent Théry (Huffmann contribution, October 2003) *) - Unlike [List.Permutation], the present notion of permutation requires - a decidable equality. At the same time, this definition can be used - with a non-standard equality, whereas [List.Permutation] cannot. - - The present file contains basic results, obtained without any particular - assumption on the decidable equality used. - - File [PermutSetoid] contains additional results about permutations - with respect to an setoid equality (i.e. an equivalence relation). - - Finally, file [PermutEq] concerns Coq equality : this file is similar - to the previous one, but proves in addition that [List.Permutation] - and [permutation] are equivalent in this context. -x*) +Require Import List Setoid. Set Implicit Arguments. -Section defs. - - (** * From lists to multisets *) - - Variable A : Type. - Variable eqA : relation A. - Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. - - Let emptyBag := EmptyBag A. - Let singletonBag := SingletonBag _ eqA_dec. - - (** contents of a list *) - - Fixpoint list_contents (l:list A) : multiset A := - match l with - | nil => emptyBag - | a :: l => munion (singletonBag a) (list_contents l) - end. - - Lemma list_contents_app : - forall l m:list A, - meq (list_contents (l ++ m)) (munion (list_contents l) (list_contents m)). - Proof. - simple induction l; simpl in |- *; auto with datatypes. - intros. - apply meq_trans with - (munion (singletonBag a) (munion (list_contents l0) (list_contents m))); - auto with datatypes. - Qed. - - - (** * [permutation]: definition and basic properties *) - - Definition permutation (l m:list A) := - meq (list_contents l) (list_contents m). - - Lemma permut_refl : forall l:list A, permutation l l. - Proof. - unfold permutation in |- *; auto with datatypes. - Qed. - - Lemma permut_sym : - forall l1 l2 : list A, permutation l1 l2 -> permutation l2 l1. - Proof. - unfold permutation, meq; intros; apply sym_eq; trivial. - Qed. - - Lemma permut_tran : - forall l m n:list A, permutation l m -> permutation m n -> permutation l n. - Proof. - unfold permutation in |- *; intros. - apply meq_trans with (list_contents m); auto with datatypes. - Qed. - - Lemma permut_cons : - forall l m:list A, - permutation l m -> forall a:A, permutation (a :: l) (a :: m). - Proof. - unfold permutation in |- *; simpl in |- *; auto with datatypes. - Qed. - - Lemma permut_app : - forall l l' m m':list A, - permutation l l' -> permutation m m' -> permutation (l ++ m) (l' ++ m'). - Proof. - unfold permutation in |- *; intros. - apply meq_trans with (munion (list_contents l) (list_contents m)); - auto using permut_cons, list_contents_app with datatypes. - apply meq_trans with (munion (list_contents l') (list_contents m')); - auto using permut_cons, list_contents_app with datatypes. - apply meq_trans with (munion (list_contents l') (list_contents m)); - auto using permut_cons, list_contents_app with datatypes. - Qed. - - Lemma permut_add_inside : - forall a l1 l2 l3 l4, - permutation (l1 ++ l2) (l3 ++ l4) -> - permutation (l1 ++ a :: l2) (l3 ++ a :: l4). - Proof. - unfold permutation, meq in *; intros. - generalize (H a0); clear H. - do 4 rewrite list_contents_app. - simpl. - destruct (eqA_dec a a0); simpl; auto with arith. - do 2 rewrite <- plus_n_Sm; f_equal; auto. - Qed. - - Lemma permut_add_cons_inside : - forall a l l1 l2, - permutation l (l1 ++ l2) -> - permutation (a :: l) (l1 ++ a :: l2). - Proof. - intros; - replace (a :: l) with (nil ++ a :: l); trivial; - apply permut_add_inside; trivial. - Qed. - - Lemma permut_middle : - forall (l m:list A) (a:A), permutation (a :: l ++ m) (l ++ a :: m). - Proof. - intros; apply permut_add_cons_inside; auto using permut_sym, permut_refl. - Qed. - - Lemma permut_sym_app : - forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1). - Proof. - intros l1 l2; - unfold permutation, meq; - intro a; do 2 rewrite list_contents_app; simpl; - auto with arith. - Qed. - - Lemma permut_rev : - forall l, permutation l (rev l). - Proof. - induction l. - simpl; trivial using permut_refl. - simpl. - apply permut_add_cons_inside. - rewrite <- app_nil_end. trivial. - Qed. - - (** * Some inversion results. *) - Lemma permut_conv_inv : - forall e l1 l2, permutation (e :: l1) (e :: l2) -> permutation l1 l2. - Proof. - intros e l1 l2; unfold permutation, meq; simpl; intros H a; - generalize (H a); apply plus_reg_l. - Qed. - - Lemma permut_app_inv1 : - forall l l1 l2, permutation (l1 ++ l) (l2 ++ l) -> permutation l1 l2. - Proof. - intros l l1 l2; unfold permutation, meq; simpl; - intros H a; generalize (H a); clear H. - do 2 rewrite list_contents_app. - simpl. - intros; apply plus_reg_l with (multiplicity (list_contents l) a). - rewrite plus_comm; rewrite H; rewrite plus_comm. - trivial. - Qed. - - Lemma permut_app_inv2 : - forall l l1 l2, permutation (l ++ l1) (l ++ l2) -> permutation l1 l2. - Proof. - intros l l1 l2; unfold permutation, meq; simpl; - intros H a; generalize (H a); clear H. - do 2 rewrite list_contents_app. - simpl. - intros; apply plus_reg_l with (multiplicity (list_contents l) a). - trivial. - Qed. - - Lemma permut_remove_hd : - forall l l1 l2 a, - permutation (a :: l) (l1 ++ a :: l2) -> permutation l (l1 ++ l2). - Proof. - intros l l1 l2 a; unfold permutation, meq; simpl; intros H a0; generalize (H a0); clear H. - do 2 rewrite list_contents_app; simpl; intro H. - apply plus_reg_l with (if eqA_dec a a0 then 1 else 0). - rewrite H; clear H. - symmetry; rewrite plus_comm. - repeat rewrite <- plus_assoc; f_equal. - apply plus_comm. - Qed. - -End defs. - -(** For compatibilty *) -Notation permut_right := permut_cons. -Unset Implicit Arguments. +Local Notation "[ ]" := nil. +Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..). + +Section Permutation. + +Variable A:Type. + +Inductive Permutation : list A -> list A -> Prop := +| perm_nil: Permutation [] [] +| perm_skip x l l' : Permutation l l' -> Permutation (x::l) (x::l') +| perm_swap x y l : Permutation (y::x::l) (x::y::l) +| perm_trans l l' l'' : Permutation l l' -> Permutation l' l'' -> Permutation l l''. + +Local Hint Constructors Permutation. + +(** Some facts about [Permutation] *) + +Theorem Permutation_nil : forall (l : list A), Permutation [] l -> l = []. +Proof. + intros l HF. + remember (@nil A) as m in HF. + induction HF; discriminate || auto. +Qed. + +Theorem Permutation_nil_cons : forall (l : list A) (x : A), ~ Permutation nil (x::l). +Proof. + intros l x HF. + apply Permutation_nil in HF; discriminate. +Qed. + +(** Permutation over lists is a equivalence relation *) + +Theorem Permutation_refl : forall l : list A, Permutation l l. +Proof. + induction l; constructor. exact IHl. +Qed. + +Theorem Permutation_sym : forall l l' : list A, Permutation l l' -> Permutation l' l. +Proof. + intros l l' Hperm; induction Hperm; auto. + apply perm_trans with (l':=l'); assumption. +Qed. + +Theorem Permutation_trans : forall l l' l'' : list A, Permutation l l' -> Permutation l' l'' -> Permutation l l''. +Proof. + exact perm_trans. +Qed. + +End Permutation. + +Hint Resolve Permutation_refl perm_nil perm_skip. + +(* These hints do not reduce the size of the problem to solve and they + must be used with care to avoid combinatoric explosions *) + +Local Hint Resolve perm_swap perm_trans. +Local Hint Resolve Permutation_sym Permutation_trans. + +(* This provides reflexivity, symmetry and transitivity and rewriting + on morphims to come *) + +Instance Permutation_Equivalence A : Equivalence (@Permutation A) | 10 := { + Equivalence_Reflexive := @Permutation_refl A ; + 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. +Proof. + auto using perm_skip. +Qed. + +Section Permutation_properties. + +Variable A:Type. + +Implicit Types a b : A. +Implicit Types l m : list A. + +(** Compatibility with others operations on lists *) + +Theorem Permutation_in : forall (l l' : list A) (x : A), Permutation l l' -> In x l -> In x l'. +Proof. + intros l l' x Hperm; induction Hperm; simpl; tauto. +Qed. + +Lemma Permutation_app_tail : forall (l l' tl : list A), Permutation l l' -> Permutation (l++tl) (l'++tl). +Proof. + intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto. + eapply Permutation_trans with (l':=l'++tl); trivial. +Qed. + +Lemma Permutation_app_head : forall (l tl tl' : list A), Permutation tl tl' -> Permutation (l++tl) (l++tl'). +Proof. + intros l tl tl' Hperm; induction l; [trivial | repeat rewrite <- app_comm_cons; constructor; assumption]. +Qed. + +Theorem Permutation_app : forall (l m l' m' : list A), Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m'). +Proof. + intros l m l' m' Hpermll' Hpermmm'; induction Hpermll' as [|x l l'|x y l|l l' l'']; repeat rewrite <- app_comm_cons; auto. + apply Permutation_trans with (l' := (x :: y :: l ++ m)); + [idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial. + apply Permutation_trans with (l' := (l' ++ m')); try assumption. + apply Permutation_app_tail; assumption. +Qed. + +Add Parametric Morphism : (@app A) + with signature @Permutation A ==> @Permutation A ==> @Permutation A + as Permutation_app'. + auto using Permutation_app. +Qed. + +Lemma Permutation_add_inside : forall a (l l' tl tl' : list A), + Permutation l l' -> Permutation tl tl' -> + Permutation (l ++ a :: tl) (l' ++ a :: tl'). +Proof. + intros; apply Permutation_app; auto. +Qed. + +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. + induction l' as [|y l']; simpl. + rewrite app_nil_r; trivial. + transitivity (x :: y :: l' ++ l). + constructor; rewrite app_comm_cons; apply IHl. + transitivity (y :: x :: l' ++ l); constructor. + transitivity (x :: l ++ l'); auto. +Qed. + +Theorem Permutation_cons_app : forall (l l1 l2:list A) a, + Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2). +Proof. + intros l l1; revert l. + induction l1. + simpl. + intros; apply perm_skip; auto. + simpl; intros. + transitivity (a0::a::l1++l2). + apply perm_skip; auto. + transitivity (a::a0::l1++l2). + apply perm_swap; auto. + apply perm_skip; auto. +Qed. +Local Hint Resolve Permutation_cons_app. + +Theorem Permutation_middle : forall (l1 l2:list A) a, + Permutation (a :: l1 ++ l2) (l1 ++ a :: l2). +Proof. + auto. +Qed. + +Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). +Proof. + induction l as [| x l]; simpl; trivial. + apply Permutation_trans with (l' := [x] ++ rev l). + simpl; auto. + apply Permutation_app_comm. +Qed. + +Theorem Permutation_length : forall (l l' : list A), Permutation l l' -> length l = length l'. +Proof. + intros l l' Hperm; induction Hperm; simpl; auto. + apply trans_eq with (y:= (length l')); trivial. +Qed. + +Theorem Permutation_ind_bis : + forall P : list A -> list A -> Prop, + P [] [] -> + (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) -> + (forall x y l l', Permutation l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) -> + (forall l l' l'', Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') -> + forall l l', Permutation l l' -> P l l'. +Proof. + intros P Hnil Hskip Hswap Htrans. + induction 1; auto. + apply Htrans with (x::y::l); auto. + apply Hswap; auto. + induction l; auto. + apply Hskip; auto. + apply Hskip; auto. + induction l; auto. + eauto. +Qed. + +Ltac break_list l x l' H := + destruct l as [|x l']; simpl in *; + injection H; intros; subst; clear H. + +Theorem Permutation_app_inv : forall (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. + apply perm_trans with (l3'++c::l4); auto. + apply perm_trans with (l1'++a::l2); auto using Permutation_cons_app. + apply perm_skip. + apply (IH a l1' l2 l3' l4); auto. + (* 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. + apply perm_trans with (c::l3''++b::l4); auto. + break_list l1' c l1'' H1. + auto. + apply perm_trans with (b::l1''++c::l2); auto. + break_list l3' d l3'' H; break_list l1' e l1'' H1. + auto. + apply perm_trans with (e::a::l1''++l2); auto. + apply perm_trans with (e::l1''++a::l2); auto. + apply perm_trans with (d::a::l3''++l4); auto. + apply perm_trans with (d::l3''++a::l4); auto. + apply perm_trans with (e::d::l1''++l2); auto. + apply perm_skip; apply perm_skip. + apply (IH a l1'' l2 l3'' l4); auto. + (*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). +Qed. + +Theorem Permutation_cons_inv : + forall l l' a, Permutation (a::l) (a::l') -> Permutation l l'. +Proof. + intros; exact (Permutation_app_inv [] l [] l' a H). +Qed. + +Theorem Permutation_cons_app_inv : + forall 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). +Qed. + +Theorem Permutation_app_inv_l : + forall l l1 l2, Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2. +Proof. + induction l; simpl; auto. + intros. + apply IHl. + apply Permutation_cons_inv with a; auto. +Qed. + +Theorem Permutation_app_inv_r : + forall 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. +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); + discriminate || auto. + apply Permutation_nil in H as ->; trivial. +Qed. + +Lemma Permutation_length_1: forall a b, Permutation [a] [b] -> a = b. +Proof. + intros a b H. + apply Permutation_length_1_inv in H; injection H as ->; trivial. +Qed. + +Lemma Permutation_length_2_inv : + forall a1 a2 l, Permutation [a1;a2] l -> l = [a1;a2] \/ l = [a2;a1]. +Proof. + intros a1 a2 l H; remember [a1;a2] as m in H. + revert a1 a2 Heqm. + induction H; intros; try (injection Heqm; intros; subst; clear Heqm); + discriminate || (try tauto). + apply Permutation_length_1_inv in H as ->; left; auto. + apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as (); + auto. +Qed. + +Lemma Permutation_length_2 : + forall a1 a2 b1 b2, Permutation [a1;a2] [b1;b2] -> + a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1. +Proof. + intros a1 b1 a2 b2 H. + apply Permutation_length_2_inv in H as [H|H]; injection H as -> ->; auto. +Qed. + +Lemma NoDup_Permutation : forall 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). +Qed. + +End Permutation_properties. + +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. +Proof. + induction 1; simpl; eauto using Permutation. +Qed. + +Lemma Permutation_map : + forall l l', Permutation l l' -> Permutation (map f l) (map f l'). +Proof. + exact Permutation_map_aux_Proper. +Qed. + +End Permutation_map. + +(* begin hide *) +Notation Permutation_app_swap := Permutation_app_comm (only parsing). +(* end hide *) diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v new file mode 100644 index 00000000..2b9f59f0 --- /dev/null +++ b/theories/Sorting/Sorted.v @@ -0,0 +1,154 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A -> Prop. + + (** Locally sorted: consecutive elements of the list are ordered *) + + Inductive LocallySorted : list A -> Prop := + | LSorted_nil : LocallySorted [] + | LSorted_cons1 a : LocallySorted [a] + | LSorted_consn a b l : + LocallySorted (b :: l) -> R a b -> LocallySorted (a :: b :: l). + + (** Alternative two-step definition of being locally sorted *) + + Inductive HdRel a : list A -> Prop := + | HdRel_nil : HdRel a [] + | HdRel_cons b l : R a b -> HdRel a (b :: l). + + Inductive Sorted : list A -> Prop := + | Sorted_nil : Sorted [] + | Sorted_cons a l : Sorted l -> HdRel a l -> Sorted (a :: l). + + Lemma HdRel_inv : forall a b l, HdRel a (b :: l) -> R a b. + Proof. + inversion 1; auto. + Qed. + + Lemma Sorted_inv : + forall a l, Sorted (a :: l) -> Sorted l /\ HdRel a l. + Proof. + intros a l H; inversion H; auto. + Qed. + + Lemma Sorted_rect : + forall P:list A -> Type, + P [] -> + (forall a l, Sorted l -> P l -> HdRel a l -> P (a :: l)) -> + forall l:list A, Sorted l -> P l. + Proof. + induction l; firstorder using Sorted_inv. + Qed. + + Lemma Sorted_LocallySorted_iff : forall l, Sorted l <-> LocallySorted l. + Proof. + split; [induction 1 as [|a l [|]]| induction 1]; + auto using Sorted, LocallySorted, HdRel. + inversion H1; subst; auto using LocallySorted. + Qed. + + (** Strongly sorted: elements of the list are pairwise ordered *) + + Inductive StronglySorted : list A -> Prop := + | SSorted_nil : StronglySorted [] + | SSorted_cons a l : StronglySorted l -> Forall (R a) l -> StronglySorted (a :: l). + + Lemma StronglySorted_inv : forall a l, StronglySorted (a :: l) -> + StronglySorted l /\ Forall (R a) l. + Proof. + intros; inversion H; auto. + Defined. + + Lemma StronglySorted_rect : + forall P:list A -> Type, + P [] -> + (forall a l, StronglySorted l -> P l -> Forall (R a) l -> P (a :: l)) -> + forall l, StronglySorted l -> P l. + Proof. + induction l; firstorder using StronglySorted_inv. + Defined. + + Lemma StronglySorted_rec : + forall P:list A -> Type, + P [] -> + (forall a l, StronglySorted l -> P l -> Forall (R a) l -> P (a :: l)) -> + forall l, StronglySorted l -> P l. + Proof. + firstorder using StronglySorted_rect. + Qed. + + Lemma StronglySorted_Sorted : forall l, StronglySorted l -> Sorted l. + Proof. + induction 1 as [|? ? ? ? HForall]; constructor; trivial. + destruct HForall; constructor; trivial. + Qed. + + Lemma Sorted_extends : + Transitive R -> forall a l, Sorted (a::l) -> Forall (R a) l. + Proof. + intros. change match a :: l with [] => True | a :: l => Forall (R a) l end. + induction H0 as [|? ? ? ? H1]; [trivial|]. + destruct H1; constructor; trivial. + eapply Forall_impl; [|eassumption]. + firstorder. + Qed. + + Lemma Sorted_StronglySorted : + Transitive R -> forall l, Sorted l -> StronglySorted l. + Proof. + induction 2; constructor; trivial. + apply Sorted_extends; trivial. + constructor; trivial. + Qed. + +End defs. + +Hint Constructors HdRel. +Hint Constructors Sorted. + +(* begin hide *) +(* Compatibility with deprecated file Sorting.v *) +Notation lelistA := HdRel (only parsing). +Notation nil_leA := HdRel_nil (only parsing). +Notation cons_leA := HdRel_cons (only parsing). + +Notation sort := Sorted (only parsing). +Notation nil_sort := Sorted_nil (only parsing). +Notation cons_sort := Sorted_cons (only parsing). + +Notation lelistA_inv := HdRel_inv (only parsing). +Notation sort_inv := Sorted_inv (only parsing). +Notation sort_rect := Sorted_rect (only parsing). +(* end hide *) diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v index aed8cd15..5f8da6a4 100644 --- a/theories/Sorting/Sorting.v +++ b/theories/Sorting/Sorting.v @@ -6,125 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Sorting.v 10698 2008-03-19 18:46:59Z letouzey $ i*) +(*i $Id$ i*) -Require Import List Multiset Permutation Relations. - -Set Implicit Arguments. - -Section defs. - - Variable A : Type. - Variable leA : relation A. - Variable eqA : relation A. - - Let gtA (x y:A) := ~ leA x y. - - Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}. - Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. - Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y. - Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z. - Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y. - - Hint Resolve leA_refl. - Hint Immediate eqA_dec leA_dec leA_antisym. - - Let emptyBag := EmptyBag A. - Let singletonBag := SingletonBag _ eqA_dec. - - (** [lelistA] *) - - Inductive lelistA (a:A) : list A -> Prop := - | nil_leA : lelistA a nil - | cons_leA : forall (b:A) (l:list A), leA a b -> lelistA a (b :: l). - - Lemma lelistA_inv : forall (a b:A) (l:list A), lelistA a (b :: l) -> leA a b. - Proof. - intros; inversion H; trivial with datatypes. - Qed. - - (** * Definition for a list to be sorted *) - - Inductive sort : list A -> Prop := - | nil_sort : sort nil - | cons_sort : - forall (a:A) (l:list A), sort l -> lelistA a l -> sort (a :: l). - - Lemma sort_inv : - forall (a:A) (l:list A), sort (a :: l) -> sort l /\ lelistA a l. - Proof. - intros; inversion H; auto with datatypes. - Qed. - - Lemma sort_rect : - forall P:list A -> Type, - P nil -> - (forall (a:A) (l:list A), sort l -> P l -> lelistA a l -> P (a :: l)) -> - forall y:list A, sort y -> P y. - Proof. - simple induction y; auto with datatypes. - intros; elim (sort_inv (a:=a) (l:=l)); auto with datatypes. - Qed. - - Lemma sort_rec : - forall P:list A -> Set, - P nil -> - (forall (a:A) (l:list A), sort l -> P l -> lelistA a l -> P (a :: l)) -> - forall y:list A, sort y -> P y. - Proof. - simple induction y; auto with datatypes. - intros; elim (sort_inv (a:=a) (l:=l)); auto with datatypes. - Qed. - - (** * Merging two sorted lists *) - - Inductive merge_lem (l1 l2:list A) : Type := - merge_exist : - forall l:list A, - sort l -> - meq (list_contents _ eqA_dec l) - (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) -> - (forall a:A, lelistA a l1 -> lelistA a l2 -> lelistA a l) -> - merge_lem l1 l2. - - Lemma merge : - forall l1:list A, sort l1 -> forall l2:list A, sort l2 -> merge_lem l1 l2. - Proof. - simple induction 1; intros. - apply merge_exist with l2; auto with datatypes. - elim H2; intros. - apply merge_exist with (a :: l); simpl in |- *; auto using cons_sort with datatypes. - elim (leA_dec a a0); intros. - - (* 1 (leA a a0) *) - cut (merge_lem l (a0 :: l0)); auto using cons_sort with datatypes. - intros [l3 l3sorted l3contents Hrec]. - apply merge_exist with (a :: l3); simpl in |- *; - auto using cons_sort, cons_leA with datatypes. - apply meq_trans with - (munion (singletonBag a) - (munion (list_contents _ eqA_dec l) - (list_contents _ eqA_dec (a0 :: l0)))). - apply meq_right; trivial with datatypes. - apply meq_sym; apply munion_ass. - intros; apply cons_leA. - apply lelistA_inv with l; trivial with datatypes. - - (* 2 (leA a0 a) *) - elim X0; simpl in |- *; intros. - apply merge_exist with (a0 :: l3); simpl in |- *; - auto using cons_sort, cons_leA with datatypes. - apply meq_trans with - (munion (singletonBag a0) - (munion (munion (singletonBag a) (list_contents _ eqA_dec l)) - (list_contents _ eqA_dec l0))). - apply meq_right; trivial with datatypes. - apply munion_perm_left. - intros; apply cons_leA; apply lelistA_inv with l0; trivial with datatypes. - Qed. - -End defs. - -Unset Implicit Arguments. -Hint Constructors sort: datatypes v62. -Hint Constructors lelistA: datatypes v62. +Require Export Sorted. +Require Export Mergesort. diff --git a/theories/Sorting/vo.itarget b/theories/Sorting/vo.itarget new file mode 100644 index 00000000..079eaad1 --- /dev/null +++ b/theories/Sorting/vo.itarget @@ -0,0 +1,7 @@ +Heap.vo +Permutation.vo +PermutSetoid.vo +PermutEq.vo +Sorted.vo +Sorting.vo +Mergesort.vo diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 1c02be7f..9e760d21 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* bool) (a : ascii) := - match a with - | Ascii a1 a2 a3 a4 a5 a6 a7 a8 => - Ascii (f a1) (f a2) (f a3) (f a4) (f a5) (f a6) (f a7) (f a8) - end. - -Definition app2 (f : bool -> bool -> bool) (a b : ascii) := - match a, b with - | Ascii a1 a2 a3 a4 a5 a6 a7 a8, Ascii b1 b2 b3 b4 b5 b6 b7 b8 => - Ascii (f a1 b1) (f a2 b2) (f a3 b3) (f a4 b4) - (f a5 b5) (f a6 b6) (f a7 b7) (f a8 b8) - end. Definition shift (c : bool) (a : ascii) := match a with @@ -46,7 +34,7 @@ Definition shift (c : bool) (a : ascii) := end. (** Definition of a decidable function that is effective *) - + Definition ascii_dec : forall a b : ascii, {a = b} + {a <> b}. decide equality; apply bool_dec. Defined. @@ -54,60 +42,85 @@ Defined. (** * Conversion between natural numbers modulo 256 and ascii characters *) (** Auxillary function that turns a positive into an ascii by - looking at the last n bits, ie z mod 2^n *) - -Fixpoint ascii_of_pos_aux (res acc : ascii) (z : positive) - (n : nat) {struct n} : ascii := + looking at the last 8 bits, ie z mod 2^8 *) + +Definition ascii_of_pos : positive -> ascii := + let loop := fix loop n p := + match n with + | O => zero + | S n' => + match p with + | xH => one + | xI p' => shift true (loop n' p') + | xO p' => shift false (loop n' p') + end + end + in loop 8. + +(** Conversion from [N] to [ascii] *) + +Definition ascii_of_N (n : N) := match n with - | O => res - | S n1 => - match z with - | xH => app2 orb res acc - | xI z' => ascii_of_pos_aux (app2 orb res acc) (shift false acc) z' n1 - | xO z' => ascii_of_pos_aux res (shift false acc) z' n1 - end + | N0 => zero + | Npos p => ascii_of_pos p end. +(** Same for [nat] *) -(** Function that turns a positive into an ascii by - looking at the last 8 bits, ie a mod 8 *) - -Definition ascii_of_pos (a : positive) := ascii_of_pos_aux zero one a 8. +Definition ascii_of_nat (a : nat) := ascii_of_N (N_of_nat a). -(** Function that turns a Peano number into an ascii by converting it - to positive *) +(** The opposite functions *) -Definition ascii_of_nat (a : nat) := - match a with - | O => zero - | S a' => ascii_of_pos (P_of_succ_nat a') - end. - -(** The opposite function *) - -Definition nat_of_ascii (a : ascii) : nat := - let (a1, a2, a3, a4, a5, a6, a7, a8) := a in - 2 * - (2 * - (2 * - (2 * - (2 * - (2 * - (2 * (if a8 then 1 else 0) - + (if a7 then 1 else 0)) - + (if a6 then 1 else 0)) - + (if a5 then 1 else 0)) - + (if a4 then 1 else 0)) - + (if a3 then 1 else 0)) - + (if a2 then 1 else 0)) - + (if a1 then 1 else 0). - -Theorem ascii_nat_embedding : +Local Open Scope list_scope. + +Fixpoint N_of_digits (l:list bool) : N := + match l with + | nil => 0 + | b :: l' => (if b then 1 else 0) + 2*(N_of_digits l') + end%N. + +Definition N_of_ascii (a : ascii) : N := + let (a0,a1,a2,a3,a4,a5,a6,a7) := a in + N_of_digits (a0::a1::a2::a3::a4::a5::a6::a7::nil). + +Definition nat_of_ascii (a : ascii) : nat := nat_of_N (N_of_ascii a). + +(** Proofs that we have indeed opposite function (below 256) *) + +Theorem ascii_N_embedding : + forall a : ascii, ascii_of_N (N_of_ascii a) = a. +Proof. + destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity. +Qed. + +Theorem N_ascii_embedding : + forall n:N, (n < 256)%N -> N_of_ascii (ascii_of_N n) = n. +Proof. +destruct n. +reflexivity. +do 8 (destruct p; [ | | intros; vm_compute; reflexivity ]); + intro H; vm_compute in H; destruct p; discriminate. +Qed. + +Theorem ascii_nat_embedding : forall a : ascii, ascii_of_nat (nat_of_ascii a) = a. Proof. destruct a as [[|][|][|][|][|][|][|][|]]; compute; reflexivity. Qed. +Theorem nat_ascii_embedding : + forall n : nat, n < 256 -> nat_of_ascii (ascii_of_nat n) = n. +Proof. + intros. unfold nat_of_ascii, ascii_of_nat. + rewrite N_ascii_embedding. + apply nat_of_N_of_nat. + unfold Nlt. + change 256%N with (N_of_nat 256). + rewrite <- N_of_nat_compare. + rewrite <- Compare_dec.nat_compare_lt. auto. +Qed. + + (** * Concrete syntax *) (** @@ -123,7 +136,7 @@ Qed. Notice that the ascii characters of code >= 128 do not denote stand-alone utf8 characters so that only the notation "nnn" is available for them (unless your terminal is able to represent them, - which is typically not the case in coqide). + which is typically not the case in coqide). *) Open Local Scope char_scope. diff --git a/theories/Strings/String.v b/theories/Strings/String.v index 00f28a9c..15f29821 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* string -> string. @@ -36,7 +38,7 @@ Defined. Reserved Notation "x ++ y" (right associativity, at level 60). -Fixpoint append (s1 s2 : string) {struct s1} : string := +Fixpoint append (s1 s2 : string) : string := match s1 with | EmptyString => s2 | String c s1' => String c (s1' ++ s2) @@ -47,7 +49,7 @@ where "s1 ++ s2" := (append s1 s2) : string_scope. (******************************) (** Length *) (******************************) - + Fixpoint length (s : string) : nat := match s with | EmptyString => 0 @@ -57,7 +59,7 @@ Fixpoint length (s : string) : nat := (******************************) (** Nth character of a string *) (******************************) - + Fixpoint get (n : nat) (s : string) {struct s} : option ascii := match s with | EmptyString => None @@ -68,7 +70,7 @@ Fixpoint get (n : nat) (s : string) {struct s} : option ascii := end. (** Two lists that are identical through get are syntactically equal *) - + Theorem get_correct : forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2. Proof. @@ -89,7 +91,7 @@ rewrite H1; auto. Qed. (** The first elements of [s1 ++ s2] are the ones of [s1] *) - + Theorem append_correct1 : forall (s1 s2 : string) (n : nat), n < length s1 -> get n s1 = get n (s1 ++ s2). @@ -102,7 +104,7 @@ apply lt_S_n; auto. Qed. (** The last elements of [s1 ++ s2] are the ones of [s2] *) - + Theorem append_correct2 : forall (s1 s2 : string) (n : nat), get n s2 = get (n + length s1) (s1 ++ s2). @@ -119,8 +121,8 @@ Qed. (** [substring n m s] returns the substring of [s] that starts at position [n] and of length [m]; if this does not make sense it returns [""] *) - -Fixpoint substring (n m : nat) (s : string) {struct s} : string := + +Fixpoint substring (n m : nat) (s : string) : string := match n, m, s with | 0, 0, _ => EmptyString | 0, S m', EmptyString => s @@ -130,7 +132,7 @@ Fixpoint substring (n m : nat) (s : string) {struct s} : string := end. (** The substring is included in the initial string *) - + Theorem substring_correct1 : forall (s : string) (n m p : nat), p < m -> get p (substring n m s) = get (p + n) s. @@ -148,7 +150,7 @@ intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl in |- *; auto. Qed. (** The substring has at most [m] elements *) - + Theorem substring_correct2 : forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None. Proof. @@ -166,7 +168,7 @@ Qed. (** *** Test functions *) (** Test if [s1] is a prefix of [s2] *) - + Fixpoint prefix (s1 s2 : string) {struct s2} : bool := match s1 with | EmptyString => true @@ -183,7 +185,7 @@ Fixpoint prefix (s1 s2 : string) {struct s2} : bool := (** If [s1] is a prefix of [s2], it is the [substring] of length [length s1] starting at position [O] of [s2] *) - + Theorem prefix_correct : forall s1 s2 : string, prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1. @@ -202,8 +204,8 @@ Qed. (** Test if, starting at position [n], [s1] occurs in [s2]; if so it returns the position *) - -Fixpoint index (n : nat) (s1 s2 : string) {struct s2} : option nat := + +Fixpoint index (n : nat) (s1 s2 : string) : option nat := match s2, n with | EmptyString, 0 => match s1 with @@ -211,7 +213,7 @@ Fixpoint index (n : nat) (s1 s2 : string) {struct s2} : option nat := | String a s1' => None end | EmptyString, S n' => None - | String b s2', 0 => + | String b s2', 0 => if prefix s1 s2 then Some 0 else match index 0 s1 s2' with @@ -229,7 +231,7 @@ Fixpoint index (n : nat) (s1 s2 : string) {struct s2} : option nat := Opaque prefix. (** If the result of [index] is [Some m], [s1] in [s2] at position [m] *) - + Theorem index_correct1 : forall (n m : nat) (s1 s2 : string), index n s1 s2 = Some m -> substring m (length s1) s2 = s1. @@ -259,9 +261,9 @@ intros x H H1; apply H; injection H1; intros H2; injection H2; auto. intros; discriminate. Qed. -(** If the result of [index] is [Some m], +(** If the result of [index] is [Some m], [s1] does not occur in [s2] before [m] *) - + Theorem index_correct2 : forall (n m : nat) (s1 s2 : string), index n s1 s2 = Some m -> @@ -304,9 +306,9 @@ apply Lt.lt_S_n; auto. intros; discriminate. Qed. -(** If the result of [index] is [None], [s1] does not occur in [s2] +(** If the result of [index] is [None], [s1] does not occur in [s2] after [n] *) - + Theorem index_correct3 : forall (n m : nat) (s1 s2 : string), index n s1 s2 = None -> @@ -348,7 +350,7 @@ Transparent prefix. (** If we are searching for the [Empty] string and the answer is no this means that [n] is greater than the size of [s] *) - + Theorem index_correct4 : forall (n : nat) (s : string), index n EmptyString s = None -> length s < n. @@ -367,7 +369,7 @@ Qed. (** Same as [index] but with no optional type, we return [0] when it does not occur *) - + Definition findex n s1 s2 := match index n s1 s2 with | Some n => n diff --git a/theories/Strings/vo.itarget b/theories/Strings/vo.itarget new file mode 100644 index 00000000..20813b42 --- /dev/null +++ b/theories/Strings/vo.itarget @@ -0,0 +1,2 @@ +Ascii.vo +String.vo diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v new file mode 100644 index 00000000..2c72e30b --- /dev/null +++ b/theories/Structures/DecidableType.v @@ -0,0 +1,156 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* split. + + (* eqke is stricter than eqk *) + + Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. + Proof. + unfold eqk, eqke; intuition. + Qed. + + (* eqk, eqke are equalities *) + + Lemma eqk_refl : forall e, eqk e e. + Proof. auto. Qed. + + Lemma eqke_refl : forall e, eqke e e. + Proof. auto. Qed. + + Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. + Proof. auto. Qed. + + Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. + Proof. unfold eqke; intuition. Qed. + + Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. + Proof. eauto. Qed. + + Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. + Proof. + unfold eqke; intuition; [ eauto | congruence ]. + Qed. + + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. + Hint Immediate eqk_sym eqke_sym. + + Global Instance eqk_equiv : Equivalence eqk. + Proof. split; eauto. Qed. + + Global Instance eqke_equiv : Equivalence eqke. + Proof. split; eauto. Qed. + + Lemma InA_eqke_eqk : + forall x m, InA eqke x m -> InA eqk x m. + Proof. + unfold eqke; induction 1; intuition. + Qed. + 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 *. + Qed. + + Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). + Definition In k m := exists e:elt, MapsTo k e m. + + Hint Unfold MapsTo In. + + (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) + + Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. + Proof. + firstorder. + exists x; auto. + induction H. + destruct y. + exists e; auto. + destruct IHInA as [e H0]. + exists e; auto. + Qed. + + Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. + Proof. + intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. + Qed. + + Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. + Proof. + destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. + Qed. + + Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. + Proof. + inversion 1. + inversion_clear H0; eauto. + destruct H1; simpl in *; intuition. + Qed. + + Lemma In_inv_2 : forall k k' e e' l, + InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. + Proof. + inversion_clear 1; compute in H0; intuition. + Qed. + + Lemma In_inv_3 : forall x x' l, + InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. + Proof. + inversion_clear 1; compute in H0; intuition. + Qed. + + End Elt. + + Hint Unfold eqk eqke. + Hint Extern 2 (eqke ?a ?b) => split. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. + Hint Immediate eqk_sym eqke_sym. + Hint Resolve InA_eqke_eqk. + Hint Unfold MapsTo In. + Hint Resolve In_inv_2 In_inv_3. + +End KeyDecidableType. + + + + + diff --git a/theories/Structures/DecidableTypeEx.v b/theories/Structures/DecidableTypeEx.v new file mode 100644 index 00000000..4407ead4 --- /dev/null +++ b/theories/Structures/DecidableTypeEx.v @@ -0,0 +1,96 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* eq y x. + Proof. + intros (x1,x2) (y1,y2); unfold eq; simpl; intuition. + Qed. + + Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. + Proof. + intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto. + Qed. + + Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. + Proof. + intros (x1,x2) (y1,y2); unfold eq; simpl. + destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); intuition. + Defined. + +End PairDecidableType. + +(** Similarly for pairs of UsualDecidableType *) + +Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. + Definition t := prod D1.t D2.t. + Definition eq := @eq t. + Definition eq_refl := @refl_equal t. + Definition eq_sym := @sym_eq t. + Definition eq_trans := @trans_eq t. + Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. + Proof. + intros (x1,x2) (y1,y2); + destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); + unfold eq, D1.eq, D2.eq in *; simpl; + (left; f_equal; auto; fail) || + (right; intro H; injection H; auto). + Defined. + +End PairUsualDecidableType. diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v new file mode 100644 index 00000000..487b1d0c --- /dev/null +++ b/theories/Structures/Equalities.v @@ -0,0 +1,218 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> Prop. +End HasEq. + +Module Type Eq := Typ <+ HasEq. + +Module Type EqNotation (Import E:Eq). + Infix "==" := eq (at level 70, no associativity). + Notation "x ~= y" := (~eq x y) (at level 70, no associativity). +End EqNotation. + +Module Type Eq' := Eq <+ EqNotation. + +(** * Specification of the equality via the [Equivalence] type class *) + +Module Type IsEq (Import E:Eq). + Declare Instance eq_equiv : Equivalence eq. +End IsEq. + +(** * Earlier specification of equality by three separate lemmas. *) + +Module Type IsEqOrig (Import E:Eq'). + Axiom eq_refl : forall x : t, x==x. + Axiom eq_sym : forall x y : t, x==y -> y==x. + Axiom eq_trans : forall x y z : t, x==y -> y==z -> x==z. + Hint Immediate eq_sym. + Hint Resolve eq_refl eq_trans. +End IsEqOrig. + +(** * Types with decidable equality *) + +Module Type HasEqDec (Import E:Eq'). + Parameter eq_dec : forall x y : t, { x==y } + { ~ x==y }. +End HasEqDec. + +(** * Boolean Equality *) + +(** Having [eq_dec] is the same as having a boolean equality plus + a correctness proof. *) + +Module Type HasEqBool (Import E:Eq'). + Parameter Inline eqb : t -> t -> bool. + Parameter eqb_eq : forall x y, eqb x y = true <-> x==y. +End HasEqBool. + +(** From these basic blocks, we can build many combinations + of static standalone module types. *) + +Module Type EqualityType := Eq <+ IsEq. + +Module Type EqualityTypeOrig := Eq <+ IsEqOrig. + +Module Type EqualityTypeBoth <: EqualityType <: EqualityTypeOrig + := Eq <+ IsEq <+ IsEqOrig. + +Module Type DecidableType <: EqualityType + := Eq <+ IsEq <+ HasEqDec. + +Module Type DecidableTypeOrig <: EqualityTypeOrig + := Eq <+ IsEqOrig <+ HasEqDec. + +Module Type DecidableTypeBoth <: DecidableType <: DecidableTypeOrig + := EqualityTypeBoth <+ HasEqDec. + +Module Type BooleanEqualityType <: EqualityType + := Eq <+ IsEq <+ HasEqBool. + +Module Type BooleanDecidableType <: DecidableType <: BooleanEqualityType + := Eq <+ IsEq <+ HasEqDec <+ HasEqBool. + +Module Type DecidableTypeFull <: DecidableTypeBoth <: BooleanDecidableType + := Eq <+ IsEq <+ IsEqOrig <+ HasEqDec <+ HasEqBool. + +(** Same, with notation for [eq] *) + +Module Type EqualityType' := EqualityType <+ EqNotation. +Module Type EqualityTypeOrig' := EqualityTypeOrig <+ EqNotation. +Module Type EqualityTypeBoth' := EqualityTypeBoth <+ EqNotation. +Module Type DecidableType' := DecidableType <+ EqNotation. +Module Type DecidableTypeOrig' := DecidableTypeOrig <+ EqNotation. +Module Type DecidableTypeBoth' := DecidableTypeBoth <+ EqNotation. +Module Type BooleanEqualityType' := BooleanEqualityType <+ EqNotation. +Module Type BooleanDecidableType' := BooleanDecidableType <+ EqNotation. +Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation. + +(** * Compatibility wrapper from/to the old version of + [EqualityType] and [DecidableType] *) + +Module BackportEq (E:Eq)(F:IsEq E) <: IsEqOrig E. + Definition eq_refl := @Equivalence_Reflexive _ _ F.eq_equiv. + Definition eq_sym := @Equivalence_Symmetric _ _ F.eq_equiv. + Definition eq_trans := @Equivalence_Transitive _ _ F.eq_equiv. +End BackportEq. + +Module UpdateEq (E:Eq)(F:IsEqOrig E) <: IsEq E. + Instance eq_equiv : Equivalence E.eq. + Proof. exact (Build_Equivalence _ _ F.eq_refl F.eq_sym F.eq_trans). Qed. +End UpdateEq. + +Module Backport_ET (E:EqualityType) <: EqualityTypeBoth + := E <+ BackportEq. + +Module Update_ET (E:EqualityTypeOrig) <: EqualityTypeBoth + := E <+ UpdateEq. + +Module Backport_DT (E:DecidableType) <: DecidableTypeBoth + := E <+ BackportEq. + +Module Update_DT (E:DecidableTypeOrig) <: DecidableTypeBoth + := E <+ UpdateEq. + + +(** * Having [eq_dec] is equivalent to having [eqb] and its spec. *) + +Module HasEqDec2Bool (E:Eq)(F:HasEqDec E) <: HasEqBool E. + Definition eqb x y := if F.eq_dec x y then true else false. + Lemma eqb_eq : forall x y, eqb x y = true <-> E.eq x y. + Proof. + intros x y. unfold eqb. destruct F.eq_dec as [EQ|NEQ]. + auto with *. + split. discriminate. intro EQ; elim NEQ; auto. + Qed. +End HasEqDec2Bool. + +Module HasEqBool2Dec (E:Eq)(F:HasEqBool E) <: HasEqDec E. + Lemma eq_dec : forall x y, {E.eq x y}+{~E.eq x y}. + Proof. + intros x y. assert (H:=F.eqb_eq x y). + destruct (F.eqb x y); [left|right]. + apply -> H; auto. + intro EQ. apply H in EQ. discriminate. + Defined. +End HasEqBool2Dec. + +Module Dec2Bool (E:DecidableType) <: BooleanDecidableType + := E <+ HasEqDec2Bool. + +Module Bool2Dec (E:BooleanEqualityType) <: BooleanDecidableType + := E <+ HasEqBool2Dec. + + + +(** * UsualDecidableType + + A particular case of [DecidableType] where the equality is + the usual one of Coq. *) + +Module Type HasUsualEq (Import T:Typ) <: HasEq T. + Definition eq := @Logic.eq t. +End HasUsualEq. + +Module Type UsualEq <: Eq := Typ <+ HasUsualEq. + +Module Type UsualIsEq (E:UsualEq) <: IsEq E. + (* No Instance syntax to avoid saturating the Equivalence tables *) + Lemma eq_equiv : Equivalence E.eq. + Proof. exact eq_equivalence. Qed. +End UsualIsEq. + +Module Type UsualIsEqOrig (E:UsualEq) <: IsEqOrig E. + Definition eq_refl := @Logic.eq_refl E.t. + Definition eq_sym := @Logic.eq_sym E.t. + Definition eq_trans := @Logic.eq_trans E.t. +End UsualIsEqOrig. + +Module Type UsualEqualityType <: EqualityType + := UsualEq <+ UsualIsEq. + +Module Type UsualDecidableType <: DecidableType + := UsualEq <+ UsualIsEq <+ HasEqDec. + +Module Type UsualDecidableTypeOrig <: DecidableTypeOrig + := UsualEq <+ UsualIsEqOrig <+ HasEqDec. + +Module Type UsualDecidableTypeBoth <: DecidableTypeBoth + := UsualEq <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqDec. + +Module Type UsualBoolEq := UsualEq <+ HasEqBool. + +Module Type UsualDecidableTypeFull <: DecidableTypeFull + := UsualEq <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqDec <+ HasEqBool. + + +(** Some shortcuts for easily building a [UsualDecidableType] *) + +Module Type MiniDecidableType. + Include Typ. + Parameter eq_dec : forall x y : t, {x=y}+{~x=y}. +End MiniDecidableType. + +Module Make_UDT (M:MiniDecidableType) <: UsualDecidableTypeBoth + := M <+ HasUsualEq <+ UsualIsEq <+ UsualIsEqOrig. + +Module Make_UDTF (M:UsualBoolEq) <: UsualDecidableTypeFull + := M <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqBool2Dec. diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v new file mode 100644 index 00000000..d9b1d76f --- /dev/null +++ b/theories/Structures/EqualitiesFacts.v @@ -0,0 +1,185 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* E.eq ==> Logic.eq) eqb. +Proof. +intros x x' Exx' y y' Eyy'. +apply eq_true_iff_eq. +rewrite 2 eqb_eq, Exx', Eyy'; auto with *. +Qed. + +End BoolEqualityFacts. + + +(** * Keys and datas used in FMap *) +Module KeyDecidableType(Import D:DecidableType). + + Section Elt. + Variable elt : Type. + Notation key:=t. + + Local Open Scope signature_scope. + + Definition eqk : relation (key*elt) := eq @@1. + Definition eqke : relation (key*elt) := eq * Logic.eq. + Hint Unfold eqk eqke. + + (* eqke is stricter than eqk *) + + Global Instance eqke_eqk : subrelation eqke eqk. + Proof. firstorder. Qed. + + (* eqk, eqke are equalities, ltk is a strict order *) + + Global Instance eqk_equiv : Equivalence eqk. + + Global Instance eqke_equiv : Equivalence eqke. + + (* Additionnal facts *) + + Lemma InA_eqke_eqk : + forall x m, InA eqke x m -> InA eqk x m. + Proof. + unfold eqke, RelProd; induction 1; firstorder. + 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. rewrite <- H; auto. + Qed. + + Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). + Definition In k m := exists e:elt, MapsTo k e m. + + Hint Unfold MapsTo In. + + (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) + + Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. + Proof. + firstorder. + exists x; auto. + induction H. + destruct y; compute in H. + exists e; left; auto. + destruct IHInA as [e H0]. + exists e; auto. + Qed. + + Lemma In_alt2 : forall k l, In k l <-> Exists (fun p => eq k (fst p)) l. + Proof. + unfold In, MapsTo. + setoid_rewrite Exists_exists; setoid_rewrite InA_alt. + firstorder. + exists (snd x), x; auto. + Qed. + + Lemma In_nil : forall k, In k nil <-> False. + Proof. + intros; rewrite In_alt2; apply Exists_nil. + Qed. + + Lemma In_cons : forall k p l, + In k (p::l) <-> eq k (fst p) \/ In k l. + Proof. + intros; rewrite !In_alt2, Exists_cons; intuition. + Qed. + + Global Instance MapsTo_compat : + Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo. + Proof. + intros x x' Hx e e' He l l' Hl. unfold MapsTo. + rewrite Hx, He, Hl; intuition. + Qed. + + Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In. + Proof. + intros x x' Hx l l' Hl. rewrite !In_alt. + setoid_rewrite Hl. setoid_rewrite Hx. intuition. + Qed. + + Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. + Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed. + + Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. + Proof. intros l x y EQ. rewrite <- EQ; auto. Qed. + + Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. + Proof. + intros; invlist In; invlist MapsTo. compute in * |- ; intuition. + right; exists x; auto. + Qed. + + Lemma In_inv_2 : forall k k' e e' l, + InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. + Proof. + intros; invlist InA; intuition. + Qed. + + Lemma In_inv_3 : forall x x' l, + InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. + Proof. + intros; invlist InA; compute in * |- ; intuition. + Qed. + + End Elt. + + Hint Unfold eqk eqke. + Hint Extern 2 (eqke ?a ?b) => split. + Hint Resolve InA_eqke_eqk. + Hint Unfold MapsTo In. + Hint Resolve In_inv_2 In_inv_3. + +End KeyDecidableType. + + +(** * PairDecidableType + + From two decidable types, we can build a new DecidableType + over their cartesian product. *) + +Module PairDecidableType(D1 D2:DecidableType) <: DecidableType. + + Definition t := (D1.t * D2.t)%type. + + Definition eq := (D1.eq * D2.eq)%signature. + + Instance eq_equiv : Equivalence eq. + + Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. + Proof. + intros (x1,x2) (y1,y2); unfold eq; simpl. + destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); + compute; intuition. + Defined. + +End PairDecidableType. + +(** Similarly for pairs of UsualDecidableType *) + +Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. + Definition t := (D1.t * D2.t)%type. + Definition eq := @eq t. + Program Instance eq_equiv : Equivalence eq. + Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. + Proof. + intros (x1,x2) (y1,y2); + destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); + unfold eq, D1.eq, D2.eq in *; simpl; + (left; f_equal; auto; fail) || + (right; intro H; injection H; auto). + Defined. + +End PairUsualDecidableType. diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v new file mode 100644 index 00000000..68f20189 --- /dev/null +++ b/theories/Structures/GenericMinMax.v @@ -0,0 +1,656 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> t. + Parameter max_l : forall x y, y<=x -> max x y == x. + Parameter max_r : forall x y, x<=y -> max x y == y. +End HasMax. + +Module Type HasMin (Import E:EqLe'). + Parameter Inline min : t -> t -> t. + Parameter min_l : forall x y, x<=y -> min x y == x. + Parameter min_r : forall x y, y<=x -> min x y == y. +End HasMin. + +Module Type HasMinMax (E:EqLe) := HasMax E <+ HasMin E. + + +(** ** Any [OrderedTypeFull] can be equipped by [max] and [min] + based on the compare function. *) + +Definition gmax {A} (cmp : A->A->comparison) x y := + match cmp x y with Lt => y | _ => x end. +Definition gmin {A} (cmp : A->A->comparison) x y := + match cmp x y with Gt => y | _ => x end. + +Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O. + + Definition max := gmax O.compare. + Definition min := gmin O.compare. + + Lemma ge_not_lt : forall x y, y<=x -> x False. + Proof. + intros x y H H'. + apply (StrictOrder_Irreflexive x). + rewrite le_lteq in *; destruct H as [H|H]. + transitivity y; auto. + rewrite H in H'; auto. + Qed. + + Lemma max_l : forall x y, y<=x -> max x y == x. + Proof. + intros. unfold max, gmax. case compare_spec; auto with relations. + intros; elim (ge_not_lt x y); auto. + Qed. + + Lemma max_r : forall x y, x<=y -> max x y == y. + Proof. + intros. unfold max, gmax. case compare_spec; auto with relations. + intros; elim (ge_not_lt y x); auto. + Qed. + + Lemma min_l : forall x y, x<=y -> min x y == x. + Proof. + intros. unfold min, gmin. case compare_spec; auto with relations. + intros; elim (ge_not_lt y x); auto. + Qed. + + Lemma min_r : forall x y, y<=x -> min x y == y. + Proof. + intros. unfold min, gmin. case compare_spec; auto with relations. + intros; elim (ge_not_lt x y); auto. + Qed. + +End GenericMinMax. + + +(** ** Consequences of the minimalist interface: facts about [max]. *) + +Module MaxLogicalProperties (Import O:TotalOrder')(Import M:HasMax O). + Module Import T := !MakeOrderTac O. + +(** An alternative caracterisation of [max], equivalent to + [max_l /\ max_r] *) + +Lemma max_spec : forall n m, + (n < m /\ max n m == m) \/ (m <= n /\ max n m == n). +Proof. + intros n m. + destruct (lt_total n m); [left|right]. + split; auto. apply max_r. rewrite le_lteq; auto. + assert (m <= n) by (rewrite le_lteq; intuition). + split; auto. apply max_l; auto. +Qed. + +(** A more symmetric version of [max_spec], based only on [le]. + Beware that left and right alternatives overlap. *) + +Lemma max_spec_le : forall n m, + (n <= m /\ max n m == m) \/ (m <= n /\ max n m == n). +Proof. + intros. destruct (max_spec n m); [left|right]; intuition; order. +Qed. + +Instance : Proper (eq==>eq==>iff) le. +Proof. repeat red. intuition order. Qed. + +Instance max_compat : Proper (eq==>eq==>eq) max. +Proof. +intros x x' Hx y y' Hy. +assert (H1 := max_spec x y). assert (H2 := max_spec x' y'). +set (m := max x y) in *; set (m' := max x' y') in *; clearbody m m'. +rewrite <- Hx, <- Hy in *. +destruct (lt_total x y); intuition order. +Qed. + + +(** A function satisfying the same specification is equal to [max]. *) + +Lemma max_unicity : forall n m p, + ((n < m /\ p == m) \/ (m <= n /\ p == n)) -> p == max n m. +Proof. + intros. assert (Hm := max_spec n m). + destruct (lt_total n m); intuition; order. +Qed. + +Lemma max_unicity_ext : forall f, + (forall n m, (n < m /\ f n m == m) \/ (m <= n /\ f n m == n)) -> + (forall n m, f n m == max n m). +Proof. + intros. apply max_unicity; auto. +Qed. + +(** [max] commutes with monotone functions. *) + +Lemma max_mono: forall f, + (Proper (eq ==> eq) f) -> + (Proper (le ==> le) f) -> + forall x y, max (f x) (f y) == f (max x y). +Proof. + intros f Eqf Lef x y. + destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; + destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. + assert (f x <= f y) by (apply Lef; order). order. + assert (f y <= f x) by (apply Lef; order). order. +Qed. + +(** *** Semi-lattice algebraic properties of [max] *) + +Lemma max_id : forall n, max n n == n. +Proof. + intros. destruct (max_spec n n); intuition. +Qed. + +Notation max_idempotent := max_id (only parsing). + +Lemma max_assoc : forall m n p, max m (max n p) == max (max m n) p. +Proof. + intros. + destruct (max_spec n p) as [(H,Eq)|(H,Eq)]; rewrite Eq. + destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'. + destruct (max_spec m p); intuition; order. order. + destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'. order. + destruct (max_spec m p); intuition; order. +Qed. + +Lemma max_comm : forall n m, max n m == max m n. +Proof. + intros. + destruct (max_spec n m) as [(H,Eq)|(H,Eq)]; rewrite Eq. + destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'; order. + destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'; order. +Qed. + +(** *** Least-upper bound properties of [max] *) + +Lemma le_max_l : forall n m, n <= max n m. +Proof. + intros; destruct (max_spec n m); intuition; order. +Qed. + +Lemma le_max_r : forall n m, m <= max n m. +Proof. + intros; destruct (max_spec n m); intuition; order. +Qed. + +Lemma max_l_iff : forall n m, max n m == n <-> m <= n. +Proof. + split. intro H; rewrite <- H. apply le_max_r. apply max_l. +Qed. + +Lemma max_r_iff : forall n m, max n m == m <-> n <= m. +Proof. + split. intro H; rewrite <- H. apply le_max_l. apply max_r. +Qed. + +Lemma max_le : forall n m p, p <= max n m -> p <= n \/ p <= m. +Proof. + intros n m p H; destruct (max_spec n m); + [right|left]; intuition; order. +Qed. + +Lemma max_le_iff : forall n m p, p <= max n m <-> p <= n \/ p <= m. +Proof. + intros. split. apply max_le. + destruct (max_spec n m); intuition; order. +Qed. + +Lemma max_lt_iff : forall n m p, p < max n m <-> p < n \/ p < m. +Proof. + intros. destruct (max_spec n m); intuition; + order || (right; order) || (left; order). +Qed. + +Lemma max_lub_l : forall n m p, max n m <= p -> n <= p. +Proof. + intros; destruct (max_spec n m); intuition; order. +Qed. + +Lemma max_lub_r : forall n m p, max n m <= p -> m <= p. +Proof. + intros; destruct (max_spec n m); intuition; order. +Qed. + +Lemma max_lub : forall n m p, n <= p -> m <= p -> max n m <= p. +Proof. + intros; destruct (max_spec n m); intuition; order. +Qed. + +Lemma max_lub_iff : forall n m p, max n m <= p <-> n <= p /\ m <= p. +Proof. + intros; destruct (max_spec n m); intuition; order. +Qed. + +Lemma max_lub_lt : forall n m p, n < p -> m < p -> max n m < p. +Proof. + intros; destruct (max_spec n m); intuition; order. +Qed. + +Lemma max_lub_lt_iff : forall n m p, max n m < p <-> n < p /\ m < p. +Proof. + intros; destruct (max_spec n m); intuition; order. +Qed. + +Lemma max_le_compat_l : forall n m p, n <= m -> max p n <= max p m. +Proof. + intros. + destruct (max_spec p n) as [(LT,E)|(LE,E)]; rewrite E. + assert (LE' := le_max_r p m). order. + apply le_max_l. +Qed. + +Lemma max_le_compat_r : forall n m p, n <= m -> max n p <= max m p. +Proof. + intros. rewrite (max_comm n p), (max_comm m p). + auto using max_le_compat_l. +Qed. + +Lemma max_le_compat : forall n m p q, n <= m -> p <= q -> + max n p <= max m q. +Proof. + intros n m p q Hnm Hpq. + assert (LE := max_le_compat_l _ _ m Hpq). + assert (LE' := max_le_compat_r _ _ p Hnm). + order. +Qed. + +End MaxLogicalProperties. + + +(** ** Properties concernant [min], then both [min] and [max]. + + To avoid too much code duplication, we exploit that [min] can be + seen as a [max] of the reversed order. +*) + +Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O). + Include MaxLogicalProperties O M. + Import T. + + Module ORev := TotalOrderRev O. + Module MRev <: HasMax ORev. + Definition max x y := M.min y x. + Definition max_l x y := M.min_r y x. + Definition max_r x y := M.min_l y x. + End MRev. + Module MPRev := MaxLogicalProperties ORev MRev. + +Instance min_compat : Proper (eq==>eq==>eq) min. +Proof. intros x x' Hx y y' Hy. apply MPRev.max_compat; assumption. Qed. + +Lemma min_spec : forall n m, + (n < m /\ min n m == n) \/ (m <= n /\ min n m == m). +Proof. intros. exact (MPRev.max_spec m n). Qed. + +Lemma min_spec_le : forall n m, + (n <= m /\ min n m == n) \/ (m <= n /\ min n m == m). +Proof. intros. exact (MPRev.max_spec_le m n). Qed. + +Lemma min_mono: forall f, + (Proper (eq ==> eq) f) -> + (Proper (le ==> le) f) -> + forall x y, min (f x) (f y) == f (min x y). +Proof. + intros. apply MPRev.max_mono; auto. compute in *; eauto. +Qed. + +Lemma min_unicity : forall n m p, + ((n < m /\ p == n) \/ (m <= n /\ p == m)) -> p == min n m. +Proof. intros n m p. apply MPRev.max_unicity. Qed. + +Lemma min_unicity_ext : forall f, + (forall n m, (n < m /\ f n m == n) \/ (m <= n /\ f n m == m)) -> + (forall n m, f n m == min n m). +Proof. intros f H n m. apply MPRev.max_unicity, H; auto. Qed. + +Lemma min_id : forall n, min n n == n. +Proof. intros. exact (MPRev.max_id n). Qed. + +Notation min_idempotent := min_id (only parsing). + +Lemma min_assoc : forall m n p, min m (min n p) == min (min m n) p. +Proof. intros. symmetry; apply MPRev.max_assoc. Qed. + +Lemma min_comm : forall n m, min n m == min m n. +Proof. intros. exact (MPRev.max_comm m n). Qed. + +Lemma le_min_r : forall n m, min n m <= m. +Proof. intros. exact (MPRev.le_max_l m n). Qed. + +Lemma le_min_l : forall n m, min n m <= n. +Proof. intros. exact (MPRev.le_max_r m n). Qed. + +Lemma min_l_iff : forall n m, min n m == n <-> n <= m. +Proof. intros n m. exact (MPRev.max_r_iff m n). Qed. + +Lemma min_r_iff : forall n m, min n m == m <-> m <= n. +Proof. intros n m. exact (MPRev.max_l_iff m n). Qed. + +Lemma min_le : forall n m p, min n m <= p -> n <= p \/ m <= p. +Proof. intros n m p H. destruct (MPRev.max_le _ _ _ H); auto. Qed. + +Lemma min_le_iff : forall n m p, min n m <= p <-> n <= p \/ m <= p. +Proof. intros n m p. rewrite (MPRev.max_le_iff m n p); intuition. Qed. + +Lemma min_lt_iff : forall n m p, min n m < p <-> n < p \/ m < p. +Proof. intros n m p. rewrite (MPRev.max_lt_iff m n p); intuition. Qed. + +Lemma min_glb_l : forall n m p, p <= min n m -> p <= n. +Proof. intros n m. exact (MPRev.max_lub_r m n). Qed. + +Lemma min_glb_r : forall n m p, p <= min n m -> p <= m. +Proof. intros n m. exact (MPRev.max_lub_l m n). Qed. + +Lemma min_glb : forall n m p, p <= n -> p <= m -> p <= min n m. +Proof. intros. apply MPRev.max_lub; auto. Qed. + +Lemma min_glb_iff : forall n m p, p <= min n m <-> p <= n /\ p <= m. +Proof. intros. rewrite (MPRev.max_lub_iff m n p); intuition. Qed. + +Lemma min_glb_lt : forall n m p, p < n -> p < m -> p < min n m. +Proof. intros. apply MPRev.max_lub_lt; auto. Qed. + +Lemma min_glb_lt_iff : forall n m p, p < min n m <-> p < n /\ p < m. +Proof. intros. rewrite (MPRev.max_lub_lt_iff m n p); intuition. Qed. + +Lemma min_le_compat_l : forall n m p, n <= m -> min p n <= min p m. +Proof. intros n m. exact (MPRev.max_le_compat_r m n). Qed. + +Lemma min_le_compat_r : forall n m p, n <= m -> min n p <= min m p. +Proof. intros n m. exact (MPRev.max_le_compat_l m n). Qed. + +Lemma min_le_compat : forall n m p q, n <= m -> p <= q -> + min n p <= min m q. +Proof. intros. apply MPRev.max_le_compat; auto. Qed. + + +(** *** Combined properties of min and max *) + +Lemma min_max_absorption : forall n m, max n (min n m) == n. +Proof. + intros. + destruct (min_spec n m) as [(C,E)|(C,E)]; rewrite E. + apply max_l. order. + destruct (max_spec n m); intuition; order. +Qed. + +Lemma max_min_absorption : forall n m, min n (max n m) == n. +Proof. + intros. + destruct (max_spec n m) as [(C,E)|(C,E)]; rewrite E. + destruct (min_spec n m) as [(C',E')|(C',E')]; auto. order. + apply min_l; auto. order. +Qed. + +(** Distributivity *) + +Lemma max_min_distr : forall n m p, + max n (min m p) == min (max n m) (max n p). +Proof. + intros. symmetry. apply min_mono. + eauto with *. + repeat red; intros. apply max_le_compat_l; auto. +Qed. + +Lemma min_max_distr : forall n m p, + min n (max m p) == max (min n m) (min n p). +Proof. + intros. symmetry. apply max_mono. + eauto with *. + repeat red; intros. apply min_le_compat_l; auto. +Qed. + +(** Modularity *) + +Lemma max_min_modular : forall n m p, + max n (min m (max n p)) == min (max n m) (max n p). +Proof. + intros. rewrite <- max_min_distr. + destruct (max_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *. + destruct (min_spec m n) as [(C',E')|(C',E')]; rewrite E'. + rewrite 2 max_l; try order. rewrite min_le_iff; auto. + rewrite 2 max_l; try order. rewrite min_le_iff; auto. +Qed. + +Lemma min_max_modular : forall n m p, + min n (max m (min n p)) == max (min n m) (min n p). +Proof. + intros. rewrite <- min_max_distr. + destruct (min_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *. + destruct (max_spec m n) as [(C',E')|(C',E')]; rewrite E'. + rewrite 2 min_l; try order. rewrite max_le_iff; right; order. + rewrite 2 min_l; try order. rewrite max_le_iff; auto. +Qed. + +(** Disassociativity *) + +Lemma max_min_disassoc : forall n m p, + min n (max m p) <= max (min n m) p. +Proof. + intros. rewrite min_max_distr. + auto using max_le_compat_l, le_min_r. +Qed. + +(** Anti-monotonicity swaps the role of [min] and [max] *) + +Lemma max_min_antimono : forall f, + Proper (eq==>eq) f -> + Proper (le==>inverse le) f -> + forall x y, max (f x) (f y) == f (min x y). +Proof. + intros f Eqf Lef x y. + destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; + destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. + assert (f y <= f x) by (apply Lef; order). order. + assert (f x <= f y) by (apply Lef; order). order. +Qed. + +Lemma min_max_antimono : forall f, + Proper (eq==>eq) f -> + Proper (le==>inverse le) f -> + forall x y, min (f x) (f y) == f (max x y). +Proof. + intros f Eqf Lef x y. + destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; + destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. + assert (f y <= f x) by (apply Lef; order). order. + assert (f x <= f y) by (apply Lef; order). order. +Qed. + +End MinMaxLogicalProperties. + + +(** ** Properties requiring a decidable order *) + +Module MinMaxDecProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O). + +(** Induction principles for [max]. *) + +Lemma max_case_strong : forall n m (P:t -> Type), + (forall x y, x==y -> P x -> P y) -> + (m<=n -> P n) -> (n<=m -> P m) -> P (max n m). +Proof. +intros n m P Compat Hl Hr. +destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. +assert (n<=m) by (rewrite le_lteq; auto). +apply (Compat m), Hr; auto. symmetry; apply max_r; auto. +assert (n<=m) by (rewrite le_lteq; auto). +apply (Compat m), Hr; auto. symmetry; apply max_r; auto. +assert (m<=n) by (rewrite le_lteq; auto). +apply (Compat n), Hl; auto. symmetry; apply max_l; auto. +Defined. + +Lemma max_case : forall n m (P:t -> Type), + (forall x y, x == y -> P x -> P y) -> + P n -> P m -> P (max n m). +Proof. intros. apply max_case_strong; auto. Defined. + +(** [max] returns one of its arguments. *) + +Lemma max_dec : forall n m, {max n m == n} + {max n m == m}. +Proof. + intros n m. apply max_case; auto with relations. + intros x y H [E|E]; [left|right]; rewrite <-H; auto. +Defined. + +(** Idem for [min] *) + +Lemma min_case_strong : forall n m (P:O.t -> Type), + (forall x y, x == y -> P x -> P y) -> + (n<=m -> P n) -> (m<=n -> P m) -> P (min n m). +Proof. +intros n m P Compat Hl Hr. +destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. +assert (n<=m) by (rewrite le_lteq; auto). +apply (Compat n), Hl; auto. symmetry; apply min_l; auto. +assert (n<=m) by (rewrite le_lteq; auto). +apply (Compat n), Hl; auto. symmetry; apply min_l; auto. +assert (m<=n) by (rewrite le_lteq; auto). +apply (Compat m), Hr; auto. symmetry; apply min_r; auto. +Defined. + +Lemma min_case : forall n m (P:O.t -> Type), + (forall x y, x == y -> P x -> P y) -> + P n -> P m -> P (min n m). +Proof. intros. apply min_case_strong; auto. Defined. + +Lemma min_dec : forall n m, {min n m == n} + {min n m == m}. +Proof. + intros. apply min_case; auto with relations. + intros x y H [E|E]; [left|right]; rewrite <- E; auto with relations. +Defined. + +End MinMaxDecProperties. + +Module MinMaxProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O). + Module OT := OTF_to_TotalOrder O. + Include MinMaxLogicalProperties OT M. + Include MinMaxDecProperties O M. + Definition max_l := max_l. + Definition max_r := max_r. + Definition min_l := min_l. + Definition min_r := min_r. + Notation max_monotone := max_mono. + Notation min_monotone := min_mono. + Notation max_min_antimonotone := max_min_antimono. + Notation min_max_antimonotone := min_max_antimono. +End MinMaxProperties. + + +(** ** When the equality is Leibniz, we can skip a few [Proper] precondition. *) + +Module UsualMinMaxLogicalProperties + (Import O:UsualTotalOrder')(Import M:HasMinMax O). + + Include MinMaxLogicalProperties O M. + + Lemma max_monotone : forall f, Proper (le ==> le) f -> + forall x y, max (f x) (f y) = f (max x y). + Proof. intros; apply max_mono; auto. congruence. Qed. + + Lemma min_monotone : forall f, Proper (le ==> le) f -> + forall x y, min (f x) (f y) = f (min x y). + Proof. intros; apply min_mono; auto. congruence. Qed. + + Lemma min_max_antimonotone : forall f, Proper (le ==> inverse 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 : forall f, Proper (le ==> inverse le) f -> + forall x y, max (f x) (f y) = f (min x y). + Proof. intros; apply max_min_antimono; auto. congruence. Qed. + +End UsualMinMaxLogicalProperties. + + +Module UsualMinMaxDecProperties + (Import O:UsualOrderedTypeFull')(Import M:HasMinMax O). + + Module P := MinMaxDecProperties O M. + + Lemma max_case_strong : forall n m (P:t -> Type), + (m<=n -> P n) -> (n<=m -> P m) -> P (max n m). + Proof. intros; apply P.max_case_strong; auto. congruence. Defined. + + Lemma max_case : forall n m (P:t -> Type), + P n -> P m -> P (max n m). + Proof. intros; apply max_case_strong; auto. Defined. + + Lemma max_dec : forall n m, {max n m = n} + {max n m = m}. + Proof. exact P.max_dec. Defined. + + Lemma min_case_strong : forall n m (P:O.t -> Type), + (n<=m -> P n) -> (m<=n -> P m) -> P (min n m). + Proof. intros; apply P.min_case_strong; auto. congruence. Defined. + + Lemma min_case : forall n m (P:O.t -> Type), + P n -> P m -> P (min n m). + Proof. intros. apply min_case_strong; auto. Defined. + + Lemma min_dec : forall n m, {min n m = n} + {min n m = m}. + Proof. exact P.min_dec. Defined. + +End UsualMinMaxDecProperties. + +Module UsualMinMaxProperties + (Import O:UsualOrderedTypeFull')(Import M:HasMinMax O). + Module OT := OTF_to_TotalOrder O. + Include UsualMinMaxLogicalProperties OT M. + Include UsualMinMaxDecProperties O M. + Definition max_l := max_l. + Definition max_r := max_r. + Definition min_l := min_l. + Definition min_r := min_r. +End UsualMinMaxProperties. + + +(** From [TotalOrder] and [HasMax] and [HasEqDec], we can prove + that the order is decidable and build an [OrderedTypeFull]. *) + +Module TOMaxEqDec_to_Compare + (Import O:TotalOrder')(Import M:HasMax O)(Import E:HasEqDec O) <: HasCompare O. + + Definition compare x y := + if eq_dec x y then Eq + else if eq_dec (M.max x y) y then Lt else Gt. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + intros; unfold compare; repeat destruct eq_dec; auto; constructor. + destruct (lt_total x y); auto. + absurd (x==y); auto. transitivity (max x y); auto. + symmetry. apply max_l. rewrite le_lteq; intuition. + destruct (lt_total y x); auto. + absurd (max x y == y); auto. apply max_r; rewrite le_lteq; intuition. + Qed. + +End TOMaxEqDec_to_Compare. + +Module TOMaxEqDec_to_OTF (O:TotalOrder)(M:HasMax O)(E:HasEqDec O) + <: OrderedTypeFull + := O <+ E <+ TOMaxEqDec_to_Compare O M E. + + + +(** TODO: Some Remaining questions... + +--> Compare with a type-classes version ? + +--> Is max_unicity and max_unicity_ext really convenient to express + that any possible definition of max will in fact be equivalent ? + +--> Is it possible to avoid copy-paste about min even more ? + +*) diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v new file mode 100644 index 00000000..72fbe796 --- /dev/null +++ b/theories/Structures/OrderedType.v @@ -0,0 +1,485 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* X -> Prop) (x y : X) : Type := + | LT : lt x y -> Compare lt eq x y + | EQ : eq x y -> Compare lt eq x y + | GT : lt y x -> Compare lt eq x y. + +Module Type MiniOrderedType. + + Parameter Inline t : Type. + + Parameter Inline eq : t -> t -> Prop. + Parameter Inline lt : t -> t -> Prop. + + Axiom eq_refl : forall x : t, eq x x. + Axiom eq_sym : forall x y : t, eq x y -> eq y x. + Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. + + Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. + Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. + + Parameter compare : forall x y : t, Compare lt eq x y. + + Hint Immediate eq_sym. + Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. + +End MiniOrderedType. + +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. *) + Parameter eq_dec : forall x y, { eq x y } + { ~ eq x y }. + +End OrderedType. + +Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. + Include O. + + Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. + Proof. + intros; elim (compare x y); intro H; [ right | left | right ]; auto. + assert (~ eq y x); auto. + Defined. + +End MOT_to_OT. + +(** * Ordered types properties *) + +(** Additional properties that can be derived from signature + [OrderedType]. *) + +Module OrderedTypeFacts (Import O: OrderedType). + + Instance eq_equiv : Equivalence eq. + Proof. split; [ exact eq_refl | exact eq_sym | exact eq_trans ]. Qed. + + Lemma lt_antirefl : forall x, ~ lt x x. + Proof. + intros; intro; absurd (eq x x); auto. + Qed. + + Instance lt_strorder : StrictOrder lt. + Proof. split; [ exact lt_antirefl | exact lt_trans]. Qed. + + Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. + Proof. + intros; destruct (compare x z); auto. + elim (lt_not_eq H); apply eq_trans with z; auto. + elim (lt_not_eq (lt_trans l 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. + elim (lt_not_eq H0); apply eq_trans with x; auto. + elim (lt_not_eq (lt_trans H0 l)); auto. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + intros x x' Hx y y' Hy H. + apply eq_lt with x; auto. + apply lt_eq with y; auto. + Qed. + + Lemma lt_total : forall x y, lt x y \/ eq x y \/ lt y x. + Proof. intros; destruct (compare x y); auto. Qed. + + Module OrderElts <: Orders.TotalOrder. + Definition t := t. + Definition eq := eq. + Definition lt := lt. + Definition le x y := lt x y \/ eq x y. + Definition eq_equiv := eq_equiv. + Definition lt_strorder := lt_strorder. + Definition lt_compat := lt_compat. + Definition lt_total := lt_total. + Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y. + Proof. unfold le; intuition. Qed. + End OrderElts. + Module OrderTac := !MakeOrderTac OrderElts. + Ltac order := OrderTac.order. + + Lemma le_eq x y z : ~lt x y -> eq y z -> ~lt x z. Proof. order. Qed. + Lemma eq_le x y z : eq x y -> ~lt y z -> ~lt x z. Proof. order. Qed. + Lemma neq_eq x y z : ~eq x y -> eq y z -> ~eq x z. Proof. order. Qed. + Lemma eq_neq x y z : eq x y -> ~eq y z -> ~eq x z. Proof. order. Qed. + Lemma le_lt_trans x y z : ~lt y x -> lt y z -> lt x z. Proof. order. Qed. + Lemma lt_le_trans x y z : lt x y -> ~lt z y -> lt x z. Proof. order. Qed. + Lemma le_neq x y : ~lt x y -> ~eq x y -> lt y x. Proof. order. Qed. + Lemma le_trans x y z : ~lt y x -> ~lt z y -> ~lt z x. Proof. order. Qed. + Lemma le_antisym x y : ~lt y x -> ~lt x y -> eq x y. Proof. order. Qed. + Lemma neq_sym x y : ~eq x y -> ~eq y x. Proof. order. Qed. + Lemma lt_le x y : lt x y -> ~lt y x. Proof. order. Qed. + Lemma gt_not_eq x y : lt y x -> ~ eq x y. Proof. order. Qed. + Lemma eq_not_lt x y : eq x y -> ~ lt x y. Proof. order. Qed. + Lemma eq_not_gt x y : eq x y -> ~ lt y x. Proof. order. Qed. + Lemma lt_not_gt x y : lt x y -> ~ lt y x. Proof. order. Qed. + + Hint Resolve gt_not_eq eq_not_lt. + Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq. + Hint Resolve eq_not_gt lt_antirefl lt_not_gt. + + Lemma elim_compare_eq : + forall x y : t, + eq x y -> exists H : eq x y, compare x y = EQ _ H. + Proof. + intros; case (compare x y); intros H'; try (exfalso; order). + exists H'; auto. + Qed. + + Lemma elim_compare_lt : + forall x y : t, + lt x y -> exists H : lt x y, compare x y = LT _ H. + Proof. + intros; case (compare x y); intros H'; try (exfalso; order). + exists H'; auto. + Qed. + + Lemma elim_compare_gt : + forall x y : t, + lt y x -> exists H : lt y x, compare x y = GT _ H. + Proof. + intros; case (compare x y); intros H'; try (exfalso; order). + exists H'; auto. + Qed. + + Ltac elim_comp := + match goal with + | |- ?e => match e with + | context ctx [ compare ?a ?b ] => + let H := fresh in + (destruct (compare a b) as [H|H|H]; try order) + end + end. + + Ltac elim_comp_eq x y := + elim (elim_compare_eq (x:=x) (y:=y)); + [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. + + Ltac elim_comp_lt x y := + elim (elim_compare_lt (x:=x) (y:=y)); + [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. + + Ltac elim_comp_gt x y := + elim (elim_compare_gt (x:=x) (y:=y)); + [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. + + (** For compatibility reasons *) + Definition eq_dec := eq_dec. + + Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. + Proof. + intros; elim (compare x y); [ left | right | right ]; auto. + Defined. + + Definition eqb x y : bool := if eq_dec x y then true else false. + + Lemma eqb_alt : + forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. + Proof. + unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto. + Qed. + +(* Specialization of resuts about lists modulo. *) + +Section ForNotations. + +Notation In:=(InA eq). +Notation Inf:=(lelistA lt). +Notation Sort:=(sort lt). +Notation NoDup:=(NoDupA eq). + +Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. +Proof. exact (InA_eqA eq_equiv). Qed. + +Lemma ListIn_In : forall l x, List.In x l -> In x l. +Proof. exact (In_InA eq_equiv). Qed. + +Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l. +Proof. exact (InfA_ltA lt_strorder). Qed. + +Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l. +Proof. exact (InfA_eqA eq_equiv lt_strorder lt_compat). Qed. + +Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x. +Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed. + +Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l. +Proof. exact (@In_InfA t lt). Qed. + +Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l. +Proof. exact (InA_InfA eq_equiv (ltA:=lt)). Qed. + +Lemma Inf_alt : + forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)). +Proof. exact (InfA_alt eq_equiv lt_strorder lt_compat). Qed. + +Lemma Sort_NoDup : forall l, Sort l -> NoDup l. +Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat). Qed. + +End ForNotations. + +Hint Resolve ListIn_In Sort_NoDup Inf_lt. +Hint Immediate In_eq Inf_lt. + +End OrderedTypeFacts. + +Module KeyOrderedType(O:OrderedType). + Import O. + Module MO:=OrderedTypeFacts(O). + Import MO. + + Section Elt. + Variable elt : Type. + Notation key:=t. + + Definition eqk (p p':key*elt) := eq (fst p) (fst p'). + Definition eqke (p p':key*elt) := + eq (fst p) (fst p') /\ (snd p) = (snd p'). + Definition ltk (p p':key*elt) := lt (fst p) (fst p'). + + Hint Unfold eqk eqke ltk. + Hint Extern 2 (eqke ?a ?b) => split. + + (* eqke is stricter than eqk *) + + Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. + Proof. + unfold eqk, eqke; intuition. + Qed. + + (* ltk ignore the second components *) + + Lemma ltk_right_r : forall x k e e', ltk x (k,e) -> ltk x (k,e'). + Proof. auto. Qed. + + Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. + Proof. auto. Qed. + Hint Immediate ltk_right_r ltk_right_l. + + (* eqk, eqke are equalities, ltk is a strict order *) + + Lemma eqk_refl : forall e, eqk e e. + Proof. auto. Qed. + + Lemma eqke_refl : forall e, eqke e e. + Proof. auto. Qed. + + Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. + Proof. auto. Qed. + + Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. + Proof. unfold eqke; intuition. Qed. + + Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. + Proof. eauto. Qed. + + Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. + Proof. + unfold eqke; intuition; [ eauto | congruence ]. + Qed. + + Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''. + Proof. eauto. Qed. + + Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. + Proof. unfold eqk, ltk; auto. Qed. + + Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. + Proof. + unfold eqke, ltk; intuition; simpl in *; subst. + exact (lt_not_eq H H1). + Qed. + + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. + Hint Immediate eqk_sym eqke_sym. + + Global Instance eqk_equiv : Equivalence eqk. + Proof. split; eauto. Qed. + + Global Instance eqke_equiv : Equivalence eqke. + Proof. split; eauto. Qed. + + Global Instance ltk_strorder : StrictOrder ltk. + Proof. + split; eauto. + intros (x,e); compute; apply (StrictOrder_Irreflexive x). + Qed. + + Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. + Proof. + intros (x,e) (x',e') Hxx' (y,f) (y',f') Hyy'; compute. + compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. + Qed. + + Global Instance ltk_compat' : Proper (eqke==>eqke==>iff) ltk. + Proof. + intros (x,e) (x',e') (Hxx',_) (y,f) (y',f') (Hyy',_); compute. + compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. + Qed. + + (* Additionnal facts *) + + Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. + Proof. + unfold eqk, ltk; simpl; auto. + Qed. + + Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''. + Proof. eauto. Qed. + + Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''. + Proof. + intros (k,e) (k',e') (k'',e''). + unfold ltk, eqk; simpl; eauto. + Qed. + Hint Resolve eqk_not_ltk. + Hint Immediate ltk_eqk eqk_ltk. + + Lemma InA_eqke_eqk : + forall x m, InA eqke x m -> InA eqk x m. + Proof. + unfold eqke; induction 1; intuition. + Qed. + Hint Resolve InA_eqke_eqk. + + Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). + Definition In k m := exists e:elt, MapsTo k e m. + Notation Sort := (sort ltk). + Notation Inf := (lelistA ltk). + + Hint Unfold MapsTo In. + + (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) + + Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. + Proof. + firstorder. + exists x; auto. + induction H. + destruct y. + exists e; auto. + destruct IHInA as [e H0]. + exists e; auto. + Qed. + + Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. + Proof. + intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. + Qed. + + Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. + Proof. + destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. + Qed. + + Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. + Proof. exact (InfA_eqA eqk_equiv ltk_strorder 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. + + Hint Immediate Inf_eq. + Hint Resolve Inf_lt. + + Lemma Sort_Inf_In : + forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. + Proof. + exact (SortA_InfA_InA eqk_equiv ltk_strorder ltk_compat). + Qed. + + Lemma Sort_Inf_NotIn : + forall l k e, Sort l -> Inf (k,e) l -> ~In k l. + Proof. + intros; red; intros. + destruct H1 as [e' H2]. + elim (@ltk_not_eqk (k,e) (k,e')). + eapply Sort_Inf_In; eauto. + red; simpl; auto. + Qed. + + Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. + Proof. + exact (SortA_NoDupA eqk_equiv ltk_strorder ltk_compat). + Qed. + + Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. + Proof. + inversion 1; intros; eapply Sort_Inf_In; eauto. + Qed. + + Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> + ltk e e' \/ eqk e e'. + Proof. + inversion_clear 2; auto. + left; apply Sort_In_cons_1 with l; auto. + Qed. + + Lemma Sort_In_cons_3 : + forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. + Proof. + inversion_clear 1; red; intros. + destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)). + Qed. + + Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. + Proof. + inversion 1. + inversion_clear H0; eauto. + destruct H1; simpl in *; intuition. + Qed. + + Lemma In_inv_2 : forall k k' e e' l, + InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. + Proof. + inversion_clear 1; compute in H0; intuition. + Qed. + + Lemma In_inv_3 : forall x x' l, + InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. + Proof. + inversion_clear 1; compute in H0; intuition. + Qed. + + End Elt. + + Hint Unfold eqk eqke ltk. + Hint Extern 2 (eqke ?a ?b) => split. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. + Hint Immediate eqk_sym eqke_sym. + Hint Resolve eqk_not_ltk. + Hint Immediate ltk_eqk eqk_ltk. + Hint Resolve InA_eqke_eqk. + Hint Unfold MapsTo In. + Hint Immediate Inf_eq. + Hint Resolve Inf_lt. + Hint Resolve Sort_Inf_NotIn. + Hint Resolve In_inv_2 In_inv_3. + +End KeyOrderedType. + + diff --git a/theories/Structures/OrderedTypeAlt.v b/theories/Structures/OrderedTypeAlt.v new file mode 100644 index 00000000..23ae4c85 --- /dev/null +++ b/theories/Structures/OrderedTypeAlt.v @@ -0,0 +1,122 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> comparison. + + Infix "?=" := compare (at level 70, no associativity). + + Parameter compare_sym : + forall x y, (y?=x) = CompOpp (x?=y). + Parameter compare_trans : + forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. + +End OrderedTypeAlt. + +(** From this new presentation to the original one. *) + +Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType. + Import O. + + Definition t := t. + + Definition eq x y := (x?=y) = Eq. + Definition lt x y := (x?=y) = Lt. + + Lemma eq_refl : forall x, eq x x. + Proof. + intro x. + unfold eq. + assert (H:=compare_sym x x). + destruct (x ?= x); simpl in *; try discriminate; auto. + Qed. + + Lemma eq_sym : forall x y, eq x y -> eq y x. + Proof. + unfold eq; intros. + rewrite compare_sym. + rewrite H; simpl; auto. + Qed. + + Definition eq_trans := (compare_trans Eq). + + Definition lt_trans := (compare_trans Lt). + + Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. + Proof. + unfold eq, lt; intros. + rewrite H; discriminate. + Qed. + + Definition compare : forall x y, Compare lt eq x y. + Proof. + intros. + case_eq (x ?= y); intros. + apply EQ; auto. + apply LT; auto. + apply GT; red. + rewrite compare_sym; rewrite H; auto. + Defined. + + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros; unfold eq. + case (x ?= y); [ left | right | right ]; auto; discriminate. + Defined. + +End OrderedType_from_Alt. + +(** From the original presentation to this alternative one. *) + +Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt. + Import O. + Module MO:=OrderedTypeFacts(O). + Import MO. + + Definition t := t. + + Definition compare x y := match compare x y with + | LT _ => Lt + | EQ _ => Eq + | GT _ => Gt + end. + + Infix "?=" := compare (at level 70, no associativity). + + Lemma compare_sym : + forall x y, (y?=x) = CompOpp (x?=y). + Proof. + intros x y; unfold compare. + destruct O.compare; elim_comp; simpl; auto. + Qed. + + Lemma compare_trans : + forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. + Proof. + intros c x y z. + destruct c; unfold compare; + do 2 (destruct O.compare; intros; try discriminate); + elim_comp; auto. + Qed. + +End OrderedType_to_Alt. + + diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v new file mode 100644 index 00000000..b4dbceba --- /dev/null +++ b/theories/Structures/OrderedTypeEx.v @@ -0,0 +1,333 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> Prop. + Definition eq_refl := @refl_equal t. + Definition eq_sym := @sym_eq t. + Definition eq_trans := @trans_eq t. + Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. + Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. + Parameter compare : forall x y : t, Compare lt eq x y. + Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }. +End UsualOrderedType. + +(** a [UsualOrderedType] is in particular an [OrderedType]. *) + +Module UOT_to_OT (U:UsualOrderedType) <: OrderedType := U. + +(** [nat] is an ordered type with respect to the usual order on natural numbers. *) + +Module Nat_as_OT <: UsualOrderedType. + + Definition t := nat. + + Definition eq := @eq nat. + Definition eq_refl := @refl_equal t. + Definition eq_sym := @sym_eq t. + Definition eq_trans := @trans_eq t. + + Definition lt := lt. + + Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. + Proof. unfold lt; intros; apply lt_trans with y; auto. Qed. + + Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. + Proof. unfold lt, eq; intros; omega. Qed. + + Definition compare : forall x y : t, Compare lt eq x y. + Proof. + intros x y; destruct (nat_compare x y) as [ | | ]_eqn. + apply EQ. apply nat_compare_eq; assumption. + apply LT. apply nat_compare_Lt_lt; assumption. + apply GT. apply nat_compare_Gt_gt; assumption. + Defined. + + Definition eq_dec := eq_nat_dec. + +End Nat_as_OT. + + +(** [Z] is an ordered type with respect to the usual order on integers. *) + +Open Local Scope Z_scope. + +Module Z_as_OT <: UsualOrderedType. + + Definition t := Z. + Definition eq := @eq Z. + Definition eq_refl := @refl_equal t. + Definition eq_sym := @sym_eq t. + Definition eq_trans := @trans_eq t. + + Definition lt (x y:Z) := (x y x ~ x=y. + Proof. intros; omega. Qed. + + Definition compare : forall x y, Compare lt eq x y. + Proof. + intros x y; destruct (x ?= y) as [ | | ]_eqn. + apply EQ; apply Zcompare_Eq_eq; assumption. + apply LT; assumption. + apply GT; apply Zgt_lt; assumption. + Defined. + + Definition eq_dec := Z_eq_dec. + +End Z_as_OT. + +(** [positive] is an ordered type with respect to the usual order on natural numbers. *) + +Open Local Scope positive_scope. + +Module Positive_as_OT <: UsualOrderedType. + Definition t:=positive. + Definition eq:=@eq positive. + Definition eq_refl := @refl_equal t. + Definition eq_sym := @sym_eq t. + Definition eq_trans := @trans_eq t. + + Definition lt p q:= (p ?= q) Eq = Lt. + + Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. + Proof. + unfold lt; intros x y z. + change ((Zpos x < Zpos y)%Z -> (Zpos y < Zpos z)%Z -> (Zpos x < Zpos z)%Z). + omega. + Qed. + + Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. + Proof. + intros; intro. + rewrite H0 in H. + unfold lt in H. + rewrite Pcompare_refl in H; discriminate. + Qed. + + Definition compare : forall x y : t, Compare lt eq x y. + Proof. + intros x y. destruct ((x ?= y) Eq) as [ | | ]_eqn. + apply EQ; apply Pcompare_Eq_eq; assumption. + apply LT; assumption. + apply GT; apply ZC1; assumption. + Defined. + + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros; unfold eq; decide equality. + Defined. + +End Positive_as_OT. + + +(** [N] is an ordered type with respect to the usual order on natural numbers. *) + +Open Local Scope positive_scope. + +Module N_as_OT <: UsualOrderedType. + Definition t:=N. + Definition eq:=@eq N. + Definition eq_refl := @refl_equal t. + Definition eq_sym := @sym_eq t. + Definition eq_trans := @trans_eq t. + + Definition lt:=Nlt. + Definition lt_trans := Nlt_trans. + Definition lt_not_eq := Nlt_not_eq. + + Definition compare : forall x y : t, Compare lt eq x y. + Proof. + intros x y. destruct (x ?= y)%N as [ | | ]_eqn. + apply EQ; apply Ncompare_Eq_eq; assumption. + apply LT; assumption. + apply GT. apply Ngt_Nlt; assumption. + Defined. + + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros. unfold eq. decide equality. apply Positive_as_OT.eq_dec. + Defined. + +End N_as_OT. + + +(** From two ordered types, we can build a new OrderedType + over their cartesian product, using the lexicographic order. *) + +Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. + Module MO1:=OrderedTypeFacts(O1). + Module MO2:=OrderedTypeFacts(O2). + + Definition t := prod O1.t O2.t. + + Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y). + + Definition lt x y := + O1.lt (fst x) (fst y) \/ + (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)). + + Lemma eq_refl : forall x : t, eq x x. + Proof. + intros (x1,x2); red; simpl; auto. + Qed. + + Lemma eq_sym : forall x y : t, eq x y -> eq y x. + Proof. + intros (x1,x2) (y1,y2); unfold eq; simpl; intuition. + Qed. + + Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. + Proof. + intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto. + Qed. + + Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. + Proof. + intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition. + left; eauto. + left; eapply MO1.lt_eq; eauto. + left; eapply MO1.eq_lt; eauto. + right; split; eauto. + Qed. + + Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. + Proof. + intros (x1,x2) (y1,y2); unfold eq, lt; simpl; intuition. + apply (O1.lt_not_eq H0 H1). + apply (O2.lt_not_eq H3 H2). + Qed. + + Definition compare : forall x y : t, Compare lt eq x y. + intros (x1,x2) (y1,y2). + destruct (O1.compare x1 y1). + apply LT; unfold lt; auto. + destruct (O2.compare x2 y2). + apply LT; unfold lt; auto. + apply EQ; unfold eq; auto. + apply GT; unfold lt; auto. + apply GT; unfold lt; auto. + Defined. + + Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. + Proof. + intros; elim (compare x y); intro H; [ right | left | right ]; auto. + auto using lt_not_eq. + assert (~ eq y x); auto using lt_not_eq, eq_sym. + Defined. + +End PairOrderedType. + + +(** Even if [positive] can be seen as an ordered type with respect to the + usual order (see above), we can also use a lexicographic order over bits + (lower bits are considered first). This is more natural when using + [positive] as indexes for sets or maps (see FSetPositive and FMapPositive. *) + +Module PositiveOrderedTypeBits <: UsualOrderedType. + Definition t:=positive. + Definition eq:=@eq positive. + Definition eq_refl := @refl_equal t. + Definition eq_sym := @sym_eq t. + Definition eq_trans := @trans_eq t. + + Fixpoint bits_lt (p q:positive) : Prop := + match p, q with + | xH, xI _ => True + | xH, _ => False + | xO p, xO q => bits_lt p q + | xO _, _ => True + | xI p, xI q => bits_lt p q + | xI _, _ => False + end. + + Definition lt:=bits_lt. + + Lemma bits_lt_trans : + forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z. + Proof. + induction x. + induction y; destruct z; simpl; eauto; intuition. + induction y; destruct z; simpl; eauto; intuition. + induction y; destruct z; simpl; eauto; intuition. + Qed. + + Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. + Proof. + exact bits_lt_trans. + Qed. + + Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x. + Proof. + induction x; simpl; auto. + Qed. + + Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. + Proof. + intros; intro. + rewrite <- H0 in H; clear H0 y. + unfold lt in H. + exact (bits_lt_antirefl x H). + Qed. + + Definition compare : forall x y : t, Compare lt eq x y. + Proof. + induction x; destruct y. + (* I I *) + destruct (IHx y). + apply LT; auto. + apply EQ; rewrite e; red; auto. + apply GT; auto. + (* I O *) + apply GT; simpl; auto. + (* I H *) + apply GT; simpl; auto. + (* O I *) + apply LT; simpl; auto. + (* O O *) + destruct (IHx y). + apply LT; auto. + apply EQ; rewrite e; red; auto. + apply GT; auto. + (* O H *) + apply LT; simpl; auto. + (* H I *) + apply LT; simpl; auto. + (* H O *) + apply GT; simpl; auto. + (* H H *) + apply EQ; red; auto. + Qed. + + Lemma eq_dec (x y: positive): {x = y} + {x <> y}. + Proof. + intros. case_eq ((x ?= y) Eq); intros. + left. apply Pcompare_Eq_eq; auto. + right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate. + right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate. + Qed. + +End PositiveOrderedTypeBits. diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v new file mode 100644 index 00000000..bddd461a --- /dev/null +++ b/theories/Structures/Orders.v @@ -0,0 +1,333 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> Prop. +End HasLt. + +Module Type HasLe (Import T:Typ). + Parameter Inline le : t -> t -> Prop. +End HasLe. + +Module Type EqLt := Typ <+ HasEq <+ HasLt. +Module Type EqLe := Typ <+ HasEq <+ HasLe. +Module Type EqLtLe := Typ <+ HasEq <+ HasLt <+ HasLe. + +(** Versions with nice notations *) + +Module Type LtNotation (E:EqLt). + Infix "<" := E.lt. + Notation "x > y" := (y= y" := (y<=x) (only parsing). + Notation "x <= y <= z" := (x<=y /\ y<=z). +End LeNotation. + +Module Type LtLeNotation (E:EqLtLe). + Include LtNotation E <+ LeNotation E. + Notation "x <= y < z" := (x<=y /\ yeq==>iff) lt. +End IsStrOrder. + +Module Type LeIsLtEq (Import E:EqLtLe'). + Axiom le_lteq : forall x y, x<=y <-> x t -> comparison. + Axiom compare_spec : forall x y, CompSpec eq lt x y (compare x y). +End HasCompare. + +Module Type StrOrder := EqualityType <+ HasLt <+ IsStrOrder. +Module Type DecStrOrder := StrOrder <+ HasCompare. +Module Type OrderedType <: DecidableType := DecStrOrder <+ HasEqDec. +Module Type OrderedTypeFull := OrderedType <+ HasLe <+ LeIsLtEq. + +Module Type StrOrder' := StrOrder <+ EqLtNotation. +Module Type DecStrOrder' := DecStrOrder <+ EqLtNotation. +Module Type OrderedType' := OrderedType <+ EqLtNotation. +Module Type OrderedTypeFull' := OrderedTypeFull <+ EqLtLeNotation. + +(** NB: in [OrderedType], an [eq_dec] could be deduced from [compare]. + But adding this redundant field allows to see an [OrderedType] as a + [DecidableType]. *) + +(** * Versions with [eq] being the usual Leibniz equality of Coq *) + +Module Type UsualStrOrder := UsualEqualityType <+ HasLt <+ IsStrOrder. +Module Type UsualDecStrOrder := UsualStrOrder <+ HasCompare. +Module Type UsualOrderedType <: UsualDecidableType <: OrderedType + := UsualDecStrOrder <+ HasEqDec. +Module Type UsualOrderedTypeFull := UsualOrderedType <+ HasLe <+ LeIsLtEq. + +(** NB: in [UsualOrderedType], the field [lt_compat] is + useless since [eq] is [Leibniz], but it should be + there for subtyping. *) + +Module Type UsualStrOrder' := UsualStrOrder <+ LtNotation. +Module Type UsualDecStrOrder' := UsualDecStrOrder <+ LtNotation. +Module Type UsualOrderedType' := UsualOrderedType <+ LtNotation. +Module Type UsualOrderedTypeFull' := UsualOrderedTypeFull <+ LtLeNotation. + +(** * Purely logical versions *) + +Module Type LtIsTotal (Import E:EqLt'). + Axiom lt_total : forall x y, x true | _ => false end. + + Lemma eqb_eq : forall x y, eqb x y = true <-> x==y. + Proof. + unfold eqb. intros x y. + destruct (compare_spec x y) as [H|H|H]; split; auto; try discriminate. + intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H). + intros EQ; rewrite EQ in H; elim (StrictOrder_Irreflexive _ H). + Qed. + +End Compare2EqBool. + +Module DSO_to_OT (O:DecStrOrder) <: OrderedType := + O <+ Compare2EqBool <+ HasEqBool2Dec. + +(** From [OrderedType] To [OrderedTypeFull] (adding [<=]) *) + +Module OT_to_Full (O:OrderedType') <: OrderedTypeFull. + Include O. + Definition le x y := x x-> Sortclass. +Hint Unfold is_true. + +Module Type HasLeBool (Import T:Typ). + Parameter Inline leb : t -> t -> bool. +End HasLeBool. + +Module Type HasLtBool (Import T:Typ). + Parameter Inline ltb : t -> t -> bool. +End HasLtBool. + +Module Type LeBool := Typ <+ HasLeBool. +Module Type LtBool := Typ <+ HasLtBool. + +Module Type LeBoolNotation (E:LeBool). + Infix "<=?" := E.leb (at level 35). +End LeBoolNotation. + +Module Type LtBoolNotation (E:LtBool). + Infix " Y.le x y. +End LeBool_Le. + +Module Type LtBool_Lt (T:Typ)(X:HasLtBool T)(Y:HasLt T). + Parameter ltb_lt : forall x y, X.ltb x y = true <-> Y.lt x y. +End LtBool_Lt. + +Module Type LeBoolIsTotal (Import X:LeBool'). + Axiom leb_total : forall x y, (x <=? y) = true \/ (y <=? x) = true. +End LeBoolIsTotal. + +Module Type TotalLeBool := LeBool <+ LeBoolIsTotal. +Module Type TotalLeBool' := LeBool' <+ LeBoolIsTotal. + +Module Type LeBoolIsTransitive (Import X:LeBool'). + Axiom leb_trans : Transitive X.leb. +End LeBoolIsTransitive. + +Module Type TotalTransitiveLeBool := TotalLeBool <+ LeBoolIsTransitive. +Module Type TotalTransitiveLeBool' := TotalLeBool' <+ LeBoolIsTransitive. + + +(** * From [OrderedTypeFull] to [TotalTransitiveLeBool] *) + +Module OTF_to_TTLB (Import O : OrderedTypeFull') <: TotalTransitiveLeBool. + + Definition leb x y := + match compare x y with Gt => false | _ => true end. + + Lemma leb_le : forall x y, leb x y <-> x <= y. + Proof. + intros. unfold leb. rewrite le_lteq. + destruct (compare_spec x y) as [EQ|LT|GT]; split; auto. + discriminate. + intros LE. elim (StrictOrder_Irreflexive x). + destruct LE as [LT|EQ]. now transitivity y. now rewrite <- EQ in GT. + Qed. + + Lemma leb_total : forall x y, leb x y \/ leb y x. + Proof. + intros. rewrite 2 leb_le. rewrite 2 le_lteq. + destruct (compare_spec x y); intuition. + Qed. + + Lemma leb_trans : Transitive leb. + Proof. + intros x y z. rewrite !leb_le, !le_lteq. + intros [Hxy|Hxy] [Hyz|Hyz]. + left; transitivity y; auto. + left; rewrite <- Hyz; auto. + left; rewrite Hxy; auto. + right; transitivity y; auto. + Qed. + + Definition t := t. + +End OTF_to_TTLB. + + +(** * From [TotalTransitiveLeBool] to [OrderedTypeFull] + + [le] is [leb ... = true]. + [eq] is [le /\ swap le]. + [lt] is [le /\ ~swap le]. +*) + +Local Open Scope bool_scope. + +Module TTLB_to_OTF (Import O : TotalTransitiveLeBool') <: OrderedTypeFull. + + Definition t := t. + + Definition le x y : Prop := x <=? y. + Definition eq x y : Prop := le x y /\ le y x. + Definition lt x y : Prop := le x y /\ ~le y x. + + Definition compare x y := + if x <=? y then (if y <=? x then Eq else Lt) else Gt. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + intros. unfold compare. + case_eq (x <=? y). + case_eq (y <=? x). + constructor. split; auto. + constructor. split; congruence. + constructor. destruct (leb_total x y); split; congruence. + Qed. + + Definition eqb x y := (x <=? y) && (y <=? x). + + Lemma eqb_eq : forall x y, eqb x y <-> eq x y. + Proof. + intros. unfold eq, eqb, le. + case leb; simpl; intuition; discriminate. + Qed. + + Include HasEqBool2Dec. + + Instance eq_equiv : Equivalence eq. + Proof. + split. + intros x; unfold eq, le. destruct (leb_total x x); auto. + intros x y; unfold eq, le. intuition. + intros x y z; unfold eq, le. intuition; apply leb_trans with y; auto. + Qed. + + Instance lt_strorder : StrictOrder lt. + Proof. + split. + intros x. unfold lt; red; intuition. + intros x y z; unfold lt, le. intuition. + apply leb_trans with y; auto. + absurd (z <=? y); auto. + apply leb_trans with x; auto. + Qed. + + Instance lt_compat : Proper (eq ==> eq ==> iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + intros x x' Hx y y' Hy' H. unfold eq, lt, le in *. + intuition. + apply leb_trans with x; auto. + apply leb_trans with y; auto. + absurd (y <=? x); auto. + apply leb_trans with x'; auto. + apply leb_trans with y'; auto. + Qed. + + Definition le_lteq : forall x y, le x y <-> lt x y \/ eq x y. + Proof. + intros. + unfold lt, eq, le. + split; [ | intuition ]. + intros LE. + case_eq (y <=? x); [right|left]; intuition; try discriminate. + Qed. + +End TTLB_to_OTF. diff --git a/theories/Structures/OrdersAlt.v b/theories/Structures/OrdersAlt.v new file mode 100644 index 00000000..d86b02a1 --- /dev/null +++ b/theories/Structures/OrdersAlt.v @@ -0,0 +1,242 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> comparison. + + Infix "?=" := compare (at level 70, no associativity). + + Parameter compare_sym : + forall x y, (y?=x) = CompOpp (x?=y). + Parameter compare_trans : + forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. + +End OrderedTypeAlt. + +(** ** From OrderedTypeOrig to OrderedType. *) + +Module Update_OT (O:OrderedTypeOrig) <: OrderedType. + + Include Update_DT O. (* Provides : t eq eq_equiv eq_dec *) + + Definition lt := O.lt. + + Instance lt_strorder : StrictOrder lt. + Proof. + split. + intros x Hx. apply (O.lt_not_eq Hx); auto with *. + exact O.lt_trans. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + intros x x' Hx y y' Hy H. + assert (H0 : lt x' y). + destruct (O.compare x' y) as [H'|H'|H']; auto. + elim (O.lt_not_eq H). transitivity x'; auto with *. + elim (O.lt_not_eq (O.lt_trans H H')); auto. + destruct (O.compare x' y') as [H'|H'|H']; auto. + elim (O.lt_not_eq H). + transitivity x'; auto with *. transitivity y'; auto with *. + elim (O.lt_not_eq (O.lt_trans H' H0)); auto with *. + Qed. + + Definition compare x y := + match O.compare x y with + | EQ _ => Eq + | LT _ => Lt + | GT _ => Gt + end. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + intros; unfold compare; destruct O.compare; auto. + Qed. + +End Update_OT. + +(** ** From OrderedType to OrderedTypeOrig. *) + +Module Backport_OT (O:OrderedType) <: OrderedTypeOrig. + + Include Backport_DT O. (* Provides : t eq eq_refl eq_sym eq_trans eq_dec *) + + Definition lt := O.lt. + + Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. + Proof. + intros x y L E; rewrite E in L. apply (StrictOrder_Irreflexive y); auto. + Qed. + + Lemma lt_trans : Transitive lt. + Proof. apply O.lt_strorder. Qed. + + Definition compare : forall x y, Compare lt eq x y. + Proof. + intros x y; destruct (CompSpec2Type (O.compare_spec x y)); + [apply EQ|apply LT|apply GT]; auto. + Defined. + +End Backport_OT. + + +(** ** From OrderedTypeAlt to OrderedType. *) + +Module OT_from_Alt (Import O:OrderedTypeAlt) <: OrderedType. + + Definition t := t. + + Definition eq x y := (x?=y) = Eq. + Definition lt x y := (x?=y) = Lt. + + Instance eq_equiv : Equivalence eq. + Proof. + split; red. + (* refl *) + unfold eq; intros x. + assert (H:=compare_sym x x). + destruct (x ?= x); simpl in *; auto; discriminate. + (* sym *) + unfold eq; intros x y H. + rewrite compare_sym, H; simpl; auto. + (* trans *) + apply compare_trans. + Qed. + + Instance lt_strorder : StrictOrder lt. + Proof. + split; repeat red; unfold lt; try apply compare_trans. + intros x H. + assert (eq x x) by reflexivity. + unfold eq in *; congruence. + Qed. + + Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. + Proof. + unfold lt, eq; intros x y z Hxy Hyz. + destruct (compare x z) as [ ]_eqn:Hxz; auto. + rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz. + rewrite (compare_trans Hxz Hyz) in Hxy; discriminate. + rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy. + rewrite (compare_trans Hxy Hxz) in Hyz; discriminate. + Qed. + + Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. + Proof. + unfold lt, eq; intros x y z Hxy Hyz. + destruct (compare x z) as [ ]_eqn:Hxz; auto. + rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy. + rewrite (compare_trans Hxy Hxz) in Hyz; discriminate. + rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz. + rewrite (compare_trans Hxz Hyz) in Hxy; discriminate. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + repeat red; intros. + eapply lt_eq; eauto. eapply eq_lt; eauto. symmetry; auto. + Qed. + + Definition compare := O.compare. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + unfold eq, lt, compare; intros. + destruct (O.compare x y) as [ ]_eqn:H; auto. + apply CompGt. + rewrite compare_sym, H; auto. + Qed. + + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros; unfold eq. + case (x ?= y); [ left | right | right ]; auto; discriminate. + Defined. + +End OT_from_Alt. + +(** From the original presentation to this alternative one. *) + +Module OT_to_Alt (Import O:OrderedType) <: OrderedTypeAlt. + + Definition t := t. + Definition compare := compare. + + Infix "?=" := compare (at level 70, no associativity). + + Lemma compare_sym : + forall x y, (y?=x) = CompOpp (x?=y). + Proof. + intros x y; unfold compare. + destruct (compare_spec x y) as [U|U|U]; + destruct (compare_spec y x) as [V|V|V]; auto. + rewrite U in V. elim (StrictOrder_Irreflexive y); auto. + rewrite U in V. elim (StrictOrder_Irreflexive y); auto. + rewrite V in U. elim (StrictOrder_Irreflexive x); auto. + rewrite V in U. elim (StrictOrder_Irreflexive x); auto. + rewrite V in U. elim (StrictOrder_Irreflexive x); auto. + rewrite V in U. elim (StrictOrder_Irreflexive y); auto. + Qed. + + Lemma compare_Eq : forall x y, compare x y = Eq <-> eq x y. + Proof. + unfold compare. + intros x y; destruct (compare_spec x y); intuition; + try discriminate. + rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto. + rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto. + Qed. + + Lemma compare_Lt : forall x y, compare x y = Lt <-> lt x y. + Proof. + unfold compare. + intros x y; destruct (compare_spec x y); intuition; + try discriminate. + rewrite H in H0. elim (StrictOrder_Irreflexive y); auto. + rewrite H in H0. elim (StrictOrder_Irreflexive x); auto. + Qed. + + Lemma compare_Gt : forall x y, compare x y = Gt <-> lt y x. + Proof. + intros x y. rewrite compare_sym, CompOpp_iff. apply compare_Lt. + Qed. + + Lemma compare_trans : + forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. + Proof. + intros c x y z. + destruct c; unfold compare; + rewrite ?compare_Eq, ?compare_Lt, ?compare_Gt; + transitivity y; auto. + Qed. + +End OT_to_Alt. diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v new file mode 100644 index 00000000..56f1d5de --- /dev/null +++ b/theories/Structures/OrdersEx.v @@ -0,0 +1,88 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* eq==>iff) lt. + Proof. + compute. + intros (x1,x2) (x1',x2') (X1,X2) (y1,y2) (y1',y2') (Y1,Y2). + rewrite X1,X2,Y1,Y2; intuition. + Qed. + + Definition compare x y := + match O1.compare (fst x) (fst y) with + | Eq => O2.compare (snd x) (snd y) + | Lt => Lt + | Gt => Gt + end. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + intros (x1,x2) (y1,y2); unfold compare; simpl. + destruct (O1.compare_spec x1 y1); try (constructor; compute; auto). + destruct (O2.compare_spec x2 y2); constructor; compute; auto with relations. + Qed. + +End PairOrderedType. + diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v new file mode 100644 index 00000000..a28b7977 --- /dev/null +++ b/theories/Structures/OrdersFacts.v @@ -0,0 +1,234 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* eq==>iff) le. + Proof. repeat red; iorder. Qed. + + Instance le_preorder : PreOrder le. + Proof. split; red; order. Qed. + + Instance le_order : PartialOrder eq le. + Proof. compute; iorder. Qed. + + Instance le_antisym : Antisymmetric _ eq le. + Proof. apply partial_order_antisym; auto with *. Qed. + + Lemma le_not_gt_iff : forall x y, x<=y <-> ~y ~y<=x. + Proof. iorder. Qed. + + Lemma le_or_gt : forall x y, x<=y \/ y x<=y /\ y<=x. + Proof. iorder. Qed. + +End OrderedTypeFullFacts. + + +(** * Properties of [OrderedType] *) + +Module OrderedTypeFacts (Import O: OrderedType'). + + Module OrderTac := OT_to_OrderTac O. + Ltac order := OrderTac.order. + + Notation "x <= y" := (~lt y x) : order. + Infix "?=" := compare (at level 70, no associativity) : order. + + Local Open Scope order. + + Tactic Notation "elim_compare" constr(x) constr(y) := + destruct (compare_spec x y). + + Tactic Notation "elim_compare" constr(x) constr(y) "as" ident(h) := + destruct (compare_spec x y) as [h|h|h]. + + (** The following lemmas are either re-phrasing of [eq_equiv] and + [lt_strorder] or immediately provable by [order]. Interest: + compatibility, test of order, etc *) + + Definition eq_refl (x:t) : x==x := Equivalence_Reflexive x. + + Definition eq_sym (x y:t) : x==y -> y==x := Equivalence_Symmetric x y. + + Definition eq_trans (x y z:t) : x==y -> y==z -> x==z := + Equivalence_Transitive x y z. + + Definition lt_trans (x y z:t) : x y x x==y. + Proof. + intros; elim_compare x y; intuition; try discriminate; order. + Qed. + + Lemma compare_lt_iff : forall x y, (x ?= y) = Lt <-> x y Lt <-> y<=x. + Proof. + intros; rewrite compare_lt_iff; intuition. + Qed. + + Lemma compare_le_iff : forall x y, (x ?= y) <> Gt <-> x<=y. + Proof. + intros; rewrite compare_gt_iff; intuition. + Qed. + + Hint Rewrite compare_eq_iff compare_lt_iff compare_gt_iff : order. + + Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare. + Proof. + intros x x' Hxx' y y' Hyy'. + elim_compare x' y'; autorewrite with order; order. + Qed. + + Lemma compare_refl : forall x, (x ?= x) = Eq. + Proof. + intros; elim_compare x x; auto; order. + Qed. + + Lemma compare_antisym : forall x y, (y ?= x) = CompOpp (x ?= y). + Proof. + intros; elim_compare x y; simpl; autorewrite with order; order. + Qed. + + (** For compatibility reasons *) + Definition eq_dec := eq_dec. + + Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. + Proof. + intros x y; destruct (CompSpec2Type (compare_spec x y)); + [ right | left | right ]; order. + Defined. + + Definition eqb x y : bool := if eq_dec x y then true else false. + + Lemma if_eq_dec : forall x y (B:Type)(b b':B), + (if eq_dec x y then b else b') = + (match compare x y with Eq => b | _ => b' end). + Proof. + intros; destruct eq_dec; elim_compare x y; auto; order. + Qed. + + Lemma eqb_alt : + forall x y, eqb x y = match compare x y with Eq => true | _ => false end. + Proof. + unfold eqb; intros; apply if_eq_dec. + Qed. + + Instance eqb_compat : Proper (eq==>eq==>Logic.eq) eqb. + Proof. + intros x x' Hxx' y y' Hyy'. + rewrite 2 eqb_alt, Hxx', Hyy'; auto. + Qed. + +End OrderedTypeFacts. + + + + + + +(** * Tests of the order tactic + + Is it at least capable of proving some basic properties ? *) + +Module OrderedTypeTest (Import O:OrderedType'). + Module Import MO := OrderedTypeFacts O. + Local Open Scope order. + Lemma lt_not_eq x y : x ~x==y. Proof. order. Qed. + Lemma lt_eq x y z : x y==z -> x y x y==z -> x<=z. Proof. order. Qed. + Lemma eq_le x y z : x==y -> y<=z -> x<=z. Proof. order. Qed. + Lemma neq_eq x y z : ~x==y -> y==z -> ~x==z. Proof. order. Qed. + Lemma eq_neq x y z : x==y -> ~y==z -> ~x==z. Proof. order. Qed. + Lemma le_lt_trans x y z : x<=y -> y x y<=z -> x y<=z -> x<=z. Proof. order. Qed. + Lemma le_antisym x y : x<=y -> y<=x -> x==y. Proof. order. Qed. + Lemma le_neq x y : x<=y -> ~x==y -> x ~y==x. Proof. order. Qed. + Lemma lt_le x y : x x<=y. Proof. order. Qed. + Lemma gt_not_eq x y : y ~x==y. Proof. order. Qed. + Lemma eq_not_lt x y : x==y -> ~x ~ y ~ y ~xeq==>iff) lt. +Proof. unfold lt; auto with *. Qed. + +Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y. +Proof. intros; unfold le, lt, flip. rewrite O.le_lteq; intuition. Qed. + +Definition compare := flip O.compare. + +Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). +Proof. +intros; unfold compare, eq, lt, flip. +destruct (O.compare_spec y x); auto with relations. +Qed. + +End OrderedTypeRev. + diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v new file mode 100644 index 00000000..2ed07026 --- /dev/null +++ b/theories/Structures/OrdersLists.v @@ -0,0 +1,256 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* In x l -> In y l. +Proof. intros. rewrite <- H; auto. Qed. + +Lemma ListIn_In : forall l x, List.In x l -> In x l. +Proof. exact (In_InA eq_equiv). Qed. + +Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l. +Proof. exact (InfA_ltA lt_strorder). Qed. + +Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l. +Proof. exact (InfA_eqA eq_equiv lt_strorder lt_compat). Qed. + +Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x. +Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed. + +Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l. +Proof. exact (@In_InfA t lt). Qed. + +Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l. +Proof. exact (InA_InfA eq_equiv (ltA:=lt)). Qed. + +Lemma Inf_alt : + forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)). +Proof. exact (InfA_alt eq_equiv lt_strorder lt_compat). Qed. + +Lemma Sort_NoDup : forall l, Sort l -> NoDup l. +Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat) . Qed. + +End ForNotations. + +Hint Resolve ListIn_In Sort_NoDup Inf_lt. +Hint Immediate In_eq Inf_lt. + +End OrderedTypeLists. + + + + + +(** * Results about keys and data as manipulated in FMaps. *) + + +Module KeyOrderedType(Import O:OrderedType). + Module Import MO:=OrderedTypeLists(O). + + Section Elt. + Variable elt : Type. + Notation key:=t. + + Local Open Scope signature_scope. + + Definition eqk : relation (key*elt) := eq @@1. + Definition eqke : relation (key*elt) := eq * Logic.eq. + Definition ltk : relation (key*elt) := lt @@1. + + Hint Unfold eqk eqke ltk. + + (* eqke is stricter than eqk *) + + Global Instance eqke_eqk : subrelation eqke eqk. + Proof. firstorder. Qed. + + (* eqk, eqke are equalities, ltk is a strict order *) + + Global Instance eqk_equiv : Equivalence eqk. + + Global Instance eqke_equiv : Equivalence eqke. + + Global Instance ltk_strorder : StrictOrder ltk. + + Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. + Proof. unfold eqk, ltk; auto with *. Qed. + + (* Additionnal facts *) + + Global Instance pair_compat : Proper (eq==>Logic.eq==>eqke) (@pair key elt). + Proof. apply pair_compat. Qed. + + Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. + Proof. + intros e e' LT EQ; rewrite EQ in LT. + elim (StrictOrder_Irreflexive _ LT). + Qed. + + Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. + Proof. + intros e e' LT EQ; rewrite EQ in LT. + elim (StrictOrder_Irreflexive _ LT). + Qed. + + Lemma InA_eqke_eqk : + forall x m, InA eqke x m -> InA eqk x m. + Proof. + unfold eqke, RelProd; induction 1; firstorder. + Qed. + Hint Resolve InA_eqke_eqk. + + Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). + Definition In k m := exists e:elt, MapsTo k e m. + Notation Sort := (sort ltk). + Notation Inf := (lelistA ltk). + + Hint Unfold MapsTo In. + + (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) + + Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. + Proof. + firstorder. + exists x; auto. + induction H. + destruct y; compute in H. + exists e; left; auto. + destruct IHInA as [e H0]. + exists e; auto. + Qed. + + Lemma In_alt2 : forall k l, In k l <-> Exists (fun p => eq k (fst p)) l. + Proof. + unfold In, MapsTo. + setoid_rewrite Exists_exists; setoid_rewrite InA_alt. + firstorder. + exists (snd x), x; auto. + Qed. + + Lemma In_nil : forall k, In k nil <-> False. + Proof. + intros; rewrite In_alt2; apply Exists_nil. + Qed. + + Lemma In_cons : forall k p l, + In k (p::l) <-> eq k (fst p) \/ In k l. + Proof. + intros; rewrite !In_alt2, Exists_cons; intuition. + Qed. + + Global Instance MapsTo_compat : + Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo. + Proof. + intros x x' Hx e e' He l l' Hl. unfold MapsTo. + rewrite Hx, He, Hl; intuition. + Qed. + + Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In. + Proof. + intros x x' Hx l l' Hl. rewrite !In_alt. + setoid_rewrite Hl. setoid_rewrite Hx. intuition. + Qed. + + Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. + Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed. + + Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. + Proof. intros l x y EQ. rewrite <- EQ; auto. Qed. + + Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. + Proof. intros l x x' H. rewrite H; auto. Qed. + + Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. + Proof. apply InfA_ltA; auto with *. Qed. + + Hint Immediate Inf_eq. + Hint Resolve Inf_lt. + + Lemma Sort_Inf_In : + forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. + Proof. apply SortA_InfA_InA; auto with *. Qed. + + Lemma Sort_Inf_NotIn : + forall l k e, Sort l -> Inf (k,e) l -> ~In k l. + Proof. + intros; red; intros. + destruct H1 as [e' H2]. + elim (@ltk_not_eqk (k,e) (k,e')). + eapply Sort_Inf_In; eauto. + repeat red; reflexivity. + Qed. + + Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. + Proof. apply SortA_NoDupA; auto with *. Qed. + + Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. + Proof. + intros; invlist sort; eapply Sort_Inf_In; eauto. + Qed. + + Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> + ltk e e' \/ eqk e e'. + Proof. + intros; invlist InA; auto with relations. + left; apply Sort_In_cons_1 with l; auto with relations. + Qed. + + Lemma Sort_In_cons_3 : + forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. + Proof. + intros; invlist sort; red; intros. + eapply Sort_Inf_NotIn; eauto using In_eq. + Qed. + + Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. + Proof. + intros; invlist In; invlist MapsTo. compute in * |- ; intuition. + right; exists x; auto. + Qed. + + Lemma In_inv_2 : forall k k' e e' l, + InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. + Proof. + intros; invlist InA; intuition. + Qed. + + Lemma In_inv_3 : forall x x' l, + InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. + Proof. + intros; invlist InA; compute in * |- ; intuition. + Qed. + + End Elt. + + Hint Unfold eqk eqke ltk. + Hint Extern 2 (eqke ?a ?b) => split. + Hint Resolve ltk_not_eqk ltk_not_eqke. + Hint Resolve InA_eqke_eqk. + Hint Unfold MapsTo In. + Hint Immediate Inf_eq. + Hint Resolve Inf_lt. + Hint Resolve Sort_Inf_NotIn. + Hint Resolve In_inv_2 In_inv_3. + +End KeyOrderedType. + diff --git a/theories/Structures/OrdersTac.v b/theories/Structures/OrdersTac.v new file mode 100644 index 00000000..66a672c9 --- /dev/null +++ b/theories/Structures/OrdersTac.v @@ -0,0 +1,293 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* le y z -> le x z]. +*) + +Inductive ord := OEQ | OLT | OLE. +Definition trans_ord o o' := + match o, o' with + | OEQ, _ => o' + | _, OEQ => o + | OLE, OLE => OLE + | _, _ => OLT + end. +Local Infix "+" := trans_ord. + + +(** ** The requirements of the tactic : [TotalOrder]. + + [TotalOrder] contains an equivalence [eq], + a strict order [lt] total and compatible with [eq], and + a larger order [le] synonym for [lt\/eq]. +*) + +(** ** Properties that will be used by the [order] tactic *) + +Module OrderFacts(Import O:TotalOrder'). + +(** Reflexivity rules *) + +Lemma eq_refl : forall x, x==x. +Proof. reflexivity. Qed. + +Lemma le_refl : forall x, x<=x. +Proof. intros; rewrite le_lteq; right; reflexivity. Qed. + +Lemma lt_irrefl : forall x, ~ x y==x. +Proof. auto with *. Qed. + +Lemma le_antisym : forall x y, x<=y -> y<=x -> x==y. +Proof. + intros x y; rewrite 2 le_lteq. intuition. + elim (StrictOrder_Irreflexive x); transitivity y; auto. +Qed. + +Lemma neq_sym : forall x y, ~x==y -> ~y==x. +Proof. auto using eq_sym. Qed. + +(** Transitivity rules : first, a generic formulation, then instances*) + +Ltac subst_eqns := + match goal with + | H : _==_ |- _ => (rewrite H || rewrite <- H); clear H; subst_eqns + | _ => idtac + end. + +Definition interp_ord o := + match o with OEQ => O.eq | OLT => O.lt | OLE => O.le end. +Local Notation "#" := interp_ord. + +Lemma trans : forall o o' x y z, #o x y -> #o' y z -> #(o+o') x z. +Proof. +destruct o, o'; simpl; intros x y z; rewrite ?le_lteq; intuition; + 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. +Definition le_trans x y z : x<=y -> y<=z -> x<=z := @trans OLE OLE x y z. +Definition lt_trans x y z : x y x y x y<=z -> x y x y==z -> x y<=z -> x<=z := @trans OEQ OLE x y z. +Definition le_eq x y z : x<=y -> y==z -> x<=z := @trans OLE OEQ x y z. + +Lemma eq_neq : forall x y z, x==y -> ~y==z -> ~x==z. +Proof. eauto using eq_trans, eq_sym. Qed. + +Lemma neq_eq : forall x y z, ~x==y -> y==z -> ~x==z. +Proof. eauto using eq_trans, eq_sym. Qed. + +(** (double) negation rules *) + +Lemma not_neq_eq : forall x y, ~~x==y -> x==y. +Proof. +intros x y H. destruct (lt_total x y) as [H'|[H'|H']]; auto; + destruct H; intro H; rewrite H in H'; eapply lt_irrefl; eauto. +Qed. + +Lemma not_ge_lt : forall x y, ~y<=x -> x x<=y. +Proof. +intros x y H. rewrite le_lteq. generalize (lt_total x y); intuition. +Qed. + +Lemma le_neq_lt : forall x y, x<=y -> ~x==y -> x 0 @@ -761,16 +755,16 @@ Proof. rewrite <-(Zopp_involutive a), <-(Zopp_involutive b). rewrite <- Zopp_plus_distr; rewrite ZOmod_opp_l. rewrite (ZOmod_opp_l (-a)),(ZOmod_opp_l (-b)). - match goal with |- _ = (-?x+-?y) mod n => + match goal with |- _ = (-?x+-?y) mod n => rewrite <-(Zopp_plus_distr x y), ZOmod_opp_l end. f_equal; apply H; auto with zarith. Qed. -Lemma ZOplus_mod_idemp_l: forall a b n, - 0 <= a * b -> +Lemma ZOplus_mod_idemp_l: forall a b n, + 0 <= a * b -> (a mod n + b) mod n = (a + b) mod n. Proof. - intros. + intros. rewrite ZOplus_mod. rewrite ZOmod_mod. symmetry. @@ -791,8 +785,8 @@ Proof. destruct b; simpl; auto with zarith. Qed. -Lemma ZOplus_mod_idemp_r: forall a b n, - 0 <= a*b -> +Lemma ZOplus_mod_idemp_r: forall a b n, + 0 <= a*b -> (b + a mod n) mod n = (b + a) mod n. Proof. intros. @@ -822,12 +816,12 @@ Proof. replace (b * (c * (a / b / c) + (a / b) mod c) + a mod b) with ((a / b / c)*(b * c) + (b * ((a / b) mod c) + a mod b)) by ring. assert (b*c<>0). - intro H2; - assert (H3: c <> 0) by auto with zarith; + intro H2; + assert (H3: c <> 0) by auto with zarith; rewrite (Zmult_integral_l _ _ H3 H2) in H0; auto with zarith. assert (0<=a/b) by (apply (ZO_div_pos a b); auto with zarith). assert (0<=a mod b < b) by (apply ZOmod_lt_pos_pos; auto with zarith). - assert (0<=(a/b) mod c < c) by + assert (0<=(a/b) mod c < c) by (apply ZOmod_lt_pos_pos; auto with zarith). rewrite ZO_div_plus_l; auto with zarith. rewrite (ZOdiv_small (b * ((a / b) mod c) + a mod b)). @@ -852,14 +846,14 @@ Proof. intros; destruct b as [ |b|b]. repeat rewrite ZOdiv_0_r; reflexivity. apply H0; auto with zarith. - change (Zneg b) with (-Zpos b); + change (Zneg b) with (-Zpos b); repeat (rewrite ZOdiv_opp_r || rewrite ZOdiv_opp_l || rewrite <- Zopp_mult_distr_l). f_equal; apply H0; auto with zarith. (* a b c general *) intros; destruct c as [ |c|c]. rewrite Zmult_0_r; repeat rewrite ZOdiv_0_r; reflexivity. apply H1; auto with zarith. - change (Zneg c) with (-Zpos c); + change (Zneg c) with (-Zpos c); rewrite <- Zopp_mult_distr_r; do 2 rewrite ZOdiv_opp_r. f_equal; apply H1; auto with zarith. Qed. @@ -870,11 +864,11 @@ Theorem ZOdiv_mult_le: forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b. Proof. intros a b c Ha Hb Hc. - destruct (Zle_lt_or_eq _ _ Ha); + destruct (Zle_lt_or_eq _ _ Ha); [ | subst; rewrite ZOdiv_0_l, Zmult_0_r, ZOdiv_0_l; auto]. - destruct (Zle_lt_or_eq _ _ Hb); + destruct (Zle_lt_or_eq _ _ Hb); [ | subst; rewrite ZOdiv_0_r, ZOdiv_0_r, Zmult_0_r; auto]. - destruct (Zle_lt_or_eq _ _ Hc); + destruct (Zle_lt_or_eq _ _ Hc); [ | subst; rewrite ZOdiv_0_l; auto]. case (ZOmod_lt_pos_pos a b); auto with zarith; intros Hu1 Hu2. case (ZOmod_lt_pos_pos c b); auto with zarith; intros Hv1 Hv2. @@ -890,14 +884,14 @@ Proof. apply (ZOmod_le ((c mod b) * (a mod b)) b); auto with zarith. apply Zmult_le_compat_r; auto with zarith. apply (ZOmod_le c b); auto. - pattern (c * a) at 1; rewrite (ZO_div_mod_eq (c * a) b); try ring; + pattern (c * a) at 1; rewrite (ZO_div_mod_eq (c * a) b); try ring; auto with zarith. pattern a at 1; rewrite (ZO_div_mod_eq a b); try ring; auto with zarith. Qed. (** ZOmod is related to divisibility (see more in Znumtheory) *) -Lemma ZOmod_divides : forall a b, +Lemma ZOmod_divides : forall a b, a mod b = 0 <-> exists c, a = b*c. Proof. split; intros. @@ -916,7 +910,7 @@ Qed. (** They agree at least on positive numbers: *) -Theorem ZOdiv_eucl_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b -> +Theorem ZOdiv_eucl_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b -> a/b = Zdiv.Zdiv a b /\ a mod b = Zdiv.Zmod a b. Proof. intros. @@ -927,7 +921,7 @@ Proof. symmetry; apply ZO_div_mod_eq; auto with *. Qed. -Theorem ZOdiv_Zdiv_pos : forall a b, 0 <= a -> 0 <= b -> +Theorem ZOdiv_Zdiv_pos : forall a b, 0 <= a -> 0 <= b -> a/b = Zdiv.Zdiv a b. Proof. intros a b Ha Hb. @@ -936,7 +930,7 @@ Proof. subst; rewrite ZOdiv_0_r, Zdiv.Zdiv_0_r; reflexivity. Qed. -Theorem ZOmod_Zmod_pos : forall a b, 0 <= a -> 0 < b -> +Theorem ZOmod_Zmod_pos : forall a b, 0 <= a -> 0 < b -> a mod b = Zdiv.Zmod a b. Proof. intros a b Ha Hb; generalize (ZOdiv_eucl_Zdiv_eucl_pos a b Ha Hb); @@ -945,9 +939,9 @@ Qed. (** Modulos are null at the same places *) -Theorem ZOmod_Zmod_zero : forall a b, b<>0 -> +Theorem ZOmod_Zmod_zero : forall a b, b<>0 -> (a mod b = 0 <-> Zdiv.Zmod a b = 0). Proof. intros. rewrite ZOmod_divides, Zdiv.Zmod_divides; intuition. -Qed. +Qed. diff --git a/theories/ZArith/ZOdiv_def.v b/theories/ZArith/ZOdiv_def.v index 2c84765e..88d573bb 100644 --- a/theories/ZArith/ZOdiv_def.v +++ b/theories/ZArith/ZOdiv_def.v @@ -17,9 +17,9 @@ Definition NPgeb (a:N)(b:positive) := | Npos na => match Pcompare na b Eq with Lt => false | _ => true end end. -Fixpoint Pdiv_eucl (a b:positive) {struct a} : N * N := +Fixpoint Pdiv_eucl (a b:positive) : N * N := match a with - | xH => + | xH => match b with xH => (1, 0)%N | _ => (0, 1)%N end | xO a' => let (q, r) := Pdiv_eucl a' b in @@ -33,21 +33,21 @@ Fixpoint Pdiv_eucl (a b:positive) {struct a} : N * N := else (2 * q, r')%N end. -Definition ZOdiv_eucl (a b:Z) : Z * Z := +Definition ZOdiv_eucl (a b:Z) : Z * Z := match a, b with | Z0, _ => (Z0, Z0) | _, Z0 => (Z0, a) - | Zpos na, Zpos nb => - let (nq, nr) := Pdiv_eucl na nb in + | Zpos na, Zpos nb => + let (nq, nr) := Pdiv_eucl na nb in (Z_of_N nq, Z_of_N nr) - | Zneg na, Zpos nb => - let (nq, nr) := Pdiv_eucl na nb in + | Zneg na, Zpos nb => + let (nq, nr) := Pdiv_eucl na nb in (Zopp (Z_of_N nq), Zopp (Z_of_N nr)) - | Zpos na, Zneg nb => - let (nq, nr) := Pdiv_eucl na nb in + | Zpos na, Zneg nb => + let (nq, nr) := Pdiv_eucl na nb in (Zopp (Z_of_N nq), Z_of_N nr) - | Zneg na, Zneg nb => - let (nq, nr) := Pdiv_eucl na nb in + | Zneg na, Zneg nb => + let (nq, nr) := Pdiv_eucl na nb in (Z_of_N nq, Zopp (Z_of_N nr)) end. @@ -55,7 +55,7 @@ Definition ZOdiv a b := fst (ZOdiv_eucl a b). Definition ZOmod a b := snd (ZOdiv_eucl a b). -Definition Ndiv_eucl (a b:N) : N * N := +Definition Ndiv_eucl (a b:N) : N * N := match a, b with | N0, _ => (N0, N0) | _, N0 => (N0, a) @@ -68,13 +68,13 @@ Definition Nmod a b := snd (Ndiv_eucl a b). (* Proofs of specifications for these euclidean divisions. *) -Theorem NPgeb_correct: forall (a:N)(b:positive), +Theorem NPgeb_correct: forall (a:N)(b:positive), if NPgeb a b then a = (Nminus a (Npos b) + Npos b)%N else True. Proof. destruct a; intros; simpl; auto. generalize (Pcompare_Eq_eq p b). case_eq (Pcompare p b Eq); intros; auto. - rewrite H0; auto. + rewrite H0; auto. now rewrite Pminus_mask_diag. destruct (Pminus_mask_Gt p b H) as [d [H2 [H3 _]]]. rewrite H2. rewrite <- H3. @@ -82,11 +82,11 @@ Proof. Qed. Hint Rewrite Z_of_N_plus Z_of_N_mult Z_of_N_minus Zmult_1_l Zmult_assoc - Zmult_plus_distr_l Zmult_plus_distr_r : zdiv. -Hint Rewrite <- Zplus_assoc : zdiv. + Zmult_plus_distr_l Zmult_plus_distr_r : zdiv. +Hint Rewrite <- Zplus_assoc : zdiv. Theorem Pdiv_eucl_correct: forall a b, - let (q,r) := Pdiv_eucl a b in + let (q,r) := Pdiv_eucl a b in Zpos a = Z_of_N q * Zpos b + Z_of_N r. Proof. induction a; cbv beta iota delta [Pdiv_eucl]; fold Pdiv_eucl; cbv zeta. diff --git a/theories/ZArith/ZOrderedType.v b/theories/ZArith/ZOrderedType.v new file mode 100644 index 00000000..570e2a4d --- /dev/null +++ b/theories/ZArith/ZOrderedType.v @@ -0,0 +1,60 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Logic.eq==>iff) Zlt. + Proof. repeat red; intros; subst; auto. Qed. + + Definition le_lteq := Zle_lt_or_eq_iff. + Definition compare_spec := Zcompare_spec. + +End Z_as_OT. + +(** Note that [Z_as_OT] can also be seen as a [UsualOrderedType] + and a [OrderedType] (and also as a [DecidableType]). *) + + + +(** * An [order] tactic for integers *) + +Module ZOrder := OTF_to_OrderTac Z_as_OT. +Ltac z_order := ZOrder.order. + +(** Note that [z_order] is domain-agnostic: it will not prove + [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) + diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v index c15493e3..36eb4110 100644 --- a/theories/ZArith/Zabs.v +++ b/theories/ZArith/Zabs.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* x /\ Zabs x = -x. +Lemma Zabs_spec : forall x:Z, + 0 <= x /\ Zabs x = x \/ + 0 > x /\ Zabs x = -x. Proof. intros; unfold Zabs, Zle, Zgt; destruct x; simpl; intuition discriminate. Qed. @@ -142,7 +143,7 @@ Lemma Zabs_nat_mult: forall n m:Z, Zabs_nat (n*m) = (Zabs_nat n * Zabs_nat m)%na Proof. intros; apply inj_eq_rev. rewrite inj_mult; repeat rewrite inj_Zabs_nat; apply Zabs_Zmult. -Qed. +Qed. Lemma Zabs_nat_Zsucc: forall p, 0 <= p -> Zabs_nat (Zsucc p) = S (Zabs_nat p). @@ -151,13 +152,13 @@ Proof. rewrite inj_S; repeat rewrite inj_Zabs_nat, Zabs_eq; auto with zarith. Qed. -Lemma Zabs_nat_Zplus: +Lemma Zabs_nat_Zplus: forall x y, 0<=x -> 0<=y -> Zabs_nat (x+y) = (Zabs_nat x + Zabs_nat y)%nat. Proof. intros; apply inj_eq_rev. rewrite inj_plus; repeat rewrite inj_Zabs_nat, Zabs_eq; auto with zarith. apply Zplus_le_0_compat; auto. -Qed. +Qed. Lemma Zabs_nat_Zminus: forall x y, 0 <= x <= y -> Zabs_nat (y - x) = (Zabs_nat y - Zabs_nat x)%nat. @@ -200,11 +201,11 @@ Qed. (** A characterization of the sign function: *) -Lemma Zsgn_spec : forall x:Z, - 0 < x /\ Zsgn x = 1 \/ - 0 = x /\ Zsgn x = 0 \/ +Lemma Zsgn_spec : forall x:Z, + 0 < x /\ Zsgn x = 1 \/ + 0 = x /\ Zsgn x = 0 \/ 0 > x /\ Zsgn x = -1. -Proof. +Proof. intros; unfold Zsgn, Zle, Zgt; destruct x; compute; intuition. Qed. diff --git a/theories/ZArith/Zbinary.v b/theories/ZArith/Zbinary.v deleted file mode 100644 index 08f08e12..00000000 --- a/theories/ZArith/Zbinary.v +++ /dev/null @@ -1,352 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Z - two_power_nat_S - : (n:nat)`(two_power_nat (S n)) = 2*(two_power_nat n)` - Z_lt_ge_dec - : (x,y:Z){`x < y`}+{`x >= y`} -*) - - -Section VALUE_OF_BOOLEAN_VECTORS. - -(** Les calculs sont effectus dans la convention positive usuelle. - Les valeurs correspondent soit l'criture binaire (nat), - soit au complment deux (int). - On effectue le calcul suivant le schma de Horner. - Le complment deux n'a de sens que sur les vecteurs de taille - suprieure ou gale un, le bit de signe tant valu ngativement. -*) - - Definition bit_value (b:bool) : Z := - match b with - | true => 1%Z - | false => 0%Z - end. - - Lemma binary_value : forall n:nat, Bvector n -> Z. - Proof. - simple induction n; intros. - exact 0%Z. - - inversion H0. - exact (bit_value a + 2 * H H2)%Z. - Defined. - - Lemma two_compl_value : forall n:nat, Bvector (S n) -> Z. - Proof. - simple induction n; intros. - inversion H. - exact (- bit_value a)%Z. - - inversion H0. - exact (bit_value a + 2 * H H2)%Z. - Defined. - -End VALUE_OF_BOOLEAN_VECTORS. - -Section ENCODING_VALUE. - -(** On calcule la valeur binaire selon un schema de Horner. - Le calcul s'arrete la longueur du vecteur sans vrification. - On definit une fonction Zmod2 calquee sur Zdiv2 mais donnant le quotient - de la division z=2q+r avec 0<=r<=1. - La valeur en complment deux est calcule selon un schema de Horner - avec Zmod2, le paramtre est la taille moins un. -*) - - Definition Zmod2 (z:Z) := - match z with - | Z0 => 0%Z - | Zpos p => match p with - | xI q => Zpos q - | xO q => Zpos q - | xH => 0%Z - end - | Zneg p => - match p with - | xI q => (Zneg q - 1)%Z - | xO q => Zneg q - | xH => (-1)%Z - end - end. - - - Lemma Zmod2_twice : - forall z:Z, z = (2 * Zmod2 z + bit_value (Zeven.Zodd_bool z))%Z. - Proof. - destruct z; simpl in |- *. - trivial. - - destruct p; simpl in |- *; trivial. - - destruct p; simpl in |- *. - destruct p as [p| p| ]; simpl in |- *. - rewrite <- (Pdouble_minus_one_o_succ_eq_xI p); trivial. - - trivial. - - trivial. - - trivial. - - trivial. - Qed. - - Lemma Z_to_binary : forall n:nat, Z -> Bvector n. - Proof. - simple induction n; intros. - exact Bnil. - - exact (Bcons (Zeven.Zodd_bool H0) n0 (H (Zeven.Zdiv2 H0))). - Defined. - - Lemma Z_to_two_compl : forall n:nat, Z -> Bvector (S n). - Proof. - simple induction n; intros. - exact (Bcons (Zeven.Zodd_bool H) 0 Bnil). - - exact (Bcons (Zeven.Zodd_bool H0) (S n0) (H (Zmod2 H0))). - Defined. - -End ENCODING_VALUE. - -Section Z_BRIC_A_BRAC. - - (** Bibliotheque de lemmes utiles dans la section suivante. - Utilise largement ZArith. - Mriterait d'tre rcrite. - *) - - Lemma binary_value_Sn : - forall (n:nat) (b:bool) (bv:Bvector n), - binary_value (S n) (Vcons bool b n bv) = - (bit_value b + 2 * binary_value n bv)%Z. - Proof. - intros; auto. - Qed. - - Lemma Z_to_binary_Sn : - forall (n:nat) (b:bool) (z:Z), - (z >= 0)%Z -> - Z_to_binary (S n) (bit_value b + 2 * z) = Bcons b n (Z_to_binary n z). - Proof. - destruct b; destruct z; simpl in |- *; auto. - intro H; elim H; trivial. - Qed. - - 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 in |- *. - omega. - - destruct a; destruct (binary_value n v); simpl in |- *; auto. - auto with zarith. - Qed. - - Lemma two_compl_value_Sn : - forall (n:nat) (bv:Bvector (S n)) (b:bool), - two_compl_value (S n) (Bcons b (S n) bv) = - (bit_value b + 2 * two_compl_value n bv)%Z. - Proof. - intros; auto. - Qed. - - Lemma Z_to_two_compl_Sn : - forall (n:nat) (b:bool) (z:Z), - Z_to_two_compl (S n) (bit_value b + 2 * z) = - Bcons b (S n) (Z_to_two_compl n z). - Proof. - destruct b; destruct z as [| p| p]; auto. - destruct p as [p| p| ]; auto. - destruct p as [p| p| ]; simpl in |- *; auto. - intros; rewrite (Psucc_o_double_minus_one_eq_xO p); trivial. - Qed. - - Lemma Z_to_binary_Sn_z : - forall (n:nat) (z:Z), - Z_to_binary (S n) z = - Bcons (Zeven.Zodd_bool z) n (Z_to_binary n (Zeven.Zdiv2 z)). - Proof. - intros; auto. - Qed. - - Lemma Z_div2_value : - forall z:Z, - (z >= 0)%Z -> (bit_value (Zeven.Zodd_bool z) + 2 * Zeven.Zdiv2 z)%Z = z. - Proof. - destruct z as [| p| p]; auto. - destruct p; auto. - intro H; elim H; trivial. - Qed. - - Lemma Pdiv2 : forall z:Z, (z >= 0)%Z -> (Zeven.Zdiv2 z >= 0)%Z. - Proof. - destruct z as [| p| p]. - auto. - - destruct p; auto. - simpl in |- *; intros; omega. - - intro H; elim H; trivial. - Qed. - - Lemma Zdiv2_two_power_nat : - forall (z:Z) (n:nat), - (z >= 0)%Z -> - (z < two_power_nat (S n))%Z -> (Zeven.Zdiv2 z < two_power_nat n)%Z. - Proof. - intros. - cut (2 * Zeven.Zdiv2 z < 2 * two_power_nat n)%Z; intros. - omega. - - rewrite <- two_power_nat_S. - destruct (Zeven.Zeven_odd_dec z); intros. - rewrite <- Zeven.Zeven_div2; auto. - - generalize (Zeven.Zodd_div2 z H z0); omega. - Qed. - - Lemma Z_to_two_compl_Sn_z : - forall (n:nat) (z:Z), - Z_to_two_compl (S n) z = - Bcons (Zeven.Zodd_bool z) (S n) (Z_to_two_compl n (Zmod2 z)). - Proof. - intros; auto. - Qed. - - Lemma Zeven_bit_value : - forall z:Z, Zeven.Zeven z -> bit_value (Zeven.Zodd_bool z) = 0%Z. - Proof. - destruct z; unfold bit_value in |- *; auto. - destruct p; tauto || (intro H; elim H). - destruct p; tauto || (intro H; elim H). - Qed. - - Lemma Zodd_bit_value : - forall z:Z, Zeven.Zodd z -> bit_value (Zeven.Zodd_bool z) = 1%Z. - Proof. - destruct z; unfold bit_value in |- *; auto. - intros; elim H. - destruct p; tauto || (intros; elim H). - destruct p; tauto || (intros; elim H). - Qed. - - Lemma Zge_minus_two_power_nat_S : - forall (n:nat) (z:Z), - (z >= - two_power_nat (S n))%Z -> (Zmod2 z >= - two_power_nat n)%Z. - Proof. - intros n z; rewrite (two_power_nat_S n). - generalize (Zmod2_twice z). - destruct (Zeven.Zeven_odd_dec z) as [H| H]. - rewrite (Zeven_bit_value z H); intros; omega. - - rewrite (Zodd_bit_value z H); intros; omega. - Qed. - - Lemma Zlt_two_power_nat_S : - forall (n:nat) (z:Z), - (z < two_power_nat (S n))%Z -> (Zmod2 z < two_power_nat n)%Z. - Proof. - intros n z; rewrite (two_power_nat_S n). - generalize (Zmod2_twice z). - destruct (Zeven.Zeven_odd_dec z) as [H| H]. - rewrite (Zeven_bit_value z H); intros; omega. - - rewrite (Zodd_bit_value z H); intros; omega. - Qed. - -End Z_BRIC_A_BRAC. - -Section COHERENT_VALUE. - -(** On vrifie que dans l'intervalle de dfinition les fonctions sont - rciproques l'une de l'autre. Elles utilisent les lemmes du bric-a-brac. -*) - - Lemma binary_to_Z_to_binary : - forall (n:nat) (bv:Bvector n), Z_to_binary n (binary_value n bv) = bv. - Proof. - induction bv as [| a n bv IHbv]. - auto. - - rewrite binary_value_Sn. - rewrite Z_to_binary_Sn. - rewrite IHbv; trivial. - - apply binary_value_pos. - Qed. - - Lemma two_compl_to_Z_to_two_compl : - forall (n:nat) (bv:Bvector n) (b:bool), - Z_to_two_compl n (two_compl_value n (Bcons b n bv)) = Bcons b n bv. - Proof. - induction bv as [| a n bv IHbv]; intro b. - destruct b; auto. - - rewrite two_compl_value_Sn. - rewrite Z_to_two_compl_Sn. - rewrite IHbv; trivial. - Qed. - - Lemma Z_to_binary_to_Z : - forall (n:nat) (z:Z), - (z >= 0)%Z -> - (z < two_power_nat n)%Z -> binary_value n (Z_to_binary n z) = z. - Proof. - induction n as [| n IHn]. - unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros; omega. - - intros; rewrite Z_to_binary_Sn_z. - rewrite binary_value_Sn. - rewrite IHn. - apply Z_div2_value; auto. - - apply Pdiv2; trivial. - - apply Zdiv2_two_power_nat; trivial. - Qed. - - Lemma Z_to_two_compl_to_Z : - forall (n:nat) (z:Z), - (z >= - two_power_nat n)%Z -> - (z < two_power_nat n)%Z -> two_compl_value n (Z_to_two_compl n z) = z. - Proof. - induction n as [| n IHn]. - unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros. - assert (z = (-1)%Z \/ z = 0%Z). omega. - intuition; subst z; trivial. - - intros; rewrite Z_to_two_compl_Sn_z. - rewrite two_compl_value_Sn. - rewrite IHn. - generalize (Zmod2_twice z); omega. - - apply Zge_minus_two_power_nat_S; auto. - - apply Zlt_two_power_nat_S; auto. - Qed. - -End COHERENT_VALUE. diff --git a/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v index 34771897..8cdd73cc 100644 --- a/theories/ZArith/Zbool.v +++ b/theories/ZArith/Zbool.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Zbool.v 12271 2009-08-11 10:29:45Z herbelin $ *) +(* $Id$ *) Require Import BinInt. Require Import Zeven. @@ -228,3 +228,8 @@ Proof. discriminate. Qed. +Lemma Zeq_bool_if : forall x y, if Zeq_bool x y then x=y else x<>y. +Proof. + intros. generalize (Zeq_bool_eq x y)(Zeq_bool_neq x y). + destruct Zeq_bool; auto. +Qed. \ No newline at end of file diff --git a/theories/ZArith/Zcompare.v b/theories/ZArith/Zcompare.v index 8244d4ce..3e611d54 100644 --- a/theories/ZArith/Zcompare.v +++ b/theories/ZArith/Zcompare.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* - let H := fresh "H" in +Ltac destr_zcompare := + match goal with |- context [Zcompare ?x ?y] => + let H := fresh "H" in case_eq (Zcompare x y); intro H; [generalize (Zcompare_Eq_eq _ _ H); clear H; intro H | - change (xy)%Z in H ] end. @@ -58,35 +59,48 @@ Qed. Lemma Zcompare_antisym : forall n m:Z, CompOpp (n ?= m) = (m ?= n). Proof. intros x y; destruct x; destruct y; simpl in |- *; - reflexivity || discriminate H || rewrite Pcompare_antisym; + reflexivity || discriminate H || rewrite Pcompare_antisym; reflexivity. Qed. Lemma Zcompare_Gt_Lt_antisym : forall n m:Z, (n ?= m) = Gt <-> (m ?= n) = Lt. Proof. - intros x y; split; intro H; - [ change Lt with (CompOpp Gt) in |- *; rewrite <- Zcompare_antisym; - rewrite H; reflexivity - | change Gt with (CompOpp Lt) in |- *; rewrite <- Zcompare_antisym; - rewrite H; reflexivity ]. + intros x y. + rewrite <- Zcompare_antisym. change Gt with (CompOpp Lt). + split. + auto using CompOpp_inj. + intros; f_equal; auto. Qed. +Lemma Zcompare_spec : forall n m, CompSpec eq Zlt n m (n ?= m). +Proof. + intros. + destruct (n?=m) as [ ]_eqn:H; constructor; auto. + apply Zcompare_Eq_eq; auto. + red; rewrite <- Zcompare_antisym, H; auto. +Qed. + + (** * Transitivity of comparison *) +Lemma Zcompare_Lt_trans : + forall n m p:Z, (n ?= m) = Lt -> (m ?= p) = Lt -> (n ?= p) = Lt. +Proof. + intros x y z; case x; case y; case z; simpl; + try discriminate; auto with arith. + intros; eapply Plt_trans; eauto. + intros p q r; rewrite 3 Pcompare_antisym; simpl. + intros; eapply Plt_trans; eauto. +Qed. + Lemma Zcompare_Gt_trans : forall n m p:Z, (n ?= m) = Gt -> (m ?= p) = Gt -> (n ?= p) = Gt. Proof. - intros x y z; case x; case y; case z; simpl in |- *; - try (intros; discriminate H || discriminate H0); auto with arith; - [ intros p q r H H0; apply nat_of_P_gt_Gt_compare_complement_morphism; - unfold gt in |- *; apply lt_trans with (m := nat_of_P q); - apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; - assumption - | intros p q r; do 3 rewrite <- ZC4; intros H H0; - apply nat_of_P_gt_Gt_compare_complement_morphism; - unfold gt in |- *; apply lt_trans with (m := nat_of_P q); - apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; - assumption ]. + intros n m p Hnm Hmp. + apply <- Zcompare_Gt_Lt_antisym. + apply -> Zcompare_Gt_Lt_antisym in Hnm. + apply -> Zcompare_Gt_Lt_antisym in Hmp. + eapply Zcompare_Lt_trans; eauto. Qed. (** * Comparison and opposite *) @@ -129,7 +143,7 @@ Proof. [ reflexivity | apply H | rewrite (Zcompare_opp x y); rewrite Zcompare_opp; - do 2 rewrite Zopp_plus_distr; rewrite Zopp_neg; + do 2 rewrite Zopp_plus_distr; rewrite Zopp_neg; apply H ]. Qed. @@ -145,7 +159,7 @@ Proof. rewrite nat_of_P_minus_morphism; [ unfold gt in |- *; apply ZL16 | assumption ] | intros p; ElimPcompare z p; intros E; auto with arith; - apply nat_of_P_gt_Gt_compare_complement_morphism; + apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *; apply ZL17 | intros p q; ElimPcompare q p; intros E; rewrite E; [ rewrite (Pcompare_Eq_eq q p E); apply Pcompare_refl @@ -170,7 +184,7 @@ Proof. [ apply lt_trans with (m := nat_of_P z); [ apply ZL16 | apply ZL17 ] | assumption ] | intros p q; ElimPcompare z q; intros E0; rewrite E0; ElimPcompare z p; - intros E1; rewrite E1; ElimPcompare q p; intros E2; + intros E1; rewrite E1; ElimPcompare q p; intros E2; rewrite E2; auto with arith; [ absurd ((q ?= p)%positive Eq = Lt); [ rewrite <- (Pcompare_Eq_eq z q E0); @@ -273,7 +287,7 @@ Proof. [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P q); rewrite plus_assoc; rewrite le_plus_minus_r; [ rewrite (plus_comm (nat_of_P q)); apply plus_lt_compat_l; - apply nat_of_P_lt_Lt_compare_morphism; + apply nat_of_P_lt_Lt_compare_morphism; assumption | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption ] @@ -289,7 +303,7 @@ Proof. [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p); rewrite plus_assoc; rewrite le_plus_minus_r; [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l; - apply nat_of_P_lt_Lt_compare_morphism; + apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption ] @@ -330,7 +344,7 @@ Qed. Lemma Zcompare_succ_Gt : forall n:Z, (Zsucc n ?= n) = Gt. Proof. intro x; unfold Zsucc in |- *; pattern x at 2 in |- *; - rewrite <- (Zplus_0_r x); rewrite Zcompare_plus_compat; + rewrite <- (Zplus_0_r x); rewrite Zcompare_plus_compat; reflexivity. Qed. @@ -351,7 +365,7 @@ Proof. apply nat_of_P_lt_Lt_compare_morphism; change ((Zpos h ?= 1) = Lt) in |- *; rewrite <- H2; rewrite <- (fun m n:Z => Zcompare_plus_compat m n y); - rewrite (Zplus_comm x); rewrite Zplus_assoc; + rewrite (Zplus_comm x); rewrite Zplus_assoc; rewrite Zplus_opp_r; simpl in |- *; exact H1 ] ] | intros H1; rewrite H1; discriminate ] | intros H; elim_compare x (y + 1); @@ -369,7 +383,7 @@ Proof. intros n m; unfold Zsucc in |- *; do 2 rewrite (fun t:Z => Zplus_comm t 1); rewrite Zcompare_plus_compat; auto with arith. Qed. - + (** * Multiplication and comparison *) Lemma Zcompare_mult_compat : @@ -394,7 +408,7 @@ Qed. Lemma rename : forall (A:Type) (P:A -> Prop) (x:A), (forall y:A, x = y -> P y) -> P x. Proof. - auto with arith. + auto with arith. Qed. Lemma Zcompare_elim : @@ -473,7 +487,7 @@ Lemma Zge_compare : | Gt => True end. Proof. - intros x y; unfold Zge in |- *; elim (x ?= y); auto with arith. + intros x y; unfold Zge in |- *; elim (x ?= y); auto with arith. Qed. Lemma Zgt_compare : diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v index c6ade934..08cc564d 100644 --- a/theories/ZArith/Zcomplements.v +++ b/theories/ZArith/Zcomplements.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zcomplements.v 10617 2008-03-04 18:07:16Z letouzey $ i*) +(*i $Id$ i*) Require Import ZArithRing. Require Import ZArith_base. @@ -19,26 +19,26 @@ Open Local Scope Z_scope. (** About parity *) Lemma two_or_two_plus_one : - forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}. + forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}. Proof. intro x; destruct x. left; split with 0; reflexivity. - + destruct p. right; split with (Zpos p); reflexivity. - + left; split with (Zpos p); reflexivity. - + right; split with 0; reflexivity. - + destruct p. right; split with (Zneg (1 + p)). rewrite BinInt.Zneg_xI. rewrite BinInt.Zneg_plus_distr. omega. - + left; split with (Zneg p); reflexivity. - + right; split with (-1); reflexivity. Qed. @@ -64,24 +64,24 @@ Proof. trivial. Qed. -Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p. +Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p. Proof. unfold floor in |- *. intro a; induction a as [p| p| ]. - + simpl in |- *. repeat rewrite BinInt.Zpos_xI. - rewrite (BinInt.Zpos_xO (xO (floor_pos p))). + rewrite (BinInt.Zpos_xO (xO (floor_pos p))). rewrite (BinInt.Zpos_xO (floor_pos p)). omega. - + simpl in |- *. repeat rewrite BinInt.Zpos_xI. rewrite (BinInt.Zpos_xO (xO (floor_pos p))). rewrite (BinInt.Zpos_xO (floor_pos p)). rewrite (BinInt.Zpos_xO p). omega. - + simpl in |- *; omega. Qed. @@ -128,7 +128,7 @@ Proof. elim (Zabs_dec m); intro eq; rewrite eq; trivial. Qed. -(** To do case analysis over the sign of [z] *) +(** To do case analysis over the sign of [z] *) Lemma Zcase_sign : forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P. @@ -160,11 +160,11 @@ Qed. Require Import List. -Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) {struct l} : Z := +Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) : Z := match l with | nil => acc | _ :: l => Zlength_aux (Zsucc acc) A l - end. + end. Definition Zlength := Zlength_aux 0. Implicit Arguments Zlength [A]. @@ -177,7 +177,7 @@ Section Zlength_properties. Lemma Zlength_correct : forall l, Zlength l = Z_of_nat (length l). Proof. - assert (forall l (acc:Z), Zlength_aux acc A l = acc + Z_of_nat (length l)). + assert (forall l (acc:Z), Zlength_aux acc A l = acc + Z_of_nat (length l)). simple induction l. simpl in |- *; auto with zarith. intros; simpl (length (a :: l0)) in |- *; rewrite Znat.inj_S. @@ -202,7 +202,7 @@ Section Zlength_properties. case l; auto. intros x l'; simpl (length (x :: l')) in |- *. rewrite Znat.inj_S. - intros; elimtype False; generalize (Zle_0_nat (length l')); omega. + intros; exfalso; generalize (Zle_0_nat (length l')); omega. Qed. End Zlength_properties. diff --git a/theories/ZArith/Zdigits.v b/theories/ZArith/Zdigits.v new file mode 100644 index 00000000..0a6c9498 --- /dev/null +++ b/theories/ZArith/Zdigits.v @@ -0,0 +1,347 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 1%Z + | false => 0%Z + end. + + Lemma binary_value : forall n:nat, Bvector n -> Z. + Proof. + simple induction n; intros. + exact 0%Z. + + inversion H0. + exact (bit_value a + 2 * H H2)%Z. + Defined. + + Lemma two_compl_value : forall n:nat, Bvector (S n) -> Z. + Proof. + simple induction n; intros. + inversion H. + exact (- bit_value a)%Z. + + inversion H0. + exact (bit_value a + 2 * H H2)%Z. + Defined. + +End VALUE_OF_BOOLEAN_VECTORS. + +Section ENCODING_VALUE. + +(** We compute the binary value via a Horner scheme. + Computation stops at the vector length without checks. + We define a function Zmod2 similar to Zdiv2 returning the + quotient of division z=2q+r with 0<=r<=1. + The two's complement value is also computed via a Horner scheme + with Zmod2, the parameter is the size minus one. +*) + + Definition Zmod2 (z:Z) := + match z with + | Z0 => 0%Z + | Zpos p => match p with + | xI q => Zpos q + | xO q => Zpos q + | xH => 0%Z + end + | Zneg p => + match p with + | xI q => (Zneg q - 1)%Z + | xO q => Zneg q + | xH => (-1)%Z + end + end. + + + Lemma Zmod2_twice : + forall z:Z, z = (2 * Zmod2 z + bit_value (Zeven.Zodd_bool z))%Z. + Proof. + destruct z; simpl in |- *. + trivial. + + destruct p; simpl in |- *; trivial. + + destruct p; simpl in |- *. + destruct p as [p| p| ]; simpl in |- *. + rewrite <- (Pdouble_minus_one_o_succ_eq_xI p); trivial. + + trivial. + + trivial. + + trivial. + + trivial. + Qed. + + Lemma Z_to_binary : forall n:nat, Z -> Bvector n. + Proof. + simple induction n; intros. + exact Bnil. + + exact (Bcons (Zeven.Zodd_bool H0) n0 (H (Zeven.Zdiv2 H0))). + Defined. + + Lemma Z_to_two_compl : forall n:nat, Z -> Bvector (S n). + Proof. + simple induction n; intros. + exact (Bcons (Zeven.Zodd_bool H) 0 Bnil). + + exact (Bcons (Zeven.Zodd_bool H0) (S n0) (H (Zmod2 H0))). + Defined. + +End ENCODING_VALUE. + +Section Z_BRIC_A_BRAC. + + (** Some auxiliary lemmas used in the next section. Large use of ZArith. + Deserve to be properly rewritten. + *) + + Lemma binary_value_Sn : + forall (n:nat) (b:bool) (bv:Bvector n), + binary_value (S n) (Vcons bool b n bv) = + (bit_value b + 2 * binary_value n bv)%Z. + Proof. + intros; auto. + Qed. + + Lemma Z_to_binary_Sn : + forall (n:nat) (b:bool) (z:Z), + (z >= 0)%Z -> + Z_to_binary (S n) (bit_value b + 2 * z) = Bcons b n (Z_to_binary n z). + Proof. + destruct b; destruct z; simpl in |- *; auto. + intro H; elim H; trivial. + Qed. + + 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 in |- *. + omega. + + destruct a; destruct (binary_value n v); simpl in |- *; auto. + auto with zarith. + Qed. + + Lemma two_compl_value_Sn : + forall (n:nat) (bv:Bvector (S n)) (b:bool), + two_compl_value (S n) (Bcons b (S n) bv) = + (bit_value b + 2 * two_compl_value n bv)%Z. + Proof. + intros; auto. + Qed. + + Lemma Z_to_two_compl_Sn : + forall (n:nat) (b:bool) (z:Z), + Z_to_two_compl (S n) (bit_value b + 2 * z) = + Bcons b (S n) (Z_to_two_compl n z). + Proof. + destruct b; destruct z as [| p| p]; auto. + destruct p as [p| p| ]; auto. + destruct p as [p| p| ]; simpl in |- *; auto. + intros; rewrite (Psucc_o_double_minus_one_eq_xO p); trivial. + Qed. + + Lemma Z_to_binary_Sn_z : + forall (n:nat) (z:Z), + Z_to_binary (S n) z = + Bcons (Zeven.Zodd_bool z) n (Z_to_binary n (Zeven.Zdiv2 z)). + Proof. + intros; auto. + Qed. + + Lemma Z_div2_value : + forall z:Z, + (z >= 0)%Z -> (bit_value (Zeven.Zodd_bool z) + 2 * Zeven.Zdiv2 z)%Z = z. + Proof. + destruct z as [| p| p]; auto. + destruct p; auto. + intro H; elim H; trivial. + Qed. + + Lemma Pdiv2 : forall z:Z, (z >= 0)%Z -> (Zeven.Zdiv2 z >= 0)%Z. + Proof. + destruct z as [| p| p]. + auto. + + destruct p; auto. + simpl in |- *; intros; omega. + + intro H; elim H; trivial. + Qed. + + Lemma Zdiv2_two_power_nat : + forall (z:Z) (n:nat), + (z >= 0)%Z -> + (z < two_power_nat (S n))%Z -> (Zeven.Zdiv2 z < two_power_nat n)%Z. + Proof. + intros. + cut (2 * Zeven.Zdiv2 z < 2 * two_power_nat n)%Z; intros. + omega. + + rewrite <- two_power_nat_S. + destruct (Zeven.Zeven_odd_dec z); intros. + rewrite <- Zeven.Zeven_div2; auto. + + generalize (Zeven.Zodd_div2 z H z0); omega. + Qed. + + Lemma Z_to_two_compl_Sn_z : + forall (n:nat) (z:Z), + Z_to_two_compl (S n) z = + Bcons (Zeven.Zodd_bool z) (S n) (Z_to_two_compl n (Zmod2 z)). + Proof. + intros; auto. + Qed. + + Lemma Zeven_bit_value : + forall z:Z, Zeven.Zeven z -> bit_value (Zeven.Zodd_bool z) = 0%Z. + Proof. + destruct z; unfold bit_value in |- *; auto. + destruct p; tauto || (intro H; elim H). + destruct p; tauto || (intro H; elim H). + Qed. + + Lemma Zodd_bit_value : + forall z:Z, Zeven.Zodd z -> bit_value (Zeven.Zodd_bool z) = 1%Z. + Proof. + destruct z; unfold bit_value in |- *; auto. + intros; elim H. + destruct p; tauto || (intros; elim H). + destruct p; tauto || (intros; elim H). + Qed. + + Lemma Zge_minus_two_power_nat_S : + forall (n:nat) (z:Z), + (z >= - two_power_nat (S n))%Z -> (Zmod2 z >= - two_power_nat n)%Z. + Proof. + intros n z; rewrite (two_power_nat_S n). + generalize (Zmod2_twice z). + destruct (Zeven.Zeven_odd_dec z) as [H| H]. + rewrite (Zeven_bit_value z H); intros; omega. + + rewrite (Zodd_bit_value z H); intros; omega. + Qed. + + Lemma Zlt_two_power_nat_S : + forall (n:nat) (z:Z), + (z < two_power_nat (S n))%Z -> (Zmod2 z < two_power_nat n)%Z. + Proof. + intros n z; rewrite (two_power_nat_S n). + generalize (Zmod2_twice z). + destruct (Zeven.Zeven_odd_dec z) as [H| H]. + rewrite (Zeven_bit_value z H); intros; omega. + + rewrite (Zodd_bit_value z H); intros; omega. + Qed. + +End Z_BRIC_A_BRAC. + +Section COHERENT_VALUE. + +(** We check that the functions are reciprocal on the definition interval. + This uses earlier library lemmas. +*) + + Lemma binary_to_Z_to_binary : + forall (n:nat) (bv:Bvector n), Z_to_binary n (binary_value n bv) = bv. + Proof. + induction bv as [| a n bv IHbv]. + auto. + + rewrite binary_value_Sn. + rewrite Z_to_binary_Sn. + rewrite IHbv; trivial. + + apply binary_value_pos. + Qed. + + Lemma two_compl_to_Z_to_two_compl : + forall (n:nat) (bv:Bvector n) (b:bool), + Z_to_two_compl n (two_compl_value n (Bcons b n bv)) = Bcons b n bv. + Proof. + induction bv as [| a n bv IHbv]; intro b. + destruct b; auto. + + rewrite two_compl_value_Sn. + rewrite Z_to_two_compl_Sn. + rewrite IHbv; trivial. + Qed. + + Lemma Z_to_binary_to_Z : + forall (n:nat) (z:Z), + (z >= 0)%Z -> + (z < two_power_nat n)%Z -> binary_value n (Z_to_binary n z) = z. + Proof. + induction n as [| n IHn]. + unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros; omega. + + intros; rewrite Z_to_binary_Sn_z. + rewrite binary_value_Sn. + rewrite IHn. + apply Z_div2_value; auto. + + apply Pdiv2; trivial. + + apply Zdiv2_two_power_nat; trivial. + Qed. + + Lemma Z_to_two_compl_to_Z : + forall (n:nat) (z:Z), + (z >= - two_power_nat n)%Z -> + (z < two_power_nat n)%Z -> two_compl_value n (Z_to_two_compl n z) = z. + Proof. + induction n as [| n IHn]. + unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros. + assert (z = (-1)%Z \/ z = 0%Z). omega. + intuition; subst z; trivial. + + intros; rewrite Z_to_two_compl_Sn_z. + rewrite two_compl_value_Sn. + rewrite IHn. + generalize (Zmod2_twice z); omega. + + apply Zge_minus_two_power_nat_S; auto. + + apply Zlt_two_power_nat_S; auto. + Qed. + +End COHERENT_VALUE. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 228a882a..f3e65697 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* if Zge_bool b 2 then (0, 1) else (1, 0) | xO a' => @@ -50,41 +50,41 @@ Unboxed Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} : (** Euclidean division of integers. - - Total function than returns (0,0) when dividing by 0. -*) - -(** + + Total function than returns (0,0) when dividing by 0. +*) + +(** The pseudo-code is: - + if b = 0 : (0,0) - + if b <> 0 and a = 0 : (0,0) - if b > 0 and a < 0 : let (q,r) = div_eucl_pos (-a) b in + if b > 0 and a < 0 : let (q,r) = div_eucl_pos (-a) b in if r = 0 then (-q,0) else (-(q+1),b-r) if b < 0 and a < 0 : let (q,r) = div_eucl (-a) (-b) in (q,-r) - if b < 0 and a > 0 : let (q,r) = div_eucl a (-b) in + if b < 0 and a > 0 : let (q,r) = div_eucl a (-b) in if r = 0 then (-q,0) else (-(q+1),b+r) - In other word, when b is non-zero, q is chosen to be the greatest integer - smaller or equal to a/b. And sgn(r)=sgn(b) and |r| < |b| (at least when - r is not null). + In other word, when b is non-zero, q is chosen to be the greatest integer + smaller or equal to a/b. And sgn(r)=sgn(b) and |r| < |b| (at least when + r is not null). *) (* Nota: At least two others conventions also exist for euclidean division. - They all satify the equation a=b*q+r, but differ on the choice of (q,r) + They all satify the equation a=b*q+r, but differ on the choice of (q,r) on negative numbers. * Ocaml uses Round-Toward-Zero division: (-a)/b = a/(-b) = -(a/b). Hence (-a) mod b = - (a mod b) a mod (-b) = a mod b - And: |r| < |b| and sgn(r) = sgn(a) (notice the a here instead of b). + And: |r| < |b| and sgn(r) = sgn(a) (notice the a here instead of b). - * Another solution is to always pick a non-negative remainder: + * Another solution is to always pick a non-negative remainder: a=b*q+r with 0 <= r < |b| *) @@ -113,7 +113,7 @@ Definition Zdiv_eucl (a b:Z) : Z * Z := Definition Zdiv (a b:Z) : Z := let (q, _) := Zdiv_eucl a b in q. -Definition Zmod (a b:Z) : Z := let (_, r) := Zdiv_eucl a b in r. +Definition Zmod (a b:Z) : Z := let (_, r) := Zdiv_eucl a b in r. (** Syntax *) @@ -122,7 +122,7 @@ Infix "mod" := Zmod (at level 40, no associativity) : Z_scope. (* Tests: -Eval compute in (Zdiv_eucl 7 3). +Eval compute in (Zdiv_eucl 7 3). Eval compute in (Zdiv_eucl (-7) 3). @@ -133,7 +133,7 @@ Eval compute in (Zdiv_eucl (-7) (-3)). *) -(** * Main division theorem *) +(** * Main division theorem *) (** First a lemma for two positive arguments *) @@ -170,7 +170,7 @@ Theorem Z_div_mod : Proof. intros a b; case a; case b; try (simpl in |- *; intros; omega). unfold Zdiv_eucl in |- *; intros; apply Z_div_mod_POS; trivial. - + intros; discriminate. intros. @@ -179,25 +179,25 @@ Proof. case (Zdiv_eucl_POS p0 (Zpos p)). intros z z0. case z0. - + intros [H1 H2]. split; trivial. change (Zneg p0) with (- Zpos p0); rewrite H1; ring. - + intros p1 [H1 H2]. split; trivial. change (Zneg p0) with (- Zpos p0); rewrite H1; ring. generalize (Zorder.Zgt_pos_0 p1); omega. - + intros p1 [H1 H2]. split; trivial. change (Zneg p0) with (- Zpos p0); rewrite H1; ring. generalize (Zorder.Zlt_neg_0 p1); omega. - + intros; discriminate. Qed. -(** For stating the fully general result, let's give a short name +(** For stating the fully general result, let's give a short name to the condition on the remainder. *) Definition Remainder r b := 0 <= r < b \/ b < r <= 0. @@ -206,7 +206,7 @@ Definition Remainder r b := 0 <= r < b \/ b < r <= 0. Definition Remainder_alt r b := Zabs r < Zabs b /\ Zsgn r <> - Zsgn b. -(* In the last formulation, [ Zsgn r <> - Zsgn b ] is less nice than saying +(* In the last formulation, [ Zsgn r <> - Zsgn b ] is less nice than saying [ Zsgn r = Zsgn b ], but at least it works even when [r] is null. *) Lemma Remainder_equiv : forall r b, Remainder r b <-> Remainder_alt r b. @@ -250,7 +250,7 @@ Proof. destruct Zdiv_eucl_POS as (q,r). destruct r as [|r|r]; change (Zneg b) with (-Zpos b). rewrite Zmult_opp_comm; omega with *. - rewrite <- Zmult_opp_comm, Zmult_plus_distr_r; + rewrite <- Zmult_opp_comm, Zmult_plus_distr_r; repeat rewrite Zmult_opp_comm; omega. rewrite Zmult_opp_comm; omega with *. Qed. @@ -331,14 +331,14 @@ elim (Zlt_not_le (Zabs (r2 - r1)) (Zabs b)). omega with *. replace (r2-r1) with (b*(q1-q2)) by (rewrite Zmult_minus_distr_l; omega). replace (Zabs b) with ((Zabs b)*1) by ring. -rewrite Zabs_Zmult. +rewrite Zabs_Zmult. apply Zmult_le_compat_l; auto with *. omega with *. Qed. Theorem Zdiv_mod_unique_2 : forall b q1 q2 r1 r2:Z, - Remainder r1 b -> Remainder r2 b -> + Remainder r1 b -> Remainder r2 b -> b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2. Proof. unfold Remainder. @@ -356,7 +356,7 @@ omega with *. Qed. Theorem Zdiv_unique_full: - forall a b q r, Remainder r b -> + forall a b q r, Remainder r b -> a = b*q + r -> q = a/b. Proof. intros. @@ -368,7 +368,7 @@ Proof. Qed. Theorem Zdiv_unique: - forall a b q r, 0 <= r < b -> + forall a b q r, 0 <= r < b -> a = b*q + r -> q = a/b. Proof. intros; eapply Zdiv_unique_full; eauto. @@ -425,7 +425,7 @@ Proof. intros; symmetry; apply Zdiv_unique with 0; auto with zarith. Qed. -Hint Resolve Zmod_0_l Zmod_0_r Zdiv_0_l Zdiv_0_r Zdiv_1_r Zmod_1_r +Hint Resolve Zmod_0_l Zmod_0_r Zdiv_0_l Zdiv_0_r Zdiv_1_r Zmod_1_r : zarith. Lemma Zdiv_1_l: forall a, 1 < a -> 1/a = 0. @@ -460,7 +460,7 @@ Qed. Lemma Z_div_mult_full : forall a b:Z, b <> 0 -> (a*b)/b = a. Proof. - intros; symmetry; apply Zdiv_unique_full with 0; auto with zarith; + intros; symmetry; apply Zdiv_unique_full with 0; auto with zarith; [ red; omega | ring]. Qed. @@ -485,7 +485,7 @@ Proof. intros; generalize (Z_div_pos a b H); auto with zarith. Qed. -(** As soon as the divisor is greater or equal than 2, +(** As soon as the divisor is greater or equal than 2, the division is strictly decreasing. *) Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> a/b < a. @@ -530,7 +530,7 @@ Proof. intro. absurd (b - a >= 1). omega. - replace (b-a) with (c * (b/c-a/c) + b mod c - a mod c) by + replace (b-a) with (c * (b/c-a/c) + b mod c - a mod c) by (symmetry; pattern a at 1; rewrite H2; pattern b at 1; rewrite H0; ring). assert (c * (b / c - a / c) >= c * 1). apply Zmult_ge_compat_l. @@ -580,7 +580,7 @@ Qed. (** A modulo cannot grow beyond its starting point. *) Theorem Zmod_le: forall a b, 0 < b -> 0 <= a -> a mod b <= a. -Proof. +Proof. intros a b H1 H2; case (Zle_or_lt b a); intros H3. case (Z_mod_lt a b); auto with zarith. rewrite Zmod_small; auto with zarith. @@ -588,45 +588,38 @@ Qed. (** Some additionnal inequalities about Zdiv. *) -Theorem Zdiv_le_upper_bound: - forall a b q, 0 <= a -> 0 < b -> a <= q*b -> a/b <= q. +Theorem Zdiv_lt_upper_bound: + forall a b q, 0 < b -> a < q*b -> a/b < q. Proof. - intros a b q H1 H2 H3. - apply Zmult_le_reg_r with b; auto with zarith. - apply Zle_trans with (2 := H3). + intros a b q H1 H2. + apply Zmult_lt_reg_r with b; auto with zarith. + apply Zle_lt_trans with (2 := H2). pattern a at 2; rewrite (Z_div_mod_eq a b); auto with zarith. rewrite (Zmult_comm b); case (Z_mod_lt a b); auto with zarith. Qed. -Theorem Zdiv_lt_upper_bound: - forall a b q, 0 <= a -> 0 < b -> a < q*b -> a/b < q. +Theorem Zdiv_le_upper_bound: + forall a b q, 0 < b -> a <= q*b -> a/b <= q. Proof. - intros a b q H1 H2 H3. - apply Zmult_lt_reg_r with b; auto with zarith. - apply Zle_lt_trans with (2 := H3). - pattern a at 2; rewrite (Z_div_mod_eq a b); auto with zarith. - rewrite (Zmult_comm b); case (Z_mod_lt a b); auto with zarith. + intros. + rewrite <- (Z_div_mult_full q b); auto with zarith. + apply Z_div_le; auto with zarith. Qed. -Theorem Zdiv_le_lower_bound: - forall a b q, 0 <= a -> 0 < b -> q*b <= a -> q <= a/b. +Theorem Zdiv_le_lower_bound: + forall a b q, 0 < b -> q*b <= a -> q <= a/b. Proof. - intros a b q H1 H2 H3. - assert (q < a / b + 1); auto with zarith. - apply Zmult_lt_reg_r with b; auto with zarith. - apply Zle_lt_trans with (1 := H3). - pattern a at 1; rewrite (Z_div_mod_eq a b); auto with zarith. - rewrite Zmult_plus_distr_l; rewrite (Zmult_comm b); case (Z_mod_lt a b); - auto with zarith. + intros. + rewrite <- (Z_div_mult_full q b); auto with zarith. + apply Z_div_le; auto with zarith. Qed. - (** A division of respect opposite monotonicity for the divisor *) Lemma Zdiv_le_compat_l: forall p q r, 0 <= p -> 0 < q < r -> p / r <= p / q. Proof. - intros p q r H H1. + intros p q r H H1. apply Zdiv_le_lower_bound; auto with zarith. rewrite Zmult_comm. pattern p at 2; rewrite (Z_div_mod_eq p r); auto with zarith. @@ -636,11 +629,11 @@ Proof. case (Z_mod_lt p r); auto with zarith. Qed. -Theorem Zdiv_sgn: forall a b, +Theorem Zdiv_sgn: forall a b, 0 <= Zsgn (a/b) * Zsgn a * Zsgn b. Proof. - destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; - generalize (Z_div_pos (Zpos a) (Zpos b)); unfold Zdiv, Zdiv_eucl; + destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; + generalize (Z_div_pos (Zpos a) (Zpos b)); unfold Zdiv, Zdiv_eucl; destruct Zdiv_eucl_POS as (q,r); destruct r; omega with *. Qed. @@ -668,12 +661,12 @@ Qed. Theorem Z_div_plus_full_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b. Proof. intros a b c H; rewrite Zplus_comm; rewrite Z_div_plus_full; - try apply Zplus_comm; auto with zarith. + try apply Zplus_comm; auto with zarith. Qed. (** [Zopp] and [Zdiv], [Zmod]. - Due to the choice of convention for our Euclidean division, - some of the relations about [Zopp] and divisions are rather complex. *) + Due to the choice of convention for our Euclidean division, + some of the relations about [Zopp] and divisions are rather complex. *) Lemma Zdiv_opp_opp : forall a b:Z, (-a)/(-b) = a/b. Proof. @@ -702,7 +695,7 @@ Proof. ring. Qed. -Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 -> +Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 -> (-a) mod b = b - (a mod b). Proof. intros. @@ -721,7 +714,7 @@ Proof. rewrite Z_mod_zero_opp_full; auto. Qed. -Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 -> +Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 -> a mod (-b) = (a mod b) - b. Proof. intros. @@ -740,7 +733,7 @@ Proof. rewrite H; ring. Qed. -Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 -> +Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 -> (-a)/b = -(a/b)-1. Proof. intros. @@ -758,7 +751,7 @@ Proof. rewrite Z_div_zero_opp_full; auto. Qed. -Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 -> +Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 -> a/(-b) = -(a/b)-1. Proof. intros. @@ -769,7 +762,7 @@ Qed. (** Cancellations. *) -Lemma Zdiv_mult_cancel_r : forall a b c:Z, +Lemma Zdiv_mult_cancel_r : forall a b c:Z, c <> 0 -> (a*c)/(b*c) = a/b. Proof. assert (X: forall a b c, b > 0 -> c > 0 -> (a*c) / (b*c) = a / b). @@ -781,17 +774,17 @@ assert (X: forall a b c, b > 0 -> c > 0 -> (a*c) / (b*c) = a / b). apply Zmult_lt_compat_r; auto with zarith. pattern a at 1; rewrite (Z_div_mod_eq a b Hb); ring. intros a b c Hc. -destruct (Z_dec b 0) as [Hb|Hb]. +destruct (Z_dec b 0) as [Hb|Hb]. destruct Hb as [Hb|Hb]; destruct (not_Zeq_inf _ _ Hc); auto with *. -rewrite <- (Zdiv_opp_opp a), <- (Zmult_opp_opp b), <-(Zmult_opp_opp a); +rewrite <- (Zdiv_opp_opp a), <- (Zmult_opp_opp b), <-(Zmult_opp_opp a); auto with *. -rewrite <- (Zdiv_opp_opp a), <- Zdiv_opp_opp, Zopp_mult_distr_l, +rewrite <- (Zdiv_opp_opp a), <- Zdiv_opp_opp, Zopp_mult_distr_l, Zopp_mult_distr_l; auto with *. rewrite <- Zdiv_opp_opp, Zopp_mult_distr_r, Zopp_mult_distr_r; auto with *. rewrite Hb; simpl; do 2 rewrite Zdiv_0_r; auto. Qed. -Lemma Zdiv_mult_cancel_l : forall a b c:Z, +Lemma Zdiv_mult_cancel_l : forall a b c:Z, c<>0 -> (c*a)/(c*b) = a/b. Proof. intros. @@ -799,7 +792,7 @@ Proof. apply Zdiv_mult_cancel_r; auto. Qed. -Lemma Zmult_mod_distr_l: forall a b c, +Lemma Zmult_mod_distr_l: forall a b c, (c*a) mod (c*b) = c * (a mod b). Proof. intros; destruct (Z_eq_dec c 0) as [Hc|Hc]. @@ -814,7 +807,7 @@ Proof. ring. Qed. -Lemma Zmult_mod_distr_r: forall a b c, +Lemma Zmult_mod_distr_r: forall a b c, (a*c) mod (b*c) = (a mod b) * c. Proof. intros; repeat rewrite (fun x => (Zmult_comm x c)). @@ -982,8 +975,8 @@ Proof. apply Zplus_le_compat;auto with zarith. destruct (Z_mod_lt (a/b) c);auto with zarith. replace (b * (c - 1) + (b - 1)) with (b*c-1);try ring;auto with zarith. - intro H1; - assert (H2: c <> 0) by auto with zarith; + intro H1; + assert (H2: c <> 0) by auto with zarith; rewrite (Zmult_integral_l _ _ H2 H1) in H; auto with zarith. Qed. @@ -996,7 +989,7 @@ Theorem Zdiv_mult_le: forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b. Proof. intros a b c H1 H2 H3. - destruct (Zle_lt_or_eq _ _ H2); + destruct (Zle_lt_or_eq _ _ H2); [ | subst; rewrite Zdiv_0_r, Zdiv_0_r, Zmult_0_r; auto]. case (Z_mod_lt a b); auto with zarith; intros Hu1 Hu2. case (Z_mod_lt c b); auto with zarith; intros Hv1 Hv2. @@ -1012,14 +1005,14 @@ Proof. apply (Zmod_le ((c mod b) * (a mod b)) b); auto with zarith. apply Zmult_le_compat_r; auto with zarith. apply (Zmod_le c b); auto. - pattern (c * a) at 1; rewrite (Z_div_mod_eq (c * a) b); try ring; + pattern (c * a) at 1; rewrite (Z_div_mod_eq (c * a) b); try ring; auto with zarith. pattern a at 1; rewrite (Z_div_mod_eq a b); try ring; auto with zarith. Qed. (** Zmod is related to divisibility (see more in Znumtheory) *) -Lemma Zmod_divides : forall a b, b<>0 -> +Lemma Zmod_divides : forall a b, b<>0 -> (a mod b = 0 <-> exists c, a = b*c). Proof. split; intros. @@ -1077,7 +1070,7 @@ Qed. (** * A direct way to compute Zmod *) -Fixpoint Zmod_POS (a : positive) (b : Z) {struct a} : Z := +Fixpoint Zmod_POS (a : positive) (b : Z) : Z := match a with | xI a' => let r := Zmod_POS a' b in @@ -1166,11 +1159,11 @@ Qed. Implicit Arguments Zdiv_eucl_extended. (** A third convention: Ocaml. - + See files ZOdiv_def.v and ZOdiv.v. - + Ocaml uses Round-Toward-Zero division: (-a)/b = a/(-b) = -(a/b). Hence (-a) mod b = - (a mod b) a mod (-b) = a mod b - And: |r| < |b| and sgn(r) = sgn(a) (notice the a here instead of b). + And: |r| < |b| and sgn(r) = sgn(a) (notice the a here instead of b). *) diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v index 4a402c61..09131043 100644 --- a/theories/ZArith/Zeven.v +++ b/theories/ZArith/Zeven.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zeven.v 10291 2007-11-06 02:18:53Z letouzey $ i*) +(*i $Id$ i*) Require Import BinInt. @@ -96,32 +96,32 @@ Qed. Lemma Zeven_Sn : forall n:Z, Zodd n -> Zeven (Zsucc n). Proof. intro z; destruct z; unfold Zsucc in |- *; - [ idtac | destruct p | destruct p ]; simpl in |- *; - trivial. + [ idtac | destruct p | destruct p ]; simpl in |- *; + trivial. unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto. Qed. Lemma Zodd_Sn : forall n:Z, Zeven n -> Zodd (Zsucc n). Proof. intro z; destruct z; unfold Zsucc in |- *; - [ idtac | destruct p | destruct p ]; simpl in |- *; - trivial. + [ idtac | destruct p | destruct p ]; simpl in |- *; + trivial. unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto. Qed. Lemma Zeven_pred : forall n:Z, Zodd n -> Zeven (Zpred n). Proof. intro z; destruct z; unfold Zpred in |- *; - [ idtac | destruct p | destruct p ]; simpl in |- *; - trivial. + [ idtac | destruct p | destruct p ]; simpl in |- *; + trivial. unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto. Qed. Lemma Zodd_pred : forall n:Z, Zeven n -> Zodd (Zpred n). Proof. intro z; destruct z; unfold Zpred in |- *; - [ idtac | destruct p | destruct p ]; simpl in |- *; - trivial. + [ idtac | destruct p | destruct p ]; simpl in |- *; + trivial. unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto. Qed. @@ -132,7 +132,7 @@ Hint Unfold Zeven Zodd: zarith. (** * Definition of [Zdiv2] and properties wrt [Zeven] and [Zodd] *) (** [Zdiv2] is defined on all [Z], but notice that for odd negative - integers it is not the euclidean quotient: in that case we have + integers it is not the euclidean quotient: in that case we have [n = 2*(n/2)-1] *) Definition Zdiv2 (z:Z) := @@ -200,7 +200,7 @@ Proof. intros x. elim (Z_modulo_2 x); intros [y Hy]; rewrite Zmult_comm in Hy; rewrite <- Zplus_diag_eq_mult_2 in Hy. - exists (y, y); split. + exists (y, y); split. assumption. left; reflexivity. exists (y, (y + 1)%Z); split. @@ -239,7 +239,7 @@ Proof. destruct p; simpl; auto. Qed. -Theorem Zeven_plus_Zodd: forall a b, +Theorem Zeven_plus_Zodd: forall a b, Zeven a -> Zodd b -> Zodd (a + b). Proof. intros a b H1 H2; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto. @@ -257,13 +257,13 @@ Proof. apply Zmult_plus_distr_r; auto. Qed. -Theorem Zodd_plus_Zeven: forall a b, +Theorem Zodd_plus_Zeven: forall a b, Zodd a -> Zeven b -> Zodd (a + b). Proof. intros a b H1 H2; rewrite Zplus_comm; apply Zeven_plus_Zodd; auto. Qed. -Theorem Zodd_plus_Zodd: forall a b, +Theorem Zodd_plus_Zodd: forall a b, Zodd a -> Zodd b -> Zeven (a + b). Proof. intros a b H1 H2; case Zodd_ex with (1 := H1); intros x H3; try rewrite H3; auto. @@ -276,7 +276,7 @@ Proof. repeat rewrite <- Zplus_assoc; auto. Qed. -Theorem Zeven_mult_Zeven_l: forall a b, +Theorem Zeven_mult_Zeven_l: forall a b, Zeven a -> Zeven (a * b). Proof. intros a b H1; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto. @@ -285,7 +285,7 @@ Proof. apply Zmult_assoc. Qed. -Theorem Zeven_mult_Zeven_r: forall a b, +Theorem Zeven_mult_Zeven_r: forall a b, Zeven b -> Zeven (a * b). Proof. intros a b H1; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto. @@ -296,10 +296,10 @@ Proof. rewrite (Zmult_comm 2 a); auto. Qed. -Hint Rewrite Zmult_plus_distr_r Zmult_plus_distr_l +Hint Rewrite Zmult_plus_distr_r Zmult_plus_distr_l Zplus_assoc Zmult_1_r Zmult_1_l : Zexpand. -Theorem Zodd_mult_Zodd: forall a b, +Theorem Zodd_mult_Zodd: forall a b, Zodd a -> Zodd b -> Zodd (a * b). Proof. intros a b H1 H2; case Zodd_ex with (1 := H1); intros x H3; try rewrite H3; auto. @@ -308,7 +308,7 @@ Proof. (* ring part *) autorewrite with Zexpand; f_equal. repeat rewrite <- Zplus_assoc; f_equal. - repeat rewrite <- Zmult_assoc; f_equal. + repeat rewrite <- Zmult_assoc; f_equal. repeat rewrite Zmult_assoc; f_equal; apply Zmult_comm. Qed. diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v index 286dd710..447f6101 100644 --- a/theories/ZArith/Zgcd_alt.v +++ b/theories/ZArith/Zgcd_alt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zgcd_alt.v 10997 2008-05-27 15:16:40Z letouzey $ i*) +(*i $Id$ i*) (** * Zgcd_alt : an alternate version of Zgcd, based on Euler's algorithm *) @@ -30,7 +30,7 @@ Open Scope Z_scope. (** In Coq, we need to control the number of iteration of modulo. For that, we use an explicit measure in [nat], and we prove later - that using [2*d] is enough, where [d] is the number of binary + that using [2*d] is enough, where [d] is the number of binary digits of the first argument. *) Fixpoint Zgcdn (n:nat) : Z -> Z -> Z := fun a b => @@ -43,17 +43,17 @@ Open Scope Z_scope. end end. - Definition Zgcd_bound (a:Z) := + Definition Zgcd_bound (a:Z) := match a with | Z0 => S O | Zpos p => let n := Psize p in (n+n)%nat | Zneg p => let n := Psize p in (n+n)%nat end. - + Definition Zgcd_alt a b := Zgcdn (Zgcd_bound a) a b. - + (** A first obvious fact : [Zgcd a b] is positive. *) - + Lemma Zgcdn_pos : forall n a b, 0 <= Zgcdn n a b. Proof. @@ -61,22 +61,22 @@ Open Scope Z_scope. simpl; auto with zarith. destruct a; simpl; intros; auto with zarith; auto. Qed. - + Lemma Zgcd_alt_pos : forall a b, 0 <= Zgcd_alt a b. Proof. intros; unfold Zgcd; apply Zgcdn_pos; auto. Qed. - + (** We now prove that Zgcd is indeed a gcd. *) - + (** 1) We prove a weaker & easier bound. *) - + Lemma Zgcdn_linear_bound : forall n a b, Zabs a < Z_of_nat n -> Zis_gcd a b (Zgcdn n a b). Proof. induction n. simpl; intros. - elimtype False; generalize (Zabs_pos a); omega. + exfalso; generalize (Zabs_pos a); omega. destruct a; intros; simpl; [ generalize (Zis_gcd_0_abs b); intuition | | ]; unfold Zmod; @@ -93,17 +93,17 @@ Open Scope Z_scope. apply Zis_gcd_minus; apply Zis_gcd_sym. apply Zis_gcd_for_euclid2; auto. Qed. - + (** 2) For Euclid's algorithm, the worst-case situation corresponds to Fibonacci numbers. Let's define them: *) - + Fixpoint fibonacci (n:nat) : Z := match n with | O => 1 | S O => 1 | S (S n as p) => fibonacci p + fibonacci n end. - + Lemma fibonacci_pos : forall n, 0 <= fibonacci n. Proof. cut (forall N n, (n 0<=fibonacci n). @@ -118,7 +118,7 @@ Open Scope Z_scope. change (0 <= fibonacci (S n) + fibonacci n). generalize (IHN n) (IHN (S n)); omega. Qed. - + Lemma fibonacci_incr : forall n m, (n<=m)%nat -> fibonacci n <= fibonacci m. Proof. @@ -131,11 +131,11 @@ Open Scope Z_scope. change (fibonacci (S m) <= fibonacci (S m)+fibonacci m). generalize (fibonacci_pos m); omega. Qed. - + (** 3) We prove that fibonacci numbers are indeed worst-case: for a given number [n], if we reach a conclusion about [gcd(a,b)] in exactly [n+1] loops, then [fibonacci (n+1)<=a /\ fibonacci(n+2)<=b] *) - + Lemma Zgcdn_worst_is_fibonacci : forall n a b, 0 < a < b -> Zis_gcd a b (Zgcdn (S n) a b) -> @@ -192,14 +192,14 @@ Open Scope Z_scope. simpl in H5. elim H5; auto. Qed. - + (** 3b) We reformulate the previous result in a more positive way. *) - + Lemma Zgcdn_ok_before_fibonacci : forall n a b, 0 < a < b -> a < fibonacci (S n) -> Zis_gcd a b (Zgcdn n a b). Proof. - destruct a; [ destruct 1; elimtype False; omega | | destruct 1; discriminate]. + destruct a; [ destruct 1; exfalso; omega | | destruct 1; discriminate]. cut (forall k n b, k = (S (nat_of_P p) - n)%nat -> 0 < Zpos p < b -> Zpos p < fibonacci (S n) -> @@ -224,44 +224,44 @@ Open Scope Z_scope. replace (Zgcdn n (Zpos p) b) with (Zgcdn (S n) (Zpos p) b); auto. generalize (H2 H3); clear H2 H3; omega. Qed. - + (** 4) The proposed bound leads to a fibonacci number that is big enough. *) - + Lemma Zgcd_bound_fibonacci : forall a, 0 < a -> a < fibonacci (Zgcd_bound a). Proof. destruct a; [omega| | intro H; discriminate]. intros _. - induction p; [ | | compute; auto ]; + induction p; [ | | compute; auto ]; simpl Zgcd_bound in *; - rewrite plus_comm; simpl plus; + rewrite plus_comm; simpl plus; set (n:= (Psize p+Psize p)%nat) in *; simpl; assert (n <> O) by (unfold n; destruct p; simpl; auto). - + destruct n as [ |m]; [elim H; auto| ]. generalize (fibonacci_pos m); rewrite Zpos_xI; omega. destruct n as [ |m]; [elim H; auto| ]. generalize (fibonacci_pos m); rewrite Zpos_xO; omega. Qed. - + (* 5) the end: we glue everything together and take care of situations not corresponding to [0 + forall n a b, (Zgcd_bound a <= n)%nat -> Zis_gcd a b (Zgcdn n a b). Proof. destruct a; intros. simpl in H. - destruct n; [elimtype False; omega | ]. + destruct n; [exfalso; omega | ]. simpl; generalize (Zis_gcd_0_abs b); intuition. (*Zpos*) generalize (Zgcd_bound_fibonacci (Zpos p)). simpl Zgcd_bound in *. remember (Psize p+Psize p)%nat as m. assert (1 < m)%nat. - rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm; + rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm; auto with arith. destruct m as [ |m]; [inversion H0; auto| ]. destruct n as [ |n]; [inversion H; auto| ]. @@ -277,15 +277,15 @@ Open Scope Z_scope. apply Zgcdn_ok_before_fibonacci; auto. apply Zlt_le_trans with (fibonacci (S m)); [ omega | apply fibonacci_incr; auto]. subst r; simpl. - destruct m as [ |m]; [elimtype False; omega| ]. - destruct n as [ |n]; [elimtype False; omega| ]. + destruct m as [ |m]; [exfalso; omega| ]. + destruct n as [ |n]; [exfalso; omega| ]. simpl; apply Zis_gcd_sym; apply Zis_gcd_0. (*Zneg*) generalize (Zgcd_bound_fibonacci (Zpos p)). simpl Zgcd_bound in *. remember (Psize p+Psize p)%nat as m. assert (1 < m)%nat. - rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm; + rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm; auto with arith. destruct m as [ |m]; [inversion H0; auto| ]. destruct n as [ |n]; [inversion H; auto| ]. @@ -303,11 +303,11 @@ Open Scope Z_scope. apply Zgcdn_ok_before_fibonacci; auto. apply Zlt_le_trans with (fibonacci (S m)); [ omega | apply fibonacci_incr; auto]. subst r; simpl. - destruct m as [ |m]; [elimtype False; omega| ]. - destruct n as [ |n]; [elimtype False; omega| ]. + destruct m as [ |m]; [exfalso; omega| ]. + destruct n as [ |n]; [exfalso; omega| ]. simpl; apply Zis_gcd_sym; apply Zis_gcd_0. Qed. - + Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Zgcd_alt a b). Proof. diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v index b8f8ba30..5459e693 100644 --- a/theories/ZArith/Zhints.v +++ b/theories/ZArith/Zhints.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zhints.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) (** This file centralizes the lemmas about [Z], classifying them according to the way they can be used in automatic search *) @@ -40,27 +40,27 @@ Require Import Wf_Z. (** No subgoal or smaller subgoals *) -Hint Resolve +Hint Resolve (** ** Reversible simplification lemmas (no loss of information) *) (** Should clearly be declared as hints *) - + (** Lemmas ending by eq *) Zsucc_eq_compat (* :(n,m:Z)`n = m`->`(Zs n) = (Zs m)` *) - + (** Lemmas ending by Zgt *) Zsucc_gt_compat (* :(n,m:Z)`m > n`->`(Zs m) > (Zs n)` *) Zgt_succ (* :(n:Z)`(Zs n) > n` *) Zorder.Zgt_pos_0 (* :(p:positive)`(POS p) > 0` *) Zplus_gt_compat_l (* :(n,m,p:Z)`n > m`->`p+n > p+m` *) Zplus_gt_compat_r (* :(n,m,p:Z)`n > m`->`n+p > m+p` *) - + (** Lemmas ending by Zlt *) Zlt_succ (* :(n:Z)`n < (Zs n)` *) Zsucc_lt_compat (* :(n,m:Z)`n < m`->`(Zs n) < (Zs m)` *) Zlt_pred (* :(n:Z)`(Zpred n) < n` *) Zplus_lt_compat_l (* :(n,m,p:Z)`n < m`->`p+n < p+m` *) Zplus_lt_compat_r (* :(n,m,p:Z)`n < m`->`n+p < m+p` *) - + (** Lemmas ending by Zle *) Zle_0_nat (* :(n:nat)`0 <= (inject_nat n)` *) Zorder.Zle_0_pos (* :(p:positive)`0 <= (POS p)` *) @@ -73,24 +73,24 @@ Hint Resolve Zplus_le_compat_l (* :(n,m,p:Z)`n <= m`->`p+n <= p+m` *) Zplus_le_compat_r (* :(a,b,c:Z)`a <= b`->`a+c <= b+c` *) Zabs_pos (* :(x:Z)`0 <= |x|` *) - + (** ** Irreversible simplification lemmas *) (** Probably to be declared as hints, when no other simplification is possible *) - + (** Lemmas ending by eq *) BinInt.Z_eq_mult (* :(x,y:Z)`y = 0`->`y*x = 0` *) Zplus_eq_compat (* :(n,m,p,q:Z)`n = m`->`p = q`->`n+p = m+q` *) - + (** Lemmas ending by Zge *) Zorder.Zmult_ge_compat_r (* :(a,b,c:Z)`a >= b`->`c >= 0`->`a*c >= b*c` *) Zorder.Zmult_ge_compat_l (* :(a,b,c:Z)`a >= b`->`c >= 0`->`c*a >= c*b` *) Zorder.Zmult_ge_compat (* : (a,b,c,d:Z)`a >= c`->`b >= d`->`c >= 0`->`d >= 0`->`a*b >= c*d` *) - + (** Lemmas ending by Zlt *) Zorder.Zmult_gt_0_compat (* :(a,b:Z)`a > 0`->`b > 0`->`a*b > 0` *) Zlt_lt_succ (* :(n,m:Z)`n < m`->`n < (Zs m)` *) - + (** Lemmas ending by Zle *) Zorder.Zmult_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x*y` *) Zorder.Zmult_le_compat_r (* :(a,b,c:Z)`a <= b`->`0 <= c`->`a*c <= b*c` *) @@ -98,9 +98,9 @@ Hint Resolve Zplus_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x+y` *) Zle_le_succ (* :(x,y:Z)`x <= y`->`x <= (Zs y)` *) Zplus_le_compat (* :(n,m,p,q:Z)`n <= m`->`p <= q`->`n+p <= m+q` *) - + : zarith. - + (**********************************************************************) (** * Reversible lemmas relating operators *) (** Probably to be declared as hints but need to define precedences *) @@ -108,7 +108,7 @@ Hint Resolve (** ** Conversion between comparisons/predicates and arithmetic operators *) (** Lemmas ending by eq *) -(** +(** << Zegal_left: (x,y:Z)`x = y`->`x+(-y) = 0` Zabs_eq: (x:Z)`0 <= x`->`|x| = x` @@ -118,7 +118,7 @@ Zodd_div2: (x:Z)`x >= 0`->(Zodd x)->`x = 2*(Zdiv2 x)+1` *) (** Lemmas ending by Zgt *) -(** +(** << Zgt_left_rev: (x,y:Z)`x+(-y) > 0`->`x > y` Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0` @@ -126,7 +126,7 @@ Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0` *) (** Lemmas ending by Zlt *) -(** +(** << Zlt_left_rev: (x,y:Z)`0 < y+(-x)`->`x < y` Zlt_left_lt: (x,y:Z)`x < y`->`0 < y+(-x)` @@ -135,7 +135,7 @@ Zlt_O_minus_lt: (n,m:Z)`0 < n-m`->`m < n` *) (** Lemmas ending by Zle *) -(** +(** << Zle_left: (x,y:Z)`x <= y`->`0 <= y+(-x)` Zle_left_rev: (x,y:Z)`0 <= y+(-x)`->`x <= y` @@ -148,35 +148,35 @@ Zgt_left: (x,y:Z)`x > y`->`0 <= x+(-1)+(-y)` (** ** Conversion between nat comparisons and Z comparisons *) (** Lemmas ending by eq *) -(** +(** << inj_eq: (x,y:nat)x=y->`(inject_nat x) = (inject_nat y)` >> *) (** Lemmas ending by Zge *) -(** +(** << inj_ge: (x,y:nat)(ge x y)->`(inject_nat x) >= (inject_nat y)` >> *) (** Lemmas ending by Zgt *) -(** +(** << inj_gt: (x,y:nat)(gt x y)->`(inject_nat x) > (inject_nat y)` >> *) (** Lemmas ending by Zlt *) -(** +(** << inj_lt: (x,y:nat)(lt x y)->`(inject_nat x) < (inject_nat y)` >> *) (** Lemmas ending by Zle *) -(** +(** << inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)` >> @@ -185,7 +185,7 @@ inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)` (** ** Conversion between comparisons *) (** Lemmas ending by Zge *) -(** +(** << not_Zlt: (x,y:Z)~`x < y`->`x >= y` Zle_ge: (m,n:Z)`m <= n`->`n >= m` @@ -193,7 +193,7 @@ Zle_ge: (m,n:Z)`m <= n`->`n >= m` *) (** Lemmas ending by Zgt *) -(** +(** << Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n` not_Zle: (x,y:Z)~`x <= y`->`x > y` @@ -203,7 +203,7 @@ Zle_S_gt: (n,m:Z)`(Zs n) <= m`->`m > n` *) (** Lemmas ending by Zlt *) -(** +(** << not_Zge: (x,y:Z)~`x >= y`->`x < y` Zgt_lt: (m,n:Z)`m > n`->`n < m` @@ -212,7 +212,7 @@ Zle_lt_n_Sm: (n,m:Z)`n <= m`->`n < (Zs m)` *) (** Lemmas ending by Zle *) -(** +(** << Zlt_ZERO_pred_le_ZERO: (x:Z)`0 < x`->`0 <= (Zpred x)` not_Zgt: (x,y:Z)~`x > y`->`x <= y` @@ -230,7 +230,7 @@ Zle_refl: (n,m:Z)`n = m`->`n <= m` (** useful with clear precedences *) (** Lemmas ending by Zlt *) -(** +(** << Zlt_le_reg :(a,b,c,d:Z)`a < b`->`c <= d`->`a+c < b+d` Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d` @@ -240,21 +240,21 @@ Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d` (** ** What is decreasing here ? *) (** Lemmas ending by eq *) -(** +(** << Zplus_minus: (n,m,p:Z)`n = m+p`->`p = n-m` >> *) (** Lemmas ending by Zgt *) -(** +(** << Zgt_pred: (n,p:Z)`p > (Zs n)`->`(Zpred p) > n` >> *) (** Lemmas ending by Zlt *) -(** +(** << Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)` >> @@ -266,8 +266,8 @@ Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)` (** ** Bottom-up simplification: should be used *) (** Lemmas ending by eq *) -(** -<< +(** +<< Zeq_add_S: (n,m:Z)`(Zs n) = (Zs m)`->`n = m` Zsimpl_plus_l: (n,m,p:Z)`n+m = n+p`->`m = p` Zplus_unit_left: (n,m:Z)`n+0 = m`->`n = m` @@ -276,21 +276,21 @@ Zplus_unit_right: (n,m:Z)`n = m+0`->`n = m` *) (** Lemmas ending by Zgt *) -(** -<< +(** +<< Zsimpl_gt_plus_l: (n,m,p:Z)`p+n > p+m`->`n > m` Zsimpl_gt_plus_r: (n,m,p:Z)`n+p > m+p`->`n > m` -Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n` ->> +Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n` +>> *) (** Lemmas ending by Zlt *) -(** -<< +(** +<< Zsimpl_lt_plus_l: (n,m,p:Z)`p+n < p+m`->`n < m` Zsimpl_lt_plus_r: (n,m,p:Z)`n+p < m+p`->`n < m` -Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m` ->> +Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m` +>> *) (** Lemmas ending by Zle *) @@ -301,7 +301,7 @@ Zle_S_n: (n,m:Z)`(Zs m) <= (Zs n)`->`m <= n` >> *) (** ** Bottom-up irreversible (syntactic) simplification *) (** Lemmas ending by Zle *) -(** +(** << Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m` >> @@ -310,78 +310,78 @@ Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m` (** ** Other unclearly simplifying lemmas *) (** Lemmas ending by Zeq *) -(** -<< -Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0` ->> +(** +<< +Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0` +>> *) (* Lemmas ending by Zgt *) -(** -<< +(** +<< Zmult_gt: (x,y:Z)`x > 0`->`x*y > 0`->`y > 0` >> *) (* Lemmas ending by Zlt *) -(** -<< +(** +<< pZmult_lt: (x,y:Z)`x > 0`->`0 < y*x`->`0 < y` ->> +>> *) (* Lemmas ending by Zle *) -(** -<< +(** +<< Zmult_le: (x,y:Z)`x > 0`->`0 <= y*x`->`0 <= y` OMEGA1: (x,y:Z)`x = y`->`0 <= x`->`0 <= y` ->> +>> *) (**********************************************************************) (** * Irreversible lemmas with meta-variables *) -(** To be used by EAuto *) +(** To be used by EAuto *) (* Hints Immediate *) (** Lemmas ending by eq *) -(** -<< +(** +<< Zle_antisym: (n,m:Z)`n <= m`->`m <= n`->`n = m` >> *) (** Lemmas ending by Zge *) -(** -<< +(** +<< Zge_trans: (n,m,p:Z)`n >= m`->`m >= p`->`n >= p` ->> +>> *) (** Lemmas ending by Zgt *) -(** -<< +(** +<< Zgt_trans: (n,m,p:Z)`n > m`->`m > p`->`n > p` Zgt_trans_S: (n,m,p:Z)`(Zs n) > m`->`m > p`->`n > p` Zle_gt_trans: (n,m,p:Z)`m <= n`->`m > p`->`n > p` Zgt_le_trans: (n,m,p:Z)`n > m`->`p <= m`->`n > p` ->> +>> *) (** Lemmas ending by Zlt *) -(** -<< +(** +<< Zlt_trans: (n,m,p:Z)`n < m`->`m < p`->`n < p` Zlt_le_trans: (n,m,p:Z)`n < m`->`m <= p`->`n < p` Zle_lt_trans: (n,m,p:Z)`n <= m`->`m < p`->`n < p` ->> +>> *) (** Lemmas ending by Zle *) -(** -<< +(** +<< Zle_trans: (n,m,p:Z)`n <= m`->`m <= p`->`n <= p` ->> +>> *) diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v index d8f4f236..70a959c2 100644 --- a/theories/ZArith/Zlogarithm.v +++ b/theories/ZArith/Zlogarithm.v @@ -6,10 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zlogarithm.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id$ i*) (**********************************************************************) -(** The integer logarithms with base 2. +(** The integer logarithms with base 2. There are three logarithms, depending on the rounding of the real 2-based logarithm: @@ -27,7 +27,7 @@ Require Import Zpower. Open Local Scope Z_scope. Section Log_pos. (* Log of positive integers *) - + (** First we build [log_inf] and [log_sup] *) Fixpoint log_inf (p:positive) : Z := @@ -43,31 +43,30 @@ Section Log_pos. (* Log of positive integers *) | xO n => Zsucc (log_sup n) (* 2n *) | xI n => Zsucc (Zsucc (log_inf n)) (* 2n+1 *) end. - + Hint Unfold log_inf log_sup. - - (** Then we give the specifications of [log_inf] and [log_sup] + + (** Then we give the specifications of [log_inf] and [log_sup] and prove their validity *) - + Hint Resolve Zle_trans: zarith. Theorem log_inf_correct : forall x:positive, 0 <= log_inf x /\ two_p (log_inf x) <= Zpos x < two_p (Zsucc (log_inf x)). + Proof. simple induction x; intros; simpl in |- *; [ elim H; intros Hp HR; clear H; split; [ auto with zarith - | conditional apply Zle_le_succ; trivial rewrite - two_p_S with (x := Zsucc (log_inf p)); - conditional trivial rewrite two_p_S; - conditional trivial rewrite two_p_S in HR; rewrite (BinInt.Zpos_xI p); + | rewrite two_p_S with (x := Zsucc (log_inf p)) by (apply Zle_le_succ; trivial); + rewrite two_p_S by trivial; + rewrite two_p_S in HR by trivial; rewrite (BinInt.Zpos_xI p); omega ] | elim H; intros Hp HR; clear H; split; [ auto with zarith - | conditional apply Zle_le_succ; trivial rewrite - two_p_S with (x := Zsucc (log_inf p)); - conditional trivial rewrite two_p_S; - conditional trivial rewrite two_p_S in HR; rewrite (BinInt.Zpos_xO p); + | rewrite two_p_S with (x := Zsucc (log_inf p)) by (apply Zle_le_succ; trivial); + rewrite two_p_S by trivial; + rewrite two_p_S in HR by trivial; rewrite (BinInt.Zpos_xO p); omega ] | unfold two_power_pos in |- *; unfold shift_pos in |- *; simpl in |- *; omega ]. @@ -101,11 +100,11 @@ Section Log_pos. (* Log of positive integers *) [ left; simpl in |- *; rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); rewrite (two_p_S (log_sup p0) (log_sup_correct1 p0)); - rewrite <- (proj1 Hif); rewrite <- (proj2 Hif); + rewrite <- (proj1 Hif); rewrite <- (proj2 Hif); auto | right; simpl in |- *; rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); - rewrite BinInt.Zpos_xO; unfold Zsucc in |- *; + rewrite BinInt.Zpos_xO; unfold Zsucc in |- *; omega ] | left; auto ]. Qed. @@ -142,7 +141,7 @@ Section Log_pos. (* Log of positive integers *) | xI xH => 2 | xO y => Zsucc (log_near y) | xI y => Zsucc (log_near y) - end. + end. Theorem log_near_correct1 : forall p:positive, 0 <= log_near p. Proof. @@ -187,7 +186,7 @@ End Log_pos. Section divers. (** Number of significative digits. *) - + Definition N_digits (x:Z) := match x with | Zpos p => log_inf p diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v index 0d6fc94a..53c40ae7 100644 --- a/theories/ZArith/Zmax.v +++ b/theories/ZArith/Zmax.v @@ -5,162 +5,102 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zmax.v 10291 2007-11-06 02:18:53Z letouzey $ i*) +(*i $Id$ i*) -Require Import Arith_base. -Require Import BinInt. -Require Import Zcompare. -Require Import Zorder. +(** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *) + +Require Export BinInt Zorder Zminmax. Open Local Scope Z_scope. -(******************************************) -(** Maximum of two binary integer numbers *) +(** [Zmax] is now [Zminmax.Zmax]. Code that do things like + [unfold Zmin.Zmin] will have to be adapted, and neither + a [Definition] or a [Notation] here can help much. *) -Definition Zmax m n := - match m ?= n with - | Eq | Gt => m - | Lt => n - end. (** * Characterization of maximum on binary integer numbers *) -Lemma Zmax_case : forall (n m:Z) (P:Z -> Type), P n -> P m -> P (Zmax n m). -Proof. - intros n m P H1 H2; unfold Zmax in |- *; case (n ?= m); auto with arith. -Qed. - -Lemma Zmax_case_strong : forall (n m:Z) (P:Z -> Type), - (m<=n -> P n) -> (n<=m -> P m) -> P (Zmax n m). -Proof. - intros n m P H1 H2; unfold Zmax, Zle, Zge in *. - rewrite <- (Zcompare_antisym n m) in H1. - destruct (n ?= m); (apply H1|| apply H2); discriminate. -Qed. +Definition Zmax_case := Z.max_case. +Definition Zmax_case_strong := Z.max_case_strong. -Lemma Zmax_spec : forall x y:Z, - x >= y /\ Zmax x y = x \/ - x < y /\ Zmax x y = y. +Lemma Zmax_spec : forall x y, + x >= y /\ Zmax x y = x \/ x < y /\ Zmax x y = y. Proof. - intros; unfold Zmax, Zlt, Zge. - destruct (Zcompare x y); [ left | right | left ]; split; auto; discriminate. + intros x y. rewrite Zge_iff_le. destruct (Z.max_spec x y); auto. Qed. -Lemma Zmax_left : forall n m:Z, n>=m -> Zmax n m = n. -Proof. - intros n m; unfold Zmax, Zge; destruct (n ?= m); auto. - intro H; elim H; auto. -Qed. +Lemma Zmax_left : forall n m, n>=m -> Zmax n m = n. +Proof. intros x y. rewrite Zge_iff_le. apply Zmax_l. Qed. -Lemma Zmax_right : forall n m:Z, n<=m -> Zmax n m = m. -Proof. - intros n m; unfold Zmax, Zle. - generalize (Zcompare_Eq_eq n m). - destruct (n ?= m); auto. - intros _ H; elim H; auto. -Qed. +Definition Zmax_right : forall n m, n<=m -> Zmax n m = m := Zmax_r. (** * Least upper bound properties of max *) -Lemma Zle_max_l : forall n m:Z, n <= Zmax n m. -Proof. - intros; apply Zmax_case_strong; auto with zarith. -Qed. +Definition Zle_max_l : forall n m, n <= Zmax n m := Z.le_max_l. +Definition Zle_max_r : forall n m, m <= Zmax n m := Z.le_max_r. -Notation Zmax1 := Zle_max_l (only parsing). +Definition Zmax_lub : forall n m p, n <= p -> m <= p -> Zmax n m <= p + := Z.max_lub. -Lemma Zle_max_r : forall n m:Z, m <= Zmax n m. -Proof. - intros; apply Zmax_case_strong; auto with zarith. -Qed. +Definition Zmax_lub_lt : forall n m p:Z, n < p -> m < p -> Zmax n m < p + := Z.max_lub_lt. -Notation Zmax2 := Zle_max_r (only parsing). -Lemma Zmax_lub : forall n m p:Z, n <= p -> m <= p -> Zmax n m <= p. -Proof. - intros; apply Zmax_case; assumption. -Qed. +(** * Compatibility with order *) -(** * Semi-lattice properties of max *) +Definition Zle_max_compat_r : forall n m p, n <= m -> Zmax n p <= Zmax m p + := Z.max_le_compat_r. -Lemma Zmax_idempotent : forall n:Z, Zmax n n = n. -Proof. - intros; apply Zmax_case; auto. -Qed. +Definition Zle_max_compat_l : forall n m p, n <= m -> Zmax p n <= Zmax p m + := Z.max_le_compat_l. -Lemma Zmax_comm : forall n m:Z, Zmax n m = Zmax m n. -Proof. - intros; do 2 apply Zmax_case_strong; intros; - apply Zle_antisym; auto with zarith. -Qed. -Lemma Zmax_assoc : forall n m p:Z, Zmax n (Zmax m p) = Zmax (Zmax n m) p. -Proof. - intros n m p; repeat apply Zmax_case_strong; intros; - reflexivity || (try apply Zle_antisym); eauto with zarith. -Qed. +(** * Semi-lattice properties of max *) + +Definition Zmax_idempotent : forall n, Zmax n n = n := Z.max_id. +Definition Zmax_comm : forall n m, Zmax n m = Zmax m n := Z.max_comm. +Definition Zmax_assoc : forall n m p, Zmax n (Zmax m p) = Zmax (Zmax n m) p + := Z.max_assoc. (** * Additional properties of max *) -Lemma Zmax_irreducible_inf : forall n m:Z, Zmax n m = n \/ Zmax n m = m. -Proof. - intros; apply Zmax_case; auto. -Qed. +Lemma Zmax_irreducible_dec : forall n m, {Zmax n m = n} + {Zmax n m = m}. +Proof. exact Z.max_dec. Qed. + +Definition Zmax_le_prime : forall n m p, p <= Zmax n m -> p <= n \/ p <= m + := Z.max_le. -Lemma Zmax_le_prime_inf : forall n m p:Z, p <= Zmax n m -> p <= n \/ p <= m. -Proof. - intros n m p; apply Zmax_case; auto. -Qed. (** * Operations preserving max *) -Lemma Zsucc_max_distr : - forall n m:Z, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m). -Proof. - intros n m; unfold Zmax in |- *; rewrite (Zcompare_succ_compat n m); - elim_compare n m; intros E; rewrite E; auto with arith. -Qed. +Definition Zsucc_max_distr : + forall n m:Z, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m) + := Z.succ_max_distr. -Lemma Zplus_max_distr_r : forall n m p:Z, Zmax (n + p) (m + p) = Zmax n m + p. -Proof. - intros x y n; unfold Zmax in |- *. - rewrite (Zplus_comm x n); rewrite (Zplus_comm y n); - rewrite (Zcompare_plus_compat x y n). - case (x ?= y); apply Zplus_comm. -Qed. +Definition Zplus_max_distr_l : forall n m p:Z, Zmax (p + n) (p + m) = p + Zmax n m + := Z.plus_max_distr_l. + +Definition Zplus_max_distr_r : forall n m p:Z, Zmax (n + p) (m + p) = Zmax n m + p + := Z.plus_max_distr_r. (** * Maximum and Zpos *) -Lemma Zpos_max : forall p q, Zpos (Pmax p q) = Zmax (Zpos p) (Zpos q). -Proof. - intros; unfold Zmax, Pmax; simpl; generalize (Pcompare_Eq_eq p q). - destruct Pcompare; auto. - intro H; rewrite H; auto. -Qed. +Definition Zpos_max : forall p q, Zpos (Pmax p q) = Zmax (Zpos p) (Zpos q) + := Z.pos_max. -Lemma Zpos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p. -Proof. - intros; unfold Zmax; simpl; destruct p; simpl; auto. -Qed. +Definition Zpos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p + := Z.pos_max_1. (** * Characterization of Pminus in term of Zminus and Zmax *) -Lemma Zpos_minus : forall p q, Zpos (Pminus p q) = Zmax 1 (Zpos p - Zpos q). -Proof. - intros. - case_eq (Pcompare p q Eq). - intros H; rewrite (Pcompare_Eq_eq _ _ H). - rewrite Zminus_diag. - unfold Zmax; simpl. - unfold Pminus; rewrite Pminus_mask_diag; auto. - intros; rewrite Pminus_Lt; auto. - destruct (Zmax_spec 1 (Zpos p - Zpos q)) as [(H1,H2)|(H1,H2)]; auto. - elimtype False; clear H2. - assert (H1':=Zlt_trans 0 1 _ Zlt_0_1 H1). - generalize (Zlt_0_minus_lt _ _ H1'). - unfold Zlt; simpl. - rewrite (ZC2 _ _ H); intro; discriminate. - intros; simpl; rewrite H. - symmetry; apply Zpos_max_1. -Qed. +Definition Zpos_minus : + forall p q, Zpos (Pminus p q) = Zmax 1 (Zpos p - Zpos q) + := Zpos_minus. +(* begin hide *) +(* Compatibility *) +Notation Zmax1 := Zle_max_l (only parsing). +Notation Zmax2 := Zle_max_r (only parsing). +Notation Zmax_irreducible_inf := Zmax_irreducible_dec (only parsing). +Notation Zmax_le_prime_inf := Zmax_le_prime (only parsing). +(* end hide *) diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v index bad40a32..5dd26fa3 100644 --- a/theories/ZArith/Zmin.v +++ b/theories/ZArith/Zmin.v @@ -5,142 +5,86 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zmin.v 10028 2007-07-18 22:38:06Z letouzey $ i*) +(*i $Id$ i*) -(** Initial version from Pierre Crégut (CNET, Lannion, France), 1996. - Further extensions by the Coq development team, with suggestions - from Russell O'Connor (Radbout U., Nijmegen, The Netherlands). - *) +(** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *) -Require Import Arith_base. -Require Import BinInt. -Require Import Zcompare. -Require Import Zorder. +Require Import BinInt Zorder Zminmax. Open Local Scope Z_scope. -(**************************************) -(** Minimum on binary integer numbers *) +(** [Zmin] is now [Zminmax.Zmin]. Code that do things like + [unfold Zmin.Zmin] will have to be adapted, and neither + a [Definition] or a [Notation] here can help much. *) -Unboxed Definition Zmin (n m:Z) := - match n ?= m with - | Eq | Lt => n - | Gt => m - end. (** * Characterization of the minimum on binary integer numbers *) -Lemma Zmin_case_strong : forall (n m:Z) (P:Z -> Type), - (n<=m -> P n) -> (m<=n -> P m) -> P (Zmin n m). -Proof. - intros n m P H1 H2; unfold Zmin, Zle, Zge in *. - rewrite <- (Zcompare_antisym n m) in H2. - destruct (n ?= m); (apply H1|| apply H2); discriminate. -Qed. - -Lemma Zmin_case : forall (n m:Z) (P:Z -> Type), P n -> P m -> P (Zmin n m). -Proof. - intros n m P H1 H2; unfold Zmin in |- *; case (n ?= m); auto with arith. -Qed. +Definition Zmin_case := Z.min_case. +Definition Zmin_case_strong := Z.min_case_strong. -Lemma Zmin_spec : forall x y:Z, - x <= y /\ Zmin x y = x \/ - x > y /\ Zmin x y = y. +Lemma Zmin_spec : forall x y, + x <= y /\ Zmin x y = x \/ x > y /\ Zmin x y = y. Proof. - intros; unfold Zmin, Zle, Zgt. - destruct (Zcompare x y); [ left | left | right ]; split; auto; discriminate. + intros x y. rewrite Zgt_iff_lt, Z.min_comm. destruct (Z.min_spec y x); auto. Qed. (** * Greatest lower bound properties of min *) -Lemma Zle_min_l : forall n m:Z, Zmin n m <= n. -Proof. - intros n m; unfold Zmin in |- *; elim_compare n m; intros E; rewrite E; - [ apply Zle_refl - | apply Zle_refl - | apply Zlt_le_weak; apply Zgt_lt; exact E ]. -Qed. +Definition Zle_min_l : forall n m, Zmin n m <= n := Z.le_min_l. +Definition Zle_min_r : forall n m, Zmin n m <= m := Z.le_min_r. -Lemma Zle_min_r : forall n m:Z, Zmin n m <= m. -Proof. - intros n m; unfold Zmin in |- *; elim_compare n m; intros E; rewrite E; - [ unfold Zle in |- *; rewrite E; discriminate - | unfold Zle in |- *; rewrite E; discriminate - | apply Zle_refl ]. -Qed. +Definition Zmin_glb : forall n m p, p <= n -> p <= m -> p <= Zmin n m + := Z.min_glb. +Definition Zmin_glb_lt : forall n m p, p < n -> p < m -> p < Zmin n m + := Z.min_glb_lt. -Lemma Zmin_glb : forall n m p:Z, p <= n -> p <= m -> p <= Zmin n m. -Proof. - intros; apply Zmin_case; assumption. -Qed. +(** * Compatibility with order *) -(** * Semi-lattice properties of min *) +Definition Zle_min_compat_r : forall n m p, n <= m -> Zmin n p <= Zmin m p + := Z.min_le_compat_r. +Definition Zle_min_compat_l : forall n m p, n <= m -> Zmin p n <= Zmin p m + := Z.min_le_compat_l. -Lemma Zmin_idempotent : forall n:Z, Zmin n n = n. -Proof. - unfold Zmin in |- *; intros; elim (n ?= n); auto. -Qed. +(** * Semi-lattice properties of min *) +Definition Zmin_idempotent : forall n, Zmin n n = n := Z.min_id. Notation Zmin_n_n := Zmin_idempotent (only parsing). - -Lemma Zmin_comm : forall n m:Z, Zmin n m = Zmin m n. -Proof. - intros n m; unfold Zmin. - rewrite <- (Zcompare_antisym n m). - assert (H:=Zcompare_Eq_eq n m). - destruct (n ?= m); simpl; auto. -Qed. - -Lemma Zmin_assoc : forall n m p:Z, Zmin n (Zmin m p) = Zmin (Zmin n m) p. -Proof. - intros n m p; repeat apply Zmin_case_strong; intros; - reflexivity || (try apply Zle_antisym); eauto with zarith. -Qed. +Definition Zmin_comm : forall n m, Zmin n m = Zmin m n := Z.min_comm. +Definition Zmin_assoc : forall n m p, Zmin n (Zmin m p) = Zmin (Zmin n m) p + := Z.min_assoc. (** * Additional properties of min *) -Lemma Zmin_irreducible_inf : forall n m:Z, {Zmin n m = n} + {Zmin n m = m}. -Proof. - unfold Zmin in |- *; intros; elim (n ?= m); auto. -Qed. +Lemma Zmin_irreducible_inf : forall n m, {Zmin n m = n} + {Zmin n m = m}. +Proof. exact Z.min_dec. Qed. -Lemma Zmin_irreducible : forall n m:Z, Zmin n m = n \/ Zmin n m = m. -Proof. - intros n m; destruct (Zmin_irreducible_inf n m); [left|right]; trivial. -Qed. +Lemma Zmin_irreducible : forall n m, Zmin n m = n \/ Zmin n m = m. +Proof. intros; destruct (Z.min_dec n m); auto. Qed. Notation Zmin_or := Zmin_irreducible (only parsing). -Lemma Zmin_le_prime_inf : forall n m p:Z, Zmin n m <= p -> {n <= p} + {m <= p}. -Proof. - intros n m p; apply Zmin_case; auto. -Qed. +Lemma Zmin_le_prime_inf : forall n m p, Zmin n m <= p -> {n <= p} + {m <= p}. +Proof. intros n m p; apply Zmin_case; auto. Qed. (** * Operations preserving min *) -Lemma Zsucc_min_distr : - forall n m:Z, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m). -Proof. - intros n m; unfold Zmin in |- *; rewrite (Zcompare_succ_compat n m); - elim_compare n m; intros E; rewrite E; auto with arith. -Qed. +Definition Zsucc_min_distr : + forall n m, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m) + := Z.succ_min_distr. -Notation Zmin_SS := Zsucc_min_distr (only parsing). +Notation Zmin_SS := Z.succ_min_distr (only parsing). -Lemma Zplus_min_distr_r : forall n m p:Z, Zmin (n + p) (m + p) = Zmin n m + p. -Proof. - intros x y n; unfold Zmin in |- *. - rewrite (Zplus_comm x n); rewrite (Zplus_comm y n); - rewrite (Zcompare_plus_compat x y n). - case (x ?= y); apply Zplus_comm. -Qed. +Definition Zplus_min_distr_r : + forall n m p, Zmin (n + p) (m + p) = Zmin n m + p + := Z.plus_min_distr_r. -Notation Zmin_plus := Zplus_min_distr_r (only parsing). +Notation Zmin_plus := Z.plus_min_distr_r (only parsing). (** * Minimum and Zpos *) -Lemma Zpos_min : forall p q, Zpos (Pmin p q) = Zmin (Zpos p) (Zpos q). -Proof. - intros; unfold Zmin, Pmin; simpl; destruct Pcompare; auto. -Qed. +Definition Zpos_min : forall p q, Zpos (Pmin p q) = Zmin (Zpos p) (Zpos q) + := Z.pos_min. + + diff --git a/theories/ZArith/Zminmax.v b/theories/ZArith/Zminmax.v index 95668cf8..c1657e29 100644 --- a/theories/ZArith/Zminmax.v +++ b/theories/ZArith/Zminmax.v @@ -5,72 +5,198 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zminmax.v 9245 2006-10-17 12:53:34Z notin $ i*) -Require Import Zmin Zmax. -Require Import BinInt Zorder. +Require Import Orders BinInt Zcompare Zorder ZOrderedType + GenericMinMax. -Open Local Scope Z_scope. +(** * Maximum and Minimum of two [Z] numbers *) -(** Lattice properties of min and max on Z *) +Local Open Scope Z_scope. -(** Absorption *) +Unboxed Definition Zmax (n m:Z) := + match n ?= m with + | Eq | Gt => n + | Lt => m + end. -Lemma Zmin_max_absorption_r_r : forall n m, Zmax n (Zmin n m) = n. +Unboxed Definition Zmin (n m:Z) := + match n ?= m with + | Eq | Lt => n + | Gt => m + end. + +(** The functions [Zmax] and [Zmin] implement indeed + a maximum and a minimum *) + +Lemma Zmax_l : forall x y, y<=x -> Zmax x y = x. +Proof. + unfold Zle, Zmax. intros x y. rewrite <- (Zcompare_antisym x y). + destruct (x ?= y); intuition. +Qed. + +Lemma Zmax_r : forall x y, x<=y -> Zmax x y = y. +Proof. + unfold Zle, Zmax. intros x y. generalize (Zcompare_Eq_eq x y). + destruct (x ?= y); intuition. +Qed. + +Lemma Zmin_l : forall x y, x<=y -> Zmin x y = x. +Proof. + unfold Zle, Zmin. intros x y. generalize (Zcompare_Eq_eq x y). + destruct (x ?= y); intuition. +Qed. + +Lemma Zmin_r : forall x y, y<=x -> Zmin x y = y. +Proof. + unfold Zle, Zmin. intros x y. + rewrite <- (Zcompare_antisym x y). generalize (Zcompare_Eq_eq x y). + destruct (x ?= y); intuition. +Qed. + +Module ZHasMinMax <: HasMinMax Z_as_OT. + Definition max := Zmax. + Definition min := Zmin. + Definition max_l := Zmax_l. + Definition max_r := Zmax_r. + Definition min_l := Zmin_l. + Definition min_r := Zmin_r. +End ZHasMinMax. + +Module Z. + +(** We obtain hence all the generic properties of max and min. *) + +Include UsualMinMaxProperties Z_as_OT ZHasMinMax. + +(** * Properties specific to the [Z] domain *) + +(** Compatibilities (consequences of monotonicity) *) + +Lemma plus_max_distr_l : forall n m p, Zmax (p + n) (p + m) = p + Zmax n m. Proof. - intros; apply Zmin_case_strong; intro; apply Zmax_case_strong; intro; - reflexivity || apply Zle_antisym; trivial. + intros. apply max_monotone. + intros x y. apply Zplus_le_compat_l. Qed. -Lemma Zmax_min_absorption_r_r : forall n m, Zmin n (Zmax n m) = n. +Lemma plus_max_distr_r : forall n m p, Zmax (n + p) (m + p) = Zmax n m + p. Proof. - intros; apply Zmax_case_strong; intro; apply Zmin_case_strong; intro; - reflexivity || apply Zle_antisym; trivial. + intros. rewrite (Zplus_comm n p), (Zplus_comm m p), (Zplus_comm _ p). + apply plus_max_distr_l. Qed. -(** Distributivity *) +Lemma plus_min_distr_l : forall n m p, Zmin (p + n) (p + m) = p + Zmin n m. +Proof. + intros. apply Z.min_monotone. + intros x y. apply Zplus_le_compat_l. +Qed. -Lemma Zmax_min_distr_r : - forall n m p, Zmax n (Zmin m p) = Zmin (Zmax n m) (Zmax n p). +Lemma plus_min_distr_r : forall n m p, Zmin (n + p) (m + p) = Zmin n m + p. Proof. - intros. - repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; - reflexivity || - apply Zle_antisym; (assumption || eapply Zle_trans; eassumption). + intros. rewrite (Zplus_comm n p), (Zplus_comm m p), (Zplus_comm _ p). + apply plus_min_distr_l. Qed. -Lemma Zmin_max_distr_r : - forall n m p, Zmin n (Zmax m p) = Zmax (Zmin n m) (Zmin n p). +Lemma succ_max_distr : forall n m, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m). Proof. - intros. - repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; - reflexivity || - apply Zle_antisym; (assumption || eapply Zle_trans; eassumption). + unfold Zsucc. intros. symmetry. apply plus_max_distr_r. Qed. -(** Modularity *) +Lemma succ_min_distr : forall n m, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m). +Proof. + unfold Zsucc. intros. symmetry. apply plus_min_distr_r. +Qed. -Lemma Zmax_min_modular_r : - forall n m p, Zmax n (Zmin m (Zmax n p)) = Zmin (Zmax n m) (Zmax n p). +Lemma pred_max_distr : forall n m, Zpred (Zmax n m) = Zmax (Zpred n) (Zpred m). Proof. - intros; repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; - reflexivity || - apply Zle_antisym; (assumption || eapply Zle_trans; eassumption). + unfold Zpred. intros. symmetry. apply plus_max_distr_r. Qed. -Lemma Zmin_max_modular_r : - forall n m p, Zmin n (Zmax m (Zmin n p)) = Zmax (Zmin n m) (Zmin n p). +Lemma pred_min_distr : forall n m, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m). Proof. - intros; repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; - reflexivity || - apply Zle_antisym; (assumption || eapply Zle_trans; eassumption). + unfold Zpred. intros. symmetry. apply plus_min_distr_r. Qed. -(** Disassociativity *) +(** Anti-monotonicity swaps the role of [min] and [max] *) + +Lemma opp_max_distr : forall n m : Z, -(Zmax n m) = Zmin (- n) (- m). +Proof. + intros. symmetry. apply min_max_antimonotone. + intros x x'. red. red. rewrite <- Zcompare_opp; auto. +Qed. + +Lemma opp_min_distr : forall n m : Z, - (Zmin n m) = Zmax (- n) (- m). +Proof. + intros. symmetry. apply max_min_antimonotone. + intros x x'. red. red. rewrite <- Zcompare_opp; auto. +Qed. -Lemma max_min_disassoc : forall n m p, Zmin n (Zmax m p) <= Zmax (Zmin n m) p. +Lemma minus_max_distr_l : forall n m p, Zmax (p - n) (p - m) = p - Zmin n m. Proof. - intros; repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; - apply Zle_refl || (assumption || eapply Zle_trans; eassumption). + unfold Zminus. intros. rewrite opp_min_distr. apply plus_max_distr_l. Qed. +Lemma minus_max_distr_r : forall n m p, Zmax (n - p) (m - p) = Zmax n m - p. +Proof. + unfold Zminus. intros. apply plus_max_distr_r. +Qed. + +Lemma minus_min_distr_l : forall n m p, Zmin (p - n) (p - m) = p - Zmax n m. +Proof. + unfold Zminus. intros. rewrite opp_max_distr. apply plus_min_distr_l. +Qed. + +Lemma minus_min_distr_r : forall n m p, Zmin (n - p) (m - p) = Zmin n m - p. +Proof. + unfold Zminus. intros. apply plus_min_distr_r. +Qed. + +(** Compatibility with [Zpos] *) + +Lemma pos_max : forall p q, Zpos (Pmax p q) = Zmax (Zpos p) (Zpos q). +Proof. + intros; unfold Zmax, Pmax; simpl; generalize (Pcompare_Eq_eq p q). + destruct Pcompare; auto. + intro H; rewrite H; auto. +Qed. + +Lemma pos_min : forall p q, Zpos (Pmin p q) = Zmin (Zpos p) (Zpos q). +Proof. + intros; unfold Zmin, Pmin; simpl; generalize (Pcompare_Eq_eq p q). + destruct Pcompare; auto. +Qed. + +Lemma pos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p. +Proof. + intros; unfold Zmax; simpl; destruct p; simpl; auto. +Qed. + +Lemma pos_min_1 : forall p, Zmin 1 (Zpos p) = 1. +Proof. + intros; unfold Zmax; simpl; destruct p; simpl; auto. +Qed. + +End Z. + + +(** * Characterization of Pminus in term of Zminus and Zmax *) + +Lemma Zpos_minus : forall p q, Zpos (Pminus p q) = Zmax 1 (Zpos p - Zpos q). +Proof. + intros; simpl. destruct (Pcompare p q Eq) as [ ]_eqn:H. + rewrite (Pcompare_Eq_eq _ _ H). + unfold Pminus; rewrite Pminus_mask_diag; reflexivity. + rewrite Pminus_Lt; auto. + symmetry. apply Z.pos_max_1. +Qed. + + +(*begin hide*) +(* Compatibility with names of the old Zminmax file *) +Notation Zmin_max_absorption_r_r := Z.min_max_absorption (only parsing). +Notation Zmax_min_absorption_r_r := Z.max_min_absorption (only parsing). +Notation Zmax_min_distr_r := Z.max_min_distr (only parsing). +Notation Zmin_max_distr_r := Z.min_max_distr (only parsing). +Notation Zmax_min_modular_r := Z.max_min_modular (only parsing). +Notation Zmin_max_modular_r := Z.min_max_modular (only parsing). +Notation max_min_disassoc := Z.max_min_disassoc (only parsing). +(*end hide*) \ No newline at end of file diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v index 0634096e..178ae5f1 100644 --- a/theories/ZArith/Zmisc.v +++ b/theories/ZArith/Zmisc.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zmisc.v 11072 2008-06-08 16:13:37Z herbelin $ i*) +(*i $Id$ i*) Require Import Wf_nat. Require Import BinInt. @@ -20,7 +20,7 @@ Open Local Scope Z_scope. (** [n]th iteration of the function [f] *) -Fixpoint iter_pos (n:positive) (A:Type) (f:A -> A) (x:A) {struct n} : A := +Fixpoint iter_pos (n:positive) (A:Type) (f:A -> A) (x:A) : A := match n with | xH => f x | xO n' => iter_pos n' A f (iter_pos n' A f x) @@ -37,22 +37,29 @@ Definition iter (n:Z) (A:Type) (f:A -> A) (x:A) := Theorem iter_nat_of_P : forall (p:positive) (A:Type) (f:A -> A) (x:A), iter_pos p A f x = iter_nat (nat_of_P p) A f x. -Proof. +Proof. intro n; induction n as [p H| p H| ]; [ intros; simpl in |- *; rewrite (H A f x); - rewrite (H A f (iter_nat (nat_of_P p) A f x)); + rewrite (H A f (iter_nat (nat_of_P p) A f x)); rewrite (ZL6 p); symmetry in |- *; apply f_equal with (f := f); apply iter_nat_plus | intros; unfold nat_of_P in |- *; simpl in |- *; rewrite (H A f x); - rewrite (H A f (iter_nat (nat_of_P p) A f x)); + rewrite (H A f (iter_nat (nat_of_P p) A f x)); rewrite (ZL6 p); symmetry in |- *; apply iter_nat_plus | simpl in |- *; auto with arith ]. Qed. +Lemma iter_nat_of_Z : forall n A f x, 0 <= n -> + iter n A f x = iter_nat (Zabs_nat n) A f x. +intros n A f x; case n; auto. +intros p _; unfold iter, Zabs_nat; apply iter_nat_of_P. +intros p abs; case abs; trivial. +Qed. + Theorem iter_pos_plus : forall (p q:positive) (A:Type) (f:A -> A) (x:A), iter_pos (p + q) A f x = iter_pos p A f (iter_pos q A f x). -Proof. +Proof. intros n m; intros. rewrite (iter_nat_of_P m A f x). rewrite (iter_nat_of_P n A f (iter_nat (nat_of_P m) A f x)). @@ -61,14 +68,14 @@ Proof. apply iter_nat_plus. Qed. -(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv], +(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv], then the iterates of [f] also preserve it. *) Theorem iter_nat_invariant : forall (n:nat) (A:Type) (f:A -> A) (Inv:A -> Prop), (forall x:A, Inv x -> Inv (f x)) -> forall x:A, Inv x -> Inv (iter_nat n A f x). -Proof. +Proof. simple induction n; intros; [ trivial with arith | simpl in |- *; apply H0 with (x := iter_nat n0 A f x); apply H; @@ -79,6 +86,6 @@ Theorem iter_pos_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_pos p A f x). -Proof. +Proof. intros; rewrite iter_nat_of_P; apply iter_nat_invariant; trivial with arith. Qed. diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v index c5b5edc1..dfd9b545 100644 --- a/theories/ZArith/Znat.v +++ b/theories/ZArith/Znat.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* n = m. Proof. intros x y H. destruct (eq_nat_dec x y) as [H'|H']; auto. - elimtype False. + exfalso. exact (inj_neq _ _ H' H). Qed. @@ -90,7 +91,7 @@ Qed. Theorem inj_lt : forall n m:nat, (n < m)%nat -> Z_of_nat n < Z_of_nat m. Proof. - intros x y H; apply Zgt_lt; apply Zlt_succ_gt; rewrite <- inj_S; apply inj_le; + intros x y H; apply Zgt_lt; apply Zle_succ_gt; rewrite <- inj_S; apply inj_le; exact H. Qed. @@ -110,7 +111,7 @@ Theorem inj_le_rev : forall n m:nat, Z_of_nat n <= Z_of_nat m -> (n <= m)%nat. Proof. intros x y H. destruct (le_lt_dec x y) as [H0|H0]; auto. - elimtype False. + exfalso. assert (H1:=inj_lt _ _ H0). red in H; red in H1. rewrite <- Zcompare_antisym in H; rewrite H1 in H; auto. @@ -120,7 +121,7 @@ Theorem inj_lt_rev : forall n m:nat, Z_of_nat n < Z_of_nat m -> (n < m)%nat. Proof. intros x y H. destruct (le_lt_dec y x) as [H0|H0]; auto. - elimtype False. + exfalso. assert (H1:=inj_le _ _ H0). red in H; red in H1. rewrite <- Zcompare_antisym in H1; rewrite H in H1; auto. @@ -130,7 +131,7 @@ Theorem inj_ge_rev : forall n m:nat, Z_of_nat n >= Z_of_nat m -> (n >= m)%nat. Proof. intros x y H. destruct (le_lt_dec y x) as [H0|H0]; auto. - elimtype False. + exfalso. assert (H1:=inj_gt _ _ H0). red in H; red in H1. rewrite <- Zcompare_antisym in H; rewrite H1 in H; auto. @@ -140,7 +141,7 @@ Theorem inj_gt_rev : forall n m:nat, Z_of_nat n > Z_of_nat m -> (n > m)%nat. Proof. intros x y H. destruct (le_lt_dec x y) as [H0|H0]; auto. - elimtype False. + exfalso. assert (H1:=inj_ge _ _ H0). red in H; red in H1. rewrite <- Zcompare_antisym in H1; rewrite H in H1; auto. @@ -169,7 +170,7 @@ Proof. Qed. (** Injection and usual operations *) - + Theorem inj_plus : forall n m:nat, Z_of_nat (n + m) = Z_of_nat n + Z_of_nat m. Proof. intro x; induction x as [| n H]; intro y; destruct y as [| m]; @@ -186,7 +187,7 @@ Proof. intro x; induction x as [| n H]; [ simpl in |- *; trivial with arith | intro y; rewrite inj_S; rewrite <- Zmult_succ_l_reverse; rewrite <- H; - rewrite <- inj_plus; simpl in |- *; rewrite plus_comm; + rewrite <- inj_plus; simpl in |- *; rewrite plus_comm; trivial with arith ]. Qed. @@ -195,17 +196,17 @@ Theorem inj_minus1 : Proof. intros x y H; apply (Zplus_reg_l (Z_of_nat y)); unfold Zminus in |- *; rewrite Zplus_permute; rewrite Zplus_opp_r; rewrite <- inj_plus; - rewrite <- (le_plus_minus y x H); rewrite Zplus_0_r; + rewrite <- (le_plus_minus y x H); rewrite Zplus_0_r; trivial with arith. Qed. - + Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z_of_nat (n - m) = 0. Proof. intros x y H; rewrite not_le_minus_0; [ trivial with arith | apply gt_not_le; assumption ]. Qed. -Theorem inj_minus : forall n m:nat, +Theorem inj_minus : forall n m:nat, Z_of_nat (minus n m) = Zmax 0 (Z_of_nat n - Z_of_nat m). Proof. intros. @@ -225,7 +226,7 @@ Proof. unfold Zminus; rewrite H'; auto. Qed. -Theorem inj_min : forall n m:nat, +Theorem inj_min : forall n m:nat, Z_of_nat (min n m) = Zmin (Z_of_nat n) (Z_of_nat m). Proof. induction n; destruct m; try (compute; auto; fail). @@ -234,7 +235,7 @@ Proof. rewrite <- Zsucc_min_distr; f_equal; auto. Qed. -Theorem inj_max : forall n m:nat, +Theorem inj_max : forall n m:nat, Z_of_nat (max n m) = Zmax (Z_of_nat n) (Z_of_nat m). Proof. induction n; destruct m; try (compute; auto; fail). @@ -269,11 +270,11 @@ Proof. intros x; exists (Z_of_nat x); split; [ trivial with arith | rewrite Zmult_comm; rewrite Zmult_1_l; rewrite Zplus_0_r; - unfold Zle in |- *; elim x; intros; simpl in |- *; + unfold Zle in |- *; elim x; intros; simpl in |- *; discriminate ]. Qed. -Lemma Zpos_P_of_succ_nat : forall n:nat, +Lemma Zpos_P_of_succ_nat : forall n:nat, Zpos (P_of_succ_nat n) = Zsucc (Z_of_nat n). Proof. intros. diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index 9be372a3..2a2751c9 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Znumtheory.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id$ i*) Require Import ZArith_base. Require Import ZArithRing. @@ -15,13 +15,13 @@ Require Import Zdiv. Require Import Wf_nat. Open Local Scope Z_scope. -(** This file contains some notions of number theory upon Z numbers: +(** This file contains some notions of number theory upon Z numbers: - a divisibility predicate [Zdivide] - a gcd predicate [gcd] - Euclid algorithm [euclid] - a relatively prime predicate [rel_prime] - a prime predicate [prime] - - an efficient [Zgcd] function + - an efficient [Zgcd] function *) (** * Divisibility *) @@ -171,7 +171,7 @@ Proof. rewrite H1 in H0; left; omega. rewrite H1 in H0; right; omega. Qed. - + Theorem Zdivide_trans: forall a b c, (a | b) -> (b | c) -> (a | c). Proof. intros a b c [d H1] [e H2]; exists (d * e); auto with zarith. @@ -201,19 +201,17 @@ Qed. (** [Zdivide] can be expressed using [Zmod]. *) -Lemma Zmod_divide : forall a b:Z, b > 0 -> a mod b = 0 -> (b | a). +Lemma Zmod_divide : forall a b, b<>0 -> a mod b = 0 -> (b | a). Proof. - intros a b H H0. - apply Zdivide_intro with (a / b). - pattern a at 1 in |- *; rewrite (Z_div_mod_eq a b H). - rewrite H0; ring. + intros a b NZ EQ. + apply Zdivide_intro with (a/b). + rewrite (Z_div_mod_eq_full a b NZ) at 1. + rewrite EQ; ring. Qed. -Lemma Zdivide_mod : forall a b:Z, b > 0 -> (b | a) -> a mod b = 0. +Lemma Zdivide_mod : forall a b, (b | a) -> a mod b = 0. Proof. - intros a b; simple destruct 2; intros; subst. - change (q * b) with (0 + q * b) in |- *. - rewrite Z_mod_plus; auto. + intros a b (c,->); apply Z_mod_mult. Qed. (** [Zdivide] is hence decidable *) @@ -222,7 +220,7 @@ Lemma Zdivide_dec : forall a b:Z, {(a | b)} + {~ (a | b)}. Proof. intros a b; elim (Ztrichotomy_inf a 0). (* a<0 *) - intros H; elim H; intros. + intros H; elim H; intros. case (Z_eq_dec (b mod - a) 0). left; apply Zdivide_opp_l_rev; apply Zmod_divide; auto with zarith. intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith. @@ -236,7 +234,7 @@ Proof. intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith. Qed. -Theorem Zdivide_Zdiv_eq: forall a b : Z, +Theorem Zdivide_Zdiv_eq: forall a b : Z, 0 < a -> (a | b) -> b = a * (b / a). Proof. intros a b Hb Hc. @@ -244,7 +242,7 @@ Proof. rewrite (Zdivide_mod b a); auto with zarith. Qed. -Theorem Zdivide_Zdiv_eq_2: forall a b c : Z, +Theorem Zdivide_Zdiv_eq_2: forall a b c : Z, 0 < a -> (a | b) -> (c * b)/a = c * (b / a). Proof. intros a b c H1 H2. @@ -252,7 +250,7 @@ Proof. rewrite Hz; rewrite Zmult_assoc. repeat rewrite Z_div_mult; auto with zarith. Qed. - + Theorem Zdivide_Zabs_l: forall a b, (Zabs a | b) -> (a | b). Proof. intros a b [x H]; subst b. @@ -260,7 +258,7 @@ Proof. exists (- x); ring. exists x; ring. Qed. - + Theorem Zdivide_Zabs_inv_l: forall a b, (a | b) -> (Zabs a | b). Proof. intros a b [x H]; subst b. @@ -269,7 +267,7 @@ Proof. exists x; ring. Qed. -Theorem Zdivide_le: forall a b : Z, +Theorem Zdivide_le: forall a b : Z, 0 <= a -> 0 < b -> (a | b) -> a <= b. Proof. intros a b H1 H2 [q H3]; subst b. @@ -280,7 +278,7 @@ Proof. intros H4; subst q; omega. Qed. -Theorem Zdivide_Zdiv_lt_pos: forall a b : Z, +Theorem Zdivide_Zdiv_lt_pos: forall a b : Z, 1 < a -> 0 < b -> (a | b) -> 0 < b / a < b . Proof. intros a b H1 H2 H3; split. @@ -307,7 +305,7 @@ Proof. rewrite Zplus_0_l; rewrite Zmod_mod; auto with zarith. Qed. -Lemma Zmod_divide_minus: forall a b c : Z, 0 < b -> +Lemma Zmod_divide_minus: forall a b c : Z, 0 < b -> a mod b = c -> (b | a - c). Proof. intros a b c H H1; apply Zmod_divide; auto with zarith. @@ -317,7 +315,7 @@ Proof. subst; apply Z_mod_lt; auto with zarith. Qed. -Lemma Zdivide_mod_minus: forall a b c : Z, 0 <= c < b -> +Lemma Zdivide_mod_minus: forall a b c : Z, 0 <= c < b -> (b | a - c) -> a mod b = c. Proof. intros a b c (H1, H2) H3; assert (0 < b); try apply Zle_lt_trans with c; auto. @@ -328,9 +326,9 @@ Proof. Qed. (** * Greatest common divisor (gcd). *) - -(** There is no unicity of the gcd; hence we define the predicate [gcd a b d] - expressing that [d] is a gcd of [a] and [b]. + +(** There is no unicity of the gcd; hence we define the predicate [gcd a b d] + expressing that [d] is a gcd of [a] and [b]. (We show later that the [gcd] is actually unique if we discard its sign.) *) Inductive Zis_gcd (a b d:Z) : Prop := @@ -379,8 +377,8 @@ Proof. Qed. Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith. - -Theorem Zis_gcd_unique: forall a b c d : Z, + +Theorem Zis_gcd_unique: forall a b c d : Z, Zis_gcd a b c -> Zis_gcd a b d -> c = d \/ c = (- d). Proof. intros a b c d H1 H2. @@ -431,7 +429,7 @@ Section extended_euclid_algorithm. (** The recursive part of Euclid's algorithm uses well-founded recursion of non-negative integers. It maintains 6 integers [u1,u2,u3,v1,v2,v3] such that the following invariant holds: - [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u2,v3)=gcd(a,b)]. + [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u2,v3)=gcd(a,b)]. *) Lemma euclid_rec : @@ -455,8 +453,8 @@ Section extended_euclid_algorithm. replace (u3 - q * x) with (u3 mod x). apply Z_mod_lt; omega. assert (xpos : x > 0). omega. - generalize (Z_div_mod_eq u3 x xpos). - unfold q in |- *. + generalize (Z_div_mod_eq u3 x xpos). + unfold q in |- *. intro eq; pattern u3 at 2 in |- *; rewrite eq; ring. apply (H (u3 - q * x) Hq (proj1 Hq) v1 v2 x (u1 - q * v1) (u2 - q * v2)). tauto. @@ -531,7 +529,7 @@ Proof. rewrite H6; rewrite H7; ring. ring. Qed. - + (** * Relative primality *) @@ -612,16 +610,16 @@ Proof. intros a b g; intros. assert (g <> 0). intro. - elim H1; intros. + elim H1; intros. elim H4; intros. rewrite H2 in H6; subst b; omega. unfold rel_prime in |- *. destruct H1. destruct H1 as (a',H1). destruct H3 as (b',H3). - replace (a/g) with a'; + replace (a/g) with a'; [|rewrite H1; rewrite Z_div_mult; auto with zarith]. - replace (b/g) with b'; + replace (b/g) with b'; [|rewrite H3; rewrite Z_div_mult; auto with zarith]. constructor. exists a'; auto with zarith. @@ -643,7 +641,7 @@ Proof. red; apply Zis_gcd_sym; auto with zarith. Qed. -Theorem rel_prime_div: forall p q r, +Theorem rel_prime_div: forall p q r, rel_prime p q -> (r | p) -> rel_prime r q. Proof. intros p q r H (u, H1); subst. @@ -670,7 +668,7 @@ Proof. exists 1; auto with zarith. Qed. -Theorem rel_prime_mod: forall p q, 0 < q -> +Theorem rel_prime_mod: forall p q, 0 < q -> rel_prime p q -> rel_prime (p mod q) q. Proof. intros p q H H0. @@ -683,7 +681,7 @@ Proof. pattern p at 3; rewrite (Z_div_mod_eq p q); try ring; auto with zarith. Qed. -Theorem rel_prime_mod_rev: forall p q, 0 < q -> +Theorem rel_prime_mod_rev: forall p q, 0 < q -> rel_prime (p mod q) q -> rel_prime p q. Proof. intros p q H H0. @@ -715,7 +713,7 @@ Proof. assert (a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p). assert (Zabs a <= Zabs p). apply Zdivide_bounds; [ assumption | omega ]. - generalize H3. + generalize H3. pattern (Zabs a) in |- *; apply Zabs_ind; pattern (Zabs p) in |- *; apply Zabs_ind; intros; omega. intuition idtac. @@ -785,7 +783,7 @@ Proof. intros H1; absurd (1 < 1); auto with zarith. inversion H1; auto. Qed. - + Lemma prime_2: prime 2. Proof. apply prime_intro; auto with zarith. @@ -795,7 +793,7 @@ Proof. subst n; red; auto with zarith. apply Zis_gcd_intro; auto with zarith. Qed. - + Theorem prime_3: prime 3. Proof. apply prime_intro; auto with zarith. @@ -812,7 +810,7 @@ Proof. subst n; red; auto with zarith. apply Zis_gcd_intro; auto with zarith. Qed. - + Theorem prime_ge_2: forall p, prime p -> 2 <= p. Proof. intros p Hp; inversion Hp; auto with zarith. @@ -820,7 +818,7 @@ Qed. Definition prime' p := 1

~ (n|p)). -Theorem prime_alt: +Theorem prime_alt: forall p, prime' p <-> prime p. Proof. split; destruct 1; intros. @@ -848,7 +846,7 @@ Proof. apply Zis_gcd_intro; auto with zarith. apply H0; auto with zarith. Qed. - + Theorem square_not_prime: forall a, ~ prime (a * a). Proof. intros a Ha. @@ -864,10 +862,10 @@ Proof. exists b; auto. Qed. -Theorem prime_div_prime: forall p q, +Theorem prime_div_prime: forall p q, prime p -> prime q -> (p | q) -> p = q. Proof. - intros p q H H1 H2; + intros p q H H1 H2; assert (Hp: 0 < p); try apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. assert (Hq: 0 < q); try apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. case prime_divisors with (2 := H2); auto. @@ -878,10 +876,10 @@ Proof. Qed. -(** We could obtain a [Zgcd] function via Euclid algorithm. But we propose +(** We could obtain a [Zgcd] function via Euclid algorithm. But we propose here a binary version of [Zgcd], faster and executable within Coq. - Algorithm: + Algorithm: gcd 0 b = b gcd a 0 = a @@ -889,23 +887,23 @@ Qed. gcd (2a+1) (2b) = gcd (2a+1) b gcd (2a) (2b+1) = gcd a (2b+1) gcd (2a+1) (2b+1) = gcd (b-a) (2*a+1) - or gcd (a-b) (2*b+1), depending on whether a 1 - | S n => - match a,b with - | xH, _ => 1 + | S n => + match a,b with + | xH, _ => 1 | _, xH => 1 | xO a, xO b => xO (Pgcdn n a b) | a, xO b => Pgcdn n a b | xO a, b => Pgcdn n a b - | xI a', xI b' => - match Pcompare a' b' Eq with + | xI a', xI b' => + match Pcompare a' b' Eq with | Eq => a | Lt => Pgcdn n (b'-a') a | Gt => Pgcdn n (a'-b') b @@ -919,7 +917,7 @@ Close Scope positive_scope. Definition Zgcd (a b : Z) : Z := match a,b with - | Z0, _ => Zabs b + | Z0, _ => Zabs b | _, Z0 => Zabs a | Zpos a, Zpos b => Zpos (Pgcd a b) | Zpos a, Zneg b => Zpos (Pgcd a b) @@ -932,8 +930,8 @@ Proof. unfold Zgcd; destruct a; destruct b; auto with zarith. Qed. -Lemma Zis_gcd_even_odd : forall a b g, Zis_gcd (Zpos a) (Zpos (xI b)) g -> - Zis_gcd (Zpos (xO a)) (Zpos (xI b)) g. +Lemma Zis_gcd_even_odd : forall a b g, Zis_gcd (Zpos a) (Zpos (xI b)) g -> + Zis_gcd (Zpos (xO a)) (Zpos (xI b)) g. Proof. intros. destruct H. @@ -951,7 +949,7 @@ Proof. omega. Qed. -Lemma Pgcdn_correct : forall n a b, (Psize a + Psize b<=n)%nat -> +Lemma Pgcdn_correct : forall n a b, (Psize a + Psize b<=n)%nat -> Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcdn n a b)). Proof. intro n; pattern n; apply lt_wf_ind; clear n; intros. @@ -977,7 +975,7 @@ Proof. rewrite (Zpos_minus_morphism _ _ H1). assert (0 < Zpos a) by (compute; auto). omega. - omega. + omega. rewrite Zpos_xO; do 2 rewrite Zpos_xI. rewrite Zpos_minus_morphism; auto. omega. @@ -995,7 +993,7 @@ Proof. assert (0 < Zpos b) by (compute; auto). omega. rewrite ZC4; rewrite H1; auto. - omega. + omega. rewrite Zpos_xO; do 2 rewrite Zpos_xI. rewrite Zpos_minus_morphism; auto. omega. @@ -1062,7 +1060,7 @@ Proof. split; [apply Zgcd_is_gcd | apply Zgcd_is_pos]. Qed. -Theorem Zdivide_Zgcd: forall p q r : Z, +Theorem Zdivide_Zgcd: forall p q r : Z, (p | q) -> (p | r) -> (p | Zgcd q r). Proof. intros p q r H1 H2. @@ -1071,7 +1069,7 @@ Proof. inversion_clear H3; auto. Qed. -Theorem Zis_gcd_gcd: forall a b c : Z, +Theorem Zis_gcd_gcd: forall a b c : Z, 0 <= c -> Zis_gcd a b c -> Zgcd a b = c. Proof. intros a b c H1 H2. @@ -1103,7 +1101,7 @@ Proof. rewrite H1; ring. Qed. -Theorem Zgcd_div_swap0 : forall a b : Z, +Theorem Zgcd_div_swap0 : forall a b : Z, 0 < Zgcd a b -> 0 < b -> (a / Zgcd a b) * b = a * (b/Zgcd a b). @@ -1116,7 +1114,7 @@ Proof. rewrite <- Zdivide_Zdiv_eq; auto. Qed. -Theorem Zgcd_div_swap : forall a b c : Z, +Theorem Zgcd_div_swap : forall a b c : Z, 0 < Zgcd a b -> 0 < b -> (c * a) / Zgcd a b * b = c * a * (b/Zgcd a b). @@ -1131,7 +1129,43 @@ Proof. rewrite <- Zdivide_Zdiv_eq; auto. Qed. -Theorem Zgcd_1_rel_prime : forall a b, +Lemma Zgcd_comm : forall a b, Zgcd a b = Zgcd b a. +Proof. + intros. + apply Zis_gcd_gcd. + apply Zgcd_is_pos. + apply Zis_gcd_sym. + apply Zgcd_is_gcd. +Qed. + +Lemma Zgcd_ass : forall a b c, Zgcd (Zgcd a b) c = Zgcd a (Zgcd b c). +Proof. + intros. + apply Zis_gcd_gcd. + apply Zgcd_is_pos. + destruct (Zgcd_is_gcd a b). + destruct (Zgcd_is_gcd b c). + destruct (Zgcd_is_gcd a (Zgcd b c)). + constructor; eauto using Zdivide_trans. +Qed. + +Lemma Zgcd_Zabs : forall a b, Zgcd (Zabs a) b = Zgcd a b. +Proof. + destruct a; simpl; auto. +Qed. + +Lemma Zgcd_0 : forall a, Zgcd a 0 = Zabs a. +Proof. + destruct a; simpl; auto. +Qed. + +Lemma Zgcd_1 : forall a, Zgcd a 1 = 1. +Proof. + intros; apply Zis_gcd_gcd; auto with zarith; apply Zis_gcd_1. +Qed. +Hint Resolve Zgcd_0 Zgcd_1 : zarith. + +Theorem Zgcd_1_rel_prime : forall a b, Zgcd a b = 1 <-> rel_prime a b. Proof. unfold rel_prime; split; intro H. @@ -1142,7 +1176,7 @@ Proof. generalize (Zgcd_is_pos a b); auto with zarith. Qed. -Definition rel_prime_dec: forall a b, +Definition rel_prime_dec: forall a b, { rel_prime a b }+{ ~ rel_prime a b }. Proof. intros a b; case (Z_eq_dec (Zgcd a b) 1); intros H1. @@ -1156,10 +1190,10 @@ Definition prime_dec_aux: { exists n, 1 < n < m /\ ~ rel_prime n p }. Proof. intros p m. - case (Z_lt_dec 1 m); intros H1; - [ | left; intros; elimtype False; omega ]. + case (Z_lt_dec 1 m); intros H1; + [ | left; intros; exfalso; omega ]. pattern m; apply natlike_rec; auto with zarith. - left; intros; elimtype False; omega. + left; intros; exfalso; omega. intros x Hx IH; destruct IH as [F|E]. destruct (rel_prime_dec x p) as [Y|N]. left; intros n [HH1 HH2]. @@ -1221,34 +1255,34 @@ Qed. Open Scope positive_scope. -Fixpoint Pggcdn (n: nat) (a b : positive) { struct n } : (positive*(positive*positive)) := - match n with +Fixpoint Pggcdn (n: nat) (a b : positive) : (positive*(positive*positive)) := + match n with | O => (1,(a,b)) - | S n => - match a,b with - | xH, b => (1,(1,b)) + | S n => + match a,b with + | xH, b => (1,(1,b)) | a, xH => (1,(a,1)) - | xO a, xO b => - let (g,p) := Pggcdn n a b in + | xO a, xO b => + let (g,p) := Pggcdn n a b in (xO g,p) - | a, xO b => - let (g,p) := Pggcdn n a b in - let (aa,bb) := p in + | a, xO b => + let (g,p) := Pggcdn n a b in + let (aa,bb) := p in (g,(aa, xO bb)) - | xO a, b => - let (g,p) := Pggcdn n a b in - let (aa,bb) := p in + | xO a, b => + let (g,p) := Pggcdn n a b in + let (aa,bb) := p in (g,(xO aa, bb)) - | xI a', xI b' => - match Pcompare a' b' Eq with + | xI a', xI b' => + match Pcompare a' b' Eq with | Eq => (a,(1,1)) - | Lt => - let (g,p) := Pggcdn n (b'-a') a in - let (ba,aa) := p in + | Lt => + let (g,p) := Pggcdn n (b'-a') a in + let (ba,aa) := p in (g,(aa, aa + xO ba)) - | Gt => - let (g,p) := Pggcdn n (a'-b') b in - let (ab,bb) := p in + | Gt => + let (g,p) := Pggcdn n (a'-b') b in + let (ab,bb) := p in (g,(bb+xO ab, bb)) end end @@ -1260,28 +1294,28 @@ Open Scope Z_scope. Definition Zggcd (a b : Z) : Z*(Z*Z) := match a,b with - | Z0, _ => (Zabs b,(0, Zsgn b)) + | Z0, _ => (Zabs b,(0, Zsgn b)) | _, Z0 => (Zabs a,(Zsgn a, 0)) - | Zpos a, Zpos b => - let (g,p) := Pggcd a b in - let (aa,bb) := p in + | Zpos a, Zpos b => + let (g,p) := Pggcd a b in + let (aa,bb) := p in (Zpos g, (Zpos aa, Zpos bb)) - | Zpos a, Zneg b => - let (g,p) := Pggcd a b in - let (aa,bb) := p in + | Zpos a, Zneg b => + let (g,p) := Pggcd a b in + let (aa,bb) := p in (Zpos g, (Zpos aa, Zneg bb)) - | Zneg a, Zpos b => - let (g,p) := Pggcd a b in - let (aa,bb) := p in + | Zneg a, Zpos b => + let (g,p) := Pggcd a b in + let (aa,bb) := p in (Zpos g, (Zneg aa, Zpos bb)) | Zneg a, Zneg b => - let (g,p) := Pggcd a b in - let (aa,bb) := p in + let (g,p) := Pggcd a b in + let (aa,bb) := p in (Zpos g, (Zneg aa, Zneg bb)) end. -Lemma Pggcdn_gcdn : forall n a b, +Lemma Pggcdn_gcdn : forall n a b, fst (Pggcdn n a b) = Pgcdn n a b. Proof. induction n. @@ -1302,15 +1336,15 @@ Qed. Lemma Zggcd_gcd : forall a b, fst (Zggcd a b) = Zgcd a b. Proof. - destruct a; destruct b; simpl; auto; rewrite <- Pggcd_gcd; + destruct a; destruct b; simpl; auto; rewrite <- Pggcd_gcd; destruct (Pggcd p p0) as (g,(aa,bb)); simpl; auto. Qed. Open Scope positive_scope. -Lemma Pggcdn_correct_divisors : forall n a b, - let (g,p) := Pggcdn n a b in - let (aa,bb):=p in +Lemma Pggcdn_correct_divisors : forall n a b, + let (g,p) := Pggcdn n a b in + let (aa,bb):=p in (a=g*aa) /\ (b=g*bb). Proof. induction n. @@ -1337,7 +1371,7 @@ Proof. rewrite <- H1; rewrite <- H0. simpl; f_equal; symmetry. apply Pplus_minus; auto. - (* Then... *) + (* Then... *) generalize (IHn (xI a) b); destruct (Pggcdn n (xI a) b) as (g,(ab,bb)); simpl. intros (H0,H1); split; auto. rewrite Pmult_xO_permute_r; rewrite H1; auto. @@ -1348,9 +1382,9 @@ Proof. intros (H0,H1); split; subst; auto. Qed. -Lemma Pggcd_correct_divisors : forall a b, - let (g,p) := Pggcd a b in - let (aa,bb):=p in +Lemma Pggcd_correct_divisors : forall a b, + let (g,p) := Pggcd a b in + let (aa,bb):=p in (a=g*aa) /\ (b=g*bb). Proof. intros a b; exact (Pggcdn_correct_divisors (Psize a + Psize b)%nat a b). @@ -1358,17 +1392,17 @@ Qed. Close Scope positive_scope. -Lemma Zggcd_correct_divisors : forall a b, - let (g,p) := Zggcd a b in - let (aa,bb):=p in +Lemma Zggcd_correct_divisors : forall a b, + let (g,p) := Zggcd a b in + let (aa,bb):=p in (a=g*aa) /\ (b=g*bb). Proof. - destruct a; destruct b; simpl; auto; try solve [rewrite Pmult_comm; simpl; auto]; - generalize (Pggcd_correct_divisors p p0); destruct (Pggcd p p0) as (g,(aa,bb)); + destruct a; destruct b; simpl; auto; try solve [rewrite Pmult_comm; simpl; auto]; + generalize (Pggcd_correct_divisors p p0); destruct (Pggcd p p0) as (g,(aa,bb)); destruct 1; subst; auto. Qed. -Theorem Zggcd_opp: forall x y, +Theorem Zggcd_opp: forall x y, Zggcd (-x) y = let (p1,p) := Zggcd x y in let (p2,p3) := p in (p1,(-p2,p3)). diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 73808f92..511c364b 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* n <= m. Proof. @@ -201,7 +202,7 @@ Hint Resolve Zle_refl: zarith. Lemma Zle_antisym : forall n m:Z, n <= m -> m <= n -> n = m. Proof. - intros n m H1 H2; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]]. + intros n m H1 H2; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]]. absurd (m > n); [ apply Zle_not_gt | apply Zlt_gt ]; assumption. assumption. absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption. @@ -256,6 +257,13 @@ Proof. | absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption ]. Qed. +Lemma Zle_lt_or_eq_iff : forall n m, n <= m <-> n < m \/ n = m. +Proof. + unfold Zle, Zlt. intros. + generalize (Zcompare_Eq_iff_eq n m). + destruct (n ?= m); intuition; discriminate. +Qed. + (** Dichotomy *) Lemma Zle_or_lt : forall n m:Z, n <= m \/ m < n. @@ -276,8 +284,7 @@ Qed. Lemma Zlt_trans : forall n m p:Z, n < m -> m < p -> n < p. Proof. - intros n m p H1 H2; apply Zgt_lt; apply Zgt_trans with (m := m); apply Zlt_gt; - assumption. + exact Zcompare_Lt_trans. Qed. (** Mixed transitivity *) @@ -400,13 +407,13 @@ Qed. Lemma Zgt_le_succ : forall n m:Z, m > n -> Zsucc n <= m. Proof. unfold Zgt, Zle in |- *; intros n p H; elim (Zcompare_Gt_not_Lt p n); - intros H1 H2; unfold not in |- *; intros H3; unfold not in H1; + intros H1 H2; unfold not in |- *; intros H3; unfold not in H1; apply H1; [ assumption | elim (Zcompare_Gt_Lt_antisym (n + 1) p); intros H4 H5; apply H4; exact H3 ]. Qed. -Lemma Zlt_gt_succ : forall n m:Z, n <= m -> Zsucc m > n. +Lemma Zle_gt_succ : forall n m:Z, n <= m -> Zsucc m > n. Proof. intros n p H; apply Zgt_le_trans with p. apply Zgt_succ. @@ -415,7 +422,7 @@ Qed. Lemma Zle_lt_succ : forall n m:Z, n <= m -> n < Zsucc m. Proof. - intros n m H; apply Zgt_lt; apply Zlt_gt_succ; assumption. + intros n m H; apply Zgt_lt; apply Zle_gt_succ; assumption. Qed. Lemma Zlt_le_succ : forall n m:Z, n < m -> Zsucc n <= m. @@ -433,12 +440,17 @@ Proof. intros n m H; apply Zgt_succ_le; apply Zlt_gt; assumption. Qed. -Lemma Zlt_succ_gt : forall n m:Z, Zsucc n <= m -> m > n. +Lemma Zle_succ_gt : forall n m:Z, Zsucc n <= m -> m > n. Proof. intros n m H; apply Zle_gt_trans with (m := Zsucc n); [ assumption | apply Zgt_succ ]. Qed. +Lemma Zlt_succ_r : forall n m, n < Zsucc m <-> n <= m. +Proof. + split; [apply Zlt_succ_le | apply Zle_lt_succ]. +Qed. + (** Weakening order *) Lemma Zle_succ : forall n:Z, n <= Zsucc n. @@ -478,9 +490,9 @@ Hint Resolve Zle_le_succ: zarith. Lemma Zgt_succ_pred : forall n m:Z, m > Zsucc n -> Zpred m > n. Proof. unfold Zgt, Zsucc, Zpred in |- *; intros n p H; - rewrite <- (fun x y => Zcompare_plus_compat x y 1); + rewrite <- (fun x y => Zcompare_plus_compat x y 1); rewrite (Zplus_comm p); rewrite Zplus_assoc; - rewrite (fun x => Zplus_comm x n); simpl in |- *; + rewrite (fun x => Zplus_comm x n); simpl in |- *; assumption. Qed. @@ -563,7 +575,7 @@ Proof. assert (Hle : m <= n). apply Zgt_succ_le; assumption. destruct (Zle_lt_or_eq _ _ Hle) as [Hlt| Heq]. - left; apply Zlt_gt; assumption. + left; apply Zlt_gt; assumption. right; assumption. Qed. @@ -680,7 +692,7 @@ Proof. rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial. Qed. -(** ** Multiplication *) +(** ** Multiplication *) (** Compatibility of multiplication by a positive wrt to order *) Lemma Zmult_le_compat_r : forall n m p:Z, n <= m -> 0 <= p -> n * p <= m * p. @@ -777,7 +789,7 @@ Proof. intros a b c d H0 H1 H2 H3. apply Zge_trans with (a * d). apply Zmult_ge_compat_l; trivial. - apply Zge_trans with c; trivial. + apply Zge_trans with c; trivial. apply Zmult_ge_compat_r; trivial. Qed. @@ -965,17 +977,17 @@ Qed. Lemma Zeq_plus_swap : forall n m p:Z, n + p = m <-> n = m - p. Proof. - intros x y z; intros. split. intro. apply Zplus_minus_eq. symmetry in |- *. rewrite Zplus_comm. + intros x y z; intros. split. intro. apply Zplus_minus_eq. symmetry in |- *. rewrite Zplus_comm. assumption. - intro. rewrite H. unfold Zminus in |- *. rewrite Zplus_assoc_reverse. + intro. rewrite H. unfold Zminus in |- *. rewrite Zplus_assoc_reverse. rewrite Zplus_opp_l. apply Zplus_0_r. Qed. Lemma Zlt_minus_simpl_swap : forall n m:Z, 0 < m -> n - m < n. Proof. intros n m H; apply Zplus_lt_reg_l with (p := m); rewrite Zplus_minus; - pattern n at 1 in |- *; rewrite <- (Zplus_0_r n); - rewrite (Zplus_comm m n); apply Zplus_lt_compat_l; + pattern n at 1 in |- *; rewrite <- (Zplus_0_r n); + rewrite (Zplus_comm m n); apply Zplus_lt_compat_l; assumption. Qed. @@ -993,8 +1005,8 @@ Qed. Lemma Zle_minus_le_0 : forall n m:Z, m <= n -> 0 <= n - m. Proof. - intros n m H; unfold Zminus; apply Zplus_le_reg_r with (p := m); - rewrite <- Zplus_assoc; rewrite Zplus_opp_l; rewrite Zplus_0_r; exact H. + intros n m H; unfold Zminus; apply Zplus_le_reg_r with (p := m); + rewrite <- Zplus_assoc; rewrite Zplus_opp_l; rewrite Zplus_0_r; exact H. Qed. Lemma Zmult_lt_compat: @@ -1012,7 +1024,7 @@ Proof. rewrite <- H5; simpl; apply Zmult_lt_0_compat; auto with zarith. Qed. -Lemma Zmult_lt_compat2: +Lemma Zmult_lt_compat2: forall n m p q : Z, 0 < n <= p -> 0 < m < q -> n * m < p * q. Proof. intros n m p q (H1, H2) (H3, H4). @@ -1025,5 +1037,3 @@ Qed. (** For compatibility *) Notation Zlt_O_minus_lt := Zlt_0_minus_lt (only parsing). -Notation Zle_gt_succ := Zlt_gt_succ (only parsing). -Notation Zle_succ_gt := Zlt_succ_gt (only parsing). diff --git a/theories/ZArith/Zpow_def.v b/theories/ZArith/Zpow_def.v index b0f372de..620d6324 100644 --- a/theories/ZArith/Zpow_def.v +++ b/theories/ZArith/Zpow_def.v @@ -2,11 +2,11 @@ Require Import ZArith_base. Require Import Ring_theory. Open Local Scope Z_scope. - + (** [Zpower_pos z n] is the n-th power of [z] when [n] is an binary - integer (type [positive]) and [z] a signed integer (type [Z]) *) + integer (type [positive]) and [z] a signed integer (type [Z]) *) Definition Zpower_pos (z:Z) (n:positive) := iter_pos n Z (fun x:Z => z * x) 1. - + Definition Zpower (x y:Z) := match y with | Zpos p => Zpower_pos x p @@ -24,4 +24,4 @@ Proof. repeat rewrite Zmult_assoc;trivial. rewrite H;rewrite Zmult_1_r;trivial. Qed. - + diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v index 3d4d235a..1d9b3dfc 100644 --- a/theories/ZArith/Zpow_facts.v +++ b/theories/ZArith/Zpow_facts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zpow_facts.v 11098 2008-06-11 09:16:22Z letouzey $ i*) +(*i $Id$ i*) Require Import ZArith_base. Require Import ZArithRing. @@ -37,7 +37,7 @@ Proof. Qed. Lemma Zpower_pos_0_l: forall p, Zpower_pos 0 p = 0. -Proof. +Proof. induction p. change (xI p) with (1 + (xO p))%positive. rewrite Zpower_pos_is_exp, Zpower_pos_1_r; auto. @@ -133,7 +133,7 @@ Proof. apply Zle_ge; replace 0 with (0 * r1); try apply Zmult_le_compat_r; auto. Qed. -Theorem Zpower_le_monotone: forall a b c, +Theorem Zpower_le_monotone: forall a b c, 0 < a -> 0 <= b <= c -> a^b <= a^c. Proof. intros a b c H (H1, H2). @@ -145,7 +145,7 @@ Proof. apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith. Qed. -Theorem Zpower_lt_monotone: forall a b c, +Theorem Zpower_lt_monotone: forall a b c, 1 < a -> 0 <= b < c -> a^b < a^c. Proof. intros a b c H (H1, H2). @@ -160,7 +160,7 @@ Proof. apply Zpower_le_monotone; auto with zarith. Qed. -Theorem Zpower_gt_1 : forall x y, +Theorem Zpower_gt_1 : forall x y, 1 < x -> 0 < y -> 1 < x^y. Proof. intros x y H1 H2. @@ -168,14 +168,14 @@ Proof. apply Zpower_lt_monotone; auto with zarith. Qed. -Theorem Zpower_ge_0: forall x y, 0 <= x -> 0 <= x^y. +Theorem Zpower_ge_0: forall x y, 0 <= x -> 0 <= x^y. Proof. intros x y; case y; auto with zarith. simpl ; auto with zarith. intros p H1; assert (H: 0 <= Zpos p); auto with zarith. generalize H; pattern (Zpos p); apply natlike_ind; auto with zarith. - intros p1 H2 H3 _; unfold Zsucc; rewrite Zpower_exp; simpl; auto with zarith. - apply Zmult_le_0_compat; auto with zarith. + intros p1 H2 H3 _; unfold Zsucc; rewrite Zpower_exp; simpl; auto with zarith. + apply Zmult_le_0_compat; auto with zarith. generalize H1; case x; compute; intros; auto; try discriminate. Qed. @@ -195,7 +195,7 @@ Proof. destruct b;trivial;unfold Zgt in z;discriminate z. Qed. -Theorem Zmult_power: forall p q r, 0 <= r -> +Theorem Zmult_power: forall p q r, 0 <= r -> (p*q)^r = p^r * q^r. Proof. intros p q r H1; generalize H1; pattern r; apply natlike_ind; auto. @@ -206,7 +206,7 @@ Qed. Hint Resolve Zpower_ge_0 Zpower_gt_0: zarith. -Theorem Zpower_le_monotone3: forall a b c, +Theorem Zpower_le_monotone3: forall a b c, 0 <= c -> 0 <= a <= b -> a^c <= b^c. Proof. intros a b c H (H1, H2). @@ -216,7 +216,7 @@ Proof. apply Zle_trans with (a^x * b); auto with zarith. Qed. -Lemma Zpower_le_monotone_inv: forall a b c, +Lemma Zpower_le_monotone_inv: forall a b c, 1 < a -> 0 < b -> a^b <= a^c -> b <= c. Proof. intros a b c H H0 H1. @@ -227,14 +227,14 @@ Proof. apply Zpower_le_monotone;auto with zarith. apply Zpower_le_monotone3;auto with zarith. assert (c > 0). - destruct (Z_le_gt_dec 0 c);trivial. + destruct (Z_le_gt_dec 0 c);trivial. destruct (Zle_lt_or_eq _ _ z0);auto with zarith. - rewrite <- H3 in H1;simpl in H1; elimtype False;omega. - destruct c;try discriminate z0. simpl in H1. elimtype False;omega. - assert (H4 := Zpower_lt_monotone a c b H). elimtype False;omega. + rewrite <- H3 in H1;simpl in H1; exfalso;omega. + destruct c;try discriminate z0. simpl in H1. exfalso;omega. + assert (H4 := Zpower_lt_monotone a c b H). exfalso;omega. Qed. -Theorem Zpower_nat_Zpower: forall p q, 0 <= q -> +Theorem Zpower_nat_Zpower: forall p q, 0 <= q -> p^q = Zpower_nat p (Zabs_nat q). Proof. intros p1 q1; case q1; simpl. @@ -262,7 +262,7 @@ Proof. intros; apply Zlt_le_weak; apply Zpower2_lt_lin; auto. Qed. -Lemma Zpower2_Psize : +Lemma Zpower2_Psize : forall n p, Zpos p < 2^(Z_of_nat n) <-> (Psize p <= n)%nat. Proof. induction n. @@ -294,7 +294,7 @@ Qed. (** A direct way to compute Zpower modulo **) -Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) {struct m} : Z := +Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) : Z := match m with | xH => a mod n | xO m' => @@ -311,14 +311,14 @@ Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) {struct m} : Z := end end. -Definition Zpow_mod a m n := - match m with - | 0 => 1 - | Zpos p => Zpow_mod_pos a p n - | Zneg p => 0 +Definition Zpow_mod a m n := + match m with + | 0 => 1 + | Zpos p => Zpow_mod_pos a p n + | Zneg p => 0 end. -Theorem Zpow_mod_pos_correct: forall a m n, 0 < n -> +Theorem Zpow_mod_pos_correct: forall a m n, 0 < n -> Zpow_mod_pos a m n = (Zpower_pos a m) mod n. Proof. intros a m; elim m; simpl; auto. @@ -327,12 +327,12 @@ Proof. repeat rewrite Rec; auto. rewrite Zpower_pos_1_r. repeat rewrite (fun x => (Zmult_mod x a)); auto with zarith. - rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith. + rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith. case (Zpower_pos a p mod n); auto. intros p Rec n H1; rewrite <- Pplus_diag; auto. repeat rewrite Zpower_pos_is_exp; auto. repeat rewrite Rec; auto. - rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith. + rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith. case (Zpower_pos a p mod n); auto. unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto with zarith. Qed. @@ -354,7 +354,7 @@ Proof. pattern p at 3; rewrite <- (Zpower_1_r p); rewrite <- Zpower_exp; try f_equal; auto with zarith. Qed. -Theorem rel_prime_Zpower_r: forall i p q, 0 < i -> +Theorem rel_prime_Zpower_r: forall i p q, 0 < i -> rel_prime p q -> rel_prime p (q^i). Proof. intros i p q Hi Hpq; generalize Hi; pattern i; apply natlike_ind; auto with zarith; clear i Hi. @@ -365,7 +365,7 @@ Proof. rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1. Qed. -Theorem rel_prime_Zpower: forall i j p q, 0 <= i -> 0 <= j -> +Theorem rel_prime_Zpower: forall i j p q, 0 <= i -> 0 <= j -> rel_prime p q -> rel_prime (p^i) (q^j). Proof. intros i j p q Hi; generalize Hi j p q; pattern i; apply natlike_ind; auto with zarith; clear i Hi j p q. @@ -379,7 +379,7 @@ Proof. rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1. Qed. -Theorem prime_power_prime: forall p q n, 0 <= n -> +Theorem prime_power_prime: forall p q n, 0 <= n -> prime p -> prime q -> (p | q^n) -> p = q. Proof. intros p q n Hn Hp Hq; pattern n; apply natlike_ind; auto; clear n Hn. @@ -442,15 +442,15 @@ Fixpoint Psquare (p: positive): positive := end. Definition Zsquare p := - match p with - | Z0 => Z0 - | Zpos p => Zpos (Psquare p) + match p with + | Z0 => Z0 + | Zpos p => Zpos (Psquare p) | Zneg p => Zpos (Psquare p) end. Theorem Psquare_correct: forall p, Psquare p = (p * p)%positive. Proof. - induction p; simpl; auto; f_equal; rewrite IHp. + induction p; simpl; auto; f_equal; rewrite IHp. apply trans_equal with (xO p + xO (p*p))%positive; auto. rewrite (Pplus_comm (xO p)); auto. rewrite Pmult_xI_permute_r; rewrite Pplus_assoc. diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index 1912f5e1..508e6601 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zpower.v 11072 2008-06-08 16:13:37Z herbelin $ i*) +(*i $Id$ i*) Require Import Wf_nat. Require Import ZArith_base. @@ -20,7 +20,7 @@ Infix "^" := Zpower : Z_scope. (** * Definition of powers over [Z]*) (** [Zpower_nat z n] is the n-th power of [z] when [n] is an unary - integer (type [nat]) and [z] a signed integer (type [Z]) *) + integer (type [nat]) and [z] a signed integer (type [Z]) *) Definition Zpower_nat (z:Z) (n:nat) := iter_nat n Z (fun x:Z => z * x) 1. @@ -83,12 +83,12 @@ Section Powers_of_2. (** For the powers of two, that will be widely used, a more direct calculus is possible. We will also prove some properties such as [(x:positive) x < 2^x] that are true for all integers bigger - than 2 but more difficult to prove and useless. *) + than 2 but more difficult to prove and useless. *) (** [shift n m] computes [2^n * m], or [m] shifted by [n] positions *) - Definition shift_nat (n:nat) (z:positive) := iter_nat n positive xO z. - Definition shift_pos (n z:positive) := iter_pos n positive xO z. + Definition shift_nat (n:nat) (z:positive) := iter_nat n positive xO z. + Definition shift_pos (n z:positive) := iter_pos n positive xO z. Definition shift (n:Z) (z:positive) := match n with | Z0 => z @@ -130,7 +130,7 @@ Section Powers_of_2. rewrite (shift_nat_correct n). omega. Qed. - + (** Second we show that [two_power_pos] and [two_power_nat] are the same *) Lemma shift_pos_nat : forall p x:positive, shift_pos p x = shift_nat (nat_of_P p) x. @@ -181,12 +181,12 @@ Section Powers_of_2. apply Zpower_pos_is_exp. Qed. - (** The exponentiation [z -> 2^z] for [z] a signed integer. + (** The exponentiation [z -> 2^z] for [z] a signed integer. For convenience, we assume that [2^z = 0] for all [z < 0] We could also define a inductive type [Log_result] with 3 contructors [ Zero | Pos positive -> | minus_infty] but it's more complexe and not so useful. *) - + Definition two_p (x:Z) := match x with | Z0 => 1 @@ -227,7 +227,7 @@ Section Powers_of_2. Lemma two_p_S : forall x:Z, 0 <= x -> two_p (Zsucc x) = 2 * two_p x. Proof. - intros; unfold Zsucc in |- *. + intros; unfold Zsucc in |- *. rewrite (two_p_is_exp x 1 H (Zorder.Zle_0_pos 1)). apply Zmult_comm. Qed. @@ -247,10 +247,10 @@ Section Powers_of_2. | intro Hx0; rewrite <- Hx0; simpl in |- *; unfold Zlt in |- *; auto with zarith ] | assumption ]. - Qed. + Qed. Lemma Zlt_lt_double : forall x y:Z, 0 <= x < y -> x < 2 * y. - intros; omega. Qed. + intros; omega. Qed. End Powers_of_2. @@ -286,13 +286,13 @@ Section power_div_with_rest. let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in d = two_power_pos p. Proof. intros x p; rewrite (iter_nat_of_P p _ Zdiv_rest_aux (x, 0, 1)); - rewrite (two_power_pos_nat p); elim (nat_of_P p); + rewrite (two_power_pos_nat p); elim (nat_of_P p); simpl in |- *; [ trivial with zarith | intro n; rewrite (two_power_nat_S n); unfold Zdiv_rest_aux at 2 in |- *; - elim (iter_nat n (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)); + elim (iter_nat n (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)); destruct a; intros; apply f_equal with (f := fun z:Z => 2 * z); - assumption ]. + assumption ]. Qed. Lemma Zdiv_rest_correct2 : @@ -327,7 +327,7 @@ Section power_div_with_rest. apply f_equal with (f := fun z:Z => z + r); do 2 rewrite Zmult_plus_distr_l; rewrite Zmult_assoc; rewrite (Zmult_comm (Zneg p0) 2); rewrite <- Zplus_assoc; - apply f_equal with (f := fun z:Z => 2 * Zneg p0 * d + z); + apply f_equal with (f := fun z:Z => 2 * Zneg p0 * d + z); omega | omega ] | rewrite BinInt.Zneg_xO; unfold Zminus in |- *; intro; elim H; intros; diff --git a/theories/ZArith/Zsqrt.v b/theories/ZArith/Zsqrt.v index 6ea952e6..b845cf47 100644 --- a/theories/ZArith/Zsqrt.v +++ b/theories/ZArith/Zsqrt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Zsqrt.v 10295 2007-11-06 22:46:21Z letouzey $ *) +(* $Id$ *) Require Import ZArithRing. Require Import Omega. @@ -119,7 +119,7 @@ Definition Zsqrt : | Zneg p => fun h => False_rec - {s : Z & + {s : Z & {r : Z | Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}} (h (refl_equal Datatypes.Gt)) @@ -199,7 +199,7 @@ Qed. Theorem Zsqrt_le: forall p q, 0 <= p <= q -> Zsqrt_plain p <= Zsqrt_plain q. Proof. - intros p q [H1 H2]; case Zle_lt_or_eq with (1:=H2); clear H2; intros H2; + intros p q [H1 H2]; case Zle_lt_or_eq with (1:=H2); clear H2; intros H2; [ | subst q; auto with zarith]. case (Zle_or_lt (Zsqrt_plain p) (Zsqrt_plain q)); auto; intros H3. assert (Hp: (0 <= Zsqrt_plain q)). diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v index bd617204..32d6de19 100644 --- a/theories/ZArith/Zwf.v +++ b/theories/ZArith/Zwf.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Zwf.v 9245 2006-10-17 12:53:34Z notin $ *) +(* $Id$ *) Require Import ZArith_base. Require Export Wf_nat. @@ -15,7 +15,7 @@ Open Local Scope Z_scope. (** Well-founded relations on Z. *) -(** We define the following family of relations on [Z x Z]: +(** We define the following family of relations on [Z x Z]: [x (Zwf c) y] iff [x < y & c <= y] *) diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v index ffc3e70f..7af99ece 100644 --- a/theories/ZArith/auxiliary.v +++ b/theories/ZArith/auxiliary.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* Zne (n + - m) 0. Proof. intros x y; unfold Zne in |- *; unfold not in |- *; intros H1 H2; apply H1; - apply Zplus_reg_l with (- y); rewrite Zplus_opp_l; + apply Zplus_reg_l with (- y); rewrite Zplus_opp_l; rewrite Zplus_comm; trivial with arith. Qed. @@ -97,7 +98,7 @@ Proof. intros x y z H1 H2 H3; apply Zle_trans with (m := y * x); [ apply Zmult_gt_0_le_0_compat; assumption | pattern (y * x) at 1 in |- *; rewrite <- Zplus_0_r; - apply Zplus_le_compat_l; apply Zlt_le_weak; apply Zgt_lt; + apply Zplus_le_compat_l; apply Zlt_le_weak; apply Zgt_lt; assumption ]. Qed. diff --git a/theories/ZArith/vo.itarget b/theories/ZArith/vo.itarget new file mode 100644 index 00000000..3efa7055 --- /dev/null +++ b/theories/ZArith/vo.itarget @@ -0,0 +1,32 @@ +auxiliary.vo +BinInt.vo +Int.vo +Wf_Z.vo +Zabs.vo +ZArith_base.vo +ZArith_dec.vo +ZArith.vo +Zdigits.vo +Zbool.vo +Zcompare.vo +Zcomplements.vo +Zdiv.vo +Zeven.vo +Zgcd_alt.vo +Zhints.vo +Zlogarithm.vo +Zmax.vo +Zminmax.vo +Zmin.vo +Zmisc.vo +Znat.vo +Znumtheory.vo +ZOdiv_def.vo +ZOdiv.vo +Zorder.vo +Zpow_def.vo +Zpower.vo +Zpow_facts.vo +Zsqrt.vo +Zwf.vo +ZOrderedType.vo diff --git a/theories/theories.itarget b/theories/theories.itarget new file mode 100644 index 00000000..afc3554b --- /dev/null +++ b/theories/theories.itarget @@ -0,0 +1,22 @@ +Arith/vo.otarget +Bool/vo.otarget +Classes/vo.otarget +FSets/vo.otarget +MSets/vo.otarget +Structures/vo.otarget +Init/vo.otarget +Lists/vo.otarget +Logic/vo.otarget +NArith/vo.otarget +Numbers/vo.otarget +Program/vo.otarget +QArith/vo.otarget +Reals/vo.otarget +Relations/vo.otarget +Setoids/vo.otarget +Sets/vo.otarget +Sorting/vo.otarget +Strings/vo.otarget +Unicode/vo.otarget +Wellfounded/vo.otarget +ZArith/vo.otarget -- cgit v1.2.3