From 9043add656177eeac1491a73d2f3ab92bec0013c Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Sat, 29 Dec 2018 14:31:27 -0500 Subject: Imported Upstream version 8.8.2 --- theories/Arith/Arith.v | 10 +- theories/Arith/Arith_base.v | 10 +- theories/Arith/Between.v | 86 +- theories/Arith/Bool_nat.v | 10 +- theories/Arith/Compare.v | 10 +- theories/Arith/Compare_dec.v | 22 +- theories/Arith/Div2.v | 18 +- theories/Arith/EqNat.v | 16 +- theories/Arith/Euclid.v | 10 +- theories/Arith/Even.v | 14 +- theories/Arith/Factorial.v | 10 +- theories/Arith/Gt.v | 10 +- theories/Arith/Le.v | 28 +- theories/Arith/Lt.v | 39 +- theories/Arith/Max.v | 10 +- theories/Arith/Min.v | 10 +- theories/Arith/Minus.v | 20 +- theories/Arith/Mult.v | 34 +- theories/Arith/PeanoNat.v | 40 +- theories/Arith/Peano_dec.v | 14 +- theories/Arith/Plus.v | 24 +- theories/Arith/Wf_nat.v | 10 +- theories/Arith/vo.itarget | 22 - theories/Bool/Bool.v | 10 +- theories/Bool/BoolEq.v | 10 +- theories/Bool/Bvector.v | 10 +- theories/Bool/DecBool.v | 10 +- theories/Bool/IfProp.v | 10 +- theories/Bool/Sumbool.v | 10 +- theories/Bool/Zerob.v | 10 +- theories/Bool/vo.itarget | 7 - theories/Classes/CEquivalence.v | 10 +- theories/Classes/CMorphisms.v | 12 +- theories/Classes/CRelationClasses.v | 14 +- theories/Classes/DecidableClass.v | 10 +- theories/Classes/EquivDec.v | 10 +- theories/Classes/Equivalence.v | 10 +- theories/Classes/Init.v | 10 +- theories/Classes/Morphisms.v | 12 +- theories/Classes/Morphisms_Prop.v | 10 +- theories/Classes/Morphisms_Relations.v | 10 +- theories/Classes/RelationClasses.v | 14 +- theories/Classes/RelationPairs.v | 16 +- theories/Classes/SetoidClass.v | 10 +- theories/Classes/SetoidDec.v | 10 +- theories/Classes/SetoidTactics.v | 10 +- theories/Classes/vo.itarget | 15 - theories/Compat/AdmitAxiom.v | 10 +- theories/Compat/Coq84.v | 79 - theories/Compat/Coq85.v | 36 - theories/Compat/Coq86.v | 16 +- theories/Compat/Coq87.v | 23 + theories/Compat/Coq88.v | 11 + theories/Compat/vo.itarget | 4 - theories/FSets/FMapAVL.v | 18 +- theories/FSets/FMapFacts.v | 22 +- theories/FSets/FMapFullAVL.v | 18 +- theories/FSets/FMapInterface.v | 16 +- theories/FSets/FMapList.v | 18 +- theories/FSets/FMapPositive.v | 24 +- theories/FSets/FMapWeakList.v | 18 +- theories/FSets/FMaps.v | 16 +- theories/FSets/FSetAVL.v | 18 +- theories/FSets/FSetBridge.v | 16 +- theories/FSets/FSetCompat.v | 60 +- theories/FSets/FSetDecide.v | 16 +- theories/FSets/FSetEqProperties.v | 16 +- theories/FSets/FSetFacts.v | 16 +- theories/FSets/FSetInterface.v | 16 +- theories/FSets/FSetList.v | 16 +- theories/FSets/FSetPositive.v | 16 +- theories/FSets/FSetProperties.v | 18 +- theories/FSets/FSetToFiniteSet.v | 16 +- theories/FSets/FSetWeakList.v | 16 +- theories/FSets/FSets.v | 18 +- theories/FSets/vo.itarget | 21 - theories/Init/Datatypes.v | 38 +- theories/Init/Decimal.v | 163 ++ theories/Init/Logic.v | 188 ++- theories/Init/Logic_Type.v | 18 +- theories/Init/Nat.v | 68 +- theories/Init/Notations.v | 50 +- theories/Init/Peano.v | 34 +- theories/Init/Prelude.v | 16 +- theories/Init/Specif.v | 481 +++++- theories/Init/Tactics.v | 100 +- theories/Init/Tauto.v | 4 +- theories/Init/Wf.v | 10 +- theories/Init/_CoqProject | 2 + theories/Init/vo.itarget | 11 - theories/Lists/List.v | 42 +- theories/Lists/ListDec.v | 10 +- theories/Lists/ListSet.v | 10 +- theories/Lists/ListTactics.v | 10 +- theories/Lists/SetoidList.v | 16 +- theories/Lists/SetoidPermutation.v | 16 +- theories/Lists/StreamMemo.v | 10 +- theories/Lists/Streams.v | 12 +- theories/Lists/vo.itarget | 8 - theories/Logic/Berardi.v | 10 +- theories/Logic/ChoiceFacts.v | 710 ++++++-- theories/Logic/Classical.v | 10 +- theories/Logic/ClassicalChoice.v | 10 +- theories/Logic/ClassicalDescription.v | 10 +- theories/Logic/ClassicalEpsilon.v | 12 +- theories/Logic/ClassicalFacts.v | 76 +- theories/Logic/ClassicalUniqueChoice.v | 10 +- theories/Logic/Classical_Pred_Type.v | 10 +- theories/Logic/Classical_Prop.v | 16 +- theories/Logic/ConstructiveEpsilon.v | 10 +- theories/Logic/Decidable.v | 10 +- theories/Logic/Description.v | 10 +- theories/Logic/Diaconescu.v | 39 +- theories/Logic/Epsilon.v | 10 +- theories/Logic/Eqdep.v | 10 +- theories/Logic/EqdepFacts.v | 12 +- theories/Logic/Eqdep_dec.v | 10 +- theories/Logic/ExtensionalFunctionRepresentative.v | 26 + theories/Logic/ExtensionalityFacts.v | 10 +- theories/Logic/FinFun.v | 10 +- theories/Logic/FunctionalExtensionality.v | 166 +- theories/Logic/Hurkens.v | 25 +- theories/Logic/IndefiniteDescription.v | 10 +- theories/Logic/JMeq.v | 12 +- theories/Logic/ProofIrrelevance.v | 10 +- theories/Logic/ProofIrrelevanceFacts.v | 10 +- theories/Logic/PropExtensionality.v | 24 + theories/Logic/PropExtensionalityFacts.v | 111 ++ theories/Logic/PropFacts.v | 10 +- theories/Logic/RelationalChoice.v | 10 +- theories/Logic/SetIsType.v | 10 +- theories/Logic/SetoidChoice.v | 62 + theories/Logic/WKL.v | 10 +- theories/Logic/WeakFan.v | 10 +- theories/Logic/vo.itarget | 30 - theories/MSets/MSetAVL.v | 18 +- theories/MSets/MSetDecide.v | 16 +- theories/MSets/MSetEqProperties.v | 16 +- theories/MSets/MSetFacts.v | 16 +- theories/MSets/MSetGenTree.v | 22 +- theories/MSets/MSetInterface.v | 16 +- theories/MSets/MSetList.v | 16 +- theories/MSets/MSetPositive.v | 16 +- theories/MSets/MSetProperties.v | 16 +- theories/MSets/MSetRBT.v | 16 +- theories/MSets/MSetToFiniteSet.v | 16 +- theories/MSets/MSetWeakList.v | 16 +- theories/MSets/MSets.v | 18 +- theories/MSets/vo.itarget | 13 - theories/NArith/BinNat.v | 175 +- theories/NArith/BinNatDef.v | 30 +- theories/NArith/NArith.v | 10 +- theories/NArith/Ndec.v | 22 +- theories/NArith/Ndigits.v | 34 +- theories/NArith/Ndist.v | 10 +- theories/NArith/Ndiv_def.v | 22 +- theories/NArith/Ngcd_def.v | 10 +- theories/NArith/Nnat.v | 64 +- theories/NArith/Nsqrt_def.v | 20 +- theories/NArith/vo.itarget | 10 - theories/Numbers/BigNumPrelude.v | 411 ----- theories/Numbers/BinNums.v | 10 +- theories/Numbers/Cyclic/Abstract/CyclicAxioms.v | 12 +- theories/Numbers/Cyclic/Abstract/DoubleType.v | 71 + theories/Numbers/Cyclic/Abstract/NZCyclic.v | 33 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v | 317 ---- theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v | 437 ----- .../Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v | 966 ----------- theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v | 1494 ----------------- theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v | 519 ------ theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v | 475 ------ theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v | 621 ------- theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v | 1369 ---------------- theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v | 356 ---- theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v | 70 - theories/Numbers/Cyclic/Int31/Cyclic31.v | 265 +-- theories/Numbers/Cyclic/Int31/Int31.v | 10 +- theories/Numbers/Cyclic/Int31/Ring31.v | 10 +- theories/Numbers/Cyclic/ZModulo/ZModulo.v | 17 +- theories/Numbers/DecimalFacts.v | 143 ++ theories/Numbers/DecimalN.v | 107 ++ theories/Numbers/DecimalNat.v | 302 ++++ theories/Numbers/DecimalPos.v | 383 +++++ theories/Numbers/DecimalString.v | 265 +++ theories/Numbers/DecimalZ.v | 75 + theories/Numbers/Integer/Abstract/ZAdd.v | 10 +- theories/Numbers/Integer/Abstract/ZAddOrder.v | 10 +- theories/Numbers/Integer/Abstract/ZAxioms.v | 10 +- theories/Numbers/Integer/Abstract/ZBase.v | 10 +- theories/Numbers/Integer/Abstract/ZBits.v | 10 +- theories/Numbers/Integer/Abstract/ZDivEucl.v | 18 +- theories/Numbers/Integer/Abstract/ZDivFloor.v | 18 +- theories/Numbers/Integer/Abstract/ZDivTrunc.v | 18 +- theories/Numbers/Integer/Abstract/ZGcd.v | 10 +- theories/Numbers/Integer/Abstract/ZLcm.v | 10 +- theories/Numbers/Integer/Abstract/ZLt.v | 10 +- theories/Numbers/Integer/Abstract/ZMaxMin.v | 10 +- theories/Numbers/Integer/Abstract/ZMul.v | 10 +- theories/Numbers/Integer/Abstract/ZMulOrder.v | 10 +- theories/Numbers/Integer/Abstract/ZParity.v | 10 +- theories/Numbers/Integer/Abstract/ZPow.v | 10 +- theories/Numbers/Integer/Abstract/ZProperties.v | 10 +- theories/Numbers/Integer/Abstract/ZSgnAbs.v | 10 +- theories/Numbers/Integer/BigZ/BigZ.v | 208 --- theories/Numbers/Integer/BigZ/ZMake.v | 759 --------- theories/Numbers/Integer/Binary/ZBinary.v | 10 +- theories/Numbers/Integer/NatPairs/ZNatPairs.v | 10 +- theories/Numbers/Integer/SpecViaZ/ZSig.v | 135 -- theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v | 527 ------ theories/Numbers/NaryFunctions.v | 10 +- theories/Numbers/NatInt/NZAdd.v | 10 +- theories/Numbers/NatInt/NZAddOrder.v | 10 +- theories/Numbers/NatInt/NZAxioms.v | 10 +- theories/Numbers/NatInt/NZBase.v | 10 +- theories/Numbers/NatInt/NZBits.v | 10 +- theories/Numbers/NatInt/NZDiv.v | 10 +- theories/Numbers/NatInt/NZDomain.v | 10 +- theories/Numbers/NatInt/NZGcd.v | 10 +- theories/Numbers/NatInt/NZLog.v | 10 +- theories/Numbers/NatInt/NZMul.v | 10 +- theories/Numbers/NatInt/NZMulOrder.v | 10 +- theories/Numbers/NatInt/NZOrder.v | 10 +- theories/Numbers/NatInt/NZParity.v | 12 +- theories/Numbers/NatInt/NZPow.v | 10 +- theories/Numbers/NatInt/NZProperties.v | 10 +- theories/Numbers/NatInt/NZSqrt.v | 10 +- theories/Numbers/Natural/Abstract/NAdd.v | 10 +- theories/Numbers/Natural/Abstract/NAddOrder.v | 10 +- theories/Numbers/Natural/Abstract/NAxioms.v | 10 +- theories/Numbers/Natural/Abstract/NBase.v | 10 +- theories/Numbers/Natural/Abstract/NBits.v | 10 +- theories/Numbers/Natural/Abstract/NDefOps.v | 10 +- theories/Numbers/Natural/Abstract/NDiv.v | 10 +- theories/Numbers/Natural/Abstract/NGcd.v | 10 +- theories/Numbers/Natural/Abstract/NIso.v | 10 +- theories/Numbers/Natural/Abstract/NLcm.v | 10 +- theories/Numbers/Natural/Abstract/NLog.v | 10 +- theories/Numbers/Natural/Abstract/NMaxMin.v | 10 +- theories/Numbers/Natural/Abstract/NMulOrder.v | 10 +- theories/Numbers/Natural/Abstract/NOrder.v | 10 +- theories/Numbers/Natural/Abstract/NParity.v | 10 +- theories/Numbers/Natural/Abstract/NPow.v | 10 +- theories/Numbers/Natural/Abstract/NProperties.v | 10 +- theories/Numbers/Natural/Abstract/NSqrt.v | 10 +- theories/Numbers/Natural/Abstract/NStrongRec.v | 10 +- theories/Numbers/Natural/Abstract/NSub.v | 10 +- theories/Numbers/Natural/BigN/BigN.v | 198 --- theories/Numbers/Natural/BigN/NMake.v | 1706 -------------------- theories/Numbers/Natural/BigN/NMake_gen.ml | 1017 ------------ theories/Numbers/Natural/BigN/Nbasic.v | 569 ------- theories/Numbers/Natural/Binary/NBinary.v | 10 +- theories/Numbers/Natural/Peano/NPeano.v | 134 +- theories/Numbers/Natural/SpecViaZ/NSig.v | 124 -- theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v | 487 ------ theories/Numbers/NumPrelude.v | 10 +- theories/Numbers/Rational/BigQ/BigQ.v | 162 -- theories/Numbers/Rational/BigQ/QMake.v | 1283 --------------- theories/Numbers/Rational/SpecViaQ/QSig.v | 229 --- theories/Numbers/vo.itarget | 91 -- theories/PArith/BinPos.v | 382 +++-- theories/PArith/BinPosDef.v | 65 +- theories/PArith/PArith.v | 10 +- theories/PArith/POrderedType.v | 10 +- theories/PArith/Pnat.v | 70 +- theories/PArith/vo.itarget | 5 - theories/Program/Basics.v | 10 +- theories/Program/Combinators.v | 22 +- theories/Program/Equality.v | 10 +- theories/Program/Program.v | 10 +- theories/Program/Subset.v | 10 +- theories/Program/Syntax.v | 10 +- theories/Program/Tactics.v | 12 +- theories/Program/Utils.v | 10 +- theories/Program/Wf.v | 11 +- theories/Program/vo.itarget | 9 - theories/QArith/QArith.v | 10 +- theories/QArith/QArith_base.v | 76 +- theories/QArith/QOrderedType.v | 10 +- theories/QArith/Qabs.v | 25 +- theories/QArith/Qcabs.v | 14 +- theories/QArith/Qcanon.v | 14 +- theories/QArith/Qfield.v | 10 +- theories/QArith/Qminmax.v | 10 +- theories/QArith/Qpower.v | 14 +- theories/QArith/Qreals.v | 44 +- theories/QArith/Qreduction.v | 36 +- theories/QArith/Qring.v | 10 +- theories/QArith/Qround.v | 24 +- theories/QArith/vo.itarget | 13 - theories/Reals/Alembert.v | 12 +- theories/Reals/AltSeries.v | 68 +- theories/Reals/ArithProp.v | 12 +- theories/Reals/Binomial.v | 10 +- theories/Reals/Cauchy_prod.v | 10 +- theories/Reals/Cos_plus.v | 18 +- theories/Reals/Cos_rel.v | 10 +- theories/Reals/DiscrR.v | 24 +- theories/Reals/Exp_prop.v | 24 +- theories/Reals/Integration.v | 10 +- theories/Reals/MVT.v | 10 +- theories/Reals/Machin.v | 12 +- theories/Reals/NewtonInt.v | 10 +- theories/Reals/PSeries_reg.v | 10 +- theories/Reals/PartSum.v | 10 +- theories/Reals/RIneq.v | 215 +-- theories/Reals/RList.v | 10 +- theories/Reals/ROrderedType.v | 10 +- theories/Reals/R_Ifp.v | 80 +- theories/Reals/R_sqr.v | 63 +- theories/Reals/R_sqrt.v | 131 +- theories/Reals/Ranalysis.v | 12 +- theories/Reals/Ranalysis1.v | 10 +- theories/Reals/Ranalysis2.v | 31 +- theories/Reals/Ranalysis3.v | 42 +- theories/Reals/Ranalysis4.v | 21 +- theories/Reals/Ranalysis5.v | 87 +- theories/Reals/Ranalysis_reg.v | 10 +- theories/Reals/Ratan.v | 56 +- theories/Reals/Raxioms.v | 23 +- theories/Reals/Rbase.v | 10 +- theories/Reals/Rbasic_fun.v | 37 +- theories/Reals/Rcomplete.v | 10 +- theories/Reals/Rdefinitions.v | 39 +- theories/Reals/Rderiv.v | 22 +- theories/Reals/Reals.v | 10 +- theories/Reals/Rfunctions.v | 113 +- theories/Reals/Rgeom.v | 10 +- theories/Reals/RiemannInt.v | 10 +- theories/Reals/RiemannInt_SF.v | 19 +- theories/Reals/Rlimit.v | 48 +- theories/Reals/Rlogic.v | 14 +- theories/Reals/Rminmax.v | 10 +- theories/Reals/Rpow_def.v | 12 +- theories/Reals/Rpower.v | 79 +- theories/Reals/Rprod.v | 10 +- theories/Reals/Rseries.v | 12 +- theories/Reals/Rsigma.v | 10 +- theories/Reals/Rsqrt_def.v | 12 +- theories/Reals/Rtopology.v | 10 +- theories/Reals/Rtrigo.v | 10 +- theories/Reals/Rtrigo1.v | 383 ++--- theories/Reals/Rtrigo_alt.v | 79 +- theories/Reals/Rtrigo_calc.v | 191 +-- theories/Reals/Rtrigo_def.v | 44 +- theories/Reals/Rtrigo_fun.v | 10 +- theories/Reals/Rtrigo_reg.v | 24 +- theories/Reals/SeqProp.v | 14 +- theories/Reals/SeqSeries.v | 10 +- theories/Reals/SplitAbsolu.v | 10 +- theories/Reals/SplitRmult.v | 10 +- theories/Reals/Sqrt_reg.v | 11 +- theories/Reals/vo.itarget | 62 - theories/Relations/Operators_Properties.v | 10 +- theories/Relations/Relation_Definitions.v | 10 +- theories/Relations/Relation_Operators.v | 10 +- theories/Relations/Relations.v | 10 +- theories/Relations/vo.itarget | 4 - theories/Setoids/Setoid.v | 10 +- theories/Setoids/vo.itarget | 1 - theories/Sets/Classical_sets.v | 10 +- theories/Sets/Constructive_sets.v | 10 +- theories/Sets/Cpo.v | 10 +- theories/Sets/Ensembles.v | 10 +- theories/Sets/Finite_sets.v | 10 +- theories/Sets/Finite_sets_facts.v | 10 +- theories/Sets/Image.v | 10 +- theories/Sets/Infinite_sets.v | 10 +- theories/Sets/Integers.v | 10 +- theories/Sets/Multiset.v | 14 +- theories/Sets/Partial_Order.v | 10 +- theories/Sets/Permut.v | 10 +- theories/Sets/Powerset.v | 10 +- theories/Sets/Powerset_Classical_facts.v | 10 +- theories/Sets/Powerset_facts.v | 101 +- theories/Sets/Relations_1.v | 10 +- theories/Sets/Relations_1_facts.v | 10 +- theories/Sets/Relations_2.v | 10 +- theories/Sets/Relations_2_facts.v | 10 +- theories/Sets/Relations_3.v | 10 +- theories/Sets/Relations_3_facts.v | 10 +- theories/Sets/Uniset.v | 14 +- theories/Sets/vo.itarget | 22 - theories/Sorting/Heap.v | 16 +- theories/Sorting/Mergesort.v | 10 +- theories/Sorting/PermutEq.v | 10 +- theories/Sorting/PermutSetoid.v | 10 +- theories/Sorting/Permutation.v | 10 +- theories/Sorting/Sorted.v | 10 +- theories/Sorting/Sorting.v | 10 +- theories/Sorting/vo.itarget | 7 - theories/Strings/Ascii.v | 12 +- theories/Strings/String.v | 22 +- theories/Strings/vo.itarget | 2 - theories/Structures/DecidableType.v | 20 +- theories/Structures/DecidableTypeEx.v | 16 +- theories/Structures/Equalities.v | 16 +- theories/Structures/EqualitiesFacts.v | 16 +- theories/Structures/GenericMinMax.v | 16 +- theories/Structures/OrderedType.v | 16 +- theories/Structures/OrderedTypeAlt.v | 16 +- theories/Structures/OrderedTypeEx.v | 18 +- theories/Structures/Orders.v | 16 +- theories/Structures/OrdersAlt.v | 16 +- theories/Structures/OrdersEx.v | 16 +- theories/Structures/OrdersFacts.v | 16 +- theories/Structures/OrdersLists.v | 16 +- theories/Structures/OrdersTac.v | 16 +- theories/Structures/vo.itarget | 14 - theories/Unicode/Utf8.v | 10 +- theories/Unicode/Utf8_core.v | 25 +- theories/Unicode/vo.itarget | 2 - theories/Vectors/Fin.v | 10 +- theories/Vectors/Vector.v | 12 +- theories/Vectors/VectorDef.v | 22 +- theories/Vectors/VectorEq.v | 10 +- theories/Vectors/VectorSpec.v | 39 +- theories/Vectors/vo.itarget | 5 - theories/Wellfounded/Disjoint_Union.v | 10 +- theories/Wellfounded/Inclusion.v | 10 +- theories/Wellfounded/Inverse_Image.v | 10 +- .../Wellfounded/Lexicographic_Exponentiation.v | 10 +- theories/Wellfounded/Lexicographic_Product.v | 10 +- theories/Wellfounded/Transitive_Closure.v | 10 +- theories/Wellfounded/Union.v | 10 +- theories/Wellfounded/Well_Ordering.v | 10 +- theories/Wellfounded/Wellfounded.v | 10 +- theories/Wellfounded/vo.itarget | 9 - theories/ZArith/BinInt.v | 231 +-- theories/ZArith/BinIntDef.v | 29 +- theories/ZArith/Int.v | 22 +- theories/ZArith/Wf_Z.v | 10 +- theories/ZArith/ZArith.v | 10 +- theories/ZArith/ZArith_base.v | 10 +- theories/ZArith/ZArith_dec.v | 12 +- theories/ZArith/Zabs.v | 56 +- theories/ZArith/Zbool.v | 20 +- theories/ZArith/Zcompare.v | 36 +- theories/ZArith/Zcomplements.v | 10 +- theories/ZArith/Zdigits.v | 10 +- theories/ZArith/Zdiv.v | 35 +- theories/ZArith/Zeuclid.v | 10 +- theories/ZArith/Zeven.v | 26 +- theories/ZArith/Zgcd_alt.v | 10 +- theories/ZArith/Zhints.v | 10 +- theories/ZArith/Zlogarithm.v | 10 +- theories/ZArith/Zmax.v | 62 +- theories/ZArith/Zmin.v | 48 +- theories/ZArith/Zminmax.v | 24 +- theories/ZArith/Zmisc.v | 12 +- theories/ZArith/Znat.v | 126 +- theories/ZArith/Znumtheory.v | 72 +- theories/ZArith/Zorder.v | 102 +- theories/ZArith/Zpow_alt.v | 10 +- theories/ZArith/Zpow_def.v | 22 +- theories/ZArith/Zpow_facts.v | 40 +- theories/ZArith/Zpower.v | 10 +- theories/ZArith/Zquot.v | 40 +- theories/ZArith/Zsqrt_compat.v | 12 +- theories/ZArith/Zwf.v | 10 +- theories/ZArith/auxiliary.v | 10 +- theories/ZArith/vo.itarget | 33 - 461 files changed, 8188 insertions(+), 19191 deletions(-) delete mode 100644 theories/Arith/vo.itarget delete mode 100644 theories/Bool/vo.itarget delete mode 100644 theories/Classes/vo.itarget delete mode 100644 theories/Compat/Coq84.v delete mode 100644 theories/Compat/Coq85.v create mode 100644 theories/Compat/Coq87.v create mode 100644 theories/Compat/Coq88.v delete mode 100644 theories/Compat/vo.itarget delete mode 100644 theories/FSets/vo.itarget create mode 100644 theories/Init/Decimal.v create mode 100644 theories/Init/_CoqProject delete mode 100644 theories/Init/vo.itarget delete mode 100644 theories/Lists/vo.itarget create mode 100644 theories/Logic/ExtensionalFunctionRepresentative.v create mode 100644 theories/Logic/PropExtensionality.v create mode 100644 theories/Logic/PropExtensionalityFacts.v create mode 100644 theories/Logic/SetoidChoice.v delete mode 100644 theories/Logic/vo.itarget delete mode 100644 theories/MSets/vo.itarget delete mode 100644 theories/NArith/vo.itarget delete mode 100644 theories/Numbers/BigNumPrelude.v create mode 100644 theories/Numbers/Cyclic/Abstract/DoubleType.v delete mode 100644 theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v delete mode 100644 theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v delete mode 100644 theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v delete mode 100644 theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v delete mode 100644 theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v delete mode 100644 theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v delete mode 100644 theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v delete mode 100644 theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v delete mode 100644 theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v delete mode 100644 theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v create mode 100644 theories/Numbers/DecimalFacts.v create mode 100644 theories/Numbers/DecimalN.v create mode 100644 theories/Numbers/DecimalNat.v create mode 100644 theories/Numbers/DecimalPos.v create mode 100644 theories/Numbers/DecimalString.v create mode 100644 theories/Numbers/DecimalZ.v delete mode 100644 theories/Numbers/Integer/BigZ/BigZ.v delete mode 100644 theories/Numbers/Integer/BigZ/ZMake.v delete mode 100644 theories/Numbers/Integer/SpecViaZ/ZSig.v delete mode 100644 theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v delete mode 100644 theories/Numbers/Natural/BigN/BigN.v delete mode 100644 theories/Numbers/Natural/BigN/NMake.v delete mode 100644 theories/Numbers/Natural/BigN/NMake_gen.ml delete mode 100644 theories/Numbers/Natural/BigN/Nbasic.v delete mode 100644 theories/Numbers/Natural/SpecViaZ/NSig.v delete mode 100644 theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v delete mode 100644 theories/Numbers/Rational/BigQ/BigQ.v delete mode 100644 theories/Numbers/Rational/BigQ/QMake.v delete mode 100644 theories/Numbers/Rational/SpecViaQ/QSig.v delete mode 100644 theories/Numbers/vo.itarget delete mode 100644 theories/PArith/vo.itarget delete mode 100644 theories/Program/vo.itarget delete mode 100644 theories/QArith/vo.itarget delete mode 100644 theories/Reals/vo.itarget delete mode 100644 theories/Relations/vo.itarget delete mode 100644 theories/Setoids/vo.itarget delete mode 100644 theories/Sets/vo.itarget delete mode 100644 theories/Sorting/vo.itarget delete mode 100644 theories/Strings/vo.itarget delete mode 100644 theories/Structures/vo.itarget delete mode 100644 theories/Unicode/vo.itarget delete mode 100644 theories/Vectors/vo.itarget delete mode 100644 theories/Wellfounded/vo.itarget delete mode 100644 theories/ZArith/vo.itarget (limited to 'theories') diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v index 953f7e4d..1cba8faf 100644 --- a/theories/Arith/Arith.v +++ b/theories/Arith/Arith.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop. + (** The [between] type expresses the concept + [forall i: nat, k <= i < l -> P i.]. *) Inductive between k : nat -> Prop := | bet_emp : between k k | bet_S : forall l, between k l -> P l -> between k (S l). @@ -24,7 +28,7 @@ Section Between. Lemma bet_eq : forall k l, l = k -> between k l. Proof. - induction 1; auto with arith. + intros * ->; auto with arith. Qed. Hint Resolve bet_eq: arith. @@ -37,9 +41,7 @@ Section Between. Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l. Proof. - intros k l H; induction H as [|l H]. - intros; absurd (S k <= k); auto with arith. - destruct H; auto with arith. + induction 1 as [|* [|]]; auto with arith. Qed. Hint Resolve between_Sk_l: arith. @@ -49,6 +51,8 @@ Section Between. induction 1; auto with arith. Qed. + (** The [exists_between] type expresses the concept + [exists i: nat, k <= i < l /\ Q i]. *) Inductive exists_between k : nat -> Prop := | exists_S : forall l, exists_between k l -> exists_between k (S l) | exists_le : forall l, k <= l -> Q l -> exists_between k (S l). @@ -74,32 +78,32 @@ Section Between. Lemma in_int_intro : forall p q r, p <= r -> r < q -> in_int p q r. Proof. - red; auto with arith. + split; assumption. Qed. Hint Resolve in_int_intro: arith. Lemma in_int_lt : forall p q r, in_int p q r -> p < q. Proof. - induction 1; intros. - apply le_lt_trans with r; auto with arith. + intros * []. + eapply le_lt_trans; eassumption. Qed. Lemma in_int_p_Sq : - forall p q r, in_int p (S q) r -> in_int p q r \/ r = q :>nat. + forall p q r, in_int p (S q) r -> in_int p q r \/ r = q. Proof. - induction 1; intros. - elim (le_lt_or_eq r q); auto with arith. + intros p q r []. + destruct (le_lt_or_eq r q); auto with arith. Qed. Lemma in_int_S : forall p q r, in_int p q r -> in_int p (S q) r. Proof. - induction 1; auto with arith. + intros * []; auto with arith. Qed. Hint Resolve in_int_S: arith. Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r. Proof. - induction 1; auto with arith. + intros * []; auto with arith. Qed. Hint Immediate in_int_Sp_q: arith. @@ -107,10 +111,9 @@ Section Between. forall k l, between k l -> forall r, in_int k l r -> P r. Proof. induction 1; intros. - absurd (k < k); auto with arith. - apply in_int_lt with r; auto with arith. - elim (in_int_p_Sq k l r); intros; auto with arith. - rewrite H2; trivial with arith. + - absurd (k < k). { auto with arith. } + eapply in_int_lt; eassumption. + - destruct (in_int_p_Sq k l r) as [| ->]; auto with arith. Qed. Lemma in_int_between : @@ -120,17 +123,17 @@ Section Between. Qed. Lemma exists_in_int : - forall k l, exists_between k l -> exists2 m : nat, in_int k l m & Q m. + forall k l, exists_between k l -> exists2 m : nat, in_int k l m & Q m. Proof. - induction 1. - case IHexists_between; intros p inp Qp; exists p; auto with arith. - exists l; auto with arith. + induction 1 as [* ? (p, ?, ?)|]. + - exists p; auto with arith. + - exists l; auto with arith. Qed. Lemma in_int_exists : forall k l r, in_int k l r -> Q r -> exists_between k l. Proof. - destruct 1; intros. - elim H0; auto with arith. + intros * (?, lt_r_l) ?. + induction lt_r_l; auto with arith. Qed. Lemma between_or_exists : @@ -139,9 +142,11 @@ Section Between. (forall n:nat, in_int k l n -> P n \/ Q n) -> between k l \/ exists_between k l. Proof. - induction 1; intros; auto with arith. - elim IHle; intro; auto with arith. - elim (H0 m); auto with arith. + induction 1 as [|m ? IHle]. + - auto with arith. + - intros P_or_Q. + destruct IHle; auto with arith. + destruct (P_or_Q m); auto with arith. Qed. Lemma between_not_exists : @@ -150,14 +155,14 @@ Section Between. (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l. Proof. induction 1; red; intros. - absurd (k < k); auto with arith. - absurd (Q l); auto with arith. - elim (exists_in_int k (S l)); auto with arith; intros l' inl' Ql'. - replace l with l'; auto with arith. - elim inl'; intros. - elim (le_lt_or_eq l' l); auto with arith; intros. - absurd (exists_between k l); auto with arith. - apply in_int_exists with l'; auto with arith. + - absurd (k < k); auto with arith. + - absurd (Q l). { auto with arith. } + destruct (exists_in_int k (S l)) as (l',[],?). + + auto with arith. + + replace l with l'. { trivial. } + destruct (le_lt_or_eq l' l); auto with arith. + absurd (exists_between k l). { auto with arith. } + eapply in_int_exists; eauto with arith. Qed. Inductive P_nth (init:nat) : nat -> nat -> Prop := @@ -168,15 +173,16 @@ Section Between. Lemma nth_le : forall (init:nat) l (n:nat), P_nth init l n -> init <= l. Proof. - induction 1; intros; auto with arith. - apply le_trans with (S k); auto with arith. + induction 1. + - auto with arith. + - eapply le_trans; eauto with arith. Qed. Definition eventually (n:nat) := exists2 k : nat, k <= n & Q k. Lemma event_O : eventually 0 -> Q 0. Proof. - induction 1; intros. + intros (x, ?, ?). replace 0 with x; auto with arith. Qed. diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v index 602555b6..d892542e 100644 --- a/theories/Arith/Bool_nat.v +++ b/theories/Arith/Bool_nat.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (n ?= m) = Lt. Proof. @@ -198,9 +200,9 @@ Qed. See now [Nat.leb] and its properties. In scope [nat_scope], the notation for [Nat.leb] is "<=?" *) -Notation leb := Nat.leb (compat "8.4"). +Notation leb := Nat.leb (only parsing). -Notation leb_iff := Nat.leb_le (compat "8.4"). +Notation leb_iff := Nat.leb_le (only parsing). Lemma leb_iff_conv m n : (n <=? m) = false <-> m < n. Proof. diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 016cb85e..a5e45783 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* P 1 -> (forall n, P n -> P (S (S n))) -> forall n, P n. Proof. intros P H0 H1 H2. - fix 1. + fix ind_0_1_SS 1. destruct n as [|[|n]]. - exact H0. - exact H1. @@ -84,7 +86,7 @@ Qed. (** Properties related to the double ([2n]) *) -Notation double := Nat.double (compat "8.4"). +Notation double := Nat.double (only parsing). Hint Unfold double Nat.double: arith. @@ -103,7 +105,7 @@ Hint Resolve double_S: arith. Lemma even_odd_double n : (even n <-> n = double (div2 n)) /\ (odd n <-> n = S (double (div2 n))). Proof. - revert n. fix 1. destruct n as [|[|n]]. + revert n. fix even_odd_double 1. destruct n as [|[|n]]. - (* n = 0 *) split; split; auto with arith. inversion 1. - (* n = 1 *) diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index f998c19f..4b51dfc0 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Nat.Even n. Proof. - fix 1. + fix even_equiv 1. destruct n as [|[|n]]; simpl. - split; [now exists 0 | constructor]. - split. @@ -50,7 +52,7 @@ Qed. Lemma odd_equiv : forall n, odd n <-> Nat.Odd n. Proof. - fix 1. + fix odd_equiv 1. destruct n as [|[|n]]; simpl. - split. + inversion_clear 1. diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v index b119bb00..22f586d7 100644 --- a/theories/Arith/Factorial.v +++ b/theories/Arith/Factorial.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 = n. Proof. @@ -53,8 +55,8 @@ Proof Peano.le_n_S. Theorem le_S_n : forall n m, S n <= S m -> n <= m. Proof Peano.le_S_n. -Notation le_n_Sn := Nat.le_succ_diag_r (compat "8.4"). (* n <= S n *) -Notation le_Sn_n := Nat.nle_succ_diag_l (compat "8.4"). (* ~ S n <= n *) +Notation le_n_Sn := Nat.le_succ_diag_r (only parsing). (* n <= S n *) +Notation le_Sn_n := Nat.nle_succ_diag_l (only parsing). (* ~ S n <= n *) Theorem le_Sn_le : forall n m, S n <= m -> n <= m. Proof Nat.lt_le_incl. @@ -65,8 +67,8 @@ Hint Immediate le_n_0_eq le_Sn_le le_S_n : arith. (** * Properties of [le] w.r.t predecessor *) -Notation le_pred_n := Nat.le_pred_l (compat "8.4"). (* pred n <= n *) -Notation le_pred := Nat.pred_le_mono (compat "8.4"). (* n<=m -> pred n <= pred m *) +Notation le_pred_n := Nat.le_pred_l (only parsing). (* pred n <= n *) +Notation le_pred := Nat.pred_le_mono (only parsing). (* n<=m -> pred n <= pred m *) Hint Resolve le_pred_n: arith. diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v index bfc2b91a..0c7515c6 100644 --- a/theories/Arith/Lt.v +++ b/theories/Arith/Lt.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ~m ~m n -> 0 < n. Proof. @@ -84,8 +86,8 @@ Hint Immediate neq_0_lt lt_0_neq: arith. (** * Order and successor *) -Notation lt_n_Sn := Nat.lt_succ_diag_r (compat "8.4"). (* n < S n *) -Notation lt_S := Nat.lt_lt_succ_r (compat "8.4"). (* n < m -> n < S m *) +Notation lt_n_Sn := Nat.lt_succ_diag_r (only parsing). (* n < S n *) +Notation lt_S := Nat.lt_lt_succ_r (only parsing). (* n < m -> n < S m *) Theorem lt_n_S n m : n < m -> S n < S m. Proof. @@ -107,6 +109,11 @@ Proof. intros. symmetry. now apply Nat.lt_succ_pred with m. Qed. +Lemma S_pred_pos n: O < n -> n = S (pred n). +Proof. + apply S_pred. +Qed. + Lemma lt_pred n m : S n < m -> n < pred m. Proof. apply Nat.lt_succ_lt_pred. @@ -122,28 +129,28 @@ Hint Resolve lt_pred_n_n: arith. (** * Transitivity properties *) -Notation lt_trans := Nat.lt_trans (compat "8.4"). -Notation lt_le_trans := Nat.lt_le_trans (compat "8.4"). -Notation le_lt_trans := Nat.le_lt_trans (compat "8.4"). +Notation lt_trans := Nat.lt_trans (only parsing). +Notation lt_le_trans := Nat.lt_le_trans (only parsing). +Notation le_lt_trans := Nat.le_lt_trans (only parsing). Hint Resolve lt_trans lt_le_trans le_lt_trans: arith. (** * Large = strict or equal *) -Notation le_lt_or_eq_iff := Nat.lt_eq_cases (compat "8.4"). +Notation le_lt_or_eq_iff := Nat.lt_eq_cases (only parsing). Theorem le_lt_or_eq n m : n <= m -> n < m \/ n = m. Proof. apply Nat.lt_eq_cases. Qed. -Notation lt_le_weak := Nat.lt_le_incl (compat "8.4"). +Notation lt_le_weak := Nat.lt_le_incl (only parsing). Hint Immediate lt_le_weak: arith. (** * Dichotomy *) -Notation le_or_lt := Nat.le_gt_cases (compat "8.4"). (* n <= m \/ m < n *) +Notation le_or_lt := Nat.le_gt_cases (only parsing). (* n <= m \/ m < n *) Theorem nat_total_order n m : n <> m -> n < m \/ m < n. Proof. diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index 49152549..1727fa37 100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* n - p <= m - p. *) + Nat.sub_le_mono_r (only parsing). (* n <= m -> n - p <= m - p. *) Notation minus_le_compat_l := - Nat.sub_le_mono_l (compat "8.4"). (* n <= m -> p - m <= p - n. *) + Nat.sub_le_mono_l (only parsing). (* n <= m -> p - m <= p - n. *) -Notation le_minus := Nat.le_sub_l (compat "8.4"). (* n - m <= n *) -Notation lt_minus := Nat.sub_lt (compat "8.4"). (* m <= n -> 0 < m -> n-m < n *) +Notation le_minus := Nat.le_sub_l (only parsing). (* n - m <= n *) +Notation lt_minus := Nat.sub_lt (only parsing). (* m <= n -> 0 < m -> n-m < n *) Lemma lt_O_minus_lt n m : 0 < n - m -> m < n. Proof. diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index a173efc1..4f4aa183 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Even n. Proof. - fix 1. + fix even_spec 1. destruct n as [|[|n]]; simpl. - split; [ now exists 0 | trivial ]. - split; [ discriminate | intro H; elim (Even_1 H) ]. @@ -323,7 +325,7 @@ Qed. Lemma odd_spec : forall n, odd n = true <-> Odd n. Proof. unfold odd. - fix 1. + fix odd_spec 1. destruct n as [|[|n]]; simpl. - split; [ discriminate | intro H; elim (Odd_0 H) ]. - split; [ now exists 0 | trivial ]. @@ -471,7 +473,7 @@ Notation "( x | y )" := (divide x y) (at level 0) : nat_scope. Lemma gcd_divide : forall a b, (gcd a b | a) /\ (gcd a b | b). Proof. - fix 1. + fix gcd_divide 1. intros [|a] b; simpl. split. now exists 0. @@ -500,7 +502,7 @@ Qed. Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b). Proof. - fix 1. + fix gcd_greatest 1. intros [|a] b; simpl; auto. fold (b mod (S a)). intros c H H'. apply gcd_greatest; auto. @@ -534,7 +536,7 @@ Qed. Lemma le_div2 n : div2 (S n) <= n. Proof. revert n. - fix 1. + fix le_div2 1. destruct n; simpl; trivial. apply lt_succ_r. destruct n; [simpl|]; trivial. now constructor. Qed. @@ -724,6 +726,26 @@ Definition shiftr_spec a n m (_:0<=m) := shiftr_specif a n m. Include NExtraProp. +(** Properties of tail-recursive addition and multiplication *) + +Lemma tail_add_spec n m : tail_add n m = n + m. +Proof. + revert m. induction n as [|n IH]; simpl; trivial. + intros. now rewrite IH, add_succ_r. +Qed. + +Lemma tail_addmul_spec r n m : tail_addmul r n m = r + n * m. +Proof. + revert m r. induction n as [| n IH]; simpl; trivial. + intros. rewrite IH, tail_add_spec. + rewrite add_assoc. f_equal. apply add_comm. +Qed. + +Lemma tail_mul_spec n m : tail_mul n m = n * m. +Proof. + unfold tail_mul. now rewrite tail_addmul_spec. +Qed. + End Nat. (** Re-export notations that should be available even when diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index f8020a50..9a24c804 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* sum (R x y) (R' x y). (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) - - Set Automatic Introduction. - + Global Instance relation_equivalence_equivalence : Equivalence relation_equivalence. Proof. split; red; unfold relation_equivalence, iffT. firstorder. diff --git a/theories/Classes/DecidableClass.v b/theories/Classes/DecidableClass.v index a3b7e311..bffad2b3 100644 --- a/theories/Classes/DecidableClass.v +++ b/theories/Classes/DecidableClass.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* -> sig. -Coercion sigT_of_sigT2 : sigT2 >-> sigT. -Coercion sigT_of_sig : sig >-> sigT. -Coercion sig_of_sigT : sigT >-> sig. -Coercion sigT2_of_sig2 : sig2 >-> sigT2. -Coercion sig2_of_sigT2 : sigT2 >-> sig2. - -(** In 8.4, the statement of admitted lemmas did not depend on the section - variables. *) -Unset Keep Admitted Variables. diff --git a/theories/Compat/Coq85.v b/theories/Compat/Coq85.v deleted file mode 100644 index 64ba6b1e..00000000 --- a/theories/Compat/Coq85.v +++ /dev/null @@ -1,36 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* C", does not - behave as "intros [H|H]" but leave instead hypotheses quantified in - the goal, here producing subgoals A->C and B->C. *) - -Global Unset Bracketing Last Introduction Pattern. -Global Unset Regular Subst Tactic. -Global Unset Structural Injection. -Global Unset Shrink Abstract. -Global Unset Shrink Obligations. -Global Set Refolding Reduction. - -(** The resolution algorithm for type classes has changed. *) -Global Set Typeclasses Legacy Resolution. -Global Set Typeclasses Limit Intros. -Global Unset Typeclasses Filtered Unification. - -(** Allow silently letting unification constraints float after a "." *) -Global Unset Solve Unification Constraints. diff --git a/theories/Compat/Coq86.v b/theories/Compat/Coq86.v index 6952fdf1..666be207 100644 --- a/theories/Compat/Coq86.v +++ b/theories/Compat/Coq86.v @@ -1,9 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* constructor; congruence. Module WFacts_fun (E:DecidableType)(Import M:WSfun E). -Notation option_map := option_map (compat "8.4"). +Notation option_map := option_map (compat "8.6"). Notation eq_dec := E.eq_dec. Definition eqb x y := if eq_dec x y then true else false. @@ -440,7 +442,7 @@ destruct (eq_dec x y); auto. Qed. Lemma map_o : forall m x (f:elt->elt'), - find x (map f m) = option_map f (find x m). + find x (map f m) = Datatypes.option_map f (find x m). Proof. intros. generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x) @@ -473,7 +475,7 @@ Qed. Lemma mapi_o : forall m x (f:key->elt->elt'), (forall x y e, E.eq x y -> f x e = f y e) -> - find x (mapi f m) = option_map (f x) (find x m). + find x (mapi f m) = Datatypes.option_map (f x) (find x m). Proof. intros. generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index a7be3232..34529678 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -1,10 +1,12 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* E.bits_lt p0 p. - Proof. + Proof using. intros. generalize (xelements_complete _ _ _ _ H); clear H; intros. - revert p0 q m v H. + revert p0 H. induction p; destruct p0; simpl; intros; eauto; try discriminate. Qed. Lemma xelements_bits_lt_2 : forall p p0 q m v, List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0. - Proof. + Proof using. intros. generalize (xelements_complete _ _ _ _ H); clear H; intros. - revert p0 q m v H. + revert p0 H. induction p; destruct p0; simpl; intros; eauto; try discriminate. Qed. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 130cbee8..67360965 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -1,17 +1,19 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 + min_elt s = Some x -> In y s -> ~ O.lt y x := M.min_elt_spec2. Definition min_elt_3 : forall s, min_elt s = None -> Empty s := M.min_elt_spec3. Definition max_elt_1 : forall s x, max_elt s = Some x -> In x s := M.max_elt_spec1. Definition max_elt_2 : forall s x y, - max_elt s = Some x -> In y s -> ~ E.lt x y + max_elt s = Some x -> In y s -> ~ O.lt x y := M.max_elt_spec2. Definition max_elt_3 : forall s, max_elt s = None -> Empty s := M.max_elt_spec3. - Definition elements_3 : forall s, sort E.lt (elements s) + Definition elements_3 : forall s, sort O.lt (elements s) := M.elements_spec2. Definition choose_3 : forall s s' x y, - choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y + choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y := M.choose_spec3. Definition lt_trans : forall s s' s'', lt s s' -> lt s' s'' -> lt s s'' := @StrictOrder_Transitive _ _ M.lt_strorder. @@ -211,7 +213,7 @@ Module Backport_Sets [ apply EQ | apply LT | apply GT ]; auto. Defined. - Module E := E. + Module E := O. End Backport_Sets. @@ -342,13 +344,13 @@ 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. + (O:Orders.OrderedType) + (M:FSetInterface.S with Definition E.t := O.t + with Definition E.eq := O.eq + with Definition E.lt := O.lt) + <: MSetInterface.Sets with Module E:=O. - Include Update_WSets E M. + Include Update_WSets O M. Implicit Type s : t. Implicit Type x y : elt. @@ -359,21 +361,21 @@ Module Update_Sets 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 + min_elt s = Some x -> In y s -> ~ O.lt y x := M.min_elt_2. Definition min_elt_spec3 : forall s, min_elt s = None -> Empty s := M.min_elt_3. Definition max_elt_spec1 : forall s x, max_elt s = Some x -> In x s := M.max_elt_1. Definition max_elt_spec2 : forall s x y, - max_elt s = Some x -> In y s -> ~ E.lt x y + max_elt s = Some x -> In y s -> ~ O.lt x y := M.max_elt_2. Definition max_elt_spec3 : forall s, max_elt s = None -> Empty s := M.max_elt_3. - Definition elements_spec2 : forall s, sort E.lt (elements s) + Definition elements_spec2 : forall s, sort O.lt (elements s) := M.elements_3. Definition choose_spec3 : forall s s' x y, - choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y + choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y := M.choose_3. Instance lt_strorder : StrictOrder lt. @@ -407,6 +409,6 @@ Module Update_Sets 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. + Module E := O. End Update_Sets. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index 1db6a71e..83bb07ff 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -1,10 +1,12 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Logic.eq) as cardinal_m. Proof. exact Equal_cardinal. Qed. diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v index 3ac5d9e4..f8d13ed2 100644 --- a/theories/FSets/FSetToFiniteSet.v +++ b/theories/FSets/FSetToFiniteSet.v @@ -1,10 +1,12 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* a = true /\ b = true. Proof. - destruct a; destruct b; intros; split; try (reflexivity || discriminate). + destruct a, b; repeat split; assumption. Qed. Hint Resolve andb_prop: bool. @@ -262,6 +264,11 @@ Inductive comparison : Set := | Lt : comparison | Gt : comparison. +Lemma comparison_eq_stable : forall c c' : comparison, ~~ c = c' -> c = c'. +Proof. + destruct c, c'; intro H; reflexivity || destruct H; discriminate. +Qed. + Definition CompOpp (r:comparison) := match r with | Eq => Eq @@ -326,13 +333,12 @@ 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. intros. apply CompareSpec2Type; assumption. Defined. - (******************************************************************) (** * Misc Other Datatypes *) (** [identity A a] is the family of datatypes on [A] whose sole non-empty member is the singleton datatype [identity A a a] whose - sole inhabitant is denoted [refl_identity A a] *) + sole inhabitant is denoted [identity_refl A a] *) Inductive identity (A:Type) (a:A) : A -> Type := identity_refl : identity a a. @@ -355,14 +361,14 @@ Definition idProp : IDProp := fun A x => x. (* Compatibility *) -Notation prodT := prod (compat "8.2"). -Notation pairT := pair (compat "8.2"). -Notation prodT_rect := prod_rect (compat "8.2"). -Notation prodT_rec := prod_rec (compat "8.2"). -Notation prodT_ind := prod_ind (compat "8.2"). -Notation fstT := fst (compat "8.2"). -Notation sndT := snd (compat "8.2"). -Notation prodT_uncurry := prod_uncurry (compat "8.2"). -Notation prodT_curry := prod_curry (compat "8.2"). +Notation prodT := prod (only parsing). +Notation pairT := pair (only parsing). +Notation prodT_rect := prod_rect (only parsing). +Notation prodT_rec := prod_rec (only parsing). +Notation prodT_ind := prod_ind (only parsing). +Notation fstT := fst (only parsing). +Notation sndT := snd (only parsing). +Notation prodT_uncurry := prod_uncurry (only parsing). +Notation prodT_curry := prod_curry (only parsing). (* end hide *) diff --git a/theories/Init/Decimal.v b/theories/Init/Decimal.v new file mode 100644 index 00000000..57163b1b --- /dev/null +++ b/theories/Init/Decimal.v @@ -0,0 +1,163 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* nzhead d + | _ => d + end. + +(** [unorm] : normalization of unsigned integers *) + +Definition unorm d := + match nzhead d with + | Nil => zero + | d => d + end. + +(** [norm] : normalization of signed integers *) + +Definition norm d := + match d with + | Pos d => Pos (unorm d) + | Neg d => + match nzhead d with + | Nil => Pos zero + | d => Neg d + end + end. + +(** A few easy operations. For more advanced computations, use the conversions + with other Coq numeral datatypes (e.g. Z) and the operations on them. *) + +Definition opp (d:int) := + match d with + | Pos d => Neg d + | Neg d => Pos d + end. + +(** For conversions with binary numbers, it is easier to operate + on little-endian numbers. *) + +Fixpoint revapp (d d' : uint) := + match d with + | Nil => d' + | D0 d => revapp d (D0 d') + | D1 d => revapp d (D1 d') + | D2 d => revapp d (D2 d') + | D3 d => revapp d (D3 d') + | D4 d => revapp d (D4 d') + | D5 d => revapp d (D5 d') + | D6 d => revapp d (D6 d') + | D7 d => revapp d (D7 d') + | D8 d => revapp d (D8 d') + | D9 d => revapp d (D9 d') + end. + +Definition rev d := revapp d Nil. + +Module Little. + +(** Successor of little-endian numbers *) + +Fixpoint succ d := + match d with + | Nil => D1 Nil + | D0 d => D1 d + | D1 d => D2 d + | D2 d => D3 d + | D3 d => D4 d + | D4 d => D5 d + | D5 d => D6 d + | D6 d => D7 d + | D7 d => D8 d + | D8 d => D9 d + | D9 d => D0 (succ d) + end. + +(** Doubling little-endian numbers *) + +Fixpoint double d := + match d with + | Nil => Nil + | D0 d => D0 (double d) + | D1 d => D2 (double d) + | D2 d => D4 (double d) + | D3 d => D6 (double d) + | D4 d => D8 (double d) + | D5 d => D0 (succ_double d) + | D6 d => D2 (succ_double d) + | D7 d => D4 (succ_double d) + | D8 d => D6 (succ_double d) + | D9 d => D8 (succ_double d) + end + +with succ_double d := + match d with + | Nil => D1 Nil + | D0 d => D1 (double d) + | D1 d => D3 (double d) + | D2 d => D5 (double d) + | D3 d => D7 (double d) + | D4 d => D9 (double d) + | D5 d => D1 (succ_double d) + | D6 d => D3 (succ_double d) + | D7 d => D5 (succ_double d) + | D8 d => D7 (succ_double d) + | D9 d => D9 (succ_double d) + end. + +End Little. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 85123cc4..15ca5abc 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* C) -> ((A -> B) <-> (A -> C)). +Proof. + intros ? ? ? [Hl Hr]; split; intros H ?; [apply Hl | apply Hr]; apply H; assumption. +Qed. + +Theorem imp_iff_compat_r : forall A B C : Prop, + (B <-> C) -> ((B -> A) <-> (C -> A)). +Proof. + intros ? ? ? [Hl Hr]; split; intros H ?; [apply H, Hr | apply H, Hl]; assumption. +Qed. + +Theorem not_iff_compat : forall A B : Prop, + (A <-> B) -> (~ A <-> ~B). +Proof. + intros; apply imp_iff_compat_r; assumption. +Qed. + + (** Some equivalences *) Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False). @@ -204,7 +225,7 @@ Proof. Qed. (** [(IF_then_else P Q R)], written [IF P then Q else R] denotes - either [P] and [Q], or [~P] and [Q] *) + either [P] and [Q], or [~P] and [R] *) Definition IF_then_else (P Q R:Prop) := P /\ Q \/ ~ P /\ R. @@ -243,9 +264,16 @@ Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..)) Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q)) (at level 200, x ident, p at level 200, right associativity) : type_scope. -Notation "'exists2' x : t , p & q" := (ex2 (fun x:t => p) (fun x:t => q)) - (at level 200, x ident, t at level 200, p at level 200, right associativity, - format "'[' 'exists2' '/ ' x : t , '/ ' '[' p & '/' q ']' ']'") +Notation "'exists2' x : A , p & q" := (ex2 (A:=A) (fun x => p) (fun x => q)) + (at level 200, x ident, A at level 200, p at level 200, right associativity, + format "'[' 'exists2' '/ ' x : A , '/ ' '[' p & '/' q ']' ']'") + : type_scope. + +Notation "'exists2' ' x , p & q" := (ex2 (fun x => p) (fun x => q)) + (at level 200, x strict pattern, p at level 200, right associativity) : type_scope. +Notation "'exists2' ' x : A , p & q" := (ex2 (A:=A) (fun x => p) (fun x => q)) + (at level 200, x strict pattern, A at level 200, p at level 200, right associativity, + format "'[' 'exists2' '/ ' ' x : A , '/ ' '[' p & '/' q ']' ']'") : type_scope. (** Derived rules for universal quantification *) @@ -294,8 +322,8 @@ Arguments eq_ind [A] x P _ y _. Arguments eq_rec [A] x P _ y _. Arguments eq_rect [A] x P _ y _. -Hint Resolve I conj or_introl or_intror : core. -Hint Resolve eq_refl: core. +Hint Resolve I conj or_introl or_intror : core. +Hint Resolve eq_refl: core. Hint Resolve ex_intro ex_intro2: core. Section Logic_lemmas. @@ -424,7 +452,7 @@ Proof. destruct e. reflexivity. Defined. -(** The goupoid structure of equality *) +(** The groupoid structure of equality *) Theorem eq_trans_refl_l : forall A (x y:A) (e:x=y), eq_trans eq_refl e = e. Proof. @@ -485,6 +513,11 @@ Proof. reflexivity. Defined. +Lemma eq_refl_map_distr : forall A B x (f:A->B), f_equal f (eq_refl x) = eq_refl (f x). +Proof. + reflexivity. +Qed. + Lemma eq_trans_map_distr : forall A B x y z (f:A->B) (e:x=y) (e':y=z), f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e'). Proof. destruct e'. @@ -503,16 +536,29 @@ destruct e, e'. reflexivity. Defined. +Lemma eq_trans_rew_distr : forall A (P:A -> Type) (x y z:A) (e:x=y) (e':y=z) (k:P x), + rew (eq_trans e e') in k = rew e' in rew e in k. +Proof. + destruct e, e'; reflexivity. +Qed. + +Lemma rew_const : forall A P (x y:A) (e:x=y) (k:P), + rew [fun _ => P] e in k = k. +Proof. + destruct e; reflexivity. +Qed. + + (* Aliases *) -Notation sym_eq := eq_sym (compat "8.3"). -Notation trans_eq := eq_trans (compat "8.3"). -Notation sym_not_eq := not_eq_sym (compat "8.3"). +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 (compat "8.3"). -Notation sym_equal := eq_sym (compat "8.3"). -Notation trans_equal := eq_trans (compat "8.3"). -Notation sym_not_equal := not_eq_sym (compat "8.3"). +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. @@ -553,9 +599,10 @@ Proof. intros A P (x & Hp & Huniq); split. - intro; exists x; auto. - intros (x0 & HPx0 & HQx0) x1 HPx1. - replace x1 with x0 by (transitivity x; [symmetry|]; auto). + assert (H : x0 = x1) by (transitivity x; [symmetry|]; auto). + destruct H. assumption. -Qed. +Qed. Lemma forall_exists_coincide_unique_domain : forall A (P:A->Prop), @@ -567,7 +614,7 @@ Proof. exists x. split; [trivial|]. destruct H with (Q:=fun x'=>x=x') as (_,Huniq). apply Huniq. exists x; auto. -Qed. +Qed. (** * Being inhabited *) @@ -589,6 +636,11 @@ Proof. destruct 1; auto. Qed. +Lemma inhabited_covariant (A B : Type) : (A -> B) -> inhabited A -> inhabited B. +Proof. + intros f [x];exact (inhabits (f x)). +Qed. + (** Declaration of stepl and stepr for eq and iff *) Lemma eq_stepl : forall (A : Type) (x y z : A), x = y -> x = z -> z = y. @@ -606,3 +658,97 @@ Qed. Declare Left Step iff_stepl. Declare Right Step iff_trans. + +Local Notation "'rew' 'dependent' H 'in' H'" + := (match H with + | eq_refl => H' + end) + (at level 10, H' at level 10, + format "'[' 'rew' 'dependent' '/ ' H in '/' H' ']'"). + +(** Equality for [ex] *) +Section ex. + Local Unset Implicit Arguments. + Definition eq_ex_uncurried {A : Type} (P : A -> Prop) {u1 v1 : A} {u2 : P u1} {v2 : P v1} + (pq : exists p : u1 = v1, rew p in u2 = v2) + : ex_intro P u1 u2 = ex_intro P v1 v2. + Proof. + destruct pq as [p q]. + destruct q; simpl in *. + destruct p; reflexivity. + Qed. + + Definition eq_ex {A : Type} {P : A -> Prop} (u1 v1 : A) (u2 : P u1) (v2 : P v1) + (p : u1 = v1) (q : rew p in u2 = v2) + : ex_intro P u1 u2 = ex_intro P v1 v2 + := eq_ex_uncurried P (ex_intro _ p q). + + Definition eq_ex_hprop {A} {P : A -> Prop} (P_hprop : forall (x : A) (p q : P x), p = q) + (u1 v1 : A) (u2 : P u1) (v2 : P v1) + (p : u1 = v1) + : ex_intro P u1 u2 = ex_intro P v1 v2 + := eq_ex u1 v1 u2 v2 p (P_hprop _ _ _). + + Lemma rew_ex {A x} {P : A -> Type} (Q : forall a, P a -> Prop) (u : exists p, Q x p) {y} (H : x = y) + : rew [fun a => exists p, Q a p] H in u + = match u with + | ex_intro _ u1 u2 + => ex_intro + (Q y) + (rew H in u1) + (rew dependent H in u2) + end. + Proof. + destruct H, u; reflexivity. + Qed. +End ex. + +(** Equality for [ex2] *) +Section ex2. + Local Unset Implicit Arguments. + + Definition eq_ex2_uncurried {A : Type} (P Q : A -> Prop) {u1 v1 : A} + {u2 : P u1} {v2 : P v1} + {u3 : Q u1} {v3 : Q v1} + (pq : exists2 p : u1 = v1, rew p in u2 = v2 & rew p in u3 = v3) + : ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3. + Proof. + destruct pq as [p q r]. + destruct r, q, p; simpl in *. + reflexivity. + Qed. + + Definition eq_ex2 {A : Type} {P Q : A -> Prop} + (u1 v1 : A) + (u2 : P u1) (v2 : P v1) + (u3 : Q u1) (v3 : Q v1) + (p : u1 = v1) (q : rew p in u2 = v2) (r : rew p in u3 = v3) + : ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3 + := eq_ex2_uncurried P Q (ex_intro2 _ _ p q r). + + Definition eq_ex2_hprop {A} {P Q : A -> Prop} + (P_hprop : forall (x : A) (p q : P x), p = q) + (Q_hprop : forall (x : A) (p q : Q x), p = q) + (u1 v1 : A) (u2 : P u1) (v2 : P v1) (u3 : Q u1) (v3 : Q v1) + (p : u1 = v1) + : ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3 + := eq_ex2 u1 v1 u2 v2 u3 v3 p (P_hprop _ _ _) (Q_hprop _ _ _). + + Lemma rew_ex2 {A x} {P : A -> Type} + (Q : forall a, P a -> Prop) + (R : forall a, P a -> Prop) + (u : exists2 p, Q x p & R x p) {y} (H : x = y) + : rew [fun a => exists2 p, Q a p & R a p] H in u + = match u with + | ex_intro2 _ _ u1 u2 u3 + => ex_intro2 + (Q y) + (R y) + (rew H in u1) + (rew dependent H in u2) + (rew dependent H in u3) + end. + Proof. + destruct H, u; reflexivity. + Qed. +End ex2. diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index 4536dfc0..6f10a939 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* m + | S n => tail_add n (S m) + end. + +(** [tail_addmul r n m] is [r + n * m]. *) + +Fixpoint tail_addmul r n m := + match n with + | O => r + | S n => tail_addmul (tail_add m r) n m + end. + +Definition tail_mul n m := tail_addmul 0 n m. + +(** ** Conversion with a decimal representation for printing/parsing *) + +Local Notation ten := (S (S (S (S (S (S (S (S (S (S O)))))))))). + +Fixpoint of_uint_acc (d:Decimal.uint)(acc:nat) := + match d with + | Decimal.Nil => acc + | Decimal.D0 d => of_uint_acc d (tail_mul ten acc) + | Decimal.D1 d => of_uint_acc d (S (tail_mul ten acc)) + | Decimal.D2 d => of_uint_acc d (S (S (tail_mul ten acc))) + | Decimal.D3 d => of_uint_acc d (S (S (S (tail_mul ten acc)))) + | Decimal.D4 d => of_uint_acc d (S (S (S (S (tail_mul ten acc))))) + | Decimal.D5 d => of_uint_acc d (S (S (S (S (S (tail_mul ten acc)))))) + | Decimal.D6 d => of_uint_acc d (S (S (S (S (S (S (tail_mul ten acc))))))) + | Decimal.D7 d => of_uint_acc d (S (S (S (S (S (S (S (tail_mul ten acc)))))))) + | Decimal.D8 d => of_uint_acc d (S (S (S (S (S (S (S (S (tail_mul ten acc))))))))) + | Decimal.D9 d => of_uint_acc d (S (S (S (S (S (S (S (S (S (tail_mul ten acc)))))))))) + end. + +Definition of_uint (d:Decimal.uint) := of_uint_acc d O. + +Fixpoint to_little_uint n acc := + match n with + | O => acc + | S n => to_little_uint n (Decimal.Little.succ acc) + end. + +Definition to_uint n := + Decimal.rev (to_little_uint n Decimal.zero). + +Definition of_int (d:Decimal.int) : option nat := + match Decimal.norm d with + | Decimal.Pos u => Some (of_uint u) + | _ => None + end. + +Definition to_int n := Decimal.Pos (to_uint n). + (** ** Euclidean division *) (** This division is linear and tail-recursive. diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index 48fbe079..72073bb4 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* u | _ => v end) + (at level 200, p pattern at level 100). + +End IfNotations. + +(** Scopes *) + Delimit Scope type_scope with type. Delimit Scope function_scope with function. Delimit Scope core_scope with core. @@ -88,9 +121,6 @@ Open Scope type_scope. (** ML Tactic Notations *) -Declare ML Module "coretactics". -Declare ML Module "extratactics". -Declare ML Module "g_auto". -Declare ML Module "g_class". -Declare ML Module "g_eqdecide". -Declare ML Module "g_rewrite". +Declare ML Module "ltac_plugin". + +Global Set Default Proof Mode "Classic". diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 6c4a6350..d5322d09 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* =m] *) -Notation minus := Nat.sub (compat "8.4"). +Notation minus := Nat.sub (only parsing). Infix "-" := Nat.sub : nat_scope. (** Definition of the usual orders, the basic properties of [le] and [lt] @@ -219,8 +223,8 @@ Qed. (** Maximum and minimum : definitions and specifications *) -Notation max := Nat.max (compat "8.4"). -Notation min := Nat.min (compat "8.4"). +Notation max := Nat.max (only parsing). +Notation min := Nat.min (only parsing). Lemma max_l n m : m <= n -> Nat.max n m = n. Proof. diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 03f2328d..802f18c0 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* P) (fun x => Q)) : type_scope. Notation "{ x : A | P }" := (sig (A:=A) (fun x => P)) : type_scope. Notation "{ x : A | P & Q }" := (sig2 (A:=A) (fun x => P) (fun x => Q)) : type_scope. +Notation "{ x & P }" := (sigT (fun x => P)) : type_scope. Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope. Notation "{ x : A & P & Q }" := (sigT2 (A:=A) (fun x => P) (fun x => Q)) : type_scope. +Notation "{ ' pat | P }" := (sig (fun pat => P)) : type_scope. +Notation "{ ' pat | P & Q }" := (sig2 (fun pat => P) (fun pat => Q)) : type_scope. +Notation "{ ' pat : A | P }" := (sig (A:=A) (fun pat => P)) : type_scope. +Notation "{ ' pat : A | P & Q }" := (sig2 (A:=A) (fun pat => P) (fun pat => Q)) : + type_scope. +Notation "{ ' pat : A & P }" := (sigT (A:=A) (fun pat => P)) : type_scope. +Notation "{ ' pat : A & P & Q }" := (sigT2 (A:=A) (fun pat => P) (fun pat => Q)) : + type_scope. + Add Printing Let sig. Add Printing Let sig2. Add Printing Let sigT. @@ -103,7 +115,7 @@ Definition sig_of_sig2 (A : Type) (P Q : A -> Prop) (X : sig2 P Q) : sig P of an [a] of type [A], a of a proof [h] that [a] satisfies [P], and a proof [h'] that [a] satisfies [Q]. Then [(proj1_sig (sig_of_sig2 y))] is the witness [a], - [(proj2_sig (sig_of_sig2 y))] is the proof of [(P a)], and + [(proj2_sig (sig_of_sig2 y))] is the proof of [(P a)], and [(proj3_sig y)] is the proof of [(Q a)]. *) Section Subset_projections2. @@ -190,6 +202,435 @@ Definition sig2_of_sigT2 (A : Type) (P Q : A -> Prop) (X : sigT2 P Q) : sig2 P Q Definition sigT2_of_sig2 (A : Type) (P Q : A -> Prop) (X : sig2 P Q) : sigT2 P Q := existT2 P Q (proj1_sig (sig_of_sig2 X)) (proj2_sig (sig_of_sig2 X)) (proj3_sig X). +(** η Principles *) +Definition sigT_eta {A P} (p : { a : A & P a }) + : p = existT _ (projT1 p) (projT2 p). +Proof. destruct p; reflexivity. Defined. + +Definition sig_eta {A P} (p : { a : A | P a }) + : p = exist _ (proj1_sig p) (proj2_sig p). +Proof. destruct p; reflexivity. Defined. + +Definition sigT2_eta {A P Q} (p : { a : A & P a & Q a }) + : p = existT2 _ _ (projT1 (sigT_of_sigT2 p)) (projT2 (sigT_of_sigT2 p)) (projT3 p). +Proof. destruct p; reflexivity. Defined. + +Definition sig2_eta {A P Q} (p : { a : A | P a & Q a }) + : p = exist2 _ _ (proj1_sig (sig_of_sig2 p)) (proj2_sig (sig_of_sig2 p)) (proj3_sig p). +Proof. destruct p; reflexivity. Defined. + +(** [exists x : A, B] is equivalent to [inhabited {x : A | B}] *) +Lemma exists_to_inhabited_sig {A P} : (exists x : A, P x) -> inhabited {x : A | P x}. +Proof. + intros [x y]. exact (inhabits (exist _ x y)). +Qed. + +Lemma inhabited_sig_to_exists {A P} : inhabited {x : A | P x} -> exists x : A, P x. +Proof. + intros [[x y]];exists x;exact y. +Qed. + +(** Equality of sigma types *) +Import EqNotations. +Local Notation "'rew' 'dependent' H 'in' H'" + := (match H with + | eq_refl => H' + end) + (at level 10, H' at level 10, + format "'[' 'rew' 'dependent' '/ ' H in '/' H' ']'"). + +(** Equality for [sigT] *) +Section sigT. + Local Unset Implicit Arguments. + (** Projecting an equality of a pair to equality of the first components *) + Definition projT1_eq {A} {P : A -> Type} {u v : { a : A & P a }} (p : u = v) + : projT1 u = projT1 v + := f_equal (@projT1 _ _) p. + + (** Projecting an equality of a pair to equality of the second components *) + Definition projT2_eq {A} {P : A -> Type} {u v : { a : A & P a }} (p : u = v) + : rew projT1_eq p in projT2 u = projT2 v + := rew dependent p in eq_refl. + + (** Equality of [sigT] is itself a [sigT] (forwards-reasoning version) *) + Definition eq_existT_uncurried {A : Type} {P : A -> Type} {u1 v1 : A} {u2 : P u1} {v2 : P v1} + (pq : { p : u1 = v1 & rew p in u2 = v2 }) + : existT _ u1 u2 = existT _ v1 v2. + Proof. + destruct pq as [p q]. + destruct q; simpl in *. + destruct p; reflexivity. + Defined. + + (** Equality of [sigT] is itself a [sigT] (backwards-reasoning version) *) + Definition eq_sigT_uncurried {A : Type} {P : A -> Type} (u v : { a : A & P a }) + (pq : { p : projT1 u = projT1 v & rew p in projT2 u = projT2 v }) + : u = v. + Proof. + destruct u as [u1 u2], v as [v1 v2]; simpl in *. + apply eq_existT_uncurried; exact pq. + Defined. + + (** Curried version of proving equality of sigma types *) + Definition eq_sigT {A : Type} {P : A -> Type} (u v : { a : A & P a }) + (p : projT1 u = projT1 v) (q : rew p in projT2 u = projT2 v) + : u = v + := eq_sigT_uncurried u v (existT _ p q). + + (** Equality of [sigT] when the property is an hProp *) + Definition eq_sigT_hprop {A P} (P_hprop : forall (x : A) (p q : P x), p = q) + (u v : { a : A & P a }) + (p : projT1 u = projT1 v) + : u = v + := eq_sigT u v p (P_hprop _ _ _). + + (** Equivalence of equality of [sigT] with a [sigT] of equality *) + (** We could actually prove an isomorphism here, and not just [<->], + but for simplicity, we don't. *) + Definition eq_sigT_uncurried_iff {A P} + (u v : { a : A & P a }) + : u = v <-> { p : projT1 u = projT1 v & rew p in projT2 u = projT2 v }. + Proof. + split; [ intro; subst; exists eq_refl; reflexivity | apply eq_sigT_uncurried ]. + Defined. + + (** Induction principle for [@eq (sigT _)] *) + Definition eq_sigT_rect {A P} {u v : { a : A & P a }} (Q : u = v -> Type) + (f : forall p q, Q (eq_sigT u v p q)) + : forall p, Q p. + Proof. intro p; specialize (f (projT1_eq p) (projT2_eq p)); destruct u, p; exact f. Defined. + Definition eq_sigT_rec {A P u v} (Q : u = v :> { a : A & P a } -> Set) := eq_sigT_rect Q. + Definition eq_sigT_ind {A P u v} (Q : u = v :> { a : A & P a } -> Prop) := eq_sigT_rec Q. + + (** Equivalence of equality of [sigT] involving hProps with equality of the first components *) + Definition eq_sigT_hprop_iff {A P} (P_hprop : forall (x : A) (p q : P x), p = q) + (u v : { a : A & P a }) + : u = v <-> (projT1 u = projT1 v) + := conj (fun p => f_equal (@projT1 _ _) p) (eq_sigT_hprop P_hprop u v). + + (** Non-dependent classification of equality of [sigT] *) + Definition eq_sigT_nondep {A B : Type} (u v : { a : A & B }) + (p : projT1 u = projT1 v) (q : projT2 u = projT2 v) + : u = v + := @eq_sigT _ _ u v p (eq_trans (rew_const _ _) q). + + (** Classification of transporting across an equality of [sigT]s *) + Lemma rew_sigT {A x} {P : A -> Type} (Q : forall a, P a -> Prop) (u : { p : P x & Q x p }) {y} (H : x = y) + : rew [fun a => { p : P a & Q a p }] H in u + = existT + (Q y) + (rew H in projT1 u) + (rew dependent H in (projT2 u)). + Proof. + destruct H, u; reflexivity. + Defined. +End sigT. + +(** Equality for [sig] *) +Section sig. + Local Unset Implicit Arguments. + (** Projecting an equality of a pair to equality of the first components *) + Definition proj1_sig_eq {A} {P : A -> Prop} {u v : { a : A | P a }} (p : u = v) + : proj1_sig u = proj1_sig v + := f_equal (@proj1_sig _ _) p. + + (** Projecting an equality of a pair to equality of the second components *) + Definition proj2_sig_eq {A} {P : A -> Prop} {u v : { a : A | P a }} (p : u = v) + : rew proj1_sig_eq p in proj2_sig u = proj2_sig v + := rew dependent p in eq_refl. + + (** Equality of [sig] is itself a [sig] (forwards-reasoning version) *) + Definition eq_exist_uncurried {A : Type} {P : A -> Prop} {u1 v1 : A} {u2 : P u1} {v2 : P v1} + (pq : { p : u1 = v1 | rew p in u2 = v2 }) + : exist _ u1 u2 = exist _ v1 v2. + Proof. + destruct pq as [p q]. + destruct q; simpl in *. + destruct p; reflexivity. + Defined. + + (** Equality of [sig] is itself a [sig] (backwards-reasoning version) *) + Definition eq_sig_uncurried {A : Type} {P : A -> Prop} (u v : { a : A | P a }) + (pq : { p : proj1_sig u = proj1_sig v | rew p in proj2_sig u = proj2_sig v }) + : u = v. + Proof. + destruct u as [u1 u2], v as [v1 v2]; simpl in *. + apply eq_exist_uncurried; exact pq. + Defined. + + (** Curried version of proving equality of sigma types *) + Definition eq_sig {A : Type} {P : A -> Prop} (u v : { a : A | P a }) + (p : proj1_sig u = proj1_sig v) (q : rew p in proj2_sig u = proj2_sig v) + : u = v + := eq_sig_uncurried u v (exist _ p q). + + (** Induction principle for [@eq (sig _)] *) + Definition eq_sig_rect {A P} {u v : { a : A | P a }} (Q : u = v -> Type) + (f : forall p q, Q (eq_sig u v p q)) + : forall p, Q p. + Proof. intro p; specialize (f (proj1_sig_eq p) (proj2_sig_eq p)); destruct u, p; exact f. Defined. + Definition eq_sig_rec {A P u v} (Q : u = v :> { a : A | P a } -> Set) := eq_sig_rect Q. + Definition eq_sig_ind {A P u v} (Q : u = v :> { a : A | P a } -> Prop) := eq_sig_rec Q. + + (** Equality of [sig] when the property is an hProp *) + Definition eq_sig_hprop {A} {P : A -> Prop} (P_hprop : forall (x : A) (p q : P x), p = q) + (u v : { a : A | P a }) + (p : proj1_sig u = proj1_sig v) + : u = v + := eq_sig u v p (P_hprop _ _ _). + + (** Equivalence of equality of [sig] with a [sig] of equality *) + (** We could actually prove an isomorphism here, and not just [<->], + but for simplicity, we don't. *) + Definition eq_sig_uncurried_iff {A} {P : A -> Prop} + (u v : { a : A | P a }) + : u = v <-> { p : proj1_sig u = proj1_sig v | rew p in proj2_sig u = proj2_sig v }. + Proof. + split; [ intro; subst; exists eq_refl; reflexivity | apply eq_sig_uncurried ]. + Defined. + + (** Equivalence of equality of [sig] involving hProps with equality of the first components *) + Definition eq_sig_hprop_iff {A} {P : A -> Prop} (P_hprop : forall (x : A) (p q : P x), p = q) + (u v : { a : A | P a }) + : u = v <-> (proj1_sig u = proj1_sig v) + := conj (fun p => f_equal (@proj1_sig _ _) p) (eq_sig_hprop P_hprop u v). + + Lemma rew_sig {A x} {P : A -> Type} (Q : forall a, P a -> Prop) (u : { p : P x | Q x p }) {y} (H : x = y) + : rew [fun a => { p : P a | Q a p }] H in u + = exist + (Q y) + (rew H in proj1_sig u) + (rew dependent H in proj2_sig u). + Proof. + destruct H, u; reflexivity. + Defined. +End sig. + +(** Equality for [sigT] *) +Section sigT2. + (* We make [sigT_of_sigT2] a coercion so we can use [projT1], [projT2] on [sigT2] *) + Local Coercion sigT_of_sigT2 : sigT2 >-> sigT. + Local Unset Implicit Arguments. + (** Projecting an equality of a pair to equality of the first components *) + Definition sigT_of_sigT2_eq {A} {P Q : A -> Type} {u v : { a : A & P a & Q a }} (p : u = v) + : u = v :> { a : A & P a } + := f_equal _ p. + Definition projT1_of_sigT2_eq {A} {P Q : A -> Type} {u v : { a : A & P a & Q a }} (p : u = v) + : projT1 u = projT1 v + := projT1_eq (sigT_of_sigT2_eq p). + + (** Projecting an equality of a pair to equality of the second components *) + Definition projT2_of_sigT2_eq {A} {P Q : A -> Type} {u v : { a : A & P a & Q a }} (p : u = v) + : rew projT1_of_sigT2_eq p in projT2 u = projT2 v + := rew dependent p in eq_refl. + + (** Projecting an equality of a pair to equality of the third components *) + Definition projT3_eq {A} {P Q : A -> Type} {u v : { a : A & P a & Q a }} (p : u = v) + : rew projT1_of_sigT2_eq p in projT3 u = projT3 v + := rew dependent p in eq_refl. + + (** Equality of [sigT2] is itself a [sigT2] (forwards-reasoning version) *) + Definition eq_existT2_uncurried {A : Type} {P Q : A -> Type} + {u1 v1 : A} {u2 : P u1} {v2 : P v1} {u3 : Q u1} {v3 : Q v1} + (pqr : { p : u1 = v1 + & rew p in u2 = v2 & rew p in u3 = v3 }) + : existT2 _ _ u1 u2 u3 = existT2 _ _ v1 v2 v3. + Proof. + destruct pqr as [p q r]. + destruct r, q, p; simpl. + reflexivity. + Defined. + + (** Equality of [sigT2] is itself a [sigT2] (backwards-reasoning version) *) + Definition eq_sigT2_uncurried {A : Type} {P Q : A -> Type} (u v : { a : A & P a & Q a }) + (pqr : { p : projT1 u = projT1 v + & rew p in projT2 u = projT2 v & rew p in projT3 u = projT3 v }) + : u = v. + Proof. + destruct u as [u1 u2 u3], v as [v1 v2 v3]; simpl in *. + apply eq_existT2_uncurried; exact pqr. + Defined. + + (** Curried version of proving equality of sigma types *) + Definition eq_sigT2 {A : Type} {P Q : A -> Type} (u v : { a : A & P a & Q a }) + (p : projT1 u = projT1 v) + (q : rew p in projT2 u = projT2 v) + (r : rew p in projT3 u = projT3 v) + : u = v + := eq_sigT2_uncurried u v (existT2 _ _ p q r). + + (** Equality of [sigT2] when the second property is an hProp *) + Definition eq_sigT2_hprop {A P Q} (Q_hprop : forall (x : A) (p q : Q x), p = q) + (u v : { a : A & P a & Q a }) + (p : u = v :> { a : A & P a }) + : u = v + := eq_sigT2 u v (projT1_eq p) (projT2_eq p) (Q_hprop _ _ _). + + (** Equivalence of equality of [sigT2] with a [sigT2] of equality *) + (** We could actually prove an isomorphism here, and not just [<->], + but for simplicity, we don't. *) + Definition eq_sigT2_uncurried_iff {A P Q} + (u v : { a : A & P a & Q a }) + : u = v + <-> { p : projT1 u = projT1 v + & rew p in projT2 u = projT2 v & rew p in projT3 u = projT3 v }. + Proof. + split; [ intro; subst; exists eq_refl; reflexivity | apply eq_sigT2_uncurried ]. + Defined. + + (** Induction principle for [@eq (sigT2 _ _)] *) + Definition eq_sigT2_rect {A P Q} {u v : { a : A & P a & Q a }} (R : u = v -> Type) + (f : forall p q r, R (eq_sigT2 u v p q r)) + : forall p, R p. + Proof. + intro p. + specialize (f (projT1_of_sigT2_eq p) (projT2_of_sigT2_eq p) (projT3_eq p)). + destruct u, p; exact f. + Defined. + Definition eq_sigT2_rec {A P Q u v} (R : u = v :> { a : A & P a & Q a } -> Set) := eq_sigT2_rect R. + Definition eq_sigT2_ind {A P Q u v} (R : u = v :> { a : A & P a & Q a } -> Prop) := eq_sigT2_rec R. + + (** Equivalence of equality of [sigT2] involving hProps with equality of the first components *) + Definition eq_sigT2_hprop_iff {A P Q} (Q_hprop : forall (x : A) (p q : Q x), p = q) + (u v : { a : A & P a & Q a }) + : u = v <-> (u = v :> { a : A & P a }) + := conj (fun p => f_equal (@sigT_of_sigT2 _ _ _) p) (eq_sigT2_hprop Q_hprop u v). + + (** Non-dependent classification of equality of [sigT] *) + Definition eq_sigT2_nondep {A B C : Type} (u v : { a : A & B & C }) + (p : projT1 u = projT1 v) (q : projT2 u = projT2 v) (r : projT3 u = projT3 v) + : u = v + := @eq_sigT2 _ _ _ u v p (eq_trans (rew_const _ _) q) (eq_trans (rew_const _ _) r). + + (** Classification of transporting across an equality of [sigT2]s *) + Lemma rew_sigT2 {A x} {P : A -> Type} (Q R : forall a, P a -> Prop) + (u : { p : P x & Q x p & R x p }) + {y} (H : x = y) + : rew [fun a => { p : P a & Q a p & R a p }] H in u + = existT2 + (Q y) + (R y) + (rew H in projT1 u) + (rew dependent H in projT2 u) + (rew dependent H in projT3 u). + Proof. + destruct H, u; reflexivity. + Defined. +End sigT2. + +(** Equality for [sig2] *) +Section sig2. + (* We make [sig_of_sig2] a coercion so we can use [proj1], [proj2] on [sig2] *) + Local Coercion sig_of_sig2 : sig2 >-> sig. + Local Unset Implicit Arguments. + (** Projecting an equality of a pair to equality of the first components *) + Definition sig_of_sig2_eq {A} {P Q : A -> Prop} {u v : { a : A | P a & Q a }} (p : u = v) + : u = v :> { a : A | P a } + := f_equal _ p. + Definition proj1_sig_of_sig2_eq {A} {P Q : A -> Prop} {u v : { a : A | P a & Q a }} (p : u = v) + : proj1_sig u = proj1_sig v + := proj1_sig_eq (sig_of_sig2_eq p). + + (** Projecting an equality of a pair to equality of the second components *) + Definition proj2_sig_of_sig2_eq {A} {P Q : A -> Prop} {u v : { a : A | P a & Q a }} (p : u = v) + : rew proj1_sig_of_sig2_eq p in proj2_sig u = proj2_sig v + := rew dependent p in eq_refl. + + (** Projecting an equality of a pair to equality of the third components *) + Definition proj3_sig_eq {A} {P Q : A -> Prop} {u v : { a : A | P a & Q a }} (p : u = v) + : rew proj1_sig_of_sig2_eq p in proj3_sig u = proj3_sig v + := rew dependent p in eq_refl. + + (** Equality of [sig2] is itself a [sig2] (fowards-reasoning version) *) + Definition eq_exist2_uncurried {A} {P Q : A -> Prop} + {u1 v1 : A} {u2 : P u1} {v2 : P v1} {u3 : Q u1} {v3 : Q v1} + (pqr : { p : u1 = v1 + | rew p in u2 = v2 & rew p in u3 = v3 }) + : exist2 _ _ u1 u2 u3 = exist2 _ _ v1 v2 v3. + Proof. + destruct pqr as [p q r]. + destruct r, q, p; simpl. + reflexivity. + Defined. + + (** Equality of [sig2] is itself a [sig2] (backwards-reasoning version) *) + Definition eq_sig2_uncurried {A} {P Q : A -> Prop} (u v : { a : A | P a & Q a }) + (pqr : { p : proj1_sig u = proj1_sig v + | rew p in proj2_sig u = proj2_sig v & rew p in proj3_sig u = proj3_sig v }) + : u = v. + Proof. + destruct u as [u1 u2 u3], v as [v1 v2 v3]; simpl in *. + apply eq_exist2_uncurried; exact pqr. + Defined. + + (** Curried version of proving equality of sigma types *) + Definition eq_sig2 {A} {P Q : A -> Prop} (u v : { a : A | P a & Q a }) + (p : proj1_sig u = proj1_sig v) + (q : rew p in proj2_sig u = proj2_sig v) + (r : rew p in proj3_sig u = proj3_sig v) + : u = v + := eq_sig2_uncurried u v (exist2 _ _ p q r). + + (** Equality of [sig2] when the second property is an hProp *) + Definition eq_sig2_hprop {A} {P Q : A -> Prop} (Q_hprop : forall (x : A) (p q : Q x), p = q) + (u v : { a : A | P a & Q a }) + (p : u = v :> { a : A | P a }) + : u = v + := eq_sig2 u v (proj1_sig_eq p) (proj2_sig_eq p) (Q_hprop _ _ _). + + (** Equivalence of equality of [sig2] with a [sig2] of equality *) + (** We could actually prove an isomorphism here, and not just [<->], + but for simplicity, we don't. *) + Definition eq_sig2_uncurried_iff {A P Q} + (u v : { a : A | P a & Q a }) + : u = v + <-> { p : proj1_sig u = proj1_sig v + | rew p in proj2_sig u = proj2_sig v & rew p in proj3_sig u = proj3_sig v }. + Proof. + split; [ intro; subst; exists eq_refl; reflexivity | apply eq_sig2_uncurried ]. + Defined. + + (** Induction principle for [@eq (sig2 _ _)] *) + Definition eq_sig2_rect {A P Q} {u v : { a : A | P a & Q a }} (R : u = v -> Type) + (f : forall p q r, R (eq_sig2 u v p q r)) + : forall p, R p. + Proof. + intro p. + specialize (f (proj1_sig_of_sig2_eq p) (proj2_sig_of_sig2_eq p) (proj3_sig_eq p)). + destruct u, p; exact f. + Defined. + Definition eq_sig2_rec {A P Q u v} (R : u = v :> { a : A | P a & Q a } -> Set) := eq_sig2_rect R. + Definition eq_sig2_ind {A P Q u v} (R : u = v :> { a : A | P a & Q a } -> Prop) := eq_sig2_rec R. + + (** Equivalence of equality of [sig2] involving hProps with equality of the first components *) + Definition eq_sig2_hprop_iff {A} {P Q : A -> Prop} (Q_hprop : forall (x : A) (p q : Q x), p = q) + (u v : { a : A | P a & Q a }) + : u = v <-> (u = v :> { a : A | P a }) + := conj (fun p => f_equal (@sig_of_sig2 _ _ _) p) (eq_sig2_hprop Q_hprop u v). + + (** Non-dependent classification of equality of [sig] *) + Definition eq_sig2_nondep {A} {B C : Prop} (u v : @sig2 A (fun _ => B) (fun _ => C)) + (p : proj1_sig u = proj1_sig v) (q : proj2_sig u = proj2_sig v) (r : proj3_sig u = proj3_sig v) + : u = v + := @eq_sig2 _ _ _ u v p (eq_trans (rew_const _ _) q) (eq_trans (rew_const _ _) r). + + (** Classification of transporting across an equality of [sig2]s *) + Lemma rew_sig2 {A x} {P : A -> Type} (Q R : forall a, P a -> Prop) + (u : { p : P x | Q x p & R x p }) + {y} (H : x = y) + : rew [fun a => { p : P a | Q a p & R a p }] H in u + = exist2 + (Q y) + (R y) + (rew H in proj1_sig u) + (rew dependent H in proj2_sig u) + (rew dependent H in proj3_sig u). + Proof. + destruct H, u; reflexivity. + Defined. +End sig2. + + (** [sumbool] is a boolean type equipped with the justification of their value *) @@ -263,10 +704,10 @@ Section Dependent_choice_lemmas. (forall x:X, {y | R x y}) -> forall x0, {f : nat -> X | f O = x0 /\ forall n, R (f n) (f (S n))}. Proof. - intros H x0. + intros H x0. set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end). exists f. - split. reflexivity. + split. reflexivity. induction n; simpl; apply proj2_sig. Defined. @@ -304,16 +745,16 @@ Hint Resolve exist exist2 existT existT2: core. (* Compatibility *) -Notation sigS := sigT (compat "8.2"). -Notation existS := existT (compat "8.2"). -Notation sigS_rect := sigT_rect (compat "8.2"). -Notation sigS_rec := sigT_rec (compat "8.2"). -Notation sigS_ind := sigT_ind (compat "8.2"). -Notation projS1 := projT1 (compat "8.2"). -Notation projS2 := projT2 (compat "8.2"). - -Notation sigS2 := sigT2 (compat "8.2"). -Notation existS2 := existT2 (compat "8.2"). -Notation sigS2_rect := sigT2_rect (compat "8.2"). -Notation sigS2_rec := sigT2_rec (compat "8.2"). -Notation sigS2_ind := sigT2_ind (compat "8.2"). +Notation sigS := sigT (compat "8.6"). +Notation existS := existT (compat "8.6"). +Notation sigS_rect := sigT_rect (compat "8.6"). +Notation sigS_rec := sigT_rec (compat "8.6"). +Notation sigS_ind := sigT_ind (compat "8.6"). +Notation projS1 := projT1 (compat "8.6"). +Notation projS2 := projT2 (compat "8.6"). + +Notation sigS2 := sigT2 (compat "8.6"). +Notation existS2 := existT2 (compat "8.6"). +Notation sigS2_rect := sigT2_rect (compat "8.6"). +Notation sigS2_rec := sigT2_rec (compat "8.6"). +Notation sigS2_ind := sigT2_ind (compat "8.6"). diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 5d1e87ae..8df533e7 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* let G' := context G[x] in change G' in H + | context G[proj2_sig (exist _ ?x ?p)] + => let G' := context G[p] in change G' in H + | context G[projT1 (existT _ ?x ?p)] + => let G' := context G[x] in change G' in H + | context G[projT2 (existT _ ?x ?p)] + => let G' := context G[p] in change G' in H + | context G[proj3_sig (exist2 _ _ ?x ?p ?q)] + => let G' := context G[q] in change G' in H + | context G[projT3 (existT2 _ _ ?x ?p ?q)] + => let G' := context G[q] in change G' in H + | context G[sig_of_sig2 (@exist2 ?A ?P ?Q ?x ?p ?q)] + => let G' := context G[@exist A P x p] in change G' in H + | context G[sigT_of_sigT2 (@existT2 ?A ?P ?Q ?x ?p ?q)] + => let G' := context G[@existT A P x p] in change G' in H + end. +Ltac induction_sigma_in_using H rect := + let H0 := fresh H in + let H1 := fresh H in + induction H as [H0 H1] using (rect _ _ _ _); + simpl_proj_exist_in H0; + simpl_proj_exist_in H1. +Ltac induction_sigma2_in_using H rect := + let H0 := fresh H in + let H1 := fresh H in + let H2 := fresh H in + induction H as [H0 H1 H2] using (rect _ _ _ _ _); + simpl_proj_exist_in H0; + simpl_proj_exist_in H1; + simpl_proj_exist_in H2. +Ltac inversion_sigma_step := + match goal with + | [ H : _ = exist _ _ _ |- _ ] + => induction_sigma_in_using H @eq_sig_rect + | [ H : _ = existT _ _ _ |- _ ] + => induction_sigma_in_using H @eq_sigT_rect + | [ H : exist _ _ _ = _ |- _ ] + => induction_sigma_in_using H @eq_sig_rect + | [ H : existT _ _ _ = _ |- _ ] + => induction_sigma_in_using H @eq_sigT_rect + | [ H : _ = exist2 _ _ _ _ _ |- _ ] + => induction_sigma2_in_using H @eq_sig2_rect + | [ H : _ = existT2 _ _ _ _ _ |- _ ] + => induction_sigma2_in_using H @eq_sigT2_rect + | [ H : exist2 _ _ _ _ _ = _ |- _ ] + => induction_sigma_in_using H @eq_sig2_rect + | [ H : existT2 _ _ _ _ _ = _ |- _ ] + => induction_sigma_in_using H @eq_sigT2_rect + end. +Ltac inversion_sigma := repeat inversion_sigma_step. + +(** A version of [time] that works for constrs *) + +Ltac time_constr tac := + let eval_early := match goal with _ => restart_timer end in + let ret := tac () in + let eval_early := match goal with _ => finish_timing ( "Tactic evaluation" ) end in + ret. + +(** Useful combinators *) + +Ltac assert_fails tac := + tryif tac then fail 0 tac "succeeds" else idtac. +Ltac assert_succeeds tac := + tryif (assert_fails tac) then fail 0 tac "fails" else idtac. +Tactic Notation "assert_succeeds" tactic3(tac) := + assert_succeeds tac. +Tactic Notation "assert_fails" tactic3(tac) := + assert_fails tac. diff --git a/theories/Init/Tauto.v b/theories/Init/Tauto.v index 1e409607..87b7a9a3 100644 --- a/theories/Init/Tauto.v +++ b/theories/Init/Tauto.v @@ -2,7 +2,7 @@ Require Import Notations. Require Import Datatypes. Require Import Logic. -Local Declare ML Module "tauto". +Declare ML Module "tauto_plugin". Local Ltac not_dep_intros := repeat match goal with @@ -27,7 +27,7 @@ Local Ltac simplif flags := | id: ?X1 |- _ => is_disj flags X1; elim id; intro; clear id | id0: (forall (_: ?X1), ?X2), id1: ?X1|- _ => (* generalize (id0 id1); intro; clear id0 does not work - (see Marco Maggiesi's bug PR#301) + (see Marco Maggiesi's BZ#301) so we instead use Assert and exact. *) assert X2; [exact (id0 id1) | clear id0] | id: forall (_ : ?X1), ?X2|- _ => diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index b5b17e5e..c27ffa33 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* l = []. Proof. split. - - destruct l as [|a l' _]. + - destruct l as [|a l']. * intuition. * simpl. destruct (f a), (partition l'); now intros [= -> ->]. - now intros ->. @@ -2110,13 +2111,13 @@ Section Exists_Forall. {Exists l} + {~ Exists l}. Proof. intro Pdec. induction l as [|a l' Hrec]. - - right. now rewrite Exists_nil. + - right. abstract now rewrite Exists_nil. - destruct Hrec as [Hl'|Hl']. * left. now apply Exists_cons_tl. * destruct (Pdec a) as [Ha|Ha]. + left. now apply Exists_cons_hd. - + right. now inversion_clear 1. - Qed. + + right. abstract now inversion 1. + Defined. Inductive Forall : list A -> Prop := | Forall_nil : Forall nil @@ -2152,9 +2153,9 @@ Section Exists_Forall. - destruct Hrec as [Hl'|Hl']. + destruct (Pdec a) as [Ha|Ha]. * left. now apply Forall_cons. - * right. now inversion_clear 1. - + right. now inversion_clear 1. - Qed. + * right. abstract now inversion 1. + + right. abstract now inversion 1. + Defined. End One_predicate. @@ -2179,6 +2180,16 @@ Section Exists_Forall. * now apply Exists_cons_hd. Qed. + Lemma neg_Forall_Exists_neg (P:A->Prop) (l:list A) : + (forall x:A, {P x} + { ~ P x }) -> + ~ Forall P l -> + Exists (fun x => ~ P x) l. + Proof. + intro Dec. + apply Exists_Forall_neg; intros. + destruct (Dec x); auto. + Qed. + Lemma Forall_Exists_dec (P:A->Prop) : (forall x:A, {P x} + { ~ P x }) -> forall l:list A, @@ -2186,9 +2197,8 @@ Section Exists_Forall. Proof. intros Pdec l. destruct (Forall_dec P Pdec l); [left|right]; trivial. - apply Exists_Forall_neg; trivial. - intro x. destruct (Pdec x); [now left|now right]. - Qed. + now apply neg_Forall_Exists_neg. + Defined. Lemma Forall_impl : forall (P Q : A -> Prop), (forall a, P a -> Q a) -> forall l, Forall P l -> Forall Q l. diff --git a/theories/Lists/ListDec.v b/theories/Lists/ListDec.v index 3e2eeac0..e7e2cfc8 100644 --- a/theories/Lists/ListDec.v +++ b/theories/Lists/ListDec.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop) (S:Stream A), ForAll (fun s => P (map s)) S <-> ForAll P (map S). Proof. intros P S. -split; generalize S; clear S; cofix; intros S; constructor; +split; generalize S; clear S; cofix ForAll_map; intros S; constructor; destruct H as [H0 H]; firstorder. Qed. diff --git a/theories/Lists/vo.itarget b/theories/Lists/vo.itarget deleted file mode 100644 index 82dd1be8..00000000 --- a/theories/Lists/vo.itarget +++ /dev/null @@ -1,8 +0,0 @@ -ListSet.vo -ListTactics.vo -List.vo -ListDec.vo -SetoidList.vo -SetoidPermutation.vo -StreamMemo.vo -Streams.vo diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index 1e0bd0fe..c6836a1c 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* GAC_rel and IPL_2 |- GAC_rel = OAC_rel - -3.2. IPL^2 |- AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker - -3.3. D_iota -> ID_iota and D_epsilon <-> ID_epsilon + Drinker - -4. Derivability of choice for decidable relations with well-ordered codomain - -5. Equivalence of choices on dependent or non dependent functional types - -6. Non contradiction of constructive descriptions wrt functional choices - -7. Definite description transports classical logic to the computational world - -8. Choice -> Dependent choice -> Countable choice - -References: - + intuitionistic logic. *) +(** * References: *) +(** [[Bell]] John L. Bell, Choice principles in intuitionistic set theory, unpublished. [[Bell93]] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic Type Theories, Mathematical Logic Quarterly, volume 39, 1993. +[[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent to +AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004. + [[Carlström05]] Jesper Carlström, Interpreting descriptions in intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005. + +[[Werner97]] Benjamin Werner, Sets in Types, Types in Sets, TACS, 1997. *) +Require Import RelationClasses Logic. + Set Implicit Arguments. Local Unset Intuition Negation Unfolding. @@ -108,59 +50,139 @@ Variables A B :Type. Variable P:A->Prop. -Variable R:A->B->Prop. - (** ** Constructive choice and description *) -(** AC_rel *) +(** AC_rel = relational form of the (non extensional) axiom of choice + (a "set-theoretic" axiom of choice) *) Definition RelationalChoice_on := forall R:A->B->Prop, (forall x : A, exists y : B, R x y) -> (exists R' : A->B->Prop, subrelation R' R /\ forall x, exists! y, R' x y). -(** AC_fun *) +(** AC_fun = functional form of the (non extensional) axiom of choice + (a "type-theoretic" axiom of choice) *) + +(* Note: This is called Type-Theoretic Description Axiom (TTDA) in + [[Werner97]] (using a non-standard meaning of "description"). This + is called intensional axiom of choice (AC_int) in [[Carlström04]] *) + +Definition FunctionalChoice_on_rel (R:A->B->Prop) := + (forall x:A, exists y : B, R x y) -> + exists f : A -> B, (forall x:A, R x (f x)). Definition FunctionalChoice_on := forall R:A->B->Prop, (forall x : A, exists y : B, R x y) -> (exists f : A->B, forall x : A, R x (f x)). -(** DC_fun *) +(** AC_fun_dep = functional form of the (non extensional) axiom of + choice, with dependent functions *) +Definition DependentFunctionalChoice_on (A:Type) (B:A -> Type) := + forall R:forall x:A, B x -> Prop, + (forall x:A, exists y : B x, R x y) -> + (exists f : (forall x:A, B x), forall x:A, R x (f x)). + +(** AC_trunc = axiom of choice for propositional truncations + (truncation and quantification commute) *) +Definition InhabitedForallCommute_on (A : Type) (B : A -> Type) := + (forall x, inhabited (B x)) -> inhabited (forall x, B x). + +(** DC_fun = functional form of the dependent axiom of choice *) Definition FunctionalDependentChoice_on := forall (R:A->A->Prop), (forall x, exists y, R x y) -> forall x0, (exists f : nat -> A, f 0 = x0 /\ forall n, R (f n) (f (S n))). -(** ACw_fun *) +(** ACw_fun = functional form of the countable axiom of choice *) Definition FunctionalCountableChoice_on := forall (R:nat->A->Prop), (forall n, exists y, R n y) -> (exists f : nat -> A, forall n, R n (f n)). -(** AC! or Functional Relation Reification (known as Axiom of Unique Choice - in topos theory; also called principle of definite description *) +(** AC! = functional relation reification + (known as axiom of unique choice in topos theory, + sometimes called principle of definite description in + the context of constructive type theory, sometimes + called axiom of no choice) *) Definition FunctionalRelReification_on := forall R:A->B->Prop, (forall x : A, exists! y : B, R x y) -> (exists f : A->B, forall x : A, R x (f x)). -(** ID_epsilon (constructive version of indefinite description; - combined with proof-irrelevance, it may be connected to - Carlström's type theory with a constructive indefinite description - operator) *) +(** AC_dep! = functional relation reification, with dependent functions + see AC! *) +Definition DependentFunctionalRelReification_on (A:Type) (B:A -> Type) := + forall (R:forall x:A, B x -> Prop), + (forall x:A, exists! y : B x, R x y) -> + (exists f : (forall x:A, B x), forall x:A, R x (f x)). + +(** AC_fun_repr = functional choice of a representative in an equivalence class *) + +(* Note: This is called Type-Theoretic Choice Axiom (TTCA) in + [[Werner97]] (by reference to the extensional set-theoretic + formulation of choice); Note also a typo in its intended + formulation in [[Werner97]]. *) + +Definition RepresentativeFunctionalChoice_on := + forall R:A->A->Prop, + (Equivalence R) -> + (exists f : A->A, forall x : A, (R x (f x)) /\ forall x', R x x' -> f x = f x'). + +(** AC_fun_setoid = functional form of the (so-called extensional) axiom of + choice from setoids *) + +Definition SetoidFunctionalChoice_on := + forall R : A -> A -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + (forall x x' y, R x x' -> T x y -> T x' y) -> + (forall x, exists y, T x y) -> + exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). + +(** AC_fun_setoid_gen = functional form of the general form of the (so-called + extensional) axiom of choice over setoids *) + +(* Note: This is called extensional axiom of choice (AC_ext) in + [[Carlström04]]. *) + +Definition GeneralizedSetoidFunctionalChoice_on := + forall R : A -> A -> Prop, + forall S : B -> B -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + Equivalence S -> + (forall x x' y y', R x x' -> S y y' -> T x y -> T x' y') -> + (forall x, exists y, T x y) -> + exists f : A -> B, + forall x : A, T x (f x) /\ (forall x' : A, R x x' -> S (f x) (f x')). + +(** AC_fun_setoid_simple = functional form of the (so-called extensional) axiom of + choice from setoids on locally compatible relations *) + +Definition SimpleSetoidFunctionalChoice_on A B := + forall R : A -> A -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + (forall x, exists y, forall x', R x x' -> T x' y) -> + exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). + +(** ID_epsilon = constructive version of indefinite description; + combined with proof-irrelevance, it may be connected to + Carlström's type theory with a constructive indefinite description + operator *) Definition ConstructiveIndefiniteDescription_on := forall P:A->Prop, (exists x, P x) -> { x:A | P x }. -(** ID_iota (constructive version of definite description; combined - with proof-irrelevance, it may be connected to Carlström's and - Stenlund's type theory with a constructive definite description - operator) *) +(** ID_iota = constructive version of definite description; + combined with proof-irrelevance, it may be connected to + Carlström's and Stenlund's type theory with a + constructive definite description operator) *) Definition ConstructiveDefiniteDescription_on := forall P:A->Prop, @@ -168,7 +190,7 @@ Definition ConstructiveDefiniteDescription_on := (** ** Weakly classical choice and description *) -(** GAC_rel *) +(** GAC_rel = guarded relational form of the (non extensional) axiom of choice *) Definition GuardedRelationalChoice_on := forall P : A->Prop, forall R : A->B->Prop, @@ -176,7 +198,7 @@ Definition GuardedRelationalChoice_on := (exists R' : A->B->Prop, subrelation R' R /\ forall x, P x -> exists! y, R' x y). -(** GAC_fun *) +(** GAC_fun = guarded functional form of the (non extensional) axiom of choice *) Definition GuardedFunctionalChoice_on := forall P : A->Prop, forall R : A->B->Prop, @@ -184,7 +206,7 @@ Definition GuardedFunctionalChoice_on := (forall x : A, P x -> exists y : B, R x y) -> (exists f : A->B, forall x, P x -> R x (f x)). -(** GFR_fun *) +(** GAC! = guarded functional relation reification *) Definition GuardedFunctionalRelReification_on := forall P : A->Prop, forall R : A->B->Prop, @@ -192,27 +214,28 @@ Definition GuardedFunctionalRelReification_on := (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 *) +(** OAC_rel = "omniscient" relational form of the (non extensional) axiom of choice *) Definition OmniscientRelationalChoice_on := forall R : A->B->Prop, exists R' : A->B->Prop, subrelation R' R /\ forall x : A, (exists y : B, R x y) -> exists! y, R' x y. -(** OAC_fun *) +(** OAC_fun = "omniscient" functional form of the (non extensional) axiom of choice + (called AC* in Bell [[Bell]]) *) Definition OmniscientFunctionalChoice_on := forall R : A->B->Prop, inhabited B -> exists f : A->B, forall x : A, (exists y : B, R x y) -> R x (f x). -(** D_epsilon *) +(** D_epsilon = (weakly classical) indefinite description principle *) Definition EpsilonStatement_on := forall P:A->Prop, inhabited A -> { x:A | (exists x, P x) -> P x }. -(** D_iota *) +(** D_iota = (weakly classical) definite description principle *) Definition IotaStatement_on := forall P:A->Prop, @@ -226,14 +249,28 @@ Notation RelationalChoice := (forall A B : Type, RelationalChoice_on A B). Notation FunctionalChoice := (forall A B : Type, FunctionalChoice_on A B). -Definition FunctionalDependentChoice := +Notation DependentFunctionalChoice := + (forall A (B:A->Type), DependentFunctionalChoice_on B). +Notation InhabitedForallCommute := + (forall A (B : A -> Type), InhabitedForallCommute_on B). +Notation FunctionalDependentChoice := (forall A : Type, FunctionalDependentChoice_on A). -Definition FunctionalCountableChoice := +Notation FunctionalCountableChoice := (forall A : Type, FunctionalCountableChoice_on A). Notation FunctionalChoiceOnInhabitedSet := (forall A B : Type, inhabited B -> FunctionalChoice_on A B). Notation FunctionalRelReification := (forall A B : Type, FunctionalRelReification_on A B). +Notation DependentFunctionalRelReification := + (forall A (B:A->Type), DependentFunctionalRelReification_on B). +Notation RepresentativeFunctionalChoice := + (forall A : Type, RepresentativeFunctionalChoice_on A). +Notation SetoidFunctionalChoice := + (forall A B: Type, SetoidFunctionalChoice_on A B). +Notation GeneralizedSetoidFunctionalChoice := + (forall A B : Type, GeneralizedSetoidFunctionalChoice_on A B). +Notation SimpleSetoidFunctionalChoice := + (forall A B : Type, SimpleSetoidFunctionalChoice_on A B). Notation GuardedRelationalChoice := (forall A B : Type, GuardedRelationalChoice_on A B). @@ -259,18 +296,87 @@ Notation EpsilonStatement := (** Subclassical schemes *) +(** PI = proof irrelevance *) Definition ProofIrrelevance := forall (A:Prop) (a1 a2:A), a1 = a2. +(** IGP = independence of general premises + (an unconstrained generalisation of the constructive principle of + independence of premises) *) Definition IndependenceOfGeneralPremises := forall (A:Type) (P:A -> Prop) (Q:Prop), inhabited A -> (Q -> exists x, P x) -> exists x, Q -> P x. +(** Drinker = drinker's paradox (small form) + (called Ex in Bell [[Bell]]) *) Definition SmallDrinker'sParadox := forall (A:Type) (P:A -> Prop), inhabited A -> exists x, (exists x, P x) -> P x. +(** EM = excluded-middle *) +Definition ExcludedMiddle := + forall P:Prop, P \/ ~ P. + +(** Extensional schemes *) + +(** Ext_prop_repr = choice of a representative among extensional propositions *) +Local Notation ExtensionalPropositionRepresentative := + (forall (A:Type), + exists h : Prop -> Prop, + forall P : Prop, (P <-> h P) /\ forall Q, (P <-> Q) -> h P = h Q). + +(** Ext_pred_repr = choice of a representative among extensional predicates *) +Local Notation ExtensionalPredicateRepresentative := + (forall (A:Type), + exists h : (A->Prop) -> (A->Prop), + forall (P : A -> Prop), (forall x, P x <-> h P x) /\ forall Q, (forall x, P x <-> Q x) -> h P = h Q). + +(** Ext_fun_repr = choice of a representative among extensional functions *) +Local Notation ExtensionalFunctionRepresentative := + (forall (A B:Type), + exists h : (A->B) -> (A->B), + forall (f : A -> B), (forall x, f x = h f x) /\ forall g, (forall x, f x = g x) -> h f = h g). + +(** We let also + +- IPL_2 = 2nd-order impredicative minimal predicate logic (with ex. quant.) +- IPL^2 = 2nd-order functional minimal predicate logic (with ex. quant.) +- IPL_2^2 = 2nd-order impredicative, 2nd-order functional minimal pred. logic (with ex. quant.) + +with no prerequisite on the non-emptiness of domains +*) + +(**********************************************************************) +(** * Table of contents *) + +(* This is very fragile. *) +(** +1. Definitions + +2. IPL_2^2 |- AC_rel + AC! = AC_fun + +3.1. typed IPL_2 + Sigma-types + PI |- AC_rel = GAC_rel and IPL_2 |- AC_rel + IGP -> GAC_rel and IPL_2 |- GAC_rel = OAC_rel + +3.2. IPL^2 |- AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker + +3.3. D_iota -> ID_iota and D_epsilon <-> ID_epsilon + Drinker + +4. Derivability of choice for decidable relations with well-ordered codomain + +5. AC_fun = AC_fun_dep = AC_trunc + +6. Non contradiction of constructive descriptions wrt functional choices + +7. Definite description transports classical logic to the computational world + +8. Choice -> Dependent choice -> Countable choice + +9.1. AC_fun_setoid = AC_fun + Ext_fun_repr + EM + +9.2. AC_fun_setoid = AC_fun + Ext_pred_repr + PI + *) + (**********************************************************************) (** * AC_rel + AC! = AC_fun @@ -284,7 +390,7 @@ Definition SmallDrinker'sParadox := relational formulation) without known inconsistency with classical logic, though functional relation reification conflicts with classical logic *) -Lemma description_rel_choice_imp_funct_choice : +Lemma functional_rel_reification_and_rel_choice_imp_fun_choice : forall A B : Type, FunctionalRelReification_on A B -> RelationalChoice_on A B -> FunctionalChoice_on A B. Proof. @@ -298,7 +404,7 @@ Proof. apply HR'R; assumption. Qed. -Lemma funct_choice_imp_rel_choice : +Lemma fun_choice_imp_rel_choice : forall A B : Type, FunctionalChoice_on A B -> RelationalChoice_on A B. Proof. intros A B FunCh R H. @@ -311,7 +417,7 @@ Proof. trivial. Qed. -Lemma funct_choice_imp_description : +Lemma fun_choice_imp_functional_rel_reification : forall A B : Type, FunctionalChoice_on A B -> FunctionalRelReification_on A B. Proof. intros A B FunCh R H. @@ -324,15 +430,15 @@ Proof. exists f; exact H0. Qed. -Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr : +Corollary fun_choice_iff_rel_choice_and_functional_rel_reification : forall A B : Type, FunctionalChoice_on A B <-> RelationalChoice_on A B /\ FunctionalRelReification_on A B. Proof. intros A B. split. intro H; split; - [ exact (funct_choice_imp_rel_choice H) - | exact (funct_choice_imp_description H) ]. - intros [H H0]; exact (description_rel_choice_imp_funct_choice H0 H). + [ exact (fun_choice_imp_rel_choice H) + | exact (fun_choice_imp_functional_rel_reification H) ]. + intros [H H0]; exact (functional_rel_reification_and_rel_choice_imp_fun_choice H0 H). Qed. (**********************************************************************) @@ -576,10 +682,6 @@ Qed. Require Import Wf_nat. Require Import Decidable. -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 -> @@ -601,18 +703,10 @@ Proof. Qed. (**********************************************************************) -(** * Choice on dependent and non dependent function types are equivalent *) +(** * AC_fun = AC_fun_dep = AC_trunc *) (** ** Choice on dependent and non dependent function types are equivalent *) -Definition DependentFunctionalChoice_on (A:Type) (B:A -> Type) := - forall R:forall x:A, B x -> Prop, - (forall x:A, exists y : B x, R x y) -> - (exists f : (forall x:A, B x), forall x:A, R x (f x)). - -Notation DependentFunctionalChoice := - (forall A (B:A->Type), DependentFunctionalChoice_on B). - (** The easy part *) Theorem dep_non_dep_functional_choice : @@ -649,15 +743,34 @@ Proof. destruct Heq using eq_indd; trivial. Qed. -(** ** Reification of dependent and non dependent functional relation are equivalent *) +(** ** Functional choice and truncation choice are equivalent *) -Definition DependentFunctionalRelReification_on (A:Type) (B:A -> Type) := - forall (R:forall x:A, B x -> Prop), - (forall x:A, exists! y : B x, R x y) -> - (exists f : (forall x:A, B x), forall x:A, R x (f x)). +Theorem functional_choice_to_inhabited_forall_commute : + FunctionalChoice -> InhabitedForallCommute. +Proof. + intros choose0 A B Hinhab. + pose proof (non_dep_dep_functional_choice choose0) as choose;clear choose0. + assert (Hexists : forall x, exists _ : B x, True). + { intros x;apply inhabited_sig_to_exists. + refine (inhabited_covariant _ (Hinhab x)). + intros y;exists y;exact I. } + apply choose in Hexists. + destruct Hexists as [f _]. + exact (inhabits f). +Qed. -Notation DependentFunctionalRelReification := - (forall A (B:A->Type), DependentFunctionalRelReification_on B). +Theorem inhabited_forall_commute_to_functional_choice : + InhabitedForallCommute -> FunctionalChoice. +Proof. + intros choose A B R Hexists. + assert (Hinhab : forall x, inhabited {y : B | R x y}). + { intros x;apply exists_to_inhabited_sig;trivial. } + apply choose in Hinhab. destruct Hinhab as [f]. + exists (fun x => proj1_sig (f x)). + exact (fun x => proj2_sig (f x)). +Qed. + +(** ** Reification of dependent and non dependent functional relation are equivalent *) (** The easy part *) @@ -862,3 +975,346 @@ Proof. rewrite Heq in HR. assumption. Qed. + +(**********************************************************************) +(** * About the axiom of choice over setoids *) + +Require Import ClassicalFacts PropExtensionalityFacts. + +(**********************************************************************) +(** ** Consequences of the choice of a representative in an equivalence class *) + +Theorem repr_fun_choice_imp_ext_prop_repr : + RepresentativeFunctionalChoice -> ExtensionalPropositionRepresentative. +Proof. + intros ReprFunChoice A. + pose (R P Q := P <-> Q). + assert (Hequiv:Equivalence R) by (split; firstorder). + apply (ReprFunChoice _ R Hequiv). +Qed. + +Theorem repr_fun_choice_imp_ext_pred_repr : + RepresentativeFunctionalChoice -> ExtensionalPredicateRepresentative. +Proof. + intros ReprFunChoice A. + pose (R P Q := forall x : A, P x <-> Q x). + assert (Hequiv:Equivalence R) by (split; firstorder). + apply (ReprFunChoice _ R Hequiv). +Qed. + +Theorem repr_fun_choice_imp_ext_function_repr : + RepresentativeFunctionalChoice -> ExtensionalFunctionRepresentative. +Proof. + intros ReprFunChoice A B. + pose (R (f g : A -> B) := forall x : A, f x = g x). + assert (Hequiv:Equivalence R). + { split; try easy. firstorder using eq_trans. } + apply (ReprFunChoice _ R Hequiv). +Qed. + +(** *** This is a variant of Diaconescu and Goodman-Myhill theorems *) + +Theorem repr_fun_choice_imp_excluded_middle : + RepresentativeFunctionalChoice -> ExcludedMiddle. +Proof. + intros ReprFunChoice. + apply representative_boolean_partition_imp_excluded_middle, ReprFunChoice. +Qed. + +Theorem repr_fun_choice_imp_relational_choice : + RepresentativeFunctionalChoice -> RelationalChoice. +Proof. + intros ReprFunChoice A B T Hexists. + pose (D := (A*B)%type). + pose (R (z z':D) := + let x := fst z in + let x' := fst z' in + let y := snd z in + let y' := snd z' in + x = x' /\ (T x y -> y = y' \/ T x y') /\ (T x y' -> y = y' \/ T x y)). + assert (Hequiv : Equivalence R). + { split. + - split. easy. firstorder. + - intros (x,y) (x',y') (H1,(H2,H2')). split. easy. simpl fst in *. simpl snd in *. + subst x'. split; intro H. + + destruct (H2' H); firstorder. + + destruct (H2 H); firstorder. + - intros (x,y) (x',y') (x'',y'') (H1,(H2,H2')) (H3,(H4,H4')). + simpl fst in *. simpl snd in *. subst x'' x'. split. easy. split; intro H. + + simpl fst in *. simpl snd in *. destruct (H2 H) as [<-|H0]. + * destruct (H4 H); firstorder. + * destruct (H2' H0), (H4 H0); try subst y'; try subst y''; try firstorder. + + simpl fst in *. simpl snd in *. destruct (H4' H) as [<-|H0]. + * destruct (H2' H); firstorder. + * destruct (H2' H0), (H4 H0); try subst y'; try subst y''; try firstorder. } + destruct (ReprFunChoice D R Hequiv) as (g,Hg). + set (T' x y := T x y /\ exists y', T x y' /\ g (x,y') = (x,y)). + exists T'. split. + - intros x y (H,_); easy. + - intro x. destruct (Hexists x) as (y,Hy). + exists (snd (g (x,y))). + destruct (Hg (x,y)) as ((Heq1,(H',H'')),Hgxyuniq); clear Hg. + destruct (H' Hy) as [Heq2|Hgy]; clear H'. + + split. split. + * rewrite <- Heq2. assumption. + * exists y. destruct (g (x,y)) as (x',y'). simpl in Heq1, Heq2. subst; easy. + * intros y' (Hy',(y'',(Hy'',Heq))). + rewrite (Hgxyuniq (x,y'')), Heq. easy. split. easy. + split; right; easy. + + split. split. + * assumption. + * exists y. destruct (g (x,y)) as (x',y'). simpl in Heq1. subst x'; easy. + * intros y' (Hy',(y'',(Hy'',Heq))). + rewrite (Hgxyuniq (x,y'')), Heq. easy. split. easy. + split; right; easy. +Qed. + +(**********************************************************************) +(** ** AC_fun_setoid = AC_fun_setoid_gen = AC_fun_setoid_simple *) + +Theorem gen_setoid_fun_choice_imp_setoid_fun_choice : + forall A B, GeneralizedSetoidFunctionalChoice_on A B -> SetoidFunctionalChoice_on A B. +Proof. + intros A B GenSetoidFunChoice R T Hequiv Hcompat Hex. + apply GenSetoidFunChoice; try easy. + apply eq_equivalence. + intros * H <-. firstorder. +Qed. + +Theorem setoid_fun_choice_imp_gen_setoid_fun_choice : + forall A B, SetoidFunctionalChoice_on A B -> GeneralizedSetoidFunctionalChoice_on A B. +Proof. + intros A B SetoidFunChoice R S T HequivR HequivS Hcompat Hex. + destruct SetoidFunChoice with (R:=R) (T:=T) as (f,Hf); try easy. + { intros; apply (Hcompat x x' y y); try easy. } + exists f. intros x; specialize Hf with x as (Hf,Huniq). intuition. now erewrite Huniq. +Qed. + +Corollary setoid_fun_choice_iff_gen_setoid_fun_choice : + forall A B, SetoidFunctionalChoice_on A B <-> GeneralizedSetoidFunctionalChoice_on A B. +Proof. + split; auto using gen_setoid_fun_choice_imp_setoid_fun_choice, setoid_fun_choice_imp_gen_setoid_fun_choice. +Qed. + +Theorem setoid_fun_choice_imp_simple_setoid_fun_choice : + forall A B, SetoidFunctionalChoice_on A B -> SimpleSetoidFunctionalChoice_on A B. +Proof. + intros A B SetoidFunChoice R T Hequiv Hexists. + pose (T' x y := forall x', R x x' -> T x' y). + assert (Hcompat : forall (x x' : A) (y : B), R x x' -> T' x y -> T' x' y) by firstorder. + destruct (SetoidFunChoice R T' Hequiv Hcompat Hexists) as (f,Hf). + exists f. firstorder. +Qed. + +Theorem simple_setoid_fun_choice_imp_setoid_fun_choice : + forall A B, SimpleSetoidFunctionalChoice_on A B -> SetoidFunctionalChoice_on A B. +Proof. + intros A B SimpleSetoidFunChoice R T Hequiv Hcompat Hexists. + destruct (SimpleSetoidFunChoice R T Hequiv) as (f,Hf); firstorder. +Qed. + +Corollary setoid_fun_choice_iff_simple_setoid_fun_choice : + forall A B, SetoidFunctionalChoice_on A B <-> SimpleSetoidFunctionalChoice_on A B. +Proof. + split; auto using simple_setoid_fun_choice_imp_setoid_fun_choice, setoid_fun_choice_imp_simple_setoid_fun_choice. +Qed. + +(**********************************************************************) +(** ** AC_fun_setoid = AC! + AC_fun_repr *) + +Theorem setoid_fun_choice_imp_fun_choice : + forall A B, SetoidFunctionalChoice_on A B -> FunctionalChoice_on A B. +Proof. + intros A B SetoidFunChoice T Hexists. + destruct SetoidFunChoice with (R:=@eq A) (T:=T) as (f,Hf). + - apply eq_equivalence. + - now intros * ->. + - assumption. + - exists f. firstorder. +Qed. + +Corollary setoid_fun_choice_imp_functional_rel_reification : + forall A B, SetoidFunctionalChoice_on A B -> FunctionalRelReification_on A B. +Proof. + intros A B SetoidFunChoice. + apply fun_choice_imp_functional_rel_reification. + now apply setoid_fun_choice_imp_fun_choice. +Qed. + +Theorem setoid_fun_choice_imp_repr_fun_choice : + SetoidFunctionalChoice -> RepresentativeFunctionalChoice . +Proof. + intros SetoidFunChoice A R Hequiv. + apply SetoidFunChoice; firstorder. +Qed. + +Theorem functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice : + FunctionalRelReification -> RepresentativeFunctionalChoice -> SetoidFunctionalChoice. +Proof. + intros FunRelReify ReprFunChoice A B R T Hequiv Hcompat Hexists. + assert (FunChoice : FunctionalChoice). + { intros A' B'. apply functional_rel_reification_and_rel_choice_imp_fun_choice. + - apply FunRelReify. + - now apply repr_fun_choice_imp_relational_choice. } + destruct (FunChoice _ _ T Hexists) as (f,Hf). + destruct (ReprFunChoice A R Hequiv) as (g,Hg). + exists (fun a => f (g a)). + intro x. destruct (Hg x) as (Hgx,HRuniq). + split. + - eapply Hcompat. symmetry. apply Hgx. apply Hf. + - intros y Hxy. f_equal. auto. +Qed. + +Theorem functional_rel_reification_and_repr_fun_choice_iff_setoid_fun_choice : + FunctionalRelReification /\ RepresentativeFunctionalChoice <-> SetoidFunctionalChoice. +Proof. + split; intros. + - now apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. + - split. + + now intros A B; apply setoid_fun_choice_imp_functional_rel_reification. + + now apply setoid_fun_choice_imp_repr_fun_choice. +Qed. + +(** Note: What characterization to give of +RepresentativeFunctionalChoice? A formulation of it as a functional +relation would certainly be equivalent to the formulation of +SetoidFunctionalChoice as a functional relation, but in their +functional forms, SetoidFunctionalChoice seems strictly stronger *) + +(**********************************************************************) +(** * AC_fun_setoid = AC_fun + Ext_fun_repr + EM *) + +Import EqNotations. + +(** ** This is the main theorem in [[Carlström04]] *) + +(** Note: all ingredients have a computational meaning when taken in + separation. However, to compute with the functional choice, + existential quantification has to be thought as a strong + existential, which is incompatible with the computational content of + excluded-middle *) + +Theorem fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice : + FunctionalChoice -> ExtensionalFunctionRepresentative -> ExcludedMiddle -> RepresentativeFunctionalChoice. +Proof. + intros FunChoice SetoidFunRepr EM A R (Hrefl,Hsym,Htrans). + assert (H:forall P:Prop, exists b, b = true <-> P). + { intros P. destruct (EM P). + - exists true; firstorder. + - exists false; easy. } + destruct (FunChoice _ _ _ H) as (c,Hc). + pose (class_of a y := c (R a y)). + pose (isclass f := exists x:A, f x = true). + pose (class := {f:A -> bool | isclass f}). + pose (contains (c:class) (a:A) := proj1_sig c a = true). + destruct (FunChoice class A contains) as (f,Hf). + - intros f. destruct (proj2_sig f) as (x,Hx). + exists x. easy. + - destruct (SetoidFunRepr A bool) as (h,Hh). + assert (Hisclass:forall a, isclass (h (class_of a))). + { intro a. exists a. destruct (Hh (class_of a)) as (Ha,Huniqa). + rewrite <- Ha. apply Hc. apply Hrefl. } + pose (f':= fun a => exist _ (h (class_of a)) (Hisclass a) : class). + exists (fun a => f (f' a)). + intros x. destruct (Hh (class_of x)) as (Hx,Huniqx). split. + + specialize Hf with (f' x). unfold contains in Hf. simpl in Hf. rewrite <- Hx in Hf. apply Hc. assumption. + + intros y Hxy. + f_equal. + assert (Heq1: h (class_of x) = h (class_of y)). + { apply Huniqx. intro z. unfold class_of. + destruct (c (R x z)) eqn:Hxz. + - symmetry. apply Hc. apply -> Hc in Hxz. firstorder. + - destruct (c (R y z)) eqn:Hyz. + + apply -> Hc in Hyz. rewrite <- Hxz. apply Hc. firstorder. + + easy. } + assert (Heq2:rew Heq1 in Hisclass x = Hisclass y). + { apply proof_irrelevance_cci, EM. } + unfold f'. + rewrite <- Heq2. + rewrite <- Heq1. + reflexivity. +Qed. + +Theorem setoid_functional_choice_first_characterization : + FunctionalChoice /\ ExtensionalFunctionRepresentative /\ ExcludedMiddle <-> SetoidFunctionalChoice. +Proof. + split. + - intros (FunChoice & SetoidFunRepr & EM). + apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. + + intros A B. apply fun_choice_imp_functional_rel_reification, FunChoice. + + now apply fun_choice_and_ext_functions_repr_and_excluded_middle_imp_setoid_fun_choice. + - intro SetoidFunChoice. repeat split. + + now intros A B; apply setoid_fun_choice_imp_fun_choice. + + apply repr_fun_choice_imp_ext_function_repr. + now apply setoid_fun_choice_imp_repr_fun_choice. + + apply repr_fun_choice_imp_excluded_middle. + now apply setoid_fun_choice_imp_repr_fun_choice. +Qed. + +(**********************************************************************) +(** ** AC_fun_setoid = AC_fun + Ext_pred_repr + PI *) + +(** Note: all ingredients have a computational meaning when taken in + separation. However, to compute with the functional choice, + existential quantification has to be thought as a strong + existential, which is incompatible with proof-irrelevance which + requires existential quantification to be truncated *) + +Theorem fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice : + FunctionalChoice -> ExtensionalPredicateRepresentative -> ProofIrrelevance -> RepresentativeFunctionalChoice. +Proof. + intros FunChoice PredExtRepr PI A R (Hrefl,Hsym,Htrans). + pose (isclass P := exists x:A, P x). + pose (class := {P:A -> Prop | isclass P}). + pose (contains (c:class) (a:A) := proj1_sig c a). + pose (class_of a := R a). + destruct (FunChoice class A contains) as (f,Hf). + - intros c. apply proj2_sig. + - destruct (PredExtRepr A) as (h,Hh). + assert (Hisclass:forall a, isclass (h (class_of a))). + { intro a. exists a. destruct (Hh (class_of a)) as (Ha,Huniqa). + rewrite <- Ha; apply Hrefl. } + pose (f':= fun a => exist _ (h (class_of a)) (Hisclass a) : class). + exists (fun a => f (f' a)). + intros x. destruct (Hh (class_of x)) as (Hx,Huniqx). split. + + specialize Hf with (f' x). simpl in Hf. rewrite <- Hx in Hf. assumption. + + intros y Hxy. + f_equal. + assert (Heq1: h (class_of x) = h (class_of y)). + { apply Huniqx. intro z. unfold class_of. firstorder. } + assert (Heq2:rew Heq1 in Hisclass x = Hisclass y). + { apply PI. } + unfold f'. + rewrite <- Heq2. + rewrite <- Heq1. + reflexivity. +Qed. + +Theorem setoid_functional_choice_second_characterization : + FunctionalChoice /\ ExtensionalPredicateRepresentative /\ ProofIrrelevance <-> SetoidFunctionalChoice. +Proof. + split. + - intros (FunChoice & ExtPredRepr & PI). + apply functional_rel_reification_and_repr_fun_choice_imp_setoid_fun_choice. + + intros A B. now apply fun_choice_imp_functional_rel_reification. + + now apply fun_choice_and_ext_pred_ext_and_proof_irrel_imp_setoid_fun_choice. + - intro SetoidFunChoice. repeat split. + + now intros A B; apply setoid_fun_choice_imp_fun_choice. + + apply repr_fun_choice_imp_ext_pred_repr. + now apply setoid_fun_choice_imp_repr_fun_choice. + + red. apply proof_irrelevance_cci. + apply repr_fun_choice_imp_excluded_middle. + now apply setoid_fun_choice_imp_repr_fun_choice. +Qed. + +(**********************************************************************) +(** * Compatibility notations *) +Notation description_rel_choice_imp_funct_choice := + functional_rel_reification_and_rel_choice_imp_fun_choice (only parsing). + +Notation funct_choice_imp_rel_choice := fun_choice_imp_rel_choice (only parsing). + +Notation FunChoice_Equiv_RelChoice_and_ParamDefinDescr := + fun_choice_iff_rel_choice_and_functional_rel_reification (only parsing). + +Notation funct_choice_imp_description := fun_choice_imp_functional_rel_reification (only parsing). diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v index 14d83501..72f53a46 100644 --- a/theories/Logic/Classical.v +++ b/theories/Logic/Classical.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* A = True. Lemma provable_prop_ext : prop_extensionality -> provable_prop_extensionality. Proof. - intros Ext A Ha; apply Ext; split; trivial. + exact PropExt_imp_ProvPropExt. Qed. (************************************************************************) @@ -516,7 +523,7 @@ End Weak_proof_irrelevance_CCI. (** ** Weak excluded-middle *) (** The weak classical logic based on [~~A \/ ~A] is referred to with - name KC in {[ChagrovZakharyaschev97]] + name KC in [[ChagrovZakharyaschev97]] [[ChagrovZakharyaschev97]] Alexander Chagrov and Michael Zakharyaschev, "Modal Logic", Clarendon Press, 1997. @@ -661,6 +668,8 @@ Proof. exists x0; exact Hnot. Qed. +(** * Axioms equivalent to classical logic *) + (** ** Principle of unrestricted minimization *) Require Import Coq.Arith.PeanoNat. @@ -736,3 +745,56 @@ Section Example_of_undecidable_predicate_with_the_minimization_property. Qed. End Example_of_undecidable_predicate_with_the_minimization_property. + +(** ** Choice of representatives in a partition of bool *) + +(** This is similar to Bell's "weak extensional selection principle" in [[Bell]] + + [[Bell]] John L. Bell, Choice principles in intuitionistic set theory, unpublished. +*) + +Require Import RelationClasses. + +Local Notation representative_boolean_partition := + (forall R:bool->bool->Prop, + Equivalence R -> exists f, forall x, R x (f x) /\ forall y, R x y -> f x = f y). + +Theorem representative_boolean_partition_imp_excluded_middle : + representative_boolean_partition -> excluded_middle. +Proof. + intros ReprFunChoice P. + pose (R (b1 b2 : bool) := b1 = b2 \/ P). + assert (Equivalence R). + { split. + - now left. + - destruct 1. now left. now right. + - destruct 1, 1; try now right. left; now transitivity y. } + destruct (ReprFunChoice R H) as (f,Hf). clear H. + destruct (Bool.bool_dec (f true) (f false)) as [Heq|Hneq]. + + left. + destruct (Hf false) as ([Hfalse|HP],_); try easy. + destruct (Hf true) as ([Htrue|HP],_); try easy. + congruence. + + right. intro HP. + destruct (Hf true) as (_,H). apply Hneq, H. now right. +Qed. + +Theorem excluded_middle_imp_representative_boolean_partition : + excluded_middle -> representative_boolean_partition. +Proof. + intros EM R H. + destruct (EM (R true false)). + - exists (fun _ => true). + intros []; firstorder. + - exists (fun b => b). + intro b. split. + + reflexivity. + + destruct b, y; intros HR; easy || now symmetry in HR. +Qed. + +Theorem excluded_middle_iff_representative_boolean_partition : + excluded_middle <-> representative_boolean_partition. +Proof. + split; auto using excluded_middle_imp_representative_boolean_partition, + representative_boolean_partition_imp_excluded_middle. +Qed. diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v index 57f367e5..841bd1be 100644 --- a/theories/Logic/ClassicalUniqueChoice.v +++ b/theories/Logic/ClassicalUniqueChoice.v @@ -1,10 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (elim (classic X1);intro;[left;trivial|right]) +Ltac classical_right := match goal with +|- ?X \/ _ => (elim (classic X);intro;[left;trivial|right]) end. Ltac classical_left := match goal with -| _:_ |- _ \/?X1 => (elim (classic X1);intro;[right;trivial|left]) +|- _ \/ ?X => (elim (classic X);intro;[right;trivial|left]) end. Require Export EqdepFacts. diff --git a/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v index a304dd24..6e3da423 100644 --- a/theories/Logic/ConstructiveEpsilon.v +++ b/theories/Logic/ConstructiveEpsilon.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* AC_ext, - Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004. + [[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent + to AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004. *) +Require ClassicalFacts ChoiceFacts. (**********************************************************************) (** * Pred. Ext. + Rel. Axiom of Choice -> Excluded-Middle *) @@ -54,7 +57,7 @@ Definition PredicateExtensionality := (** From predicate extensionality we get propositional extensionality hence proof-irrelevance *) -Require Import ClassicalFacts. +Import ClassicalFacts. Variable pred_extensionality : PredicateExtensionality. @@ -76,7 +79,7 @@ Qed. (** From proof-irrelevance and relational choice, we get guarded relational choice *) -Require Import ChoiceFacts. +Import ChoiceFacts. Variable rel_choice : RelationalChoice. @@ -89,7 +92,7 @@ Qed. (** The form of choice we need: there is a functional relation which chooses an element in any non empty subset of bool *) -Require Import Bool. +Import Bool. Lemma AC_bool_subset_to_bool : exists R : (bool -> Prop) -> bool -> Prop, @@ -161,6 +164,8 @@ End PredExt_RelChoice_imp_EM. Section ProofIrrel_RelChoice_imp_EqEM. +Import ChoiceFacts. + Variable rel_choice : RelationalChoice. Variable proof_irrelevance : forall P:Prop , forall x y:P, x=y. @@ -263,7 +268,7 @@ End ProofIrrel_RelChoice_imp_EqEM. (**********************************************************************) (** * Extensional Hilbert's epsilon description operator -> Excluded-Middle *) -(** Proof sketch from Bell [Bell93] (with thanks to P. Castéran) *) +(** Proof sketch from Bell [[Bell93]] (with thanks to P. Castéran) *) Local Notation inhabited A := A (only parsing). diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v index ffbb5758..d8c527c6 100644 --- a/theories/Logic/Epsilon.v +++ b/theories/Logic/Epsilon.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Type) (p q:U) (x:P p) (y:P q), diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index b7b4dec2..0560d9ed 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* B), + (forall x, f x = repr f x) /\ + (forall g, (forall x, f x = g x) -> repr f = repr g). diff --git a/theories/Logic/ExtensionalityFacts.v b/theories/Logic/ExtensionalityFacts.v index 0e34e7e9..02c8998a 100644 --- a/theories/Logic/ExtensionalityFacts.v +++ b/theories/Logic/ExtensionalityFacts.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* eq_refl] *) +Definition functional_extensionality_dep_good + {A} {B : A -> Type} + (f g : forall x : A, B x) + (H : forall x, f x = g x) + : f = g + := eq_trans (eq_sym (functional_extensionality_dep f f (fun _ => eq_refl))) + (functional_extensionality_dep f g H). + +Lemma functional_extensionality_dep_good_refl {A B} f + : @functional_extensionality_dep_good A B f f (fun _ => eq_refl) = eq_refl. +Proof. + unfold functional_extensionality_dep_good; edestruct functional_extensionality_dep; reflexivity. +Defined. + +Opaque functional_extensionality_dep_good. + +Lemma forall_sig_eq_rect + {A B} (f : forall a : A, B a) + (P : { g : _ | (forall a, f a = g a) } -> Type) + (k : P (exist (fun g => forall a, f a = g a) f (fun a => eq_refl))) + g +: P g. +Proof. + destruct g as [g1 g2]. + set (g' := fun x => (exist _ (g1 x) (g2 x))). + change g2 with (fun x => proj2_sig (g' x)). + change g1 with (fun x => proj1_sig (g' x)). + clearbody g'; clear g1 g2. + cut (forall x, (exist _ (f x) eq_refl) = g' x). + { intro H'. + apply functional_extensionality_dep_good in H'. + destruct H'. + exact k. } + { intro x. + destruct (g' x) as [g'x1 g'x2]. + destruct g'x2. + reflexivity. } +Defined. + +Definition forall_eq_rect + {A B} (f : forall a : A, B a) + (P : forall g, (forall a, f a = g a) -> Type) + (k : P f (fun a => eq_refl)) + g H + : P g H + := @forall_sig_eq_rect A B f (fun g => P (proj1_sig g) (proj2_sig g)) k (exist _ g H). + +Definition forall_eq_rect_comp {A B} f P k + : @forall_eq_rect A B f P k f (fun _ => eq_refl) = k. +Proof. + unfold forall_eq_rect, forall_sig_eq_rect; simpl. + rewrite functional_extensionality_dep_good_refl; reflexivity. +Qed. + +Definition f_equal__functional_extensionality_dep_good + {A B f g} H a + : f_equal (fun h => h a) (@functional_extensionality_dep_good A B f g H) = H a. +Proof. + apply forall_eq_rect with (H := H); clear H g. + change (eq_refl (f a)) with (f_equal (fun h => h a) (eq_refl f)). + apply f_equal, functional_extensionality_dep_good_refl. +Defined. + +Definition f_equal__functional_extensionality_dep_good__fun + {A B f g} H + : (fun a => f_equal (fun h => h a) (@functional_extensionality_dep_good A B f g H)) = H. +Proof. + apply functional_extensionality_dep_good; intro a; apply f_equal__functional_extensionality_dep_good. +Defined. + (** Apply [functional_extensionality], introducing variable x. *) Tactic Notation "extensionality" ident(x) := @@ -68,13 +142,93 @@ Tactic Notation "extensionality" ident(x) := apply forall_extensionality) ; intro x end. -(** Eta expansion follows from extensionality. *) +(** Iteratively apply [functional_extensionality] on an hypothesis + until finding an equality statement *) +(* Note that you can write [Ltac extensionality_in_checker tac ::= tac tt.] to get a more informative error message. *) +Ltac extensionality_in_checker tac := + first [ tac tt | fail 1 "Anomaly: Unexpected error in extensionality tactic. Please report." ]. +Tactic Notation "extensionality" "in" hyp(H) := + let rec check_is_extensional_equality H := + lazymatch type of H with + | _ = _ => constr:(Prop) + | forall a : ?A, ?T + => let Ha := fresh in + constr:(forall a : A, match H a with Ha => ltac:(let v := check_is_extensional_equality Ha in exact v) end) + end in + let assert_is_extensional_equality H := + first [ let dummy := check_is_extensional_equality H in idtac + | fail 1 "Not an extensional equality" ] in + let assert_not_intensional_equality H := + lazymatch type of H with + | _ = _ => fail "Already an intensional equality" + | _ => idtac + end in + let enforce_no_body H := + (tryif (let dummy := (eval unfold H in H) in idtac) + then clearbody H + else idtac) in + let rec extensionality_step_make_type H := + lazymatch type of H with + | forall a : ?A, ?f = ?g + => constr:({ H' | (fun a => f_equal (fun h => h a) H') = H }) + | forall a : ?A, _ + => let H' := fresh in + constr:(forall a : A, match H a with H' => ltac:(let ret := extensionality_step_make_type H' in exact ret) end) + end in + let rec eta_contract T := + lazymatch (eval cbv beta in T) with + | context T'[fun a : ?A => ?f a] + => let T'' := context T'[f] in + eta_contract T'' + | ?T => T + end in + let rec lift_sig_extensionality H := + lazymatch type of H with + | sig _ => H + | forall a : ?A, _ + => let Ha := fresh in + let ret := constr:(fun a : A => match H a with Ha => ltac:(let v := lift_sig_extensionality Ha in exact v) end) in + lazymatch type of ret with + | forall a : ?A, sig (fun b : ?B => @?f a b = @?g a b) + => eta_contract (exist (fun b : (forall a : A, B) => (fun a : A => f a (b a)) = (fun a : A => g a (b a))) + (fun a : A => proj1_sig (ret a)) + (@functional_extensionality_dep_good _ _ _ _ (fun a : A => proj2_sig (ret a)))) + end + end in + let extensionality_pre_step H H_out Heq := + let T := extensionality_step_make_type H in + let H' := fresh in + assert (H' : T) by (intros; eexists; apply f_equal__functional_extensionality_dep_good__fun); + let H''b := lift_sig_extensionality H' in + case H''b; clear H'; + intros H_out Heq in + let rec extensionality_rec H H_out Heq := + lazymatch type of H with + | forall a, _ = _ + => extensionality_pre_step H H_out Heq + | _ + => let pre_H_out' := fresh H_out in + let H_out' := fresh pre_H_out' in + extensionality_pre_step H H_out' Heq; + let Heq' := fresh Heq in + extensionality_rec H_out' H_out Heq'; + subst H_out' + end in + first [ assert_is_extensional_equality H | fail 1 "Not an extensional equality" ]; + first [ assert_not_intensional_equality H | fail 1 "Already an intensional equality" ]; + (tryif enforce_no_body H then idtac else clearbody H); + let H_out := fresh in + let Heq := fresh "Heq" in + extensionality_in_checker ltac:(fun tt => extensionality_rec H H_out Heq); + (* If we [subst H], things break if we already have another equation of the form [_ = H] *) + destruct Heq; rename H_out into H. + +(** Eta expansion is built into Coq. *) Lemma eta_expansion_dep {A} {B : A -> Type} (f : forall x : A, B x) : f = fun x => f x. Proof. intros. - extensionality x. reflexivity. Qed. diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index 841f843c..6c4a8533 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop. -Hypothesis unit : forall A:Prop, A -> M A. -Hypothesis join : forall A:Prop, M (M A) -> M A. Hypothesis incr : forall A B:Prop, (A->B) -> M A -> M B. Lemma strength: forall A (P:A->Prop), M(forall x:A,P x) -> forall x:A,M(P x). Proof. - eauto. + intros A P h x. + eapply incr in h; eauto. Qed. (** ** The universe of modal propositions *) @@ -470,7 +471,7 @@ Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). Theorem paradox : forall B:NProp, El B. Proof. intros B. - unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))). + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))). + exact (fun P => ~~P). + exact bool. + exact p2b. @@ -480,8 +481,6 @@ Proof. + cbn. auto. + cbn. auto. + cbn. auto. - + auto. - + auto. Qed. End Paradox. @@ -516,7 +515,7 @@ Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). Theorem mparadox : forall B:NProp, El B. Proof. intros B. - unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))). + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _))). + exact (fun P => P). + exact bool. + exact p2b. @@ -526,8 +525,6 @@ Proof. + cbn. auto. + cbn. auto. + cbn. auto. - + auto. - + auto. Qed. End MParadox. @@ -562,7 +559,7 @@ End Paradox. End NoRetractFromSmallPropositionToProp. -(** * Large universes are no retracts of [Prop]. *) +(** * Large universes are not retracts of [Prop]. *) (** The existence in the Calculus of Constructions with universes of a retract from some [Type] universe into [Prop] is inconsistent. *) diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v index 21be5032..86e81529 100644 --- a/theories/Logic/IndefiniteDescription.v +++ b/theories/Logic/IndefiniteDescription.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop) p q (x:P p) (y:P q), + forall U (P:U->Type) p q (x:P p) (y:P q), p = q -> JMeq x y -> eq_dep U P p x q y. Proof. intros. diff --git a/theories/Logic/ProofIrrelevance.v b/theories/Logic/ProofIrrelevance.v index 305839cd..134bf649 100644 --- a/theories/Logic/ProofIrrelevance.v +++ b/theories/Logic/ProofIrrelevance.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Q) -> P = Q. + +Require Import ClassicalFacts. + +Theorem proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2. +Proof. + apply ext_prop_dep_proof_irrel_cic. + exact propositional_extensionality. +Qed. + diff --git a/theories/Logic/PropExtensionalityFacts.v b/theories/Logic/PropExtensionalityFacts.v new file mode 100644 index 00000000..2b303517 --- /dev/null +++ b/theories/Logic/PropExtensionalityFacts.v @@ -0,0 +1,111 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* Proposition extensionality + Propositional functional extensionality + +2.2 Propositional extensionality -> Provable propositional extensionality + +2.3 Propositional extensionality -> Refutable propositional extensionality + +*) + +Set Implicit Arguments. + +(**********************************************************************) +(** * Definitions *) + +(** Propositional extensionality *) + +Local Notation PropositionalExtensionality := + (forall A B : Prop, (A <-> B) -> A = B). + +(** Provable-proposition extensionality *) + +Local Notation ProvablePropositionExtensionality := + (forall A:Prop, A -> A = True). + +(** Refutable-proposition extensionality *) + +Local Notation RefutablePropositionExtensionality := + (forall A:Prop, ~A -> A = False). + +(** Predicate extensionality *) + +Local Notation PredicateExtensionality := + (forall (A:Type) (P Q : A -> Prop), (forall x, P x <-> Q x) -> P = Q). + +(** Propositional functional extensionality *) + +Local Notation PropositionalFunctionalExtensionality := + (forall (A:Type) (P Q : A -> Prop), (forall x, P x = Q x) -> P = Q). + +(**********************************************************************) +(** * Propositional and predicate extensionality *) + +(**********************************************************************) +(** ** Predicate extensionality <-> Propositional extensionality + Propositional functional extensionality *) + +Lemma PredExt_imp_PropExt : PredicateExtensionality -> PropositionalExtensionality. +Proof. + intros Ext A B Equiv. + change A with ((fun _ => A) I). + now rewrite Ext with (P := fun _ : True =>A) (Q := fun _ => B). +Qed. + +Lemma PredExt_imp_PropFunExt : PredicateExtensionality -> PropositionalFunctionalExtensionality. +Proof. + intros Ext A P Q Eq. apply Ext. intros x. now rewrite (Eq x). +Qed. + +Lemma PropExt_and_PropFunExt_imp_PredExt : + PropositionalExtensionality -> PropositionalFunctionalExtensionality -> PredicateExtensionality. +Proof. + intros Ext FunExt A P Q Equiv. + apply FunExt. intros x. now apply Ext. +Qed. + +Theorem PropExt_and_PropFunExt_iff_PredExt : + PropositionalExtensionality /\ PropositionalFunctionalExtensionality <-> PredicateExtensionality. +Proof. + firstorder using PredExt_imp_PropExt, PredExt_imp_PropFunExt, PropExt_and_PropFunExt_imp_PredExt. +Qed. + +(**********************************************************************) +(** ** Propositional extensionality and provable proposition extensionality *) + +Lemma PropExt_imp_ProvPropExt : PropositionalExtensionality -> ProvablePropositionExtensionality. +Proof. + intros Ext A Ha; apply Ext; split; trivial. +Qed. + +(**********************************************************************) +(** ** Propositional extensionality and refutable proposition extensionality *) + +Lemma PropExt_imp_RefutPropExt : PropositionalExtensionality -> RefutablePropositionExtensionality. +Proof. + intros Ext A Ha; apply Ext; split; easy. +Qed. diff --git a/theories/Logic/PropFacts.v b/theories/Logic/PropFacts.v index 309539e5..06787035 100644 --- a/theories/Logic/PropFacts.v +++ b/theories/Logic/PropFacts.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* A -> Prop, + forall T : A -> B -> Prop, + Equivalence R -> + (forall x x' y, R x x' -> T x y -> T x' y) -> + (forall x, exists y, T x y) -> + exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x'). +Proof. + apply setoid_functional_choice_first_characterization. split; [|split]. + - exact choice. + - exact extensional_function_representative. + - exact classic. +Qed. + +Theorem representative_choice : + forall A (R:A->A->Prop), (Equivalence R) -> + exists f : A->A, forall x : A, R x (f x) /\ forall x', R x x' -> f x = f x'. +Proof. + apply setoid_fun_choice_imp_repr_fun_choice. + exact setoid_choice. +Qed. diff --git a/theories/Logic/WKL.v b/theories/Logic/WKL.v index 95f3e83f..579800b8 100644 --- a/theories/Logic/WKL.v +++ b/theories/Logic/WKL.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* A) (x:A) : A := | pos p => Pos.iter f x p end. -End N. \ No newline at end of file +(** Conversion with a decimal representation for printing/parsing *) + +Definition of_uint (d:Decimal.uint) := Pos.of_uint d. + +Definition of_int (d:Decimal.int) := + match Decimal.norm d with + | Decimal.Pos d => Some (Pos.of_uint d) + | Decimal.Neg _ => None + end. + +Definition to_uint n := + match n with + | 0 => Decimal.zero + | pos p => Pos.to_uint p + end. + +Definition to_int n := Decimal.Pos (to_uint n). + +End N. diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v index 12d3ad2f..f3007970 100644 --- a/theories/NArith/NArith.v +++ b/theories/NArith/NArith.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* p = p'. Proof. now apply Pos.eqb_eq. Qed. @@ -274,7 +276,7 @@ Qed. (* Old results about [N.min] *) -Notation Nmin_choice := N.min_dec (compat "8.3"). +Notation Nmin_choice := N.min_dec (only parsing). Lemma Nmin_le_1 a b : Nleb (N.min a b) a = true. Proof. rewrite Nleb_Nle. apply N.le_min_l. Qed. diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v index a1e51c9d..3ccaa721 100644 --- a/theories/NArith/Ndigits.v +++ b/theories/NArith/Ndigits.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* N.sqrt_spec n (N.le_0_l n)) (compat "8.3"). -Notation Nsqrtrem_sqrt := N.sqrtrem_sqrt (compat "8.3"). +Notation Nsqrtrem := N.sqrtrem (compat "8.6"). +Notation Nsqrt := N.sqrt (compat "8.6"). +Notation Nsqrtrem_spec := N.sqrtrem_spec (compat "8.6"). +Notation Nsqrt_spec := (fun n => N.sqrt_spec n (N.le_0_l n)) (only parsing). +Notation Nsqrtrem_sqrt := N.sqrtrem_sqrt (compat "8.6"). diff --git a/theories/NArith/vo.itarget b/theories/NArith/vo.itarget deleted file mode 100644 index e76033f7..00000000 --- a/theories/NArith/vo.itarget +++ /dev/null @@ -1,10 +0,0 @@ -BinNatDef.vo -BinNat.vo -NArith.vo -Ndec.vo -Ndigits.vo -Ndist.vo -Nnat.vo -Ndiv_def.vo -Nsqrt_def.vo -Ngcd_def.vo \ No newline at end of file diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v deleted file mode 100644 index bd893087..00000000 --- a/theories/Numbers/BigNumPrelude.v +++ /dev/null @@ -1,411 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* n<>0. -Proof. - auto with zarith. -Qed. - -Definition Zdiv_mult_cancel_r a b c H := Zdiv.Zdiv_mult_cancel_r a b c (Zlt0_not_eq _ H). -Definition Zdiv_mult_cancel_l a b c H := Zdiv.Zdiv_mult_cancel_r a b c (Zlt0_not_eq _ H). -Definition Z_div_plus_l a b c H := Zdiv.Z_div_plus_full_l a b c (Zlt0_not_eq _ H). - -(* Automation *) - -Hint Extern 2 (Z.le _ _) => - (match goal with - |- Zpos _ <= Zpos _ => exact (eq_refl _) -| H: _ <= ?p |- _ <= ?p => apply Z.le_trans with (2 := H) -| H: _ < ?p |- _ <= ?p => apply Z.lt_le_incl; apply Z.le_lt_trans with (2 := H) - end). - -Hint Extern 2 (Z.lt _ _) => - (match goal with - |- Zpos _ < Zpos _ => exact (eq_refl _) -| H: _ <= ?p |- _ <= ?p => apply Z.lt_le_trans with (2 := H) -| H: _ < ?p |- _ <= ?p => apply Z.le_lt_trans with (2 := H) - end). - - -Hint Resolve Z.lt_gt Z.le_ge Z_div_pos: zarith. - -(************************************** - Properties of order and product - **************************************) - - Theorem beta_lex: forall a b c d beta, - a * beta + b <= c * beta + d -> - 0 <= b < beta -> 0 <= d < beta -> - a <= c. - Proof. - intros a b c d beta H1 (H3, H4) (H5, H6). - assert (a - c < 1); auto with zarith. - apply Z.mul_lt_mono_pos_r with beta; auto with zarith. - apply Z.le_lt_trans with (d - b); auto with zarith. - rewrite Z.mul_sub_distr_r; auto with zarith. - Qed. - - Theorem beta_lex_inv: forall a b c d beta, - a < c -> 0 <= b < beta -> - 0 <= d < beta -> - a * beta + b < c * beta + d. - Proof. - intros a b c d beta H1 (H3, H4) (H5, H6). - case (Z.le_gt_cases (c * beta + d) (a * beta + b)); auto with zarith. - intros H7. contradict H1. apply Z.le_ngt. apply beta_lex with (1 := H7); auto. - Qed. - - Lemma beta_mult : forall h l beta, - 0 <= h < beta -> 0 <= l < beta -> 0 <= h*beta+l < beta^2. - Proof. - intros h l beta H1 H2;split. auto with zarith. - rewrite <- (Z.add_0_r (beta^2)); rewrite Z.pow_2_r; - apply beta_lex_inv;auto with zarith. - Qed. - - Lemma Zmult_lt_b : - forall b x y, 0 <= x < b -> 0 <= y < b -> 0 <= x * y <= b^2 - 2*b + 1. - Proof. - intros b x y (Hx1,Hx2) (Hy1,Hy2);split;auto with zarith. - apply Z.le_trans with ((b-1)*(b-1)). - apply Z.mul_le_mono_nonneg;auto with zarith. - apply Z.eq_le_incl; ring. - Qed. - - Lemma sum_mul_carry : forall xh xl yh yl wc cc beta, - 1 < beta -> - 0 <= wc < beta -> - 0 <= xh < beta -> - 0 <= xl < beta -> - 0 <= yh < beta -> - 0 <= yl < beta -> - 0 <= cc < beta^2 -> - wc*beta^2 + cc = xh*yl + xl*yh -> - 0 <= wc <= 1. - Proof. - intros xh xl yh yl wc cc beta U H1 H2 H3 H4 H5 H6 H7. - assert (H8 := Zmult_lt_b beta xh yl H2 H5). - assert (H9 := Zmult_lt_b beta xl yh H3 H4). - split;auto with zarith. - apply beta_lex with (cc) (beta^2 - 2) (beta^2); auto with zarith. - Qed. - - Theorem mult_add_ineq: forall x y cross beta, - 0 <= x < beta -> - 0 <= y < beta -> - 0 <= cross < beta -> - 0 <= x * y + cross < beta^2. - Proof. - intros x y cross beta HH HH1 HH2. - split; auto with zarith. - apply Z.le_lt_trans with ((beta-1)*(beta-1)+(beta-1)); auto with zarith. - apply Z.add_le_mono; auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - rewrite ?Z.mul_sub_distr_l, ?Z.mul_sub_distr_r, Z.pow_2_r; auto with zarith. - Qed. - - Theorem mult_add_ineq2: forall x y c cross beta, - 0 <= x < beta -> - 0 <= y < beta -> - 0 <= c*beta + cross <= 2*beta - 2 -> - 0 <= x * y + (c*beta + cross) < beta^2. - Proof. - intros x y c cross beta HH HH1 HH2. - split; auto with zarith. - apply Z.le_lt_trans with ((beta-1)*(beta-1)+(2*beta-2));auto with zarith. - apply Z.add_le_mono; auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - rewrite ?Z.mul_sub_distr_l, ?Z.mul_sub_distr_r, Z.pow_2_r; auto with zarith. - Qed. - -Theorem mult_add_ineq3: forall x y c cross beta, - 0 <= x < beta -> - 0 <= y < beta -> - 0 <= cross <= beta - 2 -> - 0 <= c <= 1 -> - 0 <= x * y + (c*beta + cross) < beta^2. - Proof. - intros x y c cross beta HH HH1 HH2 HH3. - apply mult_add_ineq2;auto with zarith. - split;auto with zarith. - apply Z.le_trans with (1*beta+cross);auto with zarith. - Qed. - -Hint Rewrite Z.mul_1_r Z.mul_0_r Z.mul_1_l Z.mul_0_l Z.add_0_l Z.add_0_r Z.sub_0_r: rm10. - - -(************************************** - Properties of Z.div and Z.modulo -**************************************) - -Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. - Proof. - intros a b H H1;case (Z_mod_lt a b);auto with zarith;intros H2 H3;split;auto. - case (Z.le_gt_cases b a); intros H4; auto with zarith. - rewrite Zmod_small; auto with zarith. - Qed. - - - Theorem Zmod_distr: forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> - (2 ^a * r + t) mod (2 ^ b) = (2 ^a * r) mod (2 ^ b) + t. - Proof. - intros a b r t (H1, H2) H3 (H4, H5). - assert (t < 2 ^ b). - apply Z.lt_le_trans with (1:= H5); auto with zarith. - apply Zpower_le_monotone; auto with zarith. - rewrite Zplus_mod; auto with zarith. - rewrite Zmod_small with (a := t); auto with zarith. - apply Zmod_small; auto with zarith. - split; auto with zarith. - assert (0 <= 2 ^a * r); auto with zarith. - apply Z.add_nonneg_nonneg; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - pattern (2 ^ b) at 2; replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); - try ring. - apply Z.add_le_lt_mono; auto with zarith. - replace b with ((b - a) + a); try ring. - rewrite Zpower_exp; auto with zarith. - pattern (2 ^a) at 4; rewrite <- (Z.mul_1_l (2 ^a)); - try rewrite <- Z.mul_sub_distr_r. - rewrite (Z.mul_comm (2 ^(b - a))); rewrite Zmult_mod_distr_l; - auto with zarith. - rewrite (Z.mul_comm (2 ^a)); apply Z.mul_le_mono_nonneg_r; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - Qed. - - Theorem Zmod_shift_r: - forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> - (r * 2 ^a + t) mod (2 ^ b) = (r * 2 ^a) mod (2 ^ b) + t. - Proof. - intros a b r t (H1, H2) H3 (H4, H5). - assert (t < 2 ^ b). - apply Z.lt_le_trans with (1:= H5); auto with zarith. - apply Zpower_le_monotone; auto with zarith. - rewrite Zplus_mod; auto with zarith. - rewrite Zmod_small with (a := t); auto with zarith. - apply Zmod_small; auto with zarith. - split; auto with zarith. - assert (0 <= 2 ^a * r); auto with zarith. - apply Z.add_nonneg_nonneg; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - pattern (2 ^ b) at 2;replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); try ring. - apply Z.add_le_lt_mono; auto with zarith. - replace b with ((b - a) + a); try ring. - rewrite Zpower_exp; auto with zarith. - pattern (2 ^a) at 4; rewrite <- (Z.mul_1_l (2 ^a)); - try rewrite <- Z.mul_sub_distr_r. - repeat rewrite (fun x => Z.mul_comm x (2 ^ a)); rewrite Zmult_mod_distr_l; - auto with zarith. - apply Z.mul_le_mono_nonneg_l; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - Qed. - - Theorem Zdiv_shift_r: - forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> - (r * 2 ^a + t) / (2 ^ b) = (r * 2 ^a) / (2 ^ b). - Proof. - intros a b r t (H1, H2) H3 (H4, H5). - assert (Eq: t < 2 ^ b); auto with zarith. - apply Z.lt_le_trans with (1 := H5); auto with zarith. - apply Zpower_le_monotone; auto with zarith. - pattern (r * 2 ^ a) at 1; rewrite Z_div_mod_eq with (b := 2 ^ b); - auto with zarith. - rewrite <- Z.add_assoc. - rewrite <- Zmod_shift_r; auto with zarith. - rewrite (Z.mul_comm (2 ^ b)); rewrite Z_div_plus_full_l; auto with zarith. - rewrite (fun x y => @Zdiv_small (x mod y)); auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - Qed. - - - Lemma shift_unshift_mod : forall n p a, - 0 <= a < 2^n -> - 0 <= p <= n -> - a * 2^p = a / 2^(n - p) * 2^n + (a*2^p) mod 2^n. - Proof. - intros n p a H1 H2. - pattern (a*2^p) at 1;replace (a*2^p) with - (a*2^p/2^n * 2^n + a*2^p mod 2^n). - 2:symmetry;rewrite (Z.mul_comm (a*2^p/2^n));apply Z_div_mod_eq. - replace (a * 2 ^ p / 2 ^ n) with (a / 2 ^ (n - p));trivial. - replace (2^n) with (2^(n-p)*2^p). - symmetry;apply Zdiv_mult_cancel_r. - destruct H1;trivial. - cut (0 < 2^p); auto with zarith. - rewrite <- Zpower_exp. - replace (n-p+p) with n;trivial. ring. - omega. omega. - apply Z.lt_gt. apply Z.pow_pos_nonneg;auto with zarith. - Qed. - - - Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> - ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = - a mod 2 ^ p. - Proof. - intros. - rewrite Zmod_small. - rewrite Zmod_eq by (auto with zarith). - unfold Z.sub at 1. - rewrite Z_div_plus_l by (auto with zarith). - assert (2^n = 2^(n-p)*2^p). - rewrite <- Zpower_exp by (auto with zarith). - replace (n-p+p) with n; auto with zarith. - rewrite H0. - rewrite <- Zdiv_Zdiv, Z_div_mult by (auto with zarith). - rewrite (Z.mul_comm (2^(n-p))), Z.mul_assoc. - rewrite <- Z.mul_opp_l. - rewrite Z_div_mult by (auto with zarith). - symmetry; apply Zmod_eq; auto with zarith. - - remember (a * 2 ^ (n - p)) as b. - destruct (Z_mod_lt b (2^n)); auto with zarith. - split. - apply Z_div_pos; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - apply Z.lt_le_trans with (2^n); auto with zarith. - rewrite <- (Z.mul_1_r (2^n)) at 1. - apply Z.mul_le_mono_nonneg; auto with zarith. - cut (0 < 2 ^ (n-p)); auto with zarith. - Qed. - - Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p. - Proof. - intros p x Hle;destruct (Z_le_gt_dec 0 p). - apply Zdiv_le_lower_bound;auto with zarith. - replace (2^p) with 0. - destruct x;compute;intro;discriminate. - destruct p;trivial;discriminate. - Qed. - - Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. - Proof. - intros p x y H;destruct (Z_le_gt_dec 0 p). - apply Zdiv_lt_upper_bound;auto with zarith. - apply Z.lt_le_trans with y;auto with zarith. - rewrite <- (Z.mul_1_r y);apply Z.mul_le_mono_nonneg;auto with zarith. - assert (0 < 2^p);auto with zarith. - replace (2^p) with 0. - destruct x;change (0 0 < Z.gcd a b -> 0 < b / Z.gcd a b. - Proof. - intros Hb Hg. - assert (H : 0 <= b / Z.gcd a b) by (apply Z.div_pos; auto with zarith). - Z.le_elim H; trivial. - rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b), <- H, Z.mul_0_r in Hb; - auto using Z.gcd_divide_r with zarith. - Qed. - - Theorem Zdiv_neg a b: - a < 0 -> 0 < b -> a / b < 0. - Proof. - intros Ha Hb. - assert (b > 0) by omega. - generalize (Z_mult_div_ge a _ H); intros. - assert (b * (a / b) < 0)%Z. - apply Z.le_lt_trans with a; auto with zarith. - destruct b; try (compute in Hb; discriminate). - destruct (a/Zpos p)%Z. - compute in H1; discriminate. - compute in H1; discriminate. - compute; auto. - Qed. - - Lemma Zdiv_gcd_zero : forall a b, b / Z.gcd a b = 0 -> b <> 0 -> - Z.gcd a b = 0. - Proof. - intros. - generalize (Zgcd_is_gcd a b); destruct 1. - destruct H2 as (k,Hk). - generalize H; rewrite Hk at 1. - destruct (Z.eq_dec (Z.gcd a b) 0) as [H'|H']; auto. - rewrite Z_div_mult_full; auto. - intros; subst k; simpl in *; subst b; elim H0; auto. - Qed. - - Lemma Zgcd_mult_rel_prime : forall a b c, - Z.gcd a c = 1 -> Z.gcd b c = 1 -> Z.gcd (a*b) c = 1. - Proof. - intros. - rewrite Zgcd_1_rel_prime in *. - apply rel_prime_sym; apply rel_prime_mult; apply rel_prime_sym; auto. - Qed. - - Lemma Zcompare_gt : forall (A:Type)(a a':A)(p q:Z), - match (p?=q)%Z with Gt => a | _ => a' end = - if Z_le_gt_dec p q then a' else a. - Proof. - intros. - destruct Z_le_gt_dec as [H|H]. - red in H. - destruct (p?=q)%Z; auto; elim H; auto. - rewrite H; auto. - Qed. - -Theorem Zbounded_induction : - (forall Q : Z -> Prop, forall b : Z, - Q 0 -> - (forall n, 0 <= n -> n < b - 1 -> Q n -> Q (n + 1)) -> - forall n, 0 <= n -> n < b -> Q n)%Z. -Proof. -intros Q b Q0 QS. -set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)). -assert (H : forall n, 0 <= n -> Q' n). -apply natlike_rec2; unfold Q'. -destruct (Z.le_gt_cases b 0) as [H | H]. now right. left; now split. -intros n H IH. destruct IH as [[IH1 IH2] | IH]. -destruct (Z.le_gt_cases (b - 1) n) as [H1 | H1]. -right; auto with zarith. -left. split; [auto with zarith | now apply (QS n)]. -right; auto with zarith. -unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3]. -assumption. now apply Z.le_ngt in H3. -Qed. - -Lemma Zsquare_le x : x <= x*x. -Proof. -destruct (Z.lt_ge_cases 0 x). -- rewrite <- Z.mul_1_l at 1. - rewrite <- Z.mul_le_mono_pos_r; auto with zarith. -- pose proof (Z.square_nonneg x); auto with zarith. -Qed. diff --git a/theories/Numbers/BinNums.v b/theories/Numbers/BinNums.v index e4f3cd6c..f8b3d9e1 100644 --- a/theories/Numbers/BinNums.v +++ b/theories/Numbers/BinNums.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* carry + | C1 : A -> carry. + + Definition interp_carry (sign:Z)(B:Z)(interp:A -> Z) c := + match c with + | C0 x => interp x + | C1 x => sign*B + interp x + end. + +End Carry. + +Section Zn2Z. + + Variable znz : Type. + + (** 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. + *) + + Inductive zn2z := + | W0 : zn2z + | WW : znz -> znz -> zn2z. + + Definition zn2z_to_Z (wB:Z) (w_to_Z:znz->Z) (x:zn2z) := + match x with + | W0 => 0 + | WW xh xl => w_to_Z xh * wB + w_to_Z xl + end. + +End Zn2Z. + +Arguments W0 {znz}. + +(** From a cyclic representation [w], we iterate the [zn2z] construct + [n] times, gaining the type of binary trees of depth at most [n], + whose leafs are either W0 (if depth < n) or elements of w + (if depth = n). +*) + +Fixpoint word (w:Type) (n:nat) : Type := + match n with + | O => w + | S n => zn2z (word w n) + end. diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index df9b8339..64935ffe 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -1,15 +1,18 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Prop, forall b : Z, + Q 0 -> + (forall n, 0 <= n -> n < b - 1 -> Q n -> Q (n + 1)) -> + forall n, 0 <= n -> n < b -> Q n)%Z. +Proof. +intros Q b Q0 QS. +set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)). +assert (H : forall n, 0 <= n -> Q' n). +apply natlike_rec2; unfold Q'. +destruct (Z.le_gt_cases b 0) as [H | H]. now right. left; now split. +intros n H IH. destruct IH as [[IH1 IH2] | IH]. +destruct (Z.le_gt_cases (b - 1) n) as [H1 | H1]. +right; auto with zarith. +left. split; [auto with zarith | now apply (QS n)]. +right; auto with zarith. +unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3]. +assumption. now apply Z.le_ngt in H3. +Qed. + Lemma B_holds : forall n : Z, 0 <= n < wB -> B n. Proof. intros n [H1 H2]. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v deleted file mode 100644 index 407bcca4..00000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v +++ /dev/null @@ -1,317 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* w -> zn2z w. - Variable w_W0 : w -> zn2z w. - Variable ww_1 : zn2z w. - Variable w_succ_c : w -> carry w. - Variable w_add_c : w -> w -> carry w. - Variable w_add_carry_c : w -> w -> carry w. - Variable w_succ : w -> w. - Variable w_add : w -> w -> w. - Variable w_add_carry : w -> w -> w. - - Definition ww_succ_c x := - match x with - | W0 => C0 ww_1 - | WW xh xl => - match w_succ_c xl with - | C0 l => C0 (WW xh l) - | C1 l => - match w_succ_c xh with - | C0 h => C0 (WW h w_0) - | C1 h => C1 W0 - end - end - end. - - Definition ww_succ x := - match x with - | W0 => ww_1 - | WW xh xl => - match w_succ_c xl with - | C0 l => WW xh l - | C1 l => w_W0 (w_succ xh) - end - end. - - Definition ww_add_c x y := - match x, y with - | W0, _ => C0 y - | _, W0 => C0 x - | WW xh xl, WW yh yl => - match w_add_c xl yl with - | C0 l => - match w_add_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (w_WW h l) - end - | C1 l => - match w_add_carry_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (w_WW h l) - end - end - end. - - Variable R : Type. - Variable f0 f1 : zn2z w -> R. - - Definition ww_add_c_cont x y := - match x, y with - | W0, _ => f0 y - | _, W0 => f0 x - | WW xh xl, WW yh yl => - match w_add_c xl yl with - | C0 l => - match w_add_c xh yh with - | C0 h => f0 (WW h l) - | C1 h => f1 (w_WW h l) - end - | C1 l => - match w_add_carry_c xh yh with - | C0 h => f0 (WW h l) - | C1 h => f1 (w_WW h l) - end - end - end. - - (* ww_add et ww_add_carry conserve la forme normale s'il n'y a pas - de debordement *) - Definition ww_add x y := - match x, y with - | W0, _ => y - | _, W0 => x - | WW xh xl, WW yh yl => - match w_add_c xl yl with - | C0 l => WW (w_add xh yh) l - | C1 l => WW (w_add_carry xh yh) l - end - end. - - Definition ww_add_carry_c x y := - match x, y with - | W0, W0 => C0 ww_1 - | W0, WW yh yl => ww_succ_c (WW yh yl) - | WW xh xl, W0 => ww_succ_c (WW xh xl) - | WW xh xl, WW yh yl => - match w_add_carry_c xl yl with - | C0 l => - match w_add_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (WW h l) - end - | C1 l => - match w_add_carry_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (w_WW h l) - end - end - end. - - Definition ww_add_carry x y := - match x, y with - | W0, W0 => ww_1 - | W0, WW yh yl => ww_succ (WW yh yl) - | WW xh xl, W0 => ww_succ (WW xh xl) - | WW xh xl, WW yh yl => - match w_add_carry_c xl yl with - | C0 l => WW (w_add xh yh) l - | C1 l => WW (w_add_carry xh yh) l - end - end. - - (*Section DoubleProof.*) - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - Variable spec_ww_1 : [[ww_1]] = 1. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. - Variable spec_w_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1. - Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add_carry_c : - forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. - Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB. - Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. - Variable spec_w_add_carry : - forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. - - Lemma spec_ww_succ_c : forall x, [+[ww_succ_c x]] = [[x]] + 1. - Proof. - destruct x as [ |xh xl];simpl. apply spec_ww_1. - generalize (spec_w_succ_c xl);destruct (w_succ_c xl) as [l|l]; - intro H;unfold interp_carry in H. simpl;rewrite H;ring. - rewrite <- Z.add_assoc;rewrite <- H;rewrite Z.mul_1_l. - assert ([|l|] = 0). generalize (spec_to_Z xl)(spec_to_Z l);omega. - rewrite H0;generalize (spec_w_succ_c xh);destruct (w_succ_c xh) as [h|h]; - intro H1;unfold interp_carry in H1. - simpl;rewrite H1;rewrite spec_w_0;ring. - unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB. - assert ([|xh|] = wB - 1). generalize (spec_to_Z xh)(spec_to_Z h);omega. - rewrite H2;ring. - Qed. - - Lemma spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. - Proof. - destruct x as [ |xh xl];trivial. - destruct y as [ |yh yl]. rewrite Z.add_0_r;trivial. - simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) - with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring. - generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; - intros H;unfold interp_carry in H;rewrite <- H. - generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *;rewrite <- H1. trivial. - repeat rewrite Z.mul_1_l;rewrite spec_w_WW;rewrite wwB_wBwB; ring. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) - as [h|h]; intros H1;unfold interp_carry in *;rewrite <- H1. - simpl;ring. - repeat rewrite Z.mul_1_l;rewrite wwB_wBwB;rewrite spec_w_WW;ring. - Qed. - - Section Cont. - Variable P : zn2z w -> zn2z w -> R -> Prop. - Variable x y : zn2z w. - Variable spec_f0 : forall r, [[r]] = [[x]] + [[y]] -> P x y (f0 r). - Variable spec_f1 : forall r, wwB + [[r]] = [[x]] + [[y]] -> P x y (f1 r). - - Lemma spec_ww_add_c_cont : P x y (ww_add_c_cont x y). - Proof. - destruct x as [ |xh xl];trivial. - apply spec_f0;trivial. - destruct y as [ |yh yl]. - apply spec_f0;rewrite Z.add_0_r;trivial. - simpl. - generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; - intros H;unfold interp_carry in H. - generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *. - apply spec_f0. simpl;rewrite H;rewrite H1;ring. - apply spec_f1. simpl;rewrite spec_w_WW;rewrite H. - rewrite Z.add_assoc;rewrite wwB_wBwB. rewrite Z.pow_2_r; rewrite <- Z.mul_add_distr_r. - rewrite Z.mul_1_l in H1;rewrite H1;ring. - generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) - as [h|h]; intros H1;unfold interp_carry in *. - apply spec_f0;simpl;rewrite H1. rewrite Z.mul_add_distr_r. - rewrite <- Z.add_assoc;rewrite H;ring. - apply spec_f1. rewrite spec_w_WW;rewrite wwB_wBwB. - rewrite Z.add_assoc; rewrite Z.pow_2_r; rewrite <- Z.mul_add_distr_r. - rewrite Z.mul_1_l in H1;rewrite H1. rewrite Z.mul_add_distr_r. - rewrite <- Z.add_assoc;rewrite H; simpl; ring. - Qed. - - End Cont. - - Lemma spec_ww_add_carry_c : - forall x y, [+[ww_add_carry_c x y]] = [[x]] + [[y]] + 1. - Proof. - destruct x as [ |xh xl];intro y. - exact (spec_ww_succ_c y). - destruct y as [ |yh yl]. - rewrite Z.add_0_r;exact (spec_ww_succ_c (WW xh xl)). - simpl; replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) - with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. - generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) - as [l|l];intros H;unfold interp_carry in H;rewrite <- H. - generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; - intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. - unfold interp_carry;repeat rewrite Z.mul_1_l;simpl;rewrite wwB_wBwB;ring. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) - as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. - unfold interp_carry;rewrite spec_w_WW; - repeat rewrite Z.mul_1_l;simpl;rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_succ : forall x, [[ww_succ x]] = ([[x]] + 1) mod wwB. - Proof. - destruct x as [ |xh xl];simpl. - rewrite spec_ww_1;rewrite Zmod_small;trivial. - split;[intro;discriminate|apply wwB_pos]. - rewrite <- Z.add_assoc;generalize (spec_w_succ_c xl); - destruct (w_succ_c xl) as[l|l];intro H;unfold interp_carry in H;rewrite <-H. - rewrite Zmod_small;trivial. - rewrite wwB_wBwB;apply beta_mult;apply spec_to_Z. - assert ([|l|] = 0). clear spec_ww_1 spec_w_1 spec_w_0. - assert (H1:= spec_to_Z l); assert (H2:= spec_to_Z xl); omega. - rewrite H0;rewrite Z.add_0_r;rewrite <- Z.mul_add_distr_r;rewrite wwB_wBwB. - rewrite Z.pow_2_r; rewrite Zmult_mod_distr_r;try apply lt_0_wB. - rewrite spec_w_W0;rewrite spec_w_succ;trivial. - Qed. - - Lemma spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. - Proof. - destruct x as [ |xh xl];intros y. - rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial. - destruct y as [ |yh yl]. - change [[W0]] with 0;rewrite Z.add_0_r. - rewrite Zmod_small;trivial. - exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)). - simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) - with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring. - generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; - unfold interp_carry;intros H;simpl;rewrite <- H. - rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial. - Qed. - - Lemma spec_ww_add_carry : - forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB. - Proof. - destruct x as [ |xh xl];intros y. - exact (spec_ww_succ y). - destruct y as [ |yh yl]. - change [[W0]] with 0;rewrite Z.add_0_r. exact (spec_ww_succ (WW xh xl)). - simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) - with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. - generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) - as [l|l];unfold interp_carry;intros H;rewrite <- H;simpl ww_to_Z. - rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial. - Qed. - -(* End DoubleProof. *) -End DoubleAdd. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v deleted file mode 100644 index e94a891d..00000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v +++ /dev/null @@ -1,437 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_digits : positive. - Variable w_zdigits: w. - Variable w_add: w -> w -> zn2z w. - Variable w_to_Z : w -> Z. - Variable w_compare : w -> w -> comparison. - - Definition ww_digits := xO w_digits. - - Definition ww_zdigits := w_add w_zdigits w_zdigits. - - Definition ww_to_Z := zn2z_to_Z (base w_digits) w_to_Z. - - Definition ww_1 := WW w_0 w_1. - - Definition ww_Bm1 := WW w_Bm1 w_Bm1. - - Definition ww_WW xh xl : zn2z (zn2z w) := - match xh, xl with - | W0, W0 => W0 - | _, _ => WW xh xl - end. - - Definition ww_W0 h : zn2z (zn2z w) := - match h with - | W0 => W0 - | _ => WW h W0 - end. - - Definition ww_0W l : zn2z (zn2z w) := - match l with - | W0 => W0 - | _ => WW W0 l - end. - - Definition double_WW (n:nat) := - match n return word w n -> word w n -> word w (S n) with - | O => w_WW - | S n => - fun (h l : zn2z (word w n)) => - match h, l with - | W0, W0 => W0 - | _, _ => WW h l - end - end. - - Definition double_wB n := base (w_digits << n). - - Fixpoint double_to_Z (n:nat) : word w n -> Z := - match n return word w n -> Z with - | O => w_to_Z - | S n => zn2z_to_Z (double_wB n) (double_to_Z n) - end. - - Fixpoint extend_aux (n:nat) (x:zn2z w) {struct n}: word w (S n) := - match n return word w (S n) with - | O => x - | S n1 => WW W0 (extend_aux n1 x) - end. - - Definition extend (n:nat) (x:w) : word w (S n) := - let r := w_0W x in - match r with - | W0 => W0 - | _ => extend_aux n r - end. - - Definition double_0 n : word w n := - match n return word w n with - | O => w_0 - | S _ => W0 - end. - - Definition double_split (n:nat) (x:zn2z (word w n)) := - match x with - | W0 => - match n return word w n * word w n with - | O => (w_0,w_0) - | S _ => (W0, W0) - end - | WW h l => (h,l) - end. - - Definition ww_compare x y := - match x, y with - | W0, W0 => Eq - | W0, WW yh yl => - match w_compare w_0 yh with - | Eq => w_compare w_0 yl - | _ => Lt - end - | WW xh xl, W0 => - match w_compare xh w_0 with - | Eq => w_compare xl w_0 - | _ => Gt - end - | WW xh xl, WW yh yl => - match w_compare xh yh with - | Eq => w_compare xl yl - | Lt => Lt - | Gt => Gt - end - end. - - - (* Return the low part of the composed word*) - Fixpoint get_low (n : nat) {struct n}: - word w n -> w := - match n return (word w n -> w) with - | 0%nat => fun x => x - | S n1 => - fun x => - match x with - | W0 => w_0 - | WW _ x1 => get_low n1 x1 - end - end. - - - Section DoubleProof. - Notation wB := (base w_digits). - Notation wwB := (base ww_digits). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[[ x ]]" := (ww_to_Z x) (at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB ww_to_Z c) (at level 0, c at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB ww_to_Z c) (at level 0, c at level 99). - Notation "[! n | x !]" := (double_to_Z n x) (at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_w_compare : forall x y, - w_compare x y = Z.compare [|x|] [|y|]. - - Lemma wwB_wBwB : wwB = wB^2. - Proof. - unfold base, ww_digits;rewrite Z.pow_2_r; rewrite (Pos2Z.inj_xO w_digits). - replace (2 * Zpos w_digits) with (Zpos w_digits + Zpos w_digits). - apply Zpower_exp; unfold Z.ge;simpl;intros;discriminate. - ring. - Qed. - - Lemma spec_ww_1 : [[ww_1]] = 1. - Proof. simpl;rewrite spec_w_0;rewrite spec_w_1;ring. Qed. - - Lemma spec_ww_Bm1 : [[ww_Bm1]] = wwB - 1. - Proof. simpl;rewrite spec_w_Bm1;rewrite wwB_wBwB;ring. Qed. - - Lemma lt_0_wB : 0 < wB. - Proof. - unfold base;apply Z.pow_pos_nonneg. unfold Z.lt;reflexivity. - unfold Z.le;intros H;discriminate H. - Qed. - - Lemma lt_0_wwB : 0 < wwB. - Proof. rewrite wwB_wBwB; rewrite Z.pow_2_r; apply Z.mul_pos_pos;apply lt_0_wB. Qed. - - Lemma wB_pos: 1 < wB. - Proof. - unfold base;apply Z.lt_le_trans with (2^1). unfold Z.lt;reflexivity. - apply Zpower_le_monotone. unfold Z.lt;reflexivity. - split;unfold Z.le;intros H. discriminate H. - clear spec_w_0W w_0W spec_w_Bm1 spec_to_Z spec_w_WW w_WW. - destruct w_digits; discriminate H. - Qed. - - Lemma wwB_pos: 1 < wwB. - Proof. - assert (H:= wB_pos);rewrite wwB_wBwB;rewrite <-(Z.mul_1_r 1). - rewrite Z.pow_2_r. - apply Zmult_lt_compat2;(split;[unfold Z.lt;reflexivity|trivial]). - apply Z.lt_le_incl;trivial. - Qed. - - Theorem wB_div_2: 2 * (wB / 2) = wB. - Proof. - clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W - spec_to_Z;unfold base. - assert (2 ^ Zpos w_digits = 2 * (2 ^ (Zpos w_digits - 1))). - pattern 2 at 2; rewrite <- Z.pow_1_r. - rewrite <- Zpower_exp; auto with zarith. - f_equal; auto with zarith. - case w_digits; compute; intros; discriminate. - rewrite H; f_equal; auto with zarith. - rewrite Z.mul_comm; apply Z_div_mult; auto with zarith. - Qed. - - Theorem wwB_div_2 : wwB / 2 = wB / 2 * wB. - Proof. - clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W - spec_to_Z. - rewrite wwB_wBwB; rewrite Z.pow_2_r. - pattern wB at 1; rewrite <- wB_div_2; auto. - rewrite <- Z.mul_assoc. - repeat (rewrite (Z.mul_comm 2); rewrite Z_div_mult); auto with zarith. - Qed. - - Lemma mod_wwB : forall z x, - (z*wB + [|x|]) mod wwB = (z mod wB)*wB + [|x|]. - Proof. - intros z x. - rewrite Zplus_mod. - pattern wwB at 1;rewrite wwB_wBwB; rewrite Z.pow_2_r. - rewrite Zmult_mod_distr_r;try apply lt_0_wB. - rewrite (Zmod_small [|x|]). - apply Zmod_small;rewrite wwB_wBwB;apply beta_mult;try apply spec_to_Z. - apply Z_mod_lt;apply Z.lt_gt;apply lt_0_wB. - destruct (spec_to_Z x);split;trivial. - change [|x|] with (0*wB+[|x|]). rewrite wwB_wBwB. - rewrite Z.pow_2_r;rewrite <- (Z.add_0_r (wB*wB));apply beta_lex_inv. - apply lt_0_wB. apply spec_to_Z. split;[apply Z.le_refl | apply lt_0_wB]. - Qed. - - Lemma wB_div : forall x y, ([|x|] * wB + [|y|]) / wB = [|x|]. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - intros x y;unfold base;rewrite Zdiv_shift_r;auto with zarith. - rewrite Z_div_mult;auto with zarith. - destruct (spec_to_Z x);trivial. - Qed. - - Lemma wB_div_plus : forall x y p, - 0 <= p -> - ([|x|]*wB + [|y|]) / 2^(Zpos w_digits + p) = [|x|] / 2^p. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - intros x y p Hp;rewrite Zpower_exp;auto with zarith. - rewrite <- Zdiv_Zdiv;auto with zarith. - rewrite wB_div;trivial. - Qed. - - Lemma lt_wB_wwB : wB < wwB. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - unfold base;apply Zpower_lt_monotone;auto with zarith. - assert (0 < Zpos w_digits). compute;reflexivity. - unfold ww_digits;rewrite Pos2Z.inj_xO;auto with zarith. - Qed. - - Lemma w_to_Z_wwB : forall x, x < wB -> x < wwB. - Proof. - intros x H;apply Z.lt_trans with wB;trivial;apply lt_wB_wwB. - Qed. - - Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - destruct x as [ |h l];simpl. - split;[apply Z.le_refl|apply lt_0_wwB]. - assert (H:=spec_to_Z h);assert (L:=spec_to_Z l);split. - apply Z.add_nonneg_nonneg;auto with zarith. - rewrite <- (Z.add_0_r wwB);rewrite wwB_wBwB; rewrite Z.pow_2_r; - apply beta_lex_inv;auto with zarith. - Qed. - - Lemma double_wB_wwB : forall n, double_wB n * double_wB n = double_wB (S n). - Proof. - intros n;unfold double_wB;simpl. - unfold base. rewrite (Pos2Z.inj_xO (_ << _)). - replace (2 * Zpos (w_digits << n)) with - (Zpos (w_digits << n) + Zpos (w_digits << n)) by ring. - symmetry; apply Zpower_exp;intro;discriminate. - Qed. - - Lemma double_wB_pos: - forall n, 0 <= double_wB n. - Proof. - intros n; unfold double_wB, base; auto with zarith. - Qed. - - Lemma double_wB_more_digits: - forall n, wB <= double_wB n. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - intros n; elim n; clear n; auto. - unfold double_wB, "<<"; auto with zarith. - intros n H1; rewrite <- double_wB_wwB. - apply Z.le_trans with (wB * 1). - rewrite Z.mul_1_r; apply Z.le_refl. - unfold base; auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - apply Z.le_trans with wB; auto with zarith. - unfold base. - rewrite <- (Z.pow_0_r 2). - apply Z.pow_le_mono_r; auto with zarith. - Qed. - - Lemma spec_double_to_Z : - forall n (x:word w n), 0 <= [!n | x!] < double_wB n. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - induction n;intros. exact (spec_to_Z x). - unfold double_to_Z;fold double_to_Z. - destruct x;unfold zn2z_to_Z. - unfold double_wB,base;split;auto with zarith. - assert (U0:= IHn w0);assert (U1:= IHn w1). - split;auto with zarith. - apply Z.lt_le_trans with ((double_wB n - 1) * double_wB n + double_wB n). - assert (double_to_Z n w0*double_wB n <= (double_wB n - 1)*double_wB n). - apply Z.mul_le_mono_nonneg_r;auto with zarith. - auto with zarith. - rewrite <- double_wB_wwB. - replace ((double_wB n - 1) * double_wB n + double_wB n) with (double_wB n * double_wB n); - [auto with zarith | ring]. - Qed. - - Lemma spec_get_low: - forall n x, - [!n | x!] < wB -> [|get_low n x|] = [!n | x!]. - Proof. - clear spec_w_1 spec_w_Bm1. - intros n; elim n; auto; clear n. - intros n Hrec x; case x; clear x; auto. - intros xx yy; simpl. - destruct (spec_double_to_Z n xx) as [F1 _]. Z.le_elim F1. - - (* 0 < [!n | xx!] *) - intros; exfalso. - assert (F3 := double_wB_more_digits n). - destruct (spec_double_to_Z n yy) as [F4 _]. - assert (F5: 1 * wB <= [!n | xx!] * double_wB n); - auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - unfold base; auto with zarith. - - (* 0 = [!n | xx!] *) - rewrite <- F1; rewrite Z.mul_0_l, Z.add_0_l. - intros; apply Hrec; auto. - Qed. - - Lemma spec_double_WW : forall n (h l : word w n), - [!S n|double_WW n h l!] = [!n|h!] * double_wB n + [!n|l!]. - Proof. - induction n;simpl;intros;trivial. - destruct h;auto. - destruct l;auto. - Qed. - - Lemma spec_extend_aux : forall n x, [!S n|extend_aux n x!] = [[x]]. - Proof. induction n;simpl;trivial. Qed. - - Lemma spec_extend : forall n x, [!S n|extend n x!] = [|x|]. - Proof. - intros n x;assert (H:= spec_w_0W x);unfold extend. - destruct (w_0W x);simpl;trivial. - rewrite <- H;exact (spec_extend_aux n (WW w0 w1)). - Qed. - - Lemma spec_double_0 : forall n, [!n|double_0 n!] = 0. - Proof. destruct n;trivial. Qed. - - Lemma spec_double_split : forall n x, - let (h,l) := double_split n x in - [!S n|x!] = [!n|h!] * double_wB n + [!n|l!]. - Proof. - destruct x;simpl;auto. - destruct n;simpl;trivial. - rewrite spec_w_0;trivial. - Qed. - - Lemma wB_lex_inv: forall a b c d, - a < c -> - a * wB + [|b|] < c * wB + [|d|]. - Proof. - intros a b c d H1; apply beta_lex_inv with (1 := H1); auto. - Qed. - - Ltac comp2ord := match goal with - | |- Lt = (?x ?= ?y) => symmetry; change (x < y) - | |- Gt = (?x ?= ?y) => symmetry; change (x > y); apply Z.lt_gt - end. - - Lemma spec_ww_compare : forall x y, - ww_compare x y = Z.compare [[x]] [[y]]. - Proof. - destruct x as [ |xh xl];destruct y as [ |yh yl];simpl;trivial. - (* 1st case *) - rewrite 2 spec_w_compare, spec_w_0. - destruct (Z.compare_spec 0 [|yh|]) as [H|H|H]. - rewrite <- H;simpl. reflexivity. - symmetry. change (0 < [|yh|]*wB+[|yl|]). - change 0 with (0*wB+0). rewrite <- spec_w_0 at 2. - apply wB_lex_inv;trivial. - absurd (0 <= [|yh|]). apply Z.lt_nge; trivial. - destruct (spec_to_Z yh);trivial. - (* 2nd case *) - rewrite 2 spec_w_compare, spec_w_0. - destruct (Z.compare_spec [|xh|] 0) as [H|H|H]. - rewrite H;simpl;reflexivity. - absurd (0 <= [|xh|]). apply Z.lt_nge; trivial. - destruct (spec_to_Z xh);trivial. - comp2ord. - change 0 with (0*wB+0). rewrite <- spec_w_0 at 2. - apply wB_lex_inv;trivial. - (* 3rd case *) - rewrite 2 spec_w_compare. - destruct (Z.compare_spec [|xh|] [|yh|]) as [H|H|H]. - rewrite H. - symmetry. apply Z.add_compare_mono_l. - comp2ord. apply wB_lex_inv;trivial. - comp2ord. apply wB_lex_inv;trivial. - Qed. - - - End DoubleProof. - -End DoubleBase. - diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v deleted file mode 100644 index 4ebe8fac..00000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v +++ /dev/null @@ -1,966 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* WW w_0 p | C1 p => WW w_1 p end. - - Let _ww_digits := xO w_digits. - - Let _ww_zdigits := w_add2 w_zdigits w_zdigits. - - Let to_Z := zn2z_to_Z wB w_to_Z. - - Let w_W0 := ZnZ.WO. - Let w_0W := ZnZ.OW. - Let w_WW := ZnZ.WW. - - Let ww_of_pos p := - match w_of_pos p with - | (N0, l) => (N0, WW w_0 l) - | (Npos ph,l) => - let (n,h) := w_of_pos ph in (n, w_WW h l) - end. - - Let head0 := - Eval lazy beta delta [ww_head0] in - ww_head0 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits. - - Let tail0 := - Eval lazy beta delta [ww_tail0] in - ww_tail0 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits. - - Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW t). - Let ww_0W := Eval lazy beta delta [ww_0W] in (@ww_0W t). - Let ww_W0 := Eval lazy beta delta [ww_W0] in (@ww_W0 t). - - (* ** Comparison ** *) - Let compare := - Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare. - - Let eq0 (x:zn2z t) := - match x with - | W0 => true - | _ => false - end. - - (* ** Opposites ** *) - Let opp_c := - Eval lazy beta delta [ww_opp_c] in ww_opp_c w_0 w_opp_c w_opp_carry. - - Let opp := - Eval lazy beta delta [ww_opp] in ww_opp w_0 w_opp_c w_opp_carry w_opp. - - Let opp_carry := - Eval lazy beta delta [ww_opp_carry] in ww_opp_carry w_WW ww_Bm1 w_opp_carry. - - (* ** Additions ** *) - - Let succ_c := - Eval lazy beta delta [ww_succ_c] in ww_succ_c w_0 ww_1 w_succ_c. - - Let add_c := - Eval lazy beta delta [ww_add_c] in ww_add_c w_WW w_add_c w_add_carry_c. - - Let add_carry_c := - Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in - ww_add_carry_c w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c. - - Let succ := - Eval lazy beta delta [ww_succ] in ww_succ w_W0 ww_1 w_succ_c w_succ. - - Let add := - Eval lazy beta delta [ww_add] in ww_add w_add_c w_add w_add_carry. - - Let add_carry := - Eval lazy beta iota delta [ww_add_carry ww_succ] in - ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry. - - (* ** Subtractions ** *) - - Let pred_c := - Eval lazy beta delta [ww_pred_c] in ww_pred_c w_Bm1 w_WW ww_Bm1 w_pred_c. - - Let sub_c := - Eval lazy beta iota delta [ww_sub_c ww_opp_c] in - ww_sub_c w_0 w_WW w_opp_c w_opp_carry w_sub_c w_sub_carry_c. - - Let sub_carry_c := - Eval lazy beta iota delta [ww_sub_carry_c ww_pred_c ww_opp_carry] in - ww_sub_carry_c w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_c w_sub_carry_c. - - Let pred := - Eval lazy beta delta [ww_pred] in ww_pred w_Bm1 w_WW ww_Bm1 w_pred_c w_pred. - - Let sub := - Eval lazy beta iota delta [ww_sub ww_opp] in - ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry. - - Let sub_carry := - Eval lazy beta iota delta [ww_sub_carry ww_pred ww_opp_carry] in - ww_sub_carry w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_carry_c w_pred - w_sub w_sub_carry. - - - (* ** Multiplication ** *) - - Let mul_c := - Eval lazy beta iota delta [ww_mul_c double_mul_c] in - ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry. - - Let karatsuba_c := - Eval lazy beta iota delta [ww_karatsuba_c double_mul_c kara_prod] in - ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c - add_c add add_carry sub_c sub. - - Let mul := - Eval lazy beta delta [ww_mul] in - ww_mul w_W0 w_add w_mul_c w_mul add. - - Let square_c := - Eval lazy beta delta [ww_square_c] in - ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add add_carry. - - (* Division operation *) - - Let div32 := - Eval lazy beta iota delta [w_div32] in - w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c - w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c. - - Let div21 := - Eval lazy beta iota delta [ww_div21] in - ww_div21 w_0 w_0W div32 ww_1 compare sub. - - Let low (p: zn2z t) := match p with WW _ p1 => p1 | _ => w_0 end. - - Let add_mul_div := - Eval lazy beta delta [ww_add_mul_div] in - ww_add_mul_div w_0 w_WW w_W0 w_0W compare w_add_mul_div sub w_zdigits low. - - Let div_gt := - Eval lazy beta delta [ww_div_gt] in - ww_div_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp - w_opp_carry w_sub_c w_sub w_sub_carry - w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits. - - Let div := - Eval lazy beta delta [ww_div] in ww_div ww_1 compare div_gt. - - Let mod_gt := - Eval lazy beta delta [ww_mod_gt] in - ww_mod_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry - w_mod_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div w_zdigits. - - Let mod_ := - Eval lazy beta delta [ww_mod] in ww_mod compare mod_gt. - - Let pos_mod := - Eval lazy beta delta [ww_pos_mod] in - ww_pos_mod w_0 w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits. - - Let is_even := - Eval lazy beta delta [ww_is_even] in ww_is_even w_is_even. - - Let sqrt2 := - Eval lazy beta delta [ww_sqrt2] in - ww_sqrt2 w_is_even w_compare w_0 w_1 w_Bm1 w_0W w_sub w_square_c - w_div21 w_add_mul_div w_zdigits w_add_c w_sqrt2 w_pred pred_c - pred add_c add sub_c add_mul_div. - - Let sqrt := - Eval lazy beta delta [ww_sqrt] in - ww_sqrt w_is_even w_0 w_sub w_add_mul_div w_zdigits - _ww_zdigits w_sqrt2 pred add_mul_div head0 compare low. - - Let gcd_gt_fix := - Eval cbv beta delta [ww_gcd_gt_aux ww_gcd_gt_body] in - ww_gcd_gt_aux w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry - w_sub_c w_sub w_sub_carry w_gcd_gt - w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div - w_zdigits. - - Let gcd_cont := - Eval lazy beta delta [gcd_cont] in gcd_cont ww_1 w_1 w_compare. - - Let gcd_gt := - Eval lazy beta delta [ww_gcd_gt] in - ww_gcd_gt w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. - - Let gcd := - Eval lazy beta delta [ww_gcd] in - ww_gcd compare w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. - - Definition lor (x y : zn2z t) := - match x, y with - | W0, _ => y - | _, W0 => x - | WW hx lx, WW hy ly => WW (ZnZ.lor hx hy) (ZnZ.lor lx ly) - end. - - Definition land (x y : zn2z t) := - match x, y with - | W0, _ => W0 - | _, W0 => W0 - | WW hx lx, WW hy ly => WW (ZnZ.land hx hy) (ZnZ.land lx ly) - end. - - Definition lxor (x y : zn2z t) := - match x, y with - | W0, _ => y - | _, W0 => x - | WW hx lx, WW hy ly => WW (ZnZ.lxor hx hy) (ZnZ.lxor lx ly) - end. - - (* ** Record of operators on 2 words *) - - Global Instance mk_zn2z_ops : ZnZ.Ops (zn2z t) | 1 := - ZnZ.MkOps _ww_digits _ww_zdigits - to_Z ww_of_pos head0 tail0 - W0 ww_1 ww_Bm1 - compare eq0 - opp_c opp opp_carry - succ_c add_c add_carry_c - succ add add_carry - pred_c sub_c sub_carry_c - pred sub sub_carry - mul_c mul square_c - div21 div_gt div - mod_gt mod_ - gcd_gt gcd - add_mul_div - pos_mod - is_even - sqrt2 - sqrt - lor - land - lxor. - - Global Instance mk_zn2z_ops_karatsuba : ZnZ.Ops (zn2z t) | 2 := - ZnZ.MkOps _ww_digits _ww_zdigits - to_Z ww_of_pos head0 tail0 - W0 ww_1 ww_Bm1 - compare eq0 - opp_c opp opp_carry - succ_c add_c add_carry_c - succ add add_carry - pred_c sub_c sub_carry_c - pred sub sub_carry - karatsuba_c mul square_c - div21 div_gt div - mod_gt mod_ - gcd_gt gcd - add_mul_div - pos_mod - is_even - sqrt2 - sqrt - lor - land - lxor. - - (* Proof *) - Context {specs : ZnZ.Specs ops}. - - Create HintDb ZnZ. - - Hint Resolve - ZnZ.spec_to_Z - ZnZ.spec_of_pos - ZnZ.spec_0 - ZnZ.spec_1 - ZnZ.spec_m1 - ZnZ.spec_compare - ZnZ.spec_eq0 - ZnZ.spec_opp_c - ZnZ.spec_opp - ZnZ.spec_opp_carry - ZnZ.spec_succ_c - ZnZ.spec_add_c - ZnZ.spec_add_carry_c - ZnZ.spec_succ - ZnZ.spec_add - ZnZ.spec_add_carry - ZnZ.spec_pred_c - ZnZ.spec_sub_c - ZnZ.spec_sub_carry_c - ZnZ.spec_pred - ZnZ.spec_sub - ZnZ.spec_sub_carry - ZnZ.spec_mul_c - ZnZ.spec_mul - ZnZ.spec_square_c - ZnZ.spec_div21 - ZnZ.spec_div_gt - ZnZ.spec_div - ZnZ.spec_modulo_gt - ZnZ.spec_modulo - ZnZ.spec_gcd_gt - ZnZ.spec_gcd - ZnZ.spec_head0 - ZnZ.spec_tail0 - ZnZ.spec_add_mul_div - ZnZ.spec_pos_mod - ZnZ.spec_is_even - ZnZ.spec_sqrt2 - ZnZ.spec_sqrt - ZnZ.spec_WO - ZnZ.spec_OW - ZnZ.spec_WW : ZnZ. - - Ltac wwauto := unfold ww_to_Z; eauto with ZnZ. - - Let wwB := base _ww_digits. - - Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). - - Notation "[+| c |]" := - (interp_carry 1 wwB to_Z c) (at level 0, c at level 99). - - Notation "[-| c |]" := - (interp_carry (-1) wwB to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (zn2z_to_Z wwB to_Z x) (at level 0, x at level 99). - - Let spec_ww_to_Z : forall x, 0 <= [| x |] < wwB. - Proof. refine (spec_ww_to_Z w_digits w_to_Z _); wwauto. Qed. - - Let spec_ww_of_pos : forall p, - Zpos p = (Z.of_N (fst (ww_of_pos p)))*wwB + [|(snd (ww_of_pos p))|]. - Proof. - unfold ww_of_pos;intros. - rewrite (ZnZ.spec_of_pos p). unfold w_of_pos. - case (ZnZ.of_pos p); intros. simpl. - destruct n; simpl ZnZ.to_Z. - simpl;unfold w_to_Z,w_0; rewrite ZnZ.spec_0;trivial. - unfold Z.of_N. - rewrite (ZnZ.spec_of_pos p0). - case (ZnZ.of_pos p0); intros. simpl. - unfold fst, snd,Z.of_N, to_Z, wB, w_digits, w_to_Z, w_WW. - rewrite ZnZ.spec_WW. - replace wwB with (wB*wB). - unfold wB,w_to_Z,w_digits;destruct n;ring. - symmetry. rewrite <- Z.pow_2_r; exact (wwB_wBwB w_digits). - Qed. - - Let spec_ww_0 : [|W0|] = 0. - Proof. reflexivity. Qed. - - Let spec_ww_1 : [|ww_1|] = 1. - Proof. refine (spec_ww_1 w_0 w_1 w_digits w_to_Z _ _);wwauto. Qed. - - Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1. - Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);wwauto. Qed. - - Let spec_ww_compare : - forall x y, compare x y = Z.compare [|x|] [|y|]. - Proof. - refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);wwauto. - Qed. - - Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0. - Proof. destruct x;simpl;intros;trivial;discriminate. Qed. - - Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|]. - Proof. - refine(spec_ww_opp_c w_0 w_0 W0 w_opp_c w_opp_carry w_digits w_to_Z _ _ _ _); - wwauto. - Qed. - - Let spec_ww_opp : forall x, [|opp x|] = (-[|x|]) mod wwB. - Proof. - refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp - w_digits w_to_Z _ _ _ _ _); - wwauto. - Qed. - - Let spec_ww_opp_carry : forall x, [|opp_carry x|] = wwB - [|x|] - 1. - Proof. - refine (spec_ww_opp_carry w_WW ww_Bm1 w_opp_carry w_digits w_to_Z _ _ _); - wwauto. - Qed. - - Let spec_ww_succ_c : forall x, [+|succ_c x|] = [|x|] + 1. - Proof. - refine (spec_ww_succ_c w_0 w_0 ww_1 w_succ_c w_digits w_to_Z _ _ _ _);wwauto. - Qed. - - Let spec_ww_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]. - Proof. - refine (spec_ww_add_c w_WW w_add_c w_add_carry_c w_digits w_to_Z _ _ _);wwauto. - Qed. - - Let spec_ww_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|]+[|y|]+1. - Proof. - refine (spec_ww_add_carry_c w_0 w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c - w_digits w_to_Z _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_succ : forall x, [|succ x|] = ([|x|] + 1) mod wwB. - Proof. - refine (spec_ww_succ w_W0 ww_1 w_succ_c w_succ w_digits w_to_Z _ _ _ _ _); - wwauto. - Qed. - - Let spec_ww_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wwB. - Proof. - refine (spec_ww_add w_add_c w_add w_add_carry w_digits w_to_Z _ _ _ _);wwauto. - Qed. - - Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB. - Proof. - refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ - w_add w_add_carry w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_pred_c : forall x, [-|pred_c x|] = [|x|] - 1. - Proof. - refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z - _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]. - Proof. - refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c - w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|]-[|y|]-1. - Proof. - refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c - w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_pred : forall x, [|pred x|] = ([|x|] - 1) mod wwB. - Proof. - refine (spec_ww_pred w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_pred w_digits w_to_Z - _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wwB. - Proof. - refine (spec_ww_sub w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c w_opp - w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_sub_carry : forall x y, [|sub_carry x y|]=([|x|]-[|y|]-1) mod wwB. - Proof. - refine (spec_ww_sub_carry w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c - w_sub_carry_c w_pred w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _); - wwauto. - Qed. - - Let spec_ww_mul_c : forall x y, [[mul_c x y ]] = [|x|] * [|y|]. - Proof. - refine (spec_ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry w_digits - w_to_Z _ _ _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_karatsuba_c : forall x y, [[karatsuba_c x y ]] = [|x|] * [|y|]. - Proof. - refine (spec_ww_karatsuba_c _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _); wwauto. - unfold w_digits; apply ZnZ.spec_more_than_1_digit; auto. - Qed. - - Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB. - Proof. - refine (spec_ww_mul w_W0 w_add w_mul_c w_mul add w_digits w_to_Z _ _ _ _ _); - wwauto. - Qed. - - Let spec_ww_square_c : forall x, [[square_c x]] = [|x|] * [|x|]. - Proof. - refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add - add_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_w_div32 : forall a1 a2 a3 b1 b2, - wB / 2 <= (w_to_Z b1) -> - [|WW a1 a2|] < [|WW b1 b2|] -> - let (q, r) := div32 a1 a2 a3 b1 b2 in - (w_to_Z a1) * wwB + (w_to_Z a2) * wB + (w_to_Z a3) = - (w_to_Z q) * ((w_to_Z b1)*wB + (w_to_Z b2)) + [|r|] /\ - 0 <= [|r|] < (w_to_Z b1)*wB + w_to_Z b2. - Proof. - refine (spec_w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c - w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c w_digits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - unfold w_Bm2, w_to_Z, w_pred, w_Bm1. - rewrite ZnZ.spec_pred, ZnZ.spec_m1. - unfold w_digits;rewrite Zmod_small. ring. - assert (H:= wB_pos(ZnZ.digits)). omega. - exact ZnZ.spec_div21. - Qed. - - Let spec_ww_div21 : forall a1 a2 b, - wwB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := div21 a1 a2 b in - [|a1|] *wwB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Proof. - refine (spec_ww_div21 w_0 w_0W div32 ww_1 compare sub w_digits w_to_Z - _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_add2: forall x y, - [|w_add2 x y|] = w_to_Z x + w_to_Z y. - unfold w_add2. - intros xh xl; generalize (ZnZ.spec_add_c xh xl). - unfold w_add_c; case ZnZ.add_c; unfold interp_carry; simpl ww_to_Z. - intros w0 Hw0; simpl; unfold w_to_Z; rewrite Hw0. - unfold w_0; rewrite ZnZ.spec_0; simpl; auto with zarith. - intros w0; rewrite Z.mul_1_l; simpl. - unfold w_to_Z, w_1; rewrite ZnZ.spec_1; auto with zarith. - rewrite Z.mul_1_l; auto. - Qed. - - Let spec_low: forall x, - w_to_Z (low x) = [|x|] mod wB. - intros x; case x; simpl low. - unfold ww_to_Z, w_to_Z, w_0; rewrite ZnZ.spec_0; simpl; wwauto. - intros xh xl; simpl. - rewrite Z.add_comm; rewrite Z_mod_plus; auto with zarith. - rewrite Zmod_small; auto with zarith. - unfold wB, base; eauto with ZnZ zarith. - unfold wB, base; eauto with ZnZ zarith. - Qed. - - Let spec_ww_digits: - [|_ww_zdigits|] = Zpos (xO w_digits). - Proof. - unfold w_to_Z, _ww_zdigits. - rewrite spec_add2. - unfold w_to_Z, w_zdigits, w_digits. - rewrite ZnZ.spec_zdigits; auto. - rewrite Pos2Z.inj_xO; auto with zarith. - Qed. - - - Let spec_ww_head00 : forall x, [|x|] = 0 -> [|head0 x|] = Zpos _ww_digits. - Proof. - refine (spec_ww_head00 w_0 w_0W - w_compare w_head0 w_add2 w_zdigits _ww_zdigits - w_to_Z _ _ _ (eq_refl _ww_digits) _ _ _ _); wwauto. - exact ZnZ.spec_head00. - exact ZnZ.spec_zdigits. - Qed. - - Let spec_ww_head0 : forall x, 0 < [|x|] -> - wwB/ 2 <= 2 ^ [|head0 x|] * [|x|] < wwB. - Proof. - refine (spec_ww_head0 w_0 w_0W w_compare w_head0 - w_add2 w_zdigits _ww_zdigits - w_to_Z _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_zdigits. - Qed. - - Let spec_ww_tail00 : forall x, [|x|] = 0 -> [|tail0 x|] = Zpos _ww_digits. - Proof. - refine (spec_ww_tail00 w_0 w_0W - w_compare w_tail0 w_add2 w_zdigits _ww_zdigits - w_to_Z _ _ _ (eq_refl _ww_digits) _ _ _ _); wwauto. - exact ZnZ.spec_tail00. - exact ZnZ.spec_zdigits. - Qed. - - - Let spec_ww_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2 * y + 1) * 2 ^ [|tail0 x|]. - Proof. - refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0 - w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_zdigits. - Qed. - - Lemma spec_ww_add_mul_div : forall x y p, - [|p|] <= Zpos _ww_digits -> - [| add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos _ww_digits) - [|p|]))) mod wwB. - Proof. - refine (@spec_ww_add_mul_div t w_0 w_WW w_W0 w_0W compare w_add_mul_div - sub w_digits w_zdigits low w_to_Z - _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_zdigits. - Qed. - - Let spec_ww_div_gt : forall a b, - [|a|] > [|b|] -> 0 < [|b|] -> - let (q,r) := div_gt a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. - Proof. -refine -(@spec_ww_div_gt t w_digits w_0 w_WW w_0W w_compare w_eq0 - w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt - w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -). - exact ZnZ.spec_0. - exact ZnZ.spec_to_Z. - wwauto. - wwauto. - exact ZnZ.spec_compare. - exact ZnZ.spec_eq0. - exact ZnZ.spec_opp_c. - exact ZnZ.spec_opp. - exact ZnZ.spec_opp_carry. - exact ZnZ.spec_sub_c. - exact ZnZ.spec_sub. - exact ZnZ.spec_sub_carry. - exact ZnZ.spec_div_gt. - exact ZnZ.spec_add_mul_div. - exact ZnZ.spec_head0. - exact ZnZ.spec_div21. - exact spec_w_div32. - exact ZnZ.spec_zdigits. - exact spec_ww_digits. - exact spec_ww_1. - exact spec_ww_add_mul_div. - Qed. - - Let spec_ww_div : forall a b, 0 < [|b|] -> - let (q,r) := div a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Proof. - refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);wwauto. - Qed. - - Let spec_ww_mod_gt : forall a b, - [|a|] > [|b|] -> 0 < [|b|] -> - [|mod_gt a b|] = [|a|] mod [|b|]. - Proof. - refine (@spec_ww_mod_gt t w_digits w_0 w_WW w_0W w_compare w_eq0 - w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_mod_gt - w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div - w_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_div_gt. - exact ZnZ.spec_div21. - exact ZnZ.spec_zdigits. - exact spec_ww_add_mul_div. - Qed. - - Let spec_ww_mod : forall a b, 0 < [|b|] -> [|mod_ a b|] = [|a|] mod [|b|]. - Proof. - refine (spec_ww_mod w_digits W0 compare mod_gt w_to_Z _ _ _);wwauto. - Qed. - - Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|gcd_gt a b|]. - Proof. - refine (@spec_ww_gcd_gt t w_digits W0 w_to_Z _ - w_0 w_0 w_eq0 w_gcd_gt _ww_digits - _ gcd_gt_fix _ _ _ _ gcd_cont _);wwauto. - refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp - w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 - w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_div21. - exact ZnZ.spec_zdigits. - exact spec_ww_add_mul_div. - refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare - _ _);wwauto. - Qed. - - Let spec_ww_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]. - Proof. - refine (@spec_ww_gcd t w_digits W0 compare w_to_Z _ _ w_0 w_0 w_eq0 w_gcd_gt - _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);wwauto. - refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp - w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 - w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_div21. - exact ZnZ.spec_zdigits. - exact spec_ww_add_mul_div. - refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare - _ _);wwauto. - Qed. - - Let spec_ww_is_even : forall x, - match is_even x with - true => [|x|] mod 2 = 0 - | false => [|x|] mod 2 = 1 - end. - Proof. - refine (@spec_ww_is_even t w_is_even w_digits _ _ ). - exact ZnZ.spec_is_even. - Qed. - - Let spec_ww_sqrt2 : forall x y, - wwB/ 4 <= [|x|] -> - let (s,r) := sqrt2 x y in - [[WW x y]] = [|s|] ^ 2 + [+|r|] /\ - [+|r|] <= 2 * [|s|]. - Proof. - intros x y H. - refine (@spec_ww_sqrt2 t w_is_even w_compare w_0 w_1 w_Bm1 - w_0W w_sub w_square_c w_div21 w_add_mul_div w_digits w_zdigits - _ww_zdigits - w_add_c w_sqrt2 w_pred pred_c pred add_c add sub_c add_mul_div - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. - exact ZnZ.spec_zdigits. - exact ZnZ.spec_more_than_1_digit. - exact ZnZ.spec_is_even. - exact ZnZ.spec_div21. - exact spec_ww_add_mul_div. - exact ZnZ.spec_sqrt2. - Qed. - - Let spec_ww_sqrt : forall x, - [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. - Proof. - refine (@spec_ww_sqrt t w_is_even w_0 w_1 w_Bm1 - w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits - w_sqrt2 pred add_mul_div head0 compare - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. - exact ZnZ.spec_zdigits. - exact ZnZ.spec_more_than_1_digit. - exact ZnZ.spec_is_even. - exact spec_ww_add_mul_div. - exact ZnZ.spec_sqrt2. - Qed. - - Let wB_pos : 0 < wB. - Proof. - unfold wB, base; apply Z.pow_pos_nonneg; auto with zarith. - Qed. - - Hint Transparent ww_to_Z. - - Let ww_testbit_high n x y : Z.pos w_digits <= n -> - Z.testbit [|WW x y|] n = - Z.testbit (ZnZ.to_Z x) (n - Z.pos w_digits). - Proof. - intros Hn. - assert (E : ZnZ.to_Z x = [|WW x y|] / wB). - { simpl. - rewrite Z.div_add_l; eauto with ZnZ zarith. - now rewrite Z.div_small, Z.add_0_r; wwauto. } - rewrite E. - unfold wB, base. rewrite Z.div_pow2_bits. - - f_equal; auto with zarith. - - easy. - - auto with zarith. - Qed. - - Let ww_testbit_low n x y : 0 <= n < Z.pos w_digits -> - Z.testbit [|WW x y|] n = Z.testbit (ZnZ.to_Z y) n. - Proof. - intros (Hn,Hn'). - assert (E : ZnZ.to_Z y = [|WW x y|] mod wB). - { simpl; symmetry. - rewrite Z.add_comm, Z.mod_add; auto with zarith nocore. - apply Z.mod_small; eauto with ZnZ zarith. } - rewrite E. - unfold wB, base. symmetry. apply Z.mod_pow2_bits_low; auto. - Qed. - - Let spec_lor x y : [|lor x y|] = Z.lor [|x|] [|y|]. - Proof. - destruct x as [ |hx lx]. trivial. - destruct y as [ |hy ly]. now rewrite Z.lor_comm. - change ([|WW (ZnZ.lor hx hy) (ZnZ.lor lx ly)|] = - Z.lor [|WW hx lx|] [|WW hy ly|]). - apply Z.bits_inj'; intros n Hn. - rewrite Z.lor_spec. - destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT]. - - now rewrite !ww_testbit_high, ZnZ.spec_lor, Z.lor_spec. - - rewrite !ww_testbit_low; auto. - now rewrite ZnZ.spec_lor, Z.lor_spec. - Qed. - - Let spec_land x y : [|land x y|] = Z.land [|x|] [|y|]. - Proof. - destruct x as [ |hx lx]. trivial. - destruct y as [ |hy ly]. now rewrite Z.land_comm. - change ([|WW (ZnZ.land hx hy) (ZnZ.land lx ly)|] = - Z.land [|WW hx lx|] [|WW hy ly|]). - apply Z.bits_inj'; intros n Hn. - rewrite Z.land_spec. - destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT]. - - now rewrite !ww_testbit_high, ZnZ.spec_land, Z.land_spec. - - rewrite !ww_testbit_low; auto. - now rewrite ZnZ.spec_land, Z.land_spec. - Qed. - - Let spec_lxor x y : [|lxor x y|] = Z.lxor [|x|] [|y|]. - Proof. - destruct x as [ |hx lx]. trivial. - destruct y as [ |hy ly]. now rewrite Z.lxor_comm. - change ([|WW (ZnZ.lxor hx hy) (ZnZ.lxor lx ly)|] = - Z.lxor [|WW hx lx|] [|WW hy ly|]). - apply Z.bits_inj'; intros n Hn. - rewrite Z.lxor_spec. - destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT]. - - now rewrite !ww_testbit_high, ZnZ.spec_lxor, Z.lxor_spec. - - rewrite !ww_testbit_low; auto. - now rewrite ZnZ.spec_lxor, Z.lxor_spec. - Qed. - - Global Instance mk_zn2z_specs : ZnZ.Specs mk_zn2z_ops. - Proof. - apply ZnZ.MkSpecs; auto. - exact spec_ww_add_mul_div. - - refine (@spec_ww_pos_mod t w_0 w_digits w_zdigits w_WW - w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_zdigits. - unfold w_to_Z, w_zdigits. - rewrite ZnZ.spec_zdigits. - rewrite <- Pos2Z.inj_xO; exact spec_ww_digits. - Qed. - - Global Instance mk_zn2z_specs_karatsuba : ZnZ.Specs mk_zn2z_ops_karatsuba. - Proof. - apply ZnZ.MkSpecs; auto. - exact spec_ww_add_mul_div. - refine (@spec_ww_pos_mod t w_0 w_digits w_zdigits w_WW - w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_zdigits. - unfold w_to_Z, w_zdigits. - rewrite ZnZ.spec_zdigits. - rewrite <- Pos2Z.inj_xO; exact spec_ww_digits. - Qed. - -End Z_2nZ. - - -Section MulAdd. - - Context {t : Type}{ops : ZnZ.Ops t}{specs : ZnZ.Specs ops}. - - Definition mul_add:= w_mul_add ZnZ.zero ZnZ.succ ZnZ.add_c ZnZ.mul_c. - - Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99). - - Notation "[|| x ||]" := - (zn2z_to_Z (base ZnZ.digits) ZnZ.to_Z x) (at level 0, x at level 99). - - Lemma spec_mul_add: forall x y z, - let (zh, zl) := mul_add x y z in - [||WW zh zl||] = [|x|] * [|y|] + [|z|]. - Proof. - intros x y z. - refine (spec_w_mul_add _ _ _ _ _ _ _ _ _ _ _ _ x y z); auto. - exact ZnZ.spec_0. - exact ZnZ.spec_to_Z. - exact ZnZ.spec_succ. - exact ZnZ.spec_add_c. - exact ZnZ.spec_mul_c. - Qed. - -End MulAdd. - - -(** Modular versions of DoubleCyclic *) - -Module DoubleCyclic (C:CyclicType) <: CyclicType. - Definition t := zn2z C.t. - Instance ops : ZnZ.Ops t := mk_zn2z_ops. - Instance specs : ZnZ.Specs ops := mk_zn2z_specs. -End DoubleCyclic. - -Module DoubleCyclicKaratsuba (C:CyclicType) <: CyclicType. - Definition t := zn2z C.t. - Definition ops : ZnZ.Ops t := mk_zn2z_ops_karatsuba. - Definition specs : ZnZ.Specs ops := mk_zn2z_specs_karatsuba. -End DoubleCyclicKaratsuba. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v deleted file mode 100644 index 09d7329b..00000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v +++ /dev/null @@ -1,1494 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* w -> zn2z w. - Variable w_pos_mod : w -> w -> w. - Variable w_compare : w -> w -> comparison. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - Variable w_0W : w -> zn2z w. - Variable low: zn2z w -> w. - Variable ww_sub: zn2z w -> zn2z w -> zn2z w. - Variable ww_zdigits : zn2z w. - - - Definition ww_pos_mod p x := - let zdigits := w_0W w_zdigits in - match x with - | W0 => W0 - | WW xh xl => - match ww_compare p zdigits with - | Eq => w_WW w_0 xl - | Lt => w_WW w_0 (w_pos_mod (low p) xl) - | Gt => - match ww_compare p ww_zdigits with - | Lt => - let n := low (ww_sub p zdigits) in - w_WW (w_pos_mod n xh) xl - | _ => x - end - end - end. - - - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - - - Variable spec_w_0 : [|w_0|] = 0. - - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - - Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - - Variable spec_pos_mod : forall w p, - [|w_pos_mod p w|] = [|w|] mod (2 ^ [|p|]). - - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_ww_compare : forall x y, - ww_compare x y = Z.compare [[x]] [[y]]. - Variable spec_ww_sub: forall x y, - [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - - Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits. - Variable spec_low: forall x, [| low x|] = [[x]] mod wB. - Variable spec_ww_zdigits : [[ww_zdigits]] = 2 * [|w_zdigits|]. - Variable spec_ww_digits : ww_digits w_digits = xO w_digits. - - - Hint Rewrite spec_w_0 spec_w_WW : w_rewrite. - - Lemma spec_ww_pos_mod : forall w p, - [[ww_pos_mod p w]] = [[w]] mod (2 ^ [[p]]). - assert (HHHHH:= lt_0_wB w_digits). - assert (F0: forall x y, x - y + y = x); auto with zarith. - intros w1 p; case (spec_to_w_Z p); intros HH1 HH2. - unfold ww_pos_mod; case w1. reflexivity. - intros xh xl; rewrite spec_ww_compare. - case Z.compare_spec; - rewrite spec_w_0W; rewrite spec_zdigits; fold wB; - intros H1. - rewrite H1; simpl ww_to_Z. - autorewrite with w_rewrite rm10. - rewrite Zplus_mod; auto with zarith. - rewrite Z_mod_mult; auto with zarith. - autorewrite with rm10. - rewrite Zmod_mod; auto with zarith. - rewrite Zmod_small; auto with zarith. - autorewrite with w_rewrite rm10. - simpl ww_to_Z. - rewrite spec_pos_mod. - assert (HH0: [|low p|] = [[p]]). - rewrite spec_low. - apply Zmod_small; auto with zarith. - case (spec_to_w_Z p); intros HHH1 HHH2; split; auto with zarith. - apply Z.lt_le_trans with (1 := H1). - unfold base; apply Zpower2_le_lin; auto with zarith. - rewrite HH0. - rewrite Zplus_mod; auto with zarith. - unfold base. - rewrite <- (F0 (Zpos w_digits) [[p]]). - rewrite Zpower_exp; auto with zarith. - rewrite Z.mul_assoc. - rewrite Z_mod_mult; auto with zarith. - autorewrite with w_rewrite rm10. - rewrite Zmod_mod; auto with zarith. - rewrite spec_ww_compare. - case Z.compare_spec; rewrite spec_ww_zdigits; - rewrite spec_zdigits; intros H2. - replace (2^[[p]]) with wwB. - rewrite Zmod_small; auto with zarith. - unfold base; rewrite H2. - rewrite spec_ww_digits; auto. - assert (HH0: [|low (ww_sub p (w_0W w_zdigits))|] = - [[p]] - Zpos w_digits). - rewrite spec_low. - rewrite spec_ww_sub. - rewrite spec_w_0W; rewrite spec_zdigits. - rewrite <- Zmod_div_mod; auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.lt_le_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. - exists wB; unfold base; rewrite <- Zpower_exp; auto with zarith. - rewrite spec_ww_digits; - apply f_equal with (f := Z.pow 2); rewrite Pos2Z.inj_xO; auto with zarith. - simpl ww_to_Z; autorewrite with w_rewrite. - rewrite spec_pos_mod; rewrite HH0. - pattern [|xh|] at 2; - rewrite Z_div_mod_eq with (b := 2 ^ ([[p]] - Zpos w_digits)); - auto with zarith. - rewrite (fun x => (Z.mul_comm (2 ^ x))); rewrite Z.mul_add_distr_r. - unfold base; rewrite <- Z.mul_assoc; rewrite <- Zpower_exp; - auto with zarith. - rewrite F0; auto with zarith. - rewrite <- Z.add_assoc; rewrite Zplus_mod; auto with zarith. - rewrite Z_mod_mult; auto with zarith. - autorewrite with rm10. - rewrite Zmod_mod; auto with zarith. - symmetry; apply Zmod_small; auto with zarith. - case (spec_to_Z xh); intros U1 U2. - case (spec_to_Z xl); intros U3 U4. - split; auto with zarith. - apply Z.add_nonneg_nonneg; auto with zarith. - apply Z.mul_nonneg_nonneg; auto with zarith. - match goal with |- 0 <= ?X mod ?Y => - case (Z_mod_lt X Y); auto with zarith - end. - match goal with |- ?X mod ?Y * ?U + ?Z < ?T => - apply Z.le_lt_trans with ((Y - 1) * U + Z ); - [case (Z_mod_lt X Y); auto with zarith | idtac] - end. - match goal with |- ?X * ?U + ?Y < ?Z => - apply Z.le_lt_trans with (X * U + (U - 1)) - end. - apply Z.add_le_mono_l; auto with zarith. - case (spec_to_Z xl); unfold base; auto with zarith. - rewrite Z.mul_sub_distr_r; rewrite <- Zpower_exp; auto with zarith. - rewrite F0; auto with zarith. - rewrite Zmod_small; auto with zarith. - case (spec_to_w_Z (WW xh xl)); intros U1 U2. - split; auto with zarith. - apply Z.lt_le_trans with (1:= U2). - unfold base; rewrite spec_ww_digits. - apply Zpower_le_monotone; auto with zarith. - split; auto with zarith. - rewrite Pos2Z.inj_xO; auto with zarith. - Qed. - -End POS_MOD. - -Section DoubleDiv32. - - Variable w : Type. - Variable w_0 : w. - Variable w_Bm1 : w. - Variable w_Bm2 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_compare : w -> w -> comparison. - Variable w_add_c : w -> w -> carry w. - Variable w_add_carry_c : w -> w -> carry w. - Variable w_add : w -> w -> w. - Variable w_add_carry : w -> w -> w. - Variable w_pred : w -> w. - Variable w_sub : w -> w -> w. - Variable w_mul_c : w -> w -> zn2z w. - Variable w_div21 : w -> w -> w -> w*w. - Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). - - Definition w_div32_body a1 a2 a3 b1 b2 := - match w_compare a1 b1 with - | Lt => - let (q,r) := w_div21 a1 a2 b1 in - match ww_sub_c (w_WW r a3) (w_mul_c q b2) with - | C0 r1 => (q,r1) - | C1 r1 => - let q := w_pred q in - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) - (fun r2 => (q,r2)) - r1 (WW b1 b2) - end - | Eq => - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) - (fun r => (w_Bm1,r)) - (WW (w_sub a2 b2) a3) (WW b1 b2) - | Gt => (w_0, W0) (* cas absurde *) - end. - - Definition w_div32 a1 a2 a3 b1 b2 := - Eval lazy beta iota delta [ww_add_c_cont ww_add w_div32_body] in - w_div32_body a1 a2 a3 b1 b2. - - (* Proof *) - - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. - Variable spec_w_Bm2 : [|w_Bm2|] = wB - 2. - - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_compare : - forall x y, w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add_carry_c : - forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. - - Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. - Variable spec_w_add_carry : - forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. - - Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. - Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - - Variable spec_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|]. - Variable spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - - Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - - Ltac Spec_w_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_to_Z x). - Ltac Spec_ww_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). - - Theorem wB_div2: forall x, wB/2 <= x -> wB <= 2 * x. - intros x H; rewrite <- wB_div_2; apply Z.mul_le_mono_nonneg_l; auto with zarith. - Qed. - - Lemma Zmult_lt_0_reg_r_2 : forall n m : Z, 0 <= n -> 0 < m * n -> 0 < m. - Proof. - intros n m H1 H2;apply Z.mul_pos_cancel_r with n;trivial. - Z.le_elim H1; trivial. - subst;rewrite Z.mul_0_r in H2;discriminate H2. - Qed. - - Theorem spec_w_div32 : forall a1 a2 a3 b1 b2, - wB/2 <= [|b1|] -> - [[WW a1 a2]] < [[WW b1 b2]] -> - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ - 0 <= [[r]] < [|b1|] * wB + [|b2|]. - Proof. - intros a1 a2 a3 b1 b2 Hle Hlt. - assert (U:= lt_0_wB w_digits); assert (U1:= lt_0_wwB w_digits). - Spec_w_to_Z a1;Spec_w_to_Z a2;Spec_w_to_Z a3;Spec_w_to_Z b1;Spec_w_to_Z b2. - rewrite wwB_wBwB; rewrite Z.pow_2_r; rewrite Z.mul_assoc;rewrite <- Z.mul_add_distr_r. - change (w_div32 a1 a2 a3 b1 b2) with (w_div32_body a1 a2 a3 b1 b2). - unfold w_div32_body. - rewrite spec_compare. case Z.compare_spec; intro Hcmp. - simpl in Hlt. - rewrite Hcmp in Hlt;assert ([|a2|] < [|b2|]). omega. - assert ([[WW (w_sub a2 b2) a3]] = ([|a2|]-[|b2|])*wB + [|a3|] + wwB). - simpl;rewrite spec_sub. - assert ([|a2|] - [|b2|] = wB*(-1) + ([|a2|] - [|b2|] + wB)). ring. - assert (0 <= [|a2|] - [|b2|] + wB < wB). omega. - rewrite <-(Zmod_unique ([|a2|]-[|b2|]) wB (-1) ([|a2|]-[|b2|]+wB) H1 H0). - rewrite wwB_wBwB;ring. - assert (U2 := wB_pos w_digits). - eapply spec_ww_add_c_cont with (P := - fun (x y:zn2z w) (res:w*zn2z w) => - let (q, r) := res in - ([|a1|] * wB + [|a2|]) * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ - 0 <= [[r]] < [|b1|] * wB + [|b2|]);eauto. - rewrite H0;intros r. - repeat - (rewrite spec_ww_add;eauto || rewrite spec_w_Bm1 || rewrite spec_w_Bm2); - simpl ww_to_Z;try rewrite Z.mul_1_l;intros H1. - assert (0<= ([[r]] + ([|b1|] * wB + [|b2|])) - wwB < [|b1|] * wB + [|b2|]). - Spec_ww_to_Z r;split;zarith. - rewrite H1. - assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB). - rewrite wwB_wBwB; rewrite Z.pow_2_r; zarith. - assert (-wwB < ([|a2|] - [|b2|]) * wB + [|a3|] < 0). - split. apply Z.lt_le_trans with (([|a2|] - [|b2|]) * wB);zarith. - rewrite wwB_wBwB;replace (-(wB^2)) with (-wB*wB);[zarith | ring]. - apply Z.mul_lt_mono_pos_r;zarith. - apply Z.le_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith. - replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with - (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith | ring]. - assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith. - replace 0 with (0*wB);zarith. - replace (([|a2|] - [|b2|]) * wB + [|a3|] + wwB + ([|b1|] * wB + [|b2|]) + - ([|b1|] * wB + [|b2|]) - wwB) with - (([|a2|] - [|b2|]) * wB + [|a3|] + 2*[|b1|] * wB + 2*[|b2|]); - [zarith | ring]. - rewrite <- (Zmod_unique ([[r]] + ([|b1|] * wB + [|b2|])) wwB - 1 ([[r]] + ([|b1|] * wB + [|b2|]) - wwB));zarith;try (ring;fail). - split. rewrite H1;rewrite Hcmp;ring. trivial. - Spec_ww_to_Z (WW b1 b2). simpl in HH4;zarith. - rewrite H0;intros r;repeat - (rewrite spec_w_Bm1 || rewrite spec_w_Bm2); - simpl ww_to_Z;try rewrite Z.mul_1_l;intros H1. - assert ([[r]]=([|a2|]-[|b2|])*wB+[|a3|]+([|b1|]*wB+[|b2|])). zarith. - split. rewrite H2;rewrite Hcmp;ring. - split. Spec_ww_to_Z r;zarith. - rewrite H2. - assert (([|a2|] - [|b2|]) * wB + [|a3|] < 0);zarith. - apply Z.le_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith. - replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with - (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith|ring]. - assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith. - replace 0 with (0*wB);zarith. - (* Cas Lt *) - assert (Hdiv21 := spec_div21 a2 Hle Hcmp); - destruct (w_div21 a1 a2 b1) as (q, r);destruct Hdiv21. - rewrite H. - assert (Hq := spec_to_Z q). - generalize - (spec_ww_sub_c (w_WW r a3) (w_mul_c q b2)); - destruct (ww_sub_c (w_WW r a3) (w_mul_c q b2)) - as [r1|r1];repeat (rewrite spec_w_WW || rewrite spec_mul_c); - unfold interp_carry;intros H1. - rewrite H1. - split. ring. split. - rewrite <- H1;destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z r1);trivial. - apply Z.le_lt_trans with ([|r|] * wB + [|a3|]). - assert ( 0 <= [|q|] * [|b2|]);zarith. - apply beta_lex_inv;zarith. - assert ([[r1]] = [|r|] * wB + [|a3|] - [|q|] * [|b2|] + wwB). - rewrite <- H1;ring. - Spec_ww_to_Z r1; assert (0 <= [|r|]*wB). zarith. - assert (0 < [|q|] * [|b2|]). zarith. - assert (0 < [|q|]). - apply Zmult_lt_0_reg_r_2 with [|b2|];zarith. - eapply spec_ww_add_c_cont with (P := - fun (x y:zn2z w) (res:w*zn2z w) => - let (q0, r0) := res in - ([|q|] * [|b1|] + [|r|]) * wB + [|a3|] = - [|q0|] * ([|b1|] * wB + [|b2|]) + [[r0]] /\ - 0 <= [[r0]] < [|b1|] * wB + [|b2|]);eauto. - intros r2;repeat (rewrite spec_pred || rewrite spec_ww_add;eauto); - simpl ww_to_Z;intros H7. - assert (0 < [|q|] - 1). - assert (H6 : 1 <= [|q|]) by zarith. - Z.le_elim H6;zarith. - rewrite <- H6 in H2;rewrite H2 in H7. - assert (0 < [|b1|]*wB). apply Z.mul_pos_pos;zarith. - Spec_ww_to_Z r2. zarith. - rewrite (Zmod_small ([|q|] -1));zarith. - rewrite (Zmod_small ([|q|] -1 -1));zarith. - assert ([[r2]] + ([|b1|] * wB + [|b2|]) = - wwB * 1 + - ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2 * ([|b1|] * wB + [|b2|]))). - rewrite H7;rewrite H2;ring. - assert - ([|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) - < [|b1|]*wB + [|b2|]). - Spec_ww_to_Z r2;omega. - Spec_ww_to_Z (WW b1 b2). simpl in HH5. - assert - (0 <= [|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) - < wwB). split;try omega. - replace (2*([|b1|]*wB+[|b2|])) with ((2*[|b1|])*wB+2*[|b2|]). 2:ring. - assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB). - rewrite wwB_wBwB; rewrite Z.pow_2_r; zarith. omega. - rewrite <- (Zmod_unique - ([[r2]] + ([|b1|] * wB + [|b2|])) - wwB - 1 - ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2*([|b1|] * wB + [|b2|])) - H10 H8). - split. ring. zarith. - intros r2;repeat (rewrite spec_pred);simpl ww_to_Z;intros H7. - rewrite (Zmod_small ([|q|] -1));zarith. - split. - replace [[r2]] with ([[r1]] + ([|b1|] * wB + [|b2|]) -wwB). - rewrite H2; ring. rewrite <- H7; ring. - Spec_ww_to_Z r2;Spec_ww_to_Z r1. omega. - simpl in Hlt. - assert ([|a1|] * wB + [|a2|] <= [|b1|] * wB + [|b2|]). zarith. - assert (H1 := beta_lex _ _ _ _ _ H HH0 HH3). rewrite spec_w_0;simpl;zarith. - Qed. - - -End DoubleDiv32. - -Section DoubleDiv21. - Variable w : Type. - Variable w_0 : w. - - Variable w_0W : w -> zn2z w. - Variable w_div32 : w -> w -> w -> w -> w -> w * zn2z w. - - Variable ww_1 : zn2z w. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - Variable ww_sub : zn2z w -> zn2z w -> zn2z w. - - - Definition ww_div21 a1 a2 b := - match a1 with - | W0 => - match ww_compare a2 b with - | Gt => (ww_1, ww_sub a2 b) - | Eq => (ww_1, W0) - | Lt => (W0, a2) - end - | WW a1h a1l => - match a2 with - | W0 => - match b with - | W0 => (W0,W0) (* cas absurde *) - | WW b1 b2 => - let (q1, r) := w_div32 a1h a1l w_0 b1 b2 in - match r with - | W0 => (WW q1 w_0, W0) - | WW r1 r2 => - let (q2, s) := w_div32 r1 r2 w_0 b1 b2 in - (WW q1 q2, s) - end - end - | WW a2h a2l => - match b with - | W0 => (W0,W0) (* cas absurde *) - | WW b1 b2 => - let (q1, r) := w_div32 a1h a1l a2h b1 b2 in - match r with - | W0 => (WW q1 w_0, w_0W a2l) - | WW r1 r2 => - let (q2, s) := w_div32 r1 r2 a2l b1 b2 in - (WW q1 q2, s) - end - end - end - end. - - (* Proof *) - - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_w_div32 : forall a1 a2 a3 b1 b2, - wB/2 <= [|b1|] -> - [[WW a1 a2]] < [[WW b1 b2]] -> - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ - 0 <= [[r]] < [|b1|] * wB + [|b2|]. - Variable spec_ww_1 : [[ww_1]] = 1. - Variable spec_ww_compare : forall x y, - ww_compare x y = Z.compare [[x]] [[y]]. - Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - - Theorem wwB_div: wwB = 2 * (wwB / 2). - Proof. - rewrite wwB_div_2; rewrite Z.mul_assoc; rewrite wB_div_2; auto. - rewrite <- Z.pow_2_r; apply wwB_wBwB. - Qed. - - Ltac Spec_w_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_to_Z x). - Ltac Spec_ww_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). - - Theorem spec_ww_div21 : forall a1 a2 b, - wwB/2 <= [[b]] -> - [[a1]] < [[b]] -> - let (q,r) := ww_div21 a1 a2 b in - [[a1]] *wwB+[[a2]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]. - Proof. - assert (U:= lt_0_wB w_digits). - assert (U1:= lt_0_wwB w_digits). - intros a1 a2 b H Hlt; unfold ww_div21. - Spec_ww_to_Z b; assert (Eq: 0 < [[b]]). Spec_ww_to_Z a1;omega. - generalize Hlt H ;clear Hlt H;case a1. - intros H1 H2;simpl in H1;Spec_ww_to_Z a2. - rewrite spec_ww_compare. case Z.compare_spec; - simpl;try rewrite spec_ww_1;autorewrite with rm10; intros;zarith. - rewrite spec_ww_sub;simpl. rewrite Zmod_small;zarith. - split. ring. - assert (wwB <= 2*[[b]]);zarith. - rewrite wwB_div;zarith. - intros a1h a1l. Spec_w_to_Z a1h;Spec_w_to_Z a1l. Spec_ww_to_Z a2. - destruct a2 as [ |a3 a4]; - (destruct b as [ |b1 b2];[unfold Z.le in Eq;discriminate Eq|idtac]); - try (Spec_w_to_Z a3; Spec_w_to_Z a4); Spec_w_to_Z b1; Spec_w_to_Z b2; - intros Hlt H; match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => - generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); - intros q1 r H0 - end; (assert (Eq1: wB / 2 <= [|b1|]);[ - apply (@beta_lex (wB / 2) 0 [|b1|] [|b2|] wB); auto with zarith; - autorewrite with rm10;repeat rewrite (Z.mul_comm wB); - rewrite <- wwB_div_2; trivial - | generalize (H0 Eq1 Hlt);clear H0;destruct r as [ |r1 r2];simpl; - try rewrite spec_w_0; try rewrite spec_w_0W;repeat rewrite Z.add_0_r; - intros (H1,H2) ]). - split;[rewrite wwB_wBwB; rewrite Z.pow_2_r | trivial]. - rewrite Z.mul_assoc;rewrite Z.mul_add_distr_r;rewrite <- Z.mul_assoc; - rewrite <- Z.pow_2_r; rewrite <- wwB_wBwB;rewrite H1;ring. - destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => - generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); - intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end. - split;[rewrite wwB_wBwB | trivial]. - rewrite Z.pow_2_r. - rewrite Z.mul_assoc;rewrite Z.mul_add_distr_r;rewrite <- Z.mul_assoc; - rewrite <- Z.pow_2_r. - rewrite <- wwB_wBwB;rewrite H1. - rewrite spec_w_0 in H4;rewrite Z.add_0_r in H4. - repeat rewrite Z.mul_add_distr_r. rewrite <- (Z.mul_assoc [|r1|]). - rewrite <- Z.pow_2_r; rewrite <- wwB_wBwB;rewrite H4;simpl;ring. - split;[rewrite wwB_wBwB | split;zarith]. - replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|])) - with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]). - rewrite H1;ring. rewrite wwB_wBwB;ring. - change [|a4|] with (0*wB+[|a4|]);apply beta_lex_inv;zarith. - assert (1 <= wB/2);zarith. - assert (H_:= wB_pos w_digits);apply Zdiv_le_lower_bound;zarith. - destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => - generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); - intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end. - split;trivial. - replace (([|a1h|] * wB + [|a1l|]) * wwB + ([|a3|] * wB + [|a4|])) with - (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB + [|a4|]); - [rewrite H1 | rewrite wwB_wBwB;ring]. - replace (([|q1|]*([|b1|]*wB+[|b2|])+([|r1|]*wB+[|r2|]))*wB+[|a4|]) with - (([|q1|]*([|b1|]*wB+[|b2|]))*wB+([|r1|]*wwB+[|r2|]*wB+[|a4|])); - [rewrite H4;simpl|rewrite wwB_wBwB];ring. - Qed. - -End DoubleDiv21. - -Section DoubleDivGt. - Variable w : Type. - Variable w_digits : positive. - Variable w_0 : w. - - Variable w_WW : w -> w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_compare : w -> w -> comparison. - Variable w_eq0 : w -> bool. - Variable w_opp_c : w -> carry w. - Variable w_opp w_opp_carry : w -> w. - Variable w_sub_c : w -> w -> carry w. - Variable w_sub w_sub_carry : w -> w -> w. - - Variable w_div_gt : w -> w -> w*w. - Variable w_mod_gt : w -> w -> w. - Variable w_gcd_gt : w -> w -> w. - Variable w_add_mul_div : w -> w -> w -> w. - Variable w_head0 : w -> w. - Variable w_div21 : w -> w -> w -> w * w. - Variable w_div32 : w -> w -> w -> w -> w -> w * zn2z w. - - - Variable _ww_zdigits : zn2z w. - Variable ww_1 : zn2z w. - Variable ww_add_mul_div : zn2z w -> zn2z w -> zn2z w -> zn2z w. - - Variable w_zdigits : w. - - Definition ww_div_gt_aux ah al bh bl := - Eval lazy beta iota delta [ww_sub ww_opp] in - let p := w_head0 bh in - match w_compare p w_0 with - | Gt => - let b1 := w_add_mul_div p bh bl in - let b2 := w_add_mul_div p bl w_0 in - let a1 := w_add_mul_div p w_0 ah in - let a2 := w_add_mul_div p ah al in - let a3 := w_add_mul_div p al w_0 in - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - (WW w_0 q, ww_add_mul_div - (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r) - | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)) - end. - - Definition ww_div_gt a b := - Eval lazy beta iota delta [ww_div_gt_aux double_divn1 - double_divn1_p double_divn1_p_aux double_divn1_0 double_divn1_0_aux - double_split double_0 double_WW] in - match a, b with - | W0, _ => (W0,W0) - | _, W0 => (W0,W0) - | WW ah al, WW bh bl => - if w_eq0 ah then - let (q,r) := w_div_gt al bl in - (WW w_0 q, w_0W r) - else - match w_compare w_0 bh with - | Eq => - let(q,r):= - double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl in - (q, w_0W r) - | Lt => ww_div_gt_aux ah al bh bl - | Gt => (W0,W0) (* cas absurde *) - end - end. - - Definition ww_mod_gt_aux ah al bh bl := - Eval lazy beta iota delta [ww_sub ww_opp] in - let p := w_head0 bh in - match w_compare p w_0 with - | Gt => - let b1 := w_add_mul_div p bh bl in - let b2 := w_add_mul_div p bl w_0 in - let a1 := w_add_mul_div p w_0 ah in - let a2 := w_add_mul_div p ah al in - let a3 := w_add_mul_div p al w_0 in - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r - | _ => - ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry (WW ah al) (WW bh bl) - end. - - Definition ww_mod_gt a b := - Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 - double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux - double_split double_0 double_WW snd] in - match a, b with - | W0, _ => W0 - | _, W0 => W0 - | WW ah al, WW bh bl => - if w_eq0 ah then w_0W (w_mod_gt al bl) - else - match w_compare w_0 bh with - | Eq => - w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl) - | Lt => ww_mod_gt_aux ah al bh bl - | Gt => W0 (* cas absurde *) - end - end. - - Definition ww_gcd_gt_body (cont: w->w->w->w->zn2z w) (ah al bh bl: w) := - Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 - double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux - double_split double_0 double_WW snd] in - match w_compare w_0 bh with - | Eq => - match w_compare w_0 bl with - | Eq => WW ah al (* normalement n'arrive pas si forme normale *) - | Lt => - let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 (WW ah al) bl in - WW w_0 (w_gcd_gt bl m) - | Gt => W0 (* absurde *) - end - | Lt => - let m := ww_mod_gt_aux ah al bh bl in - match m with - | W0 => WW bh bl - | WW mh ml => - match w_compare w_0 mh with - | Eq => - match w_compare w_0 ml with - | Eq => WW bh bl - | _ => - let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 (WW bh bl) ml in - WW w_0 (w_gcd_gt ml r) - end - | Lt => - let r := ww_mod_gt_aux bh bl mh ml in - match r with - | W0 => m - | WW rh rl => cont mh ml rh rl - end - | Gt => W0 (* absurde *) - end - end - | Gt => W0 (* absurde *) - end. - - Fixpoint ww_gcd_gt_aux - (p:positive) (cont: w -> w -> w -> w -> zn2z w) (ah al bh bl : w) - {struct p} : zn2z w := - ww_gcd_gt_body - (fun mh ml rh rl => match p with - | xH => cont mh ml rh rl - | xO p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl - | xI p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl - end) ah al bh bl. - - - (* Proof *) - - Variable w_to_Z : w -> Z. - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_compare : - forall x y, w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. - - Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. - Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB. - Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1. - - Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]. - Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - Variable spec_sub_carry : - forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. - - Variable spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - let (q,r) := w_div_gt a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Variable spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - [|w_mod_gt a b|] = [|a|] mod [|b|]. - Variable spec_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]. - - Variable spec_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ ([|p|])) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ [|w_head0 x|] * [|x|] < wB. - - Variable spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - - Variable spec_w_div32 : forall a1 a2 a3 b1 b2, - wB/2 <= [|b1|] -> - [[WW a1 a2]] < [[WW b1 b2]] -> - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ - 0 <= [[r]] < [|b1|] * wB + [|b2|]. - - Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits. - - Variable spec_ww_digits_ : [[_ww_zdigits]] = Zpos (xO w_digits). - Variable spec_ww_1 : [[ww_1]] = 1. - Variable spec_ww_add_mul_div : forall x y p, - [[p]] <= Zpos (xO w_digits) -> - [[ ww_add_mul_div p x y ]] = - ([[x]] * (2^[[p]]) + - [[y]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. - - Ltac Spec_w_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_to_Z x). - - Ltac Spec_ww_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). - - Lemma to_Z_div_minus_p : forall x p, - 0 < [|p|] < Zpos w_digits -> - 0 <= [|x|] / 2 ^ (Zpos w_digits - [|p|]) < 2 ^ [|p|]. - Proof. - intros x p H;Spec_w_to_Z x. - split. apply Zdiv_le_lower_bound;zarith. - apply Zdiv_lt_upper_bound;zarith. - rewrite <- Zpower_exp;zarith. - ring_simplify ([|p|] + (Zpos w_digits - [|p|])); unfold base in HH;zarith. - Qed. - Hint Resolve to_Z_div_minus_p : zarith. - - Lemma spec_ww_div_gt_aux : forall ah al bh bl, - [[WW ah al]] > [[WW bh bl]] -> - 0 < [|bh|] -> - let (q,r) := ww_div_gt_aux ah al bh bl in - [[WW ah al]] = [[q]] * [[WW bh bl]] + [[r]] /\ - 0 <= [[r]] < [[WW bh bl]]. - Proof. - intros ah al bh bl Hgt Hpos;unfold ww_div_gt_aux. - change - (let (q, r) := let p := w_head0 bh in - match w_compare p w_0 with - | Gt => - let b1 := w_add_mul_div p bh bl in - let b2 := w_add_mul_div p bl w_0 in - let a1 := w_add_mul_div p w_0 ah in - let a2 := w_add_mul_div p ah al in - let a3 := w_add_mul_div p al w_0 in - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - (WW w_0 q, ww_add_mul_div - (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r) - | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)) - end in [[WW ah al]]=[[q]]*[[WW bh bl]]+[[r]] /\ 0 <=[[r]]< [[WW bh bl]]). - assert (Hh := spec_head0 Hpos). - lazy zeta. - rewrite spec_compare; case Z.compare_spec; - rewrite spec_w_0; intros HH. - generalize Hh; rewrite HH; simpl Z.pow; - rewrite Z.mul_1_l; intros (HH1, HH2); clear HH. - assert (wwB <= 2*[[WW bh bl]]). - apply Z.le_trans with (2*[|bh|]*wB). - rewrite wwB_wBwB; rewrite Z.pow_2_r; apply Z.mul_le_mono_nonneg_r; zarith. - rewrite <- wB_div_2; apply Z.mul_le_mono_nonneg_l; zarith. - simpl ww_to_Z;rewrite Z.mul_add_distr_l;rewrite Z.mul_assoc. - Spec_w_to_Z bl;zarith. - Spec_ww_to_Z (WW ah al). - rewrite spec_ww_sub;eauto. - simpl;rewrite spec_ww_1;rewrite Z.mul_1_l;simpl. - simpl ww_to_Z in Hgt, H, HH;rewrite Zmod_small;split;zarith. - case (spec_to_Z (w_head0 bh)); auto with zarith. - assert ([|w_head0 bh|] < Zpos w_digits). - destruct (Z_lt_ge_dec [|w_head0 bh|] (Zpos w_digits));trivial. - exfalso. - assert (2 ^ [|w_head0 bh|] * [|bh|] >= wB);auto with zarith. - apply Z.le_ge; replace wB with (wB * 1);try ring. - Spec_w_to_Z bh;apply Z.mul_le_mono_nonneg;zarith. - unfold base;apply Zpower_le_monotone;zarith. - assert (HHHH : 0 < [|w_head0 bh|] < Zpos w_digits); auto with zarith. - assert (Hb:= Z.lt_le_incl _ _ H). - generalize (spec_add_mul_div w_0 ah Hb) - (spec_add_mul_div ah al Hb) - (spec_add_mul_div al w_0 Hb) - (spec_add_mul_div bh bl Hb) - (spec_add_mul_div bl w_0 Hb); - rewrite spec_w_0; repeat rewrite Z.mul_0_l;repeat rewrite Z.add_0_l; - rewrite Zdiv_0_l;repeat rewrite Z.add_0_r. - Spec_w_to_Z ah;Spec_w_to_Z bh. - unfold base;repeat rewrite Zmod_shift_r;zarith. - assert (H3:=to_Z_div_minus_p ah HHHH);assert(H4:=to_Z_div_minus_p al HHHH); - assert (H5:=to_Z_div_minus_p bl HHHH). - rewrite Z.mul_comm in Hh. - assert (2^[|w_head0 bh|] < wB). unfold base;apply Zpower_lt_monotone;zarith. - unfold base in H0;rewrite Zmod_small;zarith. - fold wB; rewrite (Zmod_small ([|bh|] * 2 ^ [|w_head0 bh|]));zarith. - intros U1 U2 U3 V1 V2. - generalize (@spec_w_div32 (w_add_mul_div (w_head0 bh) w_0 ah) - (w_add_mul_div (w_head0 bh) ah al) - (w_add_mul_div (w_head0 bh) al w_0) - (w_add_mul_div (w_head0 bh) bh bl) - (w_add_mul_div (w_head0 bh) bl w_0)). - destruct (w_div32 (w_add_mul_div (w_head0 bh) w_0 ah) - (w_add_mul_div (w_head0 bh) ah al) - (w_add_mul_div (w_head0 bh) al w_0) - (w_add_mul_div (w_head0 bh) bh bl) - (w_add_mul_div (w_head0 bh) bl w_0)) as (q,r). - rewrite V1;rewrite V2. rewrite Z.mul_add_distr_r. - rewrite <- (Z.add_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)). - unfold base;rewrite <- shift_unshift_mod;zarith. fold wB. - replace ([|bh|] * 2 ^ [|w_head0 bh|] * wB + [|bl|] * 2 ^ [|w_head0 bh|]) with - ([[WW bh bl]] * 2^[|w_head0 bh|]). 2:simpl;ring. - fold wwB. rewrite wwB_wBwB. rewrite Z.pow_2_r. rewrite U1;rewrite U2;rewrite U3. - rewrite Z.mul_assoc. rewrite Z.mul_add_distr_r. - rewrite (Z.add_assoc ([|ah|] / 2^(Zpos(w_digits) - [|w_head0 bh|])*wB * wB)). - rewrite <- Z.mul_add_distr_r. rewrite <- Z.add_assoc. - unfold base;repeat rewrite <- shift_unshift_mod;zarith. fold wB. - replace ([|ah|] * 2 ^ [|w_head0 bh|] * wB + [|al|] * 2 ^ [|w_head0 bh|]) with - ([[WW ah al]] * 2^[|w_head0 bh|]). 2:simpl;ring. - intros Hd;destruct Hd;zarith. - simpl. apply beta_lex_inv;zarith. rewrite U1;rewrite V1. - assert ([|ah|] / 2 ^ (Zpos (w_digits) - [|w_head0 bh|]) < wB/2);zarith. - apply Zdiv_lt_upper_bound;zarith. - unfold base. - replace (2^Zpos (w_digits)) with (2^(Zpos (w_digits) - 1)*2). - rewrite Z_div_mult;zarith. rewrite <- Zpower_exp;zarith. - apply Z.lt_le_trans with wB;zarith. - unfold base;apply Zpower_le_monotone;zarith. - pattern 2 at 2;replace 2 with (2^1);trivial. - rewrite <- Zpower_exp;zarith. ring_simplify (Zpos (w_digits) - 1 + 1);trivial. - change [[WW w_0 q]] with ([|w_0|]*wB+[|q|]);rewrite spec_w_0;rewrite - Z.mul_0_l;rewrite Z.add_0_l. - replace [[ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry - _ww_zdigits (w_0W (w_head0 bh))) W0 r]] with ([[r]]/2^[|w_head0 bh|]). - assert (0 < 2^[|w_head0 bh|]). apply Z.pow_pos_nonneg;zarith. - split. - rewrite <- (Z_div_mult [[WW ah al]] (2^[|w_head0 bh|]));zarith. - rewrite H1;rewrite Z.mul_assoc;apply Z_div_plus_l;trivial. - split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith. - rewrite spec_ww_add_mul_div. - rewrite spec_ww_sub; auto with zarith. - rewrite spec_ww_digits_. - change (Zpos (xO (w_digits))) with (2*Zpos (w_digits));zarith. - simpl ww_to_Z;rewrite Z.mul_0_l;rewrite Z.add_0_l. - rewrite spec_w_0W. - rewrite (fun x y => Zmod_small (x-y)); auto with zarith. - ring_simplify (2 * Zpos w_digits - (2 * Zpos w_digits - [|w_head0 bh|])). - rewrite Zmod_small;zarith. - split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith. - Spec_ww_to_Z r. - apply Z.lt_le_trans with wwB;zarith. - rewrite <- (Z.mul_1_r wwB);apply Z.mul_le_mono_nonneg;zarith. - split; auto with zarith. - apply Z.le_lt_trans with (2 * Zpos w_digits); auto with zarith. - unfold base, ww_digits; rewrite (Pos2Z.inj_xO w_digits). - apply Zpower2_lt_lin; auto with zarith. - rewrite spec_ww_sub; auto with zarith. - rewrite spec_ww_digits_; rewrite spec_w_0W. - rewrite Zmod_small;zarith. - rewrite Pos2Z.inj_xO; split; auto with zarith. - apply Z.le_lt_trans with (2 * Zpos w_digits); auto with zarith. - unfold base, ww_digits; rewrite (Pos2Z.inj_xO w_digits). - apply Zpower2_lt_lin; auto with zarith. - Qed. - - Lemma spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - let (q,r) := ww_div_gt a b in - [[a]] = [[q]] * [[b]] + [[r]] /\ - 0 <= [[r]] < [[b]]. - Proof. - intros a b Hgt Hpos;unfold ww_div_gt. - change (let (q,r) := match a, b with - | W0, _ => (W0,W0) - | _, W0 => (W0,W0) - | WW ah al, WW bh bl => - if w_eq0 ah then - let (q,r) := w_div_gt al bl in - (WW w_0 q, w_0W r) - else - match w_compare w_0 bh with - | Eq => - let(q,r):= - double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl in - (q, w_0W r) - | Lt => ww_div_gt_aux ah al bh bl - | Gt => (W0,W0) (* cas absurde *) - end - end in [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]). - destruct a as [ |ah al]. simpl in Hgt;omega. - destruct b as [ |bh bl]. simpl in Hpos;omega. - Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. - assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). - simpl ww_to_Z;rewrite H;trivial. simpl in Hgt;rewrite H in Hgt;trivial. - assert ([|bh|] <= 0). - apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. - assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;rewrite H1;simpl in Hgt. - simpl. simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. - assert (H2:=spec_div_gt Hgt Hpos);destruct (w_div_gt al bl). - repeat rewrite spec_w_0W;simpl;rewrite spec_w_0;simpl;trivial. - clear H. - rewrite spec_compare; case Z.compare_spec; intros Hcmp. - rewrite spec_w_0 in Hcmp. change [[WW bh bl]] with ([|bh|]*wB+[|bl|]). - rewrite <- Hcmp;rewrite Z.mul_0_l;rewrite Z.add_0_l. - simpl in Hpos;rewrite <- Hcmp in Hpos;simpl in Hpos. - assert (H2:= @spec_double_divn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div - w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 - spec_add_mul_div spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hpos). - destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 - (WW ah al) bl). - rewrite spec_w_0W;unfold ww_to_Z;trivial. - apply spec_ww_div_gt_aux;trivial. rewrite spec_w_0 in Hcmp;trivial. - rewrite spec_w_0 in Hcmp;exfalso;omega. - Qed. - - Lemma spec_ww_mod_gt_aux_eq : forall ah al bh bl, - ww_mod_gt_aux ah al bh bl = snd (ww_div_gt_aux ah al bh bl). - Proof. - intros ah al bh bl. unfold ww_mod_gt_aux, ww_div_gt_aux. - case w_compare; auto. - case w_div32; auto. - Qed. - - Lemma spec_ww_mod_gt_aux : forall ah al bh bl, - [[WW ah al]] > [[WW bh bl]] -> - 0 < [|bh|] -> - [[ww_mod_gt_aux ah al bh bl]] = [[WW ah al]] mod [[WW bh bl]]. - Proof. - intros. rewrite spec_ww_mod_gt_aux_eq;trivial. - assert (H3 := spec_ww_div_gt_aux ah al bl H H0). - destruct (ww_div_gt_aux ah al bh bl) as (q,r);simpl. simpl in H,H3. - destruct H3;apply Zmod_unique with [[q]];zarith. - rewrite H1;ring. - Qed. - - Lemma spec_w_mod_gt_eq : forall a b, [|a|] > [|b|] -> 0 <[|b|] -> - [|w_mod_gt a b|] = [|snd (w_div_gt a b)|]. - Proof. - intros a b Hgt Hpos. - rewrite spec_mod_gt;trivial. - assert (H:=spec_div_gt Hgt Hpos). - destruct (w_div_gt a b) as (q,r);simpl. - rewrite Z.mul_comm in H;destruct H. - symmetry;apply Zmod_unique with [|q|];trivial. - Qed. - - Lemma spec_ww_mod_gt_eq : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - [[ww_mod_gt a b]] = [[snd (ww_div_gt a b)]]. - Proof. - intros a b Hgt Hpos. - change (ww_mod_gt a b) with - (match a, b with - | W0, _ => W0 - | _, W0 => W0 - | WW ah al, WW bh bl => - if w_eq0 ah then w_0W (w_mod_gt al bl) - else - match w_compare w_0 bh with - | Eq => - w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl) - | Lt => ww_mod_gt_aux ah al bh bl - | Gt => W0 (* cas absurde *) - end end). - change (ww_div_gt a b) with - (match a, b with - | W0, _ => (W0,W0) - | _, W0 => (W0,W0) - | WW ah al, WW bh bl => - if w_eq0 ah then - let (q,r) := w_div_gt al bl in - (WW w_0 q, w_0W r) - else - match w_compare w_0 bh with - | Eq => - let(q,r):= - double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl in - (q, w_0W r) - | Lt => ww_div_gt_aux ah al bh bl - | Gt => (W0,W0) (* cas absurde *) - end - end). - destruct a as [ |ah al];trivial. - destruct b as [ |bh bl];trivial. - Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. - assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). - simpl in Hgt;rewrite H in Hgt;trivial. - assert ([|bh|] <= 0). - apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. - assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. - simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. - rewrite spec_w_0W;rewrite spec_w_mod_gt_eq;trivial. - destruct (w_div_gt al bl);simpl;rewrite spec_w_0W;trivial. - clear H. - rewrite spec_compare; case Z.compare_spec; intros H2. - rewrite (@spec_double_modn1_aux w w_zdigits w_0 w_WW w_head0 w_add_mul_div - w_div21 w_compare w_sub w_to_Z spec_w_0 spec_compare 1 (WW ah al) bl). - destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 - (WW ah al) bl);simpl;trivial. - rewrite spec_ww_mod_gt_aux_eq;trivial;symmetry;trivial. - trivial. - Qed. - - Lemma spec_ww_mod_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - [[ww_mod_gt a b]] = [[a]] mod [[b]]. - Proof. - intros a b Hgt Hpos. - assert (H:= spec_ww_div_gt a b Hgt Hpos). - rewrite (spec_ww_mod_gt_eq a b Hgt Hpos). - destruct (ww_div_gt a b)as(q,r);destruct H. - apply Zmod_unique with[[q]];simpl;trivial. - rewrite Z.mul_comm;trivial. - Qed. - - Lemma Zis_gcd_mod : forall a b d, - 0 < b -> Zis_gcd b (a mod b) d -> Zis_gcd a b d. - Proof. - intros a b d H H1; apply Zis_gcd_for_euclid with (a/b). - pattern a at 1;rewrite (Z_div_mod_eq a b). - ring_simplify (b * (a / b) + a mod b - a / b * b);trivial. zarith. - Qed. - - Lemma spec_ww_gcd_gt_aux_body : - forall ah al bh bl n cont, - [[WW bh bl]] <= 2^n -> - [[WW ah al]] > [[WW bh bl]] -> - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^(n-1) -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> - Zis_gcd [[WW ah al]] [[WW bh bl]] [[ww_gcd_gt_body cont ah al bh bl]]. - Proof. - intros ah al bh bl n cont Hlog Hgt Hcont. - change (ww_gcd_gt_body cont ah al bh bl) with (match w_compare w_0 bh with - | Eq => - match w_compare w_0 bl with - | Eq => WW ah al (* normalement n'arrive pas si forme normale *) - | Lt => - let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 (WW ah al) bl in - WW w_0 (w_gcd_gt bl m) - | Gt => W0 (* absurde *) - end - | Lt => - let m := ww_mod_gt_aux ah al bh bl in - match m with - | W0 => WW bh bl - | WW mh ml => - match w_compare w_0 mh with - | Eq => - match w_compare w_0 ml with - | Eq => WW bh bl - | _ => - let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 (WW bh bl) ml in - WW w_0 (w_gcd_gt ml r) - end - | Lt => - let r := ww_mod_gt_aux bh bl mh ml in - match r with - | W0 => m - | WW rh rl => cont mh ml rh rl - end - | Gt => W0 (* absurde *) - end - end - | Gt => W0 (* absurde *) - end). - rewrite spec_compare, spec_w_0. - case Z.compare_spec; intros Hbh. - simpl ww_to_Z in *. rewrite <- Hbh. - rewrite Z.mul_0_l;rewrite Z.add_0_l. - rewrite spec_compare, spec_w_0. - case Z.compare_spec; intros Hbl. - rewrite <- Hbl;apply Zis_gcd_0. - simpl;rewrite spec_w_0;rewrite Z.mul_0_l;rewrite Z.add_0_l. - apply Zis_gcd_mod;zarith. - change ([|ah|] * wB + [|al|]) with (double_to_Z w_digits w_to_Z 1 (WW ah al)). - rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div - w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div - spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hbl). - apply spec_gcd_gt. - rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. - apply Z.lt_gt;match goal with | |- ?x mod ?y < ?y => - destruct (Z_mod_lt x y);zarith end. - Spec_w_to_Z bl;exfalso;omega. - assert (H:= spec_ww_mod_gt_aux _ _ _ Hgt Hbh). - assert (H2 : 0 < [[WW bh bl]]). - simpl;Spec_w_to_Z bl. apply Z.lt_le_trans with ([|bh|]*wB);zarith. - apply Z.mul_pos_pos;zarith. - apply Zis_gcd_mod;trivial. rewrite <- H. - simpl in *;destruct (ww_mod_gt_aux ah al bh bl) as [ |mh ml]. - simpl;apply Zis_gcd_0;zarith. - rewrite spec_compare, spec_w_0; case Z.compare_spec; intros Hmh. - simpl;rewrite <- Hmh;simpl. - rewrite spec_compare, spec_w_0; case Z.compare_spec; intros Hml. - rewrite <- Hml;simpl;apply Zis_gcd_0. - simpl; rewrite spec_w_0; simpl. - apply Zis_gcd_mod;zarith. - change ([|bh|] * wB + [|bl|]) with (double_to_Z w_digits w_to_Z 1 (WW bh bl)). - rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div - w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div - spec_div21 spec_compare spec_sub 1 (WW bh bl) ml Hml). - apply spec_gcd_gt. - rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. - apply Z.lt_gt;match goal with | |- ?x mod ?y < ?y => - destruct (Z_mod_lt x y);zarith end. - Spec_w_to_Z ml;exfalso;omega. - assert ([[WW bh bl]] > [[WW mh ml]]). - rewrite H;simpl; apply Z.lt_gt;match goal with | |- ?x mod ?y < ?y => - destruct (Z_mod_lt x y);zarith end. - assert (H1:= spec_ww_mod_gt_aux _ _ _ H0 Hmh). - assert (H3 : 0 < [[WW mh ml]]). - simpl;Spec_w_to_Z ml. apply Z.lt_le_trans with ([|mh|]*wB);zarith. - apply Z.mul_pos_pos;zarith. - apply Zis_gcd_mod;zarith. simpl in *;rewrite <- H1. - destruct (ww_mod_gt_aux bh bl mh ml) as [ |rh rl]. simpl; apply Zis_gcd_0. - simpl;apply Hcont. simpl in H1;rewrite H1. - apply Z.lt_gt;match goal with | |- ?x mod ?y < ?y => - destruct (Z_mod_lt x y);zarith end. - apply Z.le_trans with (2^n/2). - apply Zdiv_le_lower_bound;zarith. - apply Z.le_trans with ([|bh|] * wB + [|bl|]);zarith. - assert (H3' := Z_div_mod_eq [[WW bh bl]] [[WW mh ml]] (Z.lt_gt _ _ H3)). - assert (H4 : 0 <= [[WW bh bl]]/[[WW mh ml]]). - apply Z.ge_le;apply Z_div_ge0;zarith. simpl in *;rewrite H1. - pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3'. - Z.le_elim H4. - assert (H6' : [[WW bh bl]] mod [[WW mh ml]] = - [[WW bh bl]] - [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). - simpl;pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3';ring. simpl in H6'. - assert ([[WW mh ml]] <= [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). - simpl;pattern ([|mh|]*wB+[|ml|]) at 1;rewrite <- Z.mul_1_r;zarith. - simpl in *;assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in H8; - zarith. - assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in *;zarith. - rewrite <- H4 in H3';rewrite Z.mul_0_r in H3';simpl in H3';zarith. - pattern n at 1;replace n with (n-1+1);try ring. - rewrite Zpower_exp;zarith. change (2^1) with 2. - rewrite Z_div_mult;zarith. - assert (2^1 <= 2^n). change (2^1) with 2;zarith. - assert (H7 := @Zpower_le_monotone_inv 2 1 n);zarith. - Spec_w_to_Z mh;exfalso;zarith. - Spec_w_to_Z bh;exfalso;zarith. - Qed. - - Lemma spec_ww_gcd_gt_aux : - forall p cont n, - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> - [[WW yh yl]] <= 2^n -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> - forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> - [[WW bh bl]] <= 2^(Zpos p + n) -> - Zis_gcd [[WW ah al]] [[WW bh bl]] - [[ww_gcd_gt_aux p cont ah al bh bl]]. - Proof. - induction p;intros cont n Hcont ah al bh bl Hgt Hs;simpl ww_gcd_gt_aux. - assert (0 < Zpos p). unfold Z.lt;reflexivity. - apply spec_ww_gcd_gt_aux_body with (n := Zpos (xI p) + n); - trivial;rewrite Pos2Z.inj_xI. - intros. apply IHp with (n := Zpos p + n);zarith. - intros. apply IHp with (n := n );zarith. - apply Z.le_trans with (2 ^ (2* Zpos p + 1+ n -1));zarith. - apply Z.pow_le_mono_r;zarith. - assert (0 < Zpos p). unfold Z.lt;reflexivity. - apply spec_ww_gcd_gt_aux_body with (n := Zpos (xO p) + n );trivial. - rewrite (Pos2Z.inj_xO p). - intros. apply IHp with (n := Zpos p + n - 1);zarith. - intros. apply IHp with (n := n -1 );zarith. - intros;apply Hcont;zarith. - apply Z.le_trans with (2^(n-1));zarith. - apply Z.pow_le_mono_r;zarith. - apply Z.le_trans with (2 ^ (Zpos p + n -1));zarith. - apply Z.pow_le_mono_r;zarith. - apply Z.le_trans with (2 ^ (2*Zpos p + n -1));zarith. - apply Z.pow_le_mono_r;zarith. - apply spec_ww_gcd_gt_aux_body with (n := n+1);trivial. - rewrite Z.add_comm;trivial. - ring_simplify (n + 1 - 1);trivial. - Qed. - -End DoubleDivGt. - -Section DoubleDiv. - - Variable w : Type. - Variable w_digits : positive. - Variable ww_1 : zn2z w. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - - Variable ww_div_gt : zn2z w -> zn2z w -> zn2z w * zn2z w. - Variable ww_mod_gt : zn2z w -> zn2z w -> zn2z w. - - Definition ww_div a b := - match ww_compare a b with - | Gt => ww_div_gt a b - | Eq => (ww_1, W0) - | Lt => (W0, a) - end. - - Definition ww_mod a b := - match ww_compare a b with - | Gt => ww_mod_gt a b - | Eq => W0 - | Lt => a - end. - - Variable w_to_Z : w -> Z. - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_ww_1 : [[ww_1]] = 1. - Variable spec_ww_compare : forall x y, - ww_compare x y = Z.compare [[x]] [[y]]. - Variable spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - let (q,r) := ww_div_gt a b in - [[a]] = [[q]] * [[b]] + [[r]] /\ - 0 <= [[r]] < [[b]]. - Variable spec_ww_mod_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - [[ww_mod_gt a b]] = [[a]] mod [[b]]. - - Ltac Spec_w_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_to_Z x). - - Ltac Spec_ww_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). - - Lemma spec_ww_div : forall a b, 0 < [[b]] -> - let (q,r) := ww_div a b in - [[a]] = [[q]] * [[b]] + [[r]] /\ - 0 <= [[r]] < [[b]]. - Proof. - intros a b Hpos;unfold ww_div. - rewrite spec_ww_compare; case Z.compare_spec; intros. - simpl;rewrite spec_ww_1;split;zarith. - simpl;split;[ring|Spec_ww_to_Z a;zarith]. - apply spec_ww_div_gt;auto with zarith. - Qed. - - Lemma spec_ww_mod : forall a b, 0 < [[b]] -> - [[ww_mod a b]] = [[a]] mod [[b]]. - Proof. - intros a b Hpos;unfold ww_mod. - rewrite spec_ww_compare; case Z.compare_spec; intros. - simpl;apply Zmod_unique with 1;try rewrite H;zarith. - Spec_ww_to_Z a;symmetry;apply Zmod_small;zarith. - apply spec_ww_mod_gt;auto with zarith. - Qed. - - - Variable w_0 : w. - Variable w_1 : w. - Variable w_compare : w -> w -> comparison. - Variable w_eq0 : w -> bool. - Variable w_gcd_gt : w -> w -> w. - Variable _ww_digits : positive. - Variable spec_ww_digits_ : _ww_digits = xO w_digits. - Variable ww_gcd_gt_fix : - positive -> (w -> w -> w -> w -> zn2z w) -> - w -> w -> w -> w -> zn2z w. - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - Variable spec_compare : - forall x y, w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. - Variable spec_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]. - Variable spec_gcd_gt_fix : - forall p cont n, - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> - [[WW yh yl]] <= 2^n -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> - forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> - [[WW bh bl]] <= 2^(Zpos p + n) -> - Zis_gcd [[WW ah al]] [[WW bh bl]] - [[ww_gcd_gt_fix p cont ah al bh bl]]. - - Definition gcd_cont (xh xl yh yl:w) := - match w_compare w_1 yl with - | Eq => ww_1 - | _ => WW xh xl - end. - - Lemma spec_gcd_cont : forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> - [[WW yh yl]] <= 1 -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[gcd_cont xh xl yh yl]]. - Proof. - intros xh xl yh yl Hgt' Hle. simpl in Hle. - assert ([|yh|] = 0). - change 1 with (0*wB+1) in Hle. - assert (0 <= 1 < wB). split;zarith. apply wB_pos. - assert (H1:= beta_lex _ _ _ _ _ Hle (spec_to_Z yl) H). - Spec_w_to_Z yh;zarith. - unfold gcd_cont; rewrite spec_compare, spec_w_1. - case Z.compare_spec; intros Hcmpy. - simpl;rewrite H;simpl; - rewrite spec_ww_1;rewrite <- Hcmpy;apply Zis_gcd_mod;zarith. - rewrite <- (Zmod_unique ([|xh|]*wB+[|xl|]) 1 ([|xh|]*wB+[|xl|]) 0);zarith. - rewrite H in Hle; exfalso;zarith. - assert (H0 : [|yl|] = 0) by (Spec_w_to_Z yl;zarith). - simpl. rewrite H0, H;simpl;apply Zis_gcd_0;trivial. - Qed. - - - Variable cont : w -> w -> w -> w -> zn2z w. - Variable spec_cont : forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> - [[WW yh yl]] <= 1 -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]. - - Definition ww_gcd_gt a b := - match a, b with - | W0, _ => b - | _, W0 => a - | WW ah al, WW bh bl => - if w_eq0 ah then (WW w_0 (w_gcd_gt al bl)) - else ww_gcd_gt_fix _ww_digits cont ah al bh bl - end. - - Definition ww_gcd a b := - Eval lazy beta delta [ww_gcd_gt] in - match ww_compare a b with - | Gt => ww_gcd_gt a b - | Eq => a - | Lt => ww_gcd_gt b a - end. - - Lemma spec_ww_gcd_gt : forall a b, [[a]] > [[b]] -> - Zis_gcd [[a]] [[b]] [[ww_gcd_gt a b]]. - Proof. - intros a b Hgt;unfold ww_gcd_gt. - destruct a as [ |ah al]. simpl;apply Zis_gcd_sym;apply Zis_gcd_0. - destruct b as [ |bh bl]. simpl;apply Zis_gcd_0. - simpl in Hgt. generalize (@spec_eq0 ah);destruct (w_eq0 ah);intros. - simpl;rewrite H in Hgt;trivial;rewrite H;trivial;rewrite spec_w_0;simpl. - assert ([|bh|] <= 0). - apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. - Spec_w_to_Z bh;assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. - rewrite H1;simpl;auto. clear H. - apply spec_gcd_gt_fix with (n:= 0);trivial. - rewrite Z.add_0_r;rewrite spec_ww_digits_. - change (2 ^ Zpos (xO w_digits)) with wwB. Spec_ww_to_Z (WW bh bl);zarith. - Qed. - - Lemma spec_ww_gcd : forall a b, Zis_gcd [[a]] [[b]] [[ww_gcd a b]]. - Proof. - intros a b. - change (ww_gcd a b) with - (match ww_compare a b with - | Gt => ww_gcd_gt a b - | Eq => a - | Lt => ww_gcd_gt b a - end). - rewrite spec_ww_compare; case Z.compare_spec; intros Hcmp. - Spec_ww_to_Z b;rewrite Hcmp. - apply Zis_gcd_for_euclid with 1;zarith. - ring_simplify ([[b]] - 1 * [[b]]). apply Zis_gcd_0;zarith. - apply Zis_gcd_sym;apply spec_ww_gcd_gt;zarith. - apply spec_ww_gcd_gt;zarith. - Qed. - -End DoubleDiv. - diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v deleted file mode 100644 index 195527dd..00000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v +++ /dev/null @@ -1,519 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* w -> zn2z w. - Variable w_head0 : w -> w. - Variable w_add_mul_div : w -> w -> w -> w. - Variable w_div21 : w -> w -> w -> w * w. - Variable w_compare : w -> w -> comparison. - Variable w_sub : w -> w -> w. - - - - (* ** For proofs ** *) - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) - (at level 0, x at level 99). - Notation "[[ x ]]" := (zn2z_to_Z wB w_to_Z x) (at level 0, x at level 99). - - Variable spec_to_Z : forall x, 0 <= [| x |] < wB. - Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits. - Variable spec_0 : [|w_0|] = 0. - Variable spec_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ [|w_head0 x|] * [|x|] < wB. - Variable spec_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Variable spec_compare : - forall x y, w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_sub: forall x y, - [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - - - - Section DIVAUX. - Variable b2p : w. - Variable b2p_le : wB/2 <= [|b2p|]. - - Definition double_divn1_0_aux n (divn1: w -> word w n -> word w n * w) r h := - let (hh,hl) := double_split w_0 n h in - let (qh,rh) := divn1 r hh in - let (ql,rl) := divn1 rh hl in - (double_WW w_WW n qh ql, rl). - - Fixpoint double_divn1_0 (n:nat) : w -> word w n -> word w n * w := - match n return w -> word w n -> word w n * w with - | O => fun r x => w_div21 r x b2p - | S n => double_divn1_0_aux n (double_divn1_0 n) - end. - - Lemma spec_split : forall (n : nat) (x : zn2z (word w n)), - let (h, l) := double_split w_0 n x in - [!S n | x!] = [!n | h!] * double_wB w_digits n + [!n | l!]. - Proof (spec_double_split w_0 w_digits w_to_Z spec_0). - - Lemma spec_double_divn1_0 : forall n r a, - [|r|] < [|b2p|] -> - let (q,r') := double_divn1_0 n r a in - [|r|] * double_wB w_digits n + [!n|a!] = [!n|q!] * [|b2p|] + [|r'|] /\ - 0 <= [|r'|] < [|b2p|]. - Proof. - induction n;intros. - exact (spec_div21 a b2p_le H). - simpl (double_divn1_0 (S n) r a); unfold double_divn1_0_aux. - assert (H1 := spec_split n a);destruct (double_split w_0 n a) as (hh,hl). - rewrite H1. - assert (H2 := IHn r hh H);destruct (double_divn1_0 n r hh) as (qh,rh). - destruct H2. - assert ([|rh|] < [|b2p|]). omega. - assert (H4 := IHn rh hl H3);destruct (double_divn1_0 n rh hl) as (ql,rl). - destruct H4;split;trivial. - rewrite spec_double_WW;trivial. - rewrite <- double_wB_wwB. - rewrite Z.mul_assoc;rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - rewrite H0;rewrite Z.mul_add_distr_r;rewrite <- Z.add_assoc. - rewrite H4;ring. - Qed. - - Definition double_modn1_0_aux n (modn1:w -> word w n -> w) r h := - let (hh,hl) := double_split w_0 n h in modn1 (modn1 r hh) hl. - - Fixpoint double_modn1_0 (n:nat) : w -> word w n -> w := - match n return w -> word w n -> w with - | O => fun r x => snd (w_div21 r x b2p) - | S n => double_modn1_0_aux n (double_modn1_0 n) - end. - - Lemma spec_double_modn1_0 : forall n r x, - double_modn1_0 n r x = snd (double_divn1_0 n r x). - Proof. - induction n;simpl;intros;trivial. - unfold double_modn1_0_aux, double_divn1_0_aux. - destruct (double_split w_0 n x) as (hh,hl). - rewrite (IHn r hh). - destruct (double_divn1_0 n r hh) as (qh,rh);simpl. - rewrite IHn. destruct (double_divn1_0 n rh hl);trivial. - Qed. - - Variable p : w. - Variable p_bounded : [|p|] <= Zpos w_digits. - - Lemma spec_add_mul_divp : forall x y, - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Proof. - intros;apply spec_add_mul_div;auto. - Qed. - - Definition double_divn1_p_aux n - (divn1 : w -> word w n -> word w n -> word w n * w) r h l := - let (hh,hl) := double_split w_0 n h in - let (lh,ll) := double_split w_0 n l in - let (qh,rh) := divn1 r hh hl in - let (ql,rl) := divn1 rh hl lh in - (double_WW w_WW n qh ql, rl). - - Fixpoint double_divn1_p (n:nat) : w -> word w n -> word w n -> word w n * w := - match n return w -> word w n -> word w n -> word w n * w with - | O => fun r h l => w_div21 r (w_add_mul_div p h l) b2p - | S n => double_divn1_p_aux n (double_divn1_p n) - end. - - Lemma p_lt_double_digits : forall n, [|p|] <= Zpos (w_digits << n). - Proof. - induction n;simpl. trivial. - case (spec_to_Z p); rewrite Pos2Z.inj_xO;auto with zarith. - Qed. - - Lemma spec_double_divn1_p : forall n r h l, - [|r|] < [|b2p|] -> - let (q,r') := double_divn1_p n r h l in - [|r|] * double_wB w_digits n + - ([!n|h!]*2^[|p|] + - [!n|l!] / (2^(Zpos(w_digits << n) - [|p|]))) - mod double_wB w_digits n = [!n|q!] * [|b2p|] + [|r'|] /\ - 0 <= [|r'|] < [|b2p|]. - Proof. - case (spec_to_Z p); intros HH0 HH1. - induction n;intros. - simpl (double_divn1_p 0 r h l). - unfold double_to_Z, double_wB, "<<". - rewrite <- spec_add_mul_divp. - exact (spec_div21 (w_add_mul_div p h l) b2p_le H). - simpl (double_divn1_p (S n) r h l). - unfold double_divn1_p_aux. - assert (H1 := spec_split n h);destruct (double_split w_0 n h) as (hh,hl). - rewrite H1. rewrite <- double_wB_wwB. - assert (H2 := spec_split n l);destruct (double_split w_0 n l) as (lh,ll). - rewrite H2. - replace ([|r|] * (double_wB w_digits n * double_wB w_digits n) + - (([!n|hh!] * double_wB w_digits n + [!n|hl!]) * 2 ^ [|p|] + - ([!n|lh!] * double_wB w_digits n + [!n|ll!]) / - 2^(Zpos (w_digits << (S n)) - [|p|])) mod - (double_wB w_digits n * double_wB w_digits n)) with - (([|r|] * double_wB w_digits n + ([!n|hh!] * 2^[|p|] + - [!n|hl!] / 2^(Zpos (w_digits << n) - [|p|])) mod - double_wB w_digits n) * double_wB w_digits n + - ([!n|hl!] * 2^[|p|] + - [!n|lh!] / 2^(Zpos (w_digits << n) - [|p|])) mod - double_wB w_digits n). - generalize (IHn r hh hl H);destruct (double_divn1_p n r hh hl) as (qh,rh); - intros (H3,H4);rewrite H3. - assert ([|rh|] < [|b2p|]). omega. - replace (([!n|qh!] * [|b2p|] + [|rh|]) * double_wB w_digits n + - ([!n|hl!] * 2 ^ [|p|] + - [!n|lh!] / 2 ^ (Zpos (w_digits << n) - [|p|])) mod - double_wB w_digits n) with - ([!n|qh!] * [|b2p|] *double_wB w_digits n + ([|rh|]*double_wB w_digits n + - ([!n|hl!] * 2 ^ [|p|] + - [!n|lh!] / 2 ^ (Zpos (w_digits << n) - [|p|])) mod - double_wB w_digits n)). 2:ring. - generalize (IHn rh hl lh H0);destruct (double_divn1_p n rh hl lh) as (ql,rl); - intros (H5,H6);rewrite H5. - split;[rewrite spec_double_WW;trivial;ring|trivial]. - assert (Uhh := spec_double_to_Z w_digits w_to_Z spec_to_Z n hh); - unfold double_wB,base in Uhh. - assert (Uhl := spec_double_to_Z w_digits w_to_Z spec_to_Z n hl); - unfold double_wB,base in Uhl. - assert (Ulh := spec_double_to_Z w_digits w_to_Z spec_to_Z n lh); - unfold double_wB,base in Ulh. - assert (Ull := spec_double_to_Z w_digits w_to_Z spec_to_Z n ll); - unfold double_wB,base in Ull. - unfold double_wB,base. - assert (UU:=p_lt_double_digits n). - rewrite Zdiv_shift_r;auto with zarith. - 2:change (Zpos (w_digits << (S n))) - with (2*Zpos (w_digits << n));auto with zarith. - replace (2 ^ (Zpos (w_digits << (S n)) - [|p|])) with - (2^(Zpos (w_digits << n) - [|p|])*2^Zpos (w_digits << n)). - rewrite Zdiv_mult_cancel_r;auto with zarith. - rewrite Z.mul_add_distr_r with (p:= 2^[|p|]). - pattern ([!n|hl!] * 2^[|p|]) at 2; - rewrite (shift_unshift_mod (Zpos(w_digits << n))([|p|])([!n|hl!])); - auto with zarith. - rewrite Z.add_assoc. - replace - ([!n|hh!] * 2^Zpos (w_digits << n)* 2^[|p|] + - ([!n|hl!] / 2^(Zpos (w_digits << n)-[|p|])* - 2^Zpos(w_digits << n))) - with - (([!n|hh!] *2^[|p|] + double_to_Z w_digits w_to_Z n hl / - 2^(Zpos (w_digits << n)-[|p|])) - * 2^Zpos(w_digits << n));try (ring;fail). - rewrite <- Z.add_assoc. - rewrite <- (Zmod_shift_r ([|p|]));auto with zarith. - replace - (2 ^ Zpos (w_digits << n) * 2 ^ Zpos (w_digits << n)) with - (2 ^ (Zpos (w_digits << n) + Zpos (w_digits << n))). - rewrite (Zmod_shift_r (Zpos (w_digits << n)));auto with zarith. - replace (2 ^ (Zpos (w_digits << n) + Zpos (w_digits << n))) - with (2^Zpos(w_digits << n) *2^Zpos(w_digits << n)). - rewrite (Z.mul_comm (([!n|hh!] * 2 ^ [|p|] + - [!n|hl!] / 2 ^ (Zpos (w_digits << n) - [|p|])))). - rewrite Zmult_mod_distr_l;auto with zarith. - ring. - rewrite Zpower_exp;auto with zarith. - assert (0 < Zpos (w_digits << n)). unfold Z.lt;reflexivity. - auto with zarith. - apply Z_mod_lt;auto with zarith. - rewrite Zpower_exp;auto with zarith. - split;auto with zarith. - apply Zdiv_lt_upper_bound;auto with zarith. - rewrite <- Zpower_exp;auto with zarith. - replace ([|p|] + (Zpos (w_digits << n) - [|p|])) with - (Zpos(w_digits << n));auto with zarith. - rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (w_digits << (S n)) - [|p|]) with - (Zpos (w_digits << n) - [|p|] + - Zpos (w_digits << n));trivial. - change (Zpos (w_digits << (S n))) with - (2*Zpos (w_digits << n)). ring. - Qed. - - Definition double_modn1_p_aux n (modn1 : w -> word w n -> word w n -> w) r h l:= - let (hh,hl) := double_split w_0 n h in - let (lh,ll) := double_split w_0 n l in - modn1 (modn1 r hh hl) hl lh. - - Fixpoint double_modn1_p (n:nat) : w -> word w n -> word w n -> w := - match n return w -> word w n -> word w n -> w with - | O => fun r h l => snd (w_div21 r (w_add_mul_div p h l) b2p) - | S n => double_modn1_p_aux n (double_modn1_p n) - end. - - Lemma spec_double_modn1_p : forall n r h l , - double_modn1_p n r h l = snd (double_divn1_p n r h l). - Proof. - induction n;simpl;intros;trivial. - unfold double_modn1_p_aux, double_divn1_p_aux. - destruct(double_split w_0 n h)as(hh,hl);destruct(double_split w_0 n l) as (lh,ll). - rewrite (IHn r hh hl);destruct (double_divn1_p n r hh hl) as (qh,rh). - rewrite IHn;simpl;destruct (double_divn1_p n rh hl lh);trivial. - Qed. - - End DIVAUX. - - Fixpoint high (n:nat) : word w n -> w := - match n return word w n -> w with - | O => fun a => a - | S n => - fun (a:zn2z (word w n)) => - match a with - | W0 => w_0 - | WW h l => high n h - end - end. - - Lemma spec_double_digits:forall n, Zpos w_digits <= Zpos (w_digits << n). - Proof. - induction n;simpl;auto with zarith. - change (Zpos (xO (w_digits << n))) with - (2*Zpos (w_digits << n)). - assert (0 < Zpos w_digits) by reflexivity. - auto with zarith. - Qed. - - Lemma spec_high : forall n (x:word w n), - [|high n x|] = [!n|x!] / 2^(Zpos (w_digits << n) - Zpos w_digits). - Proof. - induction n;intros. - unfold high,double_to_Z. rewrite Pshiftl_nat_0. - replace (Zpos w_digits - Zpos w_digits) with 0;try ring. - simpl. rewrite <- (Zdiv_unique [|x|] 1 [|x|] 0);auto with zarith. - assert (U2 := spec_double_digits n). - assert (U3 : 0 < Zpos w_digits). exact (eq_refl Lt). - destruct x;unfold high;fold high. - unfold double_to_Z,zn2z_to_Z;rewrite spec_0. - rewrite Zdiv_0_l;trivial. - assert (U0 := spec_double_to_Z w_digits w_to_Z spec_to_Z n w0); - assert (U1 := spec_double_to_Z w_digits w_to_Z spec_to_Z n w1). - simpl [!S n|WW w0 w1!]. - unfold double_wB,base;rewrite Zdiv_shift_r;auto with zarith. - replace (2 ^ (Zpos (w_digits << (S n)) - Zpos w_digits)) with - (2^(Zpos (w_digits << n) - Zpos w_digits) * - 2^Zpos (w_digits << n)). - rewrite Zdiv_mult_cancel_r;auto with zarith. - rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (w_digits << n) - Zpos w_digits + - Zpos (w_digits << n)) with - (Zpos (w_digits << (S n)) - Zpos w_digits);trivial. - change (Zpos (w_digits << (S n))) with - (2*Zpos (w_digits << n));ring. - change (Zpos (w_digits << (S n))) with - (2*Zpos (w_digits << n)); auto with zarith. - Qed. - - Definition double_divn1 (n:nat) (a:word w n) (b:w) := - let p := w_head0 b in - match w_compare p w_0 with - | Gt => - let b2p := w_add_mul_div p b w_0 in - let ha := high n a in - let k := w_sub w_zdigits p in - let lsr_n := w_add_mul_div k w_0 in - let r0 := w_add_mul_div p w_0 ha in - let (q,r) := double_divn1_p b2p p n r0 a (double_0 w_0 n) in - (q, lsr_n r) - | _ => double_divn1_0 b n w_0 a - end. - - Lemma spec_double_divn1 : forall n a b, - 0 < [|b|] -> - let (q,r) := double_divn1 n a b in - [!n|a!] = [!n|q!] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Proof. - intros n a b H. unfold double_divn1. - case (spec_head0 H); intros H0 H1. - case (spec_to_Z (w_head0 b)); intros HH1 HH2. - rewrite spec_compare; case Z.compare_spec; - rewrite spec_0; intros H2; auto with zarith. - assert (Hv1: wB/2 <= [|b|]). - generalize H0; rewrite H2; rewrite Z.pow_0_r; - rewrite Z.mul_1_l; auto. - assert (Hv2: [|w_0|] < [|b|]). - rewrite spec_0; auto. - generalize (spec_double_divn1_0 Hv1 n a Hv2). - rewrite spec_0;rewrite Z.mul_0_l; rewrite Z.add_0_l; auto. - contradict H2; auto with zarith. - assert (HHHH : 0 < [|w_head0 b|]); auto with zarith. - assert ([|w_head0 b|] < Zpos w_digits). - case (Z.le_gt_cases (Zpos w_digits) [|w_head0 b|]); auto; intros HH. - assert (2 ^ [|w_head0 b|] < wB). - apply Z.le_lt_trans with (2 ^ [|w_head0 b|] * [|b|]);auto with zarith. - replace (2 ^ [|w_head0 b|]) with (2^[|w_head0 b|] * 1);try (ring;fail). - apply Z.mul_le_mono_nonneg;auto with zarith. - assert (wB <= 2^[|w_head0 b|]). - unfold base;apply Zpower_le_monotone;auto with zarith. omega. - assert ([|w_add_mul_div (w_head0 b) b w_0|] = - 2 ^ [|w_head0 b|] * [|b|]). - rewrite (spec_add_mul_div b w_0); auto with zarith. - rewrite spec_0;rewrite Zdiv_0_l; try omega. - rewrite Z.add_0_r; rewrite Z.mul_comm. - rewrite Zmod_small; auto with zarith. - assert (H5 := spec_to_Z (high n a)). - assert - ([|w_add_mul_div (w_head0 b) w_0 (high n a)|] - <[|w_add_mul_div (w_head0 b) b w_0|]). - rewrite H4. - rewrite spec_add_mul_div;auto with zarith. - rewrite spec_0;rewrite Z.mul_0_l;rewrite Z.add_0_l. - assert (([|high n a|]/2^(Zpos w_digits - [|w_head0 b|])) < wB). - apply Zdiv_lt_upper_bound;auto with zarith. - apply Z.lt_le_trans with wB;auto with zarith. - pattern wB at 1;replace wB with (wB*1);try ring. - apply Z.mul_le_mono_nonneg;auto with zarith. - assert (H6 := Z.pow_pos_nonneg 2 (Zpos w_digits - [|w_head0 b|])); - auto with zarith. - rewrite Zmod_small;auto with zarith. - apply Zdiv_lt_upper_bound;auto with zarith. - apply Z.lt_le_trans with wB;auto with zarith. - apply Z.le_trans with (2 ^ [|w_head0 b|] * [|b|] * 2). - rewrite <- wB_div_2; try omega. - apply Z.mul_le_mono_nonneg;auto with zarith. - pattern 2 at 1;rewrite <- Z.pow_1_r. - apply Zpower_le_monotone;split;auto with zarith. - rewrite <- H4 in H0. - assert (Hb3: [|w_head0 b|] <= Zpos w_digits); auto with zarith. - assert (H7:= spec_double_divn1_p H0 Hb3 n a (double_0 w_0 n) H6). - destruct (double_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n - (w_add_mul_div (w_head0 b) w_0 (high n a)) a - (double_0 w_0 n)) as (q,r). - assert (U:= spec_double_digits n). - rewrite spec_double_0 in H7;trivial;rewrite Zdiv_0_l in H7. - rewrite Z.add_0_r in H7. - rewrite spec_add_mul_div in H7;auto with zarith. - rewrite spec_0 in H7;rewrite Z.mul_0_l in H7;rewrite Z.add_0_l in H7. - assert (([|high n a|] / 2 ^ (Zpos w_digits - [|w_head0 b|])) mod wB - = [!n|a!] / 2^(Zpos (w_digits << n) - [|w_head0 b|])). - rewrite Zmod_small;auto with zarith. - rewrite spec_high. rewrite Zdiv_Zdiv;auto with zarith. - rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (w_digits << n) - Zpos w_digits + - (Zpos w_digits - [|w_head0 b|])) - with (Zpos (w_digits << n) - [|w_head0 b|]);trivial;ring. - assert (H8 := Z.pow_pos_nonneg 2 (Zpos w_digits - [|w_head0 b|]));auto with zarith. - split;auto with zarith. - apply Z.le_lt_trans with ([|high n a|]);auto with zarith. - apply Zdiv_le_upper_bound;auto with zarith. - pattern ([|high n a|]) at 1;rewrite <- Z.mul_1_r. - apply Z.mul_le_mono_nonneg;auto with zarith. - rewrite H8 in H7;unfold double_wB,base in H7. - rewrite <- shift_unshift_mod in H7;auto with zarith. - rewrite H4 in H7. - assert ([|w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r|] - = [|r|]/2^[|w_head0 b|]). - rewrite spec_add_mul_div. - rewrite spec_0;rewrite Z.mul_0_l;rewrite Z.add_0_l. - replace (Zpos w_digits - [|w_sub w_zdigits (w_head0 b)|]) - with ([|w_head0 b|]). - rewrite Zmod_small;auto with zarith. - assert (H9 := spec_to_Z r). - split;auto with zarith. - apply Z.le_lt_trans with ([|r|]);auto with zarith. - apply Zdiv_le_upper_bound;auto with zarith. - pattern ([|r|]) at 1;rewrite <- Z.mul_1_r. - apply Z.mul_le_mono_nonneg;auto with zarith. - assert (H10 := Z.pow_pos_nonneg 2 ([|w_head0 b|]));auto with zarith. - rewrite spec_sub. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - case (spec_to_Z w_zdigits); auto with zarith. - rewrite spec_sub. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - case (spec_to_Z w_zdigits); auto with zarith. - case H7; intros H71 H72. - split. - rewrite <- (Z_div_mult [!n|a!] (2^[|w_head0 b|]));auto with zarith. - rewrite H71;rewrite H9. - replace ([!n|q!] * (2 ^ [|w_head0 b|] * [|b|])) - with ([!n|q!] *[|b|] * 2^[|w_head0 b|]); - try (ring;fail). - rewrite Z_div_plus_l;auto with zarith. - assert (H10 := spec_to_Z - (w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r));split; - auto with zarith. - rewrite H9. - apply Zdiv_lt_upper_bound;auto with zarith. - rewrite Z.mul_comm;auto with zarith. - exact (spec_double_to_Z w_digits w_to_Z spec_to_Z n a). - Qed. - - - Definition double_modn1 (n:nat) (a:word w n) (b:w) := - let p := w_head0 b in - match w_compare p w_0 with - | Gt => - let b2p := w_add_mul_div p b w_0 in - let ha := high n a in - let k := w_sub w_zdigits p in - let lsr_n := w_add_mul_div k w_0 in - let r0 := w_add_mul_div p w_0 ha in - let r := double_modn1_p b2p p n r0 a (double_0 w_0 n) in - lsr_n r - | _ => double_modn1_0 b n w_0 a - end. - - Lemma spec_double_modn1_aux : forall n a b, - double_modn1 n a b = snd (double_divn1 n a b). - Proof. - intros n a b;unfold double_divn1,double_modn1. - rewrite spec_compare; case Z.compare_spec; - rewrite spec_0; intros H2; auto with zarith. - apply spec_double_modn1_0. - apply spec_double_modn1_0. - rewrite spec_double_modn1_p. - destruct (double_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n - (w_add_mul_div (w_head0 b) w_0 (high n a)) a (double_0 w_0 n));simpl;trivial. - Qed. - - Lemma spec_double_modn1 : forall n a b, 0 < [|b|] -> - [|double_modn1 n a b|] = [!n|a!] mod [|b|]. - Proof. - intros n a b H;assert (H1 := spec_double_divn1 n a H). - assert (H2 := spec_double_modn1_aux n a b). - rewrite H2;destruct (double_divn1 n a b) as (q,r). - simpl;apply Zmod_unique with (double_to_Z w_digits w_to_Z n q);auto with zarith. - destruct H1 as (h1,h2);rewrite h1;ring. - Qed. - -End GENDIVN1. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v deleted file mode 100644 index f65b47c8..00000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v +++ /dev/null @@ -1,475 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* w -> zn2z w. - Variable w_W0 : w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_compare : w -> w -> comparison. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - Variable w_head0 : w -> w. - Variable w_tail0 : w -> w. - Variable w_add: w -> w -> zn2z w. - Variable w_add_mul_div : w -> w -> w -> w. - Variable ww_sub: zn2z w -> zn2z w -> zn2z w. - Variable w_digits : positive. - Variable ww_Digits : positive. - Variable w_zdigits : w. - Variable ww_zdigits : zn2z w. - Variable low: zn2z w -> w. - - Definition ww_head0 x := - match x with - | W0 => ww_zdigits - | WW xh xl => - match w_compare w_0 xh with - | Eq => w_add w_zdigits (w_head0 xl) - | _ => w_0W (w_head0 xh) - end - end. - - - Definition ww_tail0 x := - match x with - | W0 => ww_zdigits - | WW xh xl => - match w_compare w_0 xl with - | Eq => w_add w_zdigits (w_tail0 xh) - | _ => w_0W (w_tail0 xl) - end - end. - - - (* 0 < p < ww_digits *) - Definition ww_add_mul_div p x y := - let zdigits := w_0W w_zdigits in - match x, y with - | W0, W0 => W0 - | W0, WW yh yl => - match ww_compare p zdigits with - | Eq => w_0W yh - | Lt => w_0W (w_add_mul_div (low p) w_0 yh) - | Gt => - let n := low (ww_sub p zdigits) in - w_WW (w_add_mul_div n w_0 yh) (w_add_mul_div n yh yl) - end - | WW xh xl, W0 => - match ww_compare p zdigits with - | Eq => w_W0 xl - | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl w_0) - | Gt => - let n := low (ww_sub p zdigits) in - w_W0 (w_add_mul_div n xl w_0) - end - | WW xh xl, WW yh yl => - match ww_compare p zdigits with - | Eq => w_WW xl yh - | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl yh) - | Gt => - let n := low (ww_sub p zdigits) in - w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl) - end - end. - - Section DoubleProof. - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_compare : forall x y, - w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_ww_compare : forall x y, - ww_compare x y = Z.compare [[x]] [[y]]. - Variable spec_ww_digits : ww_Digits = xO w_digits. - Variable spec_w_head00 : forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits. - Variable spec_w_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB. - Variable spec_w_tail00 : forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits. - Variable spec_w_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2* y + 1) * (2 ^ [|w_tail0 x|]). - Variable spec_w_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_w_add: forall x y, - [[w_add x y]] = [|x|] + [|y|]. - Variable spec_ww_sub: forall x y, - [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - - Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits. - Variable spec_low: forall x, [| low x|] = [[x]] mod wB. - - Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos ww_Digits. - - Hint Resolve div_le_0 div_lt w_to_Z_wwB: lift. - Ltac zarith := auto with zarith lift. - - Lemma spec_ww_head00 : forall x, [[x]] = 0 -> [[ww_head0 x]] = Zpos ww_Digits. - Proof. - intros x; case x; unfold ww_head0. - intros HH; rewrite spec_ww_zdigits; auto. - intros xh xl; simpl; intros Hx. - case (spec_to_Z xh); intros Hx1 Hx2. - case (spec_to_Z xl); intros Hy1 Hy2. - assert (F1: [|xh|] = 0). - { Z.le_elim Hy1; auto. - - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. - apply Z.lt_le_trans with (1 := Hy1); auto with zarith. - pattern [|xl|] at 1; rewrite <- (Z.add_0_l [|xl|]). - apply Z.add_le_mono_r; auto with zarith. - - Z.le_elim Hx1; auto. - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. - rewrite <- Hy1; rewrite Z.add_0_r; auto with zarith. - apply Z.mul_pos_pos; auto with zarith. } - rewrite spec_compare. case Z.compare_spec. - intros H; simpl. - rewrite spec_w_add; rewrite spec_w_head00. - rewrite spec_zdigits; rewrite spec_ww_digits. - rewrite Pos2Z.inj_xO; auto with zarith. - rewrite F1 in Hx; auto with zarith. - rewrite spec_w_0; auto with zarith. - rewrite spec_w_0; auto with zarith. - Qed. - - Lemma spec_ww_head0 : forall x, 0 < [[x]] -> - wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB. - Proof. - clear spec_ww_zdigits. - rewrite wwB_div_2;rewrite Z.mul_comm;rewrite wwB_wBwB. - assert (U:= lt_0_wB w_digits); destruct x as [ |xh xl];simpl ww_to_Z;intros H. - unfold Z.lt in H;discriminate H. - rewrite spec_compare, spec_w_0. case Z.compare_spec; intros H0. - rewrite <- H0 in *. simpl Z.add. simpl in H. - case (spec_to_Z w_zdigits); - case (spec_to_Z (w_head0 xl)); intros HH1 HH2 HH3 HH4. - rewrite spec_w_add. - rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith. - case (spec_w_head0 H); intros H1 H2. - rewrite Z.pow_2_r; fold wB; rewrite <- Z.mul_assoc; split. - apply Z.mul_le_mono_nonneg_l; auto with zarith. - apply Z.mul_lt_mono_pos_l; auto with zarith. - assert (H1 := spec_w_head0 H0). - rewrite spec_w_0W. - split. - rewrite Z.mul_add_distr_l;rewrite Z.mul_assoc. - apply Z.le_trans with (2 ^ [|w_head0 xh|] * [|xh|] * wB). - rewrite Z.mul_comm; zarith. - assert (0 <= 2 ^ [|w_head0 xh|] * [|xl|]);zarith. - assert (H2:=spec_to_Z xl);apply Z.mul_nonneg_nonneg;zarith. - case (spec_to_Z (w_head0 xh)); intros H2 _. - generalize ([|w_head0 xh|]) H1 H2;clear H1 H2; - intros p H1 H2. - assert (Eq1 : 2^p < wB). - rewrite <- (Z.mul_1_r (2^p));apply Z.le_lt_trans with (2^p*[|xh|]);zarith. - assert (Eq2: p < Zpos w_digits). - destruct (Z.le_gt_cases (Zpos w_digits) p);trivial;contradict Eq1. - apply Z.le_ngt;unfold base;apply Zpower_le_monotone;zarith. - assert (Zpos w_digits = p + (Zpos w_digits - p)). ring. - rewrite Z.pow_2_r. - unfold base at 2;rewrite H3;rewrite Zpower_exp;zarith. - rewrite <- Z.mul_assoc; apply Z.mul_lt_mono_pos_l; zarith. - rewrite <- (Z.add_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith. - apply Z.mul_lt_mono_pos_r with (2 ^ p); zarith. - rewrite <- Zpower_exp;zarith. - rewrite Z.mul_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith. - assert (H1 := spec_to_Z xh);zarith. - Qed. - - Lemma spec_ww_tail00 : forall x, [[x]] = 0 -> [[ww_tail0 x]] = Zpos ww_Digits. - Proof. - intros x; case x; unfold ww_tail0. - intros HH; rewrite spec_ww_zdigits; auto. - intros xh xl; simpl; intros Hx. - case (spec_to_Z xh); intros Hx1 Hx2. - case (spec_to_Z xl); intros Hy1 Hy2. - assert (F1: [|xh|] = 0). - { Z.le_elim Hy1; auto. - - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. - apply Z.lt_le_trans with (1 := Hy1); auto with zarith. - pattern [|xl|] at 1; rewrite <- (Z.add_0_l [|xl|]). - apply Z.add_le_mono_r; auto with zarith. - - Z.le_elim Hx1; auto. - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. - rewrite <- Hy1; rewrite Z.add_0_r; auto with zarith. - apply Z.mul_pos_pos; auto with zarith. } - assert (F2: [|xl|] = 0). - rewrite F1 in Hx; auto with zarith. - rewrite spec_compare; case Z.compare_spec. - intros H; simpl. - rewrite spec_w_add; rewrite spec_w_tail00; auto. - rewrite spec_zdigits; rewrite spec_ww_digits. - rewrite Pos2Z.inj_xO; auto with zarith. - rewrite spec_w_0; auto with zarith. - rewrite spec_w_0; auto with zarith. - Qed. - - Lemma spec_ww_tail0 : forall x, 0 < [[x]] -> - exists y, 0 <= y /\ [[x]] = (2 * y + 1) * 2 ^ [[ww_tail0 x]]. - Proof. - clear spec_ww_zdigits. - destruct x as [ |xh xl];simpl ww_to_Z;intros H. - unfold Z.lt in H;discriminate H. - rewrite spec_compare, spec_w_0. case Z.compare_spec; intros H0. - rewrite <- H0; rewrite Z.add_0_r. - case (spec_to_Z (w_tail0 xh)); intros HH1 HH2. - generalize H; rewrite <- H0; rewrite Z.add_0_r; clear H; intros H. - case (@spec_w_tail0 xh). - apply Z.mul_lt_mono_pos_r with wB; auto with zarith. - unfold base; auto with zarith. - intros z (Hz1, Hz2); exists z; split; auto. - rewrite spec_w_add; rewrite (fun x => Z.add_comm [|x|]). - rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith. - rewrite Z.mul_assoc; rewrite <- Hz2; auto. - - case (spec_to_Z (w_tail0 xh)); intros HH1 HH2. - case (spec_w_tail0 H0); intros z (Hz1, Hz2). - assert (Hp: [|w_tail0 xl|] < Zpos w_digits). - case (Z.le_gt_cases (Zpos w_digits) [|w_tail0 xl|]); auto; intros H1. - absurd (2 ^ (Zpos w_digits) <= 2 ^ [|w_tail0 xl|]). - apply Z.lt_nge. - case (spec_to_Z xl); intros HH3 HH4. - apply Z.le_lt_trans with (2 := HH4). - apply Z.le_trans with (1 * 2 ^ [|w_tail0 xl|]); auto with zarith. - rewrite Hz2. - apply Z.mul_le_mono_nonneg_r; auto with zarith. - apply Zpower_le_monotone; auto with zarith. - exists ([|xh|] * (2 ^ ((Zpos w_digits - [|w_tail0 xl|]) - 1)) + z); split. - apply Z.add_nonneg_nonneg; auto. - apply Z.mul_nonneg_nonneg; auto with zarith. - case (spec_to_Z xh); auto. - rewrite spec_w_0W. - rewrite (Z.mul_add_distr_l 2); rewrite <- Z.add_assoc. - rewrite Z.mul_add_distr_r; rewrite <- Hz2. - apply f_equal2 with (f := Z.add); auto. - rewrite (Z.mul_comm 2). - repeat rewrite <- Z.mul_assoc. - apply f_equal2 with (f := Z.mul); auto. - case (spec_to_Z (w_tail0 xl)); intros HH3 HH4. - pattern 2 at 2; rewrite <- Z.pow_1_r. - lazy beta; repeat rewrite <- Zpower_exp; auto with zarith. - unfold base; apply f_equal with (f := Z.pow 2); auto with zarith. - - contradict H0; case (spec_to_Z xl); auto with zarith. - Qed. - - Hint Rewrite Zdiv_0_l Z.mul_0_l Z.add_0_l Z.mul_0_r Z.add_0_r - spec_w_W0 spec_w_0W spec_w_WW spec_w_0 - (wB_div w_digits w_to_Z spec_to_Z) - (wB_div_plus w_digits w_to_Z spec_to_Z) : w_rewrite. - Ltac w_rewrite := autorewrite with w_rewrite;trivial. - - Lemma spec_ww_add_mul_div_aux : forall xh xl yh yl p, - let zdigits := w_0W w_zdigits in - [[p]] <= Zpos (xO w_digits) -> - [[match ww_compare p zdigits with - | Eq => w_WW xl yh - | Lt => w_WW (w_add_mul_div (low p) xh xl) - (w_add_mul_div (low p) xl yh) - | Gt => - let n := low (ww_sub p zdigits) in - w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl) - end]] = - ([[WW xh xl]] * (2^[[p]]) + - [[WW yh yl]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. - Proof. - clear spec_ww_zdigits. - intros xh xl yh yl p zdigits;assert (HwwB := wwB_pos w_digits). - case (spec_to_w_Z p); intros Hv1 Hv2. - replace (Zpos (xO w_digits)) with (Zpos w_digits + Zpos w_digits). - 2 : rewrite Pos2Z.inj_xO;ring. - replace (Zpos w_digits + Zpos w_digits - [[p]]) with - (Zpos w_digits + (Zpos w_digits - [[p]])). 2:ring. - intros Hp; assert (Hxh := spec_to_Z xh);assert (Hxl:=spec_to_Z xl); - assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)); - simpl in Hx;assert (Hyh := spec_to_Z yh);assert (Hyl:=spec_to_Z yl); - assert (Hy:=spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW yh yl));simpl in Hy. - rewrite spec_ww_compare; case Z.compare_spec; intros H1. - rewrite H1; unfold zdigits; rewrite spec_w_0W. - rewrite spec_zdigits; rewrite Z.sub_diag; rewrite Z.add_0_r. - simpl ww_to_Z; w_rewrite;zarith. - fold wB. - rewrite Z.mul_add_distr_r;rewrite <- Z.mul_assoc;rewrite <- Z.add_assoc. - rewrite <- Z.pow_2_r. - rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|]. - exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xl yh)). ring. - simpl ww_to_Z; w_rewrite;zarith. - assert (HH0: [|low p|] = [[p]]). - rewrite spec_low. - apply Zmod_small. - case (spec_to_w_Z p); intros HH1 HH2; split; auto. - generalize H1; unfold zdigits; rewrite spec_w_0W; - rewrite spec_zdigits; intros tmp. - apply Z.lt_le_trans with (1 := tmp). - unfold base. - apply Zpower2_le_lin; auto with zarith. - 2: generalize H1; unfold zdigits; rewrite spec_w_0W; - rewrite spec_zdigits; auto with zarith. - generalize H1; unfold zdigits; rewrite spec_w_0W; - rewrite spec_zdigits; auto; clear H1; intros H1. - assert (HH: [|low p|] <= Zpos w_digits). - rewrite HH0; auto with zarith. - repeat rewrite spec_w_add_mul_div with (1 := HH). - rewrite HH0. - rewrite Z.mul_add_distr_r. - pattern ([|xl|] * 2 ^ [[p]]) at 2; - rewrite shift_unshift_mod with (n:= Zpos w_digits);fold wB;zarith. - replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. rewrite <- Z.add_assoc. - unfold base at 5;rewrite <- Zmod_shift_r;zarith. - unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); - fold wB;fold wwB;zarith. - rewrite wwB_wBwB;rewrite Z.pow_2_r; rewrite Zmult_mod_distr_r;zarith. - unfold ww_digits;rewrite Pos2Z.inj_xO;zarith. apply Z_mod_lt;zarith. - split;zarith. apply Zdiv_lt_upper_bound;zarith. - rewrite <- Zpower_exp;zarith. - ring_simplify ([[p]] + (Zpos w_digits - [[p]]));fold wB;zarith. - assert (Hv: [[p]] > Zpos w_digits). - generalize H1; clear H1. - unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits; auto with zarith. - clear H1. - assert (HH0: [|low (ww_sub p zdigits)|] = [[p]] - Zpos w_digits). - rewrite spec_low. - rewrite spec_ww_sub. - unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits. - rewrite <- Zmod_div_mod; auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.le_lt_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_lt_lin; auto with zarith. - exists wB; unfold base. - unfold ww_digits; rewrite (Pos2Z.inj_xO w_digits). - rewrite <- Zpower_exp; auto with zarith. - apply f_equal with (f := fun x => 2 ^ x); auto with zarith. - assert (HH: [|low (ww_sub p zdigits)|] <= Zpos w_digits). - rewrite HH0; auto with zarith. - replace (Zpos w_digits + (Zpos w_digits - [[p]])) with - (Zpos w_digits - ([[p]] - Zpos w_digits)); zarith. - lazy zeta; simpl ww_to_Z; w_rewrite;zarith. - repeat rewrite spec_w_add_mul_div;zarith. - rewrite HH0. - pattern wB at 5;replace wB with - (2^(([[p]] - Zpos w_digits) - + (Zpos w_digits - ([[p]] - Zpos w_digits)))). - rewrite Zpower_exp;zarith. rewrite Z.mul_assoc. - rewrite Z_div_plus_l;zarith. - rewrite shift_unshift_mod with (a:= [|yh|]) (p:= [[p]] - Zpos w_digits) - (n := Zpos w_digits);zarith. fold wB. - set (u := [[p]] - Zpos w_digits). - replace [[p]] with (u + Zpos w_digits);zarith. - rewrite Zpower_exp;zarith. rewrite Z.mul_assoc. fold wB. - repeat rewrite Z.add_assoc. rewrite <- Z.mul_add_distr_r. - repeat rewrite <- Z.add_assoc. - unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); - fold wB;fold wwB;zarith. - unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits) - (b:= Zpos w_digits);fold wB;fold wwB;zarith. - rewrite wwB_wBwB; rewrite Z.pow_2_r; rewrite Zmult_mod_distr_r;zarith. - rewrite Z.mul_add_distr_r. - replace ([|xh|] * wB * 2 ^ u) with - ([|xh|]*2^u*wB). 2:ring. - repeat rewrite <- Z.add_assoc. - rewrite (Z.add_comm ([|xh|] * 2 ^ u * wB)). - rewrite Z_mod_plus;zarith. rewrite Z_mod_mult;zarith. - unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. - unfold u; split;zarith. - split;zarith. unfold u; apply Zdiv_lt_upper_bound;zarith. - rewrite <- Zpower_exp;zarith. - fold u. - ring_simplify (u + (Zpos w_digits - u)); fold - wB;zarith. unfold ww_digits;rewrite Pos2Z.inj_xO;zarith. - unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. - unfold u; split;zarith. - unfold u; split;zarith. - apply Zdiv_lt_upper_bound;zarith. - rewrite <- Zpower_exp;zarith. - fold u. - ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith. - unfold u;zarith. - unfold u;zarith. - set (u := [[p]] - Zpos w_digits). - ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith. - Qed. - - Lemma spec_ww_add_mul_div : forall x y p, - [[p]] <= Zpos (xO w_digits) -> - [[ ww_add_mul_div p x y ]] = - ([[x]] * (2^[[p]]) + - [[y]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. - Proof. - clear spec_ww_zdigits. - intros x y p H. - destruct x as [ |xh xl]; - [assert (H1 := @spec_ww_add_mul_div_aux w_0 w_0) - |assert (H1 := @spec_ww_add_mul_div_aux xh xl)]; - (destruct y as [ |yh yl]; - [generalize (H1 w_0 w_0 p H) | generalize (H1 yh yl p H)]; - clear H1;w_rewrite);simpl ww_add_mul_div. - replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. - intros Heq;rewrite <- Heq;clear Heq; auto. - rewrite spec_ww_compare. case Z.compare_spec; intros H1; w_rewrite. - rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. - generalize H1; w_rewrite; rewrite spec_zdigits; clear H1; intros H1. - assert (HH0: [|low p|] = [[p]]). - rewrite spec_low. - apply Zmod_small. - case (spec_to_w_Z p); intros HH1 HH2; split; auto. - apply Z.lt_le_trans with (1 := H1). - unfold base; apply Zpower2_le_lin; auto with zarith. - rewrite HH0; auto with zarith. - replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. - intros Heq;rewrite <- Heq;clear Heq. - generalize (spec_ww_compare p (w_0W w_zdigits)); - case ww_compare; intros H1; w_rewrite. - rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. - rewrite Pos2Z.inj_xO in H;zarith. - assert (HH: [|low (ww_sub p (w_0W w_zdigits)) |] = [[p]] - Zpos w_digits). - symmetry in H1; change ([[p]] > [[w_0W w_zdigits]]) in H1. - revert H1. - rewrite spec_low. - rewrite spec_ww_sub; w_rewrite; intros H1. - rewrite <- Zmod_div_mod; auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.le_lt_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_lt_lin; auto with zarith. - unfold base; auto with zarith. - unfold base; auto with zarith. - exists wB; unfold base. - unfold ww_digits; rewrite (Pos2Z.inj_xO w_digits). - rewrite <- Zpower_exp; auto with zarith. - apply f_equal with (f := fun x => 2 ^ x); auto with zarith. - case (spec_to_Z xh); auto with zarith. - Qed. - - End DoubleProof. - -End DoubleLift. - diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v deleted file mode 100644 index b9901390..00000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v +++ /dev/null @@ -1,621 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* w -> zn2z w. - Variable w_W0 : w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_compare : w -> w -> comparison. - Variable w_succ : w -> w. - Variable w_add_c : w -> w -> carry w. - Variable w_add : w -> w -> w. - Variable w_sub: w -> w -> w. - Variable w_mul_c : w -> w -> zn2z w. - Variable w_mul : w -> w -> w. - Variable w_square_c : w -> zn2z w. - Variable ww_add_c : zn2z w -> zn2z w -> carry (zn2z w). - Variable ww_add : zn2z w -> zn2z w -> zn2z w. - Variable ww_add_carry : zn2z w -> zn2z w -> zn2z w. - Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). - Variable ww_sub : zn2z w -> zn2z w -> zn2z w. - - (* ** Multiplication ** *) - - (* (xh*B+xl) (yh*B + yl) - xh*yh = hh = |hhh|hhl|B2 - xh*yl +xl*yh = cc = |cch|ccl|B - xl*yl = ll = |llh|lll - *) - - Definition double_mul_c (cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w) x y := - match x, y with - | W0, _ => W0 - | _, W0 => W0 - | WW xh xl, WW yh yl => - let hh := w_mul_c xh yh in - let ll := w_mul_c xl yl in - let (wc,cc) := cross xh xl yh yl hh ll in - match cc with - | W0 => WW (ww_add hh (w_W0 wc)) ll - | WW cch ccl => - match ww_add_c (w_W0 ccl) ll with - | C0 l => WW (ww_add hh (w_WW wc cch)) l - | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l - end - end - end. - - Definition ww_mul_c := - double_mul_c - (fun xh xl yh yl hh ll=> - match ww_add_c (w_mul_c xh yl) (w_mul_c xl yh) with - | C0 cc => (w_0, cc) - | C1 cc => (w_1, cc) - end). - - Definition w_2 := w_add w_1 w_1. - - Definition kara_prod xh xl yh yl hh ll := - match ww_add_c hh ll with - C0 m => - match w_compare xl xh with - Eq => (w_0, m) - | Lt => - match w_compare yl yh with - Eq => (w_0, m) - | Lt => (w_0, ww_sub m (w_mul_c (w_sub xh xl) (w_sub yh yl))) - | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with - C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1) - end - end - | Gt => - match w_compare yl yh with - Eq => (w_0, m) - | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with - C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1) - end - | Gt => (w_0, ww_sub m (w_mul_c (w_sub xl xh) (w_sub yl yh))) - end - end - | C1 m => - match w_compare xl xh with - Eq => (w_1, m) - | Lt => - match w_compare yl yh with - Eq => (w_1, m) - | Lt => match ww_sub_c m (w_mul_c (w_sub xh xl) (w_sub yh yl)) with - C0 m1 => (w_1, m1) | C1 m1 => (w_0, m1) - end - | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with - C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1) - end - end - | Gt => - match w_compare yl yh with - Eq => (w_1, m) - | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with - C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1) - end - | Gt => match ww_sub_c m (w_mul_c (w_sub xl xh) (w_sub yl yh)) with - C1 m1 => (w_0, m1) | C0 m1 => (w_1, m1) - end - end - end - end. - - Definition ww_karatsuba_c := double_mul_c kara_prod. - - Definition ww_mul x y := - match x, y with - | W0, _ => W0 - | _, W0 => W0 - | WW xh xl, WW yh yl => - let ccl := w_add (w_mul xh yl) (w_mul xl yh) in - ww_add (w_W0 ccl) (w_mul_c xl yl) - end. - - Definition ww_square_c x := - match x with - | W0 => W0 - | WW xh xl => - let hh := w_square_c xh in - let ll := w_square_c xl in - let xhxl := w_mul_c xh xl in - let (wc,cc) := - match ww_add_c xhxl xhxl with - | C0 cc => (w_0, cc) - | C1 cc => (w_1, cc) - end in - match cc with - | W0 => WW (ww_add hh (w_W0 wc)) ll - | WW cch ccl => - match ww_add_c (w_W0 ccl) ll with - | C0 l => WW (ww_add hh (w_WW wc cch)) l - | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l - end - end - end. - - Section DoubleMulAddn1. - Variable w_mul_add : w -> w -> w -> w * w. - - Fixpoint double_mul_add_n1 (n:nat) : word w n -> w -> w -> w * word w n := - match n return word w n -> w -> w -> w * word w n with - | O => w_mul_add - | S n1 => - let mul_add := double_mul_add_n1 n1 in - fun x y r => - match x with - | W0 => (w_0,extend w_0W n1 r) - | WW xh xl => - let (rl,l) := mul_add xl y r in - let (rh,h) := mul_add xh y rl in - (rh, double_WW w_WW n1 h l) - end - end. - - End DoubleMulAddn1. - - Section DoubleMulAddmn1. - Variable wn: Type. - Variable extend_n : w -> wn. - Variable wn_0W : wn -> zn2z wn. - Variable wn_WW : wn -> wn -> zn2z wn. - Variable w_mul_add_n1 : wn -> w -> w -> w*wn. - Fixpoint double_mul_add_mn1 (m:nat) : - word wn m -> w -> w -> w*word wn m := - match m return word wn m -> w -> w -> w*word wn m with - | O => w_mul_add_n1 - | S m1 => - let mul_add := double_mul_add_mn1 m1 in - fun x y r => - match x with - | W0 => (w_0,extend wn_0W m1 (extend_n r)) - | WW xh xl => - let (rl,l) := mul_add xl y r in - let (rh,h) := mul_add xh y rl in - (rh, double_WW wn_WW m1 h l) - end - end. - - End DoubleMulAddmn1. - - Definition w_mul_add x y r := - match w_mul_c x y with - | W0 => (w_0, r) - | WW h l => - match w_add_c l r with - | C0 lr => (h,lr) - | C1 lr => (w_succ h, lr) - end - end. - - - (*Section DoubleProof. *) - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - - Notation "[|| x ||]" := - (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x) (at level 0, x at level 99). - - Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) - (at level 0, x at level 99). - - Variable spec_more_than_1_digit: 1 < Zpos w_digits. - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_w_compare : - forall x y, w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB. - Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. - Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - - Variable spec_w_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|]. - Variable spec_w_mul : forall x y, [|w_mul x y|] = ([|x|] * [|y|]) mod wB. - Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|]. - - Variable spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. - Variable spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. - Variable spec_ww_add_carry : - forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB. - Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - - - Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB. - Proof. intros x;apply spec_ww_to_Z;auto. Qed. - - Lemma spec_ww_to_Z_wBwB : forall x, 0 <= [[x]] < wB^2. - Proof. rewrite <- wwB_wBwB;apply spec_ww_to_Z. Qed. - - Hint Resolve spec_ww_to_Z spec_ww_to_Z_wBwB : mult. - Ltac zarith := auto with zarith mult. - - Lemma wBwB_lex: forall a b c d, - a * wB^2 + [[b]] <= c * wB^2 + [[d]] -> - a <= c. - Proof. - intros a b c d H; apply beta_lex with [[b]] [[d]] (wB^2);zarith. - Qed. - - Lemma wBwB_lex_inv: forall a b c d, - a < c -> - a * wB^2 + [[b]] < c * wB^2 + [[d]]. - Proof. - intros a b c d H; apply beta_lex_inv; zarith. - Qed. - - Lemma sum_mul_carry : forall xh xl yh yl wc cc, - [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> - 0 <= [|wc|] <= 1. - Proof. - intros. - apply (sum_mul_carry [|xh|] [|xl|] [|yh|] [|yl|] [|wc|][[cc]] wB);zarith. - apply wB_pos. - Qed. - - Theorem mult_add_ineq: forall xH yH crossH, - 0 <= [|xH|] * [|yH|] + [|crossH|] < wwB. - Proof. - intros;rewrite wwB_wBwB;apply mult_add_ineq;zarith. - Qed. - - Hint Resolve mult_add_ineq : mult. - - Lemma spec_mul_aux : forall xh xl yh yl wc (cc:zn2z w) hh ll, - [[hh]] = [|xh|] * [|yh|] -> - [[ll]] = [|xl|] * [|yl|] -> - [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> - [||match cc with - | W0 => WW (ww_add hh (w_W0 wc)) ll - | WW cch ccl => - match ww_add_c (w_W0 ccl) ll with - | C0 l => WW (ww_add hh (w_WW wc cch)) l - | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l - end - end||] = ([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|]). - Proof. - intros;assert (U1 := wB_pos w_digits). - replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with - ([|xh|]*[|yh|]*wB^2 + ([|xh|]*[|yl|] + [|xl|]*[|yh|])*wB + [|xl|]*[|yl|]). - 2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0. - assert (H2 := sum_mul_carry _ _ _ _ _ _ H1). - destruct cc as [ | cch ccl]; simpl zn2z_to_Z; simpl ww_to_Z. - rewrite spec_ww_add;rewrite spec_w_W0;rewrite Zmod_small; - rewrite wwB_wBwB. ring. - rewrite <- (Z.add_0_r ([|wc|]*wB));rewrite H;apply mult_add_ineq3;zarith. - simpl ww_to_Z in H1. assert (U:=spec_to_Z cch). - assert ([|wc|]*wB + [|cch|] <= 2*wB - 3). - destruct (Z_le_gt_dec ([|wc|]*wB + [|cch|]) (2*wB - 3)) as [Hle|Hgt];trivial. - assert ([|xh|] * [|yl|] + [|xl|] * [|yh|] <= (2*wB - 4)*wB + 2). - ring_simplify ((2*wB - 4)*wB + 2). - assert (H4 := Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)). - assert (H5 := Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)). - omega. - generalize H3;clear H3;rewrite <- H1. - rewrite Z.add_assoc; rewrite Z.pow_2_r; rewrite Z.mul_assoc; - rewrite <- Z.mul_add_distr_r. - assert (((2 * wB - 4) + 2)*wB <= ([|wc|] * wB + [|cch|])*wB). - apply Z.mul_le_mono_nonneg;zarith. - rewrite Z.mul_add_distr_r in H3. - intros. assert (U2 := spec_to_Z ccl);omega. - generalize (spec_ww_add_c (w_W0 ccl) ll);destruct (ww_add_c (w_W0 ccl) ll) - as [l|l];unfold interp_carry;rewrite spec_w_W0;try rewrite Z.mul_1_l; - simpl zn2z_to_Z; - try rewrite spec_ww_add;try rewrite spec_ww_add_carry;rewrite spec_w_WW; - rewrite Zmod_small;rewrite wwB_wBwB;intros. - rewrite H4;ring. rewrite H;apply mult_add_ineq2;zarith. - rewrite Z.add_assoc;rewrite Z.mul_add_distr_r. - rewrite Z.mul_1_l;rewrite <- Z.add_assoc;rewrite H4;ring. - repeat rewrite <- Z.add_assoc;rewrite H;apply mult_add_ineq2;zarith. - Qed. - - Lemma spec_double_mul_c : forall cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w, - (forall xh xl yh yl hh ll, - [[hh]] = [|xh|]*[|yh|] -> - [[ll]] = [|xl|]*[|yl|] -> - let (wc,cc) := cross xh xl yh yl hh ll in - [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) -> - forall x y, [||double_mul_c cross x y||] = [[x]] * [[y]]. - Proof. - intros cross Hcross x y;destruct x as [ |xh xl];simpl;trivial. - destruct y as [ |yh yl];simpl. rewrite Z.mul_0_r;trivial. - assert (H1:= spec_w_mul_c xh yh);assert (H2:= spec_w_mul_c xl yl). - generalize (Hcross _ _ _ _ _ _ H1 H2). - destruct (cross xh xl yh yl (w_mul_c xh yh) (w_mul_c xl yl)) as (wc,cc). - intros;apply spec_mul_aux;trivial. - rewrite <- wwB_wBwB;trivial. - Qed. - - Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]]. - Proof. - intros x y;unfold ww_mul_c;apply spec_double_mul_c. - intros xh xl yh yl hh ll H1 H2. - generalize (spec_ww_add_c (w_mul_c xh yl) (w_mul_c xl yh)); - destruct (ww_add_c (w_mul_c xh yl) (w_mul_c xl yh)) as [c|c]; - unfold interp_carry;repeat rewrite spec_w_mul_c;intros H; - (rewrite spec_w_0 || rewrite spec_w_1);rewrite H;ring. - Qed. - - Lemma spec_w_2: [|w_2|] = 2. - unfold w_2; rewrite spec_w_add; rewrite spec_w_1; simpl. - apply Zmod_small; split; auto with zarith. - rewrite <- (Z.pow_1_r 2); unfold base; apply Zpower_lt_monotone; auto with zarith. - Qed. - - Lemma kara_prod_aux : forall xh xl yh yl, - xh*yh + xl*yl - (xh-xl)*(yh-yl) = xh*yl + xl*yh. - Proof. intros;ring. Qed. - - Lemma spec_kara_prod : forall xh xl yh yl hh ll, - [[hh]] = [|xh|]*[|yh|] -> - [[ll]] = [|xl|]*[|yl|] -> - let (wc,cc) := kara_prod xh xl yh yl hh ll in - [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]. - Proof. - intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux; - rewrite <- H; rewrite <- H0; unfold kara_prod. - assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl)); - assert (Hyh := (spec_to_Z yh)); assert (Hyl := (spec_to_Z yl)). - generalize (spec_ww_add_c hh ll); case (ww_add_c hh ll); - intros z Hz; rewrite <- Hz; unfold interp_carry; assert (Hz1 := (spec_ww_to_Z z)). - rewrite spec_w_compare; case Z.compare_spec; intros Hxlh; - try rewrite Hxlh; try rewrite spec_w_0; try (ring; fail). - rewrite spec_w_compare; case Z.compare_spec; intros Hylh. - rewrite Hylh; rewrite spec_w_0; try (ring; fail). - rewrite spec_w_0; try (ring; fail). - repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - split; auto with zarith. - simpl in Hz; rewrite Hz; rewrite H; rewrite H0. - rewrite kara_prod_aux; apply Z.add_nonneg_nonneg; apply Z.mul_nonneg_nonneg; auto with zarith. - apply Z.le_lt_trans with ([[z]]-0); auto with zarith. - unfold Z.sub; apply Z.add_le_mono_l; apply Z.le_0_sub; simpl; rewrite Z.opp_involutive. - apply Z.mul_nonneg_nonneg; auto with zarith. - match goal with |- context[ww_add_c ?x ?y] => - generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2; - repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_compare; case Z.compare_spec; intros Hylh. - rewrite Hylh; rewrite spec_w_0; try (ring; fail). - match goal with |- context[ww_add_c ?x ?y] => - generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2; - repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_0; try (ring; fail). - repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - split. - match goal with |- context[(?x - ?y) * (?z - ?t)] => - replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring] - end. - simpl in Hz; rewrite Hz; rewrite H; rewrite H0. - rewrite kara_prod_aux; apply Z.add_nonneg_nonneg; apply Z.mul_nonneg_nonneg; auto with zarith. - apply Z.le_lt_trans with ([[z]]-0); auto with zarith. - unfold Z.sub; apply Z.add_le_mono_l; apply Z.le_0_sub; simpl; rewrite Z.opp_involutive. - apply Z.mul_nonneg_nonneg; auto with zarith. - (** there is a carry in hh + ll **) - rewrite Z.mul_1_l. - rewrite spec_w_compare; case Z.compare_spec; intros Hxlh; - try rewrite Hxlh; try rewrite spec_w_1; try (ring; fail). - rewrite spec_w_compare; case Z.compare_spec; intros Hylh; - try rewrite Hylh; try rewrite spec_w_1; try (ring; fail). - match goal with |- context[ww_sub_c ?x ?y] => - generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_0; rewrite Z.mul_0_l; rewrite Z.add_0_l. - generalize Hz2; clear Hz2; unfold interp_carry. - repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - match goal with |- context[ww_add_c ?x ?y] => - generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_2; unfold interp_carry in Hz2. - transitivity (wwB + (1 * wwB + [[z1]])). - ring. - rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_compare; case Z.compare_spec; intros Hylh; - try rewrite Hylh; try rewrite spec_w_1; try (ring; fail). - match goal with |- context[ww_add_c ?x ?y] => - generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_2; unfold interp_carry in Hz2. - transitivity (wwB + (1 * wwB + [[z1]])). - ring. - rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - match goal with |- context[ww_sub_c ?x ?y] => - generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_0; rewrite Z.mul_0_l; rewrite Z.add_0_l. - match goal with |- context[(?x - ?y) * (?z - ?t)] => - replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring] - end. - generalize Hz2; clear Hz2; unfold interp_carry. - repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - Qed. - - Lemma sub_carry : forall xh xl yh yl z, - 0 <= z -> - [|xh|]*[|yl|] + [|xl|]*[|yh|] = wwB + z -> - z < wwB. - Proof. - intros xh xl yh yl z Hle Heq. - destruct (Z_le_gt_dec wwB z);auto with zarith. - generalize (Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)). - generalize (Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)). - rewrite <- wwB_wBwB;intros H1 H2. - assert (H3 := wB_pos w_digits). - assert (2*wB <= wwB). - rewrite wwB_wBwB; rewrite Z.pow_2_r; apply Z.mul_le_mono_nonneg;zarith. - omega. - Qed. - - Ltac Spec_ww_to_Z x := - let H:= fresh "H" in - assert (H:= spec_ww_to_Z x). - - Ltac Zmult_lt_b x y := - let H := fresh "H" in - assert (H := Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)). - - Lemma spec_ww_karatsuba_c : forall x y, [||ww_karatsuba_c x y||]=[[x]]*[[y]]. - Proof. - intros x y; unfold ww_karatsuba_c;apply spec_double_mul_c. - intros; apply spec_kara_prod; auto. - Qed. - - Lemma spec_ww_mul : forall x y, [[ww_mul x y]] = [[x]]*[[y]] mod wwB. - Proof. - assert (U:= lt_0_wB w_digits). - assert (U1:= lt_0_wwB w_digits). - intros x y; case x; auto; intros xh xl. - case y; auto. - simpl; rewrite Z.mul_0_r; rewrite Zmod_small; auto with zarith. - intros yh yl;simpl. - repeat (rewrite spec_ww_add || rewrite spec_w_W0 || rewrite spec_w_mul_c - || rewrite spec_w_add || rewrite spec_w_mul). - rewrite <- Zplus_mod; auto with zarith. - repeat (rewrite Z.mul_add_distr_r || rewrite Z.mul_add_distr_l). - rewrite <- Zmult_mod_distr_r; auto with zarith. - rewrite <- Z.pow_2_r; rewrite <- wwB_wBwB; auto with zarith. - rewrite Zplus_mod; auto with zarith. - rewrite Zmod_mod; auto with zarith. - rewrite <- Zplus_mod; auto with zarith. - match goal with |- ?X mod _ = _ => - rewrite <- Z_mod_plus with (a := X) (b := [|xh|] * [|yh|]) - end; auto with zarith. - f_equal; auto; rewrite wwB_wBwB; ring. - Qed. - - Lemma spec_ww_square_c : forall x, [||ww_square_c x||] = [[x]]*[[x]]. - Proof. - destruct x as [ |xh xl];simpl;trivial. - case_eq match ww_add_c (w_mul_c xh xl) (w_mul_c xh xl) with - | C0 cc => (w_0, cc) - | C1 cc => (w_1, cc) - end;intros wc cc Heq. - apply (spec_mul_aux xh xl xh xl wc cc);trivial. - generalize Heq (spec_ww_add_c (w_mul_c xh xl) (w_mul_c xh xl));clear Heq. - rewrite spec_w_mul_c;destruct (ww_add_c (w_mul_c xh xl) (w_mul_c xh xl)); - unfold interp_carry;try rewrite Z.mul_1_l;intros Heq Heq';inversion Heq; - rewrite (Z.mul_comm [|xl|]);subst. - rewrite spec_w_0;rewrite Z.mul_0_l;rewrite Z.add_0_l;trivial. - rewrite spec_w_1;rewrite Z.mul_1_l;rewrite <- wwB_wBwB;trivial. - Qed. - - Section DoubleMulAddn1Proof. - - Variable w_mul_add : w -> w -> w -> w * w. - Variable spec_w_mul_add : forall x y r, - let (h,l):= w_mul_add x y r in - [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. - - Lemma spec_double_mul_add_n1 : forall n x y r, - let (h,l) := double_mul_add_n1 w_mul_add n x y r in - [|h|]*double_wB w_digits n + [!n|l!] = [!n|x!]*[|y|]+[|r|]. - Proof. - induction n;intros x y r;trivial. - exact (spec_w_mul_add x y r). - unfold double_mul_add_n1;destruct x as[ |xh xl]; - fold(double_mul_add_n1 w_mul_add). - rewrite spec_w_0;rewrite spec_extend;simpl;trivial. - assert(H:=IHn xl y r);destruct (double_mul_add_n1 w_mul_add n xl y r)as(rl,l). - assert(U:=IHn xh y rl);destruct(double_mul_add_n1 w_mul_add n xh y rl)as(rh,h). - rewrite <- double_wB_wwB. rewrite spec_double_WW;simpl;trivial. - rewrite Z.mul_add_distr_r;rewrite <- Z.add_assoc;rewrite <- H. - rewrite Z.mul_assoc;rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - rewrite U;ring. - Qed. - - End DoubleMulAddn1Proof. - - Lemma spec_w_mul_add : forall x y r, - let (h,l):= w_mul_add x y r in - [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. - Proof. - intros x y r;unfold w_mul_add;assert (H:=spec_w_mul_c x y); - destruct (w_mul_c x y) as [ |h l];simpl;rewrite <- H. - rewrite spec_w_0;trivial. - assert (U:=spec_w_add_c l r);destruct (w_add_c l r) as [lr|lr];unfold - interp_carry in U;try rewrite Z.mul_1_l in H;simpl. - rewrite U;ring. rewrite spec_w_succ. rewrite Zmod_small. - rewrite <- Z.add_assoc;rewrite <- U;ring. - simpl in H;assert (H1:= Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)). - rewrite <- H in H1. - assert (H2:=spec_to_Z h);split;zarith. - case H1;clear H1;intro H1;clear H1. - replace (wB ^ 2 - 2 * wB) with ((wB - 2)*wB). 2:ring. - intros H0;assert (U1:= wB_pos w_digits). - assert (H1 := beta_lex _ _ _ _ _ H0 (spec_to_Z l));zarith. - Qed. - -(* End DoubleProof. *) - -End DoubleMul. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v deleted file mode 100644 index d07ce301..00000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v +++ /dev/null @@ -1,1369 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool. - Variable w_compare : w -> w -> comparison. - Variable w_0 : w. - Variable w_1 : w. - Variable w_Bm1 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_W0 : w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_sub : w -> w -> w. - Variable w_sub_c : w -> w -> carry w. - Variable w_square_c : w -> zn2z w. - Variable w_div21 : w -> w -> w -> w * w. - Variable w_add_mul_div : w -> w -> w -> w. - Variable w_digits : positive. - Variable w_zdigits : w. - Variable ww_zdigits : zn2z w. - Variable w_add_c : w -> w -> carry w. - Variable w_sqrt2 : w -> w -> w * carry w. - Variable w_pred : w -> w. - Variable ww_pred_c : zn2z w -> carry (zn2z w). - Variable ww_pred : zn2z w -> zn2z w. - Variable ww_add_c : zn2z w -> zn2z w -> carry (zn2z w). - Variable ww_add : zn2z w -> zn2z w -> zn2z w. - Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). - Variable ww_add_mul_div : zn2z w -> zn2z w -> zn2z w -> zn2z w. - Variable ww_head0 : zn2z w -> zn2z w. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - Variable low : zn2z w -> w. - - Let wwBm1 := ww_Bm1 w_Bm1. - - Definition ww_is_even x := - match x with - | W0 => true - | WW xh xl => w_is_even xl - end. - - Let w_div21c x y z := - match w_compare x z with - | Eq => - match w_compare y z with - Eq => (C1 w_1, w_0) - | Gt => (C1 w_1, w_sub y z) - | Lt => (C1 w_0, y) - end - | Gt => - let x1 := w_sub x z in - let (q, r) := w_div21 x1 y z in - (C1 q, r) - | Lt => - let (q, r) := w_div21 x y z in - (C0 q, r) - end. - - Let w_div2s x y s := - match x with - C1 x1 => - let x2 := w_sub x1 s in - let (q, r) := w_div21c x2 y s in - match q with - C0 q1 => - if w_is_even q1 then - (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), C0 r) - else - (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), w_add_c r s) - | C1 q1 => - if w_is_even q1 then - (C1 (w_add_mul_div (w_pred w_zdigits) w_0 q1), C0 r) - else - (C1 (w_add_mul_div (w_pred w_zdigits) w_0 q1), w_add_c r s) - end - | C0 x1 => - let (q, r) := w_div21c x1 y s in - match q with - C0 q1 => - if w_is_even q1 then - (C0 (w_add_mul_div (w_pred w_zdigits) w_0 q1), C0 r) - else - (C0 (w_add_mul_div (w_pred w_zdigits) w_0 q1), w_add_c r s) - | C1 q1 => - if w_is_even q1 then - (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), C0 r) - else - (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), w_add_c r s) - end - end. - - Definition split x := - match x with - | W0 => (w_0,w_0) - | WW h l => (h,l) - end. - - Definition ww_sqrt2 x y := - let (x1, x2) := split x in - let (y1, y2) := split y in - let ( q, r) := w_sqrt2 x1 x2 in - let (q1, r1) := w_div2s r y1 q in - match q1 with - C0 q1 => - let q2 := w_square_c q1 in - let a := WW q q1 in - match r1 with - C1 r2 => - match ww_sub_c (WW r2 y2) q2 with - C0 r3 => (a, C1 r3) - | C1 r3 => (a, C0 r3) - end - | C0 r2 => - match ww_sub_c (WW r2 y2) q2 with - C0 r3 => (a, C0 r3) - | C1 r3 => - let a2 := ww_add_mul_div (w_0W w_1) a W0 in - match ww_pred_c a2 with - C0 a3 => - (ww_pred a, ww_add_c a3 r3) - | C1 a3 => - (ww_pred a, C0 (ww_add a3 r3)) - end - end - end - | C1 q1 => - let a1 := WW q w_Bm1 in - let a2 := ww_add_mul_div (w_0W w_1) a1 wwBm1 in - (a1, ww_add_c a2 y) - end. - - Definition ww_is_zero x := - match ww_compare W0 x with - Eq => true - | _ => false - end. - - Definition ww_head1 x := - let p := ww_head0 x in - if (ww_is_even p) then p else ww_pred p. - - Definition ww_sqrt x := - if (ww_is_zero x) then W0 - else - let p := ww_head1 x in - match ww_compare p W0 with - | Gt => - match ww_add_mul_div p x W0 with - W0 => W0 - | WW x1 x2 => - let (r, _) := w_sqrt2 x1 x2 in - WW w_0 (w_add_mul_div - (w_sub w_zdigits - (low (ww_add_mul_div (ww_pred ww_zdigits) - W0 p))) w_0 r) - end - | _ => - match x with - W0 => W0 - | WW x1 x2 => WW w_0 (fst (w_sqrt2 x1 x2)) - end - end. - - - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - - Notation "[|| x ||]" := - (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x) (at level 0, x at level 99). - - Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) - (at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. - Variable spec_w_zdigits : [|w_zdigits|] = Zpos w_digits. - Variable spec_more_than_1_digit: 1 < Zpos w_digits. - - Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos (xO w_digits). - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_w_is_even : forall x, - if w_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. - Variable spec_w_compare : forall x y, - w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|]. - Variable spec_w_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Variable spec_w_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (Z.pow 2 ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_ww_add_mul_div : forall x y p, - [[p]] <= Zpos (xO w_digits) -> - [[ ww_add_mul_div p x y ]] = - ([[x]] * (2^ [[p]]) + - [[y]] / (2^ (Zpos (xO w_digits) - [[p]]))) mod wwB. - Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. - Variable spec_w_sqrt2 : forall x y, - wB/ 4 <= [|x|] -> - let (s,r) := w_sqrt2 x y in - [[WW x y]] = [|s|] ^ 2 + [+|r|] /\ - [+|r|] <= 2 * [|s|]. - Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - Variable spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1. - Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. - Variable spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB. - Variable spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. - Variable spec_ww_compare : forall x y, - ww_compare x y = Z.compare [[x]] [[y]]. - Variable spec_ww_head0 : forall x, 0 < [[x]] -> - wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB. - Variable spec_low: forall x, [|low x|] = [[x]] mod wB. - - Let spec_ww_Bm1 : [[wwBm1]] = wwB - 1. - Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed. - - Hint Rewrite spec_w_0 spec_w_1 spec_w_WW spec_w_sub - spec_w_add_mul_div spec_ww_Bm1 spec_w_add_c : w_rewrite. - - Lemma spec_ww_is_even : forall x, - if ww_is_even x then [[x]] mod 2 = 0 else [[x]] mod 2 = 1. -clear spec_more_than_1_digit. -intros x; case x; simpl ww_is_even. - reflexivity. - simpl. - intros w1 w2; simpl. - unfold base. - rewrite Zplus_mod; auto with zarith. - rewrite (fun x y => (Zdivide_mod (x * y))); auto with zarith. - rewrite Z.add_0_l; rewrite Zmod_mod; auto with zarith. - apply spec_w_is_even; auto with zarith. - apply Z.divide_mul_r; apply Zpower_divide; auto with zarith. - Qed. - - - Theorem spec_w_div21c : forall a1 a2 b, - wB/2 <= [|b|] -> - let (q,r) := w_div21c a1 a2 b in - [|a1|] * wB + [|a2|] = [+|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. - intros a1 a2 b Hb; unfold w_div21c. - assert (H: 0 < [|b|]); auto with zarith. - assert (U := wB_pos w_digits). - apply Z.lt_le_trans with (2 := Hb); auto with zarith. - apply Z.lt_le_trans with 1; auto with zarith. - apply Zdiv_le_lower_bound; auto with zarith. - rewrite !spec_w_compare. repeat case Z.compare_spec. - intros H1 H2; split. - unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. - rewrite H1; rewrite H2; ring. - autorewrite with w_rewrite; auto with zarith. - intros H1 H2; split. - unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. - rewrite H2; ring. - destruct (spec_to_Z a2);auto with zarith. - intros H1 H2; split. - unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. - rewrite H2; rewrite Zmod_small; auto with zarith. - ring. - destruct (spec_to_Z a2);auto with zarith. - rewrite spec_w_sub; auto with zarith. - destruct (spec_to_Z a2) as [H3 H4];auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - assert ([|a2|] < 2 * [|b|]); auto with zarith. - apply Z.lt_le_trans with (2 * (wB / 2)); auto with zarith. - rewrite wB_div_2; auto. - intros H1. - match goal with |- context[w_div21 ?y ?z ?t] => - generalize (@spec_w_div21 y z t Hb H1); - case (w_div21 y z t); simpl; autorewrite with w_rewrite; - auto - end. - intros H1. - assert (H2: [|w_sub a1 b|] < [|b|]). - rewrite spec_w_sub; auto with zarith. - rewrite Zmod_small; auto with zarith. - assert ([|a1|] < 2 * [|b|]); auto with zarith. - apply Z.lt_le_trans with (2 * (wB / 2)); auto with zarith. - rewrite wB_div_2; auto. - destruct (spec_to_Z a1);auto with zarith. - destruct (spec_to_Z a1);auto with zarith. - match goal with |- context[w_div21 ?y ?z ?t] => - generalize (@spec_w_div21 y z t Hb H2); - case (w_div21 y z t); autorewrite with w_rewrite; - auto - end. - intros w0 w1; replace [+|C1 w0|] with (wB + [|w0|]). - rewrite Zmod_small; auto with zarith. - intros (H3, H4); split; auto. - rewrite Z.mul_add_distr_r. - rewrite <- Z.add_assoc; rewrite <- H3; ring. - split; auto with zarith. - assert ([|a1|] < 2 * [|b|]); auto with zarith. - apply Z.lt_le_trans with (2 * (wB / 2)); auto with zarith. - rewrite wB_div_2; auto. - destruct (spec_to_Z a1);auto with zarith. - destruct (spec_to_Z a1);auto with zarith. - simpl; case wB; auto. - Qed. - - Theorem C0_id: forall p, [+|C0 p|] = [|p|]. - intros p; simpl; auto. - Qed. - - Theorem add_mult_div_2: forall w, - [|w_add_mul_div (w_pred w_zdigits) w_0 w|] = [|w|] / 2. - intros w1. - assert (Hp: [|w_pred w_zdigits|] = Zpos w_digits - 1). - rewrite spec_pred; rewrite spec_w_zdigits. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.lt_le_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. - rewrite spec_w_add_mul_div; auto with zarith. - autorewrite with w_rewrite rm10. - match goal with |- context[?X - ?Y] => - replace (X - Y) with 1 - end. - rewrite Z.pow_1_r; rewrite Zmod_small; auto with zarith. - destruct (spec_to_Z w1) as [H1 H2];auto with zarith. - split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - rewrite Hp; ring. - Qed. - - Theorem add_mult_div_2_plus_1: forall w, - [|w_add_mul_div (w_pred w_zdigits) w_1 w|] = - [|w|] / 2 + 2 ^ Zpos (w_digits - 1). - intros w1. - assert (Hp: [|w_pred w_zdigits|] = Zpos w_digits - 1). - rewrite spec_pred; rewrite spec_w_zdigits. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.lt_le_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. - autorewrite with w_rewrite rm10; auto with zarith. - match goal with |- context[?X - ?Y] => - replace (X - Y) with 1 - end; rewrite Hp; try ring. - rewrite Pos2Z.inj_sub_max; auto with zarith. - rewrite Z.max_r; auto with zarith. - rewrite Z.pow_1_r; rewrite Zmod_small; auto with zarith. - destruct (spec_to_Z w1) as [H1 H2];auto with zarith. - split; auto with zarith. - unfold base. - match goal with |- _ < _ ^ ?X => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp - end. - rewrite Zpower_exp; try rewrite Z.pow_1_r; auto with zarith. - assert (tmp: forall p, 1 + (p -1) - 1 = p - 1); auto with zarith; - rewrite tmp; clear tmp; auto with zarith. - match goal with |- ?X + ?Y < _ => - assert (Y < X); auto with zarith - end. - apply Zdiv_lt_upper_bound; auto with zarith. - pattern 2 at 2; rewrite <- Z.pow_1_r; rewrite <- Zpower_exp; - auto with zarith. - assert (tmp: forall p, (p - 1) + 1 = p); auto with zarith; - rewrite tmp; clear tmp; auto with zarith. - Qed. - - Theorem add_mult_mult_2: forall w, - [|w_add_mul_div w_1 w w_0|] = 2 * [|w|] mod wB. - intros w1. - autorewrite with w_rewrite rm10; auto with zarith. - rewrite Z.pow_1_r; auto with zarith. - rewrite Z.mul_comm; auto. - Qed. - - Theorem ww_add_mult_mult_2: forall w, - [[ww_add_mul_div (w_0W w_1) w W0]] = 2 * [[w]] mod wwB. - intros w1. - rewrite spec_ww_add_mul_div; auto with zarith. - autorewrite with w_rewrite rm10. - rewrite spec_w_0W; rewrite spec_w_1. - rewrite Z.pow_1_r; auto with zarith. - rewrite Z.mul_comm; auto. - rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. - red; simpl; intros; discriminate. - Qed. - - Theorem ww_add_mult_mult_2_plus_1: forall w, - [[ww_add_mul_div (w_0W w_1) w wwBm1]] = - (2 * [[w]] + 1) mod wwB. - intros w1. - rewrite spec_ww_add_mul_div; auto with zarith. - rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. - rewrite Z.pow_1_r; auto with zarith. - f_equal; auto. - rewrite Z.mul_comm; f_equal; auto. - autorewrite with w_rewrite rm10. - unfold ww_digits, base. - symmetry; apply Zdiv_unique with (r := 2 ^ (Zpos (ww_digits w_digits) - 1) -1); - auto with zarith. - unfold ww_digits; split; auto with zarith. - match goal with |- 0 <= ?X - 1 => - assert (0 < X); auto with zarith - end. - apply Z.pow_pos_nonneg; auto with zarith. - match goal with |- 0 <= ?X - 1 => - assert (0 < X); auto with zarith; red; reflexivity - end. - unfold ww_digits; autorewrite with rm10. - assert (tmp: forall p q r, p + (q - r) = p + q - r); auto with zarith; - rewrite tmp; clear tmp. - assert (tmp: forall p, p + p = 2 * p); auto with zarith; - rewrite tmp; clear tmp. - f_equal; auto. - pattern 2 at 2; rewrite <- Z.pow_1_r; rewrite <- Zpower_exp; - auto with zarith. - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite tmp; clear tmp; auto. - match goal with |- ?X - 1 >= 0 => - assert (0 < X); auto with zarith; red; reflexivity - end. - rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. - red; simpl; intros; discriminate. - Qed. - - Theorem Zplus_mod_one: forall a1 b1, 0 < b1 -> (a1 + b1) mod b1 = a1 mod b1. - intros a1 b1 H; rewrite Zplus_mod; auto with zarith. - rewrite Z_mod_same; try rewrite Z.add_0_r; auto with zarith. - apply Zmod_mod; auto. - Qed. - - Lemma C1_plus_wB: forall x, [+|C1 x|] = wB + [|x|]. - unfold interp_carry; auto with zarith. - Qed. - - Theorem spec_w_div2s : forall a1 a2 b, - wB/2 <= [|b|] -> [+|a1|] <= 2 * [|b|] -> - let (q,r) := w_div2s a1 a2 b in - [+|a1|] * wB + [|a2|] = [+|q|] * (2 * [|b|]) + [+|r|] /\ 0 <= [+|r|] < 2 * [|b|]. - intros a1 a2 b H. - assert (HH: 0 < [|b|]); auto with zarith. - assert (U := wB_pos w_digits). - apply Z.lt_le_trans with (2 := H); auto with zarith. - apply Z.lt_le_trans with 1; auto with zarith. - apply Zdiv_le_lower_bound; auto with zarith. - unfold w_div2s; case a1; intros w0 H0. - match goal with |- context[w_div21c ?y ?z ?t] => - generalize (@spec_w_div21c y z t H); - case (w_div21c y z t); autorewrite with w_rewrite; - auto - end. - intros c w1; case c. - simpl interp_carry; intros w2 (Hw1, Hw2). - match goal with |- context[w_is_even ?y] => - generalize (spec_w_is_even y); - case (w_is_even y) - end. - repeat rewrite C0_id. - rewrite add_mult_div_2. - intros H1; split; auto with zarith. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; ring. - repeat rewrite C0_id. - rewrite add_mult_div_2. - rewrite spec_w_add_c; auto with zarith. - intros H1; split; auto with zarith. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; ring. - intros w2; rewrite C1_plus_wB. - intros (Hw1, Hw2). - match goal with |- context[w_is_even ?y] => - generalize (spec_w_is_even y); - case (w_is_even y) - end. - repeat rewrite C0_id. - intros H1; split; auto with zarith. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1. - repeat rewrite C0_id. - rewrite add_mult_div_2_plus_1; unfold base. - match goal with |- context[_ ^ ?X] => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; - try rewrite Z.pow_1_r; auto with zarith - end. - rewrite Pos2Z.inj_sub_max; auto with zarith. - rewrite Z.max_r; auto with zarith. - ring. - repeat rewrite C0_id. - rewrite spec_w_add_c; auto with zarith. - intros H1; split; auto with zarith. - rewrite add_mult_div_2_plus_1. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1. - unfold base. - match goal with |- context[_ ^ ?X] => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; - try rewrite Z.pow_1_r; auto with zarith - end. - rewrite Pos2Z.inj_sub_max; auto with zarith. - rewrite Z.max_r; auto with zarith. - ring. - repeat rewrite C1_plus_wB in H0. - rewrite C1_plus_wB. - match goal with |- context[w_div21c ?y ?z ?t] => - generalize (@spec_w_div21c y z t H); - case (w_div21c y z t); autorewrite with w_rewrite; - auto - end. - intros c w1; case c. - intros w2 (Hw1, Hw2); rewrite C0_id in Hw1. - rewrite <- Zplus_mod_one in Hw1; auto with zarith. - rewrite Zmod_small in Hw1; auto with zarith. - match goal with |- context[w_is_even ?y] => - generalize (spec_w_is_even y); - case (w_is_even y) - end. - repeat rewrite C0_id. - intros H1; split; auto with zarith. - rewrite add_mult_div_2_plus_1. - replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); - auto with zarith. - rewrite Z.mul_add_distr_r; rewrite <- Z.add_assoc. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; unfold base. - match goal with |- context[_ ^ ?X] => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; - try rewrite Z.pow_1_r; auto with zarith - end. - rewrite Pos2Z.inj_sub_max; auto with zarith. - rewrite Z.max_r; auto with zarith. - ring. - repeat rewrite C0_id. - rewrite add_mult_div_2_plus_1. - rewrite spec_w_add_c; auto with zarith. - intros H1; split; auto with zarith. - replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); - auto with zarith. - rewrite Z.mul_add_distr_r; rewrite <- Z.add_assoc. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; unfold base. - match goal with |- context[_ ^ ?X] => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; - try rewrite Z.pow_1_r; auto with zarith - end. - rewrite Pos2Z.inj_sub_max; auto with zarith. - rewrite Z.max_r; auto with zarith. - ring. - split; auto with zarith. - destruct (spec_to_Z b);auto with zarith. - destruct (spec_to_Z w0);auto with zarith. - destruct (spec_to_Z b);auto with zarith. - destruct (spec_to_Z b);auto with zarith. - intros w2; rewrite C1_plus_wB. - rewrite <- Zplus_mod_one; auto with zarith. - rewrite Zmod_small; auto with zarith. - intros (Hw1, Hw2). - match goal with |- context[w_is_even ?y] => - generalize (spec_w_is_even y); - case (w_is_even y) - end. - repeat (rewrite C0_id || rewrite C1_plus_wB). - intros H1; split; auto with zarith. - rewrite add_mult_div_2. - replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); - auto with zarith. - rewrite Z.mul_add_distr_r; rewrite <- Z.add_assoc. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; ring. - repeat (rewrite C0_id || rewrite C1_plus_wB). - rewrite spec_w_add_c; auto with zarith. - intros H1; split; auto with zarith. - rewrite add_mult_div_2. - replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); - auto with zarith. - rewrite Z.mul_add_distr_r; rewrite <- Z.add_assoc. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; ring. - split; auto with zarith. - destruct (spec_to_Z b);auto with zarith. - destruct (spec_to_Z w0);auto with zarith. - destruct (spec_to_Z b);auto with zarith. - destruct (spec_to_Z b);auto with zarith. - Qed. - - Theorem wB_div_4: 4 * (wB / 4) = wB. - Proof. - unfold base. - assert (2 ^ Zpos w_digits = - 4 * (2 ^ (Zpos w_digits - 2))). - change 4 with (2 ^ 2). - rewrite <- Zpower_exp; auto with zarith. - f_equal; auto with zarith. - rewrite H. - rewrite (fun x => (Z.mul_comm 4 (2 ^x))). - rewrite Z_div_mult; auto with zarith. - Qed. - - Theorem Zsquare_mult: forall p, p ^ 2 = p * p. - intros p; change 2 with (1 + 1); rewrite Zpower_exp; - try rewrite Z.pow_1_r; auto with zarith. - Qed. - - Theorem Zsquare_pos: forall p, 0 <= p ^ 2. - intros p; case (Z.le_gt_cases 0 p); intros H1. - rewrite Zsquare_mult; apply Z.mul_nonneg_nonneg; auto with zarith. - rewrite Zsquare_mult; replace (p * p) with ((- p) * (- p)); try ring. - apply Z.mul_nonneg_nonneg; auto with zarith. - Qed. - - Lemma spec_split: forall x, - [|fst (split x)|] * wB + [|snd (split x)|] = [[x]]. - intros x; case x; simpl; autorewrite with w_rewrite; - auto with zarith. - Qed. - - Theorem mult_wwB: forall x y, [|x|] * [|y|] < wwB. - Proof. - intros x y; rewrite wwB_wBwB; rewrite Z.pow_2_r. - generalize (spec_to_Z x); intros U. - generalize (spec_to_Z y); intros U1. - apply Z.le_lt_trans with ((wB -1 ) * (wB - 1)); auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - rewrite ?Z.mul_sub_distr_l, ?Z.mul_sub_distr_r; auto with zarith. - Qed. - Hint Resolve mult_wwB. - - Lemma spec_ww_sqrt2 : forall x y, - wwB/ 4 <= [[x]] -> - let (s,r) := ww_sqrt2 x y in - [||WW x y||] = [[s]] ^ 2 + [+[r]] /\ - [+[r]] <= 2 * [[s]]. - intros x y H; unfold ww_sqrt2. - repeat match goal with |- context[split ?x] => - generalize (spec_split x); case (split x) - end; simpl @fst; simpl @snd. - intros w0 w1 Hw0 w2 w3 Hw1. - assert (U: wB/4 <= [|w2|]). - case (Z.le_gt_cases (wB / 4) [|w2|]); auto; intros H1. - contradict H; apply Z.lt_nge. - rewrite wwB_wBwB; rewrite Z.pow_2_r. - pattern wB at 1; rewrite <- wB_div_4; rewrite <- Z.mul_assoc; - rewrite Z.mul_comm. - rewrite Z_div_mult; auto with zarith. - rewrite <- Hw1. - match goal with |- _ < ?X => - pattern X; rewrite <- Z.add_0_r; apply beta_lex_inv; - auto with zarith - end. - destruct (spec_to_Z w3);auto with zarith. - generalize (@spec_w_sqrt2 w2 w3 U); case (w_sqrt2 w2 w3). - intros w4 c (H1, H2). - assert (U1: wB/2 <= [|w4|]). - case (Z.le_gt_cases (wB/2) [|w4|]); auto with zarith. - intros U1. - assert (U2 : [|w4|] <= wB/2 -1); auto with zarith. - assert (U3 : [|w4|] ^ 2 <= wB/4 * wB - wB + 1); auto with zarith. - match goal with |- ?X ^ 2 <= ?Y => - rewrite Zsquare_mult; - replace Y with ((wB/2 - 1) * (wB/2 -1)) - end. - apply Z.mul_le_mono_nonneg; auto with zarith. - destruct (spec_to_Z w4);auto with zarith. - destruct (spec_to_Z w4);auto with zarith. - pattern wB at 4 5; rewrite <- wB_div_2. - rewrite Z.mul_assoc. - replace ((wB / 4) * 2) with (wB / 2). - ring. - pattern wB at 1; rewrite <- wB_div_4. - change 4 with (2 * 2). - rewrite <- Z.mul_assoc; rewrite (Z.mul_comm 2). - rewrite Z_div_mult; try ring; auto with zarith. - assert (U4 : [+|c|] <= wB -2); auto with zarith. - apply Z.le_trans with (1 := H2). - match goal with |- ?X <= ?Y => - replace Y with (2 * (wB/ 2 - 1)); auto with zarith - end. - pattern wB at 2; rewrite <- wB_div_2; auto with zarith. - match type of H1 with ?X = _ => - assert (U5: X < wB / 4 * wB) - end. - rewrite H1; auto with zarith. - contradict U; apply Z.lt_nge. - apply Z.mul_lt_mono_pos_r with wB; auto with zarith. - destruct (spec_to_Z w4);auto with zarith. - apply Z.le_lt_trans with (2 := U5). - unfold ww_to_Z, zn2z_to_Z. - destruct (spec_to_Z w3);auto with zarith. - generalize (@spec_w_div2s c w0 w4 U1 H2). - case (w_div2s c w0 w4). - intros c0; case c0; intros w5; - repeat (rewrite C0_id || rewrite C1_plus_wB). - intros c1; case c1; intros w6; - repeat (rewrite C0_id || rewrite C1_plus_wB). - intros (H3, H4). - match goal with |- context [ww_sub_c ?y ?z] => - generalize (spec_ww_sub_c y z); case (ww_sub_c y z) - end. - intros z; change [-[C0 z]] with ([[z]]). - change [+[C0 z]] with ([[z]]). - intros H5; rewrite spec_w_square_c in H5; - auto. - split. - unfold zn2z_to_Z; rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1. rewrite H1. - rewrite <- Hw0. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite H5. - unfold ww_to_Z, zn2z_to_Z. - repeat rewrite Zsquare_mult; ring. - rewrite H5. - unfold ww_to_Z, zn2z_to_Z. - match goal with |- ?X - ?Y * ?Y <= _ => - assert (V := Zsquare_pos Y); - rewrite Zsquare_mult in V; - apply Z.le_trans with X; auto with zarith; - clear V - end. - match goal with |- ?X * wB + ?Y <= 2 * (?Z * wB + ?T) => - apply Z.le_trans with ((2 * Z - 1) * wB + wB); auto with zarith - end. - destruct (spec_to_Z w1);auto with zarith. - match goal with |- ?X <= _ => - replace X with (2 * [|w4|] * wB); auto with zarith - end. - rewrite Z.mul_add_distr_l; rewrite Z.mul_assoc. - destruct (spec_to_Z w5); auto with zarith. - ring. - intros z; replace [-[C1 z]] with (- wwB + [[z]]). - 2: simpl; case wwB; auto with zarith. - intros H5; rewrite spec_w_square_c in H5; - auto. - match goal with |- context [ww_pred_c ?y] => - generalize (spec_ww_pred_c y); case (ww_pred_c y) - end. - intros z1; change [-[C0 z1]] with ([[z1]]). - rewrite ww_add_mult_mult_2. - rewrite spec_ww_add_c. - rewrite spec_ww_pred. - rewrite <- Zmod_unique with (q := 1) (r := -wwB + 2 * [[WW w4 w5]]); - auto with zarith. - intros Hz1; rewrite Zmod_small; auto with zarith. - match type of H5 with -?X + ?Y = ?Z => - assert (V: Y = Z + X); - try (rewrite <- H5; ring) - end. - split. - unfold zn2z_to_Z; rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. - rewrite <- Hw0. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite V. - rewrite Hz1. - unfold ww_to_Z; simpl zn2z_to_Z. - repeat rewrite Zsquare_mult; ring. - rewrite Hz1. - destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. - assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)). - assert (0 < [[WW w4 w5]]); auto with zarith. - apply Z.lt_le_trans with (wB/ 2 * wB + 0); auto with zarith. - autorewrite with rm10; apply Z.mul_pos_pos; auto with zarith. - apply Z.mul_lt_mono_pos_r with 2; auto with zarith. - autorewrite with rm10. - rewrite Z.mul_comm; rewrite wB_div_2; auto with zarith. - case (spec_to_Z w5);auto with zarith. - case (spec_to_Z w5);auto with zarith. - simpl. - assert (V2 := spec_to_Z w5);auto with zarith. - assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)); auto with zarith. - split; auto with zarith. - assert (wwB <= 2 * [[WW w4 w5]]); auto with zarith. - apply Z.le_trans with (2 * ([|w4|] * wB)). - rewrite wwB_wBwB; rewrite Z.pow_2_r. - rewrite Z.mul_assoc; apply Z.mul_le_mono_nonneg_r; auto with zarith. - assert (V2 := spec_to_Z w5);auto with zarith. - rewrite <- wB_div_2; auto with zarith. - simpl ww_to_Z; assert (V2 := spec_to_Z w5);auto with zarith. - assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)); auto with zarith. - intros z1; change [-[C1 z1]] with (-wwB + [[z1]]). - match goal with |- context[([+[C0 ?z]])] => - change [+[C0 z]] with ([[z]]) - end. - rewrite spec_ww_add; auto with zarith. - rewrite spec_ww_pred; auto with zarith. - rewrite ww_add_mult_mult_2. - rename V1 into VV1. - assert (VV2: 0 < [[WW w4 w5]]); auto with zarith. - apply Z.lt_le_trans with (wB/ 2 * wB + 0); auto with zarith. - autorewrite with rm10; apply Z.mul_pos_pos; auto with zarith. - apply Z.mul_lt_mono_pos_r with 2; auto with zarith. - autorewrite with rm10. - rewrite Z.mul_comm; rewrite wB_div_2; auto with zarith. - assert (VV3 := spec_to_Z w5);auto with zarith. - assert (VV3 := spec_to_Z w5);auto with zarith. - simpl. - assert (VV3 := spec_to_Z w5);auto with zarith. - assert (VV3: wwB <= 2 * [[WW w4 w5]]); auto with zarith. - apply Z.le_trans with (2 * ([|w4|] * wB)). - rewrite wwB_wBwB; rewrite Z.pow_2_r. - rewrite Z.mul_assoc; apply Z.mul_le_mono_nonneg_r; auto with zarith. - case (spec_to_Z w5);auto with zarith. - rewrite <- wB_div_2; auto with zarith. - simpl ww_to_Z; assert (V4 := spec_to_Z w5);auto with zarith. - rewrite <- Zmod_unique with (q := 1) (r := -wwB + 2 * [[WW w4 w5]]); - auto with zarith. - intros Hz1; rewrite Zmod_small; auto with zarith. - match type of H5 with -?X + ?Y = ?Z => - assert (V: Y = Z + X); - try (rewrite <- H5; ring) - end. - match type of Hz1 with -?X + ?Y = -?X + ?Z - 1 => - assert (V1: Y = Z - 1); - [replace (Z - 1) with (X + (-X + Z -1)); - [rewrite <- Hz1 | idtac]; ring - | idtac] - end. - rewrite <- Zmod_unique with (q := 1) (r := -wwB + [[z1]] + [[z]]); - auto with zarith. - unfold zn2z_to_Z; rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. - rewrite <- Hw0. - split. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite V. - rewrite Hz1. - unfold ww_to_Z; simpl zn2z_to_Z. - repeat rewrite Zsquare_mult; ring. - assert (V2 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. - assert (V2 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. - assert (V3 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z1);auto with zarith. - split; auto with zarith. - rewrite (Z.add_comm (-wwB)); rewrite <- Z.add_assoc. - rewrite H5. - match goal with |- 0 <= ?X + (?Y - ?Z) => - apply Z.le_trans with (X - Z); auto with zarith - end. - 2: generalize (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w6 w1)); unfold ww_to_Z; auto with zarith. - rewrite V1. - match goal with |- 0 <= ?X - 1 - ?Y => - assert (Y < X); auto with zarith - end. - apply Z.lt_le_trans with wwB; auto with zarith. - intros (H3, H4). - match goal with |- context [ww_sub_c ?y ?z] => - generalize (spec_ww_sub_c y z); case (ww_sub_c y z) - end. - intros z; change [-[C0 z]] with ([[z]]). - match goal with |- context[([+[C1 ?z]])] => - replace [+[C1 z]] with (wwB + [[z]]) - end. - 2: simpl; case wwB; auto. - intros H5; rewrite spec_w_square_c in H5; - auto. - split. - change ([||WW x y||]) with ([[x]] * wwB + [[y]]). - rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. - rewrite <- Hw0. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite H5. - unfold ww_to_Z; simpl zn2z_to_Z. - rewrite wwB_wBwB. - repeat rewrite Zsquare_mult; ring. - simpl ww_to_Z. - rewrite H5. - simpl ww_to_Z. - rewrite wwB_wBwB; rewrite Z.pow_2_r. - match goal with |- ?X * ?Y + (?Z * ?Y + ?T - ?U) <= _ => - apply Z.le_trans with (X * Y + (Z * Y + T - 0)); - auto with zarith - end. - assert (V := Zsquare_pos [|w5|]); - rewrite Zsquare_mult in V; auto with zarith. - autorewrite with rm10. - match goal with |- _ <= 2 * (?U * ?V + ?W) => - apply Z.le_trans with (2 * U * V + 0); - auto with zarith - end. - match goal with |- ?X * ?Y + (?Z * ?Y + ?T) <= _ => - replace (X * Y + (Z * Y + T)) with ((X + Z) * Y + T); - try ring - end. - apply Z.lt_le_incl; apply beta_lex_inv; auto with zarith. - destruct (spec_to_Z w1);auto with zarith. - destruct (spec_to_Z w5);auto with zarith. - rewrite Z.mul_add_distr_l; auto with zarith. - rewrite Z.mul_assoc; auto with zarith. - intros z; replace [-[C1 z]] with (- wwB + [[z]]). - 2: simpl; case wwB; auto with zarith. - intros H5; rewrite spec_w_square_c in H5; - auto. - match goal with |- context[([+[C0 ?z]])] => - change [+[C0 z]] with ([[z]]) - end. - match type of H5 with -?X + ?Y = ?Z => - assert (V: Y = Z + X); - try (rewrite <- H5; ring) - end. - change ([||WW x y||]) with ([[x]] * wwB + [[y]]). - simpl ww_to_Z. - rewrite <- Hw1. - simpl ww_to_Z in H1; rewrite H1. - rewrite <- Hw0. - split. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite V. - simpl ww_to_Z. - rewrite wwB_wBwB. - repeat rewrite Zsquare_mult; ring. - rewrite V. - simpl ww_to_Z. - rewrite wwB_wBwB; rewrite Z.pow_2_r. - match goal with |- (?Z * ?Y + ?T - ?U) + ?X * ?Y <= _ => - apply Z.le_trans with ((Z * Y + T - 0) + X * Y); - auto with zarith - end. - assert (V1 := Zsquare_pos [|w5|]); - rewrite Zsquare_mult in V1; auto with zarith. - autorewrite with rm10. - match goal with |- _ <= 2 * (?U * ?V + ?W) => - apply Z.le_trans with (2 * U * V + 0); - auto with zarith - end. - match goal with |- (?Z * ?Y + ?T) + ?X * ?Y <= _ => - replace ((Z * Y + T) + X * Y) with ((X + Z) * Y + T); - try ring - end. - apply Z.lt_le_incl; apply beta_lex_inv; auto with zarith. - destruct (spec_to_Z w1);auto with zarith. - destruct (spec_to_Z w5);auto with zarith. - rewrite Z.mul_add_distr_l; auto with zarith. - rewrite Z.mul_assoc; auto with zarith. - Z.le_elim H2. - intros c1 (H3, H4). - match type of H3 with ?X = ?Y => absurd (X < Y) end. - apply Z.le_ngt; rewrite <- H3; auto with zarith. - rewrite Z.mul_add_distr_r. - apply Z.lt_le_trans with ((2 * [|w4|]) * wB + 0); - auto with zarith. - apply beta_lex_inv; auto with zarith. - destruct (spec_to_Z w0);auto with zarith. - assert (V1 := spec_to_Z w5);auto with zarith. - rewrite (Z.mul_comm wB); auto with zarith. - assert (0 <= [|w5|] * (2 * [|w4|])); auto with zarith. - intros c1 (H3, H4); rewrite H2 in H3. - match type of H3 with ?X + ?Y = (?Z + ?T) * ?U + ?V => - assert (VV: (Y = (T * U) + V)); - [replace Y with ((X + Y) - X); - [rewrite H3; ring | ring] | idtac] - end. - assert (V1 := spec_to_Z w0);auto with zarith. - assert (V2 := spec_to_Z w5);auto with zarith. - case V2; intros V3 _. - Z.le_elim V3; auto with zarith. - match type of VV with ?X = ?Y => absurd (X < Y) end. - apply Z.le_ngt; rewrite <- VV; auto with zarith. - apply Z.lt_le_trans with wB; auto with zarith. - match goal with |- _ <= ?X + _ => - apply Z.le_trans with X; auto with zarith - end. - match goal with |- _ <= _ * ?X => - apply Z.le_trans with (1 * X); auto with zarith - end. - autorewrite with rm10. - rewrite <- wB_div_2; apply Z.mul_le_mono_nonneg_l; auto with zarith. - rewrite <- V3 in VV; generalize VV; autorewrite with rm10; - clear VV; intros VV. - rewrite spec_ww_add_c; auto with zarith. - rewrite ww_add_mult_mult_2_plus_1. - match goal with |- context[?X mod wwB] => - rewrite <- Zmod_unique with (q := 1) (r := -wwB + X) - end; auto with zarith. - simpl ww_to_Z. - rewrite spec_w_Bm1; auto with zarith. - split. - change ([||WW x y||]) with ([[x]] * wwB + [[y]]). - rewrite <- Hw1. - simpl ww_to_Z in H1; rewrite H1. - rewrite <- Hw0. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H2. - rewrite wwB_wBwB. - repeat rewrite Zsquare_mult; ring. - assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z y);auto with zarith. - assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z y);auto with zarith. - simpl ww_to_Z; unfold ww_to_Z. - rewrite spec_w_Bm1; auto with zarith. - split. - rewrite wwB_wBwB; rewrite Z.pow_2_r. - match goal with |- _ <= -?X + (2 * (?Z * ?T + ?U) + ?V) => - assert (X <= 2 * Z * T); auto with zarith - end. - apply Z.mul_le_mono_nonneg_r; auto with zarith. - rewrite <- wB_div_2; apply Z.mul_le_mono_nonneg_l; auto with zarith. - rewrite Z.mul_add_distr_l; auto with zarith. - rewrite Z.mul_assoc; auto with zarith. - match goal with |- _ + ?X < _ => - replace X with ((2 * (([|w4|]) + 1) * wB) - 1); try ring - end. - assert (2 * ([|w4|] + 1) * wB <= 2 * wwB); auto with zarith. - rewrite <- Z.mul_assoc; apply Z.mul_le_mono_nonneg_l; auto with zarith. - rewrite wwB_wBwB; rewrite Z.pow_2_r. - apply Z.mul_le_mono_nonneg_r; auto with zarith. - case (spec_to_Z w4);auto with zarith. -Qed. - - Lemma spec_ww_is_zero: forall x, - if ww_is_zero x then [[x]] = 0 else 0 < [[x]]. - intro x; unfold ww_is_zero. - rewrite spec_ww_compare. case Z.compare_spec; - auto with zarith. - simpl ww_to_Z. - assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z x);auto with zarith. - Qed. - - Lemma wwB_4_2: 2 * (wwB / 4) = wwB/ 2. - pattern wwB at 1; rewrite wwB_wBwB; rewrite Z.pow_2_r. - rewrite <- wB_div_2. - match goal with |- context[(2 * ?X) * (2 * ?Z)] => - replace ((2 * X) * (2 * Z)) with ((X * Z) * 4); try ring - end. - rewrite Z_div_mult; auto with zarith. - rewrite Z.mul_assoc; rewrite wB_div_2. - rewrite wwB_div_2; ring. - Qed. - - - Lemma spec_ww_head1 - : forall x : zn2z w, - (ww_is_even (ww_head1 x) = true) /\ - (0 < [[x]] -> wwB / 4 <= 2 ^ [[ww_head1 x]] * [[x]] < wwB). - assert (U := wB_pos w_digits). - intros x; unfold ww_head1. - generalize (spec_ww_is_even (ww_head0 x)); case_eq (ww_is_even (ww_head0 x)). - intros HH H1; rewrite HH; split; auto. - intros H2. - generalize (spec_ww_head0 x H2); case (ww_head0 x); autorewrite with rm10. - intros (H3, H4); split; auto with zarith. - apply Z.le_trans with (2 := H3). - apply Zdiv_le_compat_l; auto with zarith. - intros xh xl (H3, H4); split; auto with zarith. - apply Z.le_trans with (2 := H3). - apply Zdiv_le_compat_l; auto with zarith. - intros H1. - case (spec_to_w_Z (ww_head0 x)); intros Hv1 Hv2. - assert (Hp0: 0 < [[ww_head0 x]]). - generalize (spec_ww_is_even (ww_head0 x)); rewrite H1. - generalize Hv1; case [[ww_head0 x]]. - rewrite Zmod_small; auto with zarith. - intros; assert (0 < Zpos p); auto with zarith. - red; simpl; auto. - intros p H2; case H2; auto. - assert (Hp: [[ww_pred (ww_head0 x)]] = [[ww_head0 x]] - 1). - rewrite spec_ww_pred. - rewrite Zmod_small; auto with zarith. - intros H2; split. - generalize (spec_ww_is_even (ww_pred (ww_head0 x))); - case ww_is_even; auto. - rewrite Hp. - rewrite Zminus_mod; auto with zarith. - rewrite H2; repeat rewrite Zmod_small; auto with zarith. - intros H3; rewrite Hp. - case (spec_ww_head0 x); auto; intros Hv3 Hv4. - assert (Hu: forall u, 0 < u -> 2 * 2 ^ (u - 1) = 2 ^u). - intros u Hu. - pattern 2 at 1; rewrite <- Z.pow_1_r. - rewrite <- Zpower_exp; auto with zarith. - ring_simplify (1 + (u - 1)); auto with zarith. - split; auto with zarith. - apply Z.mul_le_mono_pos_r with 2; auto with zarith. - repeat rewrite (fun x => Z.mul_comm x 2). - rewrite wwB_4_2. - rewrite Z.mul_assoc; rewrite Hu; auto with zarith. - apply Z.le_lt_trans with (2 * 2 ^ ([[ww_head0 x]] - 1) * [[x]]); auto with zarith; - rewrite Hu; auto with zarith. - apply Z.mul_le_mono_nonneg_r; auto with zarith. - apply Zpower_le_monotone; auto with zarith. - Qed. - - Theorem wwB_4_wB_4: wwB / 4 = wB / 4 * wB. - Proof. - symmetry; apply Zdiv_unique with 0; auto with zarith. - rewrite Z.mul_assoc; rewrite wB_div_4; auto with zarith. - rewrite wwB_wBwB; ring. - Qed. - - Lemma spec_ww_sqrt : forall x, - [[ww_sqrt x]] ^ 2 <= [[x]] < ([[ww_sqrt x]] + 1) ^ 2. - assert (U := wB_pos w_digits). - intro x; unfold ww_sqrt. - generalize (spec_ww_is_zero x); case (ww_is_zero x). - simpl ww_to_Z; simpl Z.pow; unfold Z.pow_pos; simpl; - auto with zarith. - intros H1. - rewrite spec_ww_compare. case Z.compare_spec; - simpl ww_to_Z; autorewrite with rm10. - generalize H1; case x. - intros HH; contradict HH; simpl ww_to_Z; auto with zarith. - intros w0 w1; simpl ww_to_Z; autorewrite with w_rewrite rm10. - intros H2; case (spec_ww_head1 (WW w0 w1)); intros H3 H4 H5. - generalize (H4 H2); clear H4; rewrite H5; clear H5; autorewrite with rm10. - intros (H4, H5). - assert (V: wB/4 <= [|w0|]). - apply beta_lex with 0 [|w1|] wB; auto with zarith; autorewrite with rm10. - rewrite <- wwB_4_wB_4; auto. - generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. - case (w_sqrt2 w0 w1); intros w2 c. - simpl ww_to_Z; simpl @fst. - case c; unfold interp_carry; autorewrite with rm10. - intros w3 (H6, H7); rewrite H6. - assert (V1 := spec_to_Z w3);auto with zarith. - split; auto with zarith. - apply Z.le_lt_trans with ([|w2|] ^2 + 2 * [|w2|]); auto with zarith. - match goal with |- ?X < ?Z => - replace Z with (X + 1); auto with zarith - end. - repeat rewrite Zsquare_mult; ring. - intros w3 (H6, H7); rewrite H6. - assert (V1 := spec_to_Z w3);auto with zarith. - split; auto with zarith. - apply Z.le_lt_trans with ([|w2|] ^2 + 2 * [|w2|]); auto with zarith. - match goal with |- ?X < ?Z => - replace Z with (X + 1); auto with zarith - end. - repeat rewrite Zsquare_mult; ring. - intros HH; case (spec_to_w_Z (ww_head1 x)); auto with zarith. - intros Hv1. - case (spec_ww_head1 x); intros Hp1 Hp2. - generalize (Hp2 H1); clear Hp2; intros Hp2. - assert (Hv2: [[ww_head1 x]] <= Zpos (xO w_digits)). - case (Z.le_gt_cases (Zpos (xO w_digits)) [[ww_head1 x]]); auto with zarith; intros HH1. - case Hp2; intros _ HH2; contradict HH2. - apply Z.le_ngt; unfold base. - apply Z.le_trans with (2 ^ [[ww_head1 x]]). - apply Zpower_le_monotone; auto with zarith. - pattern (2 ^ [[ww_head1 x]]) at 1; - rewrite <- (Z.mul_1_r (2 ^ [[ww_head1 x]])). - apply Z.mul_le_mono_nonneg_l; auto with zarith. - generalize (spec_ww_add_mul_div x W0 (ww_head1 x) Hv2); - case ww_add_mul_div. - simpl ww_to_Z; autorewrite with w_rewrite rm10. - rewrite Zmod_small; auto with zarith. - intros H2. symmetry in H2. rewrite Z.mul_eq_0 in H2. destruct H2 as [H2|H2]. - rewrite H2; unfold Z.pow, Z.pow_pos; simpl; auto with zarith. - match type of H2 with ?X = ?Y => - absurd (Y < X); try (rewrite H2; auto with zarith; fail) - end. - apply Z.pow_pos_nonneg; auto with zarith. - split; auto with zarith. - case Hp2; intros _ tmp; apply Z.le_lt_trans with (2 := tmp); - clear tmp. - rewrite Z.mul_comm; apply Z.mul_le_mono_nonneg_r; auto with zarith. - assert (Hv0: [[ww_head1 x]] = 2 * ([[ww_head1 x]]/2)). - pattern [[ww_head1 x]] at 1; rewrite (Z_div_mod_eq [[ww_head1 x]] 2); - auto with zarith. - generalize (spec_ww_is_even (ww_head1 x)); rewrite Hp1; - intros tmp; rewrite tmp; rewrite Z.add_0_r; auto. - intros w0 w1; autorewrite with w_rewrite rm10. - rewrite Zmod_small; auto with zarith. - 2: rewrite Z.mul_comm; auto with zarith. - intros H2. - assert (V: wB/4 <= [|w0|]). - apply beta_lex with 0 [|w1|] wB; auto with zarith; autorewrite with rm10. - simpl ww_to_Z in H2; rewrite H2. - rewrite <- wwB_4_wB_4; auto with zarith. - rewrite Z.mul_comm; auto with zarith. - assert (V1 := spec_to_Z w1);auto with zarith. - generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. - case (w_sqrt2 w0 w1); intros w2 c. - case (spec_to_Z w2); intros HH1 HH2. - simpl ww_to_Z; simpl @fst. - assert (Hv3: [[ww_pred ww_zdigits]] - = Zpos (xO w_digits) - 1). - rewrite spec_ww_pred; rewrite spec_ww_zdigits. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.lt_le_trans with (Zpos (xO w_digits)); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. - assert (Hv4: [[ww_head1 x]]/2 < wB). - apply Z.le_lt_trans with (Zpos w_digits). - apply Z.mul_le_mono_pos_r with 2; auto with zarith. - repeat rewrite (fun x => Z.mul_comm x 2). - rewrite <- Hv0; rewrite <- Pos2Z.inj_xO; auto. - unfold base; apply Zpower2_lt_lin; auto with zarith. - assert (Hv5: [[(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))]] - = [[ww_head1 x]]/2). - rewrite spec_ww_add_mul_div. - simpl ww_to_Z; autorewrite with rm10. - rewrite Hv3. - ring_simplify (Zpos (xO w_digits) - (Zpos (xO w_digits) - 1)). - rewrite Z.pow_1_r. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.lt_le_trans with (1 := Hv4); auto with zarith. - unfold base; apply Zpower_le_monotone; auto with zarith. - split; unfold ww_digits; try rewrite Pos2Z.inj_xO; auto with zarith. - rewrite Hv3; auto with zarith. - assert (Hv6: [|low(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))|] - = [[ww_head1 x]]/2). - rewrite spec_low. - rewrite Hv5; rewrite Zmod_small; auto with zarith. - rewrite spec_w_add_mul_div; auto with zarith. - rewrite spec_w_sub; auto with zarith. - rewrite spec_w_0. - simpl ww_to_Z; autorewrite with rm10. - rewrite Hv6; rewrite spec_w_zdigits. - rewrite (fun x y => Zmod_small (x - y)). - ring_simplify (Zpos w_digits - (Zpos w_digits - [[ww_head1 x]] / 2)). - rewrite Zmod_small. - simpl ww_to_Z in H2; rewrite H2; auto with zarith. - intros (H4, H5); split. - apply Z.mul_le_mono_pos_r with (2 ^ [[ww_head1 x]]); auto with zarith. - rewrite H4. - apply Z.le_trans with ([|w2|] ^ 2); auto with zarith. - rewrite Z.mul_comm. - pattern [[ww_head1 x]] at 1; - rewrite Hv0; auto with zarith. - rewrite (Z.mul_comm 2); rewrite Z.pow_mul_r; - auto with zarith. - assert (tmp: forall p q, p ^ 2 * q ^ 2 = (p * q) ^2); - try (intros; repeat rewrite Zsquare_mult; ring); - rewrite tmp; clear tmp. - apply Zpower_le_monotone3; auto with zarith. - split; auto with zarith. - pattern [|w2|] at 2; - rewrite (Z_div_mod_eq [|w2|] (2 ^ ([[ww_head1 x]] / 2))); - auto with zarith. - match goal with |- ?X <= ?X + ?Y => - assert (0 <= Y); auto with zarith - end. - case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]] / 2))); auto with zarith. - case c; unfold interp_carry; autorewrite with rm10; - intros w3; assert (V3 := spec_to_Z w3);auto with zarith. - apply Z.mul_lt_mono_pos_r with (2 ^ [[ww_head1 x]]); auto with zarith. - rewrite H4. - apply Z.le_lt_trans with ([|w2|] ^ 2 + 2 * [|w2|]); auto with zarith. - apply Z.lt_le_trans with (([|w2|] + 1) ^ 2); auto with zarith. - match goal with |- ?X < ?Y => - replace Y with (X + 1); auto with zarith - end. - repeat rewrite (Zsquare_mult); ring. - rewrite Z.mul_comm. - pattern [[ww_head1 x]] at 1; rewrite Hv0. - rewrite (Z.mul_comm 2); rewrite Z.pow_mul_r; - auto with zarith. - assert (tmp: forall p q, p ^ 2 * q ^ 2 = (p * q) ^2); - try (intros; repeat rewrite Zsquare_mult; ring); - rewrite tmp; clear tmp. - apply Zpower_le_monotone3; auto with zarith. - split; auto with zarith. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] (2 ^ ([[ww_head1 x]]/2))); - auto with zarith. - rewrite <- Z.add_assoc; rewrite Z.mul_add_distr_l. - autorewrite with rm10; apply Z.add_le_mono_l; auto with zarith. - case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]]/2))); auto with zarith. - split; auto with zarith. - apply Z.le_lt_trans with ([|w2|]); auto with zarith. - apply Zdiv_le_upper_bound; auto with zarith. - pattern [|w2|] at 1; replace [|w2|] with ([|w2|] * 2 ^0); - auto with zarith. - apply Z.mul_le_mono_nonneg_l; auto with zarith. - apply Zpower_le_monotone; auto with zarith. - rewrite Z.pow_0_r; autorewrite with rm10; auto. - split; auto with zarith. - rewrite Hv0 in Hv2; rewrite (Pos2Z.inj_xO w_digits) in Hv2; auto with zarith. - apply Z.le_lt_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_lt_lin; auto with zarith. - rewrite spec_w_sub; auto with zarith. - rewrite Hv6; rewrite spec_w_zdigits; auto with zarith. - assert (Hv7: 0 < [[ww_head1 x]]/2); auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - assert ([[ww_head1 x]]/2 <= Zpos w_digits); auto with zarith. - apply Z.mul_le_mono_pos_r with 2; auto with zarith. - repeat rewrite (fun x => Z.mul_comm x 2). - rewrite <- Hv0; rewrite <- Pos2Z.inj_xO; auto with zarith. - apply Z.le_lt_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_lt_lin; auto with zarith. - Qed. - -End DoubleSqrt. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v deleted file mode 100644 index a2df2600..00000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v +++ /dev/null @@ -1,356 +0,0 @@ - -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* w -> zn2z w. - Variable ww_Bm1 : zn2z w. - Variable w_opp_c : w -> carry w. - Variable w_opp_carry : w -> w. - Variable w_pred_c : w -> carry w. - Variable w_sub_c : w -> w -> carry w. - Variable w_sub_carry_c : w -> w -> carry w. - Variable w_opp : w -> w. - Variable w_pred : w -> w. - Variable w_sub : w -> w -> w. - Variable w_sub_carry : w -> w -> w. - - (* ** Opposites ** *) - Definition ww_opp_c x := - match x with - | W0 => C0 W0 - | WW xh xl => - match w_opp_c xl with - | C0 _ => - match w_opp_c xh with - | C0 h => C0 W0 - | C1 h => C1 (WW h w_0) - end - | C1 l => C1 (WW (w_opp_carry xh) l) - end - end. - - Definition ww_opp x := - match x with - | W0 => W0 - | WW xh xl => - match w_opp_c xl with - | C0 _ => WW (w_opp xh) w_0 - | C1 l => WW (w_opp_carry xh) l - end - end. - - Definition ww_opp_carry x := - match x with - | W0 => ww_Bm1 - | WW xh xl => w_WW (w_opp_carry xh) (w_opp_carry xl) - end. - - Definition ww_pred_c x := - match x with - | W0 => C1 ww_Bm1 - | WW xh xl => - match w_pred_c xl with - | C0 l => C0 (w_WW xh l) - | C1 _ => - match w_pred_c xh with - | C0 h => C0 (WW h w_Bm1) - | C1 _ => C1 ww_Bm1 - end - end - end. - - Definition ww_pred x := - match x with - | W0 => ww_Bm1 - | WW xh xl => - match w_pred_c xl with - | C0 l => w_WW xh l - | C1 l => WW (w_pred xh) w_Bm1 - end - end. - - Definition ww_sub_c x y := - match y, x with - | W0, _ => C0 x - | WW yh yl, W0 => ww_opp_c (WW yh yl) - | WW yh yl, WW xh xl => - match w_sub_c xl yl with - | C0 l => - match w_sub_c xh yh with - | C0 h => C0 (w_WW h l) - | C1 h => C1 (WW h l) - end - | C1 l => - match w_sub_carry_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (WW h l) - end - end - end. - - Definition ww_sub x y := - match y, x with - | W0, _ => x - | WW yh yl, W0 => ww_opp (WW yh yl) - | WW yh yl, WW xh xl => - match w_sub_c xl yl with - | C0 l => w_WW (w_sub xh yh) l - | C1 l => WW (w_sub_carry xh yh) l - end - end. - - Definition ww_sub_carry_c x y := - match y, x with - | W0, W0 => C1 ww_Bm1 - | W0, WW xh xl => ww_pred_c (WW xh xl) - | WW yh yl, W0 => C1 (ww_opp_carry (WW yh yl)) - | WW yh yl, WW xh xl => - match w_sub_carry_c xl yl with - | C0 l => - match w_sub_c xh yh with - | C0 h => C0 (w_WW h l) - | C1 h => C1 (WW h l) - end - | C1 l => - match w_sub_carry_c xh yh with - | C0 h => C0 (w_WW h l) - | C1 h => C1 (w_WW h l) - end - end - end. - - Definition ww_sub_carry x y := - match y, x with - | W0, W0 => ww_Bm1 - | W0, WW xh xl => ww_pred (WW xh xl) - | WW yh yl, W0 => ww_opp_carry (WW yh yl) - | WW yh yl, WW xh xl => - match w_sub_carry_c xl yl with - | C0 l => w_WW (w_sub xh yh) l - | C1 l => w_WW (w_sub_carry xh yh) l - end - end. - - (*Section DoubleProof.*) - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. - Variable spec_ww_Bm1 : [[ww_Bm1]] = wwB - 1. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - - Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. - Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB. - Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1. - - Variable spec_pred_c : forall x, [-|w_pred_c x|] = [|x|] - 1. - Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]. - Variable spec_sub_carry_c : - forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1. - - Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. - Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - Variable spec_sub_carry : - forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. - - - Lemma spec_ww_opp_c : forall x, [-[ww_opp_c x]] = -[[x]]. - Proof. - destruct x as [ |xh xl];simpl. reflexivity. - rewrite Z.opp_add_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl) - as [l|l];intros H;unfold interp_carry in H;rewrite <- H; - rewrite <- Z.mul_opp_l. - assert ([|l|] = 0). - assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. - rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh) - as [h|h];intros H1;unfold interp_carry in *;rewrite <- H1. - assert ([|h|] = 0). - assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. - rewrite H2;reflexivity. - simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_w_0;ring. - unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_opp_carry; - ring. - Qed. - - Lemma spec_ww_opp : forall x, [[ww_opp x]] = (-[[x]]) mod wwB. - Proof. - destruct x as [ |xh xl];simpl. reflexivity. - rewrite Z.opp_add_distr, <- Z.mul_opp_l. - generalize (spec_opp_c xl);destruct (w_opp_c xl) - as [l|l];intros H;unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. - rewrite spec_w_0;rewrite Z.add_0_r;rewrite wwB_wBwB. - assert ([|l|] = 0). - assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. - rewrite H0;rewrite Z.add_0_r; rewrite Z.pow_2_r; - rewrite Zmult_mod_distr_r;try apply lt_0_wB. - rewrite spec_opp;trivial. - apply Zmod_unique with (q:= -1). - exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW (w_opp_carry xh) l)). - rewrite spec_opp_carry;rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_opp_carry : forall x, [[ww_opp_carry x]] = wwB - [[x]] - 1. - Proof. - destruct x as [ |xh xl];simpl. rewrite spec_ww_Bm1;ring. - rewrite spec_w_WW;simpl;repeat rewrite spec_opp_carry;rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1. - Proof. - destruct x as [ |xh xl];unfold ww_pred_c. - unfold interp_carry;rewrite spec_ww_Bm1;simpl ww_to_Z;ring. - simpl ww_to_Z;replace (([|xh|]*wB+[|xl|])-1) with ([|xh|]*wB+([|xl|]-1)). - 2:ring. generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l]; - intros H;unfold interp_carry in H;rewrite <- H. simpl;apply spec_w_WW. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - assert ([|l|] = wB - 1). - assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. - rewrite H0;change ([|xh|] + -1) with ([|xh|] - 1). - generalize (spec_pred_c xh);destruct (w_pred_c xh) as [h|h]; - intros H1;unfold interp_carry in H1;rewrite <- H1. - simpl;rewrite spec_w_Bm1;ring. - assert ([|h|] = wB - 1). - assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. - rewrite H2;unfold interp_carry;rewrite spec_ww_Bm1;rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - Proof. - destruct y as [ |yh yl];simpl. ring. - destruct x as [ |xh xl];simpl. exact (spec_ww_opp_c (WW yh yl)). - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) - with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|])). 2:ring. - generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl) as [l|l];intros H; - unfold interp_carry in H;rewrite <- H. - generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; - unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; - try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). - generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *;rewrite <- H1;simpl ww_to_Z; - try rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_sub_carry_c : - forall x y, [-[ww_sub_carry_c x y]] = [[x]] - [[y]] - 1. - Proof. - destruct y as [ |yh yl];simpl. - unfold Z.sub;simpl;rewrite Z.add_0_r;exact (spec_ww_pred_c x). - destruct x as [ |xh xl]. - unfold interp_carry;rewrite spec_w_WW;simpl ww_to_Z;rewrite wwB_wBwB; - repeat rewrite spec_opp_carry;ring. - simpl ww_to_Z. - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) - with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|]-1)). 2:ring. - generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl) - as [l|l];intros H;unfold interp_carry in H;rewrite <- H. - generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; - unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; - try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). - generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *;rewrite <- H1;try rewrite spec_w_WW; - simpl ww_to_Z; try rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB. - Proof. - destruct x as [ |xh xl];simpl. - apply Zmod_unique with (-1). apply spec_ww_to_Z;trivial. - rewrite spec_ww_Bm1;ring. - replace ([|xh|]*wB + [|xl|] - 1) with ([|xh|]*wB + ([|xl|] - 1)). 2:ring. - generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];intro H; - unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. - rewrite Zmod_small. apply spec_w_WW. - exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh l)). - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - change ([|xh|] + -1) with ([|xh|] - 1). - assert ([|l|] = wB - 1). - assert (H1:= spec_to_Z l);assert (H2:= spec_to_Z xl);omega. - rewrite (mod_wwB w_digits w_to_Z);trivial. - rewrite spec_pred;rewrite spec_w_Bm1;rewrite <- H0;trivial. - Qed. - - Lemma spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - Proof. - destruct y as [ |yh yl];simpl. - ring_simplify ([[x]] - 0);rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial. - destruct x as [ |xh xl];simpl. exact (spec_ww_opp (WW yh yl)). - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) - with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|])). 2:ring. - generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl)as[l|l];intros H; - unfold interp_carry in H;rewrite <- H. - rewrite spec_w_WW;rewrite (mod_wwB w_digits w_to_Z spec_to_Z). - rewrite spec_sub;trivial. - simpl ww_to_Z;rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial. - Qed. - - Lemma spec_ww_sub_carry : - forall x y, [[ww_sub_carry x y]] = ([[x]] - [[y]] - 1) mod wwB. - Proof. - destruct y as [ |yh yl];simpl. - ring_simplify ([[x]] - 0);exact (spec_ww_pred x). - destruct x as [ |xh xl];simpl. - apply Zmod_unique with (-1). - apply spec_ww_to_Z;trivial. - fold (ww_opp_carry (WW yh yl)). - rewrite (spec_ww_opp_carry (WW yh yl));simpl ww_to_Z;ring. - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) - with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|] - 1)). 2:ring. - generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)as[l|l]; - intros H;unfold interp_carry in H;rewrite <- H;rewrite spec_w_WW. - rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub;trivial. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial. - Qed. - -(* End DoubleProof. *) - -End DoubleSub. - - - - - diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v deleted file mode 100644 index abd567a8..00000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v +++ /dev/null @@ -1,70 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* carry - | C1 : A -> carry. - - Definition interp_carry (sign:Z)(B:Z)(interp:A -> Z) c := - match c with - | C0 x => interp x - | C1 x => sign*B + interp x - end. - -End Carry. - -Section Zn2Z. - - Variable znz : Type. - - (** 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. - *) - - Inductive zn2z := - | W0 : zn2z - | WW : znz -> znz -> zn2z. - - Definition zn2z_to_Z (wB:Z) (w_to_Z:znz->Z) (x:zn2z) := - match x with - | W0 => 0 - | WW xh xl => w_to_Z xh * wB + w_to_Z xl - end. - -End Zn2Z. - -Arguments W0 {znz}. - -(** From a cyclic representation [w], we iterate the [zn2z] construct - [n] times, gaining the type of binary trees of depth at most [n], - whose leafs are either W0 (if depth < n) or elements of w - (if depth = n). -*) - -Fixpoint word (w:Type) (n:nat) : Type := - match n with - | O => w - | S n => zn2z (word w n) - end. - diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index 0e58b815..bd4f0279 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* + ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = + a mod 2 ^ p. + Proof. + intros. + rewrite Zmod_small. + rewrite Zmod_eq by (auto with zarith). + unfold Z.sub at 1. + rewrite Z_div_plus_full_l + by (cut (0 < 2^(n-p)); auto with zarith). + assert (2^n = 2^(n-p)*2^p). + rewrite <- Zpower_exp by (auto with zarith). + replace (n-p+p) with n; auto with zarith. + rewrite H0. + rewrite <- Zdiv_Zdiv, Z_div_mult by (auto with zarith). + rewrite (Z.mul_comm (2^(n-p))), Z.mul_assoc. + rewrite <- Z.mul_opp_l. + rewrite Z_div_mult by (auto with zarith). + symmetry; apply Zmod_eq; auto with zarith. + + remember (a * 2 ^ (n - p)) as b. + destruct (Z_mod_lt b (2^n)); auto with zarith. + split. + apply Z_div_pos; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + apply Z.lt_le_trans with (2^n); auto with zarith. + rewrite <- (Z.mul_1_r (2^n)) at 1. + apply Z.mul_le_mono_nonneg; auto with zarith. + cut (0 < 2 ^ (n-p)); auto with zarith. + Qed. + Lemma spec_pos_mod : forall w p, [|ZnZ.pos_mod p w|] = [|w|] mod (2 ^ [|p|]). Proof. @@ -1654,7 +1697,7 @@ Section Int31_Specs. rewrite spec_add_mul_div by (rewrite H4; auto with zarith). change [|0|] with 0%Z; rewrite Zdiv_0_l, Z.add_0_r. rewrite H4. - apply shift_unshift_mod_2; auto with zarith. + apply shift_unshift_mod_2; simpl; auto with zarith. Qed. @@ -1973,32 +2016,24 @@ Section Int31_Specs. assert (Hp2: 0 < [|2|]) by exact (eq_refl Lt). intros Hi Hj Hij H31 Hrec; rewrite sqrt31_step_def. rewrite spec_compare, div31_phi; auto. - case Z.compare_spec; auto; intros Hc; + case Z.compare_spec; auto; intros Hc; try (split; auto; apply sqrt_test_true; auto with zarith; fail). - apply Hrec; repeat rewrite div31_phi; auto with zarith. - replace [|(j + fst (i / j)%int31)|] with ([|j|] + [|i|] / [|j|]). - split. + assert (E : [|(j + fst (i / j)%int31)|] = [|j|] + [|i|] / [|j|]). + { rewrite spec_add, div31_phi; auto using Z.mod_small with zarith. } + apply Hrec; rewrite !div31_phi, E; auto using sqrt_main with zarith. + split; try apply sqrt_test_false; auto with zarith. apply Z.le_succ_l in Hj. change (1 <= [|j|]) in Hj. Z.le_elim Hj. - replace ([|j|] + [|i|]/[|j|]) with - (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])); try ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= [|i|]/ [|j|]) by (apply Z_div_pos; auto with zarith). - assert (0 <= ([|j|] - 2 + [|i|] / [|j|]) / [|2|]) ; auto with zarith. - rewrite <- Hj, Zdiv_1_r. - replace (1 + [|i|])%Z with (1 * 2 + ([|i|] - 1))%Z; try ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= ([|i|] - 1) /2)%Z by (apply Z_div_pos; auto with zarith). - change ([|2|]) with 2%Z; auto with zarith. - apply sqrt_test_false; auto with zarith. - rewrite spec_add, div31_phi; auto. - symmetry; apply Zmod_small. - split; auto with zarith. - replace [|j + fst (i / j)%int31|] with ([|j|] + [|i|] / [|j|]). - apply sqrt_main; auto with zarith. - rewrite spec_add, div31_phi; auto. - symmetry; apply Zmod_small. - split; auto with zarith. + - replace ([|j|] + [|i|]/[|j|]) with + (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])) by ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= [|i|]/ [|j|]) by auto with zarith. + assert (0 <= ([|j|] - 2 + [|i|] / [|j|]) / [|2|]); auto with zarith. + - rewrite <- Hj, Zdiv_1_r. + replace (1 + [|i|]) with (1 * 2 + ([|i|] - 1)) by ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= ([|i|] - 1) /2) by auto with zarith. + change ([|2|]) with 2; auto with zarith. Qed. Lemma iter31_sqrt_correct n rec i j: 0 < [|i|] -> 0 < [|j|] -> @@ -2078,11 +2113,12 @@ Section Int31_Specs. case (phi_bounded j); intros Hbj _. case (phi_bounded il); intros Hbil _. case (phi_bounded ih); intros Hbih Hbih1. - assert (([|ih|] < [|j|] + 1)%Z); auto with zarith. + assert ([|ih|] < [|j|] + 1); auto with zarith. apply Z.square_lt_simpl_nonneg; auto with zarith. - repeat rewrite <-Z.pow_2_r; apply Z.le_lt_trans with (2 := H1). - apply Z.le_trans with ([|ih|] * base)%Z; unfold phi2, base; - try rewrite Z.pow_2_r; auto with zarith. + rewrite <- ?Z.pow_2_r; apply Z.le_lt_trans with (2 := H1). + apply Z.le_trans with ([|ih|] * wB). + - rewrite ? Z.pow_2_r; auto with zarith. + - unfold phi2. change base with wB; auto with zarith. Qed. Lemma div312_phi ih il j: (2^30 <= [|j|] -> [|ih|] < [|j|] -> @@ -2104,90 +2140,89 @@ Section Int31_Specs. Proof. assert (Hp2: (0 < [|2|])%Z) by exact (eq_refl Lt). intros Hih Hj Hij Hrec; rewrite sqrt312_step_def. - assert (H1: ([|ih|] <= [|j|])%Z) by (apply sqrt312_lower_bound with il; auto). + assert (H1: ([|ih|] <= [|j|])) by (apply sqrt312_lower_bound with il; auto). case (phi_bounded ih); intros Hih1 _. case (phi_bounded il); intros Hil1 _. case (phi_bounded j); intros _ Hj1. assert (Hp3: (0 < phi2 ih il)). - unfold phi2; apply Z.lt_le_trans with ([|ih|] * base)%Z; auto with zarith. - apply Z.mul_pos_pos; auto with zarith. - apply Z.lt_le_trans with (2:= Hih); auto with zarith. + { unfold phi2; apply Z.lt_le_trans with ([|ih|] * base); auto with zarith. + apply Z.mul_pos_pos; auto with zarith. + apply Z.lt_le_trans with (2:= Hih); auto with zarith. } rewrite spec_compare. case Z.compare_spec; intros Hc1. - split; auto. - apply sqrt_test_true; auto. - unfold phi2, base; auto with zarith. - unfold phi2; rewrite Hc1. - assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith). - rewrite Z.mul_comm, Z_div_plus_full_l; unfold base; auto with zarith. - simpl wB in Hj1. unfold Z.pow_pos in Hj1. simpl in Hj1. auto with zarith. - case (Z.le_gt_cases (2 ^ 30) [|j|]); intros Hjj. - rewrite spec_compare; case Z.compare_spec; - rewrite div312_phi; auto; intros Hc; - try (split; auto; apply sqrt_test_true; auto with zarith; fail). - apply Hrec. - assert (Hf1: 0 <= phi2 ih il/ [|j|]) by (apply Z_div_pos; auto with zarith). - apply Z.le_succ_l in Hj. change (1 <= [|j|]) in Hj. - Z.le_elim Hj. - 2: contradict Hc; apply Z.le_ngt; rewrite <- Hj, Zdiv_1_r; auto with zarith. - assert (Hf3: 0 < ([|j|] + phi2 ih il / [|j|]) / 2). - replace ([|j|] + phi2 ih il/ [|j|])%Z with - (1 * 2 + (([|j|] - 2) + phi2 ih il / [|j|])); try ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= ([|j|] - 2 + phi2 ih il / [|j|]) / 2) ; auto with zarith. - assert (Hf4: ([|j|] + phi2 ih il / [|j|]) / 2 < [|j|]). - apply sqrt_test_false; auto with zarith. - generalize (spec_add_c j (fst (div3121 ih il j))). - unfold interp_carry; case add31c; intros r; - rewrite div312_phi; auto with zarith. - rewrite div31_phi; change [|2|] with 2%Z; auto with zarith. - intros HH; rewrite HH; clear HH; auto with zarith. - rewrite spec_add, div31_phi; change [|2|] with 2%Z; auto. - rewrite Z.mul_1_l; intros HH. - rewrite Z.add_comm, <- Z_div_plus_full_l; auto with zarith. - change (phi v30 * 2) with (2 ^ Z.of_nat size). - rewrite HH, Zmod_small; auto with zarith. - replace (phi - match j +c fst (div3121 ih il j) with - | C0 m1 => fst (m1 / 2)%int31 - | C1 m1 => fst (m1 / 2)%int31 + v30 - end) with ((([|j|] + (phi2 ih il)/([|j|]))/2)). - apply sqrt_main; auto with zarith. - generalize (spec_add_c j (fst (div3121 ih il j))). - unfold interp_carry; case add31c; intros r; - rewrite div312_phi; auto with zarith. - rewrite div31_phi; auto with zarith. - intros HH; rewrite HH; auto with zarith. - intros HH; rewrite <- HH. - change (1 * 2 ^ Z.of_nat size) with (phi (v30) * 2). - rewrite Z_div_plus_full_l; auto with zarith. - rewrite Z.add_comm. - rewrite spec_add, Zmod_small. - rewrite div31_phi; auto. - split; auto with zarith. - case (phi_bounded (fst (r/2)%int31)); - case (phi_bounded v30); auto with zarith. - rewrite div31_phi; change (phi 2) with 2%Z; auto. - change (2 ^Z.of_nat size) with (base/2 + phi v30). - assert (phi r / 2 < base/2); auto with zarith. - apply Z.mul_lt_mono_pos_r with 2; auto with zarith. - change (base/2 * 2) with base. - apply Z.le_lt_trans with (phi r). - rewrite Z.mul_comm; apply Z_mult_div_ge; auto with zarith. - case (phi_bounded r); auto with zarith. - contradict Hij; apply Z.le_ngt. - assert ((1 + [|j|]) <= 2 ^ 30); auto with zarith. - apply Z.le_trans with ((2 ^ 30) * (2 ^ 30)); auto with zarith. - assert (0 <= 1 + [|j|]); auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - change ((2 ^ 30) * (2 ^ 30)) with ((2 ^ 29) * base). - apply Z.le_trans with ([|ih|] * base); auto with zarith. - unfold phi2, base; auto with zarith. - split; auto. - apply sqrt_test_true; auto. - unfold phi2, base; auto with zarith. - apply Z.le_ge; apply Z.le_trans with (([|j|] * base)/[|j|]). - rewrite Z.mul_comm, Z_div_mult; auto with zarith. - apply Z.ge_le; apply Z_div_ge; auto with zarith. + - split; auto. + apply sqrt_test_true; auto. + + unfold phi2, base; auto with zarith. + + unfold phi2; rewrite Hc1. + assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith). + rewrite Z.mul_comm, Z_div_plus_full_l; auto with zarith. + change base with wB. auto with zarith. + - case (Z.le_gt_cases (2 ^ 30) [|j|]); intros Hjj. + + rewrite spec_compare; case Z.compare_spec; + rewrite div312_phi; auto; intros Hc; + try (split; auto; apply sqrt_test_true; auto with zarith; fail). + apply Hrec. + * assert (Hf1: 0 <= phi2 ih il/ [|j|]) by auto with zarith. + apply Z.le_succ_l in Hj. change (1 <= [|j|]) in Hj. + Z.le_elim Hj; + [ | contradict Hc; apply Z.le_ngt; + rewrite <- Hj, Zdiv_1_r; auto with zarith ]. + assert (Hf3: 0 < ([|j|] + phi2 ih il / [|j|]) / 2). + { replace ([|j|] + phi2 ih il/ [|j|]) with + (1 * 2 + (([|j|] - 2) + phi2 ih il / [|j|])); try ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= ([|j|] - 2 + phi2 ih il / [|j|]) / 2) ; + auto with zarith. } + assert (Hf4: ([|j|] + phi2 ih il / [|j|]) / 2 < [|j|]). + { apply sqrt_test_false; auto with zarith. } + generalize (spec_add_c j (fst (div3121 ih il j))). + unfold interp_carry; case add31c; intros r; + rewrite div312_phi; auto with zarith. + { rewrite div31_phi; change [|2|] with 2; auto with zarith. + intros HH; rewrite HH; clear HH; auto with zarith. } + { rewrite spec_add, div31_phi; change [|2|] with 2; auto. + rewrite Z.mul_1_l; intros HH. + rewrite Z.add_comm, <- Z_div_plus_full_l; auto with zarith. + change (phi v30 * 2) with (2 ^ Z.of_nat size). + rewrite HH, Zmod_small; auto with zarith. } + * replace (phi _) with (([|j|] + (phi2 ih il)/([|j|]))/2); + [ apply sqrt_main; auto with zarith | ]. + generalize (spec_add_c j (fst (div3121 ih il j))). + unfold interp_carry; case add31c; intros r; + rewrite div312_phi; auto with zarith. + { rewrite div31_phi; auto with zarith. + intros HH; rewrite HH; auto with zarith. } + { intros HH; rewrite <- HH. + change (1 * 2 ^ Z.of_nat size) with (phi (v30) * 2). + rewrite Z_div_plus_full_l; auto with zarith. + rewrite Z.add_comm. + rewrite spec_add, Zmod_small. + - rewrite div31_phi; auto. + - split; auto with zarith. + + case (phi_bounded (fst (r/2)%int31)); + case (phi_bounded v30); auto with zarith. + + rewrite div31_phi; change (phi 2) with 2; auto. + change (2 ^Z.of_nat size) with (base/2 + phi v30). + assert (phi r / 2 < base/2); auto with zarith. + apply Z.mul_lt_mono_pos_r with 2; auto with zarith. + change (base/2 * 2) with base. + apply Z.le_lt_trans with (phi r). + * rewrite Z.mul_comm; apply Z_mult_div_ge; auto with zarith. + * case (phi_bounded r); auto with zarith. } + + contradict Hij; apply Z.le_ngt. + assert ((1 + [|j|]) <= 2 ^ 30); auto with zarith. + apply Z.le_trans with ((2 ^ 30) * (2 ^ 30)); auto with zarith. + * assert (0 <= 1 + [|j|]); auto with zarith. + apply Z.mul_le_mono_nonneg; auto with zarith. + * change ((2 ^ 30) * (2 ^ 30)) with ((2 ^ 29) * base). + apply Z.le_trans with ([|ih|] * base); + change wB with base in *; auto with zarith. + unfold phi2, base; auto with zarith. + - split; auto. + apply sqrt_test_true; auto. + + unfold phi2, base; auto with zarith. + + apply Z.le_ge; apply Z.le_trans with (([|j|] * base)/[|j|]). + * rewrite Z.mul_comm, Z_div_mult; auto with zarith. + * apply Z.ge_le; apply Z_div_ge; auto with zarith. Qed. Lemma iter312_sqrt_correct n rec ih il j: @@ -2209,7 +2244,7 @@ Section Int31_Specs. intros j3 Hj3 Hpj3. apply HHrec; auto. rewrite Nat2Z.inj_succ, Z.pow_succ_r. - apply Z.le_trans with (2 ^Z.of_nat n + [|j2|])%Z; auto with zarith. + apply Z.le_trans with (2 ^Z.of_nat n + [|j2|]); auto with zarith. apply Nat2Z.is_nonneg. Qed. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index ff4b998e..9f8da831 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0. Proof. + apply Z.lt_gt. unfold wB, base; auto with zarith. Qed. Hint Resolve wB_pos. @@ -558,7 +561,7 @@ Section ZModulo. apply Zmod_small. generalize (Z_mod_lt [|w|] (2 ^ [|p|])); intros. split. - destruct H; auto with zarith. + destruct H; auto using Z.lt_gt with zarith. apply Z.le_lt_trans with [|w|]; auto with zarith. apply Zmod_le; auto with zarith. Qed. diff --git a/theories/Numbers/DecimalFacts.v b/theories/Numbers/DecimalFacts.v new file mode 100644 index 00000000..0f490527 --- /dev/null +++ b/theories/Numbers/DecimalFacts.v @@ -0,0 +1,143 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* d' }. +Proof. + decide equality. +Defined. + +Lemma rev_revapp d d' : + rev (revapp d d') = revapp d' d. +Proof. + revert d'. induction d; simpl; intros; now rewrite ?IHd. +Qed. + +Lemma rev_rev d : rev (rev d) = d. +Proof. + apply rev_revapp. +Qed. + +(** Normalization on little-endian numbers *) + +Fixpoint nztail d := + match d with + | Nil => Nil + | D0 d => match nztail d with Nil => Nil | d' => D0 d' end + | D1 d => D1 (nztail d) + | D2 d => D2 (nztail d) + | D3 d => D3 (nztail d) + | D4 d => D4 (nztail d) + | D5 d => D5 (nztail d) + | D6 d => D6 (nztail d) + | D7 d => D7 (nztail d) + | D8 d => D8 (nztail d) + | D9 d => D9 (nztail d) + end. + +Definition lnorm d := + match nztail d with + | Nil => zero + | d => d + end. + +Lemma nzhead_revapp_0 d d' : nztail d = Nil -> + nzhead (revapp d d') = nzhead d'. +Proof. + revert d'. induction d; intros d' [=]; simpl; trivial. + destruct (nztail d); now rewrite IHd. +Qed. + +Lemma nzhead_revapp d d' : nztail d <> Nil -> + nzhead (revapp d d') = revapp (nztail d) d'. +Proof. + revert d'. + induction d; intros d' H; simpl in *; + try destruct (nztail d) eqn:E; + (now rewrite ?nzhead_revapp_0) || (now rewrite IHd). +Qed. + +Lemma nzhead_rev d : nztail d <> Nil -> + nzhead (rev d) = rev (nztail d). +Proof. + apply nzhead_revapp. +Qed. + +Lemma rev_nztail_rev d : + rev (nztail (rev d)) = nzhead d. +Proof. + destruct (uint_dec (nztail (rev d)) Nil) as [H|H]. + - rewrite H. unfold rev; simpl. + rewrite <- (rev_rev d). symmetry. + now apply nzhead_revapp_0. + - now rewrite <- nzhead_rev, rev_rev. +Qed. + +Lemma revapp_nil_inv d d' : revapp d d' = Nil -> d = Nil /\ d' = Nil. +Proof. + revert d'. + induction d; simpl; intros d' H; auto; now apply IHd in H. +Qed. + +Lemma rev_nil_inv d : rev d = Nil -> d = Nil. +Proof. + apply revapp_nil_inv. +Qed. + +Lemma rev_lnorm_rev d : + rev (lnorm (rev d)) = unorm d. +Proof. + unfold unorm, lnorm. + rewrite <- rev_nztail_rev. + destruct nztail; simpl; trivial; + destruct rev eqn:E; trivial; now apply rev_nil_inv in E. +Qed. + +Lemma nzhead_nonzero d d' : nzhead d <> D0 d'. +Proof. + induction d; easy. +Qed. + +Lemma unorm_0 d : unorm d = zero <-> nzhead d = Nil. +Proof. + unfold unorm. split. + - generalize (nzhead_nonzero d). + destruct nzhead; intros H [=]; trivial. now destruct (H u). + - now intros ->. +Qed. + +Lemma unorm_nonnil d : unorm d <> Nil. +Proof. + unfold unorm. now destruct nzhead. +Qed. + +Lemma nzhead_invol d : nzhead (nzhead d) = nzhead d. +Proof. + now induction d. +Qed. + +Lemma unorm_invol d : unorm (unorm d) = unorm d. +Proof. + unfold unorm. + destruct (nzhead d) eqn:E; trivial. + destruct (nzhead_nonzero _ _ E). +Qed. + +Lemma norm_invol d : norm (norm d) = norm d. +Proof. + unfold norm. + destruct d. + - f_equal. apply unorm_invol. + - destruct (nzhead d) eqn:E; auto. + destruct (nzhead_nonzero _ _ E). +Qed. diff --git a/theories/Numbers/DecimalN.v b/theories/Numbers/DecimalN.v new file mode 100644 index 00000000..ef00e280 --- /dev/null +++ b/theories/Numbers/DecimalN.v @@ -0,0 +1,107 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* n = n'. +Proof. + intros E. now rewrite <- (of_to n), <- (of_to n'), E. +Qed. + +Lemma to_uint_surj d : exists p, N.to_uint p = unorm d. +Proof. + exists (N.of_uint d). apply to_of. +Qed. + +Lemma of_uint_norm d : N.of_uint (unorm d) = N.of_uint d. +Proof. + now induction d. +Qed. + +Lemma of_inj d d' : + N.of_uint d = N.of_uint d' -> unorm d = unorm d'. +Proof. + intros. rewrite <- !to_of. now f_equal. +Qed. + +Lemma of_iff d d' : N.of_uint d = N.of_uint d' <-> unorm d = unorm d'. +Proof. + split. apply of_inj. intros E. rewrite <- of_uint_norm, E. + apply of_uint_norm. +Qed. + +End Unsigned. + +(** Conversion from/to signed decimal numbers *) + +Module Signed. + +Lemma of_to (n:N) : N.of_int (N.to_int n) = Some n. +Proof. + unfold N.to_int, N.of_int, norm. f_equal. + rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. +Qed. + +Lemma to_of (d:int)(n:N) : N.of_int d = Some n -> N.to_int n = norm d. +Proof. + unfold N.of_int. + destruct (norm d) eqn:Hd; intros [= <-]. + unfold N.to_int. rewrite Unsigned.to_of. f_equal. + revert Hd; destruct d; simpl. + - intros [= <-]. apply unorm_invol. + - destruct (nzhead d); now intros [= <-]. +Qed. + +Lemma to_int_inj n n' : N.to_int n = N.to_int n' -> n = n'. +Proof. + intro E. + assert (E' : Some n = Some n'). + { now rewrite <- (of_to n), <- (of_to n'), E. } + now injection E'. +Qed. + +Lemma to_int_pos_surj d : exists n, N.to_int n = norm (Pos d). +Proof. + exists (N.of_uint d). unfold N.to_int. now rewrite Unsigned.to_of. +Qed. + +Lemma of_int_norm d : N.of_int (norm d) = N.of_int d. +Proof. + unfold N.of_int. now rewrite norm_invol. +Qed. + +Lemma of_inj_pos d d' : + N.of_int (Pos d) = N.of_int (Pos d') -> unorm d = unorm d'. +Proof. + unfold N.of_int. simpl. intros [= H]. apply Unsigned.of_inj. + change Pos.of_uint with N.of_uint in H. + now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. +Qed. + +End Signed. diff --git a/theories/Numbers/DecimalNat.v b/theories/Numbers/DecimalNat.v new file mode 100644 index 00000000..5ffe1688 --- /dev/null +++ b/theories/Numbers/DecimalNat.v @@ -0,0 +1,302 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* 0 + | D0 _ => 0 + | D1 _ => 1 + | D2 _ => 2 + | D3 _ => 3 + | D4 _ => 4 + | D5 _ => 5 + | D6 _ => 6 + | D7 _ => 7 + | D8 _ => 8 + | D9 _ => 9 +end. + +Definition tl d := + match d with + | Nil => d + | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => d +end. + +Fixpoint usize (d:uint) : nat := + match d with + | Nil => 0 + | D0 d => S (usize d) + | D1 d => S (usize d) + | D2 d => S (usize d) + | D3 d => S (usize d) + | D4 d => S (usize d) + | D5 d => S (usize d) + | D6 d => S (usize d) + | D7 d => S (usize d) + | D8 d => S (usize d) + | D9 d => S (usize d) + end. + +(** A direct version of [to_little_uint], not tail-recursive *) +Fixpoint to_lu n := + match n with + | 0 => Decimal.zero + | S n => Little.succ (to_lu n) + end. + +(** A direct version of [of_little_uint] *) +Fixpoint of_lu (d:uint) : nat := + match d with + | Nil => 0 + | D0 d => 10 * of_lu d + | D1 d => 1 + 10 * of_lu d + | D2 d => 2 + 10 * of_lu d + | D3 d => 3 + 10 * of_lu d + | D4 d => 4 + 10 * of_lu d + | D5 d => 5 + 10 * of_lu d + | D6 d => 6 + 10 * of_lu d + | D7 d => 7 + 10 * of_lu d + | D8 d => 8 + 10 * of_lu d + | D9 d => 9 + 10 * of_lu d + end. + +(** Properties of [to_lu] *) + +Lemma to_lu_succ n : to_lu (S n) = Little.succ (to_lu n). +Proof. + reflexivity. +Qed. + +Lemma to_little_uint_succ n d : + Nat.to_little_uint n (Little.succ d) = + Little.succ (Nat.to_little_uint n d). +Proof. + revert d; induction n; simpl; trivial. +Qed. + +Lemma to_lu_equiv n : + to_lu n = Nat.to_little_uint n zero. +Proof. + induction n; simpl; trivial. + now rewrite IHn, <- to_little_uint_succ. +Qed. + +Lemma to_uint_alt n : + Nat.to_uint n = rev (to_lu n). +Proof. + unfold Nat.to_uint. f_equal. symmetry. apply to_lu_equiv. +Qed. + +(** Properties of [of_lu] *) + +Lemma of_lu_eqn d : + of_lu d = hd d + 10 * of_lu (tl d). +Proof. + induction d; simpl; trivial. +Qed. + +Ltac simpl_of_lu := + match goal with + | |- context [ of_lu (?f ?x) ] => + rewrite (of_lu_eqn (f x)); simpl hd; simpl tl + end. + +Lemma of_lu_succ d : + of_lu (Little.succ d) = S (of_lu d). +Proof. + induction d; trivial. + simpl_of_lu. rewrite IHd. simpl_of_lu. + now rewrite Nat.mul_succ_r, <- (Nat.add_comm 10). +Qed. + +Lemma of_to_lu n : + of_lu (to_lu n) = n. +Proof. + induction n; simpl; trivial. rewrite of_lu_succ. now f_equal. +Qed. + +Lemma of_lu_revapp d d' : +of_lu (revapp d d') = + of_lu (rev d) + of_lu d' * 10^usize d. +Proof. + revert d'. + induction d; intro d'; simpl usize; + [ simpl; now rewrite Nat.mul_1_r | .. ]; + unfold rev; simpl revapp; rewrite 2 IHd; + rewrite <- Nat.add_assoc; f_equal; simpl_of_lu; simpl of_lu; + rewrite Nat.pow_succ_r'; ring. +Qed. + +Lemma of_uint_acc_spec n d : + Nat.of_uint_acc d n = of_lu (rev d) + n * 10^usize d. +Proof. + revert n. induction d; intros; + simpl Nat.of_uint_acc; rewrite ?Nat.tail_mul_spec, ?IHd; + simpl rev; simpl usize; rewrite ?Nat.pow_succ_r'; + [ simpl; now rewrite Nat.mul_1_r | .. ]; + unfold rev at 2; simpl revapp; rewrite of_lu_revapp; + simpl of_lu; ring. +Qed. + +Lemma of_uint_alt d : Nat.of_uint d = of_lu (rev d). +Proof. + unfold Nat.of_uint. now rewrite of_uint_acc_spec. +Qed. + +(** First main bijection result *) + +Lemma of_to (n:nat) : Nat.of_uint (Nat.to_uint n) = n. +Proof. + rewrite to_uint_alt, of_uint_alt, rev_rev. apply of_to_lu. +Qed. + +(** The other direction *) + +Lemma to_lu_tenfold n : n<>0 -> + to_lu (10 * n) = D0 (to_lu n). +Proof. + induction n. + - simpl. now destruct 1. + - intros _. + destruct (Nat.eq_dec n 0) as [->|H]; simpl; trivial. + rewrite !Nat.add_succ_r. + simpl in *. rewrite (IHn H). now destruct (to_lu n). +Qed. + +Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. +Proof. + induction d; try simpl_of_lu; try easy. + rewrite Nat.add_0_l. + split; intros H. + - apply Nat.eq_mul_0_r in H; auto. + rewrite IHd in H. simpl. now rewrite H. + - simpl in H. destruct (nztail d); try discriminate. + now destruct IHd as [_ ->]. +Qed. + +Lemma to_of_lu_tenfold d : + to_lu (of_lu d) = lnorm d -> + to_lu (10 * of_lu d) = lnorm (D0 d). +Proof. + intro IH. + destruct (Nat.eq_dec (of_lu d) 0) as [H|H]. + - rewrite H. simpl. rewrite of_lu_0 in H. + unfold lnorm. simpl. now rewrite H. + - rewrite (to_lu_tenfold _ H), IH. + rewrite of_lu_0 in H. + unfold lnorm. simpl. now destruct (nztail d). +Qed. + +Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. +Proof. + induction d; [ reflexivity | .. ]; + simpl_of_lu; + rewrite ?Nat.add_succ_l, Nat.add_0_l, ?to_lu_succ, to_of_lu_tenfold + by assumption; + unfold lnorm; simpl; now destruct nztail. +Qed. + +(** Second bijection result *) + +Lemma to_of (d:uint) : Nat.to_uint (Nat.of_uint d) = unorm d. +Proof. + rewrite to_uint_alt, of_uint_alt, to_of_lu. + apply rev_lnorm_rev. +Qed. + +(** Some consequences *) + +Lemma to_uint_inj n n' : Nat.to_uint n = Nat.to_uint n' -> n = n'. +Proof. + intro EQ. + now rewrite <- (of_to n), <- (of_to n'), EQ. +Qed. + +Lemma to_uint_surj d : exists n, Nat.to_uint n = unorm d. +Proof. + exists (Nat.of_uint d). apply to_of. +Qed. + +Lemma of_uint_norm d : Nat.of_uint (unorm d) = Nat.of_uint d. +Proof. + unfold Nat.of_uint. now induction d. +Qed. + +Lemma of_inj d d' : + Nat.of_uint d = Nat.of_uint d' -> unorm d = unorm d'. +Proof. + intros. rewrite <- !to_of. now f_equal. +Qed. + +Lemma of_iff d d' : Nat.of_uint d = Nat.of_uint d' <-> unorm d = unorm d'. +Proof. + split. apply of_inj. intros E. rewrite <- of_uint_norm, E. + apply of_uint_norm. +Qed. + +End Unsigned. + +(** Conversion from/to signed decimal numbers *) + +Module Signed. + +Lemma of_to (n:nat) : Nat.of_int (Nat.to_int n) = Some n. +Proof. + unfold Nat.to_int, Nat.of_int, norm. f_equal. + rewrite Unsigned.of_uint_norm. apply Unsigned.of_to. +Qed. + +Lemma to_of (d:int)(n:nat) : Nat.of_int d = Some n -> Nat.to_int n = norm d. +Proof. + unfold Nat.of_int. + destruct (norm d) eqn:Hd; intros [= <-]. + unfold Nat.to_int. rewrite Unsigned.to_of. f_equal. + revert Hd; destruct d; simpl. + - intros [= <-]. apply unorm_invol. + - destruct (nzhead d); now intros [= <-]. +Qed. + +Lemma to_int_inj n n' : Nat.to_int n = Nat.to_int n' -> n = n'. +Proof. + intro E. + assert (E' : Some n = Some n'). + { now rewrite <- (of_to n), <- (of_to n'), E. } + now injection E'. +Qed. + +Lemma to_int_pos_surj d : exists n, Nat.to_int n = norm (Pos d). +Proof. + exists (Nat.of_uint d). unfold Nat.to_int. now rewrite Unsigned.to_of. +Qed. + +Lemma of_int_norm d : Nat.of_int (norm d) = Nat.of_int d. +Proof. + unfold Nat.of_int. now rewrite norm_invol. +Qed. + +Lemma of_inj_pos d d' : + Nat.of_int (Pos d) = Nat.of_int (Pos d') -> unorm d = unorm d'. +Proof. + unfold Nat.of_int. simpl. intros [= H]. apply Unsigned.of_inj. + now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm. +Qed. + +End Signed. diff --git a/theories/Numbers/DecimalPos.v b/theories/Numbers/DecimalPos.v new file mode 100644 index 00000000..722e73d9 --- /dev/null +++ b/theories/Numbers/DecimalPos.v @@ -0,0 +1,383 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* 0 + | D0 d => 10 * of_lu d + | D1 d => 1 + 10 * of_lu d + | D2 d => 2 + 10 * of_lu d + | D3 d => 3 + 10 * of_lu d + | D4 d => 4 + 10 * of_lu d + | D5 d => 5 + 10 * of_lu d + | D6 d => 6 + 10 * of_lu d + | D7 d => 7 + 10 * of_lu d + | D8 d => 8 + 10 * of_lu d + | D9 d => 9 + 10 * of_lu d + end. + +Definition hd d := +match d with + | Nil => 0 + | D0 _ => 0 + | D1 _ => 1 + | D2 _ => 2 + | D3 _ => 3 + | D4 _ => 4 + | D5 _ => 5 + | D6 _ => 6 + | D7 _ => 7 + | D8 _ => 8 + | D9 _ => 9 +end. + +Definition tl d := + match d with + | Nil => d + | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => d +end. + +Lemma of_lu_eqn d : + of_lu d = hd d + 10 * (of_lu (tl d)). +Proof. + induction d; simpl; trivial. +Qed. + +Ltac simpl_of_lu := + match goal with + | |- context [ of_lu (?f ?x) ] => + rewrite (of_lu_eqn (f x)); simpl hd; simpl tl + end. + +Fixpoint usize (d:uint) : N := + match d with + | Nil => 0 + | D0 d => N.succ (usize d) + | D1 d => N.succ (usize d) + | D2 d => N.succ (usize d) + | D3 d => N.succ (usize d) + | D4 d => N.succ (usize d) + | D5 d => N.succ (usize d) + | D6 d => N.succ (usize d) + | D7 d => N.succ (usize d) + | D8 d => N.succ (usize d) + | D9 d => N.succ (usize d) + end. + +Lemma of_lu_revapp d d' : + of_lu (revapp d d') = + of_lu (rev d) + of_lu d' * 10^usize d. +Proof. + revert d'. + induction d; simpl; intro d'; [ now rewrite N.mul_1_r | .. ]; + unfold rev; simpl revapp; rewrite 2 IHd; + rewrite <- N.add_assoc; f_equal; simpl_of_lu; simpl of_lu; + rewrite N.pow_succ_r'; ring. +Qed. + +Definition Nadd n p := + match n with + | N0 => p + | Npos p0 => (p0+p)%positive + end. + +Lemma Nadd_simpl n p q : Npos (Nadd n (p * q)) = n + Npos p * Npos q. +Proof. + now destruct n. +Qed. + +Lemma of_uint_acc_eqn d acc : d<>Nil -> + Pos.of_uint_acc d acc = Pos.of_uint_acc (tl d) (Nadd (hd d) (10*acc)). +Proof. + destruct d; simpl; trivial. now destruct 1. +Qed. + +Lemma of_uint_acc_rev d acc : + Npos (Pos.of_uint_acc d acc) = + of_lu (rev d) + (Npos acc) * 10^usize d. +Proof. + revert acc. + induction d; intros; simpl usize; + [ simpl; now rewrite Pos.mul_1_r | .. ]; + rewrite N.pow_succ_r'; + unfold rev; simpl revapp; try rewrite of_lu_revapp; simpl of_lu; + rewrite of_uint_acc_eqn by easy; simpl tl; simpl hd; + rewrite IHd, Nadd_simpl; ring. +Qed. + +Lemma of_uint_alt d : Pos.of_uint d = of_lu (rev d). +Proof. + induction d; simpl; trivial; unfold rev; simpl revapp; + rewrite of_lu_revapp; simpl of_lu; try apply of_uint_acc_rev. + rewrite IHd. ring. +Qed. + +Lemma of_lu_rev d : Pos.of_uint (rev d) = of_lu d. +Proof. + rewrite of_uint_alt. now rewrite rev_rev. +Qed. + +Lemma of_lu_double_gen d : + of_lu (Little.double d) = N.double (of_lu d) /\ + of_lu (Little.succ_double d) = N.succ_double (of_lu d). +Proof. + rewrite N.double_spec, N.succ_double_spec. + induction d; try destruct IHd as (IH1,IH2); + simpl Little.double; simpl Little.succ_double; + repeat (simpl_of_lu; rewrite ?IH1, ?IH2); split; reflexivity || ring. +Qed. + +Lemma of_lu_double d : + of_lu (Little.double d) = N.double (of_lu d). +Proof. + apply of_lu_double_gen. +Qed. + +Lemma of_lu_succ_double d : + of_lu (Little.succ_double d) = N.succ_double (of_lu d). +Proof. + apply of_lu_double_gen. +Qed. + +(** First bijection result *) + +Lemma of_to (p:positive) : Pos.of_uint (Pos.to_uint p) = Npos p. +Proof. + unfold Pos.to_uint. + rewrite of_lu_rev. + induction p; simpl; trivial. + - now rewrite of_lu_succ_double, IHp. + - now rewrite of_lu_double, IHp. +Qed. + +(** The other direction *) + +Definition to_lu n := + match n with + | N0 => Decimal.zero + | Npos p => Pos.to_little_uint p + end. + +Lemma succ_double_alt d : + Little.succ_double d = Little.succ (Little.double d). +Proof. + now induction d. +Qed. + +Lemma double_succ d : + Little.double (Little.succ d) = + Little.succ (Little.succ_double d). +Proof. + induction d; simpl; f_equal; auto using succ_double_alt. +Qed. + +Lemma to_lu_succ n : + to_lu (N.succ n) = Little.succ (to_lu n). +Proof. + destruct n; simpl; trivial. + induction p; simpl; rewrite ?IHp; + auto using succ_double_alt, double_succ. +Qed. + +Lemma nat_iter_S n {A} (f:A->A) i : + Nat.iter (S n) f i = f (Nat.iter n f i). +Proof. + reflexivity. +Qed. + +Lemma nat_iter_0 {A} (f:A->A) i : Nat.iter 0 f i = i. +Proof. + reflexivity. +Qed. + +Lemma to_ldec_tenfold p : + to_lu (10 * Npos p) = D0 (to_lu (Npos p)). +Proof. + induction p using Pos.peano_rect. + - trivial. + - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). + rewrite N.mul_succ_r. + change 10 at 2 with (Nat.iter 10%nat N.succ 0). + rewrite ?nat_iter_S, nat_iter_0. + rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp. + destruct (to_lu (N.pos p)); simpl; auto. +Qed. + +Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil. +Proof. + induction d; try simpl_of_lu; split; trivial; try discriminate; + try (intros H; now apply N.eq_add_0 in H). + - rewrite N.add_0_l. intros H. + apply N.eq_mul_0_r in H; [|easy]. rewrite IHd in H. + simpl. now rewrite H. + - simpl. destruct (nztail d); try discriminate. + now destruct IHd as [_ ->]. +Qed. + +Lemma to_of_lu_tenfold d : + to_lu (of_lu d) = lnorm d -> + to_lu (10 * of_lu d) = lnorm (D0 d). +Proof. + intro IH. + destruct (N.eq_dec (of_lu d) 0) as [H|H]. + - rewrite H. simpl. rewrite of_lu_0 in H. + unfold lnorm. simpl. now rewrite H. + - destruct (of_lu d) eqn:Eq; [easy| ]. + rewrite to_ldec_tenfold; auto. rewrite IH. + rewrite <- Eq in H. rewrite of_lu_0 in H. + unfold lnorm. simpl. now destruct (nztail d). +Qed. + +Lemma Nadd_alt n m : n + m = Nat.iter (N.to_nat n) N.succ m. +Proof. + destruct n. trivial. + induction p using Pos.peano_rect. + - now rewrite N.add_1_l. + - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)). + now rewrite N.add_succ_l, IHp, N2Nat.inj_succ. +Qed. + +Ltac simpl_to_nat := simpl N.to_nat; unfold Pos.to_nat; simpl Pos.iter_op. + +Lemma to_of_lu d : to_lu (of_lu d) = lnorm d. +Proof. + induction d; [reflexivity|..]; + simpl_of_lu; rewrite Nadd_alt; simpl_to_nat; + rewrite ?nat_iter_S, nat_iter_0, ?to_lu_succ, to_of_lu_tenfold by assumption; + unfold lnorm; simpl; destruct nztail; auto. +Qed. + +(** Second bijection result *) + +Lemma to_of (d:uint) : N.to_uint (Pos.of_uint d) = unorm d. +Proof. + rewrite of_uint_alt. + unfold N.to_uint, Pos.to_uint. + destruct (of_lu (rev d)) eqn:H. + - rewrite of_lu_0 in H. rewrite <- rev_lnorm_rev. + unfold lnorm. now rewrite H. + - change (Pos.to_little_uint p) with (to_lu (N.pos p)). + rewrite <- H. rewrite to_of_lu. apply rev_lnorm_rev. +Qed. + +(** Some consequences *) + +Lemma to_uint_nonzero p : Pos.to_uint p <> zero. +Proof. + intro E. generalize (of_to p). now rewrite E. +Qed. + +Lemma to_uint_nonnil p : Pos.to_uint p <> Nil. +Proof. + intros E. generalize (of_to p). now rewrite E. +Qed. + +Lemma to_uint_inj p p' : Pos.to_uint p = Pos.to_uint p' -> p = p'. +Proof. + intro E. + assert (E' : N.pos p = N.pos p'). + { now rewrite <- (of_to p), <- (of_to p'), E. } + now injection E'. +Qed. + +Lemma to_uint_pos_surj d : + unorm d<>zero -> exists p, Pos.to_uint p = unorm d. +Proof. + intros. + destruct (Pos.of_uint d) eqn:E. + - destruct H. generalize (to_of d). now rewrite E. + - exists p. generalize (to_of d). now rewrite E. +Qed. + +Lemma of_uint_norm d : Pos.of_uint (unorm d) = Pos.of_uint d. +Proof. + now induction d. +Qed. + +Lemma of_inj d d' : + Pos.of_uint d = Pos.of_uint d' -> unorm d = unorm d'. +Proof. + intros. rewrite <- !to_of. now f_equal. +Qed. + +Lemma of_iff d d' : Pos.of_uint d = Pos.of_uint d' <-> unorm d = unorm d'. +Proof. + split. apply of_inj. intros E. rewrite <- of_uint_norm, E. + apply of_uint_norm. +Qed. + +End Unsigned. + +(** Conversion from/to signed decimal numbers *) + +Module Signed. + +Lemma of_to (p:positive) : Pos.of_int (Pos.to_int p) = Some p. +Proof. + unfold Pos.to_int, Pos.of_int, norm. + now rewrite Unsigned.of_to. +Qed. + +Lemma to_of (d:int)(p:positive) : + Pos.of_int d = Some p -> Pos.to_int p = norm d. +Proof. + unfold Pos.of_int. + destruct d; [ | intros [=]]. + simpl norm. rewrite <- Unsigned.to_of. + destruct (Pos.of_uint d); now intros [= <-]. +Qed. + +Lemma to_int_inj p p' : Pos.to_int p = Pos.to_int p' -> p = p'. +Proof. + intro E. + assert (E' : Some p = Some p'). + { now rewrite <- (of_to p), <- (of_to p'), E. } + now injection E'. +Qed. + +Lemma to_int_pos_surj d : + unorm d <> zero -> exists p, Pos.to_int p = norm (Pos d). +Proof. + simpl. unfold Pos.to_int. intros H. + destruct (Unsigned.to_uint_pos_surj d H) as (p,Hp). + exists p. now f_equal. +Qed. + +Lemma of_int_norm d : Pos.of_int (norm d) = Pos.of_int d. +Proof. + unfold Pos.of_int. + destruct d. + - simpl. now rewrite Unsigned.of_uint_norm. + - simpl. now destruct (nzhead d) eqn:H. +Qed. + +Lemma of_inj_pos d d' : + Pos.of_int (Pos d) = Pos.of_int (Pos d') -> unorm d = unorm d'. +Proof. + unfold Pos.of_int. + destruct (Pos.of_uint d) eqn:Hd, (Pos.of_uint d') eqn:Hd'; + intros [=]. + - apply Unsigned.of_inj; now rewrite Hd, Hd'. + - apply Unsigned.of_inj; rewrite Hd, Hd'; now f_equal. +Qed. + +End Signed. diff --git a/theories/Numbers/DecimalString.v b/theories/Numbers/DecimalString.v new file mode 100644 index 00000000..1a3220f6 --- /dev/null +++ b/theories/Numbers/DecimalString.v @@ -0,0 +1,265 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* None + | Some d => + match a with + | "0" => Some (D0 d) + | "1" => Some (D1 d) + | "2" => Some (D2 d) + | "3" => Some (D3 d) + | "4" => Some (D4 d) + | "5" => Some (D5 d) + | "6" => Some (D6 d) + | "7" => Some (D7 d) + | "8" => Some (D8 d) + | "9" => Some (D9 d) + | _ => None + end + end%char. + +Lemma uint_of_char_spec c d d' : + uint_of_char c (Some d) = Some d' -> + (c = "0" /\ d' = D0 d \/ + c = "1" /\ d' = D1 d \/ + c = "2" /\ d' = D2 d \/ + c = "3" /\ d' = D3 d \/ + c = "4" /\ d' = D4 d \/ + c = "5" /\ d' = D5 d \/ + c = "6" /\ d' = D6 d \/ + c = "7" /\ d' = D7 d \/ + c = "8" /\ d' = D8 d \/ + c = "9" /\ d' = D9 d)%char. +Proof. + destruct c as [[|] [|] [|] [|] [|] [|] [|] [|]]; + intros [= <-]; intuition. +Qed. + +(** Decimal/String conversion where [Nil] is [""] *) + +Module NilEmpty. + +Fixpoint string_of_uint (d:uint) := + match d with + | Nil => EmptyString + | D0 d => String "0" (string_of_uint d) + | D1 d => String "1" (string_of_uint d) + | D2 d => String "2" (string_of_uint d) + | D3 d => String "3" (string_of_uint d) + | D4 d => String "4" (string_of_uint d) + | D5 d => String "5" (string_of_uint d) + | D6 d => String "6" (string_of_uint d) + | D7 d => String "7" (string_of_uint d) + | D8 d => String "8" (string_of_uint d) + | D9 d => String "9" (string_of_uint d) + end. + +Fixpoint uint_of_string s := + match s with + | EmptyString => Some Nil + | String a s => uint_of_char a (uint_of_string s) + end. + +Definition string_of_int (d:int) := + match d with + | Pos d => string_of_uint d + | Neg d => String "-" (string_of_uint d) + end. + +Definition int_of_string s := + match s with + | EmptyString => Some (Pos Nil) + | String a s' => + if ascii_dec a "-" then option_map Neg (uint_of_string s') + else option_map Pos (uint_of_string s) + end. + +(* NB: For the moment whitespace between - and digits are not accepted. + And in this variant [int_of_string "-" = Some (Neg Nil)]. + +Compute int_of_string "-123456890123456890123456890123456890". +Compute string_of_int (-123456890123456890123456890123456890). +*) + +(** Corresponding proofs *) + +Lemma usu d : + uint_of_string (string_of_uint d) = Some d. +Proof. + induction d; simpl; rewrite ?IHd; simpl; auto. +Qed. + +Lemma sus s d : + uint_of_string s = Some d -> string_of_uint d = s. +Proof. + revert d. + induction s; simpl. + - now intros d [= <-]. + - intros d. + destruct (uint_of_string s); [intros H | intros [=]]. + apply uint_of_char_spec in H. + intuition subst; simpl; f_equal; auto. +Qed. + +Lemma isi d : int_of_string (string_of_int d) = Some d. +Proof. + destruct d; simpl. + - unfold int_of_string. + destruct (string_of_uint d) eqn:Hd. + + now destruct d. + + destruct ascii_dec; subst. + * now destruct d. + * rewrite <- Hd, usu; auto. + - rewrite usu; auto. +Qed. + +Lemma sis s d : + int_of_string s = Some d -> string_of_int d = s. +Proof. + destruct s; [intros [= <-]| ]; simpl; trivial. + destruct ascii_dec; subst; simpl. + - destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. + simpl; f_equal. now apply sus. + - destruct d; [ | now destruct uint_of_char]. + simpl string_of_int. + intros. apply sus; simpl. + destruct uint_of_char; simpl in *; congruence. +Qed. + +End NilEmpty. + +(** Decimal/String conversions where [Nil] is ["0"] *) + +Module NilZero. + +Definition string_of_uint (d:uint) := + match d with + | Nil => "0" + | _ => NilEmpty.string_of_uint d + end. + +Definition uint_of_string s := + match s with + | EmptyString => None + | _ => NilEmpty.uint_of_string s + end. + +Definition string_of_int (d:int) := + match d with + | Pos d => string_of_uint d + | Neg d => String "-" (string_of_uint d) + end. + +Definition int_of_string s := + match s with + | EmptyString => None + | String a s' => + if ascii_dec a "-" then option_map Neg (uint_of_string s') + else option_map Pos (uint_of_string s) + end. + +(** Corresponding proofs *) + +Lemma uint_of_string_nonnil s : uint_of_string s <> Some Nil. +Proof. + destruct s; simpl. + - easy. + - destruct (NilEmpty.uint_of_string s); [intros H | intros [=]]. + apply uint_of_char_spec in H. + now intuition subst. +Qed. + +Lemma sus s d : + uint_of_string s = Some d -> string_of_uint d = s. +Proof. + destruct s; [intros [=] | intros H]. + apply NilEmpty.sus in H. now destruct d. +Qed. + +Lemma usu d : + d<>Nil -> uint_of_string (string_of_uint d) = Some d. +Proof. + destruct d; (now destruct 1) || (intros _; apply NilEmpty.usu). +Qed. + +Lemma usu_nil : + uint_of_string (string_of_uint Nil) = Some Decimal.zero. +Proof. + reflexivity. +Qed. + +Lemma usu_gen d : + uint_of_string (string_of_uint d) = Some d \/ + uint_of_string (string_of_uint d) = Some Decimal.zero. +Proof. + destruct d; (now right) || (left; now apply usu). +Qed. + +Lemma isi d : + d<>Pos Nil -> d<>Neg Nil -> + int_of_string (string_of_int d) = Some d. +Proof. + destruct d; simpl. + - intros H _. + unfold int_of_string. + destruct (string_of_uint d) eqn:Hd. + + now destruct d. + + destruct ascii_dec; subst. + * now destruct d. + * rewrite <- Hd, usu; auto. now intros ->. + - intros _ H. + rewrite usu; auto. now intros ->. +Qed. + +Lemma isi_posnil : + int_of_string (string_of_int (Pos Nil)) = Some (Pos Decimal.zero). +Proof. + reflexivity. +Qed. + +(** Warning! (-0) won't parse (compatibility with the behavior of Z). *) + +Lemma isi_negnil : + int_of_string (string_of_int (Neg Nil)) = Some (Neg (D0 Nil)). +Proof. + reflexivity. +Qed. + +Lemma sis s d : + int_of_string s = Some d -> string_of_int d = s. +Proof. + destruct s; [intros [=]| ]; simpl. + destruct ascii_dec; subst; simpl. + - destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. + simpl; f_equal. now apply sus. + - destruct d; [ | now destruct uint_of_char]. + simpl string_of_int. + intros. apply sus; simpl. + destruct uint_of_char; simpl in *; congruence. +Qed. + +End NilZero. diff --git a/theories/Numbers/DecimalZ.v b/theories/Numbers/DecimalZ.v new file mode 100644 index 00000000..3a083796 --- /dev/null +++ b/theories/Numbers/DecimalZ.v @@ -0,0 +1,75 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* n = n'. +Proof. + intro EQ. + now rewrite <- (of_to n), <- (of_to n'), EQ. +Qed. + +Lemma to_int_surj d : exists n, Z.to_int n = norm d. +Proof. + exists (Z.of_int d). apply to_of. +Qed. + +Lemma of_int_norm d : Z.of_int (norm d) = Z.of_int d. +Proof. + unfold Z.of_int, Z.of_uint. + destruct d. + - simpl. now rewrite DecimalPos.Unsigned.of_uint_norm. + - simpl. destruct (nzhead d) eqn:H; + [ induction d; simpl; auto; discriminate | + destruct (nzhead_nonzero _ _ H) | .. ]; + f_equal; f_equal; apply DecimalPos.Unsigned.of_iff; + unfold unorm; now rewrite H. +Qed. + +Lemma of_inj d d' : + Z.of_int d = Z.of_int d' -> norm d = norm d'. +Proof. + intros. rewrite <- !to_of. now f_equal. +Qed. + +Lemma of_iff d d' : Z.of_int d = Z.of_int d' <-> norm d = norm d'. +Proof. + split. apply of_inj. intros E. rewrite <- of_int_norm, E. + apply of_int_norm. +Qed. diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v index f7fdc179..c4c5174d 100644 --- a/theories/Numbers/Integer/Abstract/ZAdd.v +++ b/theories/Numbers/Integer/Abstract/ZAdd.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* + a mod b / b == 0. +Proof. + intros a b Hb. + rewrite div_small_iff by assumption. + auto using mod_always_pos. +Qed. + (** A last inequality: *) Theorem div_mul_le: diff --git a/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v index 310748dd..a0d1821b 100644 --- a/theories/Numbers/Integer/Abstract/ZDivFloor.v +++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* + a mod b / b == 0. +Proof. + intros a b Hb. + rewrite div_small_iff by assumption. + auto using mod_bound_or. +Qed. + (** A last inequality: *) Theorem div_mul_le: diff --git a/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v index 04301077..31e42738 100644 --- a/theories/Numbers/Integer/Abstract/ZDivTrunc.v +++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* + a rem b ÷ b == 0. +Proof. + intros a b Hb. + rewrite quot_small_iff by assumption. + auto using rem_bound_abs. +Qed. + (** A last inequality: *) Theorem quot_mul_le: diff --git a/theories/Numbers/Integer/Abstract/ZGcd.v b/theories/Numbers/Integer/Abstract/ZGcd.v index 30adaeb4..f0b7bf9d 100644 --- a/theories/Numbers/Integer/Abstract/ZGcd.v +++ b/theories/Numbers/Integer/Abstract/ZGcd.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* y" := (y < x) (only parsing) : bigZ_scope. -Notation "x >= y" := (y <= x) (only parsing) : bigZ_scope. -Notation "x < y < z" := (x - BigN.to_Z (BigZ.to_N n) = [n]. -Proof. -intros n; case n; simpl; intros p; - generalize (BigN.spec_pos p); case (BigN.to_Z p); auto. -intros p1 _ H1; case H1; auto. -intros p1 H1; case H1; auto. -Qed. - -(** [BigZ] is a ring *) - -Lemma BigZring : - ring_theory 0 1 BigZ.add BigZ.mul BigZ.sub BigZ.opp BigZ.eq. -Proof. -constructor. -exact BigZ.add_0_l. exact BigZ.add_comm. exact BigZ.add_assoc. -exact BigZ.mul_1_l. exact BigZ.mul_comm. exact BigZ.mul_assoc. -exact BigZ.mul_add_distr_r. -symmetry. apply BigZ.add_opp_r. -exact BigZ.add_opp_diag_r. -Qed. - -Lemma BigZeqb_correct : forall x y, (x =? y) = true -> x==y. -Proof. now apply BigZ.eqb_eq. Qed. - -Definition BigZ_of_N n := BigZ.of_Z (Z.of_N n). - -Lemma BigZpower : power_theory 1 BigZ.mul BigZ.eq BigZ_of_N BigZ.pow. -Proof. -constructor. -intros. unfold BigZ.eq, BigZ_of_N. rewrite BigZ.spec_pow, BigZ.spec_of_Z. -rewrite Zpower_theory.(rpow_pow_N). -destruct n; simpl. reflexivity. -induction p; simpl; intros; BigZ.zify; rewrite ?IHp; auto. -Qed. - -Lemma BigZdiv : div_theory BigZ.eq BigZ.add BigZ.mul (@id _) - (fun a b => if b =? 0 then (0,a) else BigZ.div_eucl a b). -Proof. -constructor. unfold id. intros a b. -BigZ.zify. -case Z.eqb_spec. -BigZ.zify. auto with zarith. -intros NEQ. -generalize (BigZ.spec_div_eucl a b). -generalize (Z_div_mod_full [a] [b] NEQ). -destruct BigZ.div_eucl as (q,r), Z.div_eucl as (q',r'). -intros (EQ,_). injection 1 as EQr EQq. -BigZ.zify. rewrite EQr, EQq; auto. -Qed. - -(** Detection of constants *) - -Ltac isBigZcst t := - match t with - | BigZ.Pos ?t => isBigNcst t - | BigZ.Neg ?t => isBigNcst t - | BigZ.zero => constr:(true) - | BigZ.one => constr:(true) - | BigZ.two => constr:(true) - | BigZ.minus_one => constr:(true) - | _ => constr:(false) - end. - -Ltac BigZcst t := - match isBigZcst t with - | true => constr:(t) - | false => constr:(NotConstant) - end. - -Ltac BigZ_to_N t := - match t with - | BigZ.Pos ?t => BigN_to_N t - | BigZ.zero => constr:(0%N) - | BigZ.one => constr:(1%N) - | BigZ.two => constr:(2%N) - | _ => constr:(NotConstant) - end. - -(** Registration for the "ring" tactic *) - -Add Ring BigZr : BigZring - (decidable BigZeqb_correct, - constants [BigZcst], - power_tac BigZpower [BigZ_to_N], - div BigZdiv). - -Section TestRing. -Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + (y + 1*x)*x. -Proof. -intros. ring_simplify. reflexivity. -Qed. -Let test' : forall x y, 1 + x*y + x^2 - 1*1 - y*x + 1*(-x)*x == 0. -Proof. -intros. ring_simplify. reflexivity. -Qed. -End TestRing. - -(** [BigZ] also benefits from an "order" tactic *) - -Ltac bigZ_order := BigZ.order. - -Section TestOrder. -Let test : forall x y : bigZ, x<=y -> y<=x -> x==y. -Proof. bigZ_order. Qed. -End TestOrder. - -(** We can use at least a bit of (r)omega by translating to [Z]. *) - -Section TestOmega. -Let test : forall x y : bigZ, x<=y -> y<=x -> x==y. -Proof. intros x y. BigZ.zify. omega. Qed. -End TestOmega. - -(** Todo: micromega *) diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v deleted file mode 100644 index fec6e068..00000000 --- a/theories/Numbers/Integer/BigZ/ZMake.v +++ /dev/null @@ -1,759 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t_ - | Neg : NN.t -> t_. - - Definition t := t_. - - Definition zero := Pos NN.zero. - Definition one := Pos NN.one. - Definition two := Pos NN.two. - Definition minus_one := Neg NN.one. - - Definition of_Z x := - match x with - | Zpos x => Pos (NN.of_N (Npos x)) - | Z0 => zero - | Zneg x => Neg (NN.of_N (Npos x)) - end. - - Definition to_Z x := - match x with - | Pos nx => NN.to_Z nx - | Neg nx => Z.opp (NN.to_Z nx) - end. - - Theorem spec_of_Z: forall x, to_Z (of_Z x) = x. - Proof. - intros x; case x; unfold to_Z, of_Z, zero. - exact NN.spec_0. - intros; rewrite NN.spec_of_N; auto. - intros; rewrite NN.spec_of_N; auto. - Qed. - - Definition eq x y := (to_Z x = to_Z y). - - Theorem spec_0: to_Z zero = 0. - exact NN.spec_0. - Qed. - - Theorem spec_1: to_Z one = 1. - exact NN.spec_1. - Qed. - - Theorem spec_2: to_Z two = 2. - exact NN.spec_2. - Qed. - - Theorem spec_m1: to_Z minus_one = -1. - simpl; rewrite NN.spec_1; auto. - Qed. - - Definition compare x y := - match x, y with - | Pos nx, Pos ny => NN.compare nx ny - | Pos nx, Neg ny => - match NN.compare nx NN.zero with - | Gt => Gt - | _ => NN.compare ny NN.zero - end - | Neg nx, Pos ny => - match NN.compare NN.zero nx with - | Lt => Lt - | _ => NN.compare NN.zero ny - end - | Neg nx, Neg ny => NN.compare ny nx - end. - - Theorem spec_compare : - forall x y, compare x y = Z.compare (to_Z x) (to_Z y). - Proof. - unfold compare, to_Z. - destruct x as [x|x], y as [y|y]; - rewrite ?NN.spec_compare, ?NN.spec_0, ?Z.compare_opp; auto; - assert (Hx:=NN.spec_pos x); assert (Hy:=NN.spec_pos y); - set (X:=NN.to_Z x) in *; set (Y:=NN.to_Z y) in *; clearbody X Y. - - destruct (Z.compare_spec X 0) as [EQ|LT|GT]. - + rewrite <- Z.opp_0 in EQ. now rewrite EQ, Z.compare_opp. - + exfalso. omega. - + symmetry. change (X > -Y). omega. - - destruct (Z.compare_spec 0 X) as [EQ|LT|GT]. - + rewrite <- EQ, Z.opp_0; auto. - + symmetry. change (-X < Y). omega. - + exfalso. omega. - Qed. - - Definition eqb x y := - match compare x y with - | Eq => true - | _ => false - end. - - Theorem spec_eqb x y : eqb x y = Z.eqb (to_Z x) (to_Z y). - Proof. - apply Bool.eq_iff_eq_true. - unfold eqb. rewrite Z.eqb_eq, <- Z.compare_eq_iff, spec_compare. - split; [now destruct Z.compare | now intros ->]. - Qed. - - Definition lt n m := to_Z n < to_Z m. - Definition le n m := to_Z n <= to_Z m. - - - Definition ltb (x y : t) : bool := - match compare x y with - | Lt => true - | _ => false - end. - - Theorem spec_ltb x y : ltb x y = Z.ltb (to_Z x) (to_Z y). - Proof. - apply Bool.eq_iff_eq_true. - rewrite Z.ltb_lt. unfold Z.lt, ltb. rewrite spec_compare. - split; [now destruct Z.compare | now intros ->]. - Qed. - - Definition leb (x y : t) : bool := - match compare x y with - | Gt => false - | _ => true - end. - - Theorem spec_leb x y : leb x y = Z.leb (to_Z x) (to_Z y). - Proof. - apply Bool.eq_iff_eq_true. - rewrite Z.leb_le. unfold Z.le, leb. rewrite spec_compare. - now destruct Z.compare; split. - Qed. - - Definition min n m := match compare n m with Gt => m | _ => n end. - Definition max n m := match compare n m with Lt => m | _ => n end. - - Theorem spec_min : forall n m, to_Z (min n m) = Z.min (to_Z n) (to_Z m). - Proof. - unfold min, Z.min. intros. rewrite spec_compare. destruct Z.compare; auto. - Qed. - - Theorem spec_max : forall n m, to_Z (max n m) = Z.max (to_Z n) (to_Z m). - Proof. - unfold max, Z.max. intros. rewrite spec_compare. destruct Z.compare; auto. - Qed. - - Definition to_N x := - match x with - | Pos nx => nx - | Neg nx => nx - end. - - Definition abs x := Pos (to_N x). - - Theorem spec_abs: forall x, to_Z (abs x) = Z.abs (to_Z x). - Proof. - intros x; case x; clear x; intros x; assert (F:=NN.spec_pos x). - simpl; rewrite Z.abs_eq; auto. - simpl; rewrite Z.abs_neq; simpl; auto with zarith. - Qed. - - Definition opp x := - match x with - | Pos nx => Neg nx - | Neg nx => Pos nx - end. - - Theorem spec_opp: forall x, to_Z (opp x) = - to_Z x. - Proof. - intros x; case x; simpl; auto with zarith. - Qed. - - Definition succ x := - match x with - | Pos n => Pos (NN.succ n) - | Neg n => - match NN.compare NN.zero n with - | Lt => Neg (NN.pred n) - | _ => one - end - end. - - Theorem spec_succ: forall n, to_Z (succ n) = to_Z n + 1. - Proof. - intros x; case x; clear x; intros x. - exact (NN.spec_succ x). - simpl. rewrite NN.spec_compare. case Z.compare_spec; rewrite ?NN.spec_0; simpl. - intros HH; rewrite <- HH; rewrite NN.spec_1; ring. - intros HH; rewrite NN.spec_pred, Z.max_r; auto with zarith. - generalize (NN.spec_pos x); auto with zarith. - Qed. - - Definition add x y := - match x, y with - | Pos nx, Pos ny => Pos (NN.add nx ny) - | Pos nx, Neg ny => - match NN.compare nx ny with - | Gt => Pos (NN.sub nx ny) - | Eq => zero - | Lt => Neg (NN.sub ny nx) - end - | Neg nx, Pos ny => - match NN.compare nx ny with - | Gt => Neg (NN.sub nx ny) - | Eq => zero - | Lt => Pos (NN.sub ny nx) - end - | Neg nx, Neg ny => Neg (NN.add nx ny) - end. - - Theorem spec_add: forall x y, to_Z (add x y) = to_Z x + to_Z y. - Proof. - unfold add, to_Z; intros [x | x] [y | y]; - try (rewrite NN.spec_add; auto with zarith); - rewrite NN.spec_compare; case Z.compare_spec; - unfold zero; rewrite ?NN.spec_0, ?NN.spec_sub; omega with *. - Qed. - - Definition pred x := - match x with - | Pos nx => - match NN.compare NN.zero nx with - | Lt => Pos (NN.pred nx) - | _ => minus_one - end - | Neg nx => Neg (NN.succ nx) - end. - - Theorem spec_pred: forall x, to_Z (pred x) = to_Z x - 1. - Proof. - unfold pred, to_Z, minus_one; intros [x | x]; - try (rewrite NN.spec_succ; ring). - rewrite NN.spec_compare; case Z.compare_spec; - rewrite ?NN.spec_0, ?NN.spec_1, ?NN.spec_pred; - generalize (NN.spec_pos x); omega with *. - Qed. - - Definition sub x y := - match x, y with - | Pos nx, Pos ny => - match NN.compare nx ny with - | Gt => Pos (NN.sub nx ny) - | Eq => zero - | Lt => Neg (NN.sub ny nx) - end - | Pos nx, Neg ny => Pos (NN.add nx ny) - | Neg nx, Pos ny => Neg (NN.add nx ny) - | Neg nx, Neg ny => - match NN.compare nx ny with - | Gt => Neg (NN.sub nx ny) - | Eq => zero - | Lt => Pos (NN.sub ny nx) - end - end. - - Theorem spec_sub: forall x y, to_Z (sub x y) = to_Z x - to_Z y. - Proof. - unfold sub, to_Z; intros [x | x] [y | y]; - try (rewrite NN.spec_add; auto with zarith); - rewrite NN.spec_compare; case Z.compare_spec; - unfold zero; rewrite ?NN.spec_0, ?NN.spec_sub; omega with *. - Qed. - - Definition mul x y := - match x, y with - | Pos nx, Pos ny => Pos (NN.mul nx ny) - | Pos nx, Neg ny => Neg (NN.mul nx ny) - | Neg nx, Pos ny => Neg (NN.mul nx ny) - | Neg nx, Neg ny => Pos (NN.mul nx ny) - end. - - Theorem spec_mul: forall x y, to_Z (mul x y) = to_Z x * to_Z y. - Proof. - unfold mul, to_Z; intros [x | x] [y | y]; rewrite NN.spec_mul; ring. - Qed. - - Definition square x := - match x with - | Pos nx => Pos (NN.square nx) - | Neg nx => Pos (NN.square nx) - end. - - Theorem spec_square: forall x, to_Z (square x) = to_Z x * to_Z x. - Proof. - unfold square, to_Z; intros [x | x]; rewrite NN.spec_square; ring. - Qed. - - Definition pow_pos x p := - match x with - | Pos nx => Pos (NN.pow_pos nx p) - | Neg nx => - match p with - | xH => x - | xO _ => Pos (NN.pow_pos nx p) - | xI _ => Neg (NN.pow_pos nx p) - end - end. - - Theorem spec_pow_pos: forall x n, to_Z (pow_pos x n) = to_Z x ^ Zpos n. - Proof. - assert (F0: forall x, (-x)^2 = x^2). - intros x; rewrite Z.pow_2_r; ring. - unfold pow_pos, to_Z; intros [x | x] [p | p |]; - try rewrite NN.spec_pow_pos; try ring. - assert (F: 0 <= 2 * Zpos p). - assert (0 <= Zpos p); auto with zarith. - rewrite Pos2Z.inj_xI; repeat rewrite Zpower_exp; auto with zarith. - repeat rewrite Z.pow_mul_r; auto with zarith. - rewrite F0; ring. - assert (F: 0 <= 2 * Zpos p). - assert (0 <= Zpos p); auto with zarith. - rewrite Pos2Z.inj_xO; repeat rewrite Zpower_exp; auto with zarith. - repeat rewrite Z.pow_mul_r; auto with zarith. - rewrite F0; ring. - Qed. - - Definition pow_N x n := - match n with - | N0 => one - | Npos p => pow_pos x p - end. - - Theorem spec_pow_N: forall x n, to_Z (pow_N x n) = to_Z x ^ Z.of_N n. - Proof. - destruct n; simpl. apply NN.spec_1. - apply spec_pow_pos. - Qed. - - Definition pow x y := - match to_Z y with - | Z0 => one - | Zpos p => pow_pos x p - | Zneg p => zero - end. - - Theorem spec_pow: forall x y, to_Z (pow x y) = to_Z x ^ to_Z y. - Proof. - intros. unfold pow. destruct (to_Z y); simpl. - apply NN.spec_1. - apply spec_pow_pos. - apply NN.spec_0. - Qed. - - Definition log2 x := - match x with - | Pos nx => Pos (NN.log2 nx) - | Neg nx => zero - end. - - Theorem spec_log2: forall x, to_Z (log2 x) = Z.log2 (to_Z x). - Proof. - intros. destruct x as [p|p]; simpl. apply NN.spec_log2. - rewrite NN.spec_0. - destruct (Z_le_lt_eq_dec _ _ (NN.spec_pos p)) as [LT|EQ]. - rewrite Z.log2_nonpos; auto with zarith. - now rewrite <- EQ. - Qed. - - Definition sqrt x := - match x with - | Pos nx => Pos (NN.sqrt nx) - | Neg nx => Neg NN.zero - end. - - Theorem spec_sqrt: forall x, to_Z (sqrt x) = Z.sqrt (to_Z x). - Proof. - destruct x as [p|p]; simpl. - apply NN.spec_sqrt. - rewrite NN.spec_0. - destruct (Z_le_lt_eq_dec _ _ (NN.spec_pos p)) as [LT|EQ]. - rewrite Z.sqrt_neg; auto with zarith. - now rewrite <- EQ. - Qed. - - Definition div_eucl x y := - match x, y with - | Pos nx, Pos ny => - let (q, r) := NN.div_eucl nx ny in - (Pos q, Pos r) - | Pos nx, Neg ny => - let (q, r) := NN.div_eucl nx ny in - if NN.eqb NN.zero r - then (Neg q, zero) - else (Neg (NN.succ q), Neg (NN.sub ny r)) - | Neg nx, Pos ny => - let (q, r) := NN.div_eucl nx ny in - if NN.eqb NN.zero r - then (Neg q, zero) - else (Neg (NN.succ q), Pos (NN.sub ny r)) - | Neg nx, Neg ny => - let (q, r) := NN.div_eucl nx ny in - (Pos q, Neg r) - end. - - Ltac break_nonneg x px EQx := - let H := fresh "H" in - assert (H:=NN.spec_pos x); - destruct (NN.to_Z x) as [|px|px] eqn:EQx; - [clear H|clear H|elim H; reflexivity]. - - Theorem spec_div_eucl: forall x y, - let (q,r) := div_eucl x y in - (to_Z q, to_Z r) = Z.div_eucl (to_Z x) (to_Z y). - Proof. - unfold div_eucl, to_Z. intros [x | x] [y | y]. - (* Pos Pos *) - generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y); auto. - (* Pos Neg *) - generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r). - break_nonneg x px EQx; break_nonneg y py EQy; - try (injection 1 as Hq Hr; rewrite NN.spec_eqb, NN.spec_0, Hr; - simpl; rewrite Hq, NN.spec_0; auto). - change (- Zpos py) with (Zneg py). - assert (GT : Zpos py > 0) by (compute; auto). - generalize (Z_div_mod (Zpos px) (Zpos py) GT). - unfold Z.div_eucl. destruct (Z.pos_div_eucl px (Zpos py)) as (q',r'). - intros (EQ,MOD). injection 1 as Hq' Hr'. - rewrite NN.spec_eqb, NN.spec_0, Hr'. - break_nonneg r pr EQr. - subst; simpl. rewrite NN.spec_0; auto. - subst. lazy iota beta delta [Z.eqb]. - rewrite NN.spec_sub, NN.spec_succ, EQy, EQr. f_equal. omega with *. - (* Neg Pos *) - generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r). - break_nonneg x px EQx; break_nonneg y py EQy; - try (injection 1 as Hq Hr; rewrite NN.spec_eqb, NN.spec_0, Hr; - simpl; rewrite Hq, NN.spec_0; auto). - change (- Zpos px) with (Zneg px). - assert (GT : Zpos py > 0) by (compute; auto). - generalize (Z_div_mod (Zpos px) (Zpos py) GT). - unfold Z.div_eucl. destruct (Z.pos_div_eucl px (Zpos py)) as (q',r'). - intros (EQ,MOD). injection 1 as Hq' Hr'. - rewrite NN.spec_eqb, NN.spec_0, Hr'. - break_nonneg r pr EQr. - subst; simpl. rewrite NN.spec_0; auto. - subst. lazy iota beta delta [Z.eqb]. - rewrite NN.spec_sub, NN.spec_succ, EQy, EQr. f_equal. omega with *. - (* Neg Neg *) - generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r). - break_nonneg x px EQx; break_nonneg y py EQy; - try (injection 1 as -> ->; auto). - simpl. intros <-; auto. - Qed. - - Definition div x y := fst (div_eucl x y). - - Definition spec_div: forall x y, - to_Z (div x y) = to_Z x / to_Z y. - Proof. - intros x y; generalize (spec_div_eucl x y); unfold div, Z.div. - case div_eucl; case Z.div_eucl; simpl; auto. - intros q r q11 r1 H; injection H; auto. - Qed. - - Definition modulo x y := snd (div_eucl x y). - - Theorem spec_modulo: - forall x y, to_Z (modulo x y) = to_Z x mod to_Z y. - Proof. - intros x y; generalize (spec_div_eucl x y); unfold modulo, Z.modulo. - case div_eucl; case Z.div_eucl; simpl; auto. - intros q r q11 r1 H; injection H; auto. - Qed. - - Definition quot x y := - match x, y with - | Pos nx, Pos ny => Pos (NN.div nx ny) - | Pos nx, Neg ny => Neg (NN.div nx ny) - | Neg nx, Pos ny => Neg (NN.div nx ny) - | Neg nx, Neg ny => Pos (NN.div nx ny) - end. - - Definition rem x y := - if eqb y zero then x - else - match x, y with - | Pos nx, Pos ny => Pos (NN.modulo nx ny) - | Pos nx, Neg ny => Pos (NN.modulo nx ny) - | Neg nx, Pos ny => Neg (NN.modulo nx ny) - | Neg nx, Neg ny => Neg (NN.modulo nx ny) - end. - - Lemma spec_quot : forall x y, to_Z (quot x y) = (to_Z x) ÷ (to_Z y). - Proof. - intros [x|x] [y|y]; simpl; symmetry; rewrite NN.spec_div; - (* Nota: we rely here on [forall a b, a ÷ 0 = b / 0] *) - destruct (Z.eq_dec (NN.to_Z y) 0) as [EQ|NEQ]; - try (rewrite EQ; now destruct (NN.to_Z x)); - rewrite ?Z.quot_opp_r, ?Z.quot_opp_l, ?Z.opp_involutive, ?Z.opp_inj_wd; - trivial; apply Z.quot_div_nonneg; - generalize (NN.spec_pos x) (NN.spec_pos y); Z.order. - Qed. - - Lemma spec_rem : forall x y, - to_Z (rem x y) = Z.rem (to_Z x) (to_Z y). - Proof. - intros x y. unfold rem. rewrite spec_eqb, spec_0. - case Z.eqb_spec; intros Hy. - (* Nota: we rely here on [Z.rem a 0 = a] *) - rewrite Hy. now destruct (to_Z x). - destruct x as [x|x], y as [y|y]; simpl in *; symmetry; - rewrite ?Z.eq_opp_l, ?Z.opp_0 in Hy; - rewrite NN.spec_modulo, ?Z.rem_opp_r, ?Z.rem_opp_l, ?Z.opp_involutive, - ?Z.opp_inj_wd; - trivial; apply Z.rem_mod_nonneg; - generalize (NN.spec_pos x) (NN.spec_pos y); Z.order. - Qed. - - Definition gcd x y := - match x, y with - | Pos nx, Pos ny => Pos (NN.gcd nx ny) - | Pos nx, Neg ny => Pos (NN.gcd nx ny) - | Neg nx, Pos ny => Pos (NN.gcd nx ny) - | Neg nx, Neg ny => Pos (NN.gcd nx ny) - end. - - Theorem spec_gcd: forall a b, to_Z (gcd a b) = Z.gcd (to_Z a) (to_Z b). - Proof. - unfold gcd, Z.gcd, to_Z; intros [x | x] [y | y]; rewrite NN.spec_gcd; unfold Z.gcd; - auto; case NN.to_Z; simpl; auto with zarith; - try rewrite Z.abs_opp; auto; - case NN.to_Z; simpl; auto with zarith. - Qed. - - Definition sgn x := - match compare zero x with - | Lt => one - | Eq => zero - | Gt => minus_one - end. - - Lemma spec_sgn : forall x, to_Z (sgn x) = Z.sgn (to_Z x). - Proof. - intros. unfold sgn. rewrite spec_compare. case Z.compare_spec. - rewrite spec_0. intros <-; auto. - rewrite spec_0, spec_1. symmetry. rewrite Z.sgn_pos_iff; auto. - rewrite spec_0, spec_m1. symmetry. rewrite Z.sgn_neg_iff; auto with zarith. - Qed. - - Definition even z := - match z with - | Pos n => NN.even n - | Neg n => NN.even n - end. - - Definition odd z := - match z with - | Pos n => NN.odd n - | Neg n => NN.odd n - end. - - Lemma spec_even : forall z, even z = Z.even (to_Z z). - Proof. - intros [n|n]; simpl; rewrite NN.spec_even; trivial. - destruct (NN.to_Z n) as [|p|p]; now try destruct p. - Qed. - - Lemma spec_odd : forall z, odd z = Z.odd (to_Z z). - Proof. - intros [n|n]; simpl; rewrite NN.spec_odd; trivial. - destruct (NN.to_Z n) as [|p|p]; now try destruct p. - Qed. - - Definition norm_pos z := - match z with - | Pos _ => z - | Neg n => if NN.eqb n NN.zero then Pos n else z - end. - - Definition testbit a n := - match norm_pos n, norm_pos a with - | Pos p, Pos a => NN.testbit a p - | Pos p, Neg a => negb (NN.testbit (NN.pred a) p) - | Neg p, _ => false - end. - - Definition shiftl a n := - match norm_pos a, n with - | Pos a, Pos n => Pos (NN.shiftl a n) - | Pos a, Neg n => Pos (NN.shiftr a n) - | Neg a, Pos n => Neg (NN.shiftl a n) - | Neg a, Neg n => Neg (NN.succ (NN.shiftr (NN.pred a) n)) - end. - - Definition shiftr a n := shiftl a (opp n). - - Definition lor a b := - match norm_pos a, norm_pos b with - | Pos a, Pos b => Pos (NN.lor a b) - | Neg a, Pos b => Neg (NN.succ (NN.ldiff (NN.pred a) b)) - | Pos a, Neg b => Neg (NN.succ (NN.ldiff (NN.pred b) a)) - | Neg a, Neg b => Neg (NN.succ (NN.land (NN.pred a) (NN.pred b))) - end. - - Definition land a b := - match norm_pos a, norm_pos b with - | Pos a, Pos b => Pos (NN.land a b) - | Neg a, Pos b => Pos (NN.ldiff b (NN.pred a)) - | Pos a, Neg b => Pos (NN.ldiff a (NN.pred b)) - | Neg a, Neg b => Neg (NN.succ (NN.lor (NN.pred a) (NN.pred b))) - end. - - Definition ldiff a b := - match norm_pos a, norm_pos b with - | Pos a, Pos b => Pos (NN.ldiff a b) - | Neg a, Pos b => Neg (NN.succ (NN.lor (NN.pred a) b)) - | Pos a, Neg b => Pos (NN.land a (NN.pred b)) - | Neg a, Neg b => Pos (NN.ldiff (NN.pred b) (NN.pred a)) - end. - - Definition lxor a b := - match norm_pos a, norm_pos b with - | Pos a, Pos b => Pos (NN.lxor a b) - | Neg a, Pos b => Neg (NN.succ (NN.lxor (NN.pred a) b)) - | Pos a, Neg b => Neg (NN.succ (NN.lxor a (NN.pred b))) - | Neg a, Neg b => Pos (NN.lxor (NN.pred a) (NN.pred b)) - end. - - Definition div2 x := shiftr x one. - - Lemma Zlnot_alt1 : forall x, -(x+1) = Z.lnot x. - Proof. - unfold Z.lnot, Z.pred; auto with zarith. - Qed. - - Lemma Zlnot_alt2 : forall x, Z.lnot (x-1) = -x. - Proof. - unfold Z.lnot, Z.pred; auto with zarith. - Qed. - - Lemma Zlnot_alt3 : forall x, Z.lnot (-x) = x-1. - Proof. - unfold Z.lnot, Z.pred; auto with zarith. - Qed. - - Lemma spec_norm_pos : forall x, to_Z (norm_pos x) = to_Z x. - Proof. - intros [x|x]; simpl; trivial. - rewrite NN.spec_eqb, NN.spec_0. - case Z.eqb_spec; simpl; auto with zarith. - Qed. - - Lemma spec_norm_pos_pos : forall x y, norm_pos x = Neg y -> - 0 < NN.to_Z y. - Proof. - intros [x|x] y; simpl; try easy. - rewrite NN.spec_eqb, NN.spec_0. - case Z.eqb_spec; simpl; try easy. - inversion 2. subst. generalize (NN.spec_pos y); auto with zarith. - Qed. - - Ltac destr_norm_pos x := - rewrite <- (spec_norm_pos x); - let H := fresh in - let x' := fresh x in - assert (H := spec_norm_pos_pos x); - destruct (norm_pos x) as [x'|x']; - specialize (H x' (eq_refl _)) || clear H. - - Lemma spec_testbit: forall x p, testbit x p = Z.testbit (to_Z x) (to_Z p). - Proof. - intros x p. unfold testbit. - destr_norm_pos p; simpl. destr_norm_pos x; simpl. - apply NN.spec_testbit. - rewrite NN.spec_testbit, NN.spec_pred, Z.max_r by auto with zarith. - symmetry. apply Z.bits_opp. apply NN.spec_pos. - symmetry. apply Z.testbit_neg_r; auto with zarith. - Qed. - - Lemma spec_shiftl: forall x p, to_Z (shiftl x p) = Z.shiftl (to_Z x) (to_Z p). - Proof. - intros x p. unfold shiftl. - destr_norm_pos x; destruct p as [p|p]; simpl; - assert (Hp := NN.spec_pos p). - apply NN.spec_shiftl. - rewrite Z.shiftl_opp_r. apply NN.spec_shiftr. - rewrite !NN.spec_shiftl. - rewrite !Z.shiftl_mul_pow2 by apply NN.spec_pos. - symmetry. apply Z.mul_opp_l. - rewrite Z.shiftl_opp_r, NN.spec_succ, NN.spec_shiftr, NN.spec_pred, Z.max_r - by auto with zarith. - now rewrite Zlnot_alt1, Z.lnot_shiftr, Zlnot_alt2. - Qed. - - Lemma spec_shiftr: forall x p, to_Z (shiftr x p) = Z.shiftr (to_Z x) (to_Z p). - Proof. - intros. unfold shiftr. rewrite spec_shiftl, spec_opp. - apply Z.shiftl_opp_r. - Qed. - - Lemma spec_land: forall x y, to_Z (land x y) = Z.land (to_Z x) (to_Z y). - Proof. - intros x y. unfold land. - destr_norm_pos x; destr_norm_pos y; simpl; - rewrite ?NN.spec_succ, ?NN.spec_land, ?NN.spec_ldiff, ?NN.spec_lor, - ?NN.spec_pred, ?Z.max_r, ?Zlnot_alt1; auto with zarith. - now rewrite Z.ldiff_land, Zlnot_alt2. - now rewrite Z.ldiff_land, Z.land_comm, Zlnot_alt2. - now rewrite Z.lnot_lor, !Zlnot_alt2. - Qed. - - Lemma spec_lor: forall x y, to_Z (lor x y) = Z.lor (to_Z x) (to_Z y). - Proof. - intros x y. unfold lor. - destr_norm_pos x; destr_norm_pos y; simpl; - rewrite ?NN.spec_succ, ?NN.spec_land, ?NN.spec_ldiff, ?NN.spec_lor, - ?NN.spec_pred, ?Z.max_r, ?Zlnot_alt1; auto with zarith. - now rewrite Z.lnot_ldiff, Z.lor_comm, Zlnot_alt2. - now rewrite Z.lnot_ldiff, Zlnot_alt2. - now rewrite Z.lnot_land, !Zlnot_alt2. - Qed. - - Lemma spec_ldiff: forall x y, to_Z (ldiff x y) = Z.ldiff (to_Z x) (to_Z y). - Proof. - intros x y. unfold ldiff. - destr_norm_pos x; destr_norm_pos y; simpl; - rewrite ?NN.spec_succ, ?NN.spec_land, ?NN.spec_ldiff, ?NN.spec_lor, - ?NN.spec_pred, ?Z.max_r, ?Zlnot_alt1; auto with zarith. - now rewrite Z.ldiff_land, Zlnot_alt3. - now rewrite Z.lnot_lor, Z.ldiff_land, <- Zlnot_alt2. - now rewrite 2 Z.ldiff_land, Zlnot_alt2, Z.land_comm, Zlnot_alt3. - Qed. - - Lemma spec_lxor: forall x y, to_Z (lxor x y) = Z.lxor (to_Z x) (to_Z y). - Proof. - intros x y. unfold lxor. - destr_norm_pos x; destr_norm_pos y; simpl; - rewrite ?NN.spec_succ, ?NN.spec_lxor, ?NN.spec_pred, ?Z.max_r, ?Zlnot_alt1; - auto with zarith. - now rewrite !Z.lnot_lxor_r, Zlnot_alt2. - now rewrite !Z.lnot_lxor_l, Zlnot_alt2. - now rewrite <- Z.lxor_lnot_lnot, !Zlnot_alt2. - Qed. - - Lemma spec_div2: forall x, to_Z (div2 x) = Z.div2 (to_Z x). - Proof. - intros x. unfold div2. now rewrite spec_shiftr, Z.div2_spec, spec_1. - Qed. - -End Make. diff --git a/theories/Numbers/Integer/Binary/ZBinary.v b/theories/Numbers/Integer/Binary/ZBinary.v index eae8204d..bed827fd 100644 --- a/theories/Numbers/Integer/Binary/ZBinary.v +++ b/theories/Numbers/Integer/Binary/ZBinary.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Z. - Local Notation "[ x ]" := (to_Z x). - - Definition eq x y := [x] = [y]. - Definition lt x y := [x] < [y]. - Definition le x y := [x] <= [y]. - - Parameter of_Z : Z -> t. - Parameter spec_of_Z: forall x, to_Z (of_Z x) = x. - - Parameter compare : t -> t -> comparison. - Parameter eqb : t -> t -> bool. - Parameter ltb : t -> t -> bool. - Parameter leb : t -> t -> bool. - Parameter min : t -> t -> t. - Parameter max : t -> t -> t. - Parameter zero : t. - Parameter one : t. - Parameter two : t. - Parameter minus_one : t. - Parameter succ : t -> t. - Parameter add : t -> t -> t. - Parameter pred : t -> t. - Parameter sub : t -> t -> t. - Parameter opp : t -> t. - Parameter mul : t -> t -> t. - Parameter square : t -> t. - Parameter pow_pos : t -> positive -> t. - Parameter pow_N : t -> N -> t. - Parameter pow : t -> t -> t. - Parameter sqrt : t -> t. - Parameter log2 : t -> t. - Parameter div_eucl : t -> t -> t * t. - Parameter div : t -> t -> t. - Parameter modulo : t -> t -> t. - Parameter quot : t -> t -> t. - Parameter rem : t -> t -> t. - Parameter gcd : t -> t -> t. - Parameter sgn : t -> t. - Parameter abs : t -> t. - Parameter even : t -> bool. - Parameter odd : t -> bool. - Parameter testbit : t -> t -> bool. - Parameter shiftr : t -> t -> t. - Parameter shiftl : t -> t -> t. - Parameter land : t -> t -> t. - Parameter lor : t -> t -> t. - Parameter ldiff : t -> t -> t. - Parameter lxor : t -> t -> t. - Parameter div2 : t -> t. - - Parameter spec_compare: forall x y, compare x y = ([x] ?= [y]). - Parameter spec_eqb : forall x y, eqb x y = ([x] =? [y]). - Parameter spec_ltb : forall x y, ltb x y = ([x] eq) succ. -Program Instance pred_wd : Proper (eq ==> eq) pred. -Program Instance add_wd : Proper (eq ==> eq ==> eq) add. -Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub. -Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul. - -Theorem pred_succ : forall n, pred (succ n) == n. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem one_succ : 1 == succ 0. -Proof. -now zify. -Qed. - -Theorem two_succ : 2 == succ 1. -Proof. -now zify. -Qed. - -Section Induction. - -Variable A : ZZ.t -> Prop. -Hypothesis A_wd : Proper (eq==>iff) A. -Hypothesis A0 : A 0. -Hypothesis AS : forall n, A n <-> A (succ n). - -Let B (z : Z) := A (of_Z z). - -Lemma B0 : B 0. -Proof. -unfold B; simpl. -rewrite <- (A_wd 0); auto. -zify. auto. -Qed. - -Lemma BS : forall z : Z, B z -> B (z + 1). -Proof. -intros z H. -unfold B in *. apply -> AS in H. -setoid_replace (of_Z (z + 1)) with (succ (of_Z z)); auto. -zify. auto. -Qed. - -Lemma BP : forall z : Z, B z -> B (z - 1). -Proof. -intros z H. -unfold B in *. rewrite AS. -setoid_replace (succ (of_Z (z - 1))) with (of_Z z); auto. -zify. auto with zarith. -Qed. - -Lemma B_holds : forall z : Z, B z. -Proof. -intros; destruct (Z_lt_le_dec 0 z). -apply natlike_ind; auto with zarith. -apply B0. -intros; apply BS; auto. -replace z with (-(-z))%Z in * by (auto with zarith). -remember (-z)%Z as z'. -pattern z'; apply natlike_ind. -apply B0. -intros; rewrite Z.opp_succ; unfold Z.pred; apply BP; auto. -subst z'; auto with zarith. -Qed. - -Theorem bi_induction : forall n, A n. -Proof. -intro n. setoid_replace n with (of_Z (to_Z n)). -apply B_holds. -zify. auto. -Qed. - -End Induction. - -Theorem add_0_l : forall n, 0 + n == n. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem add_succ_l : forall n m, (succ n) + m == succ (n + m). -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem sub_0_r : forall n, n - 0 == n. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m). -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem mul_0_l : forall n, 0 * n == 0. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem mul_succ_l : forall n m, (succ n) * m == n * m + m. -Proof. -intros. zify. ring. -Qed. - -(** Order *) - -Lemma eqb_eq x y : eqb x y = true <-> x == y. -Proof. - zify. apply Z.eqb_eq. -Qed. - -Lemma leb_le x y : leb x y = true <-> x <= y. -Proof. - zify. apply Z.leb_le. -Qed. - -Lemma ltb_lt x y : ltb x y = true <-> x < y. -Proof. - zify. apply Z.ltb_lt. -Qed. - -Lemma compare_eq_iff n m : compare n m = Eq <-> n == m. -Proof. - intros. zify. apply Z.compare_eq_iff. -Qed. - -Lemma compare_lt_iff n m : compare n m = Lt <-> n < m. -Proof. - intros. zify. reflexivity. -Qed. - -Lemma compare_le_iff n m : compare n m <> Gt <-> n <= m. -Proof. - intros. zify. reflexivity. -Qed. - -Lemma compare_antisym n m : compare m n = CompOpp (compare n m). -Proof. - intros. zify. apply Z.compare_antisym. -Qed. - -Include BoolOrderFacts ZZ ZZ ZZ [no inline]. - -Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance eqb_wd : Proper (eq ==> eq ==> Logic.eq) eqb. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance ltb_wd : Proper (eq ==> eq ==> Logic.eq) ltb. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance leb_wd : Proper (eq ==> eq ==> Logic.eq) leb. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance lt_wd : Proper (eq ==> eq ==> iff) lt. -Proof. -intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition. -Qed. - -Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m. -Proof. -intros. zify. omega. -Qed. - -Theorem min_l : forall n m, n <= m -> min n m == n. -Proof. -intros n m. zify. omega with *. -Qed. - -Theorem min_r : forall n m, m <= n -> min n m == m. -Proof. -intros n m. zify. omega with *. -Qed. - -Theorem max_l : forall n m, m <= n -> max n m == n. -Proof. -intros n m. zify. omega with *. -Qed. - -Theorem max_r : forall n m, n <= m -> max n m == m. -Proof. -intros n m. zify. omega with *. -Qed. - -(** Part specific to integers, not natural numbers *) - -Theorem succ_pred : forall n, succ (pred n) == n. -Proof. -intros. zify. auto with zarith. -Qed. - -(** Opp *) - -Program Instance opp_wd : Proper (eq ==> eq) opp. - -Theorem opp_0 : - 0 == 0. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem opp_succ : forall n, - (succ n) == pred (- n). -Proof. -intros. zify. auto with zarith. -Qed. - -(** Abs / Sgn *) - -Theorem abs_eq : forall n, 0 <= n -> abs n == n. -Proof. -intros n. zify. omega with *. -Qed. - -Theorem abs_neq : forall n, n <= 0 -> abs n == -n. -Proof. -intros n. zify. omega with *. -Qed. - -Theorem sgn_null : forall n, n==0 -> sgn n == 0. -Proof. -intros n. zify. omega with *. -Qed. - -Theorem sgn_pos : forall n, 0 sgn n == 1. -Proof. -intros n. zify. omega with *. -Qed. - -Theorem sgn_neg : forall n, n<0 -> sgn n == opp 1. -Proof. -intros n. zify. omega with *. -Qed. - -(** Power *) - -Program Instance pow_wd : Proper (eq==>eq==>eq) pow. - -Lemma pow_0_r : forall a, a^0 == 1. -Proof. - intros. now zify. -Qed. - -Lemma pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b. -Proof. - intros a b. zify. intros. now rewrite Z.add_1_r, Z.pow_succ_r. -Qed. - -Lemma pow_neg_r : forall a b, b<0 -> a^b == 0. -Proof. - intros a b. zify. intros Hb. - destruct [b]; reflexivity || discriminate. -Qed. - -Lemma pow_pow_N : forall a b, 0<=b -> a^b == pow_N a (Z.to_N (to_Z b)). -Proof. - intros a b. zify. intros Hb. now rewrite spec_pow_N, Z2N.id. -Qed. - -Lemma pow_pos_N : forall a p, pow_pos a p == pow_N a (Npos p). -Proof. - intros a b. red. now rewrite spec_pow_N, spec_pow_pos. -Qed. - -(** Square *) - -Lemma square_spec n : square n == n * n. -Proof. - now zify. -Qed. - -(** Sqrt *) - -Lemma sqrt_spec : forall n, 0<=n -> - (sqrt n)*(sqrt n) <= n /\ n < (succ (sqrt n))*(succ (sqrt n)). -Proof. - intros n. zify. apply Z.sqrt_spec. -Qed. - -Lemma sqrt_neg : forall n, n<0 -> sqrt n == 0. -Proof. - intros n. zify. apply Z.sqrt_neg. -Qed. - -(** Log2 *) - -Lemma log2_spec : forall n, 0 - 2^(log2 n) <= n /\ n < 2^(succ (log2 n)). -Proof. - intros n. zify. apply Z.log2_spec. -Qed. - -Lemma log2_nonpos : forall n, n<=0 -> log2 n == 0. -Proof. - intros n. zify. apply Z.log2_nonpos. -Qed. - -(** Even / Odd *) - -Definition Even n := exists m, n == 2*m. -Definition Odd n := exists m, n == 2*m+1. - -Lemma even_spec n : even n = true <-> Even n. -Proof. - unfold Even. zify. rewrite Z.even_spec. - split; intros (m,Hm). - - exists (of_Z m). now zify. - - exists [m]. revert Hm. now zify. -Qed. - -Lemma odd_spec n : odd n = true <-> Odd n. -Proof. - unfold Odd. zify. rewrite Z.odd_spec. - split; intros (m,Hm). - - exists (of_Z m). now zify. - - exists [m]. revert Hm. now zify. -Qed. - -(** Div / Mod *) - -Program Instance div_wd : Proper (eq==>eq==>eq) div. -Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. - -Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b). -Proof. -intros a b. zify. intros. apply Z.div_mod; auto. -Qed. - -Theorem mod_pos_bound : - forall a b, 0 < b -> 0 <= modulo a b /\ modulo a b < b. -Proof. -intros a b. zify. intros. apply Z_mod_lt; auto with zarith. -Qed. - -Theorem mod_neg_bound : - forall a b, b < 0 -> b < modulo a b /\ modulo a b <= 0. -Proof. -intros a b. zify. intros. apply Z_mod_neg; auto with zarith. -Qed. - -Definition mod_bound_pos : - forall a b, 0<=a -> 0 0 <= modulo a b /\ modulo a b < b := - fun a b _ H => mod_pos_bound a b H. - -(** Quot / Rem *) - -Program Instance quot_wd : Proper (eq==>eq==>eq) quot. -Program Instance rem_wd : Proper (eq==>eq==>eq) rem. - -Theorem quot_rem : forall a b, ~b==0 -> a == b*(quot a b) + rem a b. -Proof. -intros a b. zify. apply Z.quot_rem. -Qed. - -Theorem rem_bound_pos : - forall a b, 0<=a -> 0 0 <= rem a b /\ rem a b < b. -Proof. -intros a b. zify. apply Z.rem_bound_pos. -Qed. - -Theorem rem_opp_l : forall a b, ~b==0 -> rem (-a) b == -(rem a b). -Proof. -intros a b. zify. apply Z.rem_opp_l. -Qed. - -Theorem rem_opp_r : forall a b, ~b==0 -> rem a (-b) == rem a b. -Proof. -intros a b. zify. apply Z.rem_opp_r. -Qed. - -(** Gcd *) - -Definition divide n m := exists p, m == p*n. -Local Notation "( x | y )" := (divide x y) (at level 0). - -Lemma spec_divide : forall n m, (n|m) <-> Z.divide [n] [m]. -Proof. - intros n m. split. - - intros (p,H). exists [p]. revert H; now zify. - - intros (z,H). exists (of_Z z). now zify. -Qed. - -Lemma gcd_divide_l : forall n m, (gcd n m | n). -Proof. - intros n m. apply spec_divide. zify. apply Z.gcd_divide_l. -Qed. - -Lemma gcd_divide_r : forall n m, (gcd n m | m). -Proof. - intros n m. apply spec_divide. zify. apply Z.gcd_divide_r. -Qed. - -Lemma gcd_greatest : forall n m p, (p|n) -> (p|m) -> (p|gcd n m). -Proof. - intros n m p. rewrite !spec_divide. zify. apply Z.gcd_greatest. -Qed. - -Lemma gcd_nonneg : forall n m, 0 <= gcd n m. -Proof. - intros. zify. apply Z.gcd_nonneg. -Qed. - -(** Bitwise operations *) - -Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit. - -Lemma testbit_odd_0 : forall a, testbit (2*a+1) 0 = true. -Proof. - intros. zify. apply Z.testbit_odd_0. -Qed. - -Lemma testbit_even_0 : forall a, testbit (2*a) 0 = false. -Proof. - intros. zify. apply Z.testbit_even_0. -Qed. - -Lemma testbit_odd_succ : forall a n, 0<=n -> - testbit (2*a+1) (succ n) = testbit a n. -Proof. - intros a n. zify. apply Z.testbit_odd_succ. -Qed. - -Lemma testbit_even_succ : forall a n, 0<=n -> - testbit (2*a) (succ n) = testbit a n. -Proof. - intros a n. zify. apply Z.testbit_even_succ. -Qed. - -Lemma testbit_neg_r : forall a n, n<0 -> testbit a n = false. -Proof. - intros a n. zify. apply Z.testbit_neg_r. -Qed. - -Lemma shiftr_spec : forall a n m, 0<=m -> - testbit (shiftr a n) m = testbit a (m+n). -Proof. - intros a n m. zify. apply Z.shiftr_spec. -Qed. - -Lemma shiftl_spec_high : forall a n m, 0<=m -> n<=m -> - testbit (shiftl a n) m = testbit a (m-n). -Proof. - intros a n m. zify. intros Hn H. - now apply Z.shiftl_spec_high. -Qed. - -Lemma shiftl_spec_low : forall a n m, m - testbit (shiftl a n) m = false. -Proof. - intros a n m. zify. intros H. now apply Z.shiftl_spec_low. -Qed. - -Lemma land_spec : forall a b n, - testbit (land a b) n = testbit a n && testbit b n. -Proof. - intros a n m. zify. now apply Z.land_spec. -Qed. - -Lemma lor_spec : forall a b n, - testbit (lor a b) n = testbit a n || testbit b n. -Proof. - intros a n m. zify. now apply Z.lor_spec. -Qed. - -Lemma ldiff_spec : forall a b n, - testbit (ldiff a b) n = testbit a n && negb (testbit b n). -Proof. - intros a n m. zify. now apply Z.ldiff_spec. -Qed. - -Lemma lxor_spec : forall a b n, - testbit (lxor a b) n = xorb (testbit a n) (testbit b n). -Proof. - intros a n m. zify. now apply Z.lxor_spec. -Qed. - -Lemma div2_spec : forall a, div2 a == shiftr a 1. -Proof. - intros a. zify. now apply Z.div2_spec. -Qed. - -End ZTypeIsZAxioms. - -Module ZType_ZAxioms (ZZ : ZType) - <: ZAxiomsSig <: OrderFunctions ZZ <: HasMinMax ZZ - := ZZ <+ ZTypeIsZAxioms. diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v index eaac7d69..ee28628e 100644 --- a/theories/Numbers/NaryFunctions.v +++ b/theories/Numbers/NaryFunctions.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* y" := (y < x) (only parsing) : bigN_scope. -Notation "x >= y" := (y <= x) (only parsing) : bigN_scope. -Notation "x < y < z" := (x BigN.succ (BigN.pred q) == q. -Proof. -intros; apply BigN.succ_pred. -intro H'; rewrite H' in H; discriminate. -Qed. - -(** [BigN] is a semi-ring *) - -Lemma BigNring : semi_ring_theory 0 1 BigN.add BigN.mul BigN.eq. -Proof. -constructor. -exact BigN.add_0_l. exact BigN.add_comm. exact BigN.add_assoc. -exact BigN.mul_1_l. exact BigN.mul_0_l. exact BigN.mul_comm. -exact BigN.mul_assoc. exact BigN.mul_add_distr_r. -Qed. - -Lemma BigNeqb_correct : forall x y, (x =? y) = true -> x==y. -Proof. now apply BigN.eqb_eq. Qed. - -Lemma BigNpower : power_theory 1 BigN.mul BigN.eq BigN.of_N BigN.pow. -Proof. -constructor. -intros. red. rewrite BigN.spec_pow, BigN.spec_of_N. -rewrite Zpower_theory.(rpow_pow_N). -destruct n; simpl. reflexivity. -induction p; simpl; intros; BigN.zify; rewrite ?IHp; auto. -Qed. - -Lemma BigNdiv : div_theory BigN.eq BigN.add BigN.mul (@id _) - (fun a b => if b =? 0 then (0,a) else BigN.div_eucl a b). -Proof. -constructor. unfold id. intros a b. -BigN.zify. -case Z.eqb_spec. -BigN.zify. auto with zarith. -intros NEQ. -generalize (BigN.spec_div_eucl a b). -generalize (Z_div_mod_full [a] [b] NEQ). -destruct BigN.div_eucl as (q,r), Z.div_eucl as (q',r'). -intros (EQ,_). injection 1 as EQr EQq. -BigN.zify. rewrite EQr, EQq; auto. -Qed. - - -(** Detection of constants *) - -Ltac isStaticWordCst t := - match t with - | W0 => constr:(true) - | WW ?t1 ?t2 => - match isStaticWordCst t1 with - | false => constr:(false) - | true => isStaticWordCst t2 - end - | _ => isInt31cst t - end. - -Ltac isBigNcst t := - match t with - | BigN.N0 ?t => isStaticWordCst t - | BigN.N1 ?t => isStaticWordCst t - | BigN.N2 ?t => isStaticWordCst t - | BigN.N3 ?t => isStaticWordCst t - | BigN.N4 ?t => isStaticWordCst t - | BigN.N5 ?t => isStaticWordCst t - | BigN.N6 ?t => isStaticWordCst t - | BigN.Nn ?n ?t => match isnatcst n with - | true => isStaticWordCst t - | false => constr:(false) - end - | BigN.zero => constr:(true) - | BigN.one => constr:(true) - | BigN.two => constr:(true) - | _ => constr:(false) - end. - -Ltac BigNcst t := - match isBigNcst t with - | true => constr:(t) - | false => constr:(NotConstant) - end. - -Ltac BigN_to_N t := - match isBigNcst t with - | true => eval vm_compute in (BigN.to_N t) - | false => constr:(NotConstant) - end. - -Ltac Ncst t := - match isNcst t with - | true => constr:(t) - | false => constr:(NotConstant) - end. - -(** Registration for the "ring" tactic *) - -Add Ring BigNr : BigNring - (decidable BigNeqb_correct, - constants [BigNcst], - power_tac BigNpower [BigN_to_N], - div BigNdiv). - -Section TestRing. -Let test : forall x y, 1 + x*y^1 + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x. -intros. ring_simplify. reflexivity. -Qed. -End TestRing. - -(** We benefit also from an "order" tactic *) - -Ltac bigN_order := BigN.order. - -Section TestOrder. -Let test : forall x y : bigN, x<=y -> y<=x -> x==y. -Proof. bigN_order. Qed. -End TestOrder. - -(** We can use at least a bit of (r)omega by translating to [Z]. *) - -Section TestOmega. -Let test : forall x y : bigN, x<=y -> y<=x -> x==y. -Proof. intros x y. BigN.zify. omega. Qed. -End TestOmega. - -(** Todo: micromega *) diff --git a/theories/Numbers/Natural/BigN/NMake.v b/theories/Numbers/Natural/BigN/NMake.v deleted file mode 100644 index 1425041a..00000000 --- a/theories/Numbers/Natural/BigN/NMake.v +++ /dev/null @@ -1,1706 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* let v := (eval red_t in u) in change v end. - - (** * Generic results *) - - Tactic Notation "destr_t" constr(x) "as" simple_intropattern(pat) := - destruct (destr_t x) as pat; cbv zeta; - rewrite ?iter_mk_t, ?spec_mk_t, ?spec_reduce. - - Lemma spec_same_level : forall A (P:Z->Z->A->Prop) - (f : forall n, dom_t n -> dom_t n -> A), - (forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)) -> - forall x y, P [x] [y] (same_level f x y). - Proof. - intros. apply spec_same_level_dep with (P:=fun _ => P); auto. - Qed. - - Theorem spec_pos: forall x, 0 <= [x]. - Proof. - intros x. destr_t x as (n,x). now case (ZnZ.spec_to_Z x). - Qed. - - Lemma digits_dom_op_incr : forall n m, (n<=m)%nat -> - (ZnZ.digits (dom_op n) <= ZnZ.digits (dom_op m))%positive. - Proof. - intros. - change (Zpos (ZnZ.digits (dom_op n)) <= Zpos (ZnZ.digits (dom_op m))). - rewrite !digits_dom_op, !Pshiftl_nat_Zpower. - apply Z.mul_le_mono_nonneg_l; auto with zarith. - apply Z.pow_le_mono_r; auto with zarith. - Qed. - - Definition to_N (x : t) := Z.to_N (to_Z x). - - (** * Zero, One *) - - Definition zero := mk_t O ZnZ.zero. - Definition one := mk_t O ZnZ.one. - - Theorem spec_0: [zero] = 0. - Proof. - unfold zero. rewrite spec_mk_t. exact ZnZ.spec_0. - Qed. - - Theorem spec_1: [one] = 1. - Proof. - unfold one. rewrite spec_mk_t. exact ZnZ.spec_1. - Qed. - - (** * Successor *) - - (** NB: it is crucial here and for the rest of this file to preserve - the let-in's. They allow to pre-compute once and for all the - field access to Z/nZ initial structures (when n=0..6). *) - - Local Notation succn := (fun n => - let op := dom_op n in - let succ_c := ZnZ.succ_c in - let one := ZnZ.one in - fun x => match succ_c x with - | C0 r => mk_t n r - | C1 r => mk_t_S n (WW one r) - end). - - Definition succ : t -> t := Eval red_t in iter_t succn. - - Lemma succ_fold : succ = iter_t succn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_succ: forall n, [succ n] = [n] + 1. - Proof. - intros x. rewrite succ_fold. destr_t x as (n,x). - generalize (ZnZ.spec_succ_c x); case ZnZ.succ_c. - intros. rewrite spec_mk_t. assumption. - intros. unfold interp_carry in *. - rewrite spec_mk_t_S. simpl. rewrite ZnZ.spec_1. assumption. - Qed. - - (** Two *) - - (** Not really pretty, but since W0 might be Z/2Z, we're not sure - there's a proper 2 there. *) - - Definition two := succ one. - - Lemma spec_2 : [two] = 2. - Proof. - unfold two. now rewrite spec_succ, spec_1. - Qed. - - (** * Addition *) - - Local Notation addn := (fun n => - let op := dom_op n in - let add_c := ZnZ.add_c in - let one := ZnZ.one in - fun x y =>match add_c x y with - | C0 r => mk_t n r - | C1 r => mk_t_S n (WW one r) - end). - - Definition add : t -> t -> t := Eval red_t in same_level addn. - - Lemma add_fold : add = same_level addn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_add: forall x y, [add x y] = [x] + [y]. - Proof. - intros x y. rewrite add_fold. apply spec_same_level; clear x y. - intros n x y. cbv beta iota zeta. - generalize (ZnZ.spec_add_c x y); case ZnZ.add_c; intros z H. - rewrite spec_mk_t. assumption. - rewrite spec_mk_t_S. unfold interp_carry in H. - simpl. rewrite ZnZ.spec_1. assumption. - Qed. - - (** * Predecessor *) - - Local Notation predn := (fun n => - let pred_c := ZnZ.pred_c in - fun x => match pred_c x with - | C0 r => reduce n r - | C1 _ => zero - end). - - Definition pred : t -> t := Eval red_t in iter_t predn. - - Lemma pred_fold : pred = iter_t predn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_pred_pos : forall x, 0 < [x] -> [pred x] = [x] - 1. - Proof. - intros x. rewrite pred_fold. destr_t x as (n,x). intros H. - generalize (ZnZ.spec_pred_c x); case ZnZ.pred_c; intros y H'. - rewrite spec_reduce. assumption. - exfalso. unfold interp_carry in *. - generalize (ZnZ.spec_to_Z x) (ZnZ.spec_to_Z y); auto with zarith. - Qed. - - Theorem spec_pred0 : forall x, [x] = 0 -> [pred x] = 0. - Proof. - intros x. rewrite pred_fold. destr_t x as (n,x). intros H. - generalize (ZnZ.spec_pred_c x); case ZnZ.pred_c; intros y H'. - rewrite spec_reduce. - unfold interp_carry in H'. - generalize (ZnZ.spec_to_Z y); auto with zarith. - exact spec_0. - Qed. - - Lemma spec_pred x : [pred x] = Z.max 0 ([x]-1). - Proof. - rewrite Z.max_comm. - destruct (Z.max_spec ([x]-1) 0) as [(H,->)|(H,->)]. - - apply spec_pred0; generalize (spec_pos x); auto with zarith. - - apply spec_pred_pos; auto with zarith. - Qed. - - (** * Subtraction *) - - Local Notation subn := (fun n => - let sub_c := ZnZ.sub_c in - fun x y => match sub_c x y with - | C0 r => reduce n r - | C1 r => zero - end). - - Definition sub : t -> t -> t := Eval red_t in same_level subn. - - Lemma sub_fold : sub = same_level subn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_sub_pos : forall x y, [y] <= [x] -> [sub x y] = [x] - [y]. - Proof. - intros x y. rewrite sub_fold. apply spec_same_level. clear x y. - intros n x y. simpl. - generalize (ZnZ.spec_sub_c x y); case ZnZ.sub_c; intros z H LE. - rewrite spec_reduce. assumption. - unfold interp_carry in H. - exfalso. - generalize (ZnZ.spec_to_Z z); auto with zarith. - Qed. - - Theorem spec_sub0 : forall x y, [x] < [y] -> [sub x y] = 0. - Proof. - intros x y. rewrite sub_fold. apply spec_same_level. clear x y. - intros n x y. simpl. - generalize (ZnZ.spec_sub_c x y); case ZnZ.sub_c; intros z H LE. - rewrite spec_reduce. - unfold interp_carry in H. - generalize (ZnZ.spec_to_Z z); auto with zarith. - exact spec_0. - Qed. - - Lemma spec_sub : forall x y, [sub x y] = Z.max 0 ([x]-[y]). - Proof. - intros. destruct (Z.le_gt_cases [y] [x]). - rewrite Z.max_r; auto with zarith. apply spec_sub_pos; auto. - rewrite Z.max_l; auto with zarith. apply spec_sub0; auto. - Qed. - - (** * Comparison *) - - Definition comparen_m n : - forall m, word (dom_t n) (S m) -> dom_t n -> comparison := - let op := dom_op n in - let zero := ZnZ.zero (Ops:=op) in - let compare := ZnZ.compare (Ops:=op) in - let compare0 := compare zero in - fun m => compare_mn_1 (dom_t n) (dom_t n) zero compare compare0 compare (S m). - - Let spec_comparen_m: - forall n m (x : word (dom_t n) (S m)) (y : dom_t n), - comparen_m n m x y = Z.compare (eval n (S m) x) (ZnZ.to_Z y). - Proof. - intros n m x y. - unfold comparen_m, eval. - rewrite nmake_double. - apply spec_compare_mn_1. - exact ZnZ.spec_0. - intros. apply ZnZ.spec_compare. - exact ZnZ.spec_to_Z. - exact ZnZ.spec_compare. - exact ZnZ.spec_compare. - exact ZnZ.spec_to_Z. - Qed. - - Definition comparenm n m wx wy := - let mn := Max.max n m in - let d := diff n m in - let op := make_op mn in - ZnZ.compare - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d))). - - Local Notation compare_folded := - (iter_sym _ - (fun n => ZnZ.compare (Ops:=dom_op n)) - comparen_m - comparenm - CompOpp). - - Definition compare : t -> t -> comparison := - Eval lazy beta iota delta [iter_sym dom_op dom_t comparen_m] in - compare_folded. - - Lemma compare_fold : compare = compare_folded. - Proof. - lazy beta iota delta [iter_sym dom_op dom_t comparen_m]. reflexivity. - Qed. - - Theorem spec_compare : forall x y, - compare x y = Z.compare [x] [y]. - Proof. - intros x y. rewrite compare_fold. apply spec_iter_sym; clear x y. - intros. apply ZnZ.spec_compare. - intros. cbv beta zeta. apply spec_comparen_m. - intros n m x y; unfold comparenm. - rewrite (spec_cast_l n m x), (spec_cast_r n m y). - unfold to_Z; apply ZnZ.spec_compare. - intros. subst. now rewrite <- Z.compare_antisym. - Qed. - - Definition eqb (x y : t) : bool := - match compare x y with - | Eq => true - | _ => false - end. - - Theorem spec_eqb x y : eqb x y = Z.eqb [x] [y]. - Proof. - apply eq_iff_eq_true. - unfold eqb. rewrite Z.eqb_eq, <- Z.compare_eq_iff, spec_compare. - split; [now destruct Z.compare | now intros ->]. - Qed. - - Definition lt (n m : t) := [n] < [m]. - Definition le (n m : t) := [n] <= [m]. - - Definition ltb (x y : t) : bool := - match compare x y with - | Lt => true - | _ => false - end. - - Theorem spec_ltb x y : ltb x y = Z.ltb [x] [y]. - Proof. - apply eq_iff_eq_true. - rewrite Z.ltb_lt. unfold Z.lt, ltb. rewrite spec_compare. - split; [now destruct Z.compare | now intros ->]. - Qed. - - Definition leb (x y : t) : bool := - match compare x y with - | Gt => false - | _ => true - end. - - Theorem spec_leb x y : leb x y = Z.leb [x] [y]. - Proof. - apply eq_iff_eq_true. - rewrite Z.leb_le. unfold Z.le, leb. rewrite spec_compare. - now destruct Z.compare; split. - Qed. - - Definition min (n m : t) : t := match compare n m with Gt => m | _ => n end. - Definition max (n m : t) : t := match compare n m with Lt => m | _ => n end. - - Theorem spec_max : forall n m, [max n m] = Z.max [n] [m]. - Proof. - intros. unfold max, Z.max. rewrite spec_compare; destruct Z.compare; reflexivity. - Qed. - - Theorem spec_min : forall n m, [min n m] = Z.min [n] [m]. - Proof. - intros. unfold min, Z.min. rewrite spec_compare; destruct Z.compare; reflexivity. - Qed. - - (** * Multiplication *) - - Definition wn_mul n : forall m, word (dom_t n) (S m) -> dom_t n -> t := - let op := dom_op n in - let zero := ZnZ.zero in - let succ := ZnZ.succ (Ops:=op) in - let add_c := ZnZ.add_c (Ops:=op) in - let mul_c := ZnZ.mul_c (Ops:=op) in - let ww := @ZnZ.WW _ op in - let ow := @ZnZ.OW _ op in - let eq0 := ZnZ.eq0 in - let mul_add := @DoubleMul.w_mul_add _ zero succ add_c mul_c in - let mul_add_n1 := @DoubleMul.double_mul_add_n1 _ zero ww ow mul_add in - fun m x y => - let (w,r) := mul_add_n1 (S m) x y zero in - if eq0 w then mk_t_w' n m r - else mk_t_w' n (S m) (WW (extend n m w) r). - - Definition mulnm n m x y := - let mn := Max.max n m in - let d := diff n m in - let op := make_op mn in - reduce_n (S mn) (ZnZ.mul_c - (castm (diff_r n m) (extend_tr x (snd d))) - (castm (diff_l n m) (extend_tr y (fst d)))). - - Local Notation mul_folded := - (iter_sym _ - (fun n => let mul_c := ZnZ.mul_c in - fun x y => reduce (S n) (succ_t _ (mul_c x y))) - wn_mul - mulnm - (fun x => x)). - - Definition mul : t -> t -> t := - Eval lazy beta iota delta - [iter_sym dom_op dom_t reduce succ_t extend zeron - wn_mul DoubleMul.w_mul_add mk_t_w'] in - mul_folded. - - Lemma mul_fold : mul = mul_folded. - Proof. - lazy beta iota delta - [iter_sym dom_op dom_t reduce succ_t extend zeron - wn_mul DoubleMul.w_mul_add mk_t_w']. reflexivity. - Qed. - - Lemma spec_muln: - forall n (x: word _ (S n)) y, - [Nn (S n) (ZnZ.mul_c (Ops:=make_op n) x y)] = [Nn n x] * [Nn n y]. - Proof. - intros n x y; unfold to_Z. - rewrite <- ZnZ.spec_mul_c. - rewrite make_op_S. - case ZnZ.mul_c; auto. - Qed. - - Lemma spec_mul_add_n1: forall n m x y z, - let (q,r) := DoubleMul.double_mul_add_n1 ZnZ.zero ZnZ.WW ZnZ.OW - (DoubleMul.w_mul_add ZnZ.zero ZnZ.succ ZnZ.add_c ZnZ.mul_c) - (S m) x y z in - ZnZ.to_Z q * (base (ZnZ.digits (nmake_op _ (dom_op n) (S m)))) - + eval n (S m) r = - eval n (S m) x * ZnZ.to_Z y + ZnZ.to_Z z. - Proof. - intros n m x y z. - rewrite digits_nmake. - unfold eval. rewrite nmake_double. - apply DoubleMul.spec_double_mul_add_n1. - apply ZnZ.spec_0. - exact ZnZ.spec_WW. - exact ZnZ.spec_OW. - apply DoubleCyclic.spec_mul_add. - Qed. - - Lemma spec_wn_mul : forall n m x y, - [wn_mul n m x y] = (eval n (S m) x) * ZnZ.to_Z y. - Proof. - intros; unfold wn_mul. - generalize (spec_mul_add_n1 n m x y ZnZ.zero). - case DoubleMul.double_mul_add_n1; intros q r Hqr. - rewrite ZnZ.spec_0, Z.add_0_r in Hqr. rewrite <- Hqr. - generalize (ZnZ.spec_eq0 q); case ZnZ.eq0; intros HH. - rewrite HH; auto. simpl. apply spec_mk_t_w'. - clear. - rewrite spec_mk_t_w'. - set (m' := S m) in *. - unfold eval. - rewrite nmake_WW. f_equal. f_equal. - rewrite <- spec_mk_t. - symmetry. apply spec_extend. - Qed. - - Theorem spec_mul : forall x y, [mul x y] = [x] * [y]. - Proof. - intros x y. rewrite mul_fold. apply spec_iter_sym; clear x y. - intros n x y. cbv zeta beta. - rewrite spec_reduce, spec_succ_t, <- ZnZ.spec_mul_c; auto. - apply spec_wn_mul. - intros n m x y; unfold mulnm. rewrite spec_reduce_n. - rewrite (spec_cast_l n m x), (spec_cast_r n m y). - apply spec_muln. - intros. rewrite Z.mul_comm; auto. - Qed. - - (** * Division by a smaller number *) - - Definition wn_divn1 n := - let op := dom_op n in - let zd := ZnZ.zdigits op in - let zero := ZnZ.zero in - let ww := ZnZ.WW in - let head0 := ZnZ.head0 in - let add_mul_div := ZnZ.add_mul_div in - let div21 := ZnZ.div21 in - let compare := ZnZ.compare in - let sub := ZnZ.sub in - let ddivn1 := - DoubleDivn1.double_divn1 zd zero ww head0 add_mul_div div21 compare sub in - fun m x y => let (u,v) := ddivn1 (S m) x y in (mk_t_w' n m u, mk_t n v). - - Definition div_gtnm n m wx wy := - let mn := Max.max n m in - let d := diff n m in - let op := make_op mn in - let (q, r):= ZnZ.div_gt - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d))) in - (reduce_n mn q, reduce_n mn r). - - Local Notation div_gt_folded := - (iter _ - (fun n => let div_gt := ZnZ.div_gt in - fun x y => let (u,v) := div_gt x y in (reduce n u, reduce n v)) - (fun n => - let div_gt := ZnZ.div_gt in - fun m x y => - let y' := DoubleBase.get_low (zeron n) (S m) y in - let (u,v) := div_gt x y' in (reduce n u, reduce n v)) - wn_divn1 - div_gtnm). - - Definition div_gt := - Eval lazy beta iota delta - [iter dom_op dom_t reduce zeron wn_divn1 mk_t_w' mk_t] in - div_gt_folded. - - Lemma div_gt_fold : div_gt = div_gt_folded. - Proof. - lazy beta iota delta [iter dom_op dom_t reduce zeron wn_divn1 mk_t_w' mk_t]. - reflexivity. - Qed. - - Lemma spec_get_endn: forall n m x y, - eval n m x <= [mk_t n y] -> - [mk_t n (DoubleBase.get_low (zeron n) m x)] = eval n m x. - Proof. - intros n m x y H. - unfold eval. rewrite nmake_double. - rewrite spec_mk_t in *. - apply DoubleBase.spec_get_low. - apply spec_zeron. - exact ZnZ.spec_to_Z. - apply Z.le_lt_trans with (ZnZ.to_Z y); auto. - rewrite <- nmake_double; auto. - case (ZnZ.spec_to_Z y); auto. - Qed. - - Definition spec_divn1 n := - DoubleDivn1.spec_double_divn1 - (ZnZ.zdigits (dom_op n)) (ZnZ.zero:dom_t n) - ZnZ.WW ZnZ.head0 - ZnZ.add_mul_div ZnZ.div21 - ZnZ.compare ZnZ.sub ZnZ.to_Z - ZnZ.spec_to_Z - ZnZ.spec_zdigits - ZnZ.spec_0 ZnZ.spec_WW ZnZ.spec_head0 - ZnZ.spec_add_mul_div ZnZ.spec_div21 - ZnZ.spec_compare ZnZ.spec_sub. - - Lemma spec_div_gt_aux : forall x y, [x] > [y] -> 0 < [y] -> - let (q,r) := div_gt x y in - [x] = [q] * [y] + [r] /\ 0 <= [r] < [y]. - Proof. - intros x y. rewrite div_gt_fold. apply spec_iter; clear x y. - intros n x y H1 H2. simpl. - generalize (ZnZ.spec_div_gt x y H1 H2); case ZnZ.div_gt. - intros u v. rewrite 2 spec_reduce. auto. - intros n m x y H1 H2. cbv zeta beta. - generalize (ZnZ.spec_div_gt x - (DoubleBase.get_low (zeron n) (S m) y)). - case ZnZ.div_gt. - intros u v H3; repeat rewrite spec_reduce. - generalize (spec_get_endn n (S m) y x). rewrite !spec_mk_t. intros H4. - rewrite H4 in H3; auto with zarith. - intros n m x y H1 H2. - generalize (spec_divn1 n (S m) x y H2). - unfold wn_divn1; case DoubleDivn1.double_divn1. - intros u v H3. - rewrite spec_mk_t_w', spec_mk_t. - rewrite <- !nmake_double in H3; auto. - intros n m x y H1 H2; unfold div_gtnm. - generalize (ZnZ.spec_div_gt - (castm (diff_r n m) - (extend_tr x (snd (diff n m)))) - (castm (diff_l n m) - (extend_tr y (fst (diff n m))))). - case ZnZ.div_gt. - intros xx yy HH. - repeat rewrite spec_reduce_n. - rewrite (spec_cast_l n m x), (spec_cast_r n m y). - unfold to_Z; apply HH. - rewrite (spec_cast_l n m x) in H1; auto. - rewrite (spec_cast_r n m y) in H1; auto. - rewrite (spec_cast_r n m y) in H2; auto. - Qed. - - Theorem spec_div_gt: forall x y, [x] > [y] -> 0 < [y] -> - let (q,r) := div_gt x y in - [q] = [x] / [y] /\ [r] = [x] mod [y]. - Proof. - intros x y H1 H2; generalize (spec_div_gt_aux x y H1 H2); case div_gt. - intros q r (H3, H4); split. - apply (Zdiv_unique [x] [y] [q] [r]); auto. - rewrite Z.mul_comm; auto. - apply (Zmod_unique [x] [y] [q] [r]); auto. - rewrite Z.mul_comm; auto. - Qed. - - (** * General Division *) - - Definition div_eucl (x y : t) : t * t := - if eqb y zero then (zero,zero) else - match compare x y with - | Eq => (one, zero) - | Lt => (zero, x) - | Gt => div_gt x y - end. - - Theorem spec_div_eucl: forall x y, - let (q,r) := div_eucl x y in - ([q], [r]) = Z.div_eucl [x] [y]. - Proof. - intros x y. unfold div_eucl. - rewrite spec_eqb, spec_compare, spec_0. - case Z.eqb_spec. - intros ->. rewrite spec_0. destruct [x]; auto. - intros H'. - assert (H : 0 < [y]) by (generalize (spec_pos y); auto with zarith). - clear H'. - case Z.compare_spec; intros Cmp; - rewrite ?spec_0, ?spec_1; intros; auto with zarith. - rewrite Cmp; generalize (Z_div_same [y] (Z.lt_gt _ _ H)) - (Z_mod_same [y] (Z.lt_gt _ _ H)); - unfold Z.div, Z.modulo; case Z.div_eucl; intros; subst; auto. - assert (LeLt: 0 <= [x] < [y]) by (generalize (spec_pos x); auto). - generalize (Zdiv_small _ _ LeLt) (Zmod_small _ _ LeLt); - unfold Z.div, Z.modulo; case Z.div_eucl; intros; subst; auto. - generalize (spec_div_gt _ _ (Z.lt_gt _ _ Cmp) H); auto. - unfold Z.div, Z.modulo; case Z.div_eucl; case div_gt. - intros a b c d (H1, H2); subst; auto. - Qed. - - Definition div (x y : t) : t := fst (div_eucl x y). - - Theorem spec_div: - forall x y, [div x y] = [x] / [y]. - Proof. - intros x y; unfold div; generalize (spec_div_eucl x y); - case div_eucl; simpl fst. - intros xx yy; unfold Z.div; case Z.div_eucl; intros qq rr H; - injection H; auto. - Qed. - - (** * Modulo by a smaller number *) - - Definition wn_modn1 n := - let op := dom_op n in - let zd := ZnZ.zdigits op in - let zero := ZnZ.zero in - let head0 := ZnZ.head0 in - let add_mul_div := ZnZ.add_mul_div in - let div21 := ZnZ.div21 in - let compare := ZnZ.compare in - let sub := ZnZ.sub in - let dmodn1 := - DoubleDivn1.double_modn1 zd zero head0 add_mul_div div21 compare sub in - fun m x y => reduce n (dmodn1 (S m) x y). - - Definition mod_gtnm n m wx wy := - let mn := Max.max n m in - let d := diff n m in - let op := make_op mn in - reduce_n mn (ZnZ.modulo_gt - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d)))). - - Local Notation mod_gt_folded := - (iter _ - (fun n => let modulo_gt := ZnZ.modulo_gt in - fun x y => reduce n (modulo_gt x y)) - (fun n => let modulo_gt := ZnZ.modulo_gt in - fun m x y => - reduce n (modulo_gt x (DoubleBase.get_low (zeron n) (S m) y))) - wn_modn1 - mod_gtnm). - - Definition mod_gt := - Eval lazy beta iota delta [iter dom_op dom_t reduce wn_modn1 zeron] in - mod_gt_folded. - - Lemma mod_gt_fold : mod_gt = mod_gt_folded. - Proof. - lazy beta iota delta [iter dom_op dom_t reduce wn_modn1 zeron]. - reflexivity. - Qed. - - Definition spec_modn1 n := - DoubleDivn1.spec_double_modn1 - (ZnZ.zdigits (dom_op n)) (ZnZ.zero:dom_t n) - ZnZ.WW ZnZ.head0 - ZnZ.add_mul_div ZnZ.div21 - ZnZ.compare ZnZ.sub ZnZ.to_Z - ZnZ.spec_to_Z - ZnZ.spec_zdigits - ZnZ.spec_0 ZnZ.spec_WW ZnZ.spec_head0 - ZnZ.spec_add_mul_div ZnZ.spec_div21 - ZnZ.spec_compare ZnZ.spec_sub. - - Theorem spec_mod_gt: - forall x y, [x] > [y] -> 0 < [y] -> [mod_gt x y] = [x] mod [y]. - Proof. - intros x y. rewrite mod_gt_fold. apply spec_iter; clear x y. - intros n x y H1 H2. simpl. rewrite spec_reduce. - exact (ZnZ.spec_modulo_gt x y H1 H2). - intros n m x y H1 H2. cbv zeta beta. rewrite spec_reduce. - rewrite <- spec_mk_t in H1. - rewrite <- (spec_get_endn n (S m) y x); auto with zarith. - rewrite spec_mk_t. - apply ZnZ.spec_modulo_gt; auto. - rewrite <- (spec_get_endn n (S m) y x), !spec_mk_t in H1; auto with zarith. - rewrite <- (spec_get_endn n (S m) y x), !spec_mk_t in H2; auto with zarith. - intros n m x y H1 H2. unfold wn_modn1. rewrite spec_reduce. - unfold eval; rewrite nmake_double. - apply (spec_modn1 n); auto. - intros n m x y H1 H2; unfold mod_gtnm. - repeat rewrite spec_reduce_n. - rewrite (spec_cast_l n m x), (spec_cast_r n m y). - unfold to_Z; apply ZnZ.spec_modulo_gt. - rewrite (spec_cast_l n m x) in H1; auto. - rewrite (spec_cast_r n m y) in H1; auto. - rewrite (spec_cast_r n m y) in H2; auto. - Qed. - - (** * General Modulo *) - - Definition modulo (x y : t) : t := - if eqb y zero then zero else - match compare x y with - | Eq => zero - | Lt => x - | Gt => mod_gt x y - end. - - Theorem spec_modulo: - forall x y, [modulo x y] = [x] mod [y]. - Proof. - intros x y. unfold modulo. - rewrite spec_eqb, spec_compare, spec_0. - case Z.eqb_spec. - intros ->; rewrite spec_0. destruct [x]; auto. - intro H'. - assert (H : 0 < [y]) by (generalize (spec_pos y); auto with zarith). - clear H'. - case Z.compare_spec; - rewrite ?spec_0, ?spec_1; intros; try split; auto with zarith. - rewrite H0; symmetry; apply Z_mod_same; auto with zarith. - symmetry; apply Zmod_small; auto with zarith. - generalize (spec_pos x); auto with zarith. - apply spec_mod_gt; auto with zarith. - Qed. - - (** * Square *) - - Local Notation squaren := (fun n => - let square_c := ZnZ.square_c in - fun x => reduce (S n) (succ_t _ (square_c x))). - - Definition square : t -> t := Eval red_t in iter_t squaren. - - Lemma square_fold : square = iter_t squaren. - Proof. red_t; reflexivity. Qed. - - Theorem spec_square: forall x, [square x] = [x] * [x]. - Proof. - intros x. rewrite square_fold. destr_t x as (n,x). - rewrite spec_succ_t. exact (ZnZ.spec_square_c x). - Qed. - - (** * Square Root *) - - Local Notation sqrtn := (fun n => - let sqrt := ZnZ.sqrt in - fun x => reduce n (sqrt x)). - - Definition sqrt : t -> t := Eval red_t in iter_t sqrtn. - - Lemma sqrt_fold : sqrt = iter_t sqrtn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_sqrt_aux: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. - Proof. - intros x. rewrite sqrt_fold. destr_t x as (n,x). exact (ZnZ.spec_sqrt x). - Qed. - - Theorem spec_sqrt: forall x, [sqrt x] = Z.sqrt [x]. - Proof. - intros x. - symmetry. apply Z.sqrt_unique. - rewrite <- ! Z.pow_2_r. apply spec_sqrt_aux. - Qed. - - (** * Power *) - - Fixpoint pow_pos (x:t)(p:positive) : t := - match p with - | xH => x - | xO p => square (pow_pos x p) - | xI p => mul (square (pow_pos x p)) x - end. - - Theorem spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n. - Proof. - intros x n; generalize x; elim n; clear n x; simpl pow_pos. - intros; rewrite spec_mul; rewrite spec_square; rewrite H. - rewrite Pos2Z.inj_xI; rewrite Zpower_exp; auto with zarith. - rewrite (Z.mul_comm 2); rewrite Z.pow_mul_r; auto with zarith. - rewrite Z.pow_2_r; rewrite Z.pow_1_r; auto. - intros; rewrite spec_square; rewrite H. - rewrite Pos2Z.inj_xO; auto with zarith. - rewrite (Z.mul_comm 2); rewrite Z.pow_mul_r; auto with zarith. - rewrite Z.pow_2_r; auto. - intros; rewrite Z.pow_1_r; auto. - Qed. - - Definition pow_N (x:t)(n:N) : t := match n with - | BinNat.N0 => one - | BinNat.Npos p => pow_pos x p - end. - - Theorem spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z.of_N n. - Proof. - destruct n; simpl. apply spec_1. - apply spec_pow_pos. - Qed. - - Definition pow (x y:t) : t := pow_N x (to_N y). - - Theorem spec_pow : forall x y, [pow x y] = [x] ^ [y]. - Proof. - intros. unfold pow, to_N. - now rewrite spec_pow_N, Z2N.id by apply spec_pos. - Qed. - - - (** * digits - - Number of digits in the representation of a numbers - (including head zero's). - NB: This function isn't a morphism for setoid [eq]. - *) - - Local Notation digitsn := (fun n => - let digits := ZnZ.digits (dom_op n) in - fun _ => digits). - - Definition digits : t -> positive := Eval red_t in iter_t digitsn. - - Lemma digits_fold : digits = iter_t digitsn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_digits: forall x, 0 <= [x] < 2 ^ Zpos (digits x). - Proof. - intros x. rewrite digits_fold. destr_t x as (n,x). exact (ZnZ.spec_to_Z x). - Qed. - - Lemma digits_level : forall x, digits x = ZnZ.digits (dom_op (level x)). - Proof. - intros x. rewrite digits_fold. unfold level. destr_t x as (n,x). reflexivity. - Qed. - - (** * Gcd *) - - Definition gcd_gt_body a b cont := - match compare b zero with - | Gt => - let r := mod_gt a b in - match compare r zero with - | Gt => cont r (mod_gt b r) - | _ => b - end - | _ => a - end. - - Theorem Zspec_gcd_gt_body: forall a b cont p, - [a] > [b] -> [a] < 2 ^ p -> - (forall a1 b1, [a1] < 2 ^ (p - 1) -> [a1] > [b1] -> - Zis_gcd [a1] [b1] [cont a1 b1]) -> - Zis_gcd [a] [b] [gcd_gt_body a b cont]. - Proof. - intros a b cont p H2 H3 H4; unfold gcd_gt_body. - rewrite ! spec_compare, spec_0. case Z.compare_spec. - intros ->; apply Zis_gcd_0. - intros HH; absurd (0 <= [b]); auto with zarith. - case (spec_digits b); auto with zarith. - intros H5; case Z.compare_spec. - intros H6; rewrite <- (Z.mul_1_r [b]). - rewrite (Z_div_mod_eq [a] [b]); auto with zarith. - rewrite <- spec_mod_gt; auto with zarith. - rewrite H6; rewrite Z.add_0_r. - apply Zis_gcd_mult; apply Zis_gcd_1. - intros; apply False_ind. - case (spec_digits (mod_gt a b)); auto with zarith. - intros H6; apply DoubleDiv.Zis_gcd_mod; auto with zarith. - apply DoubleDiv.Zis_gcd_mod; auto with zarith. - rewrite <- spec_mod_gt; auto with zarith. - assert (F2: [b] > [mod_gt a b]). - case (Z_mod_lt [a] [b]); auto with zarith. - repeat rewrite <- spec_mod_gt; auto with zarith. - assert (F3: [mod_gt a b] > [mod_gt b (mod_gt a b)]). - case (Z_mod_lt [b] [mod_gt a b]); auto with zarith. - rewrite <- spec_mod_gt; auto with zarith. - repeat rewrite <- spec_mod_gt; auto with zarith. - apply H4; auto with zarith. - apply Z.mul_lt_mono_pos_r with 2; auto with zarith. - apply Z.le_lt_trans with ([b] + [mod_gt a b]); auto with zarith. - apply Z.le_lt_trans with (([a]/[b]) * [b] + [mod_gt a b]); auto with zarith. - - apply Z.add_le_mono_r. - rewrite <- (Z.mul_1_l [b]) at 1. - apply Z.mul_le_mono_nonneg_r; auto with zarith. - change 1 with (Z.succ 0). apply Z.le_succ_l. - apply Z.div_str_pos; auto with zarith. - - rewrite Z.mul_comm; rewrite spec_mod_gt; auto with zarith. - rewrite <- Z_div_mod_eq; auto with zarith. - rewrite Z.mul_comm, <- Z.pow_succ_r, Z.sub_1_r, Z.succ_pred; auto. - apply Z.le_0_sub. change 1 with (Z.succ 0). apply Z.le_succ_l. - destruct p; simpl in H3; auto with zarith. - Qed. - - Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) : t := - gcd_gt_body a b - (fun a b => - match p with - | xH => cont a b - | xO p => gcd_gt_aux p (gcd_gt_aux p cont) a b - | xI p => gcd_gt_aux p (gcd_gt_aux p cont) a b - end). - - Theorem Zspec_gcd_gt_aux: forall p n a b cont, - [a] > [b] -> [a] < 2 ^ (Zpos p + n) -> - (forall a1 b1, [a1] < 2 ^ n -> [a1] > [b1] -> - Zis_gcd [a1] [b1] [cont a1 b1]) -> - Zis_gcd [a] [b] [gcd_gt_aux p cont a b]. - intros p; elim p; clear p. - intros p Hrec n a b cont H2 H3 H4. - unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xI p) + n); auto. - intros a1 b1 H6 H7. - apply Hrec with (Zpos p + n); auto. - replace (Zpos p + (Zpos p + n)) with - (Zpos (xI p) + n - 1); auto. - rewrite Pos2Z.inj_xI; ring. - intros a2 b2 H9 H10. - apply Hrec with n; auto. - intros p Hrec n a b cont H2 H3 H4. - unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xO p) + n); auto. - intros a1 b1 H6 H7. - apply Hrec with (Zpos p + n - 1); auto. - replace (Zpos p + (Zpos p + n - 1)) with - (Zpos (xO p) + n - 1); auto. - rewrite Pos2Z.inj_xO; ring. - intros a2 b2 H9 H10. - apply Hrec with (n - 1); auto. - replace (Zpos p + (n - 1)) with - (Zpos p + n - 1); auto with zarith. - intros a3 b3 H12 H13; apply H4; auto with zarith. - apply Z.lt_le_trans with (1 := H12). - apply Z.pow_le_mono_r; auto with zarith. - intros n a b cont H H2 H3. - simpl gcd_gt_aux. - apply Zspec_gcd_gt_body with (n + 1); auto with zarith. - rewrite Z.add_comm; auto. - intros a1 b1 H5 H6; apply H3; auto. - replace n with (n + 1 - 1); auto; try ring. - Qed. - - Definition gcd_cont a b := - match compare one b with - | Eq => one - | _ => a - end. - - Definition gcd_gt a b := gcd_gt_aux (digits a) gcd_cont a b. - - Theorem spec_gcd_gt: forall a b, - [a] > [b] -> [gcd_gt a b] = Z.gcd [a] [b]. - Proof. - intros a b H2. - case (spec_digits (gcd_gt a b)); intros H3 H4. - case (spec_digits a); intros H5 H6. - symmetry; apply Zis_gcd_gcd; auto with zarith. - unfold gcd_gt; apply Zspec_gcd_gt_aux with 0; auto with zarith. - intros a1 a2; rewrite Z.pow_0_r. - case (spec_digits a2); intros H7 H8; - intros; apply False_ind; auto with zarith. - Qed. - - Definition gcd (a b : t) : t := - match compare a b with - | Eq => a - | Lt => gcd_gt b a - | Gt => gcd_gt a b - end. - - Theorem spec_gcd: forall a b, [gcd a b] = Z.gcd [a] [b]. - Proof. - intros a b. - case (spec_digits a); intros H1 H2. - case (spec_digits b); intros H3 H4. - unfold gcd. rewrite spec_compare. case Z.compare_spec. - intros HH; rewrite HH; symmetry; apply Zis_gcd_gcd; auto. - apply Zis_gcd_refl. - intros; transitivity (Z.gcd [b] [a]). - apply spec_gcd_gt; auto with zarith. - apply Zis_gcd_gcd; auto with zarith. - apply Z.gcd_nonneg. - apply Zis_gcd_sym; apply Zgcd_is_gcd. - intros; apply spec_gcd_gt; auto with zarith. - Qed. - - (** * Parity test *) - - Definition even : t -> bool := Eval red_t in - iter_t (fun n x => ZnZ.is_even x). - - Definition odd x := negb (even x). - - Lemma even_fold : even = iter_t (fun n x => ZnZ.is_even x). - Proof. red_t; reflexivity. Qed. - - Theorem spec_even_aux: forall x, - if even x then [x] mod 2 = 0 else [x] mod 2 = 1. - Proof. - intros x. rewrite even_fold. destr_t x as (n,x). - exact (ZnZ.spec_is_even x). - Qed. - - Theorem spec_even: forall x, even x = Z.even [x]. - Proof. - intros x. assert (H := spec_even_aux x). symmetry. - rewrite (Z.div_mod [x] 2); auto with zarith. - destruct (even x); rewrite H, ?Z.add_0_r. - rewrite Zeven_bool_iff. apply Zeven_2p. - apply not_true_is_false. rewrite Zeven_bool_iff. - apply Zodd_not_Zeven. apply Zodd_2p_plus_1. - Qed. - - Theorem spec_odd: forall x, odd x = Z.odd [x]. - Proof. - intros x. unfold odd. - assert (H := spec_even_aux x). symmetry. - rewrite (Z.div_mod [x] 2); auto with zarith. - destruct (even x); rewrite H, ?Z.add_0_r; simpl negb. - apply not_true_is_false. rewrite Zodd_bool_iff. - apply Zeven_not_Zodd. apply Zeven_2p. - apply Zodd_bool_iff. apply Zodd_2p_plus_1. - Qed. - - (** * Conversion *) - - Definition pheight p := - Peano.pred (Pos.to_nat (get_height (ZnZ.digits (dom_op 0)) (plength p))). - - Theorem pheight_correct: forall p, - Zpos p < 2 ^ (Zpos (ZnZ.digits (dom_op 0)) * 2 ^ (Z.of_nat (pheight p))). - Proof. - intros p; unfold pheight. - rewrite Nat2Z.inj_pred by apply Pos2Nat.is_pos. - rewrite positive_nat_Z. - rewrite <- Z.sub_1_r. - assert (F2:= (get_height_correct (ZnZ.digits (dom_op 0)) (plength p))). - apply Z.lt_le_trans with (Zpos (Pos.succ p)). - rewrite Pos2Z.inj_succ; auto with zarith. - apply Z.le_trans with (1 := plength_pred_correct (Pos.succ p)). - rewrite Pos.pred_succ. - apply Z.pow_le_mono_r; auto with zarith. - Qed. - - Definition of_pos (x:positive) : t := - let n := pheight x in - reduce n (snd (ZnZ.of_pos x)). - - Theorem spec_of_pos: forall x, - [of_pos x] = Zpos x. - Proof. - intros x; unfold of_pos. - rewrite spec_reduce. - simpl. - apply ZnZ.of_pos_correct. - unfold base. - apply Z.lt_le_trans with (1 := pheight_correct x). - apply Z.pow_le_mono_r; auto with zarith. - rewrite (digits_dom_op (_ _)), Pshiftl_nat_Zpower. auto with zarith. - Qed. - - Definition of_N (x:N) : t := - match x with - | BinNat.N0 => zero - | Npos p => of_pos p - end. - - Theorem spec_of_N: forall x, - [of_N x] = Z.of_N x. - Proof. - intros x; case x. - simpl of_N. exact spec_0. - intros p; exact (spec_of_pos p). - Qed. - - (** * [head0] and [tail0] - - Number of zero at the beginning and at the end of - the representation of the number. - NB: these functions are not morphism for setoid [eq]. - *) - - Local Notation head0n := (fun n => - let head0 := ZnZ.head0 in - fun x => reduce n (head0 x)). - - Definition head0 : t -> t := Eval red_t in iter_t head0n. - - Lemma head0_fold : head0 = iter_t head0n. - Proof. red_t; reflexivity. Qed. - - Theorem spec_head00: forall x, [x] = 0 -> [head0 x] = Zpos (digits x). - Proof. - intros x. rewrite head0_fold, digits_fold. destr_t x as (n,x). - exact (ZnZ.spec_head00 x). - Qed. - - Lemma pow2_pos_minus_1 : forall z, 0 2^(z-1) = 2^z / 2. - Proof. - intros. apply Zdiv_unique with 0; auto with zarith. - change 2 with (2^1) at 2. - rewrite <- Zpower_exp; auto with zarith. - rewrite Z.add_0_r. f_equal. auto with zarith. - Qed. - - Theorem spec_head0: forall x, 0 < [x] -> - 2 ^ (Zpos (digits x) - 1) <= 2 ^ [head0 x] * [x] < 2 ^ Zpos (digits x). - Proof. - intros x. rewrite pow2_pos_minus_1 by (red; auto). - rewrite head0_fold, digits_fold. destr_t x as (n,x). exact (ZnZ.spec_head0 x). - Qed. - - Local Notation tail0n := (fun n => - let tail0 := ZnZ.tail0 in - fun x => reduce n (tail0 x)). - - Definition tail0 : t -> t := Eval red_t in iter_t tail0n. - - Lemma tail0_fold : tail0 = iter_t tail0n. - Proof. red_t; reflexivity. Qed. - - Theorem spec_tail00: forall x, [x] = 0 -> [tail0 x] = Zpos (digits x). - Proof. - intros x. rewrite tail0_fold, digits_fold. destr_t x as (n,x). - exact (ZnZ.spec_tail00 x). - Qed. - - Theorem spec_tail0: forall x, - 0 < [x] -> exists y, 0 <= y /\ [x] = (2 * y + 1) * 2 ^ [tail0 x]. - Proof. - intros x. rewrite tail0_fold. destr_t x as (n,x). exact (ZnZ.spec_tail0 x). - Qed. - - (** * [Ndigits] - - Same as [digits] but encoded using large integers - NB: this function is not a morphism for setoid [eq]. - *) - - Local Notation Ndigitsn := (fun n => - let d := reduce n (ZnZ.zdigits (dom_op n)) in - fun _ => d). - - Definition Ndigits : t -> t := Eval red_t in iter_t Ndigitsn. - - Lemma Ndigits_fold : Ndigits = iter_t Ndigitsn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_Ndigits: forall x, [Ndigits x] = Zpos (digits x). - Proof. - intros x. rewrite Ndigits_fold, digits_fold. destr_t x as (n,x). - apply ZnZ.spec_zdigits. - Qed. - - (** * Binary logarithm *) - - Local Notation log2n := (fun n => - let op := dom_op n in - let zdigits := ZnZ.zdigits op in - let head0 := ZnZ.head0 in - let sub_carry := ZnZ.sub_carry in - fun x => reduce n (sub_carry zdigits (head0 x))). - - Definition log2 : t -> t := Eval red_t in - let log2 := iter_t log2n in - fun x => if eqb x zero then zero else log2 x. - - Lemma log2_fold : - log2 = fun x => if eqb x zero then zero else iter_t log2n x. - Proof. red_t; reflexivity. Qed. - - Lemma spec_log2_0 : forall x, [x] = 0 -> [log2 x] = 0. - Proof. - intros x H. rewrite log2_fold. - rewrite spec_eqb, H. rewrite spec_0. simpl. exact spec_0. - Qed. - - Lemma head0_zdigits : forall n (x : dom_t n), - 0 < ZnZ.to_Z x -> - ZnZ.to_Z (ZnZ.head0 x) < ZnZ.to_Z (ZnZ.zdigits (dom_op n)). - Proof. - intros n x H. - destruct (ZnZ.spec_head0 x H) as (_,H0). - intros. - assert (H1 := ZnZ.spec_to_Z (ZnZ.head0 x)). - assert (H2 := ZnZ.spec_to_Z (ZnZ.zdigits (dom_op n))). - unfold base in *. - rewrite ZnZ.spec_zdigits in H2 |- *. - set (h := ZnZ.to_Z (ZnZ.head0 x)) in *; clearbody h. - set (d := ZnZ.digits (dom_op n)) in *; clearbody d. - destruct (Z_lt_le_dec h (Zpos d)); auto. exfalso. - assert (1 * 2^Zpos d <= ZnZ.to_Z x * 2^h). - apply Z.mul_le_mono_nonneg; auto with zarith. - apply Z.pow_le_mono_r; auto with zarith. - rewrite Z.mul_comm in H0. auto with zarith. - Qed. - - Lemma spec_log2_pos : forall x, [x]<>0 -> - 2^[log2 x] <= [x] < 2^([log2 x]+1). - Proof. - intros x H. rewrite log2_fold. - rewrite spec_eqb. rewrite spec_0. - case Z.eqb_spec. - auto with zarith. - clear H. - destr_t x as (n,x). intros H. - rewrite ZnZ.spec_sub_carry. - assert (H0 := ZnZ.spec_to_Z x). - assert (H1 := ZnZ.spec_to_Z (ZnZ.head0 x)). - assert (H2 := ZnZ.spec_to_Z (ZnZ.zdigits (dom_op n))). - assert (H3 := head0_zdigits n x). - rewrite Zmod_small by auto with zarith. - rewrite Z.sub_simpl_r. - rewrite (Z.mul_lt_mono_pos_l (2^(ZnZ.to_Z (ZnZ.head0 x)))); - auto with zarith. - rewrite (Z.mul_le_mono_pos_l _ _ (2^(ZnZ.to_Z (ZnZ.head0 x)))); - auto with zarith. - rewrite <- 2 Zpower_exp; auto with zarith. - rewrite !Z.add_sub_assoc, !Z.add_simpl_l. - rewrite ZnZ.spec_zdigits. - rewrite pow2_pos_minus_1 by (red; auto). - apply ZnZ.spec_head0; auto with zarith. - Qed. - - Lemma spec_log2 : forall x, [log2 x] = Z.log2 [x]. - Proof. - intros. destruct (Z_lt_ge_dec 0 [x]). - symmetry. apply Z.log2_unique. apply spec_pos. - apply spec_log2_pos. intro EQ; rewrite EQ in *; auto with zarith. - rewrite spec_log2_0. rewrite Z.log2_nonpos; auto with zarith. - generalize (spec_pos x); auto with zarith. - Qed. - - Lemma log2_digits_head0 : forall x, 0 < [x] -> - [log2 x] = Zpos (digits x) - [head0 x] - 1. - Proof. - intros. rewrite log2_fold. - rewrite spec_eqb. rewrite spec_0. - case Z.eqb_spec. - auto with zarith. - intros _. revert H. rewrite digits_fold, head0_fold. destr_t x as (n,x). - rewrite ZnZ.spec_sub_carry. - intros. - generalize (head0_zdigits n x H). - generalize (ZnZ.spec_to_Z (ZnZ.head0 x)). - generalize (ZnZ.spec_to_Z (ZnZ.zdigits (dom_op n))). - rewrite ZnZ.spec_zdigits. intros. apply Zmod_small. - auto with zarith. - Qed. - - (** * Right shift *) - - Local Notation shiftrn := (fun n => - let op := dom_op n in - let zdigits := ZnZ.zdigits op in - let sub_c := ZnZ.sub_c in - let add_mul_div := ZnZ.add_mul_div in - let zzero := ZnZ.zero in - fun x p => match sub_c zdigits p with - | C0 d => reduce n (add_mul_div d zzero x) - | C1 _ => zero - end). - - Definition shiftr : t -> t -> t := Eval red_t in - same_level shiftrn. - - Lemma shiftr_fold : shiftr = same_level shiftrn. - Proof. red_t; reflexivity. Qed. - - Lemma div_pow2_bound :forall x y z, - 0 <= x -> 0 <= y -> x < z -> 0 <= x / 2 ^ y < z. - Proof. - intros x y z HH HH1 HH2. - split; auto with zarith. - apply Z.le_lt_trans with (2 := HH2); auto with zarith. - apply Zdiv_le_upper_bound; auto with zarith. - pattern x at 1; replace x with (x * 2 ^ 0); auto with zarith. - apply Z.mul_le_mono_nonneg_l; auto. - apply Z.pow_le_mono_r; auto with zarith. - rewrite Z.pow_0_r; ring. - Qed. - - Theorem spec_shiftr_pow2 : forall x n, - [shiftr x n] = [x] / 2 ^ [n]. - Proof. - intros x y. rewrite shiftr_fold. apply spec_same_level. clear x y. - intros n x p. simpl. - assert (Hx := ZnZ.spec_to_Z x). - assert (Hy := ZnZ.spec_to_Z p). - generalize (ZnZ.spec_sub_c (ZnZ.zdigits (dom_op n)) p). - case ZnZ.sub_c; intros d H; unfold interp_carry in *; simpl. - (** Subtraction without underflow : [ p <= digits ] *) - rewrite spec_reduce. - rewrite ZnZ.spec_zdigits in H. - rewrite ZnZ.spec_add_mul_div by auto with zarith. - rewrite ZnZ.spec_0, Z.mul_0_l, Z.add_0_l. - rewrite Zmod_small. - f_equal. f_equal. auto with zarith. - split. auto with zarith. - apply div_pow2_bound; auto with zarith. - (** Subtraction with underflow : [ digits < p ] *) - rewrite ZnZ.spec_0. symmetry. - apply Zdiv_small. - split; auto with zarith. - apply Z.lt_le_trans with (base (ZnZ.digits (dom_op n))); auto with zarith. - unfold base. apply Z.pow_le_mono_r; auto with zarith. - rewrite ZnZ.spec_zdigits in H. - generalize (ZnZ.spec_to_Z d); auto with zarith. - Qed. - - Lemma spec_shiftr: forall x p, [shiftr x p] = Z.shiftr [x] [p]. - Proof. - intros. - now rewrite spec_shiftr_pow2, Z.shiftr_div_pow2 by apply spec_pos. - Qed. - - (** * Left shift *) - - (** First an unsafe version, working correctly only if - the representation is large enough *) - - Local Notation unsafe_shiftln := (fun n => - let op := dom_op n in - let add_mul_div := ZnZ.add_mul_div in - let zero := ZnZ.zero in - fun x p => reduce n (add_mul_div p x zero)). - - Definition unsafe_shiftl : t -> t -> t := Eval red_t in - same_level unsafe_shiftln. - - Lemma unsafe_shiftl_fold : unsafe_shiftl = same_level unsafe_shiftln. - Proof. red_t; reflexivity. Qed. - - Theorem spec_unsafe_shiftl_aux : forall x p K, - 0 <= K -> - [x] < 2^K -> - [p] + K <= Zpos (digits x) -> - [unsafe_shiftl x p] = [x] * 2 ^ [p]. - Proof. - intros x p. - rewrite unsafe_shiftl_fold. rewrite digits_level. - apply spec_same_level_dep. - intros n m z z' r LE H K HK H1 H2. apply (H K); auto. - transitivity (Zpos (ZnZ.digits (dom_op n))); auto. - apply digits_dom_op_incr; auto. - clear x p. - intros n x p K HK Hx Hp. simpl. rewrite spec_reduce. - destruct (ZnZ.spec_to_Z x). - destruct (ZnZ.spec_to_Z p). - rewrite ZnZ.spec_add_mul_div by (omega with *). - rewrite ZnZ.spec_0, Zdiv_0_l, Z.add_0_r. - apply Zmod_small. unfold base. - split; auto with zarith. - rewrite Z.mul_comm. - apply Z.lt_le_trans with (2^(ZnZ.to_Z p + K)). - rewrite Zpower_exp; auto with zarith. - apply Z.mul_lt_mono_pos_l; auto with zarith. - apply Z.pow_le_mono_r; auto with zarith. - Qed. - - Theorem spec_unsafe_shiftl: forall x p, - [p] <= [head0 x] -> [unsafe_shiftl x p] = [x] * 2 ^ [p]. - Proof. - intros. - destruct (Z.eq_dec [x] 0) as [EQ|NEQ]. - (* [x] = 0 *) - apply spec_unsafe_shiftl_aux with 0; auto with zarith. - now rewrite EQ. - rewrite spec_head00 in *; auto with zarith. - (* [x] <> 0 *) - apply spec_unsafe_shiftl_aux with ([log2 x] + 1); auto with zarith. - generalize (spec_pos (log2 x)); auto with zarith. - destruct (spec_log2_pos x); auto with zarith. - rewrite log2_digits_head0; auto with zarith. - generalize (spec_pos x); auto with zarith. - Qed. - - (** Then we define a function doubling the size of the representation - but without changing the value of the number. *) - - Local Notation double_size_n := (fun n => - let zero := ZnZ.zero in - fun x => mk_t_S n (WW zero x)). - - Definition double_size : t -> t := Eval red_t in - iter_t double_size_n. - - Lemma double_size_fold : double_size = iter_t double_size_n. - Proof. red_t; reflexivity. Qed. - - Lemma double_size_level : forall x, level (double_size x) = S (level x). - Proof. - intros x. rewrite double_size_fold; unfold level at 2. destr_t x as (n,x). - apply mk_t_S_level. - Qed. - - Theorem spec_double_size_digits: - forall x, Zpos (digits (double_size x)) = 2 * (Zpos (digits x)). - Proof. - intros x. rewrite ! digits_level, double_size_level. - rewrite 2 digits_dom_op, 2 Pshiftl_nat_Zpower, - Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith. - ring. - Qed. - - Theorem spec_double_size: forall x, [double_size x] = [x]. - Proof. - intros x. rewrite double_size_fold. destr_t x as (n,x). - rewrite spec_mk_t_S. simpl. rewrite ZnZ.spec_0. auto with zarith. - Qed. - - Theorem spec_double_size_head0: - forall x, 2 * [head0 x] <= [head0 (double_size x)]. - Proof. - intros x. - assert (F1:= spec_pos (head0 x)). - assert (F2: 0 < Zpos (digits x)). - red; auto. - assert (HH := spec_pos x). Z.le_elim HH. - generalize HH; rewrite <- (spec_double_size x); intros HH1. - case (spec_head0 x HH); intros _ HH2. - case (spec_head0 _ HH1). - rewrite (spec_double_size x); rewrite (spec_double_size_digits x). - intros HH3 _. - case (Z.le_gt_cases ([head0 (double_size x)]) (2 * [head0 x])); auto; intros HH4. - absurd (2 ^ (2 * [head0 x] )* [x] < 2 ^ [head0 (double_size x)] * [x]); auto. - apply Z.le_ngt. - apply Z.mul_le_mono_nonneg_r; auto with zarith. - apply Z.pow_le_mono_r; auto; auto with zarith. - assert (HH5: 2 ^[head0 x] <= 2 ^(Zpos (digits x) - 1)). - { apply Z.le_succ_l in HH. change (1 <= [x]) in HH. - Z.le_elim HH. - - apply Z.mul_le_mono_pos_r with (2 ^ 1); auto with zarith. - rewrite <- (fun x y z => Z.pow_add_r x (y - z)); auto with zarith. - rewrite Z.sub_add. - apply Z.le_trans with (2 := Z.lt_le_incl _ _ HH2). - apply Z.mul_le_mono_nonneg_l; auto with zarith. - rewrite Z.pow_1_r; auto with zarith. - - apply Z.pow_le_mono_r; auto with zarith. - case (Z.le_gt_cases (Zpos (digits x)) [head0 x]); auto with zarith; intros HH6. - absurd (2 ^ Zpos (digits x) <= 2 ^ [head0 x] * [x]); auto with zarith. - rewrite <- HH; rewrite Z.mul_1_r. - apply Z.pow_le_mono_r; auto with zarith. } - rewrite (Z.mul_comm 2). - rewrite Z.pow_mul_r; auto with zarith. - rewrite Z.pow_2_r. - apply Z.lt_le_trans with (2 := HH3). - rewrite <- Z.mul_assoc. - replace (2 * Zpos (digits x) - 1) with - ((Zpos (digits x) - 1) + (Zpos (digits x))). - rewrite Zpower_exp; auto with zarith. - apply Zmult_lt_compat2; auto with zarith. - split; auto with zarith. - apply Z.mul_pos_pos; auto with zarith. - rewrite Pos2Z.inj_xO; ring. - apply Z.lt_le_incl; auto. - repeat rewrite spec_head00; auto. - rewrite spec_double_size_digits. - rewrite Pos2Z.inj_xO; auto with zarith. - rewrite spec_double_size; auto. - Qed. - - Theorem spec_double_size_head0_pos: - forall x, 0 < [head0 (double_size x)]. - Proof. - intros x. - assert (F := Pos2Z.is_pos (digits x)). - assert (F0 := spec_pos (head0 (double_size x))). - Z.le_elim F0; auto. - assert (F1 := spec_pos (head0 x)). - Z.le_elim F1. - apply Z.lt_le_trans with (2 := (spec_double_size_head0 x)); auto with zarith. - assert (F3 := spec_pos x). - Z.le_elim F3. - generalize F3; rewrite <- (spec_double_size x); intros F4. - absurd (2 ^ (Zpos (xO (digits x)) - 1) < 2 ^ (Zpos (digits x))). - { apply Z.le_ngt. - apply Z.pow_le_mono_r; auto with zarith. - rewrite Pos2Z.inj_xO; auto with zarith. } - case (spec_head0 x F3). - rewrite <- F1; rewrite Z.pow_0_r; rewrite Z.mul_1_l; intros _ HH. - apply Z.le_lt_trans with (2 := HH). - case (spec_head0 _ F4). - rewrite (spec_double_size x); rewrite (spec_double_size_digits x). - rewrite <- F0; rewrite Z.pow_0_r; rewrite Z.mul_1_l; auto. - generalize F1; rewrite (spec_head00 _ (eq_sym F3)); auto with zarith. - Qed. - - (** Finally we iterate [double_size] enough before [unsafe_shiftl] - in order to get a fully correct [shiftl]. *) - - Definition shiftl_aux_body cont x n := - match compare n (head0 x) with - Gt => cont (double_size x) n - | _ => unsafe_shiftl x n - end. - - Theorem spec_shiftl_aux_body: forall n x p cont, - 2^ Zpos p <= [head0 x] -> - (forall x, 2 ^ (Zpos p + 1) <= [head0 x]-> - [cont x n] = [x] * 2 ^ [n]) -> - [shiftl_aux_body cont x n] = [x] * 2 ^ [n]. - Proof. - intros n x p cont H1 H2; unfold shiftl_aux_body. - rewrite spec_compare; case Z.compare_spec; intros H. - apply spec_unsafe_shiftl; auto with zarith. - apply spec_unsafe_shiftl; auto with zarith. - rewrite H2. - rewrite spec_double_size; auto. - rewrite Z.add_comm; rewrite Zpower_exp; auto with zarith. - apply Z.le_trans with (2 := spec_double_size_head0 x). - rewrite Z.pow_1_r; apply Z.mul_le_mono_nonneg_l; auto with zarith. - Qed. - - Fixpoint shiftl_aux p cont x n := - shiftl_aux_body - (fun x n => match p with - | xH => cont x n - | xO p => shiftl_aux p (shiftl_aux p cont) x n - | xI p => shiftl_aux p (shiftl_aux p cont) x n - end) x n. - - Theorem spec_shiftl_aux: forall p q x n cont, - 2 ^ (Zpos q) <= [head0 x] -> - (forall x, 2 ^ (Zpos p + Zpos q) <= [head0 x] -> - [cont x n] = [x] * 2 ^ [n]) -> - [shiftl_aux p cont x n] = [x] * 2 ^ [n]. - Proof. - intros p; elim p; unfold shiftl_aux; fold shiftl_aux; clear p. - intros p Hrec q x n cont H1 H2. - apply spec_shiftl_aux_body with (q); auto. - intros x1 H3; apply Hrec with (q + 1)%positive; auto. - intros x2 H4; apply Hrec with (p + q + 1)%positive; auto. - rewrite <- Pos.add_assoc. - rewrite Pos2Z.inj_add; auto. - intros x3 H5; apply H2. - rewrite Pos2Z.inj_xI. - replace (2 * Zpos p + 1 + Zpos q) with (Zpos p + Zpos (p + q + 1)); - auto. - rewrite !Pos2Z.inj_add; ring. - intros p Hrec q n x cont H1 H2. - apply spec_shiftl_aux_body with (q); auto. - intros x1 H3; apply Hrec with (q); auto. - apply Z.le_trans with (2 := H3); auto with zarith. - apply Z.pow_le_mono_r; auto with zarith. - intros x2 H4; apply Hrec with (p + q)%positive; auto. - intros x3 H5; apply H2. - rewrite (Pos2Z.inj_xO p). - replace (2 * Zpos p + Zpos q) with (Zpos p + Zpos (p + q)); - auto. - rewrite Pos2Z.inj_add; ring. - intros q n x cont H1 H2. - apply spec_shiftl_aux_body with (q); auto. - rewrite Z.add_comm; auto. - Qed. - - Definition shiftl x n := - shiftl_aux_body - (shiftl_aux_body - (shiftl_aux (digits n) unsafe_shiftl)) x n. - - Theorem spec_shiftl_pow2 : forall x n, - [shiftl x n] = [x] * 2 ^ [n]. - Proof. - intros x n; unfold shiftl, shiftl_aux_body. - rewrite spec_compare; case Z.compare_spec; intros H. - apply spec_unsafe_shiftl; auto with zarith. - apply spec_unsafe_shiftl; auto with zarith. - rewrite <- (spec_double_size x). - rewrite spec_compare; case Z.compare_spec; intros H1. - apply spec_unsafe_shiftl; auto with zarith. - apply spec_unsafe_shiftl; auto with zarith. - rewrite <- (spec_double_size (double_size x)). - apply spec_shiftl_aux with 1%positive. - apply Z.le_trans with (2 := spec_double_size_head0 (double_size x)). - replace (2 ^ 1) with (2 * 1). - apply Z.mul_le_mono_nonneg_l; auto with zarith. - generalize (spec_double_size_head0_pos x); auto with zarith. - rewrite Z.pow_1_r; ring. - intros x1 H2; apply spec_unsafe_shiftl. - apply Z.le_trans with (2 := H2). - apply Z.le_trans with (2 ^ Zpos (digits n)); auto with zarith. - case (spec_digits n); auto with zarith. - apply Z.pow_le_mono_r; auto with zarith. - Qed. - - Lemma spec_shiftl: forall x p, [shiftl x p] = Z.shiftl [x] [p]. - Proof. - intros. - now rewrite spec_shiftl_pow2, Z.shiftl_mul_pow2 by apply spec_pos. - Qed. - - (** Other bitwise operations *) - - Definition testbit x n := odd (shiftr x n). - - Lemma spec_testbit: forall x p, testbit x p = Z.testbit [x] [p]. - Proof. - intros. unfold testbit. symmetry. - rewrite spec_odd, spec_shiftr. apply Z.testbit_odd. - Qed. - - Definition div2 x := shiftr x one. - - Lemma spec_div2: forall x, [div2 x] = Z.div2 [x]. - Proof. - intros. unfold div2. symmetry. - rewrite spec_shiftr, spec_1. apply Z.div2_spec. - Qed. - - Local Notation lorn := (fun n => - let op := dom_op n in - let lor := ZnZ.lor in - fun x y => reduce n (lor x y)). - - Definition lor : t -> t -> t := Eval red_t in same_level lorn. - - Lemma lor_fold : lor = same_level lorn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_lor x y : [lor x y] = Z.lor [x] [y]. - Proof. - rewrite lor_fold. apply spec_same_level; clear x y. - intros n x y. simpl. rewrite spec_reduce. apply ZnZ.spec_lor. - Qed. - - Local Notation landn := (fun n => - let op := dom_op n in - let land := ZnZ.land in - fun x y => reduce n (land x y)). - - Definition land : t -> t -> t := Eval red_t in same_level landn. - - Lemma land_fold : land = same_level landn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_land x y : [land x y] = Z.land [x] [y]. - Proof. - rewrite land_fold. apply spec_same_level; clear x y. - intros n x y. simpl. rewrite spec_reduce. apply ZnZ.spec_land. - Qed. - - Local Notation lxorn := (fun n => - let op := dom_op n in - let lxor := ZnZ.lxor in - fun x y => reduce n (lxor x y)). - - Definition lxor : t -> t -> t := Eval red_t in same_level lxorn. - - Lemma lxor_fold : lxor = same_level lxorn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_lxor x y : [lxor x y] = Z.lxor [x] [y]. - Proof. - rewrite lxor_fold. apply spec_same_level; clear x y. - intros n x y. simpl. rewrite spec_reduce. apply ZnZ.spec_lxor. - Qed. - - Local Notation ldiffn := (fun n => - let op := dom_op n in - let lxor := ZnZ.lxor in - let land := ZnZ.land in - let m1 := ZnZ.minus_one in - fun x y => reduce n (land x (lxor y m1))). - - Definition ldiff : t -> t -> t := Eval red_t in same_level ldiffn. - - Lemma ldiff_fold : ldiff = same_level ldiffn. - Proof. red_t; reflexivity. Qed. - - Lemma ldiff_alt x y p : - 0 <= x < 2^p -> 0 <= y < 2^p -> - Z.ldiff x y = Z.land x (Z.lxor y (2^p - 1)). - Proof. - intros (Hx,Hx') (Hy,Hy'). - destruct p as [|p|p]. - - simpl in *; replace x with 0; replace y with 0; auto with zarith. - - rewrite <- Z.shiftl_1_l. change (_ - 1) with (Z.ones (Z.pos p)). - rewrite <- Z.ldiff_ones_l_low; trivial. - rewrite !Z.ldiff_land, Z.land_assoc. f_equal. - rewrite Z.land_ones; try easy. - symmetry. apply Z.mod_small; now split. - Z.le_elim Hy. - + now apply Z.log2_lt_pow2. - + now subst. - - simpl in *; omega. - Qed. - - Theorem spec_ldiff x y : [ldiff x y] = Z.ldiff [x] [y]. - Proof. - rewrite ldiff_fold. apply spec_same_level; clear x y. - intros n x y. simpl. rewrite spec_reduce. - rewrite ZnZ.spec_land, ZnZ.spec_lxor, ZnZ.spec_m1. - symmetry. apply ldiff_alt; apply ZnZ.spec_to_Z. - Qed. - -End Make. diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml deleted file mode 100644 index 5177fae6..00000000 --- a/theories/Numbers/Natural/BigN/NMake_gen.ml +++ /dev/null @@ -1,1017 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Z/2nZ - process before relying on a generic construct *) - -(*s Some utilities *) - -let rec iter_str n s = if n = 0 then "" else (iter_str (n-1) s) ^ s - -let rec iter_str_gen n f = if n < 0 then "" else (iter_str_gen (n-1) f) ^ (f n) - -let rec iter_name i j base sep = - if i >= j then base^(string_of_int i) - else (iter_name i (j-1) base sep)^sep^" "^base^(string_of_int j) - -let pr s = Printf.printf (s^^"\n") - -(*s The actual printing *) - -let _ = - -pr -"(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ZnZ.Ops (zn2z w')."; - pr ""; - pr " Fixpoint make_op_aux (n:nat) : ZnZ.Ops (word w%i (S n)):=" size; - pr " match n return ZnZ.Ops (word w%i (S n)) with" size; - pr " | O => w%i_op" (size+1); - pr " | S n1 =>"; - pr " match n1 return ZnZ.Ops (word w%i (S (S n1))) with" size; - pr " | O => w%i_op" (size+2); - pr " | S n2 =>"; - pr " match n2 return ZnZ.Ops (word w%i (S (S (S n2)))) with" size; - pr " | O => w%i_op" (size+3); - pr " | S n3 => mk _ (mk _ (mk _ (make_op_aux n3)))"; - pr " end"; - pr " end"; - pr " end."; - pr ""; - pr " End Make_op."; - pr ""; - pr " Definition omake_op := make_op_aux mk_zn2z_ops_karatsuba."; - pr ""; - pr ""; - pr " Definition make_op_list := dmemo_list _ omake_op."; - pr ""; - pr " Instance make_op n : ZnZ.Ops (word w%i (S n))" size; - pr " := dmemo_get _ omake_op n make_op_list."; - pr ""; - -pr " Ltac unfold_ops := unfold omake_op, make_op_aux, w%i_op, w%i_op." (size+3) (size+2); - -pr -" - Lemma make_op_omake: forall n, make_op n = omake_op n. - Proof. - intros n; unfold make_op, make_op_list. - refine (dmemo_get_correct _ _ _). - Qed. - - Theorem make_op_S: forall n, - make_op (S n) = mk_zn2z_ops_karatsuba (make_op n). - Proof. - intros n. do 2 rewrite make_op_omake. - revert n. fix IHn 1. - do 3 (destruct n; [unfold_ops; reflexivity|]). - simpl mk_zn2z_ops_karatsuba. simpl word in *. - rewrite <- (IHn n). auto. - Qed. - - (** * The main type [t], isomorphic with [exists n, word w0 n] *) -"; - - pr " Inductive t' :="; - for i = 0 to size do - pr " | N%i : w%i -> t'" i i - done; - pr " | Nn : forall n, word w%i (S n) -> t'." size; - pr ""; - pr " Definition t := t'."; - pr ""; - - pr " (** * A generic toolbox for building and deconstructing [t] *)"; - pr ""; - - pr " Local Notation SizePlus n := %sn%s." - (iter_str size "(S ") (iter_str size ")"); - pr " Local Notation Size := (SizePlus O)."; - pr ""; - - pr " Tactic Notation (at level 3) \"do_size\" tactic3(t) := do %i t." (size+1); - pr ""; - - pr " Definition dom_t n := match n with"; - for i = 0 to size do - pr " | %i => w%i" i i; - done; - pr " | %sn => word w%i n" (if size=0 then "" else "SizePlus ") size; - pr " end."; - pr ""; - -pr -" Instance dom_op n : ZnZ.Ops (dom_t n) | 10. - Proof. - do_size (destruct n; [simpl;auto with *|]). - unfold dom_t. auto with *. - Defined. -"; - - pr " Definition iter_t {A:Type}(f : forall n, dom_t n -> A) : t -> A :="; - for i = 0 to size do - pr " let f%i := f %i in" i i; - done; - pr " let fn n := f (SizePlus (S n)) in"; - pr " fun x => match x with"; - for i = 0 to size do - pr " | N%i wx => f%i wx" i i; - done; - pr " | Nn n wx => fn n wx"; - pr " end."; - pr ""; - - pr " Definition mk_t (n:nat) : dom_t n -> t :="; - pr " match n as n' return dom_t n' -> t with"; - for i = 0 to size do - pr " | %i => N%i" i i; - done; - pr " | %s(S n) => Nn n" (if size=0 then "" else "SizePlus "); - pr " end."; - pr ""; - -pr -" Definition level := iter_t (fun n _ => n). - - Inductive View_t : t -> Prop := - Mk_t : forall n (x : dom_t n), View_t (mk_t n x). - - Lemma destr_t : forall x, View_t x. - Proof. - intros x. generalize (Mk_t (level x)). destruct x; simpl; auto. - Defined. - - Lemma iter_mk_t : forall A (f:forall n, dom_t n -> A), - forall n x, iter_t f (mk_t n x) = f n x. - Proof. - do_size (destruct n; try reflexivity). - Qed. - - (** * Projection to ZArith *) - - Definition to_Z : t -> Z := - Eval lazy beta iota delta [iter_t dom_t dom_op] in - iter_t (fun _ x => ZnZ.to_Z x). - - Notation \"[ x ]\" := (to_Z x). - - Theorem spec_mk_t : forall n (x:dom_t n), [mk_t n x] = ZnZ.to_Z x. - Proof. - intros. change to_Z with (iter_t (fun _ x => ZnZ.to_Z x)). - rewrite iter_mk_t; auto. - Qed. - - (** * Regular make op, without memoization or karatsuba - - This will normally never be used for actual computations, - but only for specification purpose when using - [word (dom_t n) m] intermediate values. *) - - Fixpoint nmake_op (ww:Type) (ww_op: ZnZ.Ops ww) (n: nat) : - ZnZ.Ops (word ww n) := - match n return ZnZ.Ops (word ww n) with - O => ww_op - | S n1 => mk_zn2z_ops (nmake_op ww ww_op n1) - end. - - Definition eval n m := ZnZ.to_Z (Ops:=nmake_op _ (dom_op n) m). - - Theorem nmake_op_S: forall ww (w_op: ZnZ.Ops ww) x, - nmake_op _ w_op (S x) = mk_zn2z_ops (nmake_op _ w_op x). - Proof. - auto. - Qed. - - Theorem digits_nmake_S :forall n ww (w_op: ZnZ.Ops ww), - ZnZ.digits (nmake_op _ w_op (S n)) = - xO (ZnZ.digits (nmake_op _ w_op n)). - Proof. - auto. - Qed. - - Theorem digits_nmake : forall n ww (w_op: ZnZ.Ops ww), - ZnZ.digits (nmake_op _ w_op n) = Pos.shiftl_nat (ZnZ.digits w_op) n. - Proof. - induction n. auto. - intros ww ww_op. rewrite Pshiftl_nat_S, <- IHn; auto. - Qed. - - Theorem nmake_double: forall n ww (w_op: ZnZ.Ops ww), - ZnZ.to_Z (Ops:=nmake_op _ w_op n) = - @DoubleBase.double_to_Z _ (ZnZ.digits w_op) (ZnZ.to_Z (Ops:=w_op)) n. - Proof. - intros n; elim n; auto; clear n. - intros n Hrec ww ww_op; simpl DoubleBase.double_to_Z; unfold zn2z_to_Z. - rewrite <- Hrec; auto. - unfold DoubleBase.double_wB; rewrite <- digits_nmake; auto. - Qed. - - Theorem nmake_WW: forall ww ww_op n xh xl, - (ZnZ.to_Z (Ops:=nmake_op ww ww_op (S n)) (WW xh xl) = - ZnZ.to_Z (Ops:=nmake_op ww ww_op n) xh * - base (ZnZ.digits (nmake_op ww ww_op n)) + - ZnZ.to_Z (Ops:=nmake_op ww ww_op n) xl)%%Z. - Proof. - auto. - Qed. - - (** * The specification proofs for the word operators *) -"; - - if size <> 0 then - pr " Typeclasses Opaque %s." (iter_name 1 size "w" ""); - pr ""; - - pr " Instance w0_spec: ZnZ.Specs w0_op := W0.specs."; - for i = 1 to min 3 size do - pr " Instance w%i_spec: ZnZ.Specs w%i_op := mk_zn2z_specs w%i_spec." i i (i-1) - done; - for i = 4 to size do - pr " Instance w%i_spec: ZnZ.Specs w%i_op := mk_zn2z_specs_karatsuba w%i_spec." i i (i-1) - done; - pr " Instance w%i_spec: ZnZ.Specs w%i_op := mk_zn2z_specs_karatsuba w%i_spec." (size+1) (size+1) size; - - -pr " - Instance wn_spec (n:nat) : ZnZ.Specs (make_op n). - Proof. - induction n. - rewrite make_op_omake; simpl; auto with *. - rewrite make_op_S. exact (mk_zn2z_specs_karatsuba IHn). - Qed. - - Instance dom_spec n : ZnZ.Specs (dom_op n) | 10. - Proof. - do_size (destruct n; auto with *). apply wn_spec. - Qed. - - Let make_op_WW : forall n x y, - (ZnZ.to_Z (Ops:=make_op (S n)) (WW x y) = - ZnZ.to_Z (Ops:=make_op n) x * base (ZnZ.digits (make_op n)) - + ZnZ.to_Z (Ops:=make_op n) y)%%Z. - Proof. - intros n x y; rewrite make_op_S; auto. - Qed. - - (** * Zero *) - - Definition zero0 : w0 := ZnZ.zero. - - Definition zeron n : dom_t n := - match n with - | O => zero0 - | SizePlus (S n) => W0 - | _ => W0 - end. - - Lemma spec_zeron : forall n, ZnZ.to_Z (zeron n) = 0%%Z. - Proof. - do_size (destruct n; - [match goal with - |- @eq Z (_ (zeron ?n)) _ => - apply (ZnZ.spec_0 (Specs:=dom_spec n)) - end|]). - destruct n; auto. simpl. rewrite make_op_S. fold word. - apply (ZnZ.spec_0 (Specs:=wn_spec (SizePlus 0))). - Qed. - - (** * Digits *) - - Lemma digits_make_op_0 : forall n, - ZnZ.digits (make_op n) = Pos.shiftl_nat (ZnZ.digits (dom_op Size)) (S n). - Proof. - induction n. - auto. - replace (ZnZ.digits (make_op (S n))) with (xO (ZnZ.digits (make_op n))). - rewrite IHn; auto. - rewrite make_op_S; auto. - Qed. - - Lemma digits_make_op : forall n, - ZnZ.digits (make_op n) = Pos.shiftl_nat (ZnZ.digits w0_op) (SizePlus (S n)). - Proof. - intros. rewrite digits_make_op_0. - replace (SizePlus (S n)) with (S n + Size) by (rewrite <- plus_comm; auto). - rewrite Pshiftl_nat_plus. auto. - Qed. - - Lemma digits_dom_op : forall n, - ZnZ.digits (dom_op n) = Pos.shiftl_nat (ZnZ.digits w0_op) n. - Proof. - do_size (destruct n; try reflexivity). - exact (digits_make_op n). - Qed. - - Lemma digits_dom_op_nmake : forall n m, - ZnZ.digits (dom_op (m+n)) = ZnZ.digits (nmake_op _ (dom_op n) m). - Proof. - intros. rewrite digits_nmake, 2 digits_dom_op. apply Pshiftl_nat_plus. - Qed. - - (** * Conversion between [zn2z (dom_t n)] and [dom_t (S n)]. - - These two types are provably equal, but not convertible, - hence we need some work. We now avoid using generic casts - (i.e. rewrite via proof of equalities in types), since - proving things with them is a mess. - *) - - Definition succ_t n : zn2z (dom_t n) -> dom_t (S n) := - match n with - | SizePlus (S _) => fun x => x - | _ => fun x => x - end. - - Lemma spec_succ_t : forall n x, - ZnZ.to_Z (succ_t n x) = - zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x. - Proof. - do_size (destruct n ; [reflexivity|]). - intros. simpl. rewrite make_op_S. simpl. auto. - Qed. - - Definition pred_t n : dom_t (S n) -> zn2z (dom_t n) := - match n with - | SizePlus (S _) => fun x => x - | _ => fun x => x - end. - - Lemma succ_pred_t : forall n x, succ_t n (pred_t n x) = x. - Proof. - do_size (destruct n ; [reflexivity|]). reflexivity. - Qed. - - (** We can hence project from [zn2z (dom_t n)] to [t] : *) - - Definition mk_t_S n (x : zn2z (dom_t n)) : t := - mk_t (S n) (succ_t n x). - - Lemma spec_mk_t_S : forall n x, - [mk_t_S n x] = zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x. - Proof. - intros. unfold mk_t_S. rewrite spec_mk_t. apply spec_succ_t. - Qed. - - Lemma mk_t_S_level : forall n x, level (mk_t_S n x) = S n. - Proof. - intros. unfold mk_t_S, level. rewrite iter_mk_t; auto. - Qed. - - (** * Conversion from [word (dom_t n) m] to [dom_t (m+n)]. - - Things are more complex here. We start with a naive version - that breaks zn2z-trees and reconstruct them. Doing this is - quite unfortunate, but I don't know how to fully avoid that. - (cast someday ?). Then we build an optimized version where - all basic cases (n<=6 or m<=7) are nicely handled. - *) - - Definition zn2z_map {A} {B} (f:A->B) (x:zn2z A) : zn2z B := - match x with - | W0 => W0 - | WW h l => WW (f h) (f l) - end. - - Lemma zn2z_map_id : forall A f (x:zn2z A), (forall u, f u = u) -> - zn2z_map f x = x. - Proof. - destruct x; auto; intros. - simpl; f_equal; auto. - Qed. - - (** The naive version *) - - Fixpoint plus_t n m : word (dom_t n) m -> dom_t (m+n) := - match m as m' return word (dom_t n) m' -> dom_t (m'+n) with - | O => fun x => x - | S m => fun x => succ_t _ (zn2z_map (plus_t n m) x) - end. - - Theorem spec_plus_t : forall n m (x:word (dom_t n) m), - ZnZ.to_Z (plus_t n m x) = eval n m x. - Proof. - unfold eval. - induction m. - simpl; auto. - intros. - simpl plus_t; simpl plus. rewrite spec_succ_t. - destruct x. - simpl; auto. - fold word in w, w0. - simpl. rewrite 2 IHm. f_equal. f_equal. f_equal. - apply digits_dom_op_nmake. - Qed. - - Definition mk_t_w n m (x:word (dom_t n) m) : t := - mk_t (m+n) (plus_t n m x). - - Theorem spec_mk_t_w : forall n m (x:word (dom_t n) m), - [mk_t_w n m x] = eval n m x. - Proof. - intros. unfold mk_t_w. rewrite spec_mk_t. apply spec_plus_t. - Qed. - - (** The optimized version. - - NB: the last particular case for m could depend on n, - but it's simplier to just expand everywhere up to m=7 - (cf [mk_t_w'] later). - *) - - Definition plus_t' n : forall m, word (dom_t n) m -> dom_t (m+n) := - match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with - | SizePlus (S n') as n => plus_t n - | _ as n => - fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with - | SizePlus (S (S m')) as m => plus_t n m - | _ => fun x => x - end - end. - - Lemma plus_t_equiv : forall n m x, - plus_t' n m x = plus_t n m x. - Proof. - (do_size try destruct n); try reflexivity; - (do_size try destruct m); try destruct m; try reflexivity; - simpl; symmetry; repeat (intros; apply zn2z_map_id; trivial). - Qed. - - Lemma spec_plus_t' : forall n m x, - ZnZ.to_Z (plus_t' n m x) = eval n m x. - Proof. - intros; rewrite plus_t_equiv. apply spec_plus_t. - Qed. - - (** Particular cases [Nk x] = eval i j x with specific k,i,j - can be solved by the following tactic *) - - Ltac solve_eval := - intros; rewrite <- spec_plus_t'; unfold to_Z; simpl dom_op; reflexivity. - - (** The last particular case that remains useful *) - - Lemma spec_eval_size : forall n x, [Nn n x] = eval Size (S n) x. - Proof. - induction n. - solve_eval. - destruct x as [ | xh xl ]. - simpl. unfold eval. rewrite make_op_S. rewrite nmake_op_S. auto. - simpl word in xh, xl |- *. - unfold to_Z in *. rewrite make_op_WW. - unfold eval in *. rewrite nmake_WW. - f_equal; auto. - f_equal; auto. - f_equal. - rewrite <- digits_dom_op_nmake. rewrite plus_comm; auto. - Qed. - - (** An optimized [mk_t_w]. - - We could say mk_t_w' := mk_t _ (plus_t' n m x) - (TODO: WHY NOT, BTW ??). - Instead we directly define functions for all intersting [n], - reverting to naive [mk_t_w] at places that should normally - never be used (see [mul] and [div_gt]). - *) -"; - -for i = 0 to size-1 do -let pattern = (iter_str (size+1-i) "(S ") ^ "_" ^ (iter_str (size+1-i) ")") in -pr -" Definition mk_t_%iw m := Eval cbv beta zeta iota delta [ mk_t plus ] in - match m return word w%i (S m) -> t with - | %s as p => mk_t_w %i (S p) - | p => mk_t (%i+p) - end. -" i i pattern i (i+1) -done; - -pr -" Definition mk_t_w' n : forall m, word (dom_t n) (S m) -> t := - match n return (forall m, word (dom_t n) (S m) -> t) with"; -for i = 0 to size-1 do pr " | %i => mk_t_%iw" i i done; -pr -" | Size => Nn - | _ as n' => fun m => mk_t_w n' (S m) - end. -"; - -pr -" Ltac solve_spec_mk_t_w' := - rewrite <- spec_plus_t'; - match goal with _ : word (dom_t ?n) ?m |- _ => apply (spec_mk_t (n+m)) end. - - Theorem spec_mk_t_w' : - forall n m x, [mk_t_w' n m x] = eval n (S m) x. - Proof. - intros. - repeat (apply spec_mk_t_w || (destruct n; - [repeat (apply spec_mk_t_w || (destruct m; [solve_spec_mk_t_w'|]))|])). - apply spec_eval_size. - Qed. - - (** * Extend : injecting [dom_t n] into [word (dom_t n) (S m)] *) - - Definition extend n m (x:dom_t n) : word (dom_t n) (S m) := - DoubleBase.extend_aux m (WW (zeron n) x). - - Lemma spec_extend : forall n m x, - [mk_t n x] = eval n (S m) (extend n m x). - Proof. - intros. unfold eval, extend. - rewrite spec_mk_t. - assert (H : forall (x:dom_t n), - (ZnZ.to_Z (zeron n) * base (ZnZ.digits (dom_op n)) + ZnZ.to_Z x = - ZnZ.to_Z x)%%Z). - clear; intros; rewrite spec_zeron; auto. - rewrite <- (@DoubleBase.spec_extend _ - (WW (zeron n)) (ZnZ.digits (dom_op n)) ZnZ.to_Z H m x). - simpl. rewrite digits_nmake, <- nmake_double. auto. - Qed. - - (** A particular case of extend, used in [same_level]: - [extend_size] is [extend Size] *) - - Definition extend_size := DoubleBase.extend (WW (W0:dom_t Size)). - - Lemma spec_extend_size : forall n x, [mk_t Size x] = [Nn n (extend_size n x)]. - Proof. - intros. rewrite spec_eval_size. apply (spec_extend Size n). - Qed. - - (** Misc results about extensions *) - - Let spec_extend_WW : forall n x, - [Nn (S n) (WW W0 x)] = [Nn n x]. - Proof. - intros n x. - set (N:=SizePlus (S n)). - change ([Nn (S n) (extend N 0 x)]=[mk_t N x]). - rewrite (spec_extend N 0). - solve_eval. - Qed. - - Let spec_extend_tr: forall m n w, - [Nn (m + n) (extend_tr w m)] = [Nn n w]. - Proof. - induction m; auto. - intros n x; simpl extend_tr. - simpl plus; rewrite spec_extend_WW; auto. - Qed. - - Let spec_cast_l: forall n m x1, - [Nn n x1] = - [Nn (Max.max n m) (castm (diff_r n m) (extend_tr x1 (snd (diff n m))))]. - Proof. - intros n m x1; case (diff_r n m); simpl castm. - rewrite spec_extend_tr; auto. - Qed. - - Let spec_cast_r: forall n m x1, - [Nn m x1] = - [Nn (Max.max n m) (castm (diff_l n m) (extend_tr x1 (fst (diff n m))))]. - Proof. - intros n m x1; case (diff_l n m); simpl castm. - rewrite spec_extend_tr; auto. - Qed. - - Ltac unfold_lets := - match goal with - | h : _ |- _ => unfold h; clear h; unfold_lets - | _ => idtac - end. - - (** * [same_level] - - Generic binary operator construction, by extending the smaller - argument to the level of the other. - *) - - Section SameLevel. - - Variable res: Type. - Variable P : Z -> Z -> res -> Prop. - Variable f : forall n, dom_t n -> dom_t n -> res. - Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y). -"; - -for i = 0 to size do -pr " Let f%i : w%i -> w%i -> res := f %i." i i i i -done; -pr -" Let fn n := f (SizePlus (S n)). - - Let Pf' : - forall n x y u v, u = [mk_t n x] -> v = [mk_t n y] -> P u v (f n x y). - Proof. - intros. subst. rewrite 2 spec_mk_t. apply Pf. - Qed. -"; - -let ext i j s = - if j <= i then s else Printf.sprintf "(extend %i %i %s)" i (j-i-1) s -in - -pr " Notation same_level_folded := (fun x y => match x, y with"; -for i = 0 to size do - for j = 0 to size do - pr " | N%i wx, N%i wy => f%i %s %s" i j (max i j) (ext i j "wx") (ext j i "wy") - done; - pr " | N%i wx, Nn m wy => fn m (extend_size m %s) wy" i (ext i size "wx") -done; -for i = 0 to size do - pr " | Nn n wx, N%i wy => fn n wx (extend_size n %s)" i (ext i size "wy") -done; -pr -" | Nn n wx, Nn m wy => - let mn := Max.max n m in - let d := diff n m in - fn mn - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d))) - end). -"; - -pr -" Definition same_level := Eval lazy beta iota delta - [ DoubleBase.extend DoubleBase.extend_aux extend zeron ] - in same_level_folded. - - Lemma spec_same_level_0: forall x y, P [x] [y] (same_level x y). - Proof. - change same_level with same_level_folded. unfold_lets. - destruct x, y; apply Pf'; simpl mk_t; rewrite <- ?spec_extend_size; - match goal with - | |- context [ extend ?n ?m _ ] => apply (spec_extend n m) - | |- context [ castm _ _ ] => apply spec_cast_l || apply spec_cast_r - | _ => reflexivity - end. - Qed. - - End SameLevel. - - Arguments same_level [res] f x y. - - Theorem spec_same_level_dep : - forall res - (P : nat -> Z -> Z -> res -> Prop) - (Pantimon : forall n m z z' r, n <= m -> P m z z' r -> P n z z' r) - (f : forall n, dom_t n -> dom_t n -> res) - (Pf: forall n x y, P n (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)), - forall x y, P (level x) [x] [y] (same_level f x y). - Proof. - intros res P Pantimon f Pf. - set (f' := fun n x y => (n, f n x y)). - set (P' := fun z z' r => P (fst r) z z' (snd r)). - assert (FST : forall x y, level x <= fst (same_level f' x y)) - by (destruct x, y; simpl; omega with * ). - assert (SND : forall x y, same_level f x y = snd (same_level f' x y)) - by (destruct x, y; reflexivity). - intros. eapply Pantimon; [eapply FST|]. - rewrite SND. eapply (@spec_same_level_0 _ P' f'); eauto. - Qed. - - (** * [iter] - - Generic binary operator construction, by splitting the larger - argument in blocks and applying the smaller argument to them. - *) - - Section Iter. - - Variable res: Type. - Variable P: Z -> Z -> res -> Prop. - - Variable f : forall n, dom_t n -> dom_t n -> res. - Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y). - - Variable fd : forall n m, dom_t n -> word (dom_t n) (S m) -> res. - Variable fg : forall n m, word (dom_t n) (S m) -> dom_t n -> res. - Variable Pfd : forall n m x y, P (ZnZ.to_Z x) (eval n (S m) y) (fd n m x y). - Variable Pfg : forall n m x y, P (eval n (S m) x) (ZnZ.to_Z y) (fg n m x y). - - Variable fnm: forall n m, word (dom_t Size) (S n) -> word (dom_t Size) (S m) -> res. - Variable Pfnm: forall n m x y, P [Nn n x] [Nn m y] (fnm n m x y). - - Let Pf' : - forall n x y u v, u = [mk_t n x] -> v = [mk_t n y] -> P u v (f n x y). - Proof. - intros. subst. rewrite 2 spec_mk_t. apply Pf. - Qed. - - Let Pfd' : forall n m x y u v, u = [mk_t n x] -> v = eval n (S m) y -> - P u v (fd n m x y). - Proof. - intros. subst. rewrite spec_mk_t. apply Pfd. - Qed. - - Let Pfg' : forall n m x y u v, u = eval n (S m) x -> v = [mk_t n y] -> - P u v (fg n m x y). - Proof. - intros. subst. rewrite spec_mk_t. apply Pfg. - Qed. -"; - -for i = 0 to size do -pr " Let f%i := f %i." i i -done; - -for i = 0 to size do -pr " Let f%in := fd %i." i i; -pr " Let fn%i := fg %i." i i; -done; - -pr " Notation iter_folded := (fun x y => match x, y with"; -for i = 0 to size do - for j = 0 to size do - pr " | N%i wx, N%i wy => f%s wx wy" i j - (if i = j then string_of_int i - else if i < j then string_of_int i ^ "n " ^ string_of_int (j-i-1) - else "n" ^ string_of_int j ^ " " ^ string_of_int (i-j-1)) - done; - pr " | N%i wx, Nn m wy => f%in m %s wy" i size (ext i size "wx") -done; -for i = 0 to size do - pr " | Nn n wx, N%i wy => fn%i n wx %s" i size (ext i size "wy") -done; -pr -" | Nn n wx, Nn m wy => fnm n m wx wy - end). -"; - -pr -" Definition iter := Eval lazy beta iota delta - [extend DoubleBase.extend DoubleBase.extend_aux zeron] - in iter_folded. - - Lemma spec_iter: forall x y, P [x] [y] (iter x y). - Proof. - change iter with iter_folded; unfold_lets. - destruct x; destruct y; apply Pf' || apply Pfd' || apply Pfg' || apply Pfnm; - simpl mk_t; - match goal with - | |- ?x = ?x => reflexivity - | |- [Nn _ _] = _ => apply spec_eval_size - | |- context [extend ?n ?m _] => apply (spec_extend n m) - | _ => idtac - end; - unfold to_Z; rewrite <- spec_plus_t'; simpl dom_op; reflexivity. - Qed. - - End Iter. -"; - -pr -" Definition switch - (P:nat->Type)%s - (fn:forall n, P n) n := - match n return P n with" - (iter_str_gen size (fun i -> Printf.sprintf "(f%i:P %i)" i i)); -for i = 0 to size do pr " | %i => f%i" i i done; -pr -" | n => fn n - end. -"; - -pr -" Lemma spec_switch : forall P (f:forall n, P n) n, - switch P %sf n = f n. - Proof. - repeat (destruct n; try reflexivity). - Qed. -" (iter_str_gen size (fun i -> Printf.sprintf "(f %i) " i)); - -pr -" (** * [iter_sym] - - A variant of [iter] for symmetric functions, or pseudo-symmetric - functions (when f y x can be deduced from f x y). - *) - - Section IterSym. - - Variable res: Type. - Variable P: Z -> Z -> res -> Prop. - - Variable f : forall n, dom_t n -> dom_t n -> res. - Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y). - - Variable fg : forall n m, word (dom_t n) (S m) -> dom_t n -> res. - Variable Pfg : forall n m x y, P (eval n (S m) x) (ZnZ.to_Z y) (fg n m x y). - - Variable fnm: forall n m, word (dom_t Size) (S n) -> word (dom_t Size) (S m) -> res. - Variable Pfnm: forall n m x y, P [Nn n x] [Nn m y] (fnm n m x y). - - Variable opp: res -> res. - Variable Popp : forall u v r, P u v r -> P v u (opp r). -"; - -for i = 0 to size do -pr " Let f%i := f %i." i i -done; - -for i = 0 to size do -pr " Let fn%i := fg %i." i i; -done; - -pr " Let f' := switch _ %s f." (iter_name 0 size "f" ""); -pr " Let fg' := switch _ %s fg." (iter_name 0 size "fn" ""); - -pr -" Local Notation iter_sym_folded := - (iter res f' (fun n m x y => opp (fg' n m y x)) fg' fnm). - - Definition iter_sym := - Eval lazy beta zeta iota delta [iter f' fg' switch] in iter_sym_folded. - - Lemma spec_iter_sym: forall x y, P [x] [y] (iter_sym x y). - Proof. - intros. change iter_sym with iter_sym_folded. apply spec_iter; clear x y. - unfold_lets. - intros. rewrite spec_switch. auto. - intros. apply Popp. unfold_lets. rewrite spec_switch; auto. - intros. unfold_lets. rewrite spec_switch; auto. - auto. - Qed. - - End IterSym. - - (** * Reduction - - [reduce] can be used instead of [mk_t], it will choose the - lowest possible level. NB: We only search and remove leftmost - W0's via ZnZ.eq0, any non-W0 block ends the process, even - if its value is 0. - *) - - (** First, a direct version ... *) - - Fixpoint red_t n : dom_t n -> t := - match n return dom_t n -> t with - | O => N0 - | S n => fun x => - let x' := pred_t n x in - reduce_n1 _ _ (N0 zero0) ZnZ.eq0 (red_t n) (mk_t_S n) x' - end. - - Lemma spec_red_t : forall n x, [red_t n x] = [mk_t n x]. - Proof. - induction n. - reflexivity. - intros. - simpl red_t. unfold reduce_n1. - rewrite <- (succ_pred_t n x) at 2. - remember (pred_t n x) as x'. - rewrite spec_mk_t, spec_succ_t. - destruct x' as [ | xh xl]. simpl. apply ZnZ.spec_0. - generalize (ZnZ.spec_eq0 xh); case ZnZ.eq0; intros H. - rewrite IHn, spec_mk_t. simpl. rewrite H; auto. - apply spec_mk_t_S. - Qed. - - (** ... then a specialized one *) -"; - -for i = 0 to size do -pr " Definition eq0%i := @ZnZ.eq0 _ w%i_op." i i; -done; - -pr " - Definition reduce_0 := N0."; -for i = 1 to size do - pr " Definition reduce_%i :=" i; - pr " Eval lazy beta iota delta [reduce_n1] in"; - pr " reduce_n1 _ _ (N0 zero0) eq0%i reduce_%i N%i." (i-1) (i-1) i -done; - - pr " Definition reduce_%i :=" (size+1); - pr " Eval lazy beta iota delta [reduce_n1] in"; - pr " reduce_n1 _ _ (N0 zero0) eq0%i reduce_%i (Nn 0)." size size; - - pr " Definition reduce_n n :="; - pr " Eval lazy beta iota delta [reduce_n] in"; - pr " reduce_n _ _ (N0 zero0) reduce_%i Nn n." (size + 1); - pr ""; - -pr " Definition reduce n : dom_t n -> t :="; -pr " match n with"; -for i = 0 to size do -pr " | %i => reduce_%i" i i; -done; -pr " | %s(S n) => reduce_n n" (if size=0 then "" else "SizePlus "); -pr " end."; -pr ""; - -pr " Ltac unfold_red := unfold reduce, %s." (iter_name 1 size "reduce_" ","); -pr ""; -for i = 0 to size do -pr " Declare Equivalent Keys reduce reduce_%i." i; -done; -pr " Declare Equivalent Keys reduce_n reduce_%i." (size + 1); - -pr " - Ltac solve_red := - let H := fresh in let G := fresh in - match goal with - | |- ?P (S ?n) => assert (H:P n) by solve_red - | _ => idtac - end; - intros n G x; destruct (le_lt_eq_dec _ _ G) as [LT|EQ]; - solve [ - apply (H _ (lt_n_Sm_le _ _ LT)) | - inversion LT | - subst; change (reduce 0 x = red_t 0 x); reflexivity | - specialize (H (pred n)); subst; destruct x; - [|unfold_red; rewrite H; auto]; reflexivity - ]. - - Lemma reduce_equiv : forall n x, n <= Size -> reduce n x = red_t n x. - Proof. - set (P N := forall n, n <= N -> forall x, reduce n x = red_t n x). - intros n x H. revert n H x. change (P Size). solve_red. - Qed. - - Lemma spec_reduce_n : forall n x, [reduce_n n x] = [Nn n x]. - Proof. - assert (H : forall x, reduce_%i x = red_t (SizePlus 1) x). - destruct x; [|unfold reduce_%i; rewrite (reduce_equiv Size)]; auto. - induction n. - intros. rewrite H. apply spec_red_t. - destruct x as [|xh xl]. - simpl. rewrite make_op_S. exact ZnZ.spec_0. - fold word in *. - destruct xh; auto. - simpl reduce_n. - rewrite IHn. - rewrite spec_extend_WW; auto. - Qed. -" (size+1) (size+1); - -pr -" Lemma spec_reduce : forall n x, [reduce n x] = ZnZ.to_Z x. - Proof. - do_size (destruct n; - [intros; rewrite reduce_equiv;[apply spec_red_t|auto with arith]|]). - apply spec_reduce_n. - Qed. - -End Make. -"; diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v deleted file mode 100644 index 18d0262c..00000000 --- a/theories/Numbers/Natural/BigN/Nbasic.v +++ /dev/null @@ -1,569 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* xH - | xO p1 => Pos.succ (plength p1) - | xI p1 => Pos.succ (plength p1) - end. - -Theorem plength_correct: forall p, (Zpos p < 2 ^ Zpos (plength p))%Z. -assert (F: (forall p, 2 ^ (Zpos (Pos.succ p)) = 2 * 2 ^ Zpos p)%Z). -intros p; replace (Zpos (Pos.succ p)) with (1 + Zpos p)%Z. -rewrite Zpower_exp; auto with zarith. -rewrite Pos2Z.inj_succ; unfold Z.succ; auto with zarith. -intros p; elim p; simpl plength; auto. -intros p1 Hp1; rewrite F; repeat rewrite Pos2Z.inj_xI. -assert (tmp: (forall p, 2 * p = p + p)%Z); - try repeat rewrite tmp; auto with zarith. -intros p1 Hp1; rewrite F; rewrite (Pos2Z.inj_xO p1). -assert (tmp: (forall p, 2 * p = p + p)%Z); - try repeat rewrite tmp; auto with zarith. -rewrite Z.pow_1_r; auto with zarith. -Qed. - -Theorem plength_pred_correct: forall p, (Zpos p <= 2 ^ Zpos (plength (Pos.pred p)))%Z. -intros p; case (Pos.succ_pred_or p); intros H1. -subst; simpl plength. -rewrite Z.pow_1_r; auto with zarith. -pattern p at 1; rewrite <- H1. -rewrite Pos2Z.inj_succ; unfold Z.succ; auto with zarith. -generalize (plength_correct (Pos.pred p)); auto with zarith. -Qed. - -Definition Pdiv p q := - match Z.div (Zpos p) (Zpos q) with - Zpos q1 => match (Zpos p) - (Zpos q) * (Zpos q1) with - Z0 => q1 - | _ => (Pos.succ q1) - end - | _ => xH - end. - -Theorem Pdiv_le: forall p q, - Zpos p <= Zpos q * Zpos (Pdiv p q). -intros p q. -unfold Pdiv. -assert (H1: Zpos q > 0); auto with zarith. -assert (H1b: Zpos p >= 0); auto with zarith. -generalize (Z_div_ge0 (Zpos p) (Zpos q) H1 H1b). -generalize (Z_div_mod_eq (Zpos p) (Zpos q) H1); case Z.div. - intros HH _; rewrite HH; rewrite Z.mul_0_r; rewrite Z.mul_1_r; simpl. -case (Z_mod_lt (Zpos p) (Zpos q) H1); auto with zarith. -intros q1 H2. -replace (Zpos p - Zpos q * Zpos q1) with (Zpos p mod Zpos q). - 2: pattern (Zpos p) at 2; rewrite H2; auto with zarith. -generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2; - case Z.modulo. - intros HH _; rewrite HH; auto with zarith. - intros r1 HH (_,HH1); rewrite HH; rewrite Pos2Z.inj_succ. - unfold Z.succ; rewrite Z.mul_add_distr_l; auto with zarith. - intros r1 _ (HH,_); case HH; auto. -intros q1 HH; rewrite HH. -unfold Z.ge; simpl Z.compare; intros HH1; case HH1; auto. -Qed. - -Definition is_one p := match p with xH => true | _ => false end. - -Theorem is_one_one: forall p, is_one p = true -> p = xH. -intros p; case p; auto; intros p1 H1; discriminate H1. -Qed. - -Definition get_height digits p := - let r := Pdiv p digits in - if is_one r then xH else Pos.succ (plength (Pos.pred r)). - -Theorem get_height_correct: - forall digits N, - Zpos N <= Zpos digits * (2 ^ (Zpos (get_height digits N) -1)). -intros digits N. -unfold get_height. -assert (H1 := Pdiv_le N digits). -case_eq (is_one (Pdiv N digits)); intros H2. -rewrite (is_one_one _ H2) in H1. -rewrite Z.mul_1_r in H1. -change (2^(1-1))%Z with 1; rewrite Z.mul_1_r; auto. -clear H2. -apply Z.le_trans with (1 := H1). -apply Z.mul_le_mono_nonneg_l; auto with zarith. -rewrite Pos2Z.inj_succ; unfold Z.succ. -rewrite Z.add_comm; rewrite Z.add_simpl_l. -apply plength_pred_correct. -Qed. - -Definition zn2z_word_comm : forall w n, zn2z (word w n) = word (zn2z w) n. - fix zn2z_word_comm 2. - intros w n; case n. - reflexivity. - intros n0;simpl. - case (zn2z_word_comm w n0). - reflexivity. -Defined. - -Fixpoint extend (n:nat) {struct n} : forall w:Type, zn2z w -> word w (S n) := - match n return forall w:Type, zn2z w -> word w (S n) with - | O => fun w x => x - | S m => - let aux := extend m in - fun w x => WW W0 (aux w x) - end. - -Section ExtendMax. - -Open Scope nat_scope. - -Fixpoint plusnS (n m: nat) {struct n} : (n + S m = S (n + m))%nat := - match n return (n + S m = S (n + m))%nat with - | 0 => eq_refl (S m) - | S n1 => - let v := S (S n1 + m) in - eq_ind_r (fun n => S n = v) (eq_refl v) (plusnS n1 m) - end. - -Fixpoint plusn0 n : n + 0 = n := - match n return (n + 0 = n) with - | 0 => eq_refl 0 - | S n1 => - let v := S n1 in - eq_ind_r (fun n : nat => S n = v) (eq_refl v) (plusn0 n1) - end. - - Fixpoint diff (m n: nat) {struct m}: nat * nat := - match m, n with - O, n => (O, n) - | m, O => (m, O) - | S m1, S n1 => diff m1 n1 - end. - -Fixpoint diff_l (m n : nat) {struct m} : fst (diff m n) + n = max m n := - match m return fst (diff m n) + n = max m n with - | 0 => - match n return (n = max 0 n) with - | 0 => eq_refl _ - | S n0 => eq_refl _ - end - | S m1 => - match n return (fst (diff (S m1) n) + n = max (S m1) n) - with - | 0 => plusn0 _ - | S n1 => - let v := fst (diff m1 n1) + n1 in - let v1 := fst (diff m1 n1) + S n1 in - eq_ind v (fun n => v1 = S n) - (eq_ind v1 (fun n => v1 = n) (eq_refl v1) (S v) (plusnS _ _)) - _ (diff_l _ _) - end - end. - -Fixpoint diff_r (m n: nat) {struct m}: snd (diff m n) + m = max m n := - match m return (snd (diff m n) + m = max m n) with - | 0 => - match n return (snd (diff 0 n) + 0 = max 0 n) with - | 0 => eq_refl _ - | S _ => plusn0 _ - end - | S m => - match n return (snd (diff (S m) n) + S m = max (S m) n) with - | 0 => eq_refl (snd (diff (S m) 0) + S m) - | S n1 => - let v := S (max m n1) in - eq_ind_r (fun n => n = v) - (eq_ind_r (fun n => S n = v) - (eq_refl v) (diff_r _ _)) (plusnS _ _) - end - end. - - Variable w: Type. - - Definition castm (m n: nat) (H: m = n) (x: word w (S m)): - (word w (S n)) := - match H in (_ = y) return (word w (S y)) with - | eq_refl => x - end. - -Variable m: nat. -Variable v: (word w (S m)). - -Fixpoint extend_tr (n : nat) {struct n}: (word w (S (n + m))) := - match n return (word w (S (n + m))) with - | O => v - | S n1 => WW W0 (extend_tr n1) - end. - -End ExtendMax. - -Arguments extend_tr [w m] v n. -Arguments castm [w m n] H x. - - - -Section Reduce. - - Variable w : Type. - Variable nT : Type. - Variable N0 : nT. - Variable eq0 : w -> bool. - Variable reduce_n : w -> nT. - Variable zn2z_to_Nt : zn2z w -> nT. - - Definition reduce_n1 (x:zn2z w) := - match x with - | W0 => N0 - | WW xh xl => - if eq0 xh then reduce_n xl - else zn2z_to_Nt x - end. - -End Reduce. - -Section ReduceRec. - - Variable w : Type. - Variable nT : Type. - Variable N0 : nT. - Variable reduce_1n : zn2z w -> nT. - Variable c : forall n, word w (S n) -> nT. - - Fixpoint reduce_n (n:nat) : word w (S n) -> nT := - match n return word w (S n) -> nT with - | O => reduce_1n - | S m => fun x => - match x with - | W0 => N0 - | WW xh xl => - match xh with - | W0 => @reduce_n m xl - | _ => @c (S m) x - end - end - end. - -End ReduceRec. - -Section CompareRec. - - Variable wm w : Type. - Variable w_0 : w. - Variable compare : w -> w -> comparison. - Variable compare0_m : wm -> comparison. - Variable compare_m : wm -> w -> comparison. - - Fixpoint compare0_mn (n:nat) : word wm n -> comparison := - match n return word wm n -> comparison with - | O => compare0_m - | S m => fun x => - match x with - | W0 => Eq - | WW xh xl => - match compare0_mn m xh with - | Eq => compare0_mn m xl - | r => Lt - end - end - end. - - Variable wm_base: positive. - Variable wm_to_Z: wm -> Z. - Variable w_to_Z: w -> Z. - Variable w_to_Z_0: w_to_Z w_0 = 0. - Variable spec_compare0_m: forall x, - compare0_m x = (w_to_Z w_0 ?= wm_to_Z x). - Variable wm_to_Z_pos: forall x, 0 <= wm_to_Z x < base wm_base. - - Let double_to_Z := double_to_Z wm_base wm_to_Z. - Let double_wB := double_wB wm_base. - - Lemma base_xO: forall n, base (xO n) = (base n)^2. - Proof. - intros n1; unfold base. - rewrite (Pos2Z.inj_xO n1); rewrite Z.mul_comm; rewrite Z.pow_mul_r; auto with zarith. - Qed. - - Let double_to_Z_pos: forall n x, 0 <= double_to_Z n x < double_wB n := - (spec_double_to_Z wm_base wm_to_Z wm_to_Z_pos). - - Declare Equivalent Keys compare0_mn compare0_m. - - Lemma spec_compare0_mn: forall n x, - compare0_mn n x = (0 ?= double_to_Z n x). - Proof. - intros n; elim n; clear n; auto. - intros x; rewrite spec_compare0_m; rewrite w_to_Z_0; auto. - intros n Hrec x; case x; unfold compare0_mn; fold compare0_mn; auto. - fold word in *. - intros xh xl. - rewrite 2 Hrec. - simpl double_to_Z. - set (wB := DoubleBase.double_wB wm_base n). - case Z.compare_spec; intros Cmp. - rewrite <- Cmp. reflexivity. - symmetry. apply Z.gt_lt, Z.lt_gt. (* ;-) *) - assert (0 < wB). - unfold wB, DoubleBase.double_wB, base; auto with zarith. - change 0 with (0 + 0); apply Z.add_lt_le_mono; auto with zarith. - apply Z.mul_pos_pos; auto with zarith. - case (double_to_Z_pos n xl); auto with zarith. - case (double_to_Z_pos n xh); intros; exfalso; omega. - Qed. - - Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison := - match n return word wm n -> w -> comparison with - | O => compare_m - | S m => fun x y => - match x with - | W0 => compare w_0 y - | WW xh xl => - match compare0_mn m xh with - | Eq => compare_mn_1 m xl y - | r => Gt - end - end - end. - - Variable spec_compare: forall x y, - compare x y = Z.compare (w_to_Z x) (w_to_Z y). - Variable spec_compare_m: forall x y, - compare_m x y = Z.compare (wm_to_Z x) (w_to_Z y). - Variable wm_base_lt: forall x, - 0 <= w_to_Z x < base (wm_base). - - Let double_wB_lt: forall n x, - 0 <= w_to_Z x < (double_wB n). - Proof. - intros n x; elim n; simpl; auto; clear n. - intros n (H0, H); split; auto. - apply Z.lt_le_trans with (1:= H). - unfold double_wB, DoubleBase.double_wB; simpl. - rewrite base_xO. - set (u := base (Pos.shiftl_nat wm_base n)). - assert (0 < u). - unfold u, base; auto with zarith. - replace (u^2) with (u * u); simpl; auto with zarith. - apply Z.le_trans with (1 * u); auto with zarith. - unfold Z.pow_pos; simpl; ring. - Qed. - - - Lemma spec_compare_mn_1: forall n x y, - compare_mn_1 n x y = Z.compare (double_to_Z n x) (w_to_Z y). - Proof. - intros n; elim n; simpl; auto; clear n. - intros n Hrec x; case x; clear x; auto. - intros y; rewrite spec_compare; rewrite w_to_Z_0. reflexivity. - intros xh xl y; simpl; - rewrite spec_compare0_mn, Hrec. case Z.compare_spec. - intros H1b. - rewrite <- H1b; rewrite Z.mul_0_l; rewrite Z.add_0_l; auto. - symmetry. apply Z.lt_gt. - case (double_wB_lt n y); intros _ H0. - apply Z.lt_le_trans with (1:= H0). - fold double_wB. - case (double_to_Z_pos n xl); intros H1 H2. - apply Z.le_trans with (double_to_Z n xh * double_wB n); auto with zarith. - apply Z.le_trans with (1 * double_wB n); auto with zarith. - case (double_to_Z_pos n xh); intros; exfalso; omega. - Qed. - -End CompareRec. - - -Section AddS. - - Variable w wm : Type. - Variable incr : wm -> carry wm. - Variable addr : w -> wm -> carry wm. - Variable injr : w -> zn2z wm. - - Variable w_0 u: w. - Fixpoint injs (n:nat): word w (S n) := - match n return (word w (S n)) with - O => WW w_0 u - | S n1 => (WW W0 (injs n1)) - end. - - Definition adds x y := - match y with - W0 => C0 (injr x) - | WW hy ly => match addr x ly with - C0 z => C0 (WW hy z) - | C1 z => match incr hy with - C0 z1 => C0 (WW z1 z) - | C1 z1 => C1 (WW z1 z) - end - end - end. - -End AddS. - - Fixpoint length_pos x := - match x with xH => O | xO x1 => S (length_pos x1) | xI x1 => S (length_pos x1) end. - - Theorem length_pos_lt: forall x y, - (length_pos x < length_pos y)%nat -> Zpos x < Zpos y. - Proof. - intros x; elim x; clear x; [intros x1 Hrec | intros x1 Hrec | idtac]; - intros y; case y; clear y; intros y1 H || intros H; simpl length_pos; - try (rewrite (Pos2Z.inj_xI x1) || rewrite (Pos2Z.inj_xO x1)); - try (rewrite (Pos2Z.inj_xI y1) || rewrite (Pos2Z.inj_xO y1)); - try (inversion H; fail); - try (assert (Zpos x1 < Zpos y1); [apply Hrec; apply lt_S_n | idtac]; auto with zarith); - assert (0 < Zpos y1); auto with zarith; red; auto. - Qed. - - Theorem cancel_app: forall A B (f g: A -> B) x, f = g -> f x = g x. - Proof. - intros A B f g x H; rewrite H; auto. - Qed. - - - Section SimplOp. - - Variable w: Type. - - Theorem digits_zop: forall t (ops : ZnZ.Ops t), - ZnZ.digits (mk_zn2z_ops ops) = xO (ZnZ.digits ops). - Proof. - intros ww x; auto. - Qed. - - Theorem digits_kzop: forall t (ops : ZnZ.Ops t), - ZnZ.digits (mk_zn2z_ops_karatsuba ops) = xO (ZnZ.digits ops). - Proof. - intros ww x; auto. - Qed. - - Theorem make_zop: forall t (ops : ZnZ.Ops t), - @ZnZ.to_Z _ (mk_zn2z_ops ops) = - fun z => match z with - | W0 => 0 - | WW xh xl => ZnZ.to_Z xh * base (ZnZ.digits ops) - + ZnZ.to_Z xl - end. - Proof. - intros ww x; auto. - Qed. - - Theorem make_kzop: forall t (ops: ZnZ.Ops t), - @ZnZ.to_Z _ (mk_zn2z_ops_karatsuba ops) = - fun z => match z with - | W0 => 0 - | WW xh xl => ZnZ.to_Z xh * base (ZnZ.digits ops) - + ZnZ.to_Z xl - end. - Proof. - intros ww x; auto. - Qed. - - End SimplOp. - -(** Abstract vision of a datatype of arbitrary-large numbers. - Concrete operations can be derived from these generic - fonctions, in particular from [iter_t] and [same_level]. -*) - -Module Type NAbstract. - -(** The domains: a sequence of [Z/nZ] structures *) - -Parameter dom_t : nat -> Type. -Declare Instance dom_op n : ZnZ.Ops (dom_t n). -Declare Instance dom_spec n : ZnZ.Specs (dom_op n). - -Axiom digits_dom_op : forall n, - ZnZ.digits (dom_op n) = Pos.shiftl_nat (ZnZ.digits (dom_op 0)) n. - -(** The type [t] of arbitrary-large numbers, with abstract constructor [mk_t] - and destructor [destr_t] and iterator [iter_t] *) - -Parameter t : Type. - -Parameter mk_t : forall (n:nat), dom_t n -> t. - -Inductive View_t : t -> Prop := - Mk_t : forall n (x : dom_t n), View_t (mk_t n x). - -Axiom destr_t : forall x, View_t x. (* i.e. every x is a (mk_t n xw) *) - -Parameter iter_t : forall {A:Type}(f : forall n, dom_t n -> A), t -> A. - -Axiom iter_mk_t : forall A (f:forall n, dom_t n -> A), - forall n x, iter_t f (mk_t n x) = f n x. - -(** Conversion to [ZArith] *) - -Parameter to_Z : t -> Z. -Local Notation "[ x ]" := (to_Z x). - -Axiom spec_mk_t : forall n x, [mk_t n x] = ZnZ.to_Z x. - -(** [reduce] is like [mk_t], but try to minimise the level of the number *) - -Parameter reduce : forall (n:nat), dom_t n -> t. -Axiom spec_reduce : forall n x, [reduce n x] = ZnZ.to_Z x. - -(** Number of level in the tree representation of a number. - NB: This function isn't a morphism for setoid [eq]. *) - -Definition level := iter_t (fun n _ => n). - -(** [same_level] and its rich specification, indexed by [level] *) - -Parameter same_level : forall {A:Type} - (f : forall n, dom_t n -> dom_t n -> A), t -> t -> A. - -Axiom spec_same_level_dep : - forall res - (P : nat -> Z -> Z -> res -> Prop) - (Pantimon : forall n m z z' r, (n <= m)%nat -> P m z z' r -> P n z z' r) - (f : forall n, dom_t n -> dom_t n -> res) - (Pf: forall n x y, P n (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)), - forall x y, P (level x) [x] [y] (same_level f x y). - -(** [mk_t_S] : building a number of the next level *) - -Parameter mk_t_S : forall (n:nat), zn2z (dom_t n) -> t. - -Axiom spec_mk_t_S : forall n (x:zn2z (dom_t n)), - [mk_t_S n x] = zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x. - -Axiom mk_t_S_level : forall n x, level (mk_t_S n x) = S n. - -End NAbstract. diff --git a/theories/Numbers/Natural/Binary/NBinary.v b/theories/Numbers/Natural/Binary/NBinary.v index 037b10d9..c9e1c640 100644 --- a/theories/Numbers/Natural/Binary/NBinary.v +++ b/theories/Numbers/Natural/Binary/NBinary.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Even.even n. Proof. symmetry. apply Even.even_equiv. Qed. Lemma Odd_equiv n : Odd n <-> Even.odd n. Proof. symmetry. apply Even.odd_equiv. Qed. -Notation divmod := Nat.divmod (compat "8.4"). -Notation div := Nat.div (compat "8.4"). -Notation modulo := Nat.modulo (compat "8.4"). -Notation divmod_spec := Nat.divmod_spec (compat "8.4"). -Notation div_mod := Nat.div_mod (compat "8.4"). -Notation mod_bound_pos := Nat.mod_bound_pos (compat "8.4"). -Notation sqrt_iter := Nat.sqrt_iter (compat "8.4"). -Notation sqrt := Nat.sqrt (compat "8.4"). -Notation sqrt_iter_spec := Nat.sqrt_iter_spec (compat "8.4"). -Notation sqrt_spec := Nat.sqrt_spec (compat "8.4"). -Notation log2_iter := Nat.log2_iter (compat "8.4"). -Notation log2 := Nat.log2 (compat "8.4"). -Notation log2_iter_spec := Nat.log2_iter_spec (compat "8.4"). -Notation log2_spec := Nat.log2_spec (compat "8.4"). -Notation log2_nonpos := Nat.log2_nonpos (compat "8.4"). -Notation gcd := Nat.gcd (compat "8.4"). -Notation divide := Nat.divide (compat "8.4"). -Notation gcd_divide := Nat.gcd_divide (compat "8.4"). -Notation gcd_divide_l := Nat.gcd_divide_l (compat "8.4"). -Notation gcd_divide_r := Nat.gcd_divide_r (compat "8.4"). -Notation gcd_greatest := Nat.gcd_greatest (compat "8.4"). -Notation testbit := Nat.testbit (compat "8.4"). -Notation shiftl := Nat.shiftl (compat "8.4"). -Notation shiftr := Nat.shiftr (compat "8.4"). -Notation bitwise := Nat.bitwise (compat "8.4"). -Notation land := Nat.land (compat "8.4"). -Notation lor := Nat.lor (compat "8.4"). -Notation ldiff := Nat.ldiff (compat "8.4"). -Notation lxor := Nat.lxor (compat "8.4"). -Notation double_twice := Nat.double_twice (compat "8.4"). -Notation testbit_0_l := Nat.testbit_0_l (compat "8.4"). -Notation testbit_odd_0 := Nat.testbit_odd_0 (compat "8.4"). -Notation testbit_even_0 := Nat.testbit_even_0 (compat "8.4"). -Notation testbit_odd_succ := Nat.testbit_odd_succ (compat "8.4"). -Notation testbit_even_succ := Nat.testbit_even_succ (compat "8.4"). -Notation shiftr_spec := Nat.shiftr_spec (compat "8.4"). -Notation shiftl_spec_high := Nat.shiftl_spec_high (compat "8.4"). -Notation shiftl_spec_low := Nat.shiftl_spec_low (compat "8.4"). -Notation div2_bitwise := Nat.div2_bitwise (compat "8.4"). -Notation odd_bitwise := Nat.odd_bitwise (compat "8.4"). -Notation div2_decr := Nat.div2_decr (compat "8.4"). -Notation testbit_bitwise_1 := Nat.testbit_bitwise_1 (compat "8.4"). -Notation testbit_bitwise_2 := Nat.testbit_bitwise_2 (compat "8.4"). -Notation land_spec := Nat.land_spec (compat "8.4"). -Notation ldiff_spec := Nat.ldiff_spec (compat "8.4"). -Notation lor_spec := Nat.lor_spec (compat "8.4"). -Notation lxor_spec := Nat.lxor_spec (compat "8.4"). +Notation divmod := Nat.divmod (only parsing). +Notation div := Nat.div (only parsing). +Notation modulo := Nat.modulo (only parsing). +Notation divmod_spec := Nat.divmod_spec (only parsing). +Notation div_mod := Nat.div_mod (only parsing). +Notation mod_bound_pos := Nat.mod_bound_pos (only parsing). +Notation sqrt_iter := Nat.sqrt_iter (only parsing). +Notation sqrt := Nat.sqrt (only parsing). +Notation sqrt_iter_spec := Nat.sqrt_iter_spec (only parsing). +Notation sqrt_spec := Nat.sqrt_spec (only parsing). +Notation log2_iter := Nat.log2_iter (only parsing). +Notation log2 := Nat.log2 (only parsing). +Notation log2_iter_spec := Nat.log2_iter_spec (only parsing). +Notation log2_spec := Nat.log2_spec (only parsing). +Notation log2_nonpos := Nat.log2_nonpos (only parsing). +Notation gcd := Nat.gcd (only parsing). +Notation divide := Nat.divide (only parsing). +Notation gcd_divide := Nat.gcd_divide (only parsing). +Notation gcd_divide_l := Nat.gcd_divide_l (only parsing). +Notation gcd_divide_r := Nat.gcd_divide_r (only parsing). +Notation gcd_greatest := Nat.gcd_greatest (only parsing). +Notation testbit := Nat.testbit (only parsing). +Notation shiftl := Nat.shiftl (only parsing). +Notation shiftr := Nat.shiftr (only parsing). +Notation bitwise := Nat.bitwise (only parsing). +Notation land := Nat.land (only parsing). +Notation lor := Nat.lor (only parsing). +Notation ldiff := Nat.ldiff (only parsing). +Notation lxor := Nat.lxor (only parsing). +Notation double_twice := Nat.double_twice (only parsing). +Notation testbit_0_l := Nat.testbit_0_l (only parsing). +Notation testbit_odd_0 := Nat.testbit_odd_0 (only parsing). +Notation testbit_even_0 := Nat.testbit_even_0 (only parsing). +Notation testbit_odd_succ := Nat.testbit_odd_succ (only parsing). +Notation testbit_even_succ := Nat.testbit_even_succ (only parsing). +Notation shiftr_spec := Nat.shiftr_spec (only parsing). +Notation shiftl_spec_high := Nat.shiftl_spec_high (only parsing). +Notation shiftl_spec_low := Nat.shiftl_spec_low (only parsing). +Notation div2_bitwise := Nat.div2_bitwise (only parsing). +Notation odd_bitwise := Nat.odd_bitwise (only parsing). +Notation div2_decr := Nat.div2_decr (only parsing). +Notation testbit_bitwise_1 := Nat.testbit_bitwise_1 (only parsing). +Notation testbit_bitwise_2 := Nat.testbit_bitwise_2 (only parsing). +Notation land_spec := Nat.land_spec (only parsing). +Notation ldiff_spec := Nat.ldiff_spec (only parsing). +Notation lor_spec := Nat.lor_spec (only parsing). +Notation lxor_spec := Nat.lxor_spec (only parsing). Infix "<=?" := Nat.leb (at level 70) : nat_scope. Infix " Z. - Local Notation "[ x ]" := (to_Z x). - Parameter spec_pos: forall x, 0 <= [x]. - - Parameter of_N : N -> t. - Parameter spec_of_N: forall x, to_Z (of_N x) = Z.of_N x. - Definition to_N n := Z.to_N (to_Z n). - - Definition eq n m := [n] = [m]. - Definition lt n m := [n] < [m]. - Definition le n m := [n] <= [m]. - - Parameter compare : t -> t -> comparison. - Parameter eqb : t -> t -> bool. - Parameter ltb : t -> t -> bool. - Parameter leb : t -> t -> bool. - Parameter max : t -> t -> t. - Parameter min : t -> t -> t. - Parameter zero : t. - Parameter one : t. - Parameter two : t. - Parameter succ : t -> t. - Parameter pred : t -> t. - Parameter add : t -> t -> t. - Parameter sub : t -> t -> t. - Parameter mul : t -> t -> t. - Parameter square : t -> t. - Parameter pow_pos : t -> positive -> t. - Parameter pow_N : t -> N -> t. - Parameter pow : t -> t -> t. - Parameter sqrt : t -> t. - Parameter log2 : t -> t. - Parameter div_eucl : t -> t -> t * t. - Parameter div : t -> t -> t. - Parameter modulo : t -> t -> t. - Parameter gcd : t -> t -> t. - Parameter even : t -> bool. - Parameter odd : t -> bool. - Parameter testbit : t -> t -> bool. - Parameter shiftr : t -> t -> t. - Parameter shiftl : t -> t -> t. - Parameter land : t -> t -> t. - Parameter lor : t -> t -> t. - Parameter ldiff : t -> t -> t. - Parameter lxor : t -> t -> t. - Parameter div2 : t -> t. - - Parameter spec_compare: forall x y, compare x y = ([x] ?= [y]). - Parameter spec_eqb : forall x y, eqb x y = ([x] =? [y]). - Parameter spec_ltb : forall x y, ltb x y = ([x] eq) succ. -Program Instance pred_wd : Proper (eq==>eq) pred. -Program Instance add_wd : Proper (eq==>eq==>eq) add. -Program Instance sub_wd : Proper (eq==>eq==>eq) sub. -Program Instance mul_wd : Proper (eq==>eq==>eq) mul. - -Theorem pred_succ : forall n, pred (succ n) == n. -Proof. -intros. zify. omega_pos n. -Qed. - -Theorem one_succ : 1 == succ 0. -Proof. -now zify. -Qed. - -Theorem two_succ : 2 == succ 1. -Proof. -now zify. -Qed. - -Definition N_of_Z z := of_N (Z.to_N z). - -Lemma spec_N_of_Z z : (0<=z)%Z -> [N_of_Z z] = z. -Proof. - unfold N_of_Z. zify. apply Z2N.id. -Qed. - -Section Induction. - -Variable A : NN.t -> Prop. -Hypothesis A_wd : Proper (eq==>iff) A. -Hypothesis A0 : A 0. -Hypothesis AS : forall n, A n <-> A (succ n). - -Let B (z : Z) := A (N_of_Z z). - -Lemma B0 : B 0. -Proof. -unfold B, N_of_Z; simpl. -rewrite <- (A_wd 0); auto. -red; rewrite spec_0, spec_of_N; auto. -Qed. - -Lemma BS : forall z : Z, (0 <= z)%Z -> B z -> B (z + 1). -Proof. -intros z H1 H2. -unfold B in *. apply -> AS in H2. -setoid_replace (N_of_Z (z + 1)) with (succ (N_of_Z z)); auto. -unfold eq. rewrite spec_succ, 2 spec_N_of_Z; auto with zarith. -Qed. - -Lemma B_holds : forall z : Z, (0 <= z)%Z -> B z. -Proof. -exact (natlike_ind B B0 BS). -Qed. - -Theorem bi_induction : forall n, A n. -Proof. -intro n. setoid_replace n with (N_of_Z (to_Z n)). -apply B_holds. apply spec_pos. -red. now rewrite spec_N_of_Z by apply spec_pos. -Qed. - -End Induction. - -Theorem add_0_l : forall n, 0 + n == n. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem add_succ_l : forall n m, (succ n) + m == succ (n + m). -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem sub_0_r : forall n, n - 0 == n. -Proof. -intros. zify. omega_pos n. -Qed. - -Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m). -Proof. -intros. zify. omega with *. -Qed. - -Theorem mul_0_l : forall n, 0 * n == 0. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem mul_succ_l : forall n m, (succ n) * m == n * m + m. -Proof. -intros. zify. ring. -Qed. - -(** Order *) - -Lemma eqb_eq x y : eqb x y = true <-> x == y. -Proof. - zify. apply Z.eqb_eq. -Qed. - -Lemma leb_le x y : leb x y = true <-> x <= y. -Proof. - zify. apply Z.leb_le. -Qed. - -Lemma ltb_lt x y : ltb x y = true <-> x < y. -Proof. - zify. apply Z.ltb_lt. -Qed. - -Lemma compare_eq_iff n m : compare n m = Eq <-> n == m. -Proof. - intros. zify. apply Z.compare_eq_iff. -Qed. - -Lemma compare_lt_iff n m : compare n m = Lt <-> n < m. -Proof. - intros. zify. reflexivity. -Qed. - -Lemma compare_le_iff n m : compare n m <> Gt <-> n <= m. -Proof. - intros. zify. reflexivity. -Qed. - -Lemma compare_antisym n m : compare m n = CompOpp (compare n m). -Proof. - intros. zify. apply Z.compare_antisym. -Qed. - -Include BoolOrderFacts NN NN NN [no inline]. - -Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance eqb_wd : Proper (eq ==> eq ==> Logic.eq) eqb. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance ltb_wd : Proper (eq ==> eq ==> Logic.eq) ltb. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance leb_wd : Proper (eq ==> eq ==> Logic.eq) leb. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance lt_wd : Proper (eq ==> eq ==> iff) lt. -Proof. -intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition. -Qed. - -Theorem lt_succ_r : forall n m, n < succ m <-> n <= m. -Proof. -intros. zify. omega. -Qed. - -Theorem min_l : forall n m, n <= m -> min n m == n. -Proof. -intros n m. zify. omega with *. -Qed. - -Theorem min_r : forall n m, m <= n -> min n m == m. -Proof. -intros n m. zify. omega with *. -Qed. - -Theorem max_l : forall n m, m <= n -> max n m == n. -Proof. -intros n m. zify. omega with *. -Qed. - -Theorem max_r : forall n m, n <= m -> max n m == m. -Proof. -intros n m. zify. omega with *. -Qed. - -(** Properties specific to natural numbers, not integers. *) - -Theorem pred_0 : pred 0 == 0. -Proof. -zify. auto. -Qed. - -(** Power *) - -Program Instance pow_wd : Proper (eq==>eq==>eq) pow. - -Lemma pow_0_r : forall a, a^0 == 1. -Proof. - intros. now zify. -Qed. - -Lemma pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b. -Proof. - intros a b. zify. intros. now Z.nzsimpl. -Qed. - -Lemma pow_neg_r : forall a b, b<0 -> a^b == 0. -Proof. - intros a b. zify. intro Hb. exfalso. omega_pos b. -Qed. - -Lemma pow_pow_N : forall a b, a^b == pow_N a (to_N b). -Proof. - intros. zify. f_equal. - now rewrite Z2N.id by apply spec_pos. -Qed. - -Lemma pow_N_pow : forall a b, pow_N a b == a^(of_N b). -Proof. - intros. now zify. -Qed. - -Lemma pow_pos_N : forall a p, pow_pos a p == pow_N a (Npos p). -Proof. - intros. now zify. -Qed. - -(** Square *) - -Lemma square_spec n : square n == n * n. -Proof. - now zify. -Qed. - -(** Sqrt *) - -Lemma sqrt_spec : forall n, 0<=n -> - (sqrt n)*(sqrt n) <= n /\ n < (succ (sqrt n))*(succ (sqrt n)). -Proof. - intros n. zify. apply Z.sqrt_spec. -Qed. - -Lemma sqrt_neg : forall n, n<0 -> sqrt n == 0. -Proof. - intros n. zify. intro H. exfalso. omega_pos n. -Qed. - -(** Log2 *) - -Lemma log2_spec : forall n, 0 - 2^(log2 n) <= n /\ n < 2^(succ (log2 n)). -Proof. - intros n. zify. change (Z.log2 [n]+1)%Z with (Z.succ (Z.log2 [n])). - apply Z.log2_spec. -Qed. - -Lemma log2_nonpos : forall n, n<=0 -> log2 n == 0. -Proof. - intros n. zify. apply Z.log2_nonpos. -Qed. - -(** Even / Odd *) - -Definition Even n := exists m, n == 2*m. -Definition Odd n := exists m, n == 2*m+1. - -Lemma even_spec n : even n = true <-> Even n. -Proof. - unfold Even. zify. rewrite Z.even_spec. - split; intros (m,Hm). - - exists (N_of_Z m). zify. rewrite spec_N_of_Z; trivial. omega_pos n. - - exists [m]. revert Hm; now zify. -Qed. - -Lemma odd_spec n : odd n = true <-> Odd n. -Proof. - unfold Odd. zify. rewrite Z.odd_spec. - split; intros (m,Hm). - - exists (N_of_Z m). zify. rewrite spec_N_of_Z; trivial. omega_pos n. - - exists [m]. revert Hm; now zify. -Qed. - -(** Div / Mod *) - -Program Instance div_wd : Proper (eq==>eq==>eq) div. -Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. - -Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b). -Proof. -intros a b. zify. intros. apply Z.div_mod; auto. -Qed. - -Theorem mod_bound_pos : forall a b, 0<=a -> 0 - 0 <= modulo a b /\ modulo a b < b. -Proof. -intros a b. zify. apply Z.mod_bound_pos. -Qed. - -(** Gcd *) - -Definition divide n m := exists p, m == p*n. -Local Notation "( x | y )" := (divide x y) (at level 0). - -Lemma spec_divide : forall n m, (n|m) <-> Z.divide [n] [m]. -Proof. - intros n m. split. - - intros (p,H). exists [p]. revert H; now zify. - - intros (z,H). exists (of_N (Z.abs_N z)). zify. - rewrite N2Z.inj_abs_N. - rewrite <- (Z.abs_eq [m]), <- (Z.abs_eq [n]) by apply spec_pos. - now rewrite H, Z.abs_mul. -Qed. - -Lemma gcd_divide_l : forall n m, (gcd n m | n). -Proof. - intros n m. apply spec_divide. zify. apply Z.gcd_divide_l. -Qed. - -Lemma gcd_divide_r : forall n m, (gcd n m | m). -Proof. - intros n m. apply spec_divide. zify. apply Z.gcd_divide_r. -Qed. - -Lemma gcd_greatest : forall n m p, (p|n) -> (p|m) -> (p|gcd n m). -Proof. - intros n m p. rewrite !spec_divide. zify. apply Z.gcd_greatest. -Qed. - -Lemma gcd_nonneg : forall n m, 0 <= gcd n m. -Proof. - intros. zify. apply Z.gcd_nonneg. -Qed. - -(** Bitwise operations *) - -Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit. - -Lemma testbit_odd_0 : forall a, testbit (2*a+1) 0 = true. -Proof. - intros. zify. apply Z.testbit_odd_0. -Qed. - -Lemma testbit_even_0 : forall a, testbit (2*a) 0 = false. -Proof. - intros. zify. apply Z.testbit_even_0. -Qed. - -Lemma testbit_odd_succ : forall a n, 0<=n -> - testbit (2*a+1) (succ n) = testbit a n. -Proof. - intros a n. zify. apply Z.testbit_odd_succ. -Qed. - -Lemma testbit_even_succ : forall a n, 0<=n -> - testbit (2*a) (succ n) = testbit a n. -Proof. - intros a n. zify. apply Z.testbit_even_succ. -Qed. - -Lemma testbit_neg_r : forall a n, n<0 -> testbit a n = false. -Proof. - intros a n. zify. apply Z.testbit_neg_r. -Qed. - -Lemma shiftr_spec : forall a n m, 0<=m -> - testbit (shiftr a n) m = testbit a (m+n). -Proof. - intros a n m. zify. apply Z.shiftr_spec. -Qed. - -Lemma shiftl_spec_high : forall a n m, 0<=m -> n<=m -> - testbit (shiftl a n) m = testbit a (m-n). -Proof. - intros a n m. zify. intros Hn H. rewrite Z.max_r by auto with zarith. - now apply Z.shiftl_spec_high. -Qed. - -Lemma shiftl_spec_low : forall a n m, m - testbit (shiftl a n) m = false. -Proof. - intros a n m. zify. intros H. now apply Z.shiftl_spec_low. -Qed. - -Lemma land_spec : forall a b n, - testbit (land a b) n = testbit a n && testbit b n. -Proof. - intros a n m. zify. now apply Z.land_spec. -Qed. - -Lemma lor_spec : forall a b n, - testbit (lor a b) n = testbit a n || testbit b n. -Proof. - intros a n m. zify. now apply Z.lor_spec. -Qed. - -Lemma ldiff_spec : forall a b n, - testbit (ldiff a b) n = testbit a n && negb (testbit b n). -Proof. - intros a n m. zify. now apply Z.ldiff_spec. -Qed. - -Lemma lxor_spec : forall a b n, - testbit (lxor a b) n = xorb (testbit a n) (testbit b n). -Proof. - intros a n m. zify. now apply Z.lxor_spec. -Qed. - -Lemma div2_spec : forall a, div2 a == shiftr a 1. -Proof. - intros a. zify. now apply Z.div2_spec. -Qed. - -(** Recursion *) - -Definition recursion (A : Type) (a : A) (f : NN.t -> A -> A) (n : NN.t) := - N.peano_rect (fun _ => A) a (fun n a => f (NN.of_N n) a) (NN.to_N n). -Arguments recursion [A] a f n. - -Instance recursion_wd (A : Type) (Aeq : relation A) : - Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A). -Proof. -unfold eq. -intros a a' Eaa' f f' Eff' x x' Exx'. -unfold recursion. -unfold NN.to_N. -rewrite <- Exx'; clear x' Exx'. -induction (Z.to_N [x]) using N.peano_ind. -simpl; auto. -rewrite 2 N.peano_rect_succ. now apply Eff'. -Qed. - -Theorem recursion_0 : - forall (A : Type) (a : A) (f : NN.t -> A -> A), recursion a f 0 = a. -Proof. -intros A a f; unfold recursion, NN.to_N; rewrite NN.spec_0; simpl; auto. -Qed. - -Theorem recursion_succ : - forall (A : Type) (Aeq : relation A) (a : A) (f : NN.t -> A -> A), - Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> - forall n, Aeq (recursion a f (succ n)) (f n (recursion a f n)). -Proof. -unfold eq, recursion; intros A Aeq a f EAaa f_wd n. -replace (to_N (succ n)) with (N.succ (to_N n)) by - (zify; now rewrite <- Z2N.inj_succ by apply spec_pos). -rewrite N.peano_rect_succ. -apply f_wd; auto. -zify. now rewrite Z2N.id by apply spec_pos. -fold (recursion a f n). apply recursion_wd; auto. red; auto. -Qed. - -End NTypeIsNAxioms. - -Module NType_NAxioms (NN : NType) - <: NAxiomsSig <: OrderFunctions NN <: HasMinMax NN - := NN <+ NTypeIsNAxioms. diff --git a/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v index f323aaeb..7cf13fea 100644 --- a/theories/Numbers/NumPrelude.v +++ b/theories/Numbers/NumPrelude.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 isBigZcst t - | BigQ.Qq ?n ?d => match isBigZcst n with - | true => isBigNcst d - | false => constr:(false) - end - | BigQ.zero => constr:(true) - | BigQ.one => constr:(true) - | BigQ.minus_one => constr:(true) - | _ => constr:(false) - end. - -Ltac BigQcst t := - match isBigQcst t with - | true => constr:(t) - | false => constr:(NotConstant) - end. - -Add Field BigQfield : BigQfieldth - (decidable BigQ.eqb_correct, - completeness BigQ.eqb_complete, - constants [BigQcst], - power_tac BigQpowerth [Qpow_tac]). - -Section TestField. - -Let ex1 : forall x y z, (x+y)*z == (x*z)+(y*z). - intros. - ring. -Qed. - -Let ex8 : forall x, x ^ 2 == x*x. - intro. - ring. -Qed. - -Let ex10 : forall x y, y!=0 -> (x/y)*y == x. -intros. -field. -auto. -Qed. - -End TestField. - -(** [BigQ] can also benefit from an "order" tactic *) - -Ltac bigQ_order := BigQ.order. - -Section TestOrder. -Let test : forall x y : bigQ, x<=y -> y<=x -> x==y. -Proof. bigQ_order. Qed. -End TestOrder. - -(** We can also reason by switching to QArith thanks to tactic - BigQ.qify. *) - -Section TestQify. -Let test : forall x : bigQ, 0+x == 1*x. -Proof. intro x. BigQ.qify. ring. Qed. -End TestQify. diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v deleted file mode 100644 index b9fed9d5..00000000 --- a/theories/Numbers/Rational/BigQ/QMake.v +++ /dev/null @@ -1,1283 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ZZ.t. - Parameter spec_Z_of_N : forall n, ZZ.to_Z (Z_of_N n) = NN.to_Z n. - Parameter Zabs_N : ZZ.t -> NN.t. - Parameter spec_Zabs_N : forall z, NN.to_Z (Zabs_N z) = Z.abs (ZZ.to_Z z). -End NType_ZType. - -Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. - - (** The notation of a rational number is either an integer x, - interpreted as itself or a pair (x,y) of an integer x and a natural - number y interpreted as x/y. The pairs (x,0) and (0,y) are all - interpreted as 0. *) - - Inductive t_ := - | Qz : ZZ.t -> t_ - | Qq : ZZ.t -> NN.t -> t_. - - Definition t := t_. - - (** Specification with respect to [QArith] *) - - Local Open Scope Q_scope. - - Definition of_Z x: t := Qz (ZZ.of_Z x). - - Definition of_Q (q:Q) : t := - let (x,y) := q in - match y with - | 1%positive => Qz (ZZ.of_Z x) - | _ => Qq (ZZ.of_Z x) (NN.of_N (Npos y)) - end. - - Definition to_Q (q: t) := - match q with - | Qz x => ZZ.to_Z x # 1 - | Qq x y => if NN.eqb y NN.zero then 0 - else ZZ.to_Z x # Z.to_pos (NN.to_Z y) - end. - - Notation "[ x ]" := (to_Q x). - - Lemma N_to_Z_pos : - forall x, (NN.to_Z x <> NN.to_Z NN.zero)%Z -> (0 < NN.to_Z x)%Z. - Proof. - intros x; rewrite NN.spec_0; generalize (NN.spec_pos x). romega. - Qed. - - Ltac destr_zcompare := case Z.compare_spec; intros ?H. - - Ltac destr_eqb := - match goal with - | |- context [ZZ.eqb ?x ?y] => - rewrite (ZZ.spec_eqb x y); - case (Z.eqb_spec (ZZ.to_Z x) (ZZ.to_Z y)); - destr_eqb - | |- context [NN.eqb ?x ?y] => - rewrite (NN.spec_eqb x y); - case (Z.eqb_spec (NN.to_Z x) (NN.to_Z y)); - [ | let H:=fresh "H" in - try (intro H;generalize (N_to_Z_pos _ H); clear H)]; - destr_eqb - | _ => idtac - end. - - Hint Rewrite - Z.add_0_r Z.add_0_l Z.mul_0_r Z.mul_0_l Z.mul_1_r Z.mul_1_l - ZZ.spec_0 NN.spec_0 ZZ.spec_1 NN.spec_1 ZZ.spec_m1 ZZ.spec_opp - ZZ.spec_compare NN.spec_compare - ZZ.spec_add NN.spec_add ZZ.spec_mul NN.spec_mul ZZ.spec_div NN.spec_div - ZZ.spec_gcd NN.spec_gcd Z.gcd_abs_l Z.gcd_1_r - spec_Z_of_N spec_Zabs_N - : nz. - - Ltac nzsimpl := autorewrite with nz in *. - - Ltac qsimpl := try red; unfold to_Q; simpl; intros; - destr_eqb; simpl; nzsimpl; intros; - rewrite ?Z2Pos.id by auto; - auto. - - Theorem strong_spec_of_Q: forall q: Q, [of_Q q] = q. - Proof. - intros(x,y); destruct y; simpl; rewrite ?ZZ.spec_of_Z; auto; - destr_eqb; now rewrite ?NN.spec_0, ?NN.spec_of_N. - Qed. - - Theorem spec_of_Q: forall q: Q, [of_Q q] == q. - Proof. - intros; rewrite strong_spec_of_Q; red; auto. - Qed. - - Definition eq x y := [x] == [y]. - - Definition zero: t := Qz ZZ.zero. - Definition one: t := Qz ZZ.one. - Definition minus_one: t := Qz ZZ.minus_one. - - Lemma spec_0: [zero] == 0. - Proof. - simpl. nzsimpl. reflexivity. - Qed. - - Lemma spec_1: [one] == 1. - Proof. - simpl. nzsimpl. reflexivity. - Qed. - - Lemma spec_m1: [minus_one] == -(1). - Proof. - simpl. nzsimpl. reflexivity. - Qed. - - Definition compare (x y: t) := - match x, y with - | Qz zx, Qz zy => ZZ.compare zx zy - | Qz zx, Qq ny dy => - if NN.eqb dy NN.zero then ZZ.compare zx ZZ.zero - else ZZ.compare (ZZ.mul zx (Z_of_N dy)) ny - | Qq nx dx, Qz zy => - if NN.eqb dx NN.zero then ZZ.compare ZZ.zero zy - else ZZ.compare nx (ZZ.mul zy (Z_of_N dx)) - | Qq nx dx, Qq ny dy => - match NN.eqb dx NN.zero, NN.eqb dy NN.zero with - | true, true => Eq - | true, false => ZZ.compare ZZ.zero ny - | false, true => ZZ.compare nx ZZ.zero - | false, false => ZZ.compare (ZZ.mul nx (Z_of_N dy)) - (ZZ.mul ny (Z_of_N dx)) - end - end. - - Theorem spec_compare: forall q1 q2, (compare q1 q2) = ([q1] ?= [q2]). - Proof. - intros [z1 | x1 y1] [z2 | x2 y2]; - unfold Qcompare, compare; qsimpl. - Qed. - - Definition lt n m := [n] < [m]. - Definition le n m := [n] <= [m]. - - Definition min n m := match compare n m with Gt => m | _ => n end. - Definition max n m := match compare n m with Lt => m | _ => n end. - - Lemma spec_min : forall n m, [min n m] == Qmin [n] [m]. - Proof. - unfold min, Qmin, GenericMinMax.gmin. intros. - rewrite spec_compare; destruct Qcompare; auto with qarith. - Qed. - - Lemma spec_max : forall n m, [max n m] == Qmax [n] [m]. - Proof. - unfold max, Qmax, GenericMinMax.gmax. intros. - rewrite spec_compare; destruct Qcompare; auto with qarith. - Qed. - - Definition eq_bool n m := - match compare n m with Eq => true | _ => false end. - - Theorem spec_eq_bool: forall x y, eq_bool x y = Qeq_bool [x] [y]. - Proof. - intros. unfold eq_bool. rewrite spec_compare. reflexivity. - Qed. - - (** [check_int] : is a reduced fraction [n/d] in fact a integer ? *) - - Definition check_int n d := - match NN.compare NN.one d with - | Lt => Qq n d - | Eq => Qz n - | Gt => zero (* n/0 encodes 0 *) - end. - - Theorem strong_spec_check_int : forall n d, [check_int n d] = [Qq n d]. - Proof. - intros; unfold check_int. - nzsimpl. - destr_zcompare. - simpl. rewrite <- H; qsimpl. congruence. - reflexivity. - qsimpl. exfalso; romega. - Qed. - - (** Normalisation function *) - - Definition norm n d : t := - let gcd := NN.gcd (Zabs_N n) d in - match NN.compare NN.one gcd with - | Lt => check_int (ZZ.div n (Z_of_N gcd)) (NN.div d gcd) - | Eq => check_int n d - | Gt => zero (* gcd = 0 => both numbers are 0 *) - end. - - Theorem spec_norm: forall n q, [norm n q] == [Qq n q]. - Proof. - intros p q; unfold norm. - assert (Hp := NN.spec_pos (Zabs_N p)). - assert (Hq := NN.spec_pos q). - nzsimpl. - destr_zcompare. - (* Eq *) - rewrite strong_spec_check_int; reflexivity. - (* Lt *) - rewrite strong_spec_check_int. - qsimpl. - generalize (Zgcd_div_pos (ZZ.to_Z p) (NN.to_Z q)). romega. - replace (NN.to_Z q) with 0%Z in * by assumption. - rewrite Zdiv_0_l in *; auto with zarith. - apply Zgcd_div_swap0; romega. - (* Gt *) - qsimpl. - assert (H' : Z.gcd (ZZ.to_Z p) (NN.to_Z q) = 0%Z). - generalize (Z.gcd_nonneg (ZZ.to_Z p) (NN.to_Z q)); romega. - symmetry; apply (Z.gcd_eq_0_l _ _ H'); auto. - Qed. - - Theorem strong_spec_norm : forall p q, [norm p q] = Qred [Qq p q]. - Proof. - intros. - replace (Qred [Qq p q]) with (Qred [norm p q]) by - (apply Qred_complete; apply spec_norm). - symmetry; apply Qred_identity. - unfold norm. - assert (Hp := NN.spec_pos (Zabs_N p)). - assert (Hq := NN.spec_pos q). - nzsimpl. - destr_zcompare; rewrite ?strong_spec_check_int. - (* Eq *) - qsimpl. - (* Lt *) - qsimpl. - rewrite Zgcd_1_rel_prime. - destruct (Z_lt_le_dec 0 (NN.to_Z q)). - apply Zis_gcd_rel_prime; auto with zarith. - apply Zgcd_is_gcd. - replace (NN.to_Z q) with 0%Z in * by romega. - rewrite Zdiv_0_l in *; romega. - (* Gt *) - simpl; auto with zarith. - Qed. - - (** Reduction function : producing irreducible fractions *) - - Definition red (x : t) : t := - match x with - | Qz z => x - | Qq n d => norm n d - end. - - Class Reduced x := is_reduced : [red x] = [x]. - - Theorem spec_red : forall x, [red x] == [x]. - Proof. - intros [ z | n d ]. - auto with qarith. - unfold red. - apply spec_norm. - Qed. - - Theorem strong_spec_red : forall x, [red x] = Qred [x]. - Proof. - intros [ z | n d ]. - unfold red. - symmetry; apply Qred_identity; simpl; auto with zarith. - unfold red; apply strong_spec_norm. - Qed. - - Definition add (x y: t): t := - match x with - | Qz zx => - match y with - | Qz zy => Qz (ZZ.add zx zy) - | Qq ny dy => - if NN.eqb dy NN.zero then x - else Qq (ZZ.add (ZZ.mul zx (Z_of_N dy)) ny) dy - end - | Qq nx dx => - if NN.eqb dx NN.zero then y - else match y with - | Qz zy => Qq (ZZ.add nx (ZZ.mul zy (Z_of_N dx))) dx - | Qq ny dy => - if NN.eqb dy NN.zero then x - else - let n := ZZ.add (ZZ.mul nx (Z_of_N dy)) (ZZ.mul ny (Z_of_N dx)) in - let d := NN.mul dx dy in - Qq n d - end - end. - - Theorem spec_add : forall x y, [add x y] == [x] + [y]. - Proof. - intros [x | nx dx] [y | ny dy]; unfold Qplus; qsimpl; - auto with zarith. - rewrite Pos.mul_1_r, Z2Pos.id; auto. - rewrite Pos.mul_1_r, Z2Pos.id; auto. - rewrite Z.mul_eq_0 in *; intuition. - rewrite Pos2Z.inj_mul, 2 Z2Pos.id; auto. - Qed. - - Definition add_norm (x y: t): t := - match x with - | Qz zx => - match y with - | Qz zy => Qz (ZZ.add zx zy) - | Qq ny dy => - if NN.eqb dy NN.zero then x - else norm (ZZ.add (ZZ.mul zx (Z_of_N dy)) ny) dy - end - | Qq nx dx => - if NN.eqb dx NN.zero then y - else match y with - | Qz zy => norm (ZZ.add nx (ZZ.mul zy (Z_of_N dx))) dx - | Qq ny dy => - if NN.eqb dy NN.zero then x - else - let n := ZZ.add (ZZ.mul nx (Z_of_N dy)) (ZZ.mul ny (Z_of_N dx)) in - let d := NN.mul dx dy in - norm n d - end - end. - - Theorem spec_add_norm : forall x y, [add_norm x y] == [x] + [y]. - Proof. - intros x y; rewrite <- spec_add. - destruct x; destruct y; unfold add_norm, add; - destr_eqb; auto using Qeq_refl, spec_norm. - Qed. - - Instance strong_spec_add_norm x y - `(Reduced x, Reduced y) : Reduced (add_norm x y). - Proof. - unfold Reduced; intros. - rewrite strong_spec_red. - rewrite <- (Qred_complete [add x y]); - [ | rewrite spec_add, spec_add_norm; apply Qeq_refl ]. - rewrite <- strong_spec_red. - destruct x as [zx|nx dx]; destruct y as [zy|ny dy]; - simpl; destr_eqb; nzsimpl; simpl; auto. - Qed. - - Definition opp (x: t): t := - match x with - | Qz zx => Qz (ZZ.opp zx) - | Qq nx dx => Qq (ZZ.opp nx) dx - end. - - Theorem strong_spec_opp: forall q, [opp q] = -[q]. - Proof. - intros [z | x y]; simpl. - rewrite ZZ.spec_opp; auto. - match goal with |- context[NN.eqb ?X ?Y] => - generalize (NN.spec_eqb X Y); case NN.eqb - end; auto; rewrite NN.spec_0. - rewrite ZZ.spec_opp; auto. - Qed. - - Theorem spec_opp : forall q, [opp q] == -[q]. - Proof. - intros; rewrite strong_spec_opp; red; auto. - Qed. - - Instance strong_spec_opp_norm q `(Reduced q) : Reduced (opp q). - Proof. - unfold Reduced; intros. - rewrite strong_spec_opp, <- H, !strong_spec_red, <- Qred_opp. - apply Qred_complete; apply spec_opp. - Qed. - - Definition sub x y := add x (opp y). - - Theorem spec_sub : forall x y, [sub x y] == [x] - [y]. - Proof. - intros x y; unfold sub; rewrite spec_add; auto. - rewrite spec_opp; ring. - Qed. - - Definition sub_norm x y := add_norm x (opp y). - - Theorem spec_sub_norm : forall x y, [sub_norm x y] == [x] - [y]. - Proof. - intros x y; unfold sub_norm; rewrite spec_add_norm; auto. - rewrite spec_opp; ring. - Qed. - - Instance strong_spec_sub_norm x y - `(Reduced x, Reduced y) : Reduced (sub_norm x y). - Proof. - intros. - unfold sub_norm. - apply strong_spec_add_norm; auto. - apply strong_spec_opp_norm; auto. - Qed. - - Definition mul (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (ZZ.mul zx zy) - | Qz zx, Qq ny dy => Qq (ZZ.mul zx ny) dy - | Qq nx dx, Qz zy => Qq (ZZ.mul nx zy) dx - | Qq nx dx, Qq ny dy => Qq (ZZ.mul nx ny) (NN.mul dx dy) - end. - - Ltac nsubst := - match goal with E : NN.to_Z _ = _ |- _ => rewrite E in * end. - - Theorem spec_mul : forall x y, [mul x y] == [x] * [y]. - Proof. - intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl; qsimpl. - rewrite Pos.mul_1_r, Z2Pos.id; auto. - rewrite Z.mul_eq_0 in *; intuition. - nsubst; auto with zarith. - nsubst; auto with zarith. - nsubst; nzsimpl; auto with zarith. - rewrite Pos2Z.inj_mul, 2 Z2Pos.id; auto. - Qed. - - Definition norm_denum n d := - if NN.eqb d NN.one then Qz n else Qq n d. - - Lemma spec_norm_denum : forall n d, - [norm_denum n d] == [Qq n d]. - Proof. - unfold norm_denum; intros; simpl; qsimpl. - congruence. - nsubst; auto with zarith. - Qed. - - Definition irred n d := - let gcd := NN.gcd (Zabs_N n) d in - match NN.compare gcd NN.one with - | Gt => (ZZ.div n (Z_of_N gcd), NN.div d gcd) - | _ => (n, d) - end. - - Lemma spec_irred : forall n d, exists g, - let (n',d') := irred n d in - (ZZ.to_Z n' * g = ZZ.to_Z n)%Z /\ (NN.to_Z d' * g = NN.to_Z d)%Z. - Proof. - intros. - unfold irred; nzsimpl; simpl. - destr_zcompare. - exists 1%Z; nzsimpl; auto. - exists 0%Z; nzsimpl. - assert (Z.gcd (ZZ.to_Z n) (NN.to_Z d) = 0%Z). - generalize (Z.gcd_nonneg (ZZ.to_Z n) (NN.to_Z d)); romega. - clear H. - split. - symmetry; apply (Z.gcd_eq_0_l _ _ H0). - symmetry; apply (Z.gcd_eq_0_r _ _ H0). - exists (Z.gcd (ZZ.to_Z n) (NN.to_Z d)). - simpl. - split. - nzsimpl. - destruct (Zgcd_is_gcd (ZZ.to_Z n) (NN.to_Z d)). - rewrite Z.mul_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith. - nzsimpl. - destruct (Zgcd_is_gcd (ZZ.to_Z n) (NN.to_Z d)). - rewrite Z.mul_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith. - Qed. - - Lemma spec_irred_zero : forall n d, - (NN.to_Z d = 0)%Z <-> (NN.to_Z (snd (irred n d)) = 0)%Z. - Proof. - intros. - unfold irred. - split. - nzsimpl; intros. - destr_zcompare; auto. - simpl. - nzsimpl. - rewrite H, Zdiv_0_l; auto. - nzsimpl; destr_zcompare; simpl; auto. - nzsimpl. - intros. - generalize (NN.spec_pos d); intros. - destruct (NN.to_Z d); auto. - assert (0 < 0)%Z. - rewrite <- H0 at 2. - apply Zgcd_div_pos; auto with zarith. - compute; auto. - discriminate. - compute in H1; elim H1; auto. - Qed. - - Lemma strong_spec_irred : forall n d, - (NN.to_Z d <> 0%Z) -> - let (n',d') := irred n d in Z.gcd (ZZ.to_Z n') (NN.to_Z d') = 1%Z. - Proof. - unfold irred; intros. - nzsimpl. - destr_zcompare; simpl; auto. - elim H. - apply (Z.gcd_eq_0_r (ZZ.to_Z n)). - generalize (Z.gcd_nonneg (ZZ.to_Z n) (NN.to_Z d)); romega. - - nzsimpl. - rewrite Zgcd_1_rel_prime. - apply Zis_gcd_rel_prime. - generalize (NN.spec_pos d); romega. - generalize (Z.gcd_nonneg (ZZ.to_Z n) (NN.to_Z d)); romega. - apply Zgcd_is_gcd; auto. - Qed. - - Definition mul_norm_Qz_Qq z n d := - if ZZ.eqb z ZZ.zero then zero - else - let gcd := NN.gcd (Zabs_N z) d in - match NN.compare gcd NN.one with - | Gt => - let z := ZZ.div z (Z_of_N gcd) in - let d := NN.div d gcd in - norm_denum (ZZ.mul z n) d - | _ => Qq (ZZ.mul z n) d - end. - - Definition mul_norm (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (ZZ.mul zx zy) - | Qz zx, Qq ny dy => mul_norm_Qz_Qq zx ny dy - | Qq nx dx, Qz zy => mul_norm_Qz_Qq zy nx dx - | Qq nx dx, Qq ny dy => - let (nx, dy) := irred nx dy in - let (ny, dx) := irred ny dx in - norm_denum (ZZ.mul ny nx) (NN.mul dx dy) - end. - - Lemma spec_mul_norm_Qz_Qq : forall z n d, - [mul_norm_Qz_Qq z n d] == [Qq (ZZ.mul z n) d]. - Proof. - intros z n d; unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt. - destr_eqb; nzsimpl; intros Hz. - qsimpl; rewrite Hz; auto. - destruct Z_le_gt_dec as [LE|GT]. - qsimpl. - rewrite spec_norm_denum. - qsimpl. - rewrite Zdiv_gcd_zero in GT; auto with zarith. - nsubst. rewrite Zdiv_0_l in *; discriminate. - rewrite <- Z.mul_assoc, (Z.mul_comm (ZZ.to_Z n)), Z.mul_assoc. - rewrite Zgcd_div_swap0; try romega. - ring. - Qed. - - Instance strong_spec_mul_norm_Qz_Qq z n d : - forall `(Reduced (Qq n d)), Reduced (mul_norm_Qz_Qq z n d). - Proof. - unfold Reduced. - rewrite 2 strong_spec_red, 2 Qred_iff. - simpl; nzsimpl. - destr_eqb; intros Hd H; simpl in *; nzsimpl. - - unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt. - destr_eqb; intros Hz; simpl; nzsimpl; simpl; auto. - destruct Z_le_gt_dec. - simpl; nzsimpl. - destr_eqb; simpl; nzsimpl; auto with zarith. - unfold norm_denum. destr_eqb; simpl; nzsimpl. - rewrite Hd, Zdiv_0_l; discriminate. - intros _. - destr_eqb; simpl; nzsimpl; auto. - nzsimpl; rewrite Hd, Zdiv_0_l; auto with zarith. - - rewrite Z2Pos.id in H; auto. - unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt. - destr_eqb; intros Hz; simpl; nzsimpl; simpl; auto. - destruct Z_le_gt_dec as [H'|H']. - simpl; nzsimpl. - destr_eqb; simpl; nzsimpl; auto. - intros. - rewrite Z2Pos.id; auto. - apply Zgcd_mult_rel_prime; auto. - generalize (Z.gcd_eq_0_l (ZZ.to_Z z) (NN.to_Z d)) - (Z.gcd_nonneg (ZZ.to_Z z) (NN.to_Z d)); romega. - destr_eqb; simpl; nzsimpl; auto. - unfold norm_denum. - destr_eqb; nzsimpl; simpl; destr_eqb; simpl; auto. - intros; nzsimpl. - rewrite Z2Pos.id; auto. - apply Zgcd_mult_rel_prime. - rewrite Zgcd_1_rel_prime. - apply Zis_gcd_rel_prime. - generalize (NN.spec_pos d); romega. - generalize (Z.gcd_nonneg (ZZ.to_Z z) (NN.to_Z d)); romega. - apply Zgcd_is_gcd. - destruct (Zgcd_is_gcd (ZZ.to_Z z) (NN.to_Z d)) as [ (z0,Hz0) (d0,Hd0) Hzd]. - replace (NN.to_Z d / Z.gcd (ZZ.to_Z z) (NN.to_Z d))%Z with d0. - rewrite Zgcd_1_rel_prime in *. - apply bezout_rel_prime. - destruct (rel_prime_bezout _ _ H) as [u v Huv]. - apply Bezout_intro with u (v*(Z.gcd (ZZ.to_Z z) (NN.to_Z d)))%Z. - rewrite <- Huv; rewrite Hd0 at 2; ring. - rewrite Hd0 at 1. - symmetry; apply Z_div_mult_full; auto with zarith. - Qed. - - Theorem spec_mul_norm : forall x y, [mul_norm x y] == [x] * [y]. - Proof. - intros x y; rewrite <- spec_mul; auto. - unfold mul_norm, mul; destruct x; destruct y. - apply Qeq_refl. - apply spec_mul_norm_Qz_Qq. - rewrite spec_mul_norm_Qz_Qq; qsimpl; ring. - - rename t0 into nx, t3 into dy, t2 into ny, t1 into dx. - destruct (spec_irred nx dy) as (g & Hg). - destruct (spec_irred ny dx) as (g' & Hg'). - assert (Hz := spec_irred_zero nx dy). - assert (Hz':= spec_irred_zero ny dx). - destruct irred as (n1,d1); destruct irred as (n2,d2). - simpl @snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. - rewrite spec_norm_denum. - qsimpl. - - match goal with E : (_ * _ = 0)%Z |- _ => - rewrite Z.mul_eq_0 in E; destruct E as [Eq|Eq] end. - rewrite Eq in *; simpl in *. - rewrite <- Hg2' in *; auto with zarith. - rewrite Eq in *; simpl in *. - rewrite <- Hg2 in *; auto with zarith. - - match goal with E : (_ * _ = 0)%Z |- _ => - rewrite Z.mul_eq_0 in E; destruct E as [Eq|Eq] end. - rewrite Hz' in Eq; rewrite Eq in *; auto with zarith. - rewrite Hz in Eq; rewrite Eq in *; auto with zarith. - - rewrite <- Hg1, <- Hg2, <- Hg1', <- Hg2'; ring. - Qed. - - Instance strong_spec_mul_norm x y : - forall `(Reduced x, Reduced y), Reduced (mul_norm x y). - Proof. - unfold Reduced; intros. - rewrite strong_spec_red, Qred_iff. - destruct x as [zx|nx dx]; destruct y as [zy|ny dy]. - simpl in *; auto with zarith. - simpl. - rewrite <- Qred_iff, <- strong_spec_red, strong_spec_mul_norm_Qz_Qq; auto. - simpl. - rewrite <- Qred_iff, <- strong_spec_red, strong_spec_mul_norm_Qz_Qq; auto. - simpl. - destruct (spec_irred nx dy) as [g Hg]. - destruct (spec_irred ny dx) as [g' Hg']. - assert (Hz := spec_irred_zero nx dy). - assert (Hz':= spec_irred_zero ny dx). - assert (Hgc := strong_spec_irred nx dy). - assert (Hgc' := strong_spec_irred ny dx). - destruct irred as (n1,d1); destruct irred as (n2,d2). - simpl @snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. - - unfold norm_denum; qsimpl. - - assert (NEQ : NN.to_Z dy <> 0%Z) by - (rewrite Hz; intros EQ; rewrite EQ in *; romega). - specialize (Hgc NEQ). - - assert (NEQ' : NN.to_Z dx <> 0%Z) by - (rewrite Hz'; intro EQ; rewrite EQ in *; romega). - specialize (Hgc' NEQ'). - - revert H H0. - rewrite 2 strong_spec_red, 2 Qred_iff; simpl. - destr_eqb; simpl; nzsimpl; try romega; intros. - rewrite Z2Pos.id in *; auto. - - apply Zgcd_mult_rel_prime; rewrite Z.gcd_comm; - apply Zgcd_mult_rel_prime; rewrite Z.gcd_comm; auto. - - rewrite Zgcd_1_rel_prime in *. - apply bezout_rel_prime. - destruct (rel_prime_bezout (ZZ.to_Z ny) (NN.to_Z dy)) as [u v Huv]; trivial. - apply Bezout_intro with (u*g')%Z (v*g)%Z. - rewrite <- Huv, <- Hg1', <- Hg2. ring. - - rewrite Zgcd_1_rel_prime in *. - apply bezout_rel_prime. - destruct (rel_prime_bezout (ZZ.to_Z nx) (NN.to_Z dx)) as [u v Huv]; trivial. - apply Bezout_intro with (u*g)%Z (v*g')%Z. - rewrite <- Huv, <- Hg2', <- Hg1. ring. - Qed. - - Definition inv (x: t): t := - match x with - | Qz z => - match ZZ.compare ZZ.zero z with - | Eq => zero - | Lt => Qq ZZ.one (Zabs_N z) - | Gt => Qq ZZ.minus_one (Zabs_N z) - end - | Qq n d => - match ZZ.compare ZZ.zero n with - | Eq => zero - | Lt => Qq (Z_of_N d) (Zabs_N n) - | Gt => Qq (ZZ.opp (Z_of_N d)) (Zabs_N n) - end - end. - - Theorem spec_inv : forall x, [inv x] == /[x]. - Proof. - destruct x as [ z | n d ]. - (* Qz z *) - simpl. - rewrite ZZ.spec_compare; destr_zcompare. - (* 0 = z *) - rewrite <- H. - simpl; nzsimpl; compute; auto. - (* 0 < z *) - simpl. - destr_eqb; nzsimpl; [ intros; rewrite Z.abs_eq in *; romega | intros _ ]. - set (z':=ZZ.to_Z z) in *; clearbody z'. - red; simpl. - rewrite Z.abs_eq by romega. - rewrite Z2Pos.id by auto. - unfold Qinv; simpl; destruct z'; simpl; auto; discriminate. - (* 0 > z *) - simpl. - destr_eqb; nzsimpl; [ intros; rewrite Z.abs_neq in *; romega | intros _ ]. - set (z':=ZZ.to_Z z) in *; clearbody z'. - red; simpl. - rewrite Z.abs_neq by romega. - rewrite Z2Pos.id by romega. - unfold Qinv; simpl; destruct z'; simpl; auto; discriminate. - (* Qq n d *) - simpl. - rewrite ZZ.spec_compare; destr_zcompare. - (* 0 = n *) - rewrite <- H. - simpl; nzsimpl. - destr_eqb; intros; compute; auto. - (* 0 < n *) - simpl. - destr_eqb; nzsimpl; intros. - intros; rewrite Z.abs_eq in *; romega. - intros; rewrite Z.abs_eq in *; romega. - nsubst; compute; auto. - set (n':=ZZ.to_Z n) in *; clearbody n'. - rewrite Z.abs_eq by romega. - red; simpl. - rewrite Z2Pos.id by auto. - unfold Qinv; simpl; destruct n'; simpl; auto; try discriminate. - rewrite Pos2Z.inj_mul, Z2Pos.id; auto. - (* 0 > n *) - simpl. - destr_eqb; nzsimpl; intros. - intros; rewrite Z.abs_neq in *; romega. - intros; rewrite Z.abs_neq in *; romega. - nsubst; compute; auto. - set (n':=ZZ.to_Z n) in *; clearbody n'. - red; simpl; nzsimpl. - rewrite Z.abs_neq by romega. - rewrite Z2Pos.id by romega. - unfold Qinv; simpl; destruct n'; simpl; auto; try discriminate. - assert (T : forall x, Zneg x = Z.opp (Zpos x)) by auto. - rewrite T, Pos2Z.inj_mul, Z2Pos.id; auto; ring. - Qed. - - Definition inv_norm (x: t): t := - match x with - | Qz z => - match ZZ.compare ZZ.zero z with - | Eq => zero - | Lt => Qq ZZ.one (Zabs_N z) - | Gt => Qq ZZ.minus_one (Zabs_N z) - end - | Qq n d => - if NN.eqb d NN.zero then zero else - match ZZ.compare ZZ.zero n with - | Eq => zero - | Lt => - match ZZ.compare n ZZ.one with - | Gt => Qq (Z_of_N d) (Zabs_N n) - | _ => Qz (Z_of_N d) - end - | Gt => - match ZZ.compare n ZZ.minus_one with - | Lt => Qq (ZZ.opp (Z_of_N d)) (Zabs_N n) - | _ => Qz (ZZ.opp (Z_of_N d)) - end - end - end. - - Theorem spec_inv_norm : forall x, [inv_norm x] == /[x]. - Proof. - intros. - rewrite <- spec_inv. - destruct x as [ z | n d ]. - (* Qz z *) - simpl. - rewrite ZZ.spec_compare; destr_zcompare; auto with qarith. - (* Qq n d *) - simpl; nzsimpl; destr_eqb. - destr_zcompare; simpl; auto with qarith. - destr_eqb; nzsimpl; auto with qarith. - intros _ Hd; rewrite Hd; auto with qarith. - destr_eqb; nzsimpl; auto with qarith. - intros _ Hd; rewrite Hd; auto with qarith. - (* 0 < n *) - destr_zcompare; auto with qarith. - destr_zcompare; nzsimpl; simpl; auto with qarith; intros. - destr_eqb; nzsimpl; [ intros; rewrite Z.abs_eq in *; romega | intros _ ]. - rewrite H0; auto with qarith. - romega. - (* 0 > n *) - destr_zcompare; nzsimpl; simpl; auto with qarith. - destr_eqb; nzsimpl; [ intros; rewrite Z.abs_neq in *; romega | intros _ ]. - rewrite H0; auto with qarith. - romega. - Qed. - - Instance strong_spec_inv_norm x : Reduced x -> Reduced (inv_norm x). - Proof. - unfold Reduced. - intros. - destruct x as [ z | n d ]. - (* Qz *) - simpl; nzsimpl. - rewrite strong_spec_red, Qred_iff. - destr_zcompare; simpl; nzsimpl; auto. - destr_eqb; nzsimpl; simpl; auto. - destr_eqb; nzsimpl; simpl; auto. - (* Qq n d *) - rewrite strong_spec_red, Qred_iff in H; revert H. - simpl; nzsimpl. - destr_eqb; nzsimpl; auto with qarith. - destr_zcompare; simpl; nzsimpl; auto; intros. - (* 0 < n *) - destr_zcompare; simpl; nzsimpl; auto. - destr_eqb; nzsimpl; simpl; auto. - rewrite Z.abs_eq; romega. - intros _. - rewrite strong_spec_norm; simpl; nzsimpl. - destr_eqb; nzsimpl. - rewrite Z.abs_eq; romega. - intros _. - rewrite Qred_iff. - simpl. - rewrite Z.abs_eq; auto with zarith. - rewrite Z2Pos.id in *; auto. - rewrite Z.gcd_comm; auto. - (* 0 > n *) - destr_eqb; nzsimpl; simpl; auto; intros. - destr_zcompare; simpl; nzsimpl; auto. - destr_eqb; nzsimpl. - rewrite Z.abs_neq; romega. - intros _. - rewrite strong_spec_norm; simpl; nzsimpl. - destr_eqb; nzsimpl. - rewrite Z.abs_neq; romega. - intros _. - rewrite Qred_iff. - simpl. - rewrite Z2Pos.id in *; auto. - intros. - rewrite Z.gcd_comm, Z.gcd_abs_l, Z.gcd_comm. - apply Zis_gcd_gcd; auto with zarith. - apply Zis_gcd_minus. - rewrite Z.opp_involutive, <- H1; apply Zgcd_is_gcd. - rewrite Z.abs_neq; romega. - Qed. - - Definition div x y := mul x (inv y). - - Theorem spec_div x y: [div x y] == [x] / [y]. - Proof. - unfold div; rewrite spec_mul; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv; auto. - Qed. - - Definition div_norm x y := mul_norm x (inv_norm y). - - Theorem spec_div_norm x y: [div_norm x y] == [x] / [y]. - Proof. - unfold div_norm; rewrite spec_mul_norm; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv_norm; auto. - Qed. - - Instance strong_spec_div_norm x y - `(Reduced x, Reduced y) : Reduced (div_norm x y). - Proof. - intros; unfold div_norm. - apply strong_spec_mul_norm; auto. - apply strong_spec_inv_norm; auto. - Qed. - - Definition square (x: t): t := - match x with - | Qz zx => Qz (ZZ.square zx) - | Qq nx dx => Qq (ZZ.square nx) (NN.square dx) - end. - - Theorem spec_square : forall x, [square x] == [x] ^ 2. - Proof. - destruct x as [ z | n d ]. - simpl; rewrite ZZ.spec_square; red; auto. - simpl. - destr_eqb; nzsimpl; intros. - apply Qeq_refl. - rewrite NN.spec_square in *; nzsimpl. - rewrite Z.mul_eq_0 in *; romega. - rewrite NN.spec_square in *; nzsimpl; nsubst; romega. - rewrite ZZ.spec_square, NN.spec_square. - red; simpl. - rewrite Pos2Z.inj_mul; rewrite !Z2Pos.id; auto. - apply Z.mul_pos_pos; auto. - Qed. - - Definition power_pos (x : t) p : t := - match x with - | Qz zx => Qz (ZZ.pow_pos zx p) - | Qq nx dx => Qq (ZZ.pow_pos nx p) (NN.pow_pos dx p) - end. - - Theorem spec_power_pos : forall x p, [power_pos x p] == [x] ^ Zpos p. - Proof. - intros [ z | n d ] p; unfold power_pos. - (* Qz *) - simpl. - rewrite ZZ.spec_pow_pos, Qpower_decomp. - red; simpl; f_equal. - now rewrite Pos2Z.inj_pow, Z.pow_1_l. - (* Qq *) - simpl. - rewrite ZZ.spec_pow_pos. - destr_eqb; nzsimpl; intros. - - apply Qeq_sym; apply Qpower_positive_0. - - rewrite NN.spec_pow_pos in *. - assert (0 < NN.to_Z d ^ ' p)%Z by - (apply Z.pow_pos_nonneg; auto with zarith). - romega. - - exfalso. - rewrite NN.spec_pow_pos in *. nsubst. - rewrite Z.pow_0_l' in *; [romega|discriminate]. - - rewrite Qpower_decomp. - red; simpl; do 3 f_equal. - apply Pos2Z.inj. rewrite Pos2Z.inj_pow. - rewrite 2 Z2Pos.id by (generalize (NN.spec_pos d); romega). - now rewrite NN.spec_pow_pos. - Qed. - - Instance strong_spec_power_pos x p `(Reduced x) : Reduced (power_pos x p). - Proof. - destruct x as [z | n d]; simpl; intros. - red; simpl; auto. - red; simpl; intros. - rewrite strong_spec_norm; simpl. - destr_eqb; nzsimpl; intros. - simpl; auto. - rewrite Qred_iff. - revert H. - unfold Reduced; rewrite strong_spec_red, Qred_iff; simpl. - destr_eqb; nzsimpl; simpl; intros. - exfalso. - rewrite NN.spec_pow_pos in *. nsubst. - rewrite Z.pow_0_l' in *; [romega|discriminate]. - rewrite Z2Pos.id in *; auto. - rewrite NN.spec_pow_pos, ZZ.spec_pow_pos; auto. - rewrite Zgcd_1_rel_prime in *. - apply rel_prime_Zpower; auto with zarith. - Qed. - - Definition power (x : t) (z : Z) : t := - match z with - | Z0 => one - | Zpos p => power_pos x p - | Zneg p => inv (power_pos x p) - end. - - Theorem spec_power : forall x z, [power x z] == [x]^z. - Proof. - destruct z. - simpl; nzsimpl; red; auto. - apply spec_power_pos. - simpl. - rewrite spec_inv, spec_power_pos; apply Qeq_refl. - Qed. - - Definition power_norm (x : t) (z : Z) : t := - match z with - | Z0 => one - | Zpos p => power_pos x p - | Zneg p => inv_norm (power_pos x p) - end. - - Theorem spec_power_norm : forall x z, [power_norm x z] == [x]^z. - Proof. - destruct z. - simpl; nzsimpl; red; auto. - apply spec_power_pos. - simpl. - rewrite spec_inv_norm, spec_power_pos; apply Qeq_refl. - Qed. - - Instance strong_spec_power_norm x z : - Reduced x -> Reduced (power_norm x z). - Proof. - destruct z; simpl. - intros _; unfold Reduced; rewrite strong_spec_red. - unfold one. - simpl to_Q; nzsimpl; auto. - intros; apply strong_spec_power_pos; auto. - intros; apply strong_spec_inv_norm; apply strong_spec_power_pos; auto. - Qed. - - - (** Interaction with [Qcanon.Qc] *) - - Open Scope Qc_scope. - - Definition of_Qc q := of_Q (this q). - - Definition to_Qc q := Q2Qc [q]. - - Notation "[[ x ]]" := (to_Qc x). - - Theorem strong_spec_of_Qc : forall q, [of_Qc q] = q. - Proof. - intros (q,Hq); intros. - unfold of_Qc; rewrite strong_spec_of_Q; auto. - Qed. - - Instance strong_spec_of_Qc_bis q : Reduced (of_Qc q). - Proof. - intros; red; rewrite strong_spec_red, strong_spec_of_Qc. - destruct q; simpl; auto. - Qed. - - Theorem spec_of_Qc: forall q, [[of_Qc q]] = q. - Proof. - intros; apply Qc_decomp; simpl; intros. - rewrite strong_spec_of_Qc. apply canon. - Qed. - - Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. - Proof. - intros q; unfold Qcopp, to_Qc, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - rewrite spec_opp, <- Qred_opp, Qred_correct. - apply Qeq_refl. - Qed. - - Theorem spec_oppc_bis : forall q : Qc, [opp (of_Qc q)] = - q. - Proof. - intros. - rewrite <- strong_spec_opp_norm by apply strong_spec_of_Qc_bis. - rewrite strong_spec_red. - symmetry; apply (Qred_complete (-q)%Q). - rewrite spec_opp, strong_spec_of_Qc; auto with qarith. - Qed. - - Theorem spec_comparec: forall q1 q2, - compare q1 q2 = ([[q1]] ?= [[q2]]). - Proof. - unfold Qccompare, to_Qc. - intros q1 q2; rewrite spec_compare; simpl; auto. - apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_addc x y: - [[add x y]] = [[x]] + [[y]]. - Proof. - unfold to_Qc. - transitivity (Q2Qc ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_add; auto. - unfold Qcplus, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_add_normc x y: - [[add_norm x y]] = [[x]] + [[y]]. - Proof. - unfold to_Qc. - transitivity (Q2Qc ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_add_norm; auto. - unfold Qcplus, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_add_normc_bis : forall x y : Qc, - [add_norm (of_Qc x) (of_Qc y)] = x+y. - Proof. - intros. - rewrite <- strong_spec_add_norm by apply strong_spec_of_Qc_bis. - rewrite strong_spec_red. - symmetry; apply (Qred_complete (x+y)%Q). - rewrite spec_add_norm, ! strong_spec_of_Qc; auto with qarith. - Qed. - - Theorem spec_subc x y: [[sub x y]] = [[x]] - [[y]]. - Proof. - unfold sub; rewrite spec_addc; auto. - rewrite spec_oppc; ring. - Qed. - - Theorem spec_sub_normc x y: - [[sub_norm x y]] = [[x]] - [[y]]. - Proof. - unfold sub_norm; rewrite spec_add_normc; auto. - rewrite spec_oppc; ring. - Qed. - - Theorem spec_sub_normc_bis : forall x y : Qc, - [sub_norm (of_Qc x) (of_Qc y)] = x-y. - Proof. - intros. - rewrite <- strong_spec_sub_norm by apply strong_spec_of_Qc_bis. - rewrite strong_spec_red. - symmetry; apply (Qred_complete (x+(-y)%Qc)%Q). - rewrite spec_sub_norm, ! strong_spec_of_Qc. - unfold Qcopp, Q2Qc, this. rewrite Qred_correct ; auto with qarith. - Qed. - - Theorem spec_mulc x y: - [[mul x y]] = [[x]] * [[y]]. - Proof. - unfold to_Qc. - transitivity (Q2Qc ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_mul; auto. - unfold Qcmult, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_mul_normc x y: - [[mul_norm x y]] = [[x]] * [[y]]. - Proof. - unfold to_Qc. - transitivity (Q2Qc ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_mul_norm; auto. - unfold Qcmult, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_mul_normc_bis : forall x y : Qc, - [mul_norm (of_Qc x) (of_Qc y)] = x*y. - Proof. - intros. - rewrite <- strong_spec_mul_norm by apply strong_spec_of_Qc_bis. - rewrite strong_spec_red. - symmetry; apply (Qred_complete (x*y)%Q). - rewrite spec_mul_norm, ! strong_spec_of_Qc; auto with qarith. - Qed. - - Theorem spec_invc x: - [[inv x]] = /[[x]]. - Proof. - unfold to_Qc. - transitivity (Q2Qc (/[x])). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_inv; auto. - unfold Qcinv, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qinv_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_inv_normc x: - [[inv_norm x]] = /[[x]]. - Proof. - unfold to_Qc. - transitivity (Q2Qc (/[x])). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_inv_norm; auto. - unfold Qcinv, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qinv_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_inv_normc_bis : forall x : Qc, - [inv_norm (of_Qc x)] = /x. - Proof. - intros. - rewrite <- strong_spec_inv_norm by apply strong_spec_of_Qc_bis. - rewrite strong_spec_red. - symmetry; apply (Qred_complete (/x)%Q). - rewrite spec_inv_norm, ! strong_spec_of_Qc; auto with qarith. - Qed. - - Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]]. - Proof. - unfold div; rewrite spec_mulc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. - Qed. - - Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]]. - Proof. - unfold div_norm; rewrite spec_mul_normc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_inv_normc; auto. - Qed. - - Theorem spec_div_normc_bis : forall x y : Qc, - [div_norm (of_Qc x) (of_Qc y)] = x/y. - Proof. - intros. - rewrite <- strong_spec_div_norm by apply strong_spec_of_Qc_bis. - rewrite strong_spec_red. - symmetry; apply (Qred_complete (x*(/y)%Qc)%Q). - rewrite spec_div_norm, ! strong_spec_of_Qc. - unfold Qcinv, Q2Qc, this; rewrite Qred_correct; auto with qarith. - Qed. - - Theorem spec_squarec x: [[square x]] = [[x]]^2. - Proof. - unfold to_Qc. - transitivity (Q2Qc ([x]^2)). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_square; auto. - simpl Qcpower. - replace (Q2Qc [x] * 1) with (Q2Qc [x]); try ring. - simpl. - unfold Qcmult, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_power_posc x p: - [[power_pos x p]] = [[x]] ^ Pos.to_nat p. - Proof. - unfold to_Qc. - transitivity (Q2Qc ([x]^Zpos p)). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_power_pos; auto. - induction p using Pos.peano_ind. - simpl; ring. - rewrite Pos2Nat.inj_succ; simpl Qcpower. - rewrite <- IHp; clear IHp. - unfold Qcmult, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - setoid_replace ([x] ^ ' Pos.succ p)%Q with ([x] * [x] ^ ' p)%Q. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - simpl. - rewrite <- Pos.add_1_l. - rewrite Qpower_plus_positive; simpl; apply Qeq_refl. - Qed. - -End Make. diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v deleted file mode 100644 index 8e20fd06..00000000 --- a/theories/Numbers/Rational/SpecViaQ/QSig.v +++ /dev/null @@ -1,229 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Q. - Local Notation "[ x ]" := (to_Q x). - - Definition eq x y := [x] == [y]. - Definition lt x y := [x] < [y]. - Definition le x y := [x] <= [y]. - - Parameter of_Q : Q -> t. - Parameter spec_of_Q: forall x, to_Q (of_Q x) == x. - - Parameter red : t -> t. - Parameter compare : t -> t -> comparison. - Parameter eq_bool : t -> t -> bool. - Parameter max : t -> t -> t. - Parameter min : t -> t -> t. - Parameter zero : t. - Parameter one : t. - Parameter minus_one : t. - Parameter add : t -> t -> t. - Parameter sub : t -> t -> t. - Parameter opp : t -> t. - Parameter mul : t -> t -> t. - Parameter square : t -> t. - Parameter inv : t -> t. - Parameter div : t -> t -> t. - Parameter power : t -> Z -> t. - - Parameter spec_red : forall x, [red x] == [x]. - Parameter strong_spec_red : forall x, [red x] = Qred [x]. - Parameter spec_compare : forall x y, compare x y = ([x] ?= [y]). - Parameter spec_eq_bool : forall x y, eq_bool x y = Qeq_bool [x] [y]. - Parameter spec_max : forall x y, [max x y] == Qmax [x] [y]. - Parameter spec_min : forall x y, [min x y] == Qmin [x] [y]. - Parameter spec_0: [zero] == 0. - Parameter spec_1: [one] == 1. - Parameter spec_m1: [minus_one] == -(1). - Parameter spec_add: forall x y, [add x y] == [x] + [y]. - Parameter spec_sub: forall x y, [sub x y] == [x] - [y]. - Parameter spec_opp: forall x, [opp x] == - [x]. - Parameter spec_mul: forall x y, [mul x y] == [x] * [y]. - Parameter spec_square: forall x, [square x] == [x] ^ 2. - Parameter spec_inv : forall x, [inv x] == / [x]. - Parameter spec_div: forall x y, [div x y] == [x] / [y]. - Parameter spec_power: forall x z, [power x z] == [x] ^ z. - -End QType. - -(** NB: several of the above functions come with [..._norm] variants - that expect reduced arguments and return reduced results. *) - -(** TODO : also speak of specifications via Qcanon ... *) - -Module Type QType_Notation (Import Q : QType). - Notation "[ x ]" := (to_Q x). - Infix "==" := eq (at level 70). - Notation "x != y" := (~x==y) (at level 70). - Infix "<=" := le. - Infix "<" := lt. - Notation "0" := zero. - Notation "1" := one. - Infix "+" := add. - Infix "-" := sub. - Infix "*" := mul. - Notation "- x" := (opp x). - Infix "/" := div. - Notation "/ x" := (inv x). - Infix "^" := power. -End QType_Notation. - -Module Type QType' := QType <+ QType_Notation. - - -Module QProperties (Import Q : QType'). - -(** Conversion to Q *) - -Hint Rewrite - spec_red spec_compare spec_eq_bool spec_min spec_max - spec_add spec_sub spec_opp spec_mul spec_square spec_inv spec_div - spec_power : qsimpl. -Ltac qify := unfold eq, lt, le in *; autorewrite with qsimpl; - try rewrite spec_0 in *; try rewrite spec_1 in *; try rewrite spec_m1 in *. - -(** NB: do not add [spec_0] in the autorewrite database. Otherwise, - after instantiation in BigQ, this lemma become convertible to 0=0, - and autorewrite loops. Idem for [spec_1] and [spec_m1] *) - -(** Morphisms *) - -Ltac solve_wd1 := intros x x' Hx; qify; now rewrite Hx. -Ltac solve_wd2 := intros x x' Hx y y' Hy; qify; now rewrite Hx, Hy. - -Local Obligation Tactic := solve_wd2 || solve_wd1. - -Instance : Measure to_Q. -Instance eq_equiv : Equivalence eq. -Proof. - change eq with (RelCompFun Qeq to_Q); apply _. -Defined. - -Program Instance lt_wd : Proper (eq==>eq==>iff) lt. -Program Instance le_wd : Proper (eq==>eq==>iff) le. -Program Instance red_wd : Proper (eq==>eq) red. -Program Instance compare_wd : Proper (eq==>eq==>Logic.eq) compare. -Program Instance eq_bool_wd : Proper (eq==>eq==>Logic.eq) eq_bool. -Program Instance min_wd : Proper (eq==>eq==>eq) min. -Program Instance max_wd : Proper (eq==>eq==>eq) max. -Program Instance add_wd : Proper (eq==>eq==>eq) add. -Program Instance sub_wd : Proper (eq==>eq==>eq) sub. -Program Instance opp_wd : Proper (eq==>eq) opp. -Program Instance mul_wd : Proper (eq==>eq==>eq) mul. -Program Instance square_wd : Proper (eq==>eq) square. -Program Instance inv_wd : Proper (eq==>eq) inv. -Program Instance div_wd : Proper (eq==>eq==>eq) div. -Program Instance power_wd : Proper (eq==>Logic.eq==>eq) power. - -(** Let's implement [HasCompare] *) - -Lemma compare_spec : forall x y, CompareSpec (x==y) (x 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. diff --git a/theories/Numbers/vo.itarget b/theories/Numbers/vo.itarget deleted file mode 100644 index c69af03f..00000000 --- a/theories/Numbers/vo.itarget +++ /dev/null @@ -1,91 +0,0 @@ -BinNums.vo -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/ZDivFloor.vo -Integer/Abstract/ZDivTrunc.vo -Integer/Abstract/ZDivEucl.vo -Integer/Abstract/ZMaxMin.vo -Integer/Abstract/ZParity.vo -Integer/Abstract/ZPow.vo -Integer/Abstract/ZGcd.vo -Integer/Abstract/ZLcm.vo -Integer/Abstract/ZBits.vo -Integer/Abstract/ZProperties.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/NZParity.vo -NatInt/NZDiv.vo -NatInt/NZPow.vo -NatInt/NZSqrt.vo -NatInt/NZLog.vo -NatInt/NZGcd.vo -NatInt/NZBits.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/Abstract/NMaxMin.vo -Natural/Abstract/NParity.vo -Natural/Abstract/NPow.vo -Natural/Abstract/NSqrt.vo -Natural/Abstract/NLog.vo -Natural/Abstract/NGcd.vo -Natural/Abstract/NLcm.vo -Natural/Abstract/NBits.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/PArith/BinPos.v b/theories/PArith/BinPos.v index 7baf102a..000d895e 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -1,10 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Lt <-> p > q. +Proof. + rewrite compare_cont_Lt_Lt. + unfold gt, le, compare. + now destruct compare_cont; split; try apply comparison_eq_stable. +Qed. + +Lemma compare_cont_Lt_not_Gt p q : + compare_cont Lt p q <> Gt <-> p <= q. +Proof. + apply not_iff_compat, compare_cont_Lt_Gt. +Qed. + +Lemma compare_cont_Gt_not_Lt p q : + compare_cont Gt p q <> Lt <-> p >= q. +Proof. + apply not_iff_compat, compare_cont_Gt_Lt. +Qed. + +Lemma compare_cont_Gt_not_Gt p q : + compare_cont Gt p q <> Gt <-> p < q. +Proof. + rewrite compare_cont_Gt_Gt. + unfold ge, lt, compare. + now destruct compare_cont; split; try apply comparison_eq_stable. +Qed. + (** We can express recursive equations for [compare] *) Lemma compare_xO_xO p q : (p~0 ?= q~0) = (p ?= q). @@ -1625,7 +1655,7 @@ Qed. Lemma sqrtrem_spec p : SqrtSpec (sqrtrem p) p. Proof. -revert p. fix 1. +revert p. fix sqrtrem_spec 1. destruct p; try destruct p; try (constructor; easy); apply sqrtrem_step_spec; auto. Qed. @@ -1875,180 +1905,180 @@ Notation IsNul := Pos.IsNul (only parsing). Notation IsPos := Pos.IsPos (only parsing). Notation IsNeg := Pos.IsNeg (only parsing). -Notation Psucc := Pos.succ (compat "8.3"). -Notation Pplus := Pos.add (compat "8.3"). -Notation Pplus_carry := Pos.add_carry (compat "8.3"). -Notation Ppred := Pos.pred (compat "8.3"). -Notation Piter_op := Pos.iter_op (compat "8.3"). -Notation Piter_op_succ := Pos.iter_op_succ (compat "8.3"). -Notation Pmult_nat := (Pos.iter_op plus) (compat "8.3"). -Notation nat_of_P := Pos.to_nat (compat "8.3"). -Notation P_of_succ_nat := Pos.of_succ_nat (compat "8.3"). -Notation Pdouble_minus_one := Pos.pred_double (compat "8.3"). -Notation positive_mask := Pos.mask (compat "8.3"). -Notation positive_mask_rect := Pos.mask_rect (compat "8.3"). -Notation positive_mask_ind := Pos.mask_ind (compat "8.3"). -Notation positive_mask_rec := Pos.mask_rec (compat "8.3"). -Notation Pdouble_plus_one_mask := Pos.succ_double_mask (compat "8.3"). -Notation Pdouble_mask := Pos.double_mask (compat "8.3"). -Notation Pdouble_minus_two := Pos.double_pred_mask (compat "8.3"). -Notation Pminus_mask := Pos.sub_mask (compat "8.3"). -Notation Pminus_mask_carry := Pos.sub_mask_carry (compat "8.3"). -Notation Pminus := Pos.sub (compat "8.3"). -Notation Pmult := Pos.mul (compat "8.3"). -Notation iter_pos := @Pos.iter (compat "8.3"). -Notation Ppow := Pos.pow (compat "8.3"). -Notation Pdiv2 := Pos.div2 (compat "8.3"). -Notation Pdiv2_up := Pos.div2_up (compat "8.3"). -Notation Psize := Pos.size_nat (compat "8.3"). -Notation Psize_pos := Pos.size (compat "8.3"). -Notation Pcompare x y m := (Pos.compare_cont m x y) (compat "8.3"). -Notation Plt := Pos.lt (compat "8.3"). -Notation Pgt := Pos.gt (compat "8.3"). -Notation Ple := Pos.le (compat "8.3"). -Notation Pge := Pos.ge (compat "8.3"). -Notation Pmin := Pos.min (compat "8.3"). -Notation Pmax := Pos.max (compat "8.3"). -Notation Peqb := Pos.eqb (compat "8.3"). -Notation positive_eq_dec := Pos.eq_dec (compat "8.3"). -Notation xI_succ_xO := Pos.xI_succ_xO (compat "8.3"). -Notation Psucc_discr := Pos.succ_discr (compat "8.3"). +Notation Psucc := Pos.succ (compat "8.6"). +Notation Pplus := Pos.add (only parsing). +Notation Pplus_carry := Pos.add_carry (only parsing). +Notation Ppred := Pos.pred (compat "8.6"). +Notation Piter_op := Pos.iter_op (compat "8.6"). +Notation Piter_op_succ := Pos.iter_op_succ (compat "8.6"). +Notation Pmult_nat := (Pos.iter_op plus) (only parsing). +Notation nat_of_P := Pos.to_nat (only parsing). +Notation P_of_succ_nat := Pos.of_succ_nat (only parsing). +Notation Pdouble_minus_one := Pos.pred_double (only parsing). +Notation positive_mask := Pos.mask (only parsing). +Notation positive_mask_rect := Pos.mask_rect (only parsing). +Notation positive_mask_ind := Pos.mask_ind (only parsing). +Notation positive_mask_rec := Pos.mask_rec (only parsing). +Notation Pdouble_plus_one_mask := Pos.succ_double_mask (only parsing). +Notation Pdouble_mask := Pos.double_mask (compat "8.6"). +Notation Pdouble_minus_two := Pos.double_pred_mask (only parsing). +Notation Pminus_mask := Pos.sub_mask (only parsing). +Notation Pminus_mask_carry := Pos.sub_mask_carry (only parsing). +Notation Pminus := Pos.sub (only parsing). +Notation Pmult := Pos.mul (only parsing). +Notation iter_pos := @Pos.iter (only parsing). +Notation Ppow := Pos.pow (compat "8.6"). +Notation Pdiv2 := Pos.div2 (compat "8.6"). +Notation Pdiv2_up := Pos.div2_up (compat "8.6"). +Notation Psize := Pos.size_nat (only parsing). +Notation Psize_pos := Pos.size (only parsing). +Notation Pcompare x y m := (Pos.compare_cont m x y) (only parsing). +Notation Plt := Pos.lt (compat "8.6"). +Notation Pgt := Pos.gt (compat "8.6"). +Notation Ple := Pos.le (compat "8.6"). +Notation Pge := Pos.ge (compat "8.6"). +Notation Pmin := Pos.min (compat "8.6"). +Notation Pmax := Pos.max (compat "8.6"). +Notation Peqb := Pos.eqb (compat "8.6"). +Notation positive_eq_dec := Pos.eq_dec (only parsing). +Notation xI_succ_xO := Pos.xI_succ_xO (only parsing). +Notation Psucc_discr := Pos.succ_discr (compat "8.6"). Notation Psucc_o_double_minus_one_eq_xO := - Pos.succ_pred_double (compat "8.3"). + Pos.succ_pred_double (only parsing). Notation Pdouble_minus_one_o_succ_eq_xI := - Pos.pred_double_succ (compat "8.3"). -Notation xO_succ_permute := Pos.double_succ (compat "8.3"). + Pos.pred_double_succ (only parsing). +Notation xO_succ_permute := Pos.double_succ (only parsing). Notation double_moins_un_xO_discr := - Pos.pred_double_xO_discr (compat "8.3"). -Notation Psucc_not_one := Pos.succ_not_1 (compat "8.3"). -Notation Ppred_succ := Pos.pred_succ (compat "8.3"). -Notation Psucc_pred := Pos.succ_pred_or (compat "8.3"). -Notation Psucc_inj := Pos.succ_inj (compat "8.3"). -Notation Pplus_carry_spec := Pos.add_carry_spec (compat "8.3"). -Notation Pplus_comm := Pos.add_comm (compat "8.3"). -Notation Pplus_succ_permute_r := Pos.add_succ_r (compat "8.3"). -Notation Pplus_succ_permute_l := Pos.add_succ_l (compat "8.3"). -Notation Pplus_no_neutral := Pos.add_no_neutral (compat "8.3"). -Notation Pplus_carry_plus := Pos.add_carry_add (compat "8.3"). -Notation Pplus_reg_r := Pos.add_reg_r (compat "8.3"). -Notation Pplus_reg_l := Pos.add_reg_l (compat "8.3"). -Notation Pplus_carry_reg_r := Pos.add_carry_reg_r (compat "8.3"). -Notation Pplus_carry_reg_l := Pos.add_carry_reg_l (compat "8.3"). -Notation Pplus_assoc := Pos.add_assoc (compat "8.3"). -Notation Pplus_xO := Pos.add_xO (compat "8.3"). -Notation Pplus_xI_double_minus_one := Pos.add_xI_pred_double (compat "8.3"). -Notation Pplus_xO_double_minus_one := Pos.add_xO_pred_double (compat "8.3"). -Notation Pplus_diag := Pos.add_diag (compat "8.3"). -Notation PeanoView := Pos.PeanoView (compat "8.3"). -Notation PeanoOne := Pos.PeanoOne (compat "8.3"). -Notation PeanoSucc := Pos.PeanoSucc (compat "8.3"). -Notation PeanoView_rect := Pos.PeanoView_rect (compat "8.3"). -Notation PeanoView_ind := Pos.PeanoView_ind (compat "8.3"). -Notation PeanoView_rec := Pos.PeanoView_rec (compat "8.3"). -Notation peanoView_xO := Pos.peanoView_xO (compat "8.3"). -Notation peanoView_xI := Pos.peanoView_xI (compat "8.3"). -Notation peanoView := Pos.peanoView (compat "8.3"). -Notation PeanoView_iter := Pos.PeanoView_iter (compat "8.3"). -Notation eq_dep_eq_positive := Pos.eq_dep_eq_positive (compat "8.3"). -Notation PeanoViewUnique := Pos.PeanoViewUnique (compat "8.3"). -Notation Prect := Pos.peano_rect (compat "8.3"). -Notation Prect_succ := Pos.peano_rect_succ (compat "8.3"). -Notation Prect_base := Pos.peano_rect_base (compat "8.3"). -Notation Prec := Pos.peano_rec (compat "8.3"). -Notation Pind := Pos.peano_ind (compat "8.3"). -Notation Pcase := Pos.peano_case (compat "8.3"). -Notation Pmult_1_r := Pos.mul_1_r (compat "8.3"). -Notation Pmult_Sn_m := Pos.mul_succ_l (compat "8.3"). -Notation Pmult_xO_permute_r := Pos.mul_xO_r (compat "8.3"). -Notation Pmult_xI_permute_r := Pos.mul_xI_r (compat "8.3"). -Notation Pmult_comm := Pos.mul_comm (compat "8.3"). -Notation Pmult_plus_distr_l := Pos.mul_add_distr_l (compat "8.3"). -Notation Pmult_plus_distr_r := Pos.mul_add_distr_r (compat "8.3"). -Notation Pmult_assoc := Pos.mul_assoc (compat "8.3"). -Notation Pmult_xI_mult_xO_discr := Pos.mul_xI_mul_xO_discr (compat "8.3"). -Notation Pmult_xO_discr := Pos.mul_xO_discr (compat "8.3"). -Notation Pmult_reg_r := Pos.mul_reg_r (compat "8.3"). -Notation Pmult_reg_l := Pos.mul_reg_l (compat "8.3"). -Notation Pmult_1_inversion_l := Pos.mul_eq_1_l (compat "8.3"). -Notation Psquare_xO := Pos.square_xO (compat "8.3"). -Notation Psquare_xI := Pos.square_xI (compat "8.3"). -Notation iter_pos_swap_gen := Pos.iter_swap_gen (compat "8.3"). -Notation iter_pos_swap := Pos.iter_swap (compat "8.3"). -Notation iter_pos_succ := Pos.iter_succ (compat "8.3"). -Notation iter_pos_plus := Pos.iter_add (compat "8.3"). -Notation iter_pos_invariant := Pos.iter_invariant (compat "8.3"). -Notation Ppow_1_r := Pos.pow_1_r (compat "8.3"). -Notation Ppow_succ_r := Pos.pow_succ_r (compat "8.3"). -Notation Peqb_refl := Pos.eqb_refl (compat "8.3"). -Notation Peqb_eq := Pos.eqb_eq (compat "8.3"). -Notation Pcompare_refl_id := Pos.compare_cont_refl (compat "8.3"). -Notation Pcompare_eq_iff := Pos.compare_eq_iff (compat "8.3"). -Notation Pcompare_Gt_Lt := Pos.compare_cont_Gt_Lt (compat "8.3"). -Notation Pcompare_eq_Lt := Pos.compare_lt_iff (compat "8.3"). -Notation Pcompare_Lt_Gt := Pos.compare_cont_Lt_Gt (compat "8.3"). - -Notation Pcompare_antisym := Pos.compare_cont_antisym (compat "8.3"). -Notation ZC1 := Pos.gt_lt (compat "8.3"). -Notation ZC2 := Pos.lt_gt (compat "8.3"). -Notation Pcompare_spec := Pos.compare_spec (compat "8.3"). -Notation Pcompare_p_Sp := Pos.lt_succ_diag_r (compat "8.3"). -Notation Pcompare_succ_succ := Pos.compare_succ_succ (compat "8.3"). -Notation Pcompare_1 := Pos.nlt_1_r (compat "8.3"). -Notation Plt_1 := Pos.nlt_1_r (compat "8.3"). -Notation Plt_1_succ := Pos.lt_1_succ (compat "8.3"). -Notation Plt_lt_succ := Pos.lt_lt_succ (compat "8.3"). -Notation Plt_irrefl := Pos.lt_irrefl (compat "8.3"). -Notation Plt_trans := Pos.lt_trans (compat "8.3"). -Notation Plt_ind := Pos.lt_ind (compat "8.3"). -Notation Ple_lteq := Pos.le_lteq (compat "8.3"). -Notation Ple_refl := Pos.le_refl (compat "8.3"). -Notation Ple_lt_trans := Pos.le_lt_trans (compat "8.3"). -Notation Plt_le_trans := Pos.lt_le_trans (compat "8.3"). -Notation Ple_trans := Pos.le_trans (compat "8.3"). -Notation Plt_succ_r := Pos.lt_succ_r (compat "8.3"). -Notation Ple_succ_l := Pos.le_succ_l (compat "8.3"). -Notation Pplus_compare_mono_l := Pos.add_compare_mono_l (compat "8.3"). -Notation Pplus_compare_mono_r := Pos.add_compare_mono_r (compat "8.3"). -Notation Pplus_lt_mono_l := Pos.add_lt_mono_l (compat "8.3"). -Notation Pplus_lt_mono_r := Pos.add_lt_mono_r (compat "8.3"). -Notation Pplus_lt_mono := Pos.add_lt_mono (compat "8.3"). -Notation Pplus_le_mono_l := Pos.add_le_mono_l (compat "8.3"). -Notation Pplus_le_mono_r := Pos.add_le_mono_r (compat "8.3"). -Notation Pplus_le_mono := Pos.add_le_mono (compat "8.3"). -Notation Pmult_compare_mono_l := Pos.mul_compare_mono_l (compat "8.3"). -Notation Pmult_compare_mono_r := Pos.mul_compare_mono_r (compat "8.3"). -Notation Pmult_lt_mono_l := Pos.mul_lt_mono_l (compat "8.3"). -Notation Pmult_lt_mono_r := Pos.mul_lt_mono_r (compat "8.3"). -Notation Pmult_lt_mono := Pos.mul_lt_mono (compat "8.3"). -Notation Pmult_le_mono_l := Pos.mul_le_mono_l (compat "8.3"). -Notation Pmult_le_mono_r := Pos.mul_le_mono_r (compat "8.3"). -Notation Pmult_le_mono := Pos.mul_le_mono (compat "8.3"). -Notation Plt_plus_r := Pos.lt_add_r (compat "8.3"). -Notation Plt_not_plus_l := Pos.lt_not_add_l (compat "8.3"). -Notation Ppow_gt_1 := Pos.pow_gt_1 (compat "8.3"). -Notation Ppred_mask := Pos.pred_mask (compat "8.3"). -Notation Pminus_mask_succ_r := Pos.sub_mask_succ_r (compat "8.3"). -Notation Pminus_mask_carry_spec := Pos.sub_mask_carry_spec (compat "8.3"). -Notation Pminus_succ_r := Pos.sub_succ_r (compat "8.3"). -Notation Pminus_mask_diag := Pos.sub_mask_diag (compat "8.3"). - -Notation Pplus_minus_eq := Pos.add_sub (compat "8.3"). -Notation Pmult_minus_distr_l := Pos.mul_sub_distr_l (compat "8.3"). -Notation Pminus_lt_mono_l := Pos.sub_lt_mono_l (compat "8.3"). -Notation Pminus_compare_mono_l := Pos.sub_compare_mono_l (compat "8.3"). -Notation Pminus_compare_mono_r := Pos.sub_compare_mono_r (compat "8.3"). -Notation Pminus_lt_mono_r := Pos.sub_lt_mono_r (compat "8.3"). -Notation Pminus_decr := Pos.sub_decr (compat "8.3"). -Notation Pminus_xI_xI := Pos.sub_xI_xI (compat "8.3"). -Notation Pplus_minus_assoc := Pos.add_sub_assoc (compat "8.3"). -Notation Pminus_plus_distr := Pos.sub_add_distr (compat "8.3"). -Notation Pminus_minus_distr := Pos.sub_sub_distr (compat "8.3"). -Notation Pminus_mask_Lt := Pos.sub_mask_neg (compat "8.3"). -Notation Pminus_Lt := Pos.sub_lt (compat "8.3"). -Notation Pminus_Eq := Pos.sub_diag (compat "8.3"). -Notation Psize_monotone := Pos.size_nat_monotone (compat "8.3"). -Notation Psize_pos_gt := Pos.size_gt (compat "8.3"). -Notation Psize_pos_le := Pos.size_le (compat "8.3"). + Pos.pred_double_xO_discr (only parsing). +Notation Psucc_not_one := Pos.succ_not_1 (only parsing). +Notation Ppred_succ := Pos.pred_succ (compat "8.6"). +Notation Psucc_pred := Pos.succ_pred_or (only parsing). +Notation Psucc_inj := Pos.succ_inj (compat "8.6"). +Notation Pplus_carry_spec := Pos.add_carry_spec (only parsing). +Notation Pplus_comm := Pos.add_comm (only parsing). +Notation Pplus_succ_permute_r := Pos.add_succ_r (only parsing). +Notation Pplus_succ_permute_l := Pos.add_succ_l (only parsing). +Notation Pplus_no_neutral := Pos.add_no_neutral (only parsing). +Notation Pplus_carry_plus := Pos.add_carry_add (only parsing). +Notation Pplus_reg_r := Pos.add_reg_r (only parsing). +Notation Pplus_reg_l := Pos.add_reg_l (only parsing). +Notation Pplus_carry_reg_r := Pos.add_carry_reg_r (only parsing). +Notation Pplus_carry_reg_l := Pos.add_carry_reg_l (only parsing). +Notation Pplus_assoc := Pos.add_assoc (only parsing). +Notation Pplus_xO := Pos.add_xO (only parsing). +Notation Pplus_xI_double_minus_one := Pos.add_xI_pred_double (only parsing). +Notation Pplus_xO_double_minus_one := Pos.add_xO_pred_double (only parsing). +Notation Pplus_diag := Pos.add_diag (only parsing). +Notation PeanoView := Pos.PeanoView (only parsing). +Notation PeanoOne := Pos.PeanoOne (only parsing). +Notation PeanoSucc := Pos.PeanoSucc (only parsing). +Notation PeanoView_rect := Pos.PeanoView_rect (only parsing). +Notation PeanoView_ind := Pos.PeanoView_ind (only parsing). +Notation PeanoView_rec := Pos.PeanoView_rec (only parsing). +Notation peanoView_xO := Pos.peanoView_xO (only parsing). +Notation peanoView_xI := Pos.peanoView_xI (only parsing). +Notation peanoView := Pos.peanoView (only parsing). +Notation PeanoView_iter := Pos.PeanoView_iter (only parsing). +Notation eq_dep_eq_positive := Pos.eq_dep_eq_positive (only parsing). +Notation PeanoViewUnique := Pos.PeanoViewUnique (only parsing). +Notation Prect := Pos.peano_rect (only parsing). +Notation Prect_succ := Pos.peano_rect_succ (only parsing). +Notation Prect_base := Pos.peano_rect_base (only parsing). +Notation Prec := Pos.peano_rec (only parsing). +Notation Pind := Pos.peano_ind (only parsing). +Notation Pcase := Pos.peano_case (only parsing). +Notation Pmult_1_r := Pos.mul_1_r (only parsing). +Notation Pmult_Sn_m := Pos.mul_succ_l (only parsing). +Notation Pmult_xO_permute_r := Pos.mul_xO_r (only parsing). +Notation Pmult_xI_permute_r := Pos.mul_xI_r (only parsing). +Notation Pmult_comm := Pos.mul_comm (only parsing). +Notation Pmult_plus_distr_l := Pos.mul_add_distr_l (only parsing). +Notation Pmult_plus_distr_r := Pos.mul_add_distr_r (only parsing). +Notation Pmult_assoc := Pos.mul_assoc (only parsing). +Notation Pmult_xI_mult_xO_discr := Pos.mul_xI_mul_xO_discr (only parsing). +Notation Pmult_xO_discr := Pos.mul_xO_discr (only parsing). +Notation Pmult_reg_r := Pos.mul_reg_r (only parsing). +Notation Pmult_reg_l := Pos.mul_reg_l (only parsing). +Notation Pmult_1_inversion_l := Pos.mul_eq_1_l (only parsing). +Notation Psquare_xO := Pos.square_xO (compat "8.6"). +Notation Psquare_xI := Pos.square_xI (compat "8.6"). +Notation iter_pos_swap_gen := Pos.iter_swap_gen (only parsing). +Notation iter_pos_swap := Pos.iter_swap (only parsing). +Notation iter_pos_succ := Pos.iter_succ (only parsing). +Notation iter_pos_plus := Pos.iter_add (only parsing). +Notation iter_pos_invariant := Pos.iter_invariant (only parsing). +Notation Ppow_1_r := Pos.pow_1_r (compat "8.6"). +Notation Ppow_succ_r := Pos.pow_succ_r (compat "8.6"). +Notation Peqb_refl := Pos.eqb_refl (compat "8.6"). +Notation Peqb_eq := Pos.eqb_eq (compat "8.6"). +Notation Pcompare_refl_id := Pos.compare_cont_refl (only parsing). +Notation Pcompare_eq_iff := Pos.compare_eq_iff (only parsing). +Notation Pcompare_Gt_Lt := Pos.compare_cont_Gt_Lt (only parsing). +Notation Pcompare_eq_Lt := Pos.compare_lt_iff (only parsing). +Notation Pcompare_Lt_Gt := Pos.compare_cont_Lt_Gt (only parsing). + +Notation Pcompare_antisym := Pos.compare_cont_antisym (only parsing). +Notation ZC1 := Pos.gt_lt (only parsing). +Notation ZC2 := Pos.lt_gt (only parsing). +Notation Pcompare_spec := Pos.compare_spec (compat "8.6"). +Notation Pcompare_p_Sp := Pos.lt_succ_diag_r (only parsing). +Notation Pcompare_succ_succ := Pos.compare_succ_succ (compat "8.6"). +Notation Pcompare_1 := Pos.nlt_1_r (only parsing). +Notation Plt_1 := Pos.nlt_1_r (only parsing). +Notation Plt_1_succ := Pos.lt_1_succ (compat "8.6"). +Notation Plt_lt_succ := Pos.lt_lt_succ (compat "8.6"). +Notation Plt_irrefl := Pos.lt_irrefl (compat "8.6"). +Notation Plt_trans := Pos.lt_trans (compat "8.6"). +Notation Plt_ind := Pos.lt_ind (compat "8.6"). +Notation Ple_lteq := Pos.le_lteq (compat "8.6"). +Notation Ple_refl := Pos.le_refl (compat "8.6"). +Notation Ple_lt_trans := Pos.le_lt_trans (compat "8.6"). +Notation Plt_le_trans := Pos.lt_le_trans (compat "8.6"). +Notation Ple_trans := Pos.le_trans (compat "8.6"). +Notation Plt_succ_r := Pos.lt_succ_r (compat "8.6"). +Notation Ple_succ_l := Pos.le_succ_l (compat "8.6"). +Notation Pplus_compare_mono_l := Pos.add_compare_mono_l (only parsing). +Notation Pplus_compare_mono_r := Pos.add_compare_mono_r (only parsing). +Notation Pplus_lt_mono_l := Pos.add_lt_mono_l (only parsing). +Notation Pplus_lt_mono_r := Pos.add_lt_mono_r (only parsing). +Notation Pplus_lt_mono := Pos.add_lt_mono (only parsing). +Notation Pplus_le_mono_l := Pos.add_le_mono_l (only parsing). +Notation Pplus_le_mono_r := Pos.add_le_mono_r (only parsing). +Notation Pplus_le_mono := Pos.add_le_mono (only parsing). +Notation Pmult_compare_mono_l := Pos.mul_compare_mono_l (only parsing). +Notation Pmult_compare_mono_r := Pos.mul_compare_mono_r (only parsing). +Notation Pmult_lt_mono_l := Pos.mul_lt_mono_l (only parsing). +Notation Pmult_lt_mono_r := Pos.mul_lt_mono_r (only parsing). +Notation Pmult_lt_mono := Pos.mul_lt_mono (only parsing). +Notation Pmult_le_mono_l := Pos.mul_le_mono_l (only parsing). +Notation Pmult_le_mono_r := Pos.mul_le_mono_r (only parsing). +Notation Pmult_le_mono := Pos.mul_le_mono (only parsing). +Notation Plt_plus_r := Pos.lt_add_r (only parsing). +Notation Plt_not_plus_l := Pos.lt_not_add_l (only parsing). +Notation Ppow_gt_1 := Pos.pow_gt_1 (compat "8.6"). +Notation Ppred_mask := Pos.pred_mask (compat "8.6"). +Notation Pminus_mask_succ_r := Pos.sub_mask_succ_r (only parsing). +Notation Pminus_mask_carry_spec := Pos.sub_mask_carry_spec (only parsing). +Notation Pminus_succ_r := Pos.sub_succ_r (only parsing). +Notation Pminus_mask_diag := Pos.sub_mask_diag (only parsing). + +Notation Pplus_minus_eq := Pos.add_sub (only parsing). +Notation Pmult_minus_distr_l := Pos.mul_sub_distr_l (only parsing). +Notation Pminus_lt_mono_l := Pos.sub_lt_mono_l (only parsing). +Notation Pminus_compare_mono_l := Pos.sub_compare_mono_l (only parsing). +Notation Pminus_compare_mono_r := Pos.sub_compare_mono_r (only parsing). +Notation Pminus_lt_mono_r := Pos.sub_lt_mono_r (only parsing). +Notation Pminus_decr := Pos.sub_decr (only parsing). +Notation Pminus_xI_xI := Pos.sub_xI_xI (only parsing). +Notation Pplus_minus_assoc := Pos.add_sub_assoc (only parsing). +Notation Pminus_plus_distr := Pos.sub_add_distr (only parsing). +Notation Pminus_minus_distr := Pos.sub_sub_distr (only parsing). +Notation Pminus_mask_Lt := Pos.sub_mask_neg (only parsing). +Notation Pminus_Lt := Pos.sub_lt (only parsing). +Notation Pminus_Eq := Pos.sub_diag (only parsing). +Notation Psize_monotone := Pos.size_nat_monotone (only parsing). +Notation Psize_pos_gt := Pos.size_gt (only parsing). +Notation Psize_pos_le := Pos.size_le (only parsing). (** More complex compatibility facts, expressed as lemmas (to preserve scopes for instance) *) diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index 74a292c6..07031474 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -1,10 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* succ (of_succ_nat x) end. +(** ** Conversion with a decimal representation for printing/parsing *) + +Local Notation ten := 1~0~1~0. + +Fixpoint of_uint_acc (d:Decimal.uint)(acc:positive) := + match d with + | Decimal.Nil => acc + | Decimal.D0 l => of_uint_acc l (mul ten acc) + | Decimal.D1 l => of_uint_acc l (add 1 (mul ten acc)) + | Decimal.D2 l => of_uint_acc l (add 1~0 (mul ten acc)) + | Decimal.D3 l => of_uint_acc l (add 1~1 (mul ten acc)) + | Decimal.D4 l => of_uint_acc l (add 1~0~0 (mul ten acc)) + | Decimal.D5 l => of_uint_acc l (add 1~0~1 (mul ten acc)) + | Decimal.D6 l => of_uint_acc l (add 1~1~0 (mul ten acc)) + | Decimal.D7 l => of_uint_acc l (add 1~1~1 (mul ten acc)) + | Decimal.D8 l => of_uint_acc l (add 1~0~0~0 (mul ten acc)) + | Decimal.D9 l => of_uint_acc l (add 1~0~0~1 (mul ten acc)) + end. + +Fixpoint of_uint (d:Decimal.uint) : N := + match d with + | Decimal.Nil => N0 + | Decimal.D0 l => of_uint l + | Decimal.D1 l => Npos (of_uint_acc l 1) + | Decimal.D2 l => Npos (of_uint_acc l 1~0) + | Decimal.D3 l => Npos (of_uint_acc l 1~1) + | Decimal.D4 l => Npos (of_uint_acc l 1~0~0) + | Decimal.D5 l => Npos (of_uint_acc l 1~0~1) + | Decimal.D6 l => Npos (of_uint_acc l 1~1~0) + | Decimal.D7 l => Npos (of_uint_acc l 1~1~1) + | Decimal.D8 l => Npos (of_uint_acc l 1~0~0~0) + | Decimal.D9 l => Npos (of_uint_acc l 1~0~0~1) + end. + +Definition of_int (d:Decimal.int) : option positive := + match d with + | Decimal.Pos d => + match of_uint d with + | N0 => None + | Npos p => Some p + end + | Decimal.Neg _ => None + end. + +Fixpoint to_little_uint p := + match p with + | 1 => Decimal.D1 Decimal.Nil + | p~1 => Decimal.Little.succ_double (to_little_uint p) + | p~0 => Decimal.Little.double (to_little_uint p) + end. + +Definition to_uint p := Decimal.rev (to_little_uint p). + +Definition to_int n := Decimal.Pos (to_uint n). + End Pos. diff --git a/theories/PArith/PArith.v b/theories/PArith/PArith.v index 6ee8d6d7..2be3d07c 100644 --- a/theories/PArith/PArith.v +++ b/theories/PArith/PArith.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* diff --git a/theories/PArith/vo.itarget b/theories/PArith/vo.itarget deleted file mode 100644 index 73044e2c..00000000 --- a/theories/PArith/vo.itarget +++ /dev/null @@ -1,5 +0,0 @@ -BinPosDef.vo -BinPos.vo -Pnat.vo -POrderedType.vo -PArith.vo \ No newline at end of file diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index 644b9b5a..f55093ed 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -1,10 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* B), id ∘ f = f. Proof. intros. - unfold id, compose. - symmetry. apply eta_expansion. + reflexivity. Qed. Lemma compose_id_right : forall A B (f : A -> B), f ∘ id = f. Proof. intros. - unfold id, compose. - symmetry ; apply eta_expansion. + reflexivity. Qed. Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D), @@ -47,9 +47,7 @@ Hint Rewrite <- @compose_assoc : core. Lemma flip_flip : forall A B C, @flip A B C ∘ flip = id. Proof. - unfold flip, compose. intros. - extensionality x ; extensionality y ; extensionality z. reflexivity. Qed. @@ -57,9 +55,7 @@ Qed. Lemma prod_uncurry_curry : forall A B C, @prod_uncurry A B C ∘ prod_curry = id. Proof. - simpl ; intros. - unfold prod_uncurry, prod_curry, compose. - extensionality x ; extensionality y ; extensionality z. + intros. reflexivity. Qed. diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index d6f9bb9d..cf42ed18 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Qeq_bool y x = true. +Proof. + rewrite !Qeq_bool_iff. now symmetry. +Qed. + +Lemma Qeq_bool_trans x y z: Qeq_bool x y = true -> Qeq_bool y z = true -> Qeq_bool x z = true. +Proof. + rewrite !Qeq_bool_iff; apply Qeq_trans. +Qed. + Hint Resolve Qnot_eq_sym : qarith. (** * Addition, multiplication and opposite *) @@ -205,9 +227,7 @@ Infix "/" := Qdiv : Q_scope. (** A light notation for [Zpos] *) -Notation " ' x " := (Zpos x) (at level 20, no associativity) : Z_scope. - -Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z ('b). +Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z (Zpos b). Proof. unfold Qeq. simpl. ring. Qed. @@ -220,9 +240,9 @@ Proof. Open Scope Z_scope. intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *. simpl_mult; ring_simplify. - replace (p1 * 'r2 * 'q2) with (p1 * 'q2 * 'r2) by ring. + replace (p1 * Zpos r2 * Zpos q2) with (p1 * Zpos q2 * Zpos r2) by ring. rewrite H. - replace (r1 * 'p2 * 'q2 * 's2) with (r1 * 's2 * 'p2 * 'q2) by ring. + replace (r1 * Zpos p2 * Zpos q2 * Zpos s2) with (r1 * Zpos s2 * Zpos p2 * Zpos q2) by ring. rewrite H0. ring. Close Scope Z_scope. @@ -233,7 +253,7 @@ Proof. unfold Qeq, Qopp; simpl. Open Scope Z_scope. intros x y H; simpl. - replace (- Qnum x * ' Qden y) with (- (Qnum x * ' Qden y)) by ring. + replace (- Qnum x * Zpos (Qden y)) with (- (Qnum x * Zpos (Qden y))) by ring. rewrite H; ring. Close Scope Z_scope. Qed. @@ -250,9 +270,9 @@ Proof. Open Scope Z_scope. intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *. intros; simpl_mult; ring_simplify. - replace (q1 * s1 * 'p2) with (q1 * 'p2 * s1) by ring. + replace (q1 * s1 * Zpos p2) with (q1 * Zpos p2 * s1) by ring. rewrite <- H. - replace (p1 * r1 * 'q2 * 's2) with (r1 * 's2 * p1 * 'q2) by ring. + replace (p1 * r1 * Zpos q2 * Zpos s2) with (r1 * Zpos s2 * p1 * Zpos q2) by ring. rewrite H0. ring. Close Scope Z_scope. @@ -283,13 +303,13 @@ Proof. unfold Qeq, Qcompare. Open Scope Z_scope. intros (p1,p2) (q1,q2) H (r1,r2) (s1,s2) H'; simpl in *. - rewrite <- (Zcompare_mult_compat (q2*s2) (p1*'r2)). - rewrite <- (Zcompare_mult_compat (p2*r2) (q1*'s2)). - change ('(q2*s2)) with ('q2 * 's2). - change ('(p2*r2)) with ('p2 * 'r2). - replace ('q2 * 's2 * (p1*'r2)) with ((p1*'q2)*'r2*'s2) by ring. + rewrite <- (Zcompare_mult_compat (q2*s2) (p1*Zpos r2)). + rewrite <- (Zcompare_mult_compat (p2*r2) (q1*Zpos s2)). + change (Zpos (q2*s2)) with (Zpos q2 * Zpos s2). + change (Zpos (p2*r2)) with (Zpos p2 * Zpos r2). + replace (Zpos q2 * Zpos s2 * (p1*Zpos r2)) with ((p1*Zpos q2)*Zpos r2*Zpos s2) by ring. rewrite H. - replace ('q2 * 's2 * (r1*'p2)) with ((r1*'s2)*'q2*'p2) by ring. + replace (Zpos q2 * Zpos s2 * (r1*Zpos p2)) with ((r1*Zpos s2)*Zpos q2*Zpos p2) by ring. rewrite H'. f_equal; ring. Close Scope Z_scope. @@ -550,8 +570,8 @@ Lemma Qle_trans : forall x y z, x<=y -> y<=z -> x<=z. Proof. unfold Qle; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros. Open Scope Z_scope. - apply Z.mul_le_mono_pos_r with ('y2); [easy|]. - apply Z.le_trans with (y1 * 'x2 * 'z2). + apply Z.mul_le_mono_pos_r with (Zpos y2); [easy|]. + apply Z.le_trans with (y1 * Zpos x2 * Zpos z2). - rewrite Z.mul_shuffle0. now apply Z.mul_le_mono_pos_r. - rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1). now apply Z.mul_le_mono_pos_r. @@ -598,8 +618,8 @@ Lemma Qle_lt_trans : forall x y z, x<=y -> y x y<=z -> x ring_simplify a b end. rewrite Z.add_comm. apply Z.add_le_mono. - match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end. + match goal with |- ?a <= ?b => ring_simplify z1 t1 (Zpos z2) (Zpos t2) a b end. auto with zarith. - match goal with |- ?a <= ?b => ring_simplify x1 y1 ('x2) ('y2) a b end. + match goal with |- ?a <= ?b => ring_simplify x1 y1 (Zpos x2) (Zpos y2) a b end. auto with zarith. Close Scope Z_scope. Qed. @@ -718,9 +738,9 @@ Proof. match goal with |- ?a < ?b => ring_simplify a b end. rewrite Z.add_comm. apply Z.add_le_lt_mono. - match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end. + match goal with |- ?a <= ?b => ring_simplify z1 t1 (Zpos z2) (Zpos t2) a b end. auto with zarith. - match goal with |- ?a < ?b => ring_simplify x1 y1 ('x2) ('y2) a b end. + match goal with |- ?a < ?b => ring_simplify x1 y1 (Zpos x2) (Zpos y2) a b end. do 2 (apply Z.mul_lt_mono_pos_r;try easy). Close Scope Z_scope. Qed. diff --git a/theories/QArith/QOrderedType.v b/theories/QArith/QOrderedType.v index 25e98f0b..37b4b298 100644 --- a/theories/QArith/QOrderedType.v +++ b/theories/QArith/QOrderedType.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Qred (Qabs x) = Qabs x. Proof. intros H; now rewrite (Qred_abs x), H. Qed. Definition Qcabs (x:Qc) : Qc := {| canon := Qcabs_canon x (canon x) |}. -Notation "[ q ]" := (Qcabs q) (q at next level, format "[ q ]") : Qc_scope. +Notation "[ q ]" := (Qcabs q) : Qc_scope. Ltac Qc_unfolds := unfold Qcabs, Qcminus, Qcopp, Qcplus, Qcmult, Qcle, Q2Qc, this. @@ -126,4 +128,4 @@ Proof. destruct (proj1 (Qcabs_Qcle_condition x 0)) as [A B]. + rewrite H; apply Qcle_refl. + apply Qcle_antisym; auto. -Qed. \ No newline at end of file +Qed. diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index 9f9651d8..1510a7b8 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Z.gcd (Qnum q) (QDen q) = 1%Z. Proof. intros (a,b) H; simpl in *. - generalize (Z.gcd_nonneg a ('b)) (Z.ggcd_correct_divisors a ('b)). + generalize (Z.gcd_nonneg a (Zpos b)) (Z.ggcd_correct_divisors a (Zpos b)). rewrite <- Z.ggcd_gcd. destruct Z.ggcd as (g,(aa,bb)); simpl in *. injection H as <- <-. intros H (_,H'). diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v index bbaf6027..6cbb491b 100644 --- a/theories/QArith/Qfield.v +++ b/theories/QArith/Qfield.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0%R. Proof. -intros; apply not_O_IZR; auto with qarith. +intros. +now apply not_O_IZR. Qed. Hint Resolve IZR_nz Rmult_integral_contrapositive. @@ -48,8 +51,7 @@ assert ((X1 * Y2)%R = (Y1 * X2)%R). apply IZR_eq; auto. clear H. field_simplify_eq; auto. -ring_simplify X1 Y2 (Y2 * X1)%R. -rewrite H0; ring. +rewrite H0; ring. Qed. Lemma Rle_Qle : forall x y : Q, (Q2R x <= Q2R y)%R -> x<=y. @@ -66,10 +68,8 @@ replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto). replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto). apply Rmult_le_compat_r; auto. apply Rmult_le_pos. -unfold X2; replace 0%R with (IZR 0); auto; apply IZR_le; - auto with zarith. -unfold Y2; replace 0%R with (IZR 0); auto; apply IZR_le; - auto with zarith. +now apply IZR_le. +now apply IZR_le. Qed. Lemma Qle_Rle : forall x y : Q, x<=y -> (Q2R x <= Q2R y)%R. @@ -88,10 +88,8 @@ replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto). replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto). apply Rmult_le_compat_r; auto. apply Rmult_le_pos; apply Rlt_le; apply Rinv_0_lt_compat. -unfold X2; replace 0%R with (IZR 0); auto; apply IZR_lt; red; - auto with zarith. -unfold Y2; replace 0%R with (IZR 0); auto; apply IZR_lt; red; - auto with zarith. +now apply IZR_lt. +now apply IZR_lt. Qed. Lemma Rlt_Qlt : forall x y : Q, (Q2R x < Q2R y)%R -> x (Q2R x < Q2R y)%R. @@ -130,10 +126,8 @@ replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto). replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto). apply Rmult_lt_compat_r; auto. apply Rmult_lt_0_compat; apply Rinv_0_lt_compat. -unfold X2; replace 0%R with (IZR 0); auto; apply IZR_lt; red; - auto with zarith. -unfold Y2; replace 0%R with (IZR 0); auto; apply IZR_lt; red; - auto with zarith. +now apply IZR_lt. +now apply IZR_lt. Qed. Lemma Q2R_plus : forall x y : Q, Q2R (x+y) = (Q2R x + Q2R y)%R. @@ -173,8 +167,8 @@ unfold Qinv, Q2R, Qeq; intros (x1, x2). case x1; unfold Qnum, Qden. simpl; intros; elim H; trivial. intros; field; auto. intros; - change (IZR (Zneg x2)) with (- IZR (' x2))%R; - change (IZR (Zneg p)) with (- IZR (' p))%R; + change (IZR (Zneg x2)) with (- IZR (Zpos x2))%R; + change (IZR (Zneg p)) with (- IZR (Zpos p))%R; simpl; field; (*auto 8 with real.*) repeat split; auto; auto with real. Qed. diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index 131214f5..17307c82 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0) by (intro; now subst g). - generalize (Z.ggcd_gcd c ('d)) (Zgcd_is_gcd c ('d)) - (Z.gcd_nonneg c ('d)) (Z.ggcd_correct_divisors c ('d)). + generalize (Z.ggcd_gcd c (Zpos d)) (Zgcd_is_gcd c (Zpos d)) + (Z.gcd_nonneg c (Zpos d)) (Z.ggcd_correct_divisors c (Zpos d)). destruct (Z.ggcd c (Zpos d)) as (g',(cc,dd)). simpl. intros <- Hg'1 Hg'2 (Hg'3,Hg'4). assert (Hg'0 : g' <> 0) by (intro; now subst g'). @@ -101,7 +103,7 @@ Proof. - apply Qred_complete. Qed. -Add Morphism Qred : Qred_comp. +Add Morphism Qred with signature (Qeq ==> Qeq) as Qred_comp. Proof. intros. now rewrite !Qred_correct. Qed. @@ -125,19 +127,19 @@ Proof. intros; unfold Qminus'; apply Qred_correct; auto. Qed. -Add Morphism Qplus' : Qplus'_comp. +Add Morphism Qplus' with signature (Qeq ==> Qeq ==> Qeq) as Qplus'_comp. Proof. intros; unfold Qplus'. rewrite H, H0; auto with qarith. Qed. -Add Morphism Qmult' : Qmult'_comp. +Add Morphism Qmult' with signature (Qeq ==> Qeq ==> Qeq) as Qmult'_comp. Proof. intros; unfold Qmult'. rewrite H, H0; auto with qarith. Qed. -Add Morphism Qminus' : Qminus'_comp. +Add Morphism Qminus' with signature (Qeq ==> Qeq ==> Qeq) as Qminus'_comp. Proof. intros; unfold Qminus'. rewrite H, H0; auto with qarith. diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v index da11c2b1..7f972d56 100644 --- a/theories/QArith/Qring.v +++ b/theories/QArith/Qring.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* An (S x + i)%nat) (/ 2)). diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v index c3ab8edc..c17ad0cf 100644 --- a/theories/Reals/AltSeries.v +++ b/theories/Reals/AltSeries.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* mult_le_compat_l p n m); assumption. - replace n with (S (pred n)). - apply not_O_INR; discriminate. - symmetry ; apply S_pred with 0%nat. - assumption. - replace N with (S (pred N)). - apply not_O_INR; discriminate. - symmetry ; apply S_pred with 0%nat. - assumption. + apply le_INR. + now apply mult_le_compat_l. rewrite mult_INR. - rewrite Rinv_mult_distr. - replace (INR 2) with 2; [ idtac | reflexivity ]. - apply Rmult_lt_reg_l with 2. - prove_sup0. - rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym; [ idtac | discrR ]. - rewrite Rmult_1_l; apply Rmult_lt_reg_l with (INR N). - apply lt_INR_0; assumption. - rewrite <- Rinv_r_sym. - apply Rmult_lt_reg_l with (/ (2 * eps)). - apply Rinv_0_lt_compat; assumption. - rewrite Rmult_1_r; - replace (/ (2 * eps) * (INR N * (2 * eps))) with - (INR N * (2 * eps * / (2 * eps))); [ idtac | ring ]. - rewrite <- Rinv_r_sym. - rewrite Rmult_1_r; replace (INR N) with (IZR (Z.of_nat N)). - rewrite <- H4. - elim H1; intros; assumption. - symmetry ; apply INR_IZR_INZ. - apply prod_neq_R0; - [ discrR | red; intro; rewrite H8 in H; elim (Rlt_irrefl _ H) ]. - apply not_O_INR. - red; intro; rewrite H8 in H5; elim (lt_irrefl _ H5). - replace (INR 2) with 2; [ discrR | reflexivity ]. - apply not_O_INR. - red; intro; rewrite H8 in H5; elim (lt_irrefl _ H5). + apply Rmult_lt_reg_l with (INR N / eps). + apply Rdiv_lt_0_compat with (2 := H). + now apply (lt_INR 0). + replace (_ */ _) with (/(2 * eps)). + replace (_ / _ * _) with (INR N). + rewrite INR_IZR_INZ. + now rewrite <- H4. + field. + now apply Rgt_not_eq. + simpl (INR 2); field; split. + now apply Rgt_not_eq, (lt_INR 0). + now apply Rgt_not_eq. apply Rle_ge; apply PI_tg_pos. apply lt_le_trans with N; assumption. elim H1; intros H5 _. @@ -395,7 +370,6 @@ Proof. elim (Rlt_irrefl _ (Rlt_trans _ _ _ H6 H5)). elim (lt_n_O _ H6). apply le_IZR. - simpl. left; apply Rlt_trans with (/ (2 * eps)). apply Rinv_0_lt_compat; assumption. elim H1; intros; assumption. diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index 6fca9c8a..37240eb7 100644 --- a/theories/Reals/ArithProp.v +++ b/theories/Reals/ArithProp.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* z2 -> IZR z1 <> IZR z2. -Proof. -intros; red; intro; elim H; apply eq_IZR; assumption. -Qed. - Ltac discrR := try match goal with | |- (?X1 <> ?X2) => - change 2 with (IZR 2); - change 1 with (IZR 1); - change 0 with (IZR 0); repeat rewrite <- plus_IZR || rewrite <- mult_IZR || @@ -52,9 +46,6 @@ Ltac prove_sup0 := end. Ltac omega_sup := - change 2 with (IZR 2); - change 1 with (IZR 1); - change 0 with (IZR 0); repeat rewrite <- plus_IZR || rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; @@ -72,9 +63,6 @@ Ltac prove_sup := end. Ltac Rcompute := - change 2 with (IZR 2); - change 1 with (IZR 1); - change 0 with (IZR 0); repeat rewrite <- plus_IZR || rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index 569518f7..3de131ea 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 < INR n. Proof. @@ -1629,7 +1634,7 @@ Hint Resolve lt_INR: real. Lemma lt_1_INR : forall n:nat, (1 < n)%nat -> 1 < INR n. Proof. - intros; replace 1 with (INR 1); auto with real. + apply lt_INR. Qed. Hint Resolve lt_1_INR: real. @@ -1653,17 +1658,16 @@ 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; 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; 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. - apply (Rplus_lt_reg_l 1 (INR n1) (INR n0)). - rewrite Rplus_comm; rewrite (Rplus_comm 1 (INR n0)); trivial. + intros n m. revert n. + induction m ; intros n H. + - elim (Rlt_irrefl 0). + apply Rle_lt_trans with (2 := H). + apply pos_INR. + - destruct n as [|n]. + apply Nat.lt_0_succ. + apply lt_n_S, IHm. + rewrite 2!S_INR in H. + apply Rplus_lt_reg_r with (1 := H). Qed. Hint Resolve INR_lt: real. @@ -1707,14 +1711,10 @@ Hint Resolve not_INR: real. Lemma INR_eq : forall n m:nat, INR n = INR m -> n = m. 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; exfalso; auto. - omega. - symmetry ; cut (m <> n). - intro H3; generalize (not_INR m n H3); intro H4; exfalso; auto. - omega. + intros n m HR. + destruct (dec_eq_nat n m) as [H|H]. + exact H. + now apply not_INR in H. Qed. Hint Resolve INR_eq: real. @@ -1728,7 +1728,8 @@ Hint Resolve INR_le: real. Lemma not_1_INR : forall n:nat, n <> 1%nat -> INR n <> 1. Proof. - replace 1 with (INR 1); auto with real. + intros n. + apply not_INR. Qed. Hint Resolve not_1_INR: real. @@ -1743,24 +1744,40 @@ Proof. intros z; idtac; apply Z_of_nat_complete; assumption. Qed. +Lemma INR_IPR : forall p, INR (Pos.to_nat p) = IPR p. +Proof. + assert (H: forall p, 2 * INR (Pos.to_nat p) = IPR_2 p). + induction p as [p|p|] ; simpl IPR_2. + rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- IHp. + now rewrite (Rplus_comm (2 * _)). + now rewrite Pos2Nat.inj_xO, mult_INR, <- IHp. + apply Rmult_1_r. + intros [p|p|] ; unfold IPR. + rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H. + apply Rplus_comm. + now rewrite Pos2Nat.inj_xO, mult_INR, <- H. + easy. +Qed. + (**********) Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z.of_nat n). Proof. - simple induction n; auto with real. - intros; simpl; rewrite SuccNat2Pos.id_succ; - auto with real. + intros [|n]. + easy. + simpl Z.of_nat. unfold IZR. + now rewrite <- INR_IPR, SuccNat2Pos.id_succ. Qed. Lemma plus_IZR_NEG_POS : forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q). Proof. intros p q; simpl. rewrite Z.pos_sub_spec. - case Pos.compare_spec; intros H; simpl. + case Pos.compare_spec; intros H; unfold IZR. subst. ring. - rewrite Pos2Nat.inj_sub by trivial. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial. rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt). ring. - rewrite Pos2Nat.inj_sub by trivial. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial. rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt). ring. Qed. @@ -1769,26 +1786,18 @@ Qed. Lemma plus_IZR : forall n m:Z, IZR (n + m) = IZR n + IZR m. Proof. intro z; destruct z; intro t; destruct t; intros; auto with real. - simpl; intros; rewrite Pos2Nat.inj_add; auto with real. + simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add. apply plus_INR. apply plus_IZR_NEG_POS. rewrite Z.add_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS. - simpl; intros; rewrite Pos2Nat.inj_add; rewrite plus_INR; - auto with real. + simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add, plus_INR. + apply Ropp_plus_distr. Qed. (**********) Lemma mult_IZR : forall n m:Z, IZR (n * m) = IZR n * IZR m. Proof. - intros z t; case z; case t; simpl; auto with real. - intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real. - intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real. - rewrite Rmult_comm. - rewrite Ropp_mult_distr_l_reverse; auto with real. - apply Ropp_eq_compat; rewrite mult_comm; auto with real. - intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real. - rewrite Ropp_mult_distr_l_reverse; auto with real. - intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real. - rewrite Rmult_opp_opp; auto with real. + intros z t; case z; case t; simpl; auto with real; + unfold IZR; intros m n; rewrite <- 3!INR_IPR, Pos2Nat.inj_mul, mult_INR; ring. Qed. Lemma pow_IZR : forall z n, pow (IZR z) n = IZR (Z.pow z (Z.of_nat n)). @@ -1804,13 +1813,13 @@ Qed. (**********) Lemma succ_IZR : forall n:Z, IZR (Z.succ n) = IZR n + 1. Proof. - intro; change 1 with (IZR 1); unfold Z.succ; apply plus_IZR. + intro; unfold Z.succ; apply plus_IZR. Qed. (**********) Lemma opp_IZR : forall n:Z, IZR (- n) = - IZR n. Proof. - intro z; case z; simpl; auto with real. + intros [|z|z]; unfold IZR; simpl; auto with real. Qed. Definition Ropp_Ropp_IZR := opp_IZR. @@ -1833,10 +1842,12 @@ Qed. Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. Proof. intro z; case z; simpl; intros. - absurd (0 < 0); auto with real. - unfold Z.lt; simpl; trivial. - case Rlt_not_le with (1 := H). - replace 0 with (-0); auto with real. + elim (Rlt_irrefl _ H). + easy. + elim (Rlt_not_le _ _ H). + unfold IZR. + rewrite <- INR_IPR. + auto with real. Qed. (**********) @@ -1852,9 +1863,12 @@ Qed. Lemma eq_IZR_R0 : forall n:Z, IZR n = 0 -> n = 0%Z. Proof. intro z; destruct z; simpl; intros; auto with zarith. - case (Rlt_not_eq 0 (INR (Pos.to_nat p))); auto with real. - case (Rlt_not_eq (- INR (Pos.to_nat p)) 0); auto with real. - apply Ropp_lt_gt_0_contravar. unfold Rgt; apply pos_INR_nat_of_P. + elim Rgt_not_eq with (2 := H). + unfold IZR. rewrite <- INR_IPR. + apply lt_0_INR, Pos2Nat.is_pos. + elim Rlt_not_eq with (2 := H). + unfold IZR. rewrite <- INR_IPR. + apply Ropp_lt_gt_0_contravar, lt_0_INR, Pos2Nat.is_pos. Qed. (**********) @@ -1892,8 +1906,8 @@ Qed. (**********) Lemma le_IZR_R1 : forall n:Z, IZR n <= 1 -> (n <= 1)%Z. Proof. - pattern 1 at 1; replace 1 with (IZR 1); intros; auto. - apply le_IZR; trivial. + intros n. + apply le_IZR. Qed. (**********) @@ -1917,12 +1931,23 @@ Proof. omega. Qed. +Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 <> IZR z2. +Proof. +intros; red; intro; elim H; apply eq_IZR; assumption. +Qed. + +Hint Extern 0 (IZR _ <= IZR _) => apply IZR_le, Zle_bool_imp_le, eq_refl : real. +Hint Extern 0 (IZR _ >= IZR _) => apply Rle_ge, IZR_le, Zle_bool_imp_le, eq_refl : real. +Hint Extern 0 (IZR _ < IZR _) => apply IZR_lt, eq_refl : real. +Hint Extern 0 (IZR _ > IZR _) => apply IZR_lt, eq_refl : real. +Hint Extern 0 (IZR _ <> IZR _) => apply IZR_neq, Zeq_bool_neq, eq_refl : real. + Lemma one_IZR_lt1 : forall n:Z, -1 < IZR n < 1 -> n = 0%Z. Proof. intros z [H1 H2]. apply Z.le_antisymm. apply Z.lt_succ_r; apply lt_IZR; trivial. - replace 0%Z with (Z.succ (-1)); trivial. + change 0%Z with (Z.succ (-1)). apply Z.le_succ_l; apply lt_IZR; trivial. Qed. @@ -1999,10 +2024,34 @@ Lemma double_var : forall r1, r1 = r1 / 2 + r1 / 2. Proof. intro; rewrite <- double; unfold Rdiv; rewrite <- Rmult_assoc; symmetry ; apply Rinv_r_simpl_m. - replace 2 with (INR 2); - [ apply not_0_INR; discriminate | unfold INR; ring ]. + now apply not_0_IZR. +Qed. + +Lemma R_rm : ring_morph + 0%R 1%R Rplus Rmult Rminus Ropp eq + 0%Z 1%Z Zplus Zmult Zminus Z.opp Zeq_bool IZR. +Proof. +constructor ; try easy. +exact plus_IZR. +exact minus_IZR. +exact mult_IZR. +exact opp_IZR. +intros x y H. +apply f_equal. +now apply Zeq_bool_eq. +Qed. + +Lemma Zeq_bool_IZR x y : + IZR x = IZR y -> Zeq_bool x y = true. +Proof. +intros H. +apply Zeq_is_eq_bool. +now apply eq_IZR. Qed. +Add Field RField : Rfield + (completeness Zeq_bool_IZR, morphism R_rm, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]). + (*********************************************************) (** ** Other rules about < and <= *) (*********************************************************) @@ -2017,42 +2066,18 @@ Qed. Lemma le_epsilon : forall r1 r2, (forall eps:R, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2. Proof. - intros x y; intros; elim (Rtotal_order x y); intro. - left; assumption. - elim H0; intro. - right; assumption. - clear H0; generalize (Rgt_minus x y H1); intro H2; change (0 < x - y) in H2. - cut (0 < 2). - intro. - generalize (Rmult_lt_0_compat (x - y) (/ 2) H2 (Rinv_0_lt_compat 2 H0)); - intro H3; generalize (H ((x - y) * / 2) H3); - replace (y + (x - y) * / 2) with ((y + x) * / 2). - intro H4; - generalize (Rmult_le_compat_l 2 x ((y + x) * / 2) (Rlt_le 0 2 H0) H4); - rewrite <- (Rmult_comm ((y + x) * / 2)); rewrite Rmult_assoc; - 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. - replace 2 with (INR 2); [ apply not_0_INR; discriminate | reflexivity ]. - pattern y at 2; replace y with (y / 2 + y / 2). - unfold Rminus, Rdiv. - repeat rewrite Rmult_plus_distr_r. - ring. - cut (forall z:R, 2 * z = z + z). - intro. - rewrite <- (H4 (y / 2)). - unfold Rdiv. - rewrite <- Rmult_assoc; apply Rinv_r_simpl_m. - replace 2 with (INR 2). - apply not_0_INR. - discriminate. - unfold INR; reflexivity. - intro; ring. - cut (0%nat <> 2%nat); - [ intro H0; generalize (lt_0_INR 2 (neq_O_lt 2 H0)); unfold INR; - intro; assumption - | discriminate ]. + intros x y H. + destruct (Rle_or_lt x y) as [H1|H1]. + exact H1. + apply Rplus_le_reg_r with x. + replace (y + x) with (2 * (y + (x - y) * / 2)) by field. + replace (x + x) with (2 * x) by ring. + apply Rmult_le_compat_l. + now apply (IZR_le 0 2). + apply H. + apply Rmult_lt_0_compat. + now apply Rgt_minus. + apply Rinv_0_lt_compat, Rlt_0_2. Qed. (**********) diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v index 924d5117..e12937c7 100644 --- a/theories/Reals/RList.v +++ b/theories/Reals/RList.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* r < IZR (z + 1) -> (z + 1)%Z = up r. Proof. - intros; generalize (Rplus_le_compat_l 1 (IZR z) r H); intro; clear H; - rewrite (Rplus_comm 1 (IZR z)) in H1; rewrite (Rplus_comm 1 r) in H1; - cut (1 = IZR 1); auto with zarith real. - intro; generalize H1; pattern 1 at 1; rewrite H; intro; clear H H1; - rewrite <- (plus_IZR z 1) in H2; apply (tech_up r (z + 1)); - auto with zarith real. + intros. + apply tech_up with (1 := H0). + rewrite plus_IZR. + now apply Rplus_le_compat_r. Qed. (**********) Lemma fp_R0 : frac_part 0 = 0. Proof. - unfold frac_part; unfold Int_part; elim (archimed 0); intros; - unfold Rminus; 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) (eq_refl (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 H H0; omega. + unfold frac_part, Int_part. + replace (up 0) with 1%Z. + now rewrite <- minus_IZR. + destruct (archimed 0) as [H1 H2]. + apply lt_IZR in H1. + rewrite <- minus_IZR in H2. + apply le_IZR in H2. + omega. Qed. (**********) @@ -112,21 +109,12 @@ Lemma base_Int_part : Proof. intro; unfold Int_part; elim (archimed r); intros. split; rewrite <- (Z_R_minus (up r) 1); simpl. - generalize (Rle_minus (IZR (up r) - r) 1 H0); intro; unfold Rminus in H1; - rewrite (Rplus_assoc (IZR (up r)) (- r) (-1)) in H1; - rewrite (Rplus_comm (- r) (-1)) in H1; - rewrite <- (Rplus_assoc (IZR (up r)) (-1) (- r)) in H1; - fold (IZR (up r) - 1) in H1; fold (IZR (up r) - 1 - r) in H1; - 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); - 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. + apply Rminus_le. + replace (IZR (up r) - 1 - r) with (IZR (up r) - r - 1) by ring. + now apply Rle_minus. + apply Rminus_gt. + replace (IZR (up r) - 1 - r - -1) with (IZR (up r) - r) by ring. + now apply Rgt_minus. Qed. (**********) @@ -238,9 +226,7 @@ Proof. rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H; elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0; - 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 (Z_R_minus (Int_part r1) (Int_part r2)) in H. 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; @@ -324,12 +310,12 @@ Proof. rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0; elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; clear a b; rewrite <- (Rplus_opp_l 1) in H0; - rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1) + 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; - cut (1 = IZR 1); auto with zarith real. - intro; rewrite H1 in H; rewrite H1 in H0; clear H1; + auto with zarith real. + change (_ + -1) with (IZR (Int_part r1 - Int_part r2) - 1) in H; 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; @@ -442,9 +428,9 @@ Proof. in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0; elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; clear a b; + change 2 with (1 + 1) in H0; rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0; - cut (1 = IZR 1); auto with zarith real. - intro; rewrite H1 in H0; rewrite H1 in H; clear H1; + auto with zarith real. rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H; @@ -507,9 +493,7 @@ Proof. in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0; elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2))); intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2)); - intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1); - auto with zarith real. - intro; rewrite H in H1; clear H; + intros a b; rewrite b in H0; clear a b. rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1; @@ -536,7 +520,7 @@ Proof. rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))); unfold Rminus; rewrite - (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-1)) + (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-(1))) ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1); trivial with zarith real. Qed. diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v index 445ffcb2..a60bb7cf 100644 --- a/theories/Reals/R_sqr.v +++ b/theories/Reals/R_sqr.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* x = y \/ x = - y. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index a6b1a26e..d4035fad 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* a * Rsqr x + b * x + c = 0. Proof. intros; elim H0; intro. - unfold sol_x1 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv; - repeat rewrite Rsqr_mult; rewrite Rsqr_plus; rewrite <- Rsqr_neg; - rewrite Rsqr_sqrt. - rewrite Rsqr_inv. - unfold Rsqr; repeat rewrite Rinv_mult_distr. - repeat rewrite Rmult_assoc; rewrite (Rmult_comm a). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite Rmult_plus_distr_r. - repeat rewrite Rmult_assoc. - pattern 2 at 2; rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite - (Rmult_plus_distr_r (- b) (sqrt (b * b - 2 * (2 * (a * c)))) (/ 2 * / a)) - . - rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc. - replace - (- b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) + - (b * (- b * (/ 2 * / a)) + - (b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) + c))) with - (b * (- b * (/ 2 * / a)) + c). - unfold Rminus; 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 <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; repeat rewrite Rmult_assoc. - rewrite (Rmult_comm a); rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite <- Rmult_opp_opp. - ring. - apply (cond_nonzero a). - discrR. - discrR. - discrR. - ring. - ring. - discrR. - apply (cond_nonzero a). - discrR. - apply (cond_nonzero a). - apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. - apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. - apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. - assumption. - unfold sol_x2 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv; - repeat rewrite Rsqr_mult; rewrite Rsqr_minus; rewrite <- Rsqr_neg; - rewrite Rsqr_sqrt. - rewrite Rsqr_inv. - unfold Rsqr; repeat rewrite Rinv_mult_distr; - repeat rewrite Rmult_assoc. - rewrite (Rmult_comm a); repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; unfold Rminus; rewrite Rmult_plus_distr_r. - rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc; - pattern 2 at 2; rewrite (Rmult_comm 2). - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; - rewrite - (Rmult_plus_distr_r (- b) (- sqrt (b * b + - (2 * (2 * (a * c))))) - (/ 2 * / a)). - rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc. - rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_involutive. - replace - (b * (sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) + - (b * (- b * (/ 2 * / a)) + - (b * (- sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) + c))) with - (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 <- 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. - rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc. - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; repeat rewrite Rmult_assoc; rewrite (Rmult_comm a); - rewrite Rmult_assoc; rewrite <- Rinv_l_sym. - rewrite Rmult_1_r; rewrite <- Rmult_opp_opp; ring. - apply (cond_nonzero a). - discrR. - discrR. - discrR. - ring. - ring. - discrR. - apply (cond_nonzero a). - discrR. - discrR. - apply (cond_nonzero a). - apply prod_neq_R0; discrR || apply (cond_nonzero a). - apply prod_neq_R0; discrR || apply (cond_nonzero a). - apply prod_neq_R0; discrR || apply (cond_nonzero a). - assumption. + rewrite H1. + unfold sol_x1, Delta, Rsqr. + field_simplify. + rewrite <- (Rsqr_pow2 (sqrt _)), Rsqr_sqrt. + field. + apply a. + apply H. + apply a. + rewrite H1. + unfold sol_x2, Delta, Rsqr. + field_simplify. + rewrite <- (Rsqr_pow2 (sqrt _)), Rsqr_sqrt. + field. + apply a. + apply H. + apply a. Qed. Lemma Rsqr_sol_eq_0_0 : @@ -505,10 +422,10 @@ Proof. rewrite (Rmult_comm (/ a)). rewrite Rmult_assoc. rewrite <- Rinv_mult_distr. - replace (2 * (2 * a) * a) with (Rsqr (2 * a)). + replace (4 * a * a) with (Rsqr (2 * a)). reflexivity. ring_Rsqr. - rewrite <- Rmult_assoc; apply prod_neq_R0; + apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ]. apply (cond_nonzero a). assumption. diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index 88ebb88b..4bde9b60 100644 --- a/theories/Reals/Ranalysis.v +++ b/theories/Reals/Ranalysis.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 l1=0 l2=0 *) @@ -224,11 +225,11 @@ Proof. elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); [ idtac | apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc; - repeat apply prod_neq_R0; + repeat apply prod_neq_R0 ; [ assumption | assumption - | red; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6) - | apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption ] ]. + | now apply Rgt_not_eq + | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. intros alp_f2d H12. cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)). intro. @@ -295,8 +296,10 @@ Proof. elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))); [ idtac | apply Rabs_pos_lt; unfold Rsqr, Rdiv; - repeat rewrite Rinv_mult_distr; repeat apply prod_neq_R0; - try assumption || discrR ]. + repeat apply prod_neq_R0 ; + [ assumption.. + | now apply Rgt_not_eq + | apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption ] ]. intros alp_f2d H11. assert (H12 := derivable_continuous_pt _ _ X). unfold continuity_pt in H12. @@ -380,15 +383,9 @@ Proof. repeat apply prod_neq_R0; try assumption. red; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. - apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; assumption. apply Rinv_neq_0_compat; assumption. discrR. - discrR. - discrR. - discrR. - discrR. apply prod_neq_R0; [ discrR | assumption ]. elim H13; intros. apply H19. @@ -408,16 +405,9 @@ Proof. repeat apply prod_neq_R0; try assumption. red; 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; 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. (***********************************) (* Fifth case *) (* (f1 x)<>0 l1<>0 l2=0 *) diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v index 661bc8c7..94f1757a 100644 --- a/theories/Reals/Ranalysis4.v +++ b/theories/Reals/Ranalysis4.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* R, forall lb ub, (forall x , f lb <= x -> x <= f ub -> lb <= g x <= ub) -> (forall x y, f lb <= x -> x < y -> y <= f ub -> g x < g y). Proof. -intros f g lb ub lb_lt_ub f_incr f_eq_g g_ok x y lb_le_x x_lt_y y_le_ub. - assert (x_encad : f lb <= x <= f ub). - split ; [assumption | apply Rle_trans with (r2:=y) ; [apply Rlt_le|] ; assumption]. - assert (y_encad : f lb <= y <= f ub). - split ; [apply Rle_trans with (r2:=x) ; [|apply Rlt_le] ; assumption | assumption]. - assert (Temp1 : lb <= lb) by intuition ; assert (Temp2 : ub <= ub) by intuition. - assert (gx_encad := g_ok _ (proj1 x_encad) (proj2 x_encad)). - assert (gy_encad := g_ok _ (proj1 y_encad) (proj2 y_encad)). - clear Temp1 Temp2. - case (Rlt_dec (g x) (g y)). - intuition. + intros f g lb ub lb_lt_ub f_incr f_eq_g g_ok x y lb_le_x x_lt_y y_le_ub. + assert (x_encad : f lb <= x <= f ub) by lra. + assert (y_encad : f lb <= y <= f ub) by lra. + assert (gx_encad := g_ok _ (proj1 x_encad) (proj2 x_encad)). + assert (gy_encad := g_ok _ (proj1 y_encad) (proj2 y_encad)). + case (Rlt_dec (g x) (g y)); [ easy |]. intros Hfalse. - assert (Temp := Rnot_lt_le _ _ Hfalse). - assert (Hcontradiction : y <= x). - replace y with (id y) by intuition ; replace x with (id x) by intuition ; - rewrite <- f_eq_g. rewrite <- f_eq_g. - assert (f_incr2 : forall x y, lb <= x -> x <= y -> y < ub -> f x <= f y). + assert (Temp := Rnot_lt_le _ _ Hfalse). + enough (y <= x) by lra. + replace y with (id y) by easy. + replace x with (id x) by easy. + rewrite <- f_eq_g by easy. + rewrite <- f_eq_g by easy. + assert (f_incr2 : forall x y, lb <= x -> x <= y -> y < ub -> f x <= f y). { intros m n lb_le_m m_le_n n_lt_ub. case (m_le_n). - intros ; apply Rlt_le ; apply f_incr ; [| | apply Rlt_le] ; assumption. - intros Hyp ; rewrite Hyp ; apply Req_le ; reflexivity. - apply f_incr2. - intuition. intuition. - Focus 3. intuition. - Focus 2. intuition. - Focus 2. intuition. Focus 2. intuition. - assert (Temp2 : g x <> ub). - intro Hf. - assert (Htemp : (comp f g) x = f ub). - unfold comp ; rewrite Hf ; reflexivity. - rewrite f_eq_g in Htemp ; unfold id in Htemp. - assert (Htemp2 : x < f ub). - apply Rlt_le_trans with (r2:=y) ; intuition. - clear -Htemp Htemp2. fourier. - intuition. intuition. - clear -Temp2 gx_encad. - case (proj2 gx_encad). - intuition. - intro Hfalse ; apply False_ind ; apply Temp2 ; assumption. - apply False_ind. clear - Hcontradiction x_lt_y. fourier. + - intros; apply Rlt_le, f_incr, Rlt_le; assumption. + - intros Hyp; rewrite Hyp; apply Req_le; reflexivity. + } + apply f_incr2; intuition. + enough (g x <> ub) by lra. + intro Hf. + assert (Htemp : (comp f g) x = f ub). { + unfold comp; rewrite Hf; reflexivity. + } + rewrite f_eq_g in Htemp by easy. + unfold id in Htemp. + fourier. Qed. Lemma derivable_pt_id_interv : forall (lb ub x:R), @@ -245,12 +236,8 @@ Lemma IVT_interv_prelim0 : forall (x y:R) (P:R->bool) (N:nat), x <= Dichotomy_ub x y P N <= y /\ x <= Dichotomy_lb x y P N <= y. Proof. assert (Sublemma : forall x y lb ub, lb <= x <= ub /\ lb <= y <= ub -> lb <= (x+y) / 2 <= ub). - intros x y lb ub Hyp. - split. - replace lb with ((lb + lb) * /2) by field. - unfold Rdiv ; apply Rmult_le_compat_r ; intuition. - replace ub with ((ub + ub) * /2) by field. - unfold Rdiv ; apply Rmult_le_compat_r ; intuition. + intros x y lb ub Hyp. + lra. intros x y P N x_lt_y. induction N. simpl ; intuition. @@ -1027,9 +1014,7 @@ Qed. Lemma ub_lt_2_pos : forall x ub lb, lb < x -> x < ub -> 0 < (ub-lb)/2. Proof. intros x ub lb lb_lt_x x_lt_ub. - assert (T : 0 < ub - lb). - fourier. - unfold Rdiv ; apply Rlt_mult_inv_pos ; intuition. +lra. Qed. Definition mkposreal_lb_ub (x lb ub:R) (lb_lt_x:lb -replace a with ((- IZR 3 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * - IZR (Z.of_nat (fact 4)) + - IZR 3 ^ 4 * IZR 2 ^ 2 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * - IZR (Z.of_nat (fact 6)) - - IZR 3 ^ 2 * IZR 2 ^ 4 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 4)) * - IZR (Z.of_nat (fact 6)) + - IZR 2 ^ 6 * IZR (Z.of_nat (fact 2)) * IZR (Z.of_nat (fact 4)) * - IZR (Z.of_nat (fact 6))) / - (IZR 2 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) * - IZR (Z.of_nat (fact 4)) * IZR (Z.of_nat (fact 6))));[ | field; - repeat apply conj;((rewrite <- INR_IZR_INZ; apply INR_fact_neq_0) || - (apply Rgt_not_eq; apply (IZR_lt 0); reflexivity)) ] -end. -rewrite !fact_simpl, !Nat2Z.inj_mul; simpl Z.of_nat. -unfold Rdiv; apply Rmult_lt_0_compat. -unfold Rminus; rewrite !pow_IZR, <- !opp_IZR, <- !mult_IZR, <- !opp_IZR, - <- !plus_IZR; apply (IZR_lt 0); reflexivity. -apply Rinv_0_lt_compat; rewrite !pow_IZR, <- !mult_IZR; apply (IZR_lt 0). -reflexivity. +rewrite !INR_IZR_INZ. +simpl. +field_simplify. +unfold Rdiv. +rewrite Rmult_0_l. +apply Rdiv_lt_0_compat ; now apply IZR_lt. Qed. Lemma PI2_1 : 1 < PI/2. @@ -502,11 +484,11 @@ split. rewrite (Rmult_comm (-1)); simpl ((/(Rabs y + 1)) ^ 0). unfold Rdiv; rewrite Rinv_1, !Rmult_assoc, <- !Rmult_plus_distr_l. apply tmp;[assumption | ]. - rewrite Rplus_assoc, Rmult_1_l; pattern 1 at 3; rewrite <- Rplus_0_r. + rewrite Rplus_assoc, Rmult_1_l; pattern 1 at 2; rewrite <- Rplus_0_r. apply Rplus_lt_compat_l. rewrite <- Rmult_assoc. match goal with |- (?a * (-1)) + _ < 0 => - rewrite <- (Rplus_opp_l a), Ropp_mult_distr_r_reverse, Rmult_1_r + rewrite <- (Rplus_opp_l a); change (-1) with (-(1)); rewrite Ropp_mult_distr_r_reverse, Rmult_1_r end. apply Rplus_lt_compat_l. assert (0 < u ^ 2) by (apply pow_lt; assumption). @@ -853,6 +835,8 @@ intros x Hx eps Heps. apply Rlt_trans with (2 := H). apply Rinv_0_lt_compat. exact Heps. + unfold N. + rewrite INR_IZR_INZ, positive_nat_Z. exact HN. apply lt_INR. omega. @@ -1076,8 +1060,9 @@ apply Rlt_not_eq; apply Rle_lt_trans with 0;[ | apply Rlt_0_1]. assert (t := pow2_ge_0 x); fourier. replace (1 + x ^ 2) with (1 - - (x ^ 2)) by ring; rewrite <- (tech3 _ n dif). apply sum_eq; unfold tg_alt, Datan_seq; intros i _. -rewrite pow_mult, <- Rpow_mult_distr, Ropp_mult_distr_l_reverse, Rmult_1_l. -reflexivity. +rewrite pow_mult, <- Rpow_mult_distr. +f_equal. +ring. Qed. Lemma Datan_seq_increasing : forall x y n, (n > 0)%nat -> 0 <= x < y -> Datan_seq x n < Datan_seq y n. @@ -1165,6 +1150,7 @@ assert (tool : forall a b, a / b - /b = (-1 + a) /b). reflexivity. set (u := 1 + x ^ 2); rewrite tool; unfold Rminus; rewrite <- Rplus_assoc. unfold Rdiv, u. +change (-1) with (-(1)). rewrite Rplus_opp_l, Rplus_0_l, Ropp_mult_distr_l_reverse, Rabs_Ropp. rewrite Rabs_mult; clear tool u. assert (tool : forall k, Rabs ((-x ^ 2) ^ k) = Rabs ((x ^ 2) ^ k)). diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 9fbda92a..6019d4fa 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 - | Zpos n => INR (Pos.to_nat n) - | Zneg n => - INR (Pos.to_nat n) - end. -Arguments IZR z%Z. - (**********************************************************) (** * [R] Archimedean *) (**********************************************************) diff --git a/theories/Reals/Rbase.v b/theories/Reals/Rbase.v index e56ce28d..b63c8e1c 100644 --- a/theories/Reals/Rbase.v +++ b/theories/Reals/Rbase.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* R1 + R1 + | xO p => (R1 + R1) * IPR_2 p + | xI p => (R1 + R1) * (R1 + IPR_2 p) + end. + +Definition IPR (p:positive) : R := + match p with + | xH => R1 + | xO p => IPR_2 p + | xI p => R1 + IPR_2 p + end. +Arguments IPR p%positive : simpl never. + +(**********) +Definition IZR (z:Z) : R := + match z with + | Z0 => R0 + | Zpos n => IPR n + | Zneg n => - IPR n + end. +Arguments IZR z%Z : simpl never. diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v index bd330ac9..dfa5c710 100644 --- a/theories/Reals/Rderiv.v +++ b/theories/Reals/Rderiv.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* -> Z. + +(* the following section should probably be somewhere else, but not sure where *) +Section Z_compl. + +Local Open Scope Z_scope. + +(* Provides a way to reason directly on Z in terms of nats instead of positive *) +Inductive Z_spec (x : Z) : Z -> Type := +| ZintNull : x = 0 -> Z_spec x 0 +| ZintPos (n : nat) : x = n -> Z_spec x n +| ZintNeg (n : nat) : x = - n -> Z_spec x (- n). + +Lemma intP (x : Z) : Z_spec x x. +Proof. + destruct x as [|p|p]. + - now apply ZintNull. + - rewrite <-positive_nat_Z at 2. + apply ZintPos. + now rewrite positive_nat_Z. + - rewrite <-Pos2Z.opp_pos. + rewrite <-positive_nat_Z at 2. + apply ZintNeg. + now rewrite positive_nat_Z. +Qed. + +End Z_compl. + Definition powerRZ (x:R) (n:Z) := match n with | Z0 => 1 @@ -657,6 +690,74 @@ Proof. auto with real. Qed. +Local Open Scope Z_scope. + +Lemma pow_powerRZ (r : R) (n : nat) : + (r ^ n)%R = powerRZ r (Z_of_nat n). +Proof. + induction n; [easy|simpl]. + now rewrite SuccNat2Pos.id_succ. +Qed. + +Lemma powerRZ_ind (P : Z -> R -> R -> Prop) : + (forall x, P 0 x 1%R) -> + (forall x n, P (Z.of_nat n) x (x ^ n)%R) -> + (forall x n, P ((-(Z.of_nat n))%Z) x (Rinv (x ^ n))) -> + forall x (m : Z), P m x (powerRZ x m)%R. +Proof. + intros ? ? ? x m. + destruct (intP m) as [Hm|n Hm|n Hm]. + - easy. + - now rewrite <- pow_powerRZ. + - unfold powerRZ. + destruct n as [|n]; [ easy |]. + rewrite Nat2Z.inj_succ, <- Zpos_P_of_succ_nat, Pos2Z.opp_pos. + now rewrite <- Pos2Z.opp_pos, <- positive_nat_Z. +Qed. + +Lemma powerRZ_inv x alpha : (x <> 0)%R -> powerRZ (/ x) alpha = Rinv (powerRZ x alpha). +Proof. + intros; destruct (intP alpha). + - now simpl; rewrite Rinv_1. + - now rewrite <-!pow_powerRZ, ?Rinv_pow, ?pow_powerRZ. + - unfold powerRZ. + destruct (- n). + + now rewrite Rinv_1. + + now rewrite Rinv_pow. + + now rewrite <-Rinv_pow. +Qed. + +Lemma powerRZ_neg x : forall alpha, x <> R0 -> powerRZ x (- alpha) = powerRZ (/ x) alpha. +Proof. + intros [|n|n] H ; simpl. + - easy. + - now rewrite Rinv_pow. + - rewrite Rinv_pow by now apply Rinv_neq_0_compat. + now rewrite Rinv_involutive. +Qed. + +Lemma powerRZ_mult_distr : + forall m x y, ((0 <= m)%Z \/ (x * y <> 0)%R) -> + (powerRZ (x*y) m = powerRZ x m * powerRZ y m)%R. +Proof. + intros m x0 y0 Hmxy. + destruct (intP m) as [ | | n Hm ]. + - now simpl; rewrite Rmult_1_l. + - now rewrite <- !pow_powerRZ, Rpow_mult_distr. + - destruct Hmxy as [H|H]. + + assert(m = 0) as -> by now omega. + now rewrite <- Hm, Rmult_1_l. + + assert(x0 <> 0)%R by now intros ->; apply H; rewrite Rmult_0_l. + assert(y0 <> 0)%R by now intros ->; apply H; rewrite Rmult_0_r. + rewrite !powerRZ_neg by assumption. + rewrite Rinv_mult_distr by assumption. + now rewrite <- !pow_powerRZ, Rpow_mult_distr. +Qed. + +End PowerRZ. + +Local Infix "^Z" := powerRZ (at level 30, right associativity) : R_scope. + (*******************************) (* For easy interface *) (*******************************) diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v index 7423ffce..6c2f3ac6 100644 --- a/theories/Reals/Rgeom.v +++ b/theories/Reals/Rgeom.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 -> eps * / 2 < eps. Proof. intros. - pattern eps at 2; rewrite <- Rmult_1_r. - repeat rewrite (Rmult_comm eps). - apply Rmult_lt_compat_r. - exact H. - apply Rmult_lt_reg_l with 2. fourier. - rewrite Rmult_1_r; rewrite <- Rinv_r_sym. - fourier. - discrR. Qed. (*********) Lemma Rlt_eps4_eps : forall eps:R, eps > 0 -> eps * / (2 + 2) < eps. Proof. intros. - replace (2 + 2) with 4. - pattern eps at 2; rewrite <- Rmult_1_r. - repeat rewrite (Rmult_comm eps). - apply Rmult_lt_compat_r. - exact H. - apply Rmult_lt_reg_l with 4. - replace 4 with 4. - apply Rmult_lt_0_compat; fourier. - ring. - rewrite Rmult_1_r; rewrite <- Rinv_r_sym. fourier. - discrR. - ring. Qed. (*********) @@ -407,8 +378,7 @@ Proof. generalize (Rplus_lt_compat (R_dist (f x2) l) eps (R_dist (f x2) l') eps H H0); unfold R_dist; 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; + rewrite (Rmult_comm 2 eps); replace (eps *2) with (eps + eps) by ring; generalize (R_dist_tri l l' (f x2)); unfold R_dist; intros; apply diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v index b9a9458c..04f13477 100644 --- a/theories/Reals/Rlogic.v +++ b/theories/Reals/Rlogic.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* IZR v + 1)%R). - apply Zabs_eq. + apply Z.abs_eq. apply Zle_minus_le_0. apply (Zlt_le_succ 1). apply lt_IZR. diff --git a/theories/Reals/Rminmax.v b/theories/Reals/Rminmax.v index 152988dc..7f73f7c1 100644 --- a/theories/Reals/Rminmax.v +++ b/theories/Reals/Rminmax.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* R1 + | O => 1 | S n => Rmult r (pow r n) end. diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index b3ce6fa3..c6fac951 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 <= y -> y < z -> x ^R y < x ^R z. + forall x y z:R, 1 < x -> y < z -> x ^R y < x ^R z. Proof. - intros x y z H H0 H1. + intros x y z H H1. unfold Rpower. apply exp_increasing. apply Rmult_lt_compat_r. @@ -473,7 +458,7 @@ Proof. unfold Rpower; auto. rewrite Rpower_mult. rewrite Rinv_l. - replace 1 with (INR 1); auto. + change 1 with (INR 1). repeat rewrite Rpower_pow; simpl. pattern x at 1; rewrite <- (sqrt_sqrt x (Rlt_le _ _ H)). ring. @@ -490,12 +475,28 @@ Proof. apply exp_Ropp. Qed. +Lemma powerRZ_Rpower x z : (0 < x)%R -> powerRZ x z = Rpower x (IZR z). +Proof. + intros Hx. + assert (x <> 0)%R + by now intros Habs; rewrite Habs in Hx; apply (Rlt_irrefl 0). + destruct (intP z). + - now rewrite Rpower_O. + - rewrite <- pow_powerRZ, <- Rpower_pow by assumption. + now rewrite INR_IZR_INZ. + - rewrite opp_IZR, Rpower_Ropp. + rewrite powerRZ_neg, powerRZ_inv by assumption. + now rewrite <- pow_powerRZ, <- INR_IZR_INZ, Rpower_pow. +Qed. + Theorem Rle_Rpower : - forall e n m:R, 1 < e -> 0 <= n -> n <= m -> e ^R n <= e ^R m. + forall e n m:R, 1 <= e -> n <= m -> e ^R n <= e ^R m. Proof. - intros e n m H H0 H1; case H1. - intros H2; left; apply Rpower_lt; assumption. - intros H2; rewrite H2; right; reflexivity. + intros e n m [H | H]; intros H1. + case H1. + intros H2; left; apply Rpower_lt; assumption. + intros H2; rewrite H2; right; reflexivity. + now rewrite <- H; unfold Rpower; rewrite ln_1, !Rmult_0_r; apply Rle_refl. Qed. Theorem ln_lt_2 : / 2 < ln 2. @@ -505,12 +506,9 @@ Proof. rewrite Rinv_r. apply exp_lt_inv. apply Rle_lt_trans with (1 := exp_le_3). - change (3 < 2 ^R 2). + change (3 < 2 ^R (1 + 1)). repeat rewrite Rpower_plus; repeat rewrite Rpower_1. - repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l; - repeat rewrite Rmult_1_l. - pattern 3 at 1; rewrite <- Rplus_0_r; replace (2 + 2) with (3 + 1); - [ apply Rplus_lt_compat_l; apply Rlt_0_1 | ring ]. + now apply (IZR_lt 3 4). prove_sup0. discrR. Qed. @@ -713,13 +711,18 @@ intros x y z x0 y0; unfold Rpower. rewrite <- exp_plus, ln_mult, Rmult_plus_distr_l; auto. Qed. -Lemma Rle_Rpower_l a b c: 0 <= c -> 0 < a <= b -> Rpower a c <= Rpower b c. +Lemma Rlt_Rpower_l a b c: 0 < c -> 0 < a < b -> a ^R c < b ^R c. +Proof. +intros c0 [a0 ab]; apply exp_increasing. +now apply Rmult_lt_compat_l; auto; apply ln_increasing; fourier. +Qed. + +Lemma Rle_Rpower_l a b c: 0 <= c -> 0 < a <= b -> a ^R c <= b ^R c. Proof. intros [c0 | c0]; [ | intros; rewrite <- c0, !Rpower_O; [apply Rle_refl | |] ]. intros [a0 [ab|ab]]. - left; apply exp_increasing. - now apply Rmult_lt_compat_l; auto; apply ln_increasing; fourier. + now apply Rlt_le, Rlt_Rpower_l;[ | split]; fourier. rewrite ab; apply Rle_refl. apply Rlt_le_trans with a; tauto. tauto. @@ -732,7 +735,7 @@ Definition arcsinh x := ln (x + sqrt (x ^ 2 + 1)). Lemma arcsinh_sinh : forall x, arcsinh (sinh x) = x. intros x; unfold sinh, arcsinh. assert (Rminus_eq_0 : forall r, r - r = 0) by (intros; ring). -pattern 1 at 5; rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus. +rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus. rewrite exp_plus. match goal with |- context[sqrt ?a] => replace a with (((exp x + exp(-x))/2)^2) by field diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v index 883e4e1a..17736af6 100644 --- a/theories/Reals/Rprod.v +++ b/theories/Reals/Rprod.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* { z:R | 0 <= z /\ y = Rsqr z }. Proof. diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index df3b95be..171dba55 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* apply Rmult_lt_reg_r with d;[apply (IZR_lt 0); reflexivity | @@ -198,7 +197,7 @@ match goal with end. unfold Rdiv; rewrite !Rmult_assoc, Rinv_l, Rmult_1_r; [ | apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity]. -repeat (rewrite <- !plus_IZR || rewrite <- !mult_IZR). +rewrite <- !mult_IZR. apply IZR_lt; reflexivity. Qed. @@ -323,6 +322,7 @@ Lemma sin_PI : sin PI = 0. Proof. assert (H := sin2_cos2 PI). rewrite cos_PI in H. + change (-1) with (-(1)) in H. rewrite <- Rsqr_neg in H. rewrite Rsqr_1 in H. cut (Rsqr (sin PI) = 0). @@ -533,9 +533,8 @@ Qed. Lemma sin_PI_x : forall x:R, sin (PI - x) = sin x. Proof. - intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI; rewrite Rmult_0_l; - unfold Rminus in |- *; rewrite Rplus_0_l; rewrite Ropp_mult_distr_l_reverse; - rewrite Ropp_involutive; apply Rmult_1_l. + intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI. + ring. Qed. Lemma sin_period : forall (x:R) (k:nat), sin (x + 2 * INR k * PI) = sin x. @@ -593,9 +592,9 @@ 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 sin2 in H0; unfold Rminus in H0; + 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; change (-1) with (-(1)); rewrite Rplus_opp_l; rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); @@ -603,6 +602,7 @@ Proof. auto with real. cut (sin x < -1). intro; generalize (Ropp_lt_gt_contravar (sin x) (-1) H); + change (-1) with (-(1)); rewrite Ropp_involutive; clear H; intro; generalize (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1) @@ -610,7 +610,7 @@ Proof. 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; + rewrite <- Rplus_assoc; change (-1) with (-(1)); rewrite Rplus_opp_l; rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); @@ -696,41 +696,38 @@ Proof. rewrite <- Rinv_l_sym. do 2 rewrite Rmult_1_r; apply Rle_lt_trans with (INR (fact (2 * n + 1)) * 4). apply Rmult_le_compat_l. - replace 0 with (INR 0); [ idtac | reflexivity ]; apply le_INR; apply le_O_n. - simpl in |- *; rewrite Rmult_1_r; replace 4 with (Rsqr 2); - [ idtac | ring_Rsqr ]; replace (a * a) with (Rsqr a); - [ idtac | reflexivity ]; apply Rsqr_incr_1. + apply pos_INR. + simpl in |- *; rewrite Rmult_1_r; change 4 with (Rsqr 2); + apply Rsqr_incr_1. apply Rle_trans with (PI / 2); [ assumption | unfold Rdiv in |- *; apply Rmult_le_reg_l with 2; [ prove_sup0 | rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m; - [ replace 4 with 4; [ apply PI_4 | ring ] | discrR ] ] ]. + [ apply PI_4 | discrR ] ] ]. left; assumption. left; prove_sup0. rewrite H1; replace (2 * n + 1 + 2)%nat with (S (S (2 * n + 1))). do 2 rewrite fact_simpl; do 2 rewrite mult_INR. repeat rewrite <- Rmult_assoc. rewrite <- (Rmult_comm (INR (fact (2 * n + 1)))). - rewrite Rmult_assoc. apply Rmult_lt_compat_l. apply lt_INR_0; apply neq_O_lt. assert (H2 := fact_neq_0 (2 * n + 1)). red in |- *; intro; elim H2; symmetry in |- *; assumption. do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; set (x := INR n); unfold INR in |- *. - replace ((2 * x + 1 + 1 + 1) * (2 * x + 1 + 1)) with (4 * x * x + 10 * x + 6); + replace (((1 + 1) * x + 1 + 1 + 1) * ((1 + 1) * x + 1 + 1)) with (4 * x * x + 10 * x + 6); [ idtac | ring ]. - apply Rplus_lt_reg_l with (-4); rewrite Rplus_opp_l; - replace (-4 + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2); + apply Rplus_lt_reg_l with (-(4)); rewrite Rplus_opp_l; + replace (-(4) + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2); [ idtac | ring ]. apply Rplus_le_lt_0_compat. cut (0 <= x). intro; apply Rplus_le_le_0_compat; repeat apply Rmult_le_pos; assumption || left; prove_sup. - unfold x in |- *; replace 0 with (INR 0); - [ apply le_INR; apply le_O_n | reflexivity ]. - prove_sup0. + apply pos_INR. + now apply IZR_lt. ring. apply INR_fact_neq_0. apply INR_fact_neq_0. @@ -738,39 +735,33 @@ Proof. Qed. Lemma SIN : forall a:R, 0 <= a -> a <= PI -> sin_lb a <= sin a <= sin_ub a. +Proof. intros; unfold sin_lb, sin_ub in |- *; apply (sin_bound a 1 H H0). Qed. Lemma COS : forall a:R, - PI / 2 <= a -> a <= PI / 2 -> cos_lb a <= cos a <= cos_ub a. +Proof. intros; unfold cos_lb, cos_ub in |- *; apply (cos_bound a 1 H H0). Qed. (**********) Lemma _PI2_RLT_0 : - (PI / 2) < 0. Proof. - rewrite <- Ropp_0; apply Ropp_lt_contravar; apply PI2_RGT_0. + assert (H := PI_RGT_0). + fourier. Qed. Lemma PI4_RLT_PI2 : PI / 4 < PI / 2. Proof. - unfold Rdiv in |- *; apply Rmult_lt_compat_l. - apply PI_RGT_0. - apply Rinv_lt_contravar. - apply Rmult_lt_0_compat; prove_sup0. - pattern 2 at 1 in |- *; rewrite <- Rplus_0_r. - replace 4 with (2 + 2); [ apply Rplus_lt_compat_l; prove_sup0 | ring ]. + assert (H := PI_RGT_0). + fourier. Qed. Lemma PI2_Rlt_PI : PI / 2 < PI. Proof. - unfold Rdiv in |- *; pattern PI at 2 in |- *; rewrite <- Rmult_1_r. - apply Rmult_lt_compat_l. - apply PI_RGT_0. - pattern 1 at 3 in |- *; rewrite <- Rinv_1; apply Rinv_lt_contravar. - rewrite Rmult_1_l; prove_sup0. - pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; - apply Rlt_0_1. + assert (H := PI_RGT_0). + fourier. Qed. (***************************************************) @@ -787,12 +778,10 @@ Proof. rewrite H3; rewrite sin_PI2; apply Rlt_0_1. rewrite <- sin_PI_x; generalize (Ropp_gt_lt_contravar x (PI / 2) H3); intro H4; generalize (Rplus_lt_compat_l PI (- x) (- (PI / 2)) H4). - replace (PI + - x) with (PI - x). replace (PI + - (PI / 2)) with (PI / 2). intro H5; generalize (Ropp_lt_gt_contravar x PI H0); intro H6; change (- PI < - x) in H6; generalize (Rplus_lt_compat_l PI (- PI) (- x) H6). rewrite Rplus_opp_r. - replace (PI + - x) with (PI - x). intro H7; elim (SIN (PI - x) (Rlt_le 0 (PI - x) H7) @@ -800,9 +789,7 @@ Proof. intros H8 _; generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5)); intro H9; apply (Rlt_le_trans 0 (sin_lb (PI - x)) (sin (PI - x)) H9 H8). - reflexivity. - pattern PI at 2 in |- *; rewrite double_var; ring. - reflexivity. + field. Qed. Theorem cos_gt_0 : forall x:R, - (PI / 2) < x -> x < PI / 2 -> 0 < cos x. @@ -855,16 +842,12 @@ Proof. rewrite <- (Ropp_involutive (cos x)); apply Ropp_le_ge_contravar; rewrite <- neg_cos; replace (x + PI) with (x - PI + 2 * INR 1 * PI). rewrite cos_period; apply cos_ge_0. - replace (- (PI / 2)) with (- PI + PI / 2). + replace (- (PI / 2)) with (- PI + PI / 2) by field. unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_le_compat_l; assumption. - pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr; - ring. unfold Rminus in |- *; rewrite Rplus_comm; - replace (PI / 2) with (- PI + 3 * (PI / 2)). + replace (PI / 2) with (- PI + 3 * (PI / 2)) by field. apply Rplus_le_compat_l; assumption. - pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr; - ring. unfold INR in |- *; ring. Qed. @@ -905,16 +888,12 @@ Proof. apply Ropp_lt_gt_contravar; rewrite <- neg_cos; replace (x + PI) with (x - PI + 2 * INR 1 * PI). rewrite cos_period; apply cos_gt_0. - replace (- (PI / 2)) with (- PI + PI / 2). + replace (- (PI / 2)) with (- PI + PI / 2) by field. 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. unfold Rminus in |- *; rewrite Rplus_comm; - replace (PI / 2) with (- PI + 3 * (PI / 2)). + replace (PI / 2) with (- PI + 3 * (PI / 2)) by field. apply Rplus_lt_compat_l; assumption. - pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr; - ring. unfold INR in |- *; ring. Qed. @@ -951,7 +930,7 @@ Lemma cos_ge_0_3PI2 : forall x:R, 3 * (PI / 2) <= x -> x <= 2 * PI -> 0 <= cos x. Proof. intros; rewrite <- cos_neg; rewrite <- (cos_period (- x) 1); - unfold INR in |- *; replace (- x + 2 * 1 * PI) with (2 * PI - x). + unfold INR in |- *; replace (- x + 2 * 1 * PI) with (2 * PI - x) by ring. generalize (Ropp_le_ge_contravar x (2 * PI) H0); intro H1; generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1; intro H1; generalize (Rplus_le_compat_l (2 * PI) (- (2 * PI)) (- x) H1). @@ -960,36 +939,30 @@ Proof. 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). + replace (2 * PI + - (3 * (PI / 2))) with (PI / 2) by field. intro H4; apply (cos_ge_0 (2 * PI - x) (Rlt_le (- (PI / 2)) (2 * PI - x) (Rlt_le_trans (- (PI / 2)) 0 (2 * PI - x) _PI2_RLT_0 H2)) H4). - rewrite double; pattern PI at 2 3 in |- *; rewrite double_var; ring. - ring. Qed. Lemma form1 : forall p q:R, cos p + cos q = 2 * cos ((p - q) / 2) * cos ((p + q) / 2). Proof. intros p q; pattern p at 1 in |- *; - replace p with ((p - q) / 2 + (p + q) / 2). - rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2). + replace p with ((p - q) / 2 + (p + q) / 2) by field. + rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2) by field. rewrite cos_plus; rewrite cos_minus; ring. - pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring. - pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring. Qed. Lemma form2 : forall p q:R, cos p - cos q = -2 * sin ((p - q) / 2) * sin ((p + q) / 2). Proof. intros p q; pattern p at 1 in |- *; - replace p with ((p - q) / 2 + (p + q) / 2). - rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2). + replace p with ((p - q) / 2 + (p + q) / 2) by field. + rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2) by field. rewrite cos_plus; rewrite cos_minus; ring. - pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring. - pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring. Qed. Lemma form3 : @@ -1007,11 +980,9 @@ Lemma form4 : forall p q:R, sin p - sin q = 2 * cos ((p + q) / 2) * sin ((p - q) / 2). Proof. intros p q; pattern p at 1 in |- *; - replace p with ((p - q) / 2 + (p + q) / 2). - pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2). + replace p with ((p - q) / 2 + (p + q) / 2) by field. + pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2) by field. rewrite sin_plus; rewrite sin_minus; ring. - pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring. - pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring. Qed. @@ -1067,13 +1038,13 @@ Proof. 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). + replace (- (PI / 2) + - (PI / 2)) with (- PI) by field. intro H5; generalize (Rmult_le_compat_l (/ 2) (- PI) (x + y) (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H5). - replace (/ 2 * (x + y)) with ((x + y) / 2). - replace (/ 2 * - PI) with (- (PI / 2)). + replace (/ 2 * (x + y)) with ((x + y) / 2) by apply Rmult_comm. + replace (/ 2 * - PI) with (- (PI / 2)) by field. clear H5; intro H5; elim H4; intro H40. elim H5; intro H50. generalize (cos_gt_0 ((x + y) / 2) H50 H40); intro H6; @@ -1095,13 +1066,6 @@ Proof. rewrite H40 in H3; assert (H50 := cos_PI2); unfold Rdiv in H50; rewrite H50 in H3; rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3; elim (Rlt_irrefl 0 H3). - unfold Rdiv in |- *. - rewrite <- Ropp_mult_distr_l_reverse. - apply Rmult_comm. - unfold Rdiv in |- *; apply Rmult_comm. - pattern PI at 1 in |- *; rewrite double_var. - rewrite Ropp_plus_distr. - reflexivity. Qed. Lemma sin_increasing_1 : @@ -1111,43 +1075,42 @@ Lemma sin_increasing_1 : Proof. intros; generalize (Rplus_lt_compat_l x x y H3); intro H4; generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) x H H); - replace (- (PI / 2) + - (PI / 2)) with (- PI). + replace (- (PI / 2) + - (PI / 2)) with (- PI) by field. assert (Hyp : 0 < 2). prove_sup0. intro H5; generalize (Rle_lt_trans (- PI) (x + x) (x + y) H5 H4); intro H6; generalize (Rmult_lt_compat_l (/ 2) (- PI) (x + y) (Rinv_0_lt_compat 2 Hyp) H6); - replace (/ 2 * - PI) with (- (PI / 2)). - replace (/ 2 * (x + y)) with ((x + y) / 2). + replace (/ 2 * - PI) with (- (PI / 2)) by field. + replace (/ 2 * (x + y)) with ((x + y) / 2) by apply Rmult_comm. clear H4 H5 H6; intro H4; generalize (Rplus_lt_compat_l y x y H3); intro H5; rewrite Rplus_comm in H5; generalize (Rplus_le_compat y (PI / 2) y (PI / 2) H2 H2). rewrite <- double_var. intro H6; generalize (Rlt_le_trans (x + y) (y + y) PI H5 H6); intro H7; generalize (Rmult_lt_compat_l (/ 2) (x + y) PI (Rinv_0_lt_compat 2 Hyp) H7); - replace (/ 2 * PI) with (PI / 2). - replace (/ 2 * (x + y)) with ((x + y) / 2). + replace (/ 2 * PI) with (PI / 2) by apply Rmult_comm. + replace (/ 2 * (x + y)) with ((x + y) / 2) by apply Rmult_comm. clear H5 H6 H7; intro H5; generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1); rewrite Ropp_involutive; clear H1; intro H1; generalize (Rge_le (PI / 2) (- y) H1); clear H1; intro H1; generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2; intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2); clear H2; intro H2; generalize (Rplus_lt_compat_l (- y) x y H3); - replace (- y + x) with (x - y). + replace (- y + x) with (x - y) by apply Rplus_comm. rewrite Rplus_opp_l. intro H6; generalize (Rmult_lt_compat_l (/ 2) (x - y) 0 (Rinv_0_lt_compat 2 Hyp) H6); - rewrite Rmult_0_r; replace (/ 2 * (x - y)) with ((x - y) / 2). + rewrite Rmult_0_r; replace (/ 2 * (x - y)) with ((x - y) / 2) by apply Rmult_comm. clear H6; intro H6; generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) (- y) H H2); - replace (- (PI / 2) + - (PI / 2)) with (- PI). - replace (x + - y) with (x - y). + replace (- (PI / 2) + - (PI / 2)) with (- PI) by field. intro H7; generalize (Rmult_le_compat_l (/ 2) (- PI) (x - y) (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H7); - replace (/ 2 * - PI) with (- (PI / 2)). - replace (/ 2 * (x - y)) with ((x - y) / 2). + replace (/ 2 * - PI) with (- (PI / 2)) by field. + replace (/ 2 * (x - y)) with ((x - y) / 2) by apply Rmult_comm. clear H7; intro H7; clear H H0 H1 H2; apply Rminus_lt; rewrite form4; generalize (cos_gt_0 ((x + y) / 2) H4 H5); intro H8; generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8); @@ -1162,23 +1125,6 @@ Proof. 2 * cos ((x + y) / 2)) H10 H8); intro H11; rewrite Rmult_0_r in H11; rewrite Rmult_comm; assumption. apply Ropp_lt_gt_contravar; apply PI2_Rlt_PI. - unfold Rdiv in |- *; apply Rmult_comm. - unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_comm. - reflexivity. - pattern PI at 1 in |- *; rewrite double_var. - rewrite Ropp_plus_distr. - reflexivity. - unfold Rdiv in |- *; apply Rmult_comm. - unfold Rminus in |- *; apply Rplus_comm. - unfold Rdiv in |- *; apply Rmult_comm. - unfold Rdiv in |- *; apply Rmult_comm. - unfold Rdiv in |- *; apply Rmult_comm. - unfold Rdiv in |- *. - rewrite <- Ropp_mult_distr_l_reverse. - apply Rmult_comm. - pattern PI at 1 in |- *; rewrite double_var. - rewrite Ropp_plus_distr. - reflexivity. Qed. Lemma sin_decreasing_0 : @@ -1193,33 +1139,16 @@ Proof. generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0); generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1); generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2); - replace (- PI + x) with (x - PI). - replace (- PI + PI / 2) with (- (PI / 2)). - replace (- PI + y) with (y - PI). - replace (- PI + 3 * (PI / 2)) with (PI / 2). - replace (- (PI - x)) with (x - PI). - replace (- (PI - y)) with (y - PI). + replace (- PI + x) with (x - PI) by apply Rplus_comm. + replace (- PI + PI / 2) with (- (PI / 2)) by field. + replace (- PI + y) with (y - PI) by apply Rplus_comm. + replace (- PI + 3 * (PI / 2)) with (PI / 2) by field. + replace (- (PI - x)) with (x - PI) by ring. + replace (- (PI - y)) with (y - PI) by ring. intros; change (sin (y - PI) < sin (x - PI)) in H8; - apply Rplus_lt_reg_l with (- PI); rewrite Rplus_comm; - replace (y + - PI) with (y - PI). - rewrite Rplus_comm; replace (x + - PI) with (x - PI). + apply Rplus_lt_reg_l with (- PI); rewrite Rplus_comm. + rewrite (Rplus_comm _ x). apply (sin_increasing_0 (y - PI) (x - PI) H4 H5 H6 H7 H8). - reflexivity. - reflexivity. - unfold Rminus in |- *; rewrite Ropp_plus_distr. - rewrite Ropp_involutive. - apply Rplus_comm. - unfold Rminus in |- *; rewrite Ropp_plus_distr. - rewrite Ropp_involutive. - apply Rplus_comm. - pattern PI at 2 in |- *; rewrite double_var. - rewrite Ropp_plus_distr. - ring. - unfold Rminus in |- *; apply Rplus_comm. - pattern PI at 2 in |- *; rewrite double_var. - rewrite Ropp_plus_distr. - ring. - unfold Rminus in |- *; apply Rplus_comm. Qed. Lemma sin_decreasing_1 : @@ -1233,24 +1162,14 @@ Proof. generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1); generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2); generalize (Rplus_lt_compat_l (- PI) x y H3); - replace (- PI + PI / 2) with (- (PI / 2)). - replace (- PI + y) with (y - PI). - replace (- PI + 3 * (PI / 2)) with (PI / 2). - replace (- PI + x) with (x - PI). + replace (- PI + PI / 2) with (- (PI / 2)) by field. + replace (- PI + y) with (y - PI) by apply Rplus_comm. + replace (- PI + 3 * (PI / 2)) with (PI / 2) by field. + replace (- PI + x) with (x - PI) by apply Rplus_comm. intros; apply Ropp_lt_cancel; repeat rewrite <- sin_neg; - replace (- (PI - x)) with (x - PI). - replace (- (PI - y)) with (y - PI). + replace (- (PI - x)) with (x - PI) by ring. + replace (- (PI - y)) with (y - PI) by ring. apply (sin_increasing_1 (x - PI) (y - PI) H7 H8 H5 H6 H4). - unfold Rminus in |- *; rewrite Ropp_plus_distr. - rewrite Ropp_involutive. - apply Rplus_comm. - unfold Rminus in |- *; rewrite Ropp_plus_distr. - rewrite Ropp_involutive. - apply Rplus_comm. - unfold Rminus in |- *; apply Rplus_comm. - pattern PI at 2 in |- *; rewrite double_var; ring. - unfold Rminus in |- *; apply Rplus_comm. - pattern PI at 2 in |- *; rewrite double_var; ring. Qed. Lemma cos_increasing_0 : @@ -1260,44 +1179,22 @@ Proof. intros x y H1 H2 H3 H4; rewrite <- (cos_neg x); rewrite <- (cos_neg y); rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1); unfold INR in |- *; - replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))). - replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))). + replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))) by field. + replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))) by field. repeat rewrite cos_shift; intro H5; generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1); generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2); generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3); generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4). - replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)). - replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)). - replace (-3 * (PI / 2) + 2 * PI) with (PI / 2). - replace (-3 * (PI / 2) + PI) with (- (PI / 2)). + replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)) by ring. + replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)) by ring. + replace (-3 * (PI / 2) + 2 * PI) with (PI / 2) by field. + replace (-3 * (PI / 2) + PI) with (- (PI / 2)) by field. clear H1 H2 H3 H4; intros H1 H2 H3 H4; apply Rplus_lt_reg_l with (-3 * (PI / 2)); - replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)). - replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)). + replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)) by ring. + replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)) by ring. apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5). - unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. - unfold Rminus in |- *. - 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. - unfold Rminus in |- *. - 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. - rewrite Rmult_1_r. - rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var. - ring. Qed. Lemma cos_increasing_1 : @@ -1312,31 +1209,16 @@ Proof. generalize (Rplus_lt_compat_l (-3 * (PI / 2)) x y H5); rewrite <- (cos_neg x); rewrite <- (cos_neg y); rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1); - unfold INR in |- *; replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)). - replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)). - replace (-3 * (PI / 2) + PI) with (- (PI / 2)). - replace (-3 * (PI / 2) + 2 * PI) with (PI / 2). + unfold INR in |- *; replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)) by ring. + replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)) by ring. + replace (-3 * (PI / 2) + PI) with (- (PI / 2)) by field. + replace (-3 * (PI / 2) + 2 * PI) with (PI / 2) by field. clear H1 H2 H3 H4 H5; intros H1 H2 H3 H4 H5; - replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))). - replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))). + replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))) by field. + replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))) by field. repeat rewrite cos_shift; apply (sin_increasing_1 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H5 H4 H3 H2 H1). - rewrite Rmult_1_r. - rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var. - ring. - rewrite Rmult_1_r. - rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var. - ring. - rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var. - ring. - pattern PI at 3 in |- *; rewrite double_var; ring. - unfold Rminus in |- *. - rewrite <- Ropp_mult_distr_l_reverse. - apply Rplus_comm. - unfold Rminus in |- *. - rewrite <- Ropp_mult_distr_l_reverse. - apply Rplus_comm. Qed. Lemma cos_decreasing_0 : @@ -1375,31 +1257,8 @@ 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 Rminus in |- *. - rewrite Rmult_plus_distr_r. - rewrite Rinv_mult_distr. - repeat rewrite (Rmult_comm (sin x)). - repeat rewrite Rmult_assoc. - rewrite (Rmult_comm (cos y)). - repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - rewrite (Rmult_comm (sin x)). - apply Rplus_eq_compat_l. - rewrite <- Ropp_mult_distr_l_reverse. - rewrite <- Ropp_mult_distr_r_reverse. - rewrite (Rmult_comm (/ cos x)). - repeat rewrite Rmult_assoc. - rewrite (Rmult_comm (cos x)). - repeat rewrite Rmult_assoc. - rewrite <- Rinv_l_sym. - rewrite Rmult_1_r. - reflexivity. - assumption. - assumption. - assumption. - assumption. + field. + now split. Qed. Lemma tan_increasing_0 : @@ -1436,10 +1295,9 @@ Proof. intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); clear H11; intro H11; generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11); - generalize (Rplus_le_compat x (PI / 4) (- y) (PI / 4) H0 H10); - replace (x + - y) with (x - y). - replace (PI / 4 + PI / 4) with (PI / 2). - replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)). + generalize (Rplus_le_compat x (PI / 4) (- y) (PI / 4) H0 H10). + replace (PI / 4 + PI / 4) with (PI / 2) by field. + replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)) by field. intros; case (Rtotal_order 0 (x - y)); intro H14. generalize (sin_gt_0 (x - y) H14 (Rle_lt_trans (x - y) (PI / 2) PI H12 PI2_Rlt_PI)); @@ -1447,28 +1305,6 @@ Proof. elim H14; intro H15. 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 |- *. - rewrite Rmult_plus_distr_r. - repeat rewrite Rmult_assoc. - rewrite <- Rinv_mult_distr. - rewrite Ropp_plus_distr. - replace 4 with 4. - reflexivity. - ring. - discrR. - discrR. - pattern PI at 1 in |- *; rewrite double_var. - unfold Rdiv in |- *. - rewrite Rmult_plus_distr_r. - repeat rewrite Rmult_assoc. - rewrite <- Rinv_mult_distr. - replace 4 with 4. - reflexivity. - ring. - discrR. - discrR. - reflexivity. case (Rcase_abs (sin (x - y))); intro H9. assumption. generalize (Rge_le (sin (x - y)) 0 H9); clear H9; intro H9; @@ -1482,8 +1318,7 @@ Proof. (Rlt_le 0 (/ (cos x * cos y)) H12)); intro H13; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (sin (x - y) * / (cos x * cos y)) 0 H13 H3)). - rewrite Rinv_mult_distr. - reflexivity. + apply Rinv_mult_distr. assumption. assumption. Qed. @@ -1521,9 +1356,8 @@ Proof. clear H10 H11; intro H8; generalize (Ropp_le_ge_contravar y (PI / 4) H2); intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); clear H11; intro H11; - generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11); - replace (x + - y) with (x - y). - replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)). + generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11). + replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)) by field. clear H11; intro H9; generalize (Rlt_minus x y H3); clear H3; intro H3; clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI; intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1); @@ -1534,18 +1368,6 @@ Proof. generalize (Rmult_lt_gt_compat_neg_l (sin (x - y)) 0 (/ (cos x * cos y)) H2 H8); rewrite Rmult_0_r; intro H4; assumption. - pattern PI at 1 in |- *; rewrite double_var. - unfold Rdiv in |- *. - rewrite Rmult_plus_distr_r. - repeat rewrite Rmult_assoc. - rewrite <- Rinv_mult_distr. - replace 4 with 4. - rewrite Ropp_plus_distr. - reflexivity. - ring. - discrR. - discrR. - reflexivity. apply Rinv_mult_distr; assumption. Qed. @@ -1737,7 +1559,7 @@ Proof. rewrite H5. rewrite mult_INR. simpl in |- *. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. apply sin_0. rewrite H5. @@ -1747,7 +1569,7 @@ Proof. rewrite Rmult_1_l; rewrite sin_plus. rewrite sin_PI. rewrite Rmult_0_r. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. rewrite sin_0; ring. apply le_IZR. @@ -1769,7 +1591,7 @@ Proof. rewrite H5. rewrite mult_INR. simpl in |- *. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. rewrite sin_0; ring. rewrite H5. @@ -1779,7 +1601,7 @@ Proof. rewrite Rmult_1_l; rewrite sin_plus. rewrite sin_PI. rewrite Rmult_0_r. - rewrite <- (Rplus_0_l (2 * INR x2 * PI)). + rewrite <- (Rplus_0_l ((1 + 1) * INR x2 * PI)). rewrite sin_period. rewrite sin_0; ring. apply le_IZR. @@ -1787,8 +1609,7 @@ Proof. rewrite Rplus_0_r. rewrite Ropp_Ropp_IZR. rewrite Rplus_opp_r. - left; replace 0 with (IZR 0); [ apply IZR_lt | reflexivity ]. - assumption. + now apply Rlt_le, IZR_lt. rewrite <- sin_neg. rewrite Ropp_mult_distr_l_reverse. rewrite Ropp_involutive. @@ -1858,7 +1679,7 @@ Proof. - right; left; auto. - left. clear Hi. subst. - replace 0 with (IZR 0 * PI) by (simpl; ring). f_equal. f_equal. + replace 0 with (IZR 0 * PI) by apply Rmult_0_l. f_equal. f_equal. apply one_IZR_lt1. split. + apply Rlt_le_trans with 0; diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index a5092d22..71b90fb4 100644 --- a/theories/Reals/Rtrigo_alt.v +++ b/theories/Reals/Rtrigo_alt.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* cos_n i * Rsqr a0 ^ i) (S n1)). unfold Rminus; rewrite Ropp_plus_distr; rewrite Ropp_involutive; repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1); - rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc; + rewrite (Rplus_comm (-(1))); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp; rewrite Ropp_plus_distr; rewrite Ropp_involutive; unfold Rminus in H6; apply H6. @@ -351,15 +346,13 @@ Proof. replace (- sum_f_R0 (tg_alt Un) (S (2 * n0))) with (-1 * sum_f_R0 (tg_alt Un) (S (2 * n0))); [ rewrite scal_sum | ring ]. apply sum_eq; intros; unfold cos_term, Un, tg_alt; - replace ((-1) ^ S i) with (-1 * (-1) ^ i). + change ((-1) ^ S i) with (-1 * (-1) ^ i). unfold Rdiv; ring. - reflexivity. replace (- sum_f_R0 (tg_alt Un) (2 * n0)) with (-1 * sum_f_R0 (tg_alt Un) (2 * n0)); [ rewrite scal_sum | ring ]; apply sum_eq; intros; unfold cos_term, Un, tg_alt; - replace ((-1) ^ S i) with (-1 * (-1) ^ i). + change ((-1) ^ S i) with (-1 * (-1) ^ i). unfold Rdiv; ring. - reflexivity. replace (2 * (n0 + 1))%nat with (S (S (2 * n0))). reflexivity. ring. @@ -367,10 +360,10 @@ Proof. reflexivity. ring. intro; elim H2; intros; split. - apply Rplus_le_reg_l with (-1). + apply Rplus_le_reg_l with (-(1)). rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite (Rplus_comm (-1)); apply H3. - apply Rplus_le_reg_l with (-1). + apply Rplus_le_reg_l with (-(1)). rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite (Rplus_comm (-1)); apply H4. unfold cos_term; simpl; unfold Rdiv; rewrite Rinv_1; diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v index 9ba14ee7..7cbfc630 100644 --- a/theories/Reals/Rtrigo_calc.v +++ b/theories/Reals/Rtrigo_calc.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0); - [ discrR | unfold Rdiv; rewrite Rinv_mult_distr; try ring ]... +Proof. + rewrite cos_sin. + replace (PI / 2 + PI / 4) with (- (PI / 4) + PI) by field. + rewrite neg_sin, sin_neg; ring. Qed. Lemma sin_PI3_cos_PI6 : sin (PI / 3) = cos (PI / 6). -Proof with trivial. - replace (PI / 6) with (PI / 2 - PI / 3)... - rewrite cos_shift... - assert (H0 : 6 <> 0); [ discrR | idtac ]... - assert (H1 : 3 <> 0); [ discrR | idtac ]... - assert (H2 : 2 <> 0); [ discrR | idtac ]... - apply Rmult_eq_reg_l with 6... - rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)... - unfold Rdiv; repeat rewrite Rmult_assoc... - rewrite <- Rinv_l_sym... - rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym... - rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r; - repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym... - ring... +Proof. + replace (PI / 6) with (PI / 2 - PI / 3) by field. + now rewrite cos_shift. Qed. Lemma sin_PI6_cos_PI3 : cos (PI / 3) = sin (PI / 6). -Proof with trivial. - replace (PI / 6) with (PI / 2 - PI / 3)... - rewrite sin_shift... - assert (H0 : 6 <> 0); [ discrR | idtac ]... - assert (H1 : 3 <> 0); [ discrR | idtac ]... - assert (H2 : 2 <> 0); [ discrR | idtac ]... - apply Rmult_eq_reg_l with 6... - rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)... - unfold Rdiv; repeat rewrite Rmult_assoc... - rewrite <- Rinv_l_sym... - rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym... - rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r; - repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym... - ring... +Proof. + replace (PI / 6) with (PI / 2 - PI / 3) by field. + now rewrite sin_shift. Qed. Lemma PI6_RGT_0 : 0 < PI / 6. @@ -90,29 +66,20 @@ Proof. Qed. Lemma sin_PI6 : sin (PI / 6) = 1 / 2. -Proof with trivial. - assert (H : 2 <> 0); [ discrR | idtac ]... - apply Rmult_eq_reg_l with (2 * cos (PI / 6))... +Proof. + apply Rmult_eq_reg_l with (2 * cos (PI / 6)). replace (2 * cos (PI / 6) * sin (PI / 6)) with - (2 * sin (PI / 6) * cos (PI / 6))... - rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3)... - rewrite sin_PI3_cos_PI6... - unfold Rdiv; rewrite Rmult_1_l; rewrite Rmult_assoc; - pattern 2 at 2; rewrite (Rmult_comm 2); rewrite Rmult_assoc; - rewrite <- Rinv_l_sym... - rewrite Rmult_1_r... - unfold Rdiv; rewrite Rinv_mult_distr... - rewrite (Rmult_comm (/ 2)); rewrite (Rmult_comm 2); - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r... - discrR... - ring... - apply prod_neq_R0... + (2 * sin (PI / 6) * cos (PI / 6)) by ring. + rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3) by field. + rewrite sin_PI3_cos_PI6. + field. + apply prod_neq_R0. + discrR. cut (0 < cos (PI / 6)); [ intro H1; auto with real | apply cos_gt_0; [ apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0) - | apply PI6_RLT_PI2 ] ]... + | apply PI6_RLT_PI2 ] ]. Qed. Lemma sqrt2_neq_0 : sqrt 2 <> 0. @@ -188,20 +155,13 @@ Proof with trivial. apply Rinv_0_lt_compat; apply Rlt_sqrt2_0... rewrite Rsqr_div... rewrite Rsqr_1; rewrite Rsqr_sqrt... - assert (H : 2 <> 0); [ discrR | idtac ]... unfold Rsqr; pattern (cos (PI / 4)) at 1; rewrite <- sin_cos_PI4; replace (sin (PI / 4) * cos (PI / 4)) with - (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4)))... - rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2)... + (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4))) by field. + rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2) by field. rewrite sin_PI2... - apply Rmult_1_r... - unfold Rdiv; rewrite (Rmult_comm 2); rewrite Rinv_mult_distr... - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r... - unfold Rdiv; rewrite Rmult_1_l; repeat rewrite <- Rmult_assoc... - rewrite <- Rinv_l_sym... - rewrite Rmult_1_l... + field. left; prove_sup... apply sqrt2_neq_0... Qed. @@ -219,24 +179,17 @@ Proof. Qed. Lemma cos3PI4 : cos (3 * (PI / 4)) = -1 / sqrt 2. -Proof with trivial. - replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))... - rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4... - unfold Rdiv; rewrite Ropp_mult_distr_l_reverse... - unfold Rminus; rewrite Ropp_involutive; pattern PI at 1; - rewrite double_var; unfold Rdiv; rewrite Rmult_plus_distr_r; - repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr; - [ ring | discrR | discrR ]... +Proof. + replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field. + rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4. + unfold Rdiv. + ring. Qed. Lemma sin3PI4 : sin (3 * (PI / 4)) = 1 / sqrt 2. -Proof with trivial. - replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))... - rewrite sin_shift; rewrite cos_neg; rewrite cos_PI4... - unfold Rminus; rewrite Ropp_involutive; pattern PI at 1; - rewrite double_var; unfold Rdiv; rewrite Rmult_plus_distr_r; - repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr; - [ ring | discrR | discrR ]... +Proof. + replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field. + now rewrite sin_shift, cos_neg, cos_PI4. Qed. Lemma cos_PI6 : cos (PI / 6) = sqrt 3 / 2. @@ -248,19 +201,11 @@ Proof with trivial. left; apply (Rmult_lt_0_compat (sqrt 3) (/ 2))... apply Rlt_sqrt3_0... apply Rinv_0_lt_compat; prove_sup0... - assert (H : 2 <> 0); [ discrR | idtac ]... - assert (H1 : 4 <> 0); [ apply prod_neq_R0 | idtac ]... rewrite Rsqr_div... rewrite cos2; unfold Rsqr; rewrite sin_PI6; rewrite sqrt_def... - unfold Rdiv; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4... - rewrite Rmult_minus_distr_l; rewrite (Rmult_comm 3); - repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym... - rewrite Rmult_1_l; rewrite Rmult_1_r... - rewrite <- (Rmult_comm (/ 2)); repeat rewrite <- Rmult_assoc... - rewrite <- Rinv_l_sym... - rewrite Rmult_1_l; rewrite <- Rinv_r_sym... - ring... - left; prove_sup0... + field. + left ; prove_sup0. + discrR. Qed. Lemma tan_PI6 : tan (PI / 6) = 1 / sqrt 3. @@ -306,56 +251,32 @@ Proof. Qed. Lemma cos_2PI3 : cos (2 * (PI / 3)) = -1 / 2. -Proof with trivial. - assert (H : 2 <> 0); [ discrR | idtac ]... - assert (H0 : 4 <> 0); [ apply prod_neq_R0 | idtac ]... - rewrite double; rewrite cos_plus; rewrite sin_PI3; rewrite cos_PI3; - unfold Rdiv; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4... - rewrite Rmult_minus_distr_l; repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2)... - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r; rewrite <- Rinv_r_sym... - pattern 2 at 4; rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; - rewrite <- Rinv_l_sym... - rewrite Rmult_1_r; rewrite Ropp_mult_distr_r_reverse; rewrite Rmult_1_r... - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r; rewrite (Rmult_comm 2); rewrite (Rmult_comm (/ 2))... - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym... - rewrite Rmult_1_r; rewrite sqrt_def... - ring... - left; prove_sup... +Proof. + rewrite cos_2a, sin_PI3, cos_PI3. + replace (sqrt 3 / 2 * (sqrt 3 / 2)) with ((sqrt 3 * sqrt 3) / 4) by field. + rewrite sqrt_sqrt. + field. + left ; prove_sup0. Qed. Lemma tan_2PI3 : tan (2 * (PI / 3)) = - sqrt 3. -Proof with trivial. - assert (H : 2 <> 0); [ discrR | idtac ]... - unfold tan; rewrite sin_2PI3; rewrite cos_2PI3; unfold Rdiv; - rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l; - rewrite <- Ropp_inv_permute... - rewrite Rinv_involutive... - rewrite Rmult_assoc; rewrite Ropp_mult_distr_r_reverse; rewrite <- Rinv_l_sym... - ring... - apply Rinv_neq_0_compat... +Proof. + unfold tan; rewrite sin_2PI3, cos_2PI3. + field. Qed. Lemma cos_5PI4 : cos (5 * (PI / 4)) = -1 / sqrt 2. -Proof with trivial. - replace (5 * (PI / 4)) with (PI / 4 + PI)... - rewrite neg_cos; rewrite cos_PI4; unfold Rdiv; - rewrite Ropp_mult_distr_l_reverse... - pattern PI at 2; rewrite double_var; pattern PI at 2 3; - rewrite double_var; assert (H : 2 <> 0); - [ discrR | unfold Rdiv; repeat rewrite Rinv_mult_distr; try ring ]... +Proof. + replace (5 * (PI / 4)) with (PI / 4 + PI) by field. + rewrite neg_cos; rewrite cos_PI4; unfold Rdiv. + ring. Qed. Lemma sin_5PI4 : sin (5 * (PI / 4)) = -1 / sqrt 2. -Proof with trivial. - replace (5 * (PI / 4)) with (PI / 4 + PI)... - rewrite neg_sin; rewrite sin_PI4; unfold Rdiv; - rewrite Ropp_mult_distr_l_reverse... - pattern PI at 2; rewrite double_var; pattern PI at 2 3; - rewrite double_var; assert (H : 2 <> 0); - [ discrR | unfold Rdiv; repeat rewrite Rinv_mult_distr; try ring ]... +Proof. + replace (5 * (PI / 4)) with (PI / 4 + PI) by field. + rewrite neg_sin; rewrite sin_PI4; unfold Rdiv. + ring. Qed. Lemma sin_cos5PI4 : cos (5 * (PI / 4)) = sin (5 * (PI / 4)). diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v index 0d2a9a8b..d2faf95b 100644 --- a/theories/Reals/Rtrigo_def.v +++ b/theories/Reals/Rtrigo_def.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0. @@ -318,28 +317,25 @@ Proof. elim H1; intros; assumption. apply lt_le_trans with (S n). unfold ge in H2; apply le_lt_n_Sm; assumption. - replace (2 * S n + 1)%nat with (S (2 * S n)); [ idtac | ring ]. + replace (2 * S n + 1)%nat with (S (2 * S n)) by ring. apply le_S; apply le_n_2n. apply Rmult_lt_reg_l with (INR (2 * S n)). apply lt_INR_0; replace (2 * S n)%nat with (S (S (2 * n))); - [ apply lt_O_Sn | replace (S n) with (n + 1)%nat; [ idtac | ring ]; ring ]. + [ apply lt_O_Sn | ring ]. rewrite <- Rinv_r_sym. - rewrite Rmult_1_r; replace 1 with (INR 1); [ apply lt_INR | reflexivity ]. + rewrite Rmult_1_r. + apply (lt_INR 1). replace (2 * S n)%nat with (S (S (2 * n))). apply lt_n_S; apply lt_O_Sn. - replace (S n) with (n + 1)%nat; [ ring | ring ]. + ring. apply not_O_INR; discriminate. apply not_O_INR; discriminate. apply not_O_INR; discriminate. - left; change (0 < / INR ((2 * S n + 1) * (2 * S n))); - apply Rinv_0_lt_compat. + left; apply Rinv_0_lt_compat. apply lt_INR_0. replace ((2 * S n + 1) * (2 * S n))%nat with - (S (S (S (S (S (S (4 * (n * n) + 10 * n))))))). + (6 + (4 * (n * n) + 10 * n))%nat by ring. apply lt_O_Sn. - apply INR_eq; repeat rewrite S_INR; rewrite plus_INR; repeat rewrite mult_INR; - rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR; - replace (INR 0) with 0; [ ring | reflexivity ]. Qed. Lemma sin_no_R0 : forall n:nat, sin_n n <> 0. diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v index f395f9ae..744a99a1 100644 --- a/theories/Reals/Rtrigo_fun.v +++ b/theories/Reals/Rtrigo_fun.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* R) (pr:has_lb Un) (* Compatibility *) Notation sequence_majorant := sequence_ub (only parsing). Notation sequence_minorant := sequence_lb (only parsing). -Unset Standard Proposition Elimination Names. + Lemma Wn_decreasing : forall (Un:nat -> R) (pr:has_ub Un), Un_decreasing (sequence_ub Un pr). Proof. @@ -1167,7 +1169,7 @@ Proof. assert (H6 := archimed (Rabs x)); fold M in H6; elim H6; intros. rewrite H4 in H7; rewrite <- INR_IZR_INZ in H7. simpl in H7; elim (Rlt_irrefl _ (Rlt_trans _ _ _ H2 H7)). - replace 1 with (INR 1); [ apply le_INR | reflexivity ]; apply le_n_S; + apply (le_INR 1); apply le_n_S; apply le_O_n. apply le_IZR; simpl; left; apply Rlt_trans with (Rabs x). assumption. diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v index 1123e7ee..ccd205e2 100644 --- a/theories/Reals/SeqSeries.v +++ b/theories/Reals/SeqSeries.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*) diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v index d43baee8..d6b386f1 100644 --- a/theories/Reals/Sqrt_reg.v +++ b/theories/Reals/Sqrt_reg.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Intersection A s1 s2 = Empty_set A. + Proof. + intros. apply Extensionality_Ensembles. split. + * destruct H. + intros x H1. unfold In in *. exfalso. intuition. apply (H _ H1). + * intuition. + Qed. + + Lemma Intersection_Empty_set_l: + forall A s, Intersection A (Empty_set A) s = Empty_set A. + Proof. + intros. auto with sets. + Qed. + + Lemma Intersection_Empty_set_r: + forall A s, Intersection A s (Empty_set A) = Empty_set A. + Proof. + intros. auto with sets. + Qed. + + Lemma Seminus_Empty_set_l: + forall A s, Setminus A (Empty_set A) s = Empty_set A. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. destruct H1. unfold In in *. assumption. + * intuition. + Qed. + + Lemma Seminus_Empty_set_r: + forall A s, Setminus A s (Empty_set A) = s. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. destruct H1. unfold In in *. assumption. + * intuition. + Qed. + + Lemma Setminus_Union_l: + forall A s1 s2 s3, + Setminus A (Union A s1 s2) s3 = Union A (Setminus A s1 s3) (Setminus A s2 s3). + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H. inversion H. inversion H0; intuition. + * intros x H. constructor; inversion H; inversion H0; intuition. + Qed. + + Lemma Setminus_Union_r: + forall A s1 s2 s3, + Setminus A s1 (Union A s2 s3) = Setminus A (Setminus A s1 s2) s3. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H. inversion H. constructor. intuition. contradict H1. intuition. + * intros x H. inversion H. inversion H0. constructor; intuition. inversion H4; intuition. + Qed. + + Lemma Setminus_Disjoint_noop: + forall A s1 s2, + Intersection A s1 s2 = Empty_set A -> Setminus A s1 s2 = s1. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. inversion_clear H1. intuition. + * intros x H1. constructor; intuition. contradict H. + apply Inhabited_not_empty. + exists x. intuition. + Qed. + + Lemma Setminus_Included_empty: + forall A s1 s2, + Included A s1 s2 -> Setminus A s1 s2 = Empty_set A. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. inversion_clear H1. contradiction H2. intuition. + * intuition. + Qed. + End Sets_as_an_algebra. Hint Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v index 45fb8134..1ed74599 100644 --- a/theories/Sets/Relations_1.v +++ b/theories/Sets/Relations_1.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (forall a, HdRel leA a l1 -> HdRel leA a l2 -> HdRel leA a l) -> merge_lem l1 l2. - Require Import Morphisms. + Import Morphisms. Instance: Equivalence (@meq A). Proof. constructor; auto with datatypes. red. apply meq_trans. Defined. @@ -146,10 +148,10 @@ Section defs. forall l1:list A, Sorted leA l1 -> forall l2:list A, Sorted leA l2 -> merge_lem l1 l2. Proof. - fix 1; intros; destruct l1. + fix merge 1; intros; destruct l1. apply merge_exist with l2; auto with datatypes. rename l1 into l. - revert l2 H0. fix 1. intros. + revert l2 H0. fix merge0 1. intros. destruct l2 as [|a0 l0]. apply merge_exist with (a :: l); simpl; auto with datatypes. induction (leA_dec a a0) as [Hle|Hle]. diff --git a/theories/Sorting/Mergesort.v b/theories/Sorting/Mergesort.v index 4b967c16..824d000d 100644 --- a/theories/Sorting/Mergesort.v +++ b/theories/Sorting/Mergesort.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* EmptyString + | cons x nil => x + | cons x xs => x ++ sep ++ concat sep xs + end. + (** *** Test functions *) (** Test if [s1] is a prefix of [s2] *) diff --git a/theories/Strings/vo.itarget b/theories/Strings/vo.itarget deleted file mode 100644 index 20813b42..00000000 --- a/theories/Strings/vo.itarget +++ /dev/null @@ -1,2 +0,0 @@ -Ascii.vo -String.vo diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index f85222df..24333ad8 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -1,10 +1,12 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* InA eqk p m -> InA eqk q m. Proof. - intros; apply InA_eqA with p; auto with *. + intros; apply InA_eqA with p; auto using eqk_equiv. Qed. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). @@ -109,7 +111,7 @@ Module KeyDecidableType(D:DecidableType). 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 *. + intros; unfold MapsTo in *; apply InA_eqA with (x,e); auto using eqke_equiv. Qed. Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. diff --git a/theories/Structures/DecidableTypeEx.v b/theories/Structures/DecidableTypeEx.v index 163a40f2..8dd2e710 100644 --- a/theories/Structures/DecidableTypeEx.v +++ b/theories/Structures/DecidableTypeEx.v @@ -1,10 +1,12 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* y) (at level 70) : type_scope. (* Abstraction *) -Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) - (at level 200, x binder, y binder, right associativity). +Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) + (at level 200, x binder, y binder, right associativity, + format "'[ ' 'λ' x .. y ']' , t"). diff --git a/theories/Unicode/vo.itarget b/theories/Unicode/vo.itarget deleted file mode 100644 index 7be1b996..00000000 --- a/theories/Unicode/vo.itarget +++ /dev/null @@ -1,2 +0,0 @@ -Utf8.vo -Utf8_core.vo diff --git a/theories/Vectors/Fin.v b/theories/Vectors/Fin.v index 2955184f..4088843a 100644 --- a/theories/Vectors/Fin.v +++ b/theories/Vectors/Fin.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t A (S (S n))) (fun h => h :: h :: []) (fun h _ _ H => h :: H). Global Arguments shiftrepeat {A} {n} v. +(** Take first [p] elements of a vector *) +Fixpoint take {A} {n} (p:nat) (le:p <= n) (v:t A n) : t A p := + match p as p return p <= n -> t A p with + | 0 => fun _ => [] + | S p' => match v in t _ n return S p' <= n -> t A (S p') with + | []=> fun le => False_rect _ (Nat.nle_succ_0 p' le) + | x::xs => fun le => x::take p' (le_S_n p' _ le) xs + end + end le. + (** Remove [p] last elements of a vector *) Lemma trunc : forall {A} {n} (p:nat), n > p -> t A n -> t A (n - p). @@ -295,12 +307,10 @@ End VECTORLIST. Module VectorNotations. Delimit Scope vector_scope with vector. Notation "[ ]" := [] (format "[ ]") : vector_scope. -Notation "[]" := [] (compat "8.5") : vector_scope. Notation "h :: t" := (h :: t) (at level 60, right associativity) : vector_scope. Notation "[ x ]" := (x :: []) : vector_scope. Notation "[ x ; y ; .. ; z ]" := (cons _ x _ (cons _ y _ .. (cons _ z _ (nil _)) ..)) : vector_scope. -Notation "[ x ; .. ; y ]" := (cons _ x _ .. (cons _ y _ (nil _)) ..) (compat "8.4") : vector_scope. Notation "v [@ p ]" := (nth v p) (at level 1, format "v [@ p ]") : vector_scope. Open Scope vector_scope. End VectorNotations. diff --git a/theories/Vectors/VectorEq.v b/theories/Vectors/VectorEq.v index 04c57073..317f3f1c 100644 --- a/theories/Vectors/VectorEq.v +++ b/theories/Vectors/VectorEq.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Z.testbit (Z.pos a) n = N.testbit (N.pos a) (Z.to_N n). Proof. apply Z.testbit_Zpos. Qed. -(** Some results concerning Z.neg *) +(** Some results concerning Z.neg and Z.pos *) Lemma inj_neg p q : Z.neg p = Z.neg q -> p = q. Proof. now injection 1. Qed. @@ -1375,18 +1377,54 @@ Proof. now injection 1. Qed. Lemma inj_neg_iff p q : Z.neg p = Z.neg q <-> p = q. Proof. split. apply inj_neg. intros; now f_equal. Qed. +Lemma inj_pos p q : Z.pos p = Z.pos q -> p = q. +Proof. now injection 1. Qed. + +Lemma inj_pos_iff p q : Z.pos p = Z.pos q <-> p = q. +Proof. split. apply inj_pos. intros; now f_equal. Qed. + Lemma neg_is_neg p : Z.neg p < 0. Proof. reflexivity. Qed. Lemma neg_is_nonpos p : Z.neg p <= 0. Proof. easy. Qed. +Lemma pos_is_pos p : 0 < Z.pos p. +Proof. reflexivity. Qed. + +Lemma pos_is_nonneg p : 0 <= Z.pos p. +Proof. easy. Qed. + +Lemma neg_le_pos p q : Zneg p <= Zpos q. +Proof. easy. Qed. + +Lemma neg_lt_pos p q : Zneg p < Zpos q. +Proof. easy. Qed. + +Lemma neg_le_neg p q : (q <= p)%positive -> Zneg p <= Zneg q. +Proof. intros; unfold Z.le; simpl. now rewrite <- Pos.compare_antisym. Qed. + +Lemma neg_lt_neg p q : (q < p)%positive -> Zneg p < Zneg q. +Proof. intros; unfold Z.lt; simpl. now rewrite <- Pos.compare_antisym. Qed. + +Lemma pos_le_pos p q : (p <= q)%positive -> Zpos p <= Zpos q. +Proof. easy. Qed. + +Lemma pos_lt_pos p q : (p < q)%positive -> Zpos p < Zpos q. +Proof. easy. Qed. + Lemma neg_xO p : Z.neg p~0 = 2 * Z.neg p. Proof. reflexivity. Qed. Lemma neg_xI p : Z.neg p~1 = 2 * Z.neg p - 1. Proof. reflexivity. Qed. +Lemma pos_xO p : Z.pos p~0 = 2 * Z.pos p. +Proof. reflexivity. Qed. + +Lemma pos_xI p : Z.pos p~1 = 2 * Z.pos p + 1. +Proof. reflexivity. Qed. + Lemma opp_neg p : - Z.neg p = Z.pos p. Proof. reflexivity. Qed. @@ -1402,6 +1440,9 @@ Proof. reflexivity. Qed. Lemma add_neg_pos p q : Z.neg p + Z.pos q = Z.pos_sub q p. Proof. reflexivity. Qed. +Lemma add_pos_pos p q : Z.pos p + Z.pos q = Z.pos (p+q). +Proof. reflexivity. Qed. + Lemma divide_pos_neg_r n p : (n|Z.pos p) <-> (n|Z.neg p). Proof. apply Z.divide_Zpos_Zneg_r. Qed. @@ -1412,6 +1453,10 @@ Lemma testbit_neg a n : 0<=n -> Z.testbit (Z.neg a) n = negb (N.testbit (Pos.pred_N a) (Z.to_N n)). Proof. apply Z.testbit_Zneg. Qed. +Lemma testbit_pos a n : 0<=n -> + Z.testbit (Z.pos a) n = N.testbit (N.pos a) (Z.to_N n). +Proof. apply Z.testbit_Zpos. Qed. + End Pos2Z. Module Z2Pos. @@ -1522,94 +1567,94 @@ End Z2Pos. (** Compatibility Notations *) -Notation Zdouble_plus_one := Z.succ_double (compat "8.3"). -Notation Zdouble_minus_one := Z.pred_double (compat "8.3"). -Notation Zdouble := Z.double (compat "8.3"). -Notation ZPminus := Z.pos_sub (compat "8.3"). -Notation Zsucc' := Z.succ (compat "8.3"). -Notation Zpred' := Z.pred (compat "8.3"). -Notation Zplus' := Z.add (compat "8.3"). -Notation Zplus := Z.add (compat "8.3"). (* Slightly incompatible *) -Notation Zopp := Z.opp (compat "8.3"). -Notation Zsucc := Z.succ (compat "8.3"). -Notation Zpred := Z.pred (compat "8.3"). -Notation Zminus := Z.sub (compat "8.3"). -Notation Zmult := Z.mul (compat "8.3"). -Notation Zcompare := Z.compare (compat "8.3"). -Notation Zsgn := Z.sgn (compat "8.3"). -Notation Zle := Z.le (compat "8.3"). -Notation Zge := Z.ge (compat "8.3"). -Notation Zlt := Z.lt (compat "8.3"). -Notation Zgt := Z.gt (compat "8.3"). -Notation Zmax := Z.max (compat "8.3"). -Notation Zmin := Z.min (compat "8.3"). -Notation Zabs := Z.abs (compat "8.3"). -Notation Zabs_nat := Z.abs_nat (compat "8.3"). -Notation Zabs_N := Z.abs_N (compat "8.3"). -Notation Z_of_nat := Z.of_nat (compat "8.3"). -Notation Z_of_N := Z.of_N (compat "8.3"). - -Notation Zind := Z.peano_ind (compat "8.3"). -Notation Zopp_0 := Z.opp_0 (compat "8.3"). -Notation Zopp_involutive := Z.opp_involutive (compat "8.3"). -Notation Zopp_inj := Z.opp_inj (compat "8.3"). -Notation Zplus_0_l := Z.add_0_l (compat "8.3"). -Notation Zplus_0_r := Z.add_0_r (compat "8.3"). -Notation Zplus_comm := Z.add_comm (compat "8.3"). -Notation Zopp_plus_distr := Z.opp_add_distr (compat "8.3"). -Notation Zopp_succ := Z.opp_succ (compat "8.3"). -Notation Zplus_opp_r := Z.add_opp_diag_r (compat "8.3"). -Notation Zplus_opp_l := Z.add_opp_diag_l (compat "8.3"). -Notation Zplus_assoc := Z.add_assoc (compat "8.3"). -Notation Zplus_permute := Z.add_shuffle3 (compat "8.3"). -Notation Zplus_reg_l := Z.add_reg_l (compat "8.3"). -Notation Zplus_succ_l := Z.add_succ_l (compat "8.3"). -Notation Zplus_succ_comm := Z.add_succ_comm (compat "8.3"). -Notation Zsucc_discr := Z.neq_succ_diag_r (compat "8.3"). -Notation Zsucc_inj := Z.succ_inj (compat "8.3"). -Notation Zsucc'_inj := Z.succ_inj (compat "8.3"). -Notation Zsucc'_pred' := Z.succ_pred (compat "8.3"). -Notation Zpred'_succ' := Z.pred_succ (compat "8.3"). -Notation Zpred'_inj := Z.pred_inj (compat "8.3"). -Notation Zsucc'_discr := Z.neq_succ_diag_r (compat "8.3"). -Notation Zminus_0_r := Z.sub_0_r (compat "8.3"). -Notation Zminus_diag := Z.sub_diag (compat "8.3"). -Notation Zminus_plus_distr := Z.sub_add_distr (compat "8.3"). -Notation Zminus_succ_r := Z.sub_succ_r (compat "8.3"). -Notation Zminus_plus := Z.add_simpl_l (compat "8.3"). -Notation Zmult_0_l := Z.mul_0_l (compat "8.3"). -Notation Zmult_0_r := Z.mul_0_r (compat "8.3"). -Notation Zmult_1_l := Z.mul_1_l (compat "8.3"). -Notation Zmult_1_r := Z.mul_1_r (compat "8.3"). -Notation Zmult_comm := Z.mul_comm (compat "8.3"). -Notation Zmult_assoc := Z.mul_assoc (compat "8.3"). -Notation Zmult_permute := Z.mul_shuffle3 (compat "8.3"). -Notation Zmult_1_inversion_l := Z.mul_eq_1 (compat "8.3"). -Notation Zdouble_mult := Z.double_spec (compat "8.3"). -Notation Zdouble_plus_one_mult := Z.succ_double_spec (compat "8.3"). -Notation Zopp_mult_distr_l_reverse := Z.mul_opp_l (compat "8.3"). -Notation Zmult_opp_opp := Z.mul_opp_opp (compat "8.3"). -Notation Zmult_opp_comm := Z.mul_opp_comm (compat "8.3"). -Notation Zopp_eq_mult_neg_1 := Z.opp_eq_mul_m1 (compat "8.3"). -Notation Zmult_plus_distr_r := Z.mul_add_distr_l (compat "8.3"). -Notation Zmult_plus_distr_l := Z.mul_add_distr_r (compat "8.3"). -Notation Zmult_minus_distr_r := Z.mul_sub_distr_r (compat "8.3"). -Notation Zmult_reg_l := Z.mul_reg_l (compat "8.3"). -Notation Zmult_reg_r := Z.mul_reg_r (compat "8.3"). -Notation Zmult_succ_l := Z.mul_succ_l (compat "8.3"). -Notation Zmult_succ_r := Z.mul_succ_r (compat "8.3"). - -Notation Zpos_xI := Pos2Z.inj_xI (compat "8.3"). -Notation Zpos_xO := Pos2Z.inj_xO (compat "8.3"). -Notation Zneg_xI := Pos2Z.neg_xI (compat "8.3"). -Notation Zneg_xO := Pos2Z.neg_xO (compat "8.3"). -Notation Zopp_neg := Pos2Z.opp_neg (compat "8.3"). -Notation Zpos_succ_morphism := Pos2Z.inj_succ (compat "8.3"). -Notation Zpos_mult_morphism := Pos2Z.inj_mul (compat "8.3"). -Notation Zpos_minus_morphism := Pos2Z.inj_sub (compat "8.3"). -Notation Zpos_eq_rev := Pos2Z.inj (compat "8.3"). -Notation Zpos_plus_distr := Pos2Z.inj_add (compat "8.3"). -Notation Zneg_plus_distr := Pos2Z.add_neg_neg (compat "8.3"). +Notation Zdouble_plus_one := Z.succ_double (only parsing). +Notation Zdouble_minus_one := Z.pred_double (only parsing). +Notation Zdouble := Z.double (compat "8.6"). +Notation ZPminus := Z.pos_sub (only parsing). +Notation Zsucc' := Z.succ (compat "8.6"). +Notation Zpred' := Z.pred (compat "8.6"). +Notation Zplus' := Z.add (compat "8.6"). +Notation Zplus := Z.add (only parsing). (* Slightly incompatible *) +Notation Zopp := Z.opp (compat "8.6"). +Notation Zsucc := Z.succ (compat "8.6"). +Notation Zpred := Z.pred (compat "8.6"). +Notation Zminus := Z.sub (only parsing). +Notation Zmult := Z.mul (only parsing). +Notation Zcompare := Z.compare (compat "8.6"). +Notation Zsgn := Z.sgn (compat "8.6"). +Notation Zle := Z.le (compat "8.6"). +Notation Zge := Z.ge (compat "8.6"). +Notation Zlt := Z.lt (compat "8.6"). +Notation Zgt := Z.gt (compat "8.6"). +Notation Zmax := Z.max (compat "8.6"). +Notation Zmin := Z.min (compat "8.6"). +Notation Zabs := Z.abs (compat "8.6"). +Notation Zabs_nat := Z.abs_nat (compat "8.6"). +Notation Zabs_N := Z.abs_N (compat "8.6"). +Notation Z_of_nat := Z.of_nat (only parsing). +Notation Z_of_N := Z.of_N (only parsing). + +Notation Zind := Z.peano_ind (only parsing). +Notation Zopp_0 := Z.opp_0 (compat "8.6"). +Notation Zopp_involutive := Z.opp_involutive (compat "8.6"). +Notation Zopp_inj := Z.opp_inj (compat "8.6"). +Notation Zplus_0_l := Z.add_0_l (only parsing). +Notation Zplus_0_r := Z.add_0_r (only parsing). +Notation Zplus_comm := Z.add_comm (only parsing). +Notation Zopp_plus_distr := Z.opp_add_distr (only parsing). +Notation Zopp_succ := Z.opp_succ (compat "8.6"). +Notation Zplus_opp_r := Z.add_opp_diag_r (only parsing). +Notation Zplus_opp_l := Z.add_opp_diag_l (only parsing). +Notation Zplus_assoc := Z.add_assoc (only parsing). +Notation Zplus_permute := Z.add_shuffle3 (only parsing). +Notation Zplus_reg_l := Z.add_reg_l (only parsing). +Notation Zplus_succ_l := Z.add_succ_l (only parsing). +Notation Zplus_succ_comm := Z.add_succ_comm (only parsing). +Notation Zsucc_discr := Z.neq_succ_diag_r (only parsing). +Notation Zsucc_inj := Z.succ_inj (compat "8.6"). +Notation Zsucc'_inj := Z.succ_inj (compat "8.6"). +Notation Zsucc'_pred' := Z.succ_pred (compat "8.6"). +Notation Zpred'_succ' := Z.pred_succ (compat "8.6"). +Notation Zpred'_inj := Z.pred_inj (compat "8.6"). +Notation Zsucc'_discr := Z.neq_succ_diag_r (only parsing). +Notation Zminus_0_r := Z.sub_0_r (only parsing). +Notation Zminus_diag := Z.sub_diag (only parsing). +Notation Zminus_plus_distr := Z.sub_add_distr (only parsing). +Notation Zminus_succ_r := Z.sub_succ_r (only parsing). +Notation Zminus_plus := Z.add_simpl_l (only parsing). +Notation Zmult_0_l := Z.mul_0_l (only parsing). +Notation Zmult_0_r := Z.mul_0_r (only parsing). +Notation Zmult_1_l := Z.mul_1_l (only parsing). +Notation Zmult_1_r := Z.mul_1_r (only parsing). +Notation Zmult_comm := Z.mul_comm (only parsing). +Notation Zmult_assoc := Z.mul_assoc (only parsing). +Notation Zmult_permute := Z.mul_shuffle3 (only parsing). +Notation Zmult_1_inversion_l := Z.mul_eq_1 (only parsing). +Notation Zdouble_mult := Z.double_spec (only parsing). +Notation Zdouble_plus_one_mult := Z.succ_double_spec (only parsing). +Notation Zopp_mult_distr_l_reverse := Z.mul_opp_l (only parsing). +Notation Zmult_opp_opp := Z.mul_opp_opp (only parsing). +Notation Zmult_opp_comm := Z.mul_opp_comm (only parsing). +Notation Zopp_eq_mult_neg_1 := Z.opp_eq_mul_m1 (only parsing). +Notation Zmult_plus_distr_r := Z.mul_add_distr_l (only parsing). +Notation Zmult_plus_distr_l := Z.mul_add_distr_r (only parsing). +Notation Zmult_minus_distr_r := Z.mul_sub_distr_r (only parsing). +Notation Zmult_reg_l := Z.mul_reg_l (only parsing). +Notation Zmult_reg_r := Z.mul_reg_r (only parsing). +Notation Zmult_succ_l := Z.mul_succ_l (only parsing). +Notation Zmult_succ_r := Z.mul_succ_r (only parsing). + +Notation Zpos_xI := Pos2Z.inj_xI (only parsing). +Notation Zpos_xO := Pos2Z.inj_xO (only parsing). +Notation Zneg_xI := Pos2Z.neg_xI (only parsing). +Notation Zneg_xO := Pos2Z.neg_xO (only parsing). +Notation Zopp_neg := Pos2Z.opp_neg (only parsing). +Notation Zpos_succ_morphism := Pos2Z.inj_succ (only parsing). +Notation Zpos_mult_morphism := Pos2Z.inj_mul (only parsing). +Notation Zpos_minus_morphism := Pos2Z.inj_sub (only parsing). +Notation Zpos_eq_rev := Pos2Z.inj (only parsing). +Notation Zpos_plus_distr := Pos2Z.inj_add (only parsing). +Notation Zneg_plus_distr := Pos2Z.add_neg_neg (only parsing). Notation Z := Z (only parsing). Notation Z_rect := Z_rect (only parsing). diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v index 8c2e7d94..db4de0b9 100644 --- a/theories/ZArith/BinIntDef.v +++ b/theories/ZArith/BinIntDef.v @@ -1,10 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 1%positive end. +(** Conversion with a decimal representation for printing/parsing *) + +Definition of_uint (d:Decimal.uint) := of_N (Pos.of_uint d). + +Definition of_int (d:Decimal.int) := + match d with + | Decimal.Pos d => of_uint d + | Decimal.Neg d => opp (of_uint d) + end. + +Definition to_int n := + match n with + | 0 => Decimal.Pos Decimal.zero + | pos p => Decimal.Pos (Pos.to_uint p) + | neg p => Decimal.Neg (Pos.to_uint p) + end. + (** ** Iteration of a function By convention, iterating a negative number of times is identity. @@ -616,4 +635,4 @@ Definition lxor a b := | neg a, neg b => of_N (N.lxor (Pos.pred_N a) (Pos.pred_N b)) end. -End Z. \ No newline at end of file +End Z. diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index 72021f2e..2f3bf9a3 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -1,10 +1,12 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P. Proof. apply Zcompare_rect. Defined. -Notation Z_eq_dec := Z.eq_dec (compat "8.3"). +Notation Z_eq_dec := Z.eq_dec (compat "8.6"). Section decidability. diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v index df9db5b2..0d8450e3 100644 --- a/theories/ZArith/Zabs.v +++ b/theories/ZArith/Zabs.v @@ -1,10 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Zabs2Nat.inj_sub m n) (compat "8.3"). -Notation Zabs_nat_compare := Zabs2Nat.inj_compare (compat "8.3"). +Notation inj_Zabs_nat := Zabs2Nat.id_abs (only parsing). +Notation Zabs_nat_Z_of_nat := Zabs2Nat.id (only parsing). +Notation Zabs_nat_mult := Zabs2Nat.inj_mul (only parsing). +Notation Zabs_nat_Zsucc := Zabs2Nat.inj_succ (only parsing). +Notation Zabs_nat_Zplus := Zabs2Nat.inj_add (only parsing). +Notation Zabs_nat_Zminus := (fun n m => Zabs2Nat.inj_sub m n) (only parsing). +Notation Zabs_nat_compare := Zabs2Nat.inj_compare (only parsing). Lemma Zabs_nat_le n m : 0 <= n <= m -> (Z.abs_nat n <= Z.abs_nat m)%nat. Proof. diff --git a/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v index 41d1b2b5..632d41b6 100644 --- a/theories/ZArith/Zbool.v +++ b/theories/ZArith/Zbool.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (m <=? n) = true -> n = m. diff --git a/theories/ZArith/Zcompare.v b/theories/ZArith/Zcompare.v index 2627f174..c8432e27 100644 --- a/theories/ZArith/Zcompare.v +++ b/theories/ZArith/Zcompare.v @@ -1,10 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 = 3 / (-2*-2) *) +Lemma Zmod_div : forall a b, a mod b / b = 0. +Proof. + intros a b. + zero_or_not b. + auto using Z.mod_div. +Qed. + (** A last inequality: *) Theorem Zdiv_mult_le: diff --git a/theories/ZArith/Zeuclid.v b/theories/ZArith/Zeuclid.v index 38a824cd..dc75db13 100644 --- a/theories/ZArith/Zeuclid.v +++ b/theories/ZArith/Zeuclid.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Zeven n. Proof. @@ -130,17 +132,17 @@ Qed. Hint Unfold Zeven Zodd: zarith. -Notation Zeven_bool_succ := Z.even_succ (compat "8.3"). -Notation Zeven_bool_pred := Z.even_pred (compat "8.3"). -Notation Zodd_bool_succ := Z.odd_succ (compat "8.3"). -Notation Zodd_bool_pred := Z.odd_pred (compat "8.3"). +Notation Zeven_bool_succ := Z.even_succ (only parsing). +Notation Zeven_bool_pred := Z.even_pred (only parsing). +Notation Zodd_bool_succ := Z.odd_succ (only parsing). +Notation Zodd_bool_pred := Z.odd_pred (only parsing). (******************************************************************) (** * Definition of [Z.quot2], [Z.div2] and properties wrt [Zeven] and [Zodd] *) -Notation Zdiv2 := Z.div2 (compat "8.3"). -Notation Zquot2 := Z.quot2 (compat "8.3"). +Notation Zdiv2 := Z.div2 (compat "8.6"). +Notation Zquot2 := Z.quot2 (compat "8.6"). (** Properties of [Z.div2] *) diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v index 3977ca9d..cced1190 100644 --- a/theories/ZArith/Zgcd_alt.v +++ b/theories/ZArith/Zgcd_alt.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* {n <= p} + {m <= p}. Proof. apply Z.min_case; auto. Qed. diff --git a/theories/ZArith/Zminmax.v b/theories/ZArith/Zminmax.v index ea9a5f86..06919642 100644 --- a/theories/ZArith/Zminmax.v +++ b/theories/ZArith/Zminmax.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Z.iter n f x = iter_nat (Z.abs_nat n) A f x. diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v index 06428a7c..5c960da1 100644 --- a/theories/ZArith/Znat.v +++ b/theories/ZArith/Znat.v @@ -1,10 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* iff_sym (Nat2Z.inj_iff n m)) (compat "8.3"). -Notation inj_le_iff := Nat2Z.inj_le (compat "8.3"). -Notation inj_lt_iff := Nat2Z.inj_lt (compat "8.3"). -Notation inj_ge_iff := Nat2Z.inj_ge (compat "8.3"). -Notation inj_gt_iff := Nat2Z.inj_gt (compat "8.3"). -Notation inj_le_rev := (fun n m => proj2 (Nat2Z.inj_le n m)) (compat "8.3"). -Notation inj_lt_rev := (fun n m => proj2 (Nat2Z.inj_lt n m)) (compat "8.3"). -Notation inj_ge_rev := (fun n m => proj2 (Nat2Z.inj_ge n m)) (compat "8.3"). -Notation inj_gt_rev := (fun n m => proj2 (Nat2Z.inj_gt n m)) (compat "8.3"). -Notation inj_plus := Nat2Z.inj_add (compat "8.3"). -Notation inj_mult := Nat2Z.inj_mul (compat "8.3"). -Notation inj_minus1 := Nat2Z.inj_sub (compat "8.3"). -Notation inj_minus := Nat2Z.inj_sub_max (compat "8.3"). -Notation inj_min := Nat2Z.inj_min (compat "8.3"). -Notation inj_max := Nat2Z.inj_max (compat "8.3"). - -Notation Z_of_nat_of_P := positive_nat_Z (compat "8.3"). +Notation inj_0 := Nat2Z.inj_0 (only parsing). +Notation inj_S := Nat2Z.inj_succ (only parsing). +Notation inj_compare := Nat2Z.inj_compare (only parsing). +Notation inj_eq_rev := Nat2Z.inj (only parsing). +Notation inj_eq_iff := (fun n m => iff_sym (Nat2Z.inj_iff n m)) (only parsing). +Notation inj_le_iff := Nat2Z.inj_le (only parsing). +Notation inj_lt_iff := Nat2Z.inj_lt (only parsing). +Notation inj_ge_iff := Nat2Z.inj_ge (only parsing). +Notation inj_gt_iff := Nat2Z.inj_gt (only parsing). +Notation inj_le_rev := (fun n m => proj2 (Nat2Z.inj_le n m)) (only parsing). +Notation inj_lt_rev := (fun n m => proj2 (Nat2Z.inj_lt n m)) (only parsing). +Notation inj_ge_rev := (fun n m => proj2 (Nat2Z.inj_ge n m)) (only parsing). +Notation inj_gt_rev := (fun n m => proj2 (Nat2Z.inj_gt n m)) (only parsing). +Notation inj_plus := Nat2Z.inj_add (only parsing). +Notation inj_mult := Nat2Z.inj_mul (only parsing). +Notation inj_minus1 := Nat2Z.inj_sub (only parsing). +Notation inj_minus := Nat2Z.inj_sub_max (only parsing). +Notation inj_min := Nat2Z.inj_min (only parsing). +Notation inj_max := Nat2Z.inj_max (only parsing). + +Notation Z_of_nat_of_P := positive_nat_Z (only parsing). Notation Zpos_eq_Z_of_nat_o_nat_of_P := - (fun p => eq_sym (positive_nat_Z p)) (compat "8.3"). - -Notation Z_of_nat_of_N := N_nat_Z (compat "8.3"). -Notation Z_of_N_of_nat := nat_N_Z (compat "8.3"). - -Notation Z_of_N_eq := (f_equal Z.of_N) (compat "8.3"). -Notation Z_of_N_eq_rev := N2Z.inj (compat "8.3"). -Notation Z_of_N_eq_iff := (fun n m => iff_sym (N2Z.inj_iff n m)) (compat "8.3"). -Notation Z_of_N_compare := N2Z.inj_compare (compat "8.3"). -Notation Z_of_N_le_iff := N2Z.inj_le (compat "8.3"). -Notation Z_of_N_lt_iff := N2Z.inj_lt (compat "8.3"). -Notation Z_of_N_ge_iff := N2Z.inj_ge (compat "8.3"). -Notation Z_of_N_gt_iff := N2Z.inj_gt (compat "8.3"). -Notation Z_of_N_le := (fun n m => proj1 (N2Z.inj_le n m)) (compat "8.3"). -Notation Z_of_N_lt := (fun n m => proj1 (N2Z.inj_lt n m)) (compat "8.3"). -Notation Z_of_N_ge := (fun n m => proj1 (N2Z.inj_ge n m)) (compat "8.3"). -Notation Z_of_N_gt := (fun n m => proj1 (N2Z.inj_gt n m)) (compat "8.3"). -Notation Z_of_N_le_rev := (fun n m => proj2 (N2Z.inj_le n m)) (compat "8.3"). -Notation Z_of_N_lt_rev := (fun n m => proj2 (N2Z.inj_lt n m)) (compat "8.3"). -Notation Z_of_N_ge_rev := (fun n m => proj2 (N2Z.inj_ge n m)) (compat "8.3"). -Notation Z_of_N_gt_rev := (fun n m => proj2 (N2Z.inj_gt n m)) (compat "8.3"). -Notation Z_of_N_pos := N2Z.inj_pos (compat "8.3"). -Notation Z_of_N_abs := N2Z.inj_abs_N (compat "8.3"). -Notation Z_of_N_le_0 := N2Z.is_nonneg (compat "8.3"). -Notation Z_of_N_plus := N2Z.inj_add (compat "8.3"). -Notation Z_of_N_mult := N2Z.inj_mul (compat "8.3"). -Notation Z_of_N_minus := N2Z.inj_sub_max (compat "8.3"). -Notation Z_of_N_succ := N2Z.inj_succ (compat "8.3"). -Notation Z_of_N_min := N2Z.inj_min (compat "8.3"). -Notation Z_of_N_max := N2Z.inj_max (compat "8.3"). -Notation Zabs_of_N := Zabs2N.id (compat "8.3"). -Notation Zabs_N_succ_abs := Zabs2N.inj_succ_abs (compat "8.3"). -Notation Zabs_N_succ := Zabs2N.inj_succ (compat "8.3"). -Notation Zabs_N_plus_abs := Zabs2N.inj_add_abs (compat "8.3"). -Notation Zabs_N_plus := Zabs2N.inj_add (compat "8.3"). -Notation Zabs_N_mult_abs := Zabs2N.inj_mul_abs (compat "8.3"). -Notation Zabs_N_mult := Zabs2N.inj_mul (compat "8.3"). + (fun p => eq_sym (positive_nat_Z p)) (only parsing). + +Notation Z_of_nat_of_N := N_nat_Z (only parsing). +Notation Z_of_N_of_nat := nat_N_Z (only parsing). + +Notation Z_of_N_eq := (f_equal Z.of_N) (only parsing). +Notation Z_of_N_eq_rev := N2Z.inj (only parsing). +Notation Z_of_N_eq_iff := (fun n m => iff_sym (N2Z.inj_iff n m)) (only parsing). +Notation Z_of_N_compare := N2Z.inj_compare (only parsing). +Notation Z_of_N_le_iff := N2Z.inj_le (only parsing). +Notation Z_of_N_lt_iff := N2Z.inj_lt (only parsing). +Notation Z_of_N_ge_iff := N2Z.inj_ge (only parsing). +Notation Z_of_N_gt_iff := N2Z.inj_gt (only parsing). +Notation Z_of_N_le := (fun n m => proj1 (N2Z.inj_le n m)) (only parsing). +Notation Z_of_N_lt := (fun n m => proj1 (N2Z.inj_lt n m)) (only parsing). +Notation Z_of_N_ge := (fun n m => proj1 (N2Z.inj_ge n m)) (only parsing). +Notation Z_of_N_gt := (fun n m => proj1 (N2Z.inj_gt n m)) (only parsing). +Notation Z_of_N_le_rev := (fun n m => proj2 (N2Z.inj_le n m)) (only parsing). +Notation Z_of_N_lt_rev := (fun n m => proj2 (N2Z.inj_lt n m)) (only parsing). +Notation Z_of_N_ge_rev := (fun n m => proj2 (N2Z.inj_ge n m)) (only parsing). +Notation Z_of_N_gt_rev := (fun n m => proj2 (N2Z.inj_gt n m)) (only parsing). +Notation Z_of_N_pos := N2Z.inj_pos (only parsing). +Notation Z_of_N_abs := N2Z.inj_abs_N (only parsing). +Notation Z_of_N_le_0 := N2Z.is_nonneg (only parsing). +Notation Z_of_N_plus := N2Z.inj_add (only parsing). +Notation Z_of_N_mult := N2Z.inj_mul (only parsing). +Notation Z_of_N_minus := N2Z.inj_sub_max (only parsing). +Notation Z_of_N_succ := N2Z.inj_succ (only parsing). +Notation Z_of_N_min := N2Z.inj_min (only parsing). +Notation Z_of_N_max := N2Z.inj_max (only parsing). +Notation Zabs_of_N := Zabs2N.id (only parsing). +Notation Zabs_N_succ_abs := Zabs2N.inj_succ_abs (only parsing). +Notation Zabs_N_succ := Zabs2N.inj_succ (only parsing). +Notation Zabs_N_plus_abs := Zabs2N.inj_add_abs (only parsing). +Notation Zabs_N_plus := Zabs2N.inj_add (only parsing). +Notation Zabs_N_mult_abs := Zabs2N.inj_mul_abs (only parsing). +Notation Zabs_N_mult := Zabs2N.inj_mul (only parsing). Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z.of_nat (n - m) = 0. Proof. diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index ee6efb3c..f5444c31 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (a | - b). Proof. apply Z.divide_opp_r. Qed. @@ -91,12 +93,12 @@ Qed. (** Only [1] and [-1] divide [1]. *) -Notation Zdivide_1 := Z.divide_1_r (compat "8.3"). +Notation Zdivide_1 := Z.divide_1_r (only parsing). (** If [a] divides [b] and [b] divides [a] then [a] is [b] or [-b]. *) -Notation Zdivide_antisym := Z.divide_antisym (compat "8.3"). -Notation Zdivide_trans := Z.divide_trans (compat "8.3"). +Notation Zdivide_antisym := Z.divide_antisym (compat "8.6"). +Notation Zdivide_trans := Z.divide_trans (compat "8.6"). (** If [a] divides [b] and [b<>0] then [|a| <= |b|]. *) @@ -734,7 +736,7 @@ Qed. (** we now prove that [Z.gcd] is indeed a gcd in the sense of [Zis_gcd]. *) -Notation Zgcd_is_pos := Z.gcd_nonneg (compat "8.3"). +Notation Zgcd_is_pos := Z.gcd_nonneg (only parsing). Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Z.gcd a b). Proof. @@ -767,8 +769,8 @@ Proof. - subst. now case (Z.gcd a b). Qed. -Notation Zgcd_inv_0_l := Z.gcd_eq_0_l (compat "8.3"). -Notation Zgcd_inv_0_r := Z.gcd_eq_0_r (compat "8.3"). +Notation Zgcd_inv_0_l := Z.gcd_eq_0_l (only parsing). +Notation Zgcd_inv_0_r := Z.gcd_eq_0_r (only parsing). Theorem Zgcd_div_swap0 : forall a b : Z, 0 < Z.gcd a b -> @@ -798,16 +800,16 @@ Proof. rewrite <- Zdivide_Zdiv_eq; auto. Qed. -Notation Zgcd_comm := Z.gcd_comm (compat "8.3"). +Notation Zgcd_comm := Z.gcd_comm (compat "8.6"). Lemma Zgcd_ass a b c : Z.gcd (Z.gcd a b) c = Z.gcd a (Z.gcd b c). Proof. symmetry. apply Z.gcd_assoc. Qed. -Notation Zgcd_Zabs := Z.gcd_abs_l (compat "8.3"). -Notation Zgcd_0 := Z.gcd_0_r (compat "8.3"). -Notation Zgcd_1 := Z.gcd_1_r (compat "8.3"). +Notation Zgcd_Zabs := Z.gcd_abs_l (only parsing). +Notation Zgcd_0 := Z.gcd_0_r (only parsing). +Notation Zgcd_1 := Z.gcd_1_r (only parsing). Hint Resolve Z.gcd_0_r Z.gcd_1_r : zarith. diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 73dee0cf..a1ec4b35 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -1,10 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* ~ m < n. Proof. @@ -121,18 +123,18 @@ Qed. (** Reflexivity *) -Notation Zle_refl := Z.le_refl (compat "8.3"). -Notation Zeq_le := Z.eq_le_incl (compat "8.3"). +Notation Zle_refl := Z.le_refl (compat "8.6"). +Notation Zeq_le := Z.eq_le_incl (only parsing). Hint Resolve Z.le_refl: zarith. (** Antisymmetry *) -Notation Zle_antisym := Z.le_antisymm (compat "8.3"). +Notation Zle_antisym := Z.le_antisymm (only parsing). (** Asymmetry *) -Notation Zlt_asym := Z.lt_asymm (compat "8.3"). +Notation Zlt_asym := Z.lt_asymm (only parsing). Lemma Zgt_asym n m : n > m -> ~ m > n. Proof. @@ -141,8 +143,8 @@ Qed. (** Irreflexivity *) -Notation Zlt_irrefl := Z.lt_irrefl (compat "8.3"). -Notation Zlt_not_eq := Z.lt_neq (compat "8.3"). +Notation Zlt_irrefl := Z.lt_irrefl (compat "8.6"). +Notation Zlt_not_eq := Z.lt_neq (only parsing). Lemma Zgt_irrefl n : ~ n > n. Proof. @@ -151,8 +153,8 @@ Qed. (** Large = strict or equal *) -Notation Zlt_le_weak := Z.lt_le_incl (compat "8.3"). -Notation Zle_lt_or_eq_iff := Z.lt_eq_cases (compat "8.3"). +Notation Zlt_le_weak := Z.lt_le_incl (only parsing). +Notation Zle_lt_or_eq_iff := Z.lt_eq_cases (only parsing). Lemma Zle_lt_or_eq n m : n <= m -> n < m \/ n = m. Proof. @@ -161,11 +163,11 @@ Qed. (** Dichotomy *) -Notation Zle_or_lt := Z.le_gt_cases (compat "8.3"). +Notation Zle_or_lt := Z.le_gt_cases (only parsing). (** Transitivity of strict orders *) -Notation Zlt_trans := Z.lt_trans (compat "8.3"). +Notation Zlt_trans := Z.lt_trans (compat "8.6"). Lemma Zgt_trans n m p : n > m -> m > p -> n > p. Proof. @@ -174,8 +176,8 @@ Qed. (** Mixed transitivity *) -Notation Zlt_le_trans := Z.lt_le_trans (compat "8.3"). -Notation Zle_lt_trans := Z.le_lt_trans (compat "8.3"). +Notation Zlt_le_trans := Z.lt_le_trans (compat "8.6"). +Notation Zle_lt_trans := Z.le_lt_trans (compat "8.6"). Lemma Zle_gt_trans n m p : m <= n -> m > p -> n > p. Proof. @@ -189,7 +191,7 @@ Qed. (** Transitivity of large orders *) -Notation Zle_trans := Z.le_trans (compat "8.3"). +Notation Zle_trans := Z.le_trans (compat "8.6"). Lemma Zge_trans n m p : n >= m -> m >= p -> n >= p. Proof. @@ -240,8 +242,8 @@ Qed. (** Special base instances of order *) -Notation Zlt_succ := Z.lt_succ_diag_r (compat "8.3"). -Notation Zlt_pred := Z.lt_pred_l (compat "8.3"). +Notation Zlt_succ := Z.lt_succ_diag_r (only parsing). +Notation Zlt_pred := Z.lt_pred_l (only parsing). Lemma Zgt_succ n : Z.succ n > n. Proof. @@ -255,8 +257,8 @@ Qed. (** Relating strict and large order using successor or predecessor *) -Notation Zlt_succ_r := Z.lt_succ_r (compat "8.3"). -Notation Zle_succ_l := Z.le_succ_l (compat "8.3"). +Notation Zlt_succ_r := Z.lt_succ_r (compat "8.6"). +Notation Zle_succ_l := Z.le_succ_l (compat "8.6"). Lemma Zgt_le_succ n m : m > n -> Z.succ n <= m. Proof. @@ -295,10 +297,10 @@ Qed. (** Weakening order *) -Notation Zle_succ := Z.le_succ_diag_r (compat "8.3"). -Notation Zle_pred := Z.le_pred_l (compat "8.3"). -Notation Zlt_lt_succ := Z.lt_lt_succ_r (compat "8.3"). -Notation Zle_le_succ := Z.le_le_succ_r (compat "8.3"). +Notation Zle_succ := Z.le_succ_diag_r (only parsing). +Notation Zle_pred := Z.le_pred_l (only parsing). +Notation Zlt_lt_succ := Z.lt_lt_succ_r (only parsing). +Notation Zle_le_succ := Z.le_le_succ_r (only parsing). Lemma Zle_succ_le n m : Z.succ n <= m -> n <= m. Proof. @@ -334,12 +336,12 @@ Qed. (** Special cases of ordered integers *) -Notation Zlt_0_1 := Z.lt_0_1 (compat "8.3"). -Notation Zle_0_1 := Z.le_0_1 (compat "8.3"). +Notation Zlt_0_1 := Z.lt_0_1 (compat "8.6"). +Notation Zle_0_1 := Z.le_0_1 (compat "8.6"). Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q. Proof. - easy. + exact Pos2Z.neg_le_pos. Qed. Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0. @@ -350,12 +352,12 @@ Qed. (* weaker but useful (in [Z.pow] for instance) *) Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p. Proof. - easy. + exact Pos2Z.pos_is_nonneg. Qed. Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0. Proof. - easy. + exact Pos2Z.neg_is_neg. Qed. Lemma Zle_0_nat : forall n:nat, 0 <= Z.of_nat n. @@ -375,10 +377,10 @@ Qed. (** ** Addition *) (** Compatibility of addition wrt to order *) -Notation Zplus_lt_le_compat := Z.add_lt_le_mono (compat "8.3"). -Notation Zplus_le_lt_compat := Z.add_le_lt_mono (compat "8.3"). -Notation Zplus_le_compat := Z.add_le_mono (compat "8.3"). -Notation Zplus_lt_compat := Z.add_lt_mono (compat "8.3"). +Notation Zplus_lt_le_compat := Z.add_lt_le_mono (only parsing). +Notation Zplus_le_lt_compat := Z.add_le_lt_mono (only parsing). +Notation Zplus_le_compat := Z.add_le_mono (only parsing). +Notation Zplus_lt_compat := Z.add_lt_mono (only parsing). Lemma Zplus_gt_compat_l n m p : n > m -> p + n > p + m. Proof. @@ -412,7 +414,7 @@ Qed. (** Compatibility of addition wrt to being positive *) -Notation Zplus_le_0_compat := Z.add_nonneg_nonneg (compat "8.3"). +Notation Zplus_le_0_compat := Z.add_nonneg_nonneg (only parsing). (** Simplification of addition wrt to order *) @@ -570,9 +572,9 @@ Qed. (** Compatibility of multiplication by a positive wrt to being positive *) -Notation Zmult_le_0_compat := Z.mul_nonneg_nonneg (compat "8.3"). -Notation Zmult_lt_0_compat := Z.mul_pos_pos (compat "8.3"). -Notation Zmult_lt_O_compat := Z.mul_pos_pos (compat "8.3"). +Notation Zmult_le_0_compat := Z.mul_nonneg_nonneg (only parsing). +Notation Zmult_lt_0_compat := Z.mul_pos_pos (only parsing). +Notation Zmult_lt_O_compat := Z.mul_pos_pos (only parsing). Lemma Zmult_gt_0_compat n m : n > 0 -> m > 0 -> n * m > 0. Proof. @@ -624,9 +626,9 @@ Qed. (** * Equivalence between inequalities *) -Notation Zle_plus_swap := Z.le_add_le_sub_r (compat "8.3"). -Notation Zlt_plus_swap := Z.lt_add_lt_sub_r (compat "8.3"). -Notation Zlt_minus_simpl_swap := Z.lt_sub_pos (compat "8.3"). +Notation Zle_plus_swap := Z.le_add_le_sub_r (only parsing). +Notation Zlt_plus_swap := Z.lt_add_lt_sub_r (only parsing). +Notation Zlt_minus_simpl_swap := Z.lt_sub_pos (only parsing). Lemma Zeq_plus_swap n m p : n + p = m <-> n = m - p. Proof. diff --git a/theories/ZArith/Zpow_alt.v b/theories/ZArith/Zpow_alt.v index 79a5a555..983405ac 100644 --- a/theories/ZArith/Zpow_alt.v +++ b/theories/ZArith/Zpow_alt.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 < Z.pow_pos x p. Proof. intros. now apply (Z.pow_pos_nonneg x (Zpos p)). Qed. -Notation Zpower_1_r := Z.pow_1_r (compat "8.3"). -Notation Zpower_1_l := Z.pow_1_l (compat "8.3"). -Notation Zpower_0_l := Z.pow_0_l' (compat "8.3"). -Notation Zpower_0_r := Z.pow_0_r (compat "8.3"). -Notation Zpower_2 := Z.pow_2_r (compat "8.3"). -Notation Zpower_gt_0 := Z.pow_pos_nonneg (compat "8.3"). -Notation Zpower_ge_0 := Z.pow_nonneg (compat "8.3"). -Notation Zpower_Zabs := Z.abs_pow (compat "8.3"). -Notation Zpower_Zsucc := Z.pow_succ_r (compat "8.3"). -Notation Zpower_mult := Z.pow_mul_r (compat "8.3"). -Notation Zpower_le_monotone2 := Z.pow_le_mono_r (compat "8.3"). +Notation Zpower_1_r := Z.pow_1_r (only parsing). +Notation Zpower_1_l := Z.pow_1_l (only parsing). +Notation Zpower_0_l := Z.pow_0_l' (only parsing). +Notation Zpower_0_r := Z.pow_0_r (only parsing). +Notation Zpower_2 := Z.pow_2_r (only parsing). +Notation Zpower_gt_0 := Z.pow_pos_nonneg (only parsing). +Notation Zpower_ge_0 := Z.pow_nonneg (only parsing). +Notation Zpower_Zabs := Z.abs_pow (only parsing). +Notation Zpower_Zsucc := Z.pow_succ_r (only parsing). +Notation Zpower_mult := Z.pow_mul_r (only parsing). +Notation Zpower_le_monotone2 := Z.pow_le_mono_r (only parsing). Theorem Zpower_le_monotone a b c : 0 < a -> 0 <= b <= c -> a^b <= a^c. @@ -231,7 +233,7 @@ Qed. (** * Z.square: a direct definition of [z^2] *) -Notation Psquare := Pos.square (compat "8.3"). -Notation Zsquare := Z.square (compat "8.3"). -Notation Psquare_correct := Pos.square_spec (compat "8.3"). -Notation Zsquare_correct := Z.square_spec (compat "8.3"). +Notation Psquare := Pos.square (compat "8.6"). +Notation Zsquare := Z.square (compat "8.6"). +Notation Psquare_correct := Pos.square_spec (only parsing). +Notation Zsquare_correct := Z.square_spec (only parsing). diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index 6f3a89f1..fa690535 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(*