diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -56,6 +56,12 @@ ghci: $(HCI) -Wall -i:src:test +RTS -M256m -c30 -RTS test/Test.hs +ghci-gauss: + $(HCI) -Wall -i:src:test +RTS -M256m -c30 -RTS test/Test/MathObj/Gaussian/Variance.hs + +ghci-compile: + $(HCI) -Wall -i:src:test +RTS -M256m -c30 -RTS -fobject-code -O -hidir=dist/build -odir=dist/build test/Test.hs + build: -mkdir $(OBJECT_DIR) $(HC) $(GHC_OPTIONS) -hide-package numeric-prelude --make -O $(MODULES) @@ -73,12 +79,3 @@ #scp -r docs/html/* cvs.haskell.org:$(HASKELLORG_HTMLDIR)/ ssh cvs.haskell.org chmod -R o+r $(HASKELLORG_HTMLDIR) #ssh cvs.haskell.org chmod o+x `find $(HASKELLORG_HTMLDIR) -type d` - -# TARBALL = dist/numeric-prelude-0.2.1 - -# sdist: -# cabal sdist -# gunzip --stdout $(TARBALL).tar.gz >$(TARBALL)-ext.tar -# tar rf --dereference $(TARBALL)-ext.tar src-ghc-6.12 -# gzip $(TARBALL)-ext.tar -## gunzip --stdout $(TARBALL).tar.gz | tar r --dereference src-ghc-6.12 | gzip >$(TARBALL)-ext.tar.gz diff --git a/docs/NOTES b/docs/NOTES --- a/docs/NOTES +++ b/docs/NOTES @@ -1,3 +1,91 @@ +* zipWithChecked + +We could make the second operand lazy, +and this way we would get a version of 'zipWith' +that can be used for some tying-the-knot applications +(as in unique-logic and BurrowsWheeler). + +* Algebra.Complex + +conjugate method that works both on real and complex numbers. +This is need in ScalarProduct implementations, +as in Synthesizer.Test.Fourier. + +* multiply vs. mul + +Make identifiers consistent. +I think Gaussian.multiply can be dropped when (*) is removed from Ring. + +* better support for Show instances in NumericPrelude.Text + +Appearance of all objects with prefix constructor should be consistent. + +* Show for infix operators + +Verify Show instances of (%) and (+:). +E.g. Show (Complex Rational) +When a number has negative sign, +the result of 'show' is sometimes no valid Haskell expression. + +* infix operator (*:) for Complex.scale + +This would be nice to have in Gaussian.Bell and Gaussian.Polynomial. + +* explicit export lists + +* AdditiveSemiGroup, AdditiveMonoid, AdditiveGroup + +Matrices with dynamic dimension have no 'zero' (because of unknown dimension) + (that is, they have a commutative AdditiveSemiGroup and MultiplicativeSemiGroup) +NonNegative has no (-) + +* MultiplicativeSemiGroup, MultiplicativeMonoid, MultiplicativeGroup + +Gaussian function, Root, ComplexSquareRoot have no AdditiveGroup operations + +* Decision class should be thrown out again + +They do not scale well. +They should be divided into 'if' and 'select' parts. + +* Eq superclass for Absolute? + +If we have Absolute we can always define + + a == b === isZero (a-b) + +Maybe this reasoning is no longer valid, +when superclasses of Ring are finer grained. + +* Ratios of polynomials + +Q(pi) can be represented by Ratio (Polynomial Integer), +however the standard cancelling algorithm +using the GCD and Euclidean algorithm would not work, +because the GCD is a too strict notion here. +Thus currently Q(pi) must be represented by Ratio (Polynomial Rational), +which is redundant. +How can this be overcome? + +Are there polynomials p and q over Z +such that p and q are relatively prime, +but for an integer multiple k·p and k·q they have a non-trivial common divisor? + +* optimizations + +http://www.haskell.org/pipermail/libraries/2010-September/014434.html + + #4101: constant folding for (**) + #3676: realToFrac conversions + #3744: comparisons against minBound and maxBound are not optimised away + #3065: quot is sub-optimal + #2269: Word type to Double or Float conversions + #2271: floor, ceiling, round :: Double -> Int are awesomely slow + #1434: slow conversion Double to Int + +All are accessible as http://hackage.haskell.org/trac/ghc/ticket/4101, etc. +All need love. + * sum (and mconcat) How to provide a 'sum' function that works optimal for the strict and lazy types? @@ -314,6 +402,15 @@ +* Function type class + +Useful for all function representations like Polynomials, Gaussian functions. +However polynomials can only be applied to Ring types, +and Gaussian functions can only be applied to Transcendental types. +This it would require the usual type tricks +for type constructor class with restricted type arguments. + + * Complex numbers The module looks horrible because auxiliary type classes are introduced @@ -340,7 +437,7 @@ - Partial Fractions: - introduce Indexable type class for allowing partial fractions of polynomials - example decomposition (e.g. implemented in test suite) - (n-2)*(n+2)/((n-4)*n*(n+4)) + (n-2)·(n+2)/((n-4)·n·(n+4)) - Hypercomplex numbers: Octonions - matrices, vectors - conversion of complex and quaternions to real matrices diff --git a/numeric-prelude.cabal b/numeric-prelude.cabal --- a/numeric-prelude.cabal +++ b/numeric-prelude.cabal @@ -1,5 +1,5 @@ Name: numeric-prelude -Version: 0.2.2.1 +Version: 0.3 License: GPL License-File: LICENSE Author: Dylan Thurston , Henning Thielemann , Mikael Johansson @@ -7,9 +7,10 @@ Homepage: http://www.haskell.org/haskellwiki/Numeric_Prelude Category: Math Stability: Experimental +Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3 +Tested-With: GHC==7.2.2 Cabal-Version: >=1.6 Build-Type: Simple -Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3, GHC==7.0.2, GHC==7.2.1 Synopsis: An experimental alternative hierarchy of numeric type classes Description: Revisiting the Numeric Classes @@ -94,7 +95,11 @@ you could also write @import Prelude ()@ but this will yield problems with numeric literals. . + There are two wrapper types that allow types + to be used with both Haskell98 and NumericPrelude type classes + that are initially implemented for only one of them. . + . Scope & Limitations\/TODO: . * It might be desireable to split Ord up into Poset and Ord @@ -139,236 +144,7 @@ Makefile docs/NOTES docs/README - src/Algebra/Absolute.hs - src/Algebra/Additive.hs - src/Algebra/AffineSpace.hs - src/Algebra/Algebraic.hs - src/Algebra/Differential.hs - src/Algebra/DimensionTerm.hs - src/Algebra/DivisibleSpace.hs - src/Algebra/EqualityDecision.hs - src/Algebra/Field.hs src/Algebra/GenerateRules.hs - src/Algebra/Indexable.hs - src/Algebra/IntegralDomain.hs - src/Algebra/Lattice.hs - src/Algebra/Laws.hs - src/Algebra/Module.hs - src/Algebra/ModuleBasis.hs - src/Algebra/Monoid.hs - src/Algebra/NonNegative.hs - src/Algebra/NormedSpace/Euclidean.hs - src/Algebra/NormedSpace/Maximum.hs - src/Algebra/NormedSpace/Sum.hs - src/Algebra/OccasionallyScalar.hs - src/Algebra/OrderDecision.hs - src/Algebra/PrincipalIdealDomain.hs - src/Algebra/RealField.hs - src/Algebra/RealIntegral.hs - src/Algebra/RealRing.hs - src/Algebra/RealTranscendental.hs - src/Algebra/RightModule.hs - src/Algebra/Ring.hs - src/Algebra/ToInteger.hs - src/Algebra/ToRational.hs - src/Algebra/Transcendental.hs - src/Algebra/Units.hs - src/Algebra/Vector.hs - src/Algebra/VectorSpace.hs - src/Algebra/ZeroTestable.hs - src/MathObj/Algebra.hs - src/MathObj/DiscreteMap.hs - src/MathObj/Gaussian/Bell.hs - src/MathObj/Gaussian/Example.hs - src/MathObj/Gaussian/Polynomial.hs - src/MathObj/Gaussian/Variance.hs - src/MathObj/LaurentPolynomial.hs - src/MathObj/Matrix.hs - src/MathObj/Monoid.hs - src/MathObj/PartialFraction.hs - src/MathObj/Permutation.hs - src/MathObj/Permutation/CycleList.hs - src/MathObj/Permutation/CycleList/Check.hs - src/MathObj/Permutation/Table.hs - src/MathObj/Polynomial.hs - src/MathObj/Polynomial/Core.hs - src/MathObj/PowerSeries.hs - src/MathObj/PowerSeries/Core.hs - src/MathObj/PowerSeries/DifferentialEquation.hs - src/MathObj/PowerSeries/Example.hs - src/MathObj/PowerSeries/Mean.hs - src/MathObj/PowerSeries2.hs - src/MathObj/PowerSeries2/Core.hs - src/MathObj/PowerSum.hs - src/MathObj/RefinementMask2.hs - src/MathObj/RootSet.hs - src/Number/Complex.hs - src/Number/ComplexSquareRoot.hs - src/Number/DimensionTerm.hs - src/Number/DimensionTerm/SI.hs - src/Number/FixedPoint.hs - src/Number/FixedPoint/Check.hs - src/Number/GaloisField2p32m5.hs - src/Number/NonNegative.hs - src/Number/NonNegativeChunky.hs - src/Number/OccasionallyScalarExpression.hs - src/Number/PartiallyTranscendental.hs - src/Number/Peano.hs - src/Number/Physical.hs - src/Number/Physical/Read.hs - src/Number/Physical/Show.hs - src/Number/Physical/Unit.hs - src/Number/Physical/UnitDatabase.hs - src/Number/Positional.hs - src/Number/Positional/Check.hs - src/Number/Quaternion.hs - src/Number/Ratio.hs - src/Number/ResidueClass.hs - src/Number/ResidueClass/Check.hs - src/Number/ResidueClass/Func.hs - src/Number/ResidueClass/Maybe.hs - src/Number/ResidueClass/Reader.hs - src/Number/Root.hs - src/Number/SI.hs - src/Number/SI/Unit.hs - src/NumericPrelude.hs - src/NumericPrelude/Base.hs - src/NumericPrelude/Elementwise.hs - src/NumericPrelude/List.hs - src/NumericPrelude/List/Checked.hs - src/NumericPrelude/List/Generic.hs - src/NumericPrelude/Numeric.hs - test/Gaussian.hs - test/Test.hs - test/Test/Algebra/IntegralDomain.hs - test/Test/Algebra/RealRing.hs - test/Test/MathObj/Gaussian/Bell.hs - test/Test/MathObj/Gaussian/Polynomial.hs - test/Test/MathObj/Gaussian/Variance.hs - test/Test/MathObj/Matrix.hs - test/Test/MathObj/PartialFraction.hs - test/Test/MathObj/Polynomial.hs - test/Test/MathObj/PowerSeries.hs - test/Test/MathObj/RefinementMask2.hs - test/Test/Number/ComplexSquareRoot.hs - test/Test/Number/GaloisField2p32m5.hs - test/Test/NumericPrelude/Utility.hs - test/Test/Run.hs - src-ghc-6.12/Algebra/Absolute.hs - src-ghc-6.12/Algebra/Additive.hs - src-ghc-6.12/Algebra/AffineSpace.hs - src-ghc-6.12/Algebra/Algebraic.hs - src-ghc-6.12/Algebra/Differential.hs - src-ghc-6.12/Algebra/DimensionTerm.hs - src-ghc-6.12/Algebra/DivisibleSpace.hs - src-ghc-6.12/Algebra/EqualityDecision.hs - src-ghc-6.12/Algebra/Field.hs - src-ghc-6.12/Algebra/GenerateRules.hs - src-ghc-6.12/Algebra/Indexable.hs - src-ghc-6.12/Algebra/IntegralDomain.hs - src-ghc-6.12/Algebra/Lattice.hs - src-ghc-6.12/Algebra/Laws.hs - src-ghc-6.12/Algebra/Module.hs - src-ghc-6.12/Algebra/ModuleBasis.hs - src-ghc-6.12/Algebra/Monoid.hs - src-ghc-6.12/Algebra/NonNegative.hs - src-ghc-6.12/Algebra/NormedSpace/Euclidean.hs - src-ghc-6.12/Algebra/NormedSpace/Maximum.hs - src-ghc-6.12/Algebra/NormedSpace/Sum.hs - src-ghc-6.12/Algebra/OccasionallyScalar.hs - src-ghc-6.12/Algebra/OrderDecision.hs - src-ghc-6.12/Algebra/PrincipalIdealDomain.hs - src-ghc-6.12/Algebra/RealField.hs - src-ghc-6.12/Algebra/RealIntegral.hs - src-ghc-6.12/Algebra/RealRing.hs - src-ghc-6.12/Algebra/RealTranscendental.hs - src-ghc-6.12/Algebra/RightModule.hs - src-ghc-6.12/Algebra/Ring.hs - src-ghc-6.12/Algebra/ToInteger.hs - src-ghc-6.12/Algebra/ToRational.hs - src-ghc-6.12/Algebra/Transcendental.hs - src-ghc-6.12/Algebra/Units.hs - src-ghc-6.12/Algebra/Vector.hs - src-ghc-6.12/Algebra/VectorSpace.hs - src-ghc-6.12/Algebra/ZeroTestable.hs - src-ghc-6.12/MathObj/Algebra.hs - src-ghc-6.12/MathObj/DiscreteMap.hs - src-ghc-6.12/MathObj/Gaussian/Bell.hs - src-ghc-6.12/MathObj/Gaussian/Example.hs - src-ghc-6.12/MathObj/Gaussian/Polynomial.hs - src-ghc-6.12/MathObj/Gaussian/Variance.hs - src-ghc-6.12/MathObj/LaurentPolynomial.hs - src-ghc-6.12/MathObj/Matrix.hs - src-ghc-6.12/MathObj/Monoid.hs - src-ghc-6.12/MathObj/PartialFraction.hs - src-ghc-6.12/MathObj/Permutation.hs - src-ghc-6.12/MathObj/Permutation/CycleList.hs - src-ghc-6.12/MathObj/Permutation/CycleList/Check.hs - src-ghc-6.12/MathObj/Permutation/Table.hs - src-ghc-6.12/MathObj/Polynomial.hs - src-ghc-6.12/MathObj/Polynomial/Core.hs - src-ghc-6.12/MathObj/PowerSeries.hs - src-ghc-6.12/MathObj/PowerSeries/Core.hs - src-ghc-6.12/MathObj/PowerSeries/DifferentialEquation.hs - src-ghc-6.12/MathObj/PowerSeries/Example.hs - src-ghc-6.12/MathObj/PowerSeries/Mean.hs - src-ghc-6.12/MathObj/PowerSeries2.hs - src-ghc-6.12/MathObj/PowerSeries2/Core.hs - src-ghc-6.12/MathObj/PowerSum.hs - src-ghc-6.12/MathObj/RefinementMask2.hs - src-ghc-6.12/MathObj/RootSet.hs - src-ghc-6.12/Number/Complex.hs - src-ghc-6.12/Number/ComplexSquareRoot.hs - src-ghc-6.12/Number/DimensionTerm.hs - src-ghc-6.12/Number/DimensionTerm/SI.hs - src-ghc-6.12/Number/FixedPoint.hs - src-ghc-6.12/Number/FixedPoint/Check.hs - src-ghc-6.12/Number/GaloisField2p32m5.hs - src-ghc-6.12/Number/NonNegative.hs - src-ghc-6.12/Number/NonNegativeChunky.hs - src-ghc-6.12/Number/OccasionallyScalarExpression.hs - src-ghc-6.12/Number/PartiallyTranscendental.hs - src-ghc-6.12/Number/Peano.hs - src-ghc-6.12/Number/Physical.hs - src-ghc-6.12/Number/Physical/Read.hs - src-ghc-6.12/Number/Physical/Show.hs - src-ghc-6.12/Number/Physical/Unit.hs - src-ghc-6.12/Number/Physical/UnitDatabase.hs - src-ghc-6.12/Number/Positional.hs - src-ghc-6.12/Number/Positional/Check.hs - src-ghc-6.12/Number/Quaternion.hs - src-ghc-6.12/Number/Ratio.hs - src-ghc-6.12/Number/ResidueClass.hs - src-ghc-6.12/Number/ResidueClass/Check.hs - src-ghc-6.12/Number/ResidueClass/Func.hs - src-ghc-6.12/Number/ResidueClass/Maybe.hs - src-ghc-6.12/Number/ResidueClass/Reader.hs - src-ghc-6.12/Number/Root.hs - src-ghc-6.12/Number/SI.hs - src-ghc-6.12/Number/SI/Unit.hs - src-ghc-6.12/NumericPrelude.hs - src-ghc-6.12/NumericPrelude/Base.hs - src-ghc-6.12/NumericPrelude/Elementwise.hs - src-ghc-6.12/NumericPrelude/List.hs - src-ghc-6.12/NumericPrelude/List/Checked.hs - src-ghc-6.12/NumericPrelude/List/Generic.hs - src-ghc-6.12/NumericPrelude/Numeric.hs - test-ghc-6.12/Gaussian.hs - test-ghc-6.12/Test.hs - test-ghc-6.12/Test/Algebra/IntegralDomain.hs - test-ghc-6.12/Test/Algebra/RealRing.hs - test-ghc-6.12/Test/MathObj/Gaussian/Bell.hs - test-ghc-6.12/Test/MathObj/Gaussian/Polynomial.hs - test-ghc-6.12/Test/MathObj/Gaussian/Variance.hs - test-ghc-6.12/Test/MathObj/Matrix.hs - test-ghc-6.12/Test/MathObj/PartialFraction.hs - test-ghc-6.12/Test/MathObj/Polynomial.hs - test-ghc-6.12/Test/MathObj/PowerSeries.hs - test-ghc-6.12/Test/MathObj/RefinementMask2.hs - test-ghc-6.12/Test/Number/ComplexSquareRoot.hs - test-ghc-6.12/Test/Number/GaloisField2p32m5.hs - test-ghc-6.12/Test/NumericPrelude/Utility.hs - test-ghc-6.12/Test/Run.hs Flag splitBase description: Choose the new smaller, split-up base package. @@ -392,7 +168,8 @@ QuickCheck >=1 && <3, storable-record >=0.0.1 && <0.1, non-negative >=0.0.5 && <0.2, - utility-ht >=0.0.6 && <0.1 + utility-ht >=0.0.6 && <0.1, + deepseq >=1.1 && <1.3 If flag(splitBase) Build-Depends: base >= 2 && <6, @@ -402,11 +179,12 @@ Else Build-Depends: base >= 1.0 && < 2 - GHC-Options: -Wall If impl(ghc>=7.0) - Hs-source-dirs: src - Else - Hs-source-dirs: src-ghc-6.12 + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Extensions: CPP + + GHC-Options: -Wall + Hs-source-dirs: src Exposed-modules: Algebra.Absolute Algebra.Additive @@ -463,6 +241,8 @@ MathObj.PowerSum MathObj.RefinementMask2 MathObj.RootSet + MathObj.Wrapper.Haskell98 + MathObj.Wrapper.NumericPrelude Number.Complex Number.DimensionTerm Number.DimensionTerm.SI @@ -500,6 +280,7 @@ Other-modules: NumericPrelude.List Algebra.AffineSpace + Algebra.RealRing98 MathObj.Gaussian.Variance MathObj.Gaussian.Bell MathObj.Gaussian.Polynomial @@ -510,19 +291,19 @@ Algebra.OrderDecision Executable test - If impl(ghc>=7.0) - Hs-source-dirs: src, test - Else - Hs-source-dirs: src-ghc-6.12, test-ghc-6.12 + Hs-Source-Dirs: src, test + GHC-Options: -Wall Main-Is: Test.hs + If !flag(buildTests) Buildable: False -Executable testsuite If impl(ghc>=7.0) - Hs-source-dirs: src, test - Else - Hs-source-dirs: src-ghc-6.12, test-ghc-6.12 + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Extensions: CPP + +Executable testsuite + Hs-Source-Dirs: src, test GHC-Options: -Wall Other-modules: Test.NumericPrelude.Utility @@ -530,6 +311,7 @@ Test.Number.ComplexSquareRoot Test.Algebra.IntegralDomain Test.Algebra.RealRing + Test.Algebra.Additive Test.MathObj.RefinementMask2 Test.MathObj.PartialFraction Test.MathObj.Matrix @@ -539,16 +321,18 @@ Test.MathObj.Gaussian.Bell Test.MathObj.Gaussian.Polynomial Main-Is: Test/Run.hs + If flag(buildTests) Build-Depends: HUnit >=1 && <2 Else Buildable: False -Executable test-gaussian If impl(ghc>=7.0) - Hs-source-dirs: src, test - Else - Hs-source-dirs: src-ghc-6.12, test-ghc-6.12 + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Extensions: CPP + +Executable test-gaussian + Hs-Source-Dirs: src, test Main-Is: Gaussian.hs Other-Modules: MathObj.Gaussian.Example @@ -558,3 +342,7 @@ HTam >=0.0.2 && <0.1 Else Buildable: False + + If impl(ghc>=7.0) + CPP-Options: -DNoImplicitPrelude=RebindableSyntax + Extensions: CPP diff --git a/src-ghc-6.12/Algebra/Absolute.hs b/src-ghc-6.12/Algebra/Absolute.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Absolute.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.Absolute ( - C(abs, signum), - absOrd, signumOrd, - ) where - -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import Algebra.Ring (one, ) -- fromInteger -import Algebra.Additive (zero, negate,) - -import Data.Int (Int, Int8, Int16, Int32, Int64, ) -import Data.Word (Word, Word8, Word16, Word32, Word64, ) - -import NumericPrelude.Base -import qualified Prelude as P -import Prelude (Integer, Float, Double, ) - - -{- | -This is the type class of a ring with a notion of an absolute value, -satisfying the laws - -> a * b === b * a -> a /= 0 => abs (signum a) === 1 -> abs a * signum a === a - -Minimal definition: 'abs', 'signum'. - -If the type is in the 'Ord' class -we expect 'abs' = 'absOrd' and 'signum' = 'signumOrd' -and we expect the following laws to hold: - -> a + (max b c) === max (a+b) (a+c) -> negate (max b c) === min (negate b) (negate c) -> a * (max b c) === max (a*b) (a*c) where a >= 0 -> absOrd a === max a (-a) - -We do not require 'Ord' as superclass -since we also want to have "Number.Complex" as instance. -'abs' for complex numbers alone may have an inappropriate type, -because it does not reflect that the absolute value is a real number. -You might prefer 'Number.Complex.magnitude'. -This type class is intended for unifying algorithms -that work for both real and complex numbers. -Note the similarity to "Algebra.Units": -'abs' plays the role of @stdAssociate@ -and 'signum' plays the role of @stdUnit@. - -Actually, since 'abs' can be defined using 'max' and 'negate' -we could relax the superclasses to @Additive@ and 'Ord' -if his class would only contain 'signum'. --} -class (Ring.C a, ZeroTestable.C a) => C a where - abs :: a -> a - signum :: a -> a - - -absOrd :: (Additive.C a, Ord a) => a -> a -absOrd x = max x (negate x) - -signumOrd :: (Ring.C a, Ord a) => a -> a -signumOrd x = - case compare x zero of - GT -> one - EQ -> zero - LT -> negate one - - -instance C Integer where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - -instance C Float where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - -instance C Double where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - - -instance C Int where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - -instance C Int8 where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - -instance C Int16 where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - -instance C Int32 where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - -instance C Int64 where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - - -instance C Word where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - -instance C Word8 where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - -instance C Word16 where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - -instance C Word32 where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - -instance C Word64 where - {-# INLINE abs #-} - {-# INLINE signum #-} - abs = P.abs - signum = P.signum - diff --git a/src-ghc-6.12/Algebra/Additive.hs b/src-ghc-6.12/Algebra/Additive.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Additive.hs +++ /dev/null @@ -1,364 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.Additive ( - -- * Class - C, - zero, - (+), (-), - negate, subtract, - - -- * Complex functions - sum, sum1, - - -- * Instance definition helpers - elementAdd, elementSub, elementNeg, - (<*>.+), (<*>.-), (<*>.-$), - - -- * Instances for atomic types - propAssociative, - propCommutative, - propIdentity, - propInverse, - ) where - -import qualified Algebra.Laws as Laws - -import Data.Int (Int, Int8, Int16, Int32, Int64, ) -import Data.Word (Word, Word8, Word16, Word32, Word64, ) - -import qualified NumericPrelude.Elementwise as Elem -import Control.Applicative (Applicative(pure, (<*>)), ) -import Data.Tuple.HT (fst3, snd3, thd3, ) - -import qualified Data.Ratio as Ratio98 -import qualified Prelude as P -import Prelude (Integer, Float, Double, fromInteger, ) -import NumericPrelude.Base - - -infixl 6 +, - - -{- | -Additive a encapsulates the notion of a commutative group, specified -by the following laws: - -@ - a + b === b + a - (a + b) + c === a + (b + c) - zero + a === a - a + negate a === 0 -@ - -Typical examples include integers, dollars, and vectors. - -Minimal definition: '+', 'zero', and ('negate' or '(-)') --} - -class C a where - -- | zero element of the vector space - zero :: a - -- | add and subtract elements - (+), (-) :: a -> a -> a - -- | inverse with respect to '+' - negate :: a -> a - - {-# INLINE negate #-} - negate a = zero - a - {-# INLINE (-) #-} - a - b = a + negate b - -{- | -'subtract' is @(-)@ with swapped operand order. -This is the operand order which will be needed in most cases -of partial application. --} -subtract :: C a => a -> a -> a -subtract = flip (-) - - - - -{- | -Sum up all elements of a list. -An empty list yields zero. - -This function is inappropriate for number types like Peano. -Maybe we should make 'sum' a method of Additive. -This would also make 'lengthLeft' and 'lengthRight' superfluous. --} -sum :: (C a) => [a] -> a -sum = foldl (+) zero - -{- | -Sum up all elements of a non-empty list. -This avoids including a zero which is useful for types -where no universal zero is available. --} -sum1 :: (C a) => [a] -> a -sum1 = foldl1 (+) - - - -{- | -Instead of baking the add operation into the element function, -we could use higher rank types -and pass a generic @uncurry (+)@ to the run function. -We do not do so in order to stay Haskell 98 -at least for parts of NumericPrelude. --} -{-# INLINE elementAdd #-} -elementAdd :: - (C x) => - (v -> x) -> Elem.T (v,v) x -elementAdd f = - Elem.element (\(x,y) -> f x + f y) - -{-# INLINE elementSub #-} -elementSub :: - (C x) => - (v -> x) -> Elem.T (v,v) x -elementSub f = - Elem.element (\(x,y) -> f x - f y) - -{-# INLINE elementNeg #-} -elementNeg :: - (C x) => - (v -> x) -> Elem.T v x -elementNeg f = - Elem.element (negate . f) - - --- like <*> -infixl 4 <*>.+, <*>.-, <*>.-$ - -{- | -> addPair :: (Additive.C a, Additive.C b) => (a,b) -> (a,b) -> (a,b) -> addPair = Elem.run2 $ Elem.with (,) <*>.+ fst <*>.+ snd --} -{-# INLINE (<*>.+) #-} -(<*>.+) :: - (C x) => - Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a -(<*>.+) f acc = - f <*> elementAdd acc - -{-# INLINE (<*>.-) #-} -(<*>.-) :: - (C x) => - Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a -(<*>.-) f acc = - f <*> elementSub acc - -{-# INLINE (<*>.-$) #-} -(<*>.-$) :: - (C x) => - Elem.T v (x -> a) -> (v -> x) -> Elem.T v a -(<*>.-$) f acc = - f <*> elementNeg acc - - --- * Instances for atomic types - -instance C Integer where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Float where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Double where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - - -instance C Int where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Int8 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Int16 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Int32 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Int64 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - - -instance C Word where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Word8 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Word16 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Word32 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Word64 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - - - - --- * Instances for composed types - -instance (C v0, C v1) => C (v0, v1) where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = (,) zero zero - (+) = Elem.run2 $ pure (,) <*>.+ fst <*>.+ snd - (-) = Elem.run2 $ pure (,) <*>.- fst <*>.- snd - negate = Elem.run $ pure (,) <*>.-$ fst <*>.-$ snd - -instance (C v0, C v1, C v2) => C (v0, v1, v2) where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = (,,) zero zero zero - (+) = Elem.run2 $ pure (,,) <*>.+ fst3 <*>.+ snd3 <*>.+ thd3 - (-) = Elem.run2 $ pure (,,) <*>.- fst3 <*>.- snd3 <*>.- thd3 - negate = Elem.run $ pure (,,) <*>.-$ fst3 <*>.-$ snd3 <*>.-$ thd3 - - -instance (C v) => C [v] where - zero = [] - negate = map negate - (+) (x:xs) (y:ys) = (+) x y : (+) xs ys - (+) xs [] = xs - (+) [] ys = ys - (-) (x:xs) (y:ys) = (-) x y : (-) xs ys - (-) xs [] = xs - (-) [] ys = negate ys - - -instance (C v) => C (b -> v) where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero _ = zero - (+) f g x = (+) (f x) (g x) - (-) f g x = (-) (f x) (g x) - negate f x = negate (f x) - --- * Properties - -propAssociative :: (Eq a, C a) => a -> a -> a -> Bool -propCommutative :: (Eq a, C a) => a -> a -> Bool -propIdentity :: (Eq a, C a) => a -> Bool -propInverse :: (Eq a, C a) => a -> Bool - -propCommutative = Laws.commutative (+) -propAssociative = Laws.associative (+) -propIdentity = Laws.identity (+) zero -propInverse = Laws.inverse (+) negate zero - - - --- legacy - -instance (P.Integral a) => C (Ratio98.Ratio a) where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = 0 - (+) = (P.+) - (-) = (P.-) - negate = P.negate diff --git a/src-ghc-6.12/Algebra/AffineSpace.hs b/src-ghc-6.12/Algebra/AffineSpace.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/AffineSpace.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- | -This module is not yet exported -since its interface is not mature. -There are two approaches for representing affine spaces: - -[1] Two sets: A set of points and a set of vectors. - Examples: Absolute potential and voltage, - absolute temperature and temperature difference. - Operations are - add :: vector -> point -> point - sub :: point -> point -> vector - -[2] One set for points, no vectors. - Examples: Interpolation - Operation: - combine :: [(coefficient, vector)] -> vector - Where it must be asserted, - that the coefficients sum up to 1. - -The second one is the one we follow here. -It is more similar to Module and VectorSpace. --} -module Algebra.AffineSpace where - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Additive as Additive -import qualified Algebra.Module as Module -import qualified Number.Ratio as Ratio - -import qualified Number.Complex as Complex - -import Control.Applicative (Applicative(pure, (<*>)), ) - -import NumericPrelude.Numeric hiding (zero, ) -import NumericPrelude.Base -import Prelude () - -{- | -The type class is for representing affine spaces via affine combinations. -However, we didn't find a way to both ensure the property -that the combination coefficients sum up to 1, -and keep it efficient. - -We propose this class instead of a combination of Additive and Module -for interpolation for those types, -where scaling and addition alone makes no sense. -Such types are e.g. internal filter parameters in signal processing: -For these types interpolation makes definitely sense, -but addition and scaling make not. - -That is, both classes are isomorphic -(you can define one in terms of the other), -but instances of this class are more easily defined, -and using an AffineSpace constraint instead of Module in a type signature -is important for documentation purposes. -AffineSpace should be superclass of Module. -(But then you may ask, why not adding another superclass for Convex spaces. -This class would provide a linear combination operation, -where the coefficients sum up to one -and all of them are non-negative.) - -We may add a safety layer that ensures -that the coefficients sum up to 1, -using start points on the simplex -and functions to move on the simplex. -Start points have components that sum up to 1, e.g. - -> (1, 0, 0, 0) -> (0, 1, 0, 0) -> (0, 0, 1, 0) -> (0, 0, 0, 1) -> (1/4, 1/4, 1/4, 1/4) - -Then you may move along the simplex in the directions - -> (1, -1, 0, 0) -> (0, 1, 0, -1) -> (-1, -1, 3, -1) - -which are characterized by components that sum up to 0. - -For example linear combination is defined by - -> lerp k (a,b) = (1-k)*>a + k*>b - -that is the coefficients are (1-k) and k. -The pair (1-k, k) can be constructed -by starting at pair (1,0) -and moving k units in direction (-1,1). - -> (1-k, k) = (1,0) + k*(-1,1) - -It is however a challenge to manage the coefficient tuples -in a type safe and efficient way. -For small numbers of interpolation nodes -(constant, linear, cubic interpolation) -a type level list would appropriate, -but what to do for large tuples -like for Whittaker interpolation? - - -As side note: -In principle it would be sufficient -to provide an affine combination of two points, -since all affine combinations of more points -can be decomposed into such simple combinations. - -> lerp a x y = (1-a)*>x + a*>y - -E.g. @a*>x + b*>y + c*>z@ with @a+b+c=1@ -can be written as @lerp c (lerp (b/(1-c)) x y) z@. -More generally you can use - -> lerpnorm a b x y -> = lerp (b/(a+b)) x y -> = (a/(a+b))*>x + (b/(a+b))*>y - -for writing - -> a*>x + b*>y + c*>z == -> lerpnorm (a+b) c (lerpnorm a b x y) z - -or - -> a*>x + b*>y + c*>z + d*>w == -> lerpnorm (a+b+c) d (lerpnorm (a+b) c (lerpnorm a b x y) z) w - -with @a+b+c+d=1@. - -The downside is, that lerpnorm requires division, that is, a field, -whereas the computation of the coefficients -sometimes only requires ring operations. --} -class Zero v => C a v where - multiplyAccumulate :: (a,v) -> v -> v - -class Zero v where - zero :: v - - -instance Zero Float where - {-# INLINE zero #-} - zero = Additive.zero - -instance Zero Double where - {-# INLINE zero #-} - zero = Additive.zero - -instance (Zero a) => Zero (Complex.T a) where - {-# INLINE zero #-} - zero = zero Complex.+: zero - -instance (PID.C a) => Zero (Ratio.T a) where - {-# INLINE zero #-} - zero = Additive.zero - - -instance C Float Float where - {-# INLINE multiplyAccumulate #-} - multiplyAccumulate (a,x) y = a*x+y - -instance C Double Double where - {-# INLINE multiplyAccumulate #-} - multiplyAccumulate (a,x) y = a*x+y - -instance (C a v) => C a (Complex.T v) where - {-# INLINE multiplyAccumulate #-} - multiplyAccumulate = - makeMac2 (Complex.+:) Complex.real Complex.imag - -instance (PID.C a) => C (Ratio.T a) (Ratio.T a) where - {-# INLINE multiplyAccumulate #-} - multiplyAccumulate (a,x) y = a*x+y - - -infixl 6 *.+ - -{- | -Infix variant of 'multiplyAccumulate'. --} -{-# INLINE (*.+) #-} -(*.+) :: C a v => v -> (a,v) -> v -(*.+) = flip multiplyAccumulate - - --- * convenience functions for defining multiplyAccumulate - -{-# INLINE multiplyAccumulateModule #-} -multiplyAccumulateModule :: - Module.C a v => - (a,v) -> v -> v -multiplyAccumulateModule (a,x) y = - a *> x + y - - -{- | -A special reader monad. --} -newtype MAC a v x = MAC {runMac :: (a,v) -> v -> x} - -{-# INLINE element #-} -element :: - (C a x) => - (v -> x) -> MAC a v x -element f = - MAC (\(a,x) y -> multiplyAccumulate (a, f x) (f y)) - -instance Functor (MAC a v) where - {-# INLINE fmap #-} - fmap f (MAC x) = - MAC $ \av v -> f $ x av v - -instance Applicative (MAC a v) where - {-# INLINE pure #-} - {-# INLINE (<*>) #-} - pure x = MAC $ \ _av _v -> x - MAC f <*> MAC x = - MAC $ \av v -> f av v $ x av v - -{-# INLINE makeMac #-} -makeMac :: - (C a x) => - (x -> v) -> - (v -> x) -> - (a,v) -> v -> v -makeMac cons x = - runMac $ pure cons <*> element x - -{-# INLINE makeMac2 #-} -makeMac2 :: - (C a x, C a y) => - (x -> y -> v) -> - (v -> x) -> (v -> y) -> - (a,v) -> v -> v -makeMac2 cons x y = - runMac $ pure cons <*> element x <*> element y - -{-# INLINE makeMac3 #-} -makeMac3 :: - (C a x, C a y, C a z) => - (x -> y -> z -> v) -> - (v -> x) -> (v -> y) -> (v -> z) -> - (a,v) -> v -> v -makeMac3 cons x y z = - runMac $ pure cons <*> element x <*> element y <*> element z diff --git a/src-ghc-6.12/Algebra/Algebraic.hs b/src-ghc-6.12/Algebra/Algebraic.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Algebraic.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.Algebraic where - -import qualified Algebra.Field as Field --- import qualified Algebra.Units as Units -import qualified Algebra.Laws as Laws -import qualified Algebra.ToRational as ToRational -import qualified Algebra.ToInteger as ToInteger - -import Number.Ratio (Rational, (%), numerator, denominator) -import Algebra.Field ((^-), recip, fromRational') -import Algebra.Ring ((*), (^), fromInteger) -import Algebra.Additive((+)) - -import NumericPrelude.Base -import qualified Prelude as P - - -infixr 8 ^/ - -{- | Minimal implementation: 'root' or '(^\/)'. -} - -class (Field.C a) => C a where - sqrt :: a -> a - sqrt = root 2 - -- sqrt x = x ** (1/2) - - root :: P.Integer -> a -> a - root n x = x ^/ (1 % n) - - (^/) :: a -> Rational -> a - x ^/ y = root (denominator y) (x ^- numerator y) - -genericRoot :: (C a, ToInteger.C b) => b -> a -> a -genericRoot n = root (ToInteger.toInteger n) - -power :: (C a, ToRational.C b) => b -> a -> a -power r = (^/ ToRational.toRational r) - -instance C P.Float where - sqrt = P.sqrt - root n x = x P.** recip (P.fromInteger n) - x ^/ y = x P.** fromRational' y - -instance C P.Double where - sqrt = P.sqrt - root n x = x P.** recip (P.fromInteger n) - x ^/ y = x P.** fromRational' y - - -{- * Properties -} - --- propSqrtSqr :: (Eq a, C a, Units.C a) => a -> Bool --- propSqrtSqr x = sqrt (x^2) == Units.stdAssociate x - -propSqrSqrt :: (Eq a, C a) => a -> Bool -propSqrSqrt x = sqrt x ^ 2 == x - -propPowerCascade :: (Eq a, C a) => a -> Rational -> Rational -> Bool -propPowerProduct :: (Eq a, C a) => a -> Rational -> Rational -> Bool -propPowerDistributive :: (Eq a, C a) => Rational -> a -> a -> Bool - -propPowerCascade x i j = Laws.rightCascade (*) (^/) x i j -propPowerProduct x i j = Laws.homomorphism (x^/) (+) (*) i j -propPowerDistributive i x y = Laws.leftDistributive (^/) (*) i x y diff --git a/src-ghc-6.12/Algebra/Differential.hs b/src-ghc-6.12/Algebra/Differential.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Differential.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.Differential where - -import qualified Algebra.Ring as Ring - --- import NumericPrelude.Numeric --- import qualified Prelude - -{- | -'differentiate' is a general differentation operation -It must fulfill the Leibnitz condition - -> differentiate (x * y) == differentiate x * y + x * differentiate y - -Unfortunately, this scheme cannot be easily extended to more than two variables, -e.g. "MathObj.PowerSeries2". --} -class Ring.C a => C a where - differentiate :: a -> a diff --git a/src-ghc-6.12/Algebra/DimensionTerm.hs b/src-ghc-6.12/Algebra/DimensionTerm.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/DimensionTerm.hs +++ /dev/null @@ -1,225 +0,0 @@ -{- | -Copyright : (c) Henning Thielemann 2008 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable - - -We already have the dynamically checked physical units -provided by "Number.Physical" -and the statically checked ones of the @dimensional@ package of Buckwalter, -which require multi-parameter type classes with functional dependencies. - -Here we provide a poor man's approach: -The units are presented by type terms. -There is no canonical form and thus the type checker -can not automatically check for equal units. -However, if two unit terms represent the same unit, -then you can tell the type checker to rewrite one into the other. - -You can add more dimensions by introducing more types of class 'C'. - -This approach is not entirely safe -because you can write your own flawed rewrite rules. -It is however more safe than with no units at all. --} - -module Algebra.DimensionTerm where - -import Prelude hiding (recip) - - -{- Haddock does not like 'where' clauses before empty declarations -} -class Show a => C a -- where - - -noValue :: C a => a -noValue = - let x = error ("there is no value of type " ++ show x) - in x - -{- * Type constructors -} - -data Scalar = Scalar -data Mul a b = Mul -data Recip a = Recip -type Sqr a = Mul a a - -appPrec :: Int -appPrec = 10 - -instance Show Scalar where - show _ = "scalar" - -instance (Show a, Show b) => Show (Mul a b) where - showsPrec p x = - let disect :: Mul a b -> (a,b) - disect _ = undefined - (y,z) = disect x - in showParen (p >= appPrec) - (showString "mul " . showsPrec appPrec y . - showString " " . showsPrec appPrec z) - -instance (Show a) => Show (Recip a) where - showsPrec p x = - let disect :: Recip a -> a - disect _ = undefined - in showParen (p >= appPrec) - (showString "recip " . showsPrec appPrec (disect x)) - - -instance C Scalar -- where - -instance (C a, C b) => C (Mul a b) -- where - -instance (C a) => C (Recip a) -- where - - -scalar :: Scalar -scalar = noValue - -mul :: (C a, C b) => a -> b -> Mul a b -mul _ _ = noValue - -recip :: (C a) => a -> Recip a -recip _ = noValue - - -infixl 7 %*% -infixl 7 %/% - -(%*%) :: (C a, C b) => a -> b -> Mul a b -(%*%) = mul - -(%/%) :: (C a, C b) => a -> b -> Mul a (Recip b) -(%/%) x y = mul x (recip y) - - -{- * Rewrites -} - -applyLeftMul :: (C u0, C u1, C v) => (u0 -> u1) -> Mul u0 v -> Mul u1 v -applyLeftMul _ _ = noValue -applyRightMul :: (C u0, C u1, C v) => (u0 -> u1) -> Mul v u0 -> Mul v u1 -applyRightMul _ _ = noValue -applyRecip :: (C u0, C u1) => (u0 -> u1) -> Recip u0 -> Recip u1 -applyRecip _ _ = noValue - -commute :: (C u0, C u1) => Mul u0 u1 -> Mul u1 u0 -commute _ = noValue -associateLeft :: (C u0, C u1, C u2) => Mul u0 (Mul u1 u2) -> Mul (Mul u0 u1) u2 -associateLeft _ = noValue -associateRight :: (C u0, C u1, C u2) => Mul (Mul u0 u1) u2 -> Mul u0 (Mul u1 u2) -associateRight _ = noValue -recipMul :: (C u0, C u1) => Recip (Mul u0 u1) -> Mul (Recip u0) (Recip u1) -recipMul _ = noValue -mulRecip :: (C u0, C u1) => Mul (Recip u0) (Recip u1) -> Recip (Mul u0 u1) -mulRecip _ = noValue - -identityLeft :: C u => Mul Scalar u -> u -identityLeft _ = noValue -identityRight :: C u => Mul u Scalar -> u -identityRight _ = noValue -cancelLeft :: C u => Mul (Recip u) u -> Scalar -cancelLeft _ = noValue -cancelRight :: C u => Mul u (Recip u) -> Scalar -cancelRight _ = noValue -invertRecip :: C u => Recip (Recip u) -> u -invertRecip _ = noValue -doubleRecip :: C u => u -> Recip (Recip u) -doubleRecip _ = noValue -recipScalar :: Recip Scalar -> Scalar -recipScalar _ = noValue - - -{- * Example dimensions -} - -{- ** Scalar -} - -{- | -This class allows defining instances that are exclusively for 'Scalar' dimension. -You won't want to define instances by yourself. --} -class C dim => IsScalar dim where - toScalar :: dim -> Scalar - fromScalar :: Scalar -> dim - -instance IsScalar Scalar where - toScalar = id - fromScalar = id - - -{- ** Basis dimensions -} - -data Length = Length -data Time = Time -data Mass = Mass -data Charge = Charge -data Angle = Angle -data Temperature = Temperature -data Information = Information - -length :: Length -length = noValue - -time :: Time -time = noValue - -mass :: Mass -mass = noValue - -charge :: Charge -charge = noValue - -angle :: Angle -angle = noValue - -temperature :: Temperature -temperature = noValue - -information :: Information -information = noValue - - -instance Show Length where show _ = "length" -instance Show Time where show _ = "time" -instance Show Mass where show _ = "mass" -instance Show Charge where show _ = "charge" -instance Show Angle where show _ = "angle" -instance Show Temperature where show _ = "temperature" -instance Show Information where show _ = "information" - -instance C Length -- where -instance C Time -- where -instance C Mass -- where -instance C Charge -- where -instance C Angle -- where -instance C Temperature -- where -instance C Information -- where - -{- ** Derived dimensions -} - -type Frequency = Recip Time - -frequency :: Frequency -frequency = noValue - - -data Voltage = Voltage - -type VoltageAnalytical = - Mul (Mul (Sqr Length) Mass) (Recip (Mul (Sqr Time) Charge)) - -voltage :: Voltage -voltage = noValue - -instance Show Voltage where show _ = "voltage" - -instance C Voltage -- where - -unpackVoltage :: Voltage -> VoltageAnalytical -unpackVoltage _ = noValue - -packVoltage :: VoltageAnalytical -> Voltage -packVoltage _ = noValue diff --git a/src-ghc-6.12/Algebra/DivisibleSpace.hs b/src-ghc-6.12/Algebra/DivisibleSpace.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/DivisibleSpace.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Algebra.DivisibleSpace where - -import qualified Algebra.VectorSpace as VectorSpace - --- Is this right? -infix 7 - -{-| -DivisibleSpace is used for free one-dimensional vector spaces. It -satisfies - -> (a b) *> b = a - -Examples include dollars and kilometers. --} -class (VectorSpace.C a b) => C a b where - () :: b -> b -> a - diff --git a/src-ghc-6.12/Algebra/EqualityDecision.hs b/src-ghc-6.12/Algebra/EqualityDecision.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/EqualityDecision.hs +++ /dev/null @@ -1,110 +0,0 @@ -{- | -Combination of @(==)@ and @if then else@ -that can be instantiated for more types than @Eq@ -or can be instantiated in a way -that allows more defined results (\"more total\" functions): - -* Reader like types for representing a context - like 'Number.ResidueClass.Reader' - -* Expressions in an EDSL - -* More generally every type based on an applicative functor - -* Tuples and Vector types - -* Positional and Peano numbers, - a common prefix of two numbers can be emitted - before the comparison is done. - (This could also be done with an overloaded 'if', - what we also do not have.) --} -module Algebra.EqualityDecision where - -import qualified NumericPrelude.Elementwise as Elem -import Control.Applicative (Applicative(pure, (<*>)), ) -import Data.Tuple.HT (fst3, snd3, thd3, ) -import Data.List (zipWith4, ) - - -{- | -For atomic types this could be a superclass of 'Eq'. -However for composed types like tuples, lists, functions -we do elementwise comparison -which is incompatible with the complete comparison performed by '(==)'. --} -class C a where - {- | - It holds - - > (a ==? b) eq noteq == if a==b then eq else noteq - - for atomic types where the right hand side can be defined. - -} - (==?) :: a -> a -> a -> a -> a - - - -{-# INLINE deflt #-} -deflt :: Eq a => a -> a -> a -> a -> a -deflt a b eq noteq = - if a==b then eq else noteq - - - -instance C Int where - {-# INLINE (==?) #-} - (==?) = deflt - -instance C Integer where - {-# INLINE (==?) #-} - (==?) = deflt - -instance C Float where - {-# INLINE (==?) #-} - (==?) = deflt - -instance C Double where - {-# INLINE (==?) #-} - (==?) = deflt - -instance C Bool where - {-# INLINE (==?) #-} - (==?) = deflt - -instance C Ordering where - {-# INLINE (==?) #-} - (==?) = deflt - - - -{-# INLINE element #-} -element :: - (C x) => - (v -> x) -> Elem.T (v,v,v,v) x -element f = - Elem.element (\(x,y,eq,noteq) -> (f x ==? f y) (f eq) (f noteq)) - -{-# INLINE (<*>.==?) #-} -(<*>.==?) :: - (C x) => - Elem.T (v,v,v,v) (x -> a) -> (v -> x) -> Elem.T (v,v,v,v) a -(<*>.==?) f acc = - f <*> element acc - - -instance (C a, C b) => C (a,b) where - {-# INLINE (==?) #-} - (==?) = Elem.run4 $ pure (,) <*>.==? fst <*>.==? snd - -instance (C a, C b, C c) => C (a,b,c) where - {-# INLINE (==?) #-} - (==?) = Elem.run4 $ pure (,,) <*>.==? fst3 <*>.==? snd3 <*>.==? thd3 - -instance C a => C [a] where - {-# INLINE (==?) #-} - (==?) = zipWith4 (==?) - -instance (C a) => C (b -> a) where - {-# INLINE (==?) #-} - (==?) x y eq noteq c = (x c ==? y c) (eq c) (noteq c) diff --git a/src-ghc-6.12/Algebra/Field.hs b/src-ghc-6.12/Algebra/Field.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Field.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.Field ( - {- * Class -} - C, - - (/), - recip, - fromRational', - fromRational, - (^-), - - {- * Properties -} - propDivision, - propReciprocal, - ) where - -import Number.Ratio (T((:%)), Rational, (%), numerator, denominator, ) -import qualified Number.Ratio as Ratio -import qualified Data.Ratio as Ratio98 -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Units as Unit - -import qualified Algebra.Ring as Ring --- import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import Algebra.Ring ((*), (^), one, fromInteger) -import Algebra.Additive (zero, negate) -import Algebra.ZeroTestable (isZero) - -import NumericPrelude.Base -import Prelude (Integer, Float, Double) -import qualified Prelude as P -import Test.QuickCheck ((==>), Property) - - -infixr 8 ^- -infixl 7 / - - -{- | -Field again corresponds to a commutative ring. -Division is partially defined and satisfies - -> not (isZero b) ==> (a * b) / b === a -> not (isZero a) ==> a * recip a === one - -when it is defined. -To safely call division, -the program must take type-specific action; -e.g., the following is appropriate in many cases: - -> safeRecip :: (Integral a, Eq a, Field.C a) => a -> Maybe a -> safeRecip x = -> let (q,r) = one `divMod` x -> in toMaybe (isZero r) q - -Typical examples include rationals, the real numbers, -and rational functions (ratios of polynomial functions). -An instance should be typically declared -only if most elements are invertible. - -Actually, we have also used this type class for non-fields -containing lots of units, -e.g. residue classes with respect to non-primes and power series. -So the restriction @not (isZero a)@ must be better @isUnit a@. - -Minimal definition: 'recip' or ('/') --} - -class (Ring.C a) => C a where - (/) :: a -> a -> a - recip :: a -> a - fromRational' :: Rational -> a - (^-) :: a -> Integer -> a - - {-# INLINE recip #-} - recip a = one / a - {-# INLINE (/) #-} - a / b = a * recip b - {-# INLINE fromRational' #-} - fromRational' r = fromInteger (numerator r) / fromInteger (denominator r) - {-# INLINE (^-) #-} - a ^- n = if n < zero - then recip (a^(-n)) - else a^n - -- a ^ n | n < 0 = reduceRepeated (^) one (recip a) (negate (toInteger n)) - -- | True = reduceRepeated (^) one a (toInteger n) - - - --- | Needed to work around shortcomings in GHC. - -{-# INLINE fromRational #-} -fromRational :: (C a) => P.Rational -> a -fromRational x = fromRational' (Ratio98.numerator x :% Ratio98.denominator x) - - -{- * Instances for atomic types -} - -{- -fromRational must be implemented explicitly for Float and Double! -It may be that numerator or denominator cannot be represented as Float -due to size constraints, but the fraction can. --} - -instance C Float where - {-# INLINE (/) #-} - {-# INLINE recip #-} - (/) = (P./) - recip = (P.recip) - -- using Ratio98.:% would be more efficient but it is not exported. - fromRational' x = - P.fromRational (numerator x Ratio98.% denominator x) - -instance C Double where - {-# INLINE (/) #-} - {-# INLINE recip #-} - (/) = (P./) - recip = (P.recip) - fromRational' x = - P.fromRational (numerator x Ratio98.% denominator x) - -instance (PID.C a) => C (Ratio.T a) where - {-# INLINE (/) #-} - {-# INLINE recip #-} - {-# INLINE fromRational' #-} --- (/) = Ratio.liftOrd (%) - x / y = x * recip y -{- -This is efficient and almost correct in the sense, -that all admissible cases yield a correct result. -However it will hide division by zero and thus may hide bugs. -Unfortunately 'x' might not be a standard associate, -thus (y:%x) may deviate from the canonical representation. - - recip (x:%y) = (y:%x) --} - recip (x:%y) = - if isZero y - then error "Ratio./: division by zero" - else (y * Unit.stdUnitInv x) :% Unit.stdAssociate x - fromRational' (x:%y) = fromInteger x % fromInteger y - - --- | the restriction on the divisor should be @isUnit a@ instead of @not (isZero a)@ -propDivision :: (Eq a, ZeroTestable.C a, C a) => a -> a -> Property -propReciprocal :: (Eq a, ZeroTestable.C a, C a) => a -> Property - -propDivision a b = not (isZero b) ==> (a * b) / b == a -propReciprocal a = not (isZero a) ==> a * recip a == one - - - --- legacy - -instance (P.Integral a) => C (Ratio98.Ratio a) where - {-# INLINE (/) #-} - {-# INLINE recip #-} - (/) = (P./) - recip = (P.recip) diff --git a/src-ghc-6.12/Algebra/GenerateRules.hs b/src-ghc-6.12/Algebra/GenerateRules.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/GenerateRules.hs +++ /dev/null @@ -1,86 +0,0 @@ -{- | -Poor man's Template Haskell: -Generate RULES for handling of primitive number types. --} -module Main where - -import Data.Maybe (fromMaybe, ) - -import Prelude hiding (fromIntegral, ) - - -pad :: Int -> String -> String -pad n str = - zipWith fromMaybe - (replicate n ' ') - (map Just str ++ repeat Nothing) - - -machineIntegerTypes :: [String] -machineIntegerTypes = - do typeSign <- "Int" : "Word" : [] - typeSize <- "" : "8" : "16" : "32" : "64" : [] - return $ typeSign ++ typeSize - -functionSignature :: String -> String -> String -> String -functionSignature functionName sourceType targetType = - functionName ++ " :: " ++ sourceType ++ " -> " ++ targetType - -{- -Simply replace NumericPrelude.roundFunc by Prelude98.roundFunc. -This is only sensible where Prelude functions are optimized. -Unfortunately there seems to be no optimization for target type Int8 et.al. --} -realField :: [String] -realField = - do sourceType <- "Float" : "Double" : [] - targetType <- machineIntegerTypes - method <- "round" : "truncate" : "floor" : "ceiling" : [] - let methodPad = pad 8 method - let signature = functionSignature methodPad sourceType targetType - return $ " " ++ - pad 40 ("\"NP." ++ signature ++ "\"") ++ - methodPad ++ " = P." ++ signature ++ ";" - -realFieldIndirect :: [String] -realFieldIndirect = - do targetType <- tail machineIntegerTypes - method <- "round" : "roundSimple" : "truncate" : "floor" : "ceiling" : [] - let methodPad = pad 11 method - let signature = functionSignature methodPad "a" targetType - return $ " " ++ - pad 33 ("\"NP." ++ signature ++ "\"") ++ - methodPad ++ " = (" ++ functionSignature "P.fromIntegral" "Int" targetType ++ ") . " - ++ method ++ ";" - -splitFractionIndirect :: [String] -splitFractionIndirect = - do targetType <- tail machineIntegerTypes - method <- "splitFraction" : [] - let methodPad = pad 13 method - let signature = functionSignature methodPad "a" ("("++targetType++",a)") - return $ " " ++ - pad 40 ("\"NP." ++ signature ++ "\"") ++ - methodPad ++ " = mapFst (" ++ functionSignature "P.fromIntegral" "Int" targetType ++ ") . " - ++ method ++ ";" - - -fromIntegral :: [String] -fromIntegral = - do sourceType <- "Integer" : machineIntegerTypes - targetType <- "Int" : "Integer" : "Float" : "Double" : [] - let function = "fromIntegral" - let signature = functionSignature function sourceType targetType - return $ " " ++ - pad 40 ("\"NP." ++ signature ++ "\"") ++ - function ++ " = P." ++ signature ++ ";" - - -main :: IO () -main = - putStrLn "module Algebra.RealRing" >> - mapM_ putStrLn realFieldIndirect >> - mapM_ putStrLn splitFractionIndirect >> - - putStrLn "module Algebra.ToInteger" >> - mapM_ putStrLn fromIntegral diff --git a/src-ghc-6.12/Algebra/Indexable.hs b/src-ghc-6.12/Algebra/Indexable.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Indexable.hs +++ /dev/null @@ -1,76 +0,0 @@ -{- | -Copyright : (c) Henning Thielemann 2007 -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable - -An alternative type class for Ord -which allows an ordering for dictionaries like "Data.Map" and "Data.Set" -independently from the ordering with respect to a magnitude. --} - -module Algebra.Indexable ( - C(compare), - ordCompare, - liftCompare, - ToOrd, - toOrd, - fromOrd, - ) where - -import Prelude hiding (compare) - -import qualified Prelude as P - - -{- | -Definition of an alternative ordering of objects -independent from a notion of magnitude. -For an application see "MathObj.PartialFraction". --} -class Eq a => C a where - compare :: a -> a -> Ordering - -{- | -If the type has already an 'Ord' instance -it is certainly the most easiest to define 'Algebra.Indexable.compare' -to be equal to @Ord@'s 'compare'. --} -ordCompare :: Ord a => a -> a -> Ordering -ordCompare = P.compare - -{- | -Lift 'compare' implementation from a wrapped object. --} -liftCompare :: C b => (a -> b) -> a -> a -> Ordering -liftCompare f x y = compare (f x) (f y) - - -instance (C a, C b) => C (a,b) where - compare (x0,x1) (y0,y1) = - let res = compare x0 y0 - in case res of - EQ -> compare x1 y1 - _ -> res - -instance C a => C [a] where - compare [] [] = EQ - compare [] _ = LT - compare _ [] = GT - compare (x:xs) (y:ys) = compare (x,xs) (y,ys) - -instance C Integer where - compare = ordCompare - - -{- | -Wrap an indexable object such that it can be used in "Data.Map" and "Data.Set". --} -newtype ToOrd a = ToOrd {fromOrd :: a} deriving (Eq, Show) - -toOrd :: a -> ToOrd a -toOrd = ToOrd - - -instance C a => Ord (ToOrd a) where - compare (ToOrd x) (ToOrd y) = compare x y diff --git a/src-ghc-6.12/Algebra/IntegralDomain.hs b/src-ghc-6.12/Algebra/IntegralDomain.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/IntegralDomain.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.IntegralDomain ( - {- * Class -} - C, - div, mod, divMod, - - {- * Derived functions -} - divModZero, - divides, - sameResidueClass, - divChecked, safeDiv, - even, - odd, - - divUp, - roundDown, - roundUp, - - {- * Algorithms -} - decomposeVarPositional, - decomposeVarPositionalInf, - - {- * Properties -} - propInverse, - propMultipleDiv, - propMultipleMod, - propProjectAddition, - propProjectMultiplication, - propUniqueRepresentative, - propZeroRepresentative, - propSameResidueClass, - ) where - -import qualified Algebra.Ring as Ring --- import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import Algebra.Ring ((*), fromInteger, ) -import Algebra.Additive (zero, (+), (-), negate, ) -import Algebra.ZeroTestable (isZero, ) - -import Data.Bool.HT (implies, ) -import Data.List (mapAccumL, ) - -import Test.QuickCheck ((==>), Property) - -import Data.Int (Int, Int8, Int16, Int32, Int64, ) -import Data.Word (Word, Word8, Word16, Word32, Word64, ) - -import NumericPrelude.Base -import Prelude (Integer, ) -import qualified Prelude as P - - - -infixl 7 `div`, `mod` - - -{- -Shall we require - @ a `mod` 0 === a @ (divModZero) -or - @ a `mod` 0 === undefined @ -? --} - - -{- | -@IntegralDomain@ corresponds to a commutative ring, -where @a `mod` b@ picks a canonical element -of the equivalence class of @a@ in the ideal generated by @b@. -'div' and 'mod' satisfy the laws - -> a * b === b * a -> (a `div` b) * b + (a `mod` b) === a -> (a+k*b) `mod` b === a `mod` b -> 0 `mod` b === 0 - -Typical examples of @IntegralDomain@ include integers and -polynomials over a field. -Note that for a field, there is a canonical instance -defined by the above rules; e.g., - -> instance IntegralDomain.C Rational where -> divMod a b = -> if isZero b -> then (undefined,a) -> else (a\/b,0) - -It shall be noted, that 'div', 'mod', 'divMod' have a parameter order -which is unfortunate for partial application. -But it is adapted to mathematical conventions, -where the operators are used in infix notation. - -Minimal definition: 'divMod' or ('div' and 'mod') --} -class (Ring.C a) => C a where - div, mod :: a -> a -> a - divMod :: a -> a -> (a,a) - - {-# INLINE div #-} - {-# INLINE mod #-} - {-# INLINE divMod #-} - div a b = fst (divMod a b) - mod a b = snd (divMod a b) - divMod a b = (div a b, mod a b) - - -{-# INLINE divides #-} -divides :: (C a, ZeroTestable.C a) => a -> a -> Bool -divides y x = isZero (mod x y) - -{-# INLINE sameResidueClass #-} -sameResidueClass :: (C a, ZeroTestable.C a) => a -> a -> a -> Bool -sameResidueClass m x y = divides m (x-y) - - - -{- | -@decomposeVarPositional [b0,b1,b2,...] x@ -decomposes @x@ into a positional representation with mixed bases -@x0 + b0*(x1 + b1*(x2 + b2*x3))@ -E.g. @decomposeVarPositional (repeat 10) 123 == [3,2,1]@ --} -decomposeVarPositional :: (C a, ZeroTestable.C a) => [a] -> a -> [a] -decomposeVarPositional bs x = - map fst $ - takeWhile (not . isZero . snd) $ - decomposeVarPositionalInfAux bs x - -decomposeVarPositionalInf :: (C a) => [a] -> a -> [a] -decomposeVarPositionalInf bs = - map fst . decomposeVarPositionalInfAux bs - -decomposeVarPositionalInfAux :: (C a) => [a] -> a -> [(a,a)] -decomposeVarPositionalInfAux bs x = - let (endN,digits) = - mapAccumL - (\n b -> let (q,r) = divMod n b in (q,(r,n))) - x bs - in digits ++ [(endN,endN)] - - - -{- | -Returns the result of the division, if divisible. -Otherwise undefined. --} -{-# INLINE divChecked #-} -divChecked, safeDiv :: (ZeroTestable.C a, C a) => a -> a -> a -divChecked a b = - let (q,r) = divMod a b - in if isZero r - then q - else error "safeDiv: indivisible term" - -{-# DEPRECATED safeDiv "use divChecked instead" #-} -safeDiv = divChecked - -{- | -Allows division by zero. -If the divisor is zero, then the dividend is returned as remainder. --} -{-# INLINE divModZero #-} -divModZero :: (C a, ZeroTestable.C a) => a -> a -> (a,a) -divModZero x y = - if isZero y - then (zero,x) - else divMod x y - - - -{-# INLINE even #-} -{-# INLINE odd #-} -even, odd :: (C a, ZeroTestable.C a) => a -> Bool -even n = divides 2 n -odd = not . even - - -{- | -@roundDown n m@ rounds @n@ down to the next multiple of @m@. -That is, @roundDown n m@ is the greatest multiple of @m@ -that is at most @n@. -The parameter order is consistent with @div@ and friends, -but maybe not useful for partial application. --} -roundDown :: C a => a -> a -> a -roundDown n m = n - mod n m - -{- | -@roundUp n m@ rounds @n@ up to the next multiple of @m@. -That is, @roundUp n m@ is the greatest multiple of @m@ -that is at most @n@. --} -roundUp :: C a => a -> a -> a -roundUp n m = n + mod (-n) m - -{- | -@divUp n m@ is similar to @div@ -but it rounds up the quotient, -such that @divUp n m * m = roundUp n m@. --} -divUp :: C a => a -> a -> a -divUp n m = - div (-n) m - -{- -What sign of the remainder is most appropriate? - -divModUp :: C a => a -> a -> (a,a) -divModUp n m = mapFst negate $ divMod (-n) m --} - - -{- * Instances for atomic types -} - -instance C Integer where - {-# INLINE div #-} - {-# INLINE mod #-} - {-# INLINE divMod #-} - div = P.div - mod = P.mod - divMod = P.divMod - -instance C Int where - {-# INLINE div #-} - {-# INLINE mod #-} - {-# INLINE divMod #-} - div = P.div - mod = P.mod - divMod = P.divMod - -instance C Int8 where - {-# INLINE div #-} - {-# INLINE mod #-} - {-# INLINE divMod #-} - div = P.div - mod = P.mod - divMod = P.divMod - -instance C Int16 where - {-# INLINE div #-} - {-# INLINE mod #-} - {-# INLINE divMod #-} - div = P.div - mod = P.mod - divMod = P.divMod - -instance C Int32 where - {-# INLINE div #-} - {-# INLINE mod #-} - {-# INLINE divMod #-} - div = P.div - mod = P.mod - divMod = P.divMod - -instance C Int64 where - {-# INLINE div #-} - {-# INLINE mod #-} - {-# INLINE divMod #-} - div = P.div - mod = P.mod - divMod = P.divMod - - -instance C Word where - {-# INLINE div #-} - {-# INLINE mod #-} - {-# INLINE divMod #-} - div = P.div - mod = P.mod - divMod = P.divMod - -instance C Word8 where - {-# INLINE div #-} - {-# INLINE mod #-} - {-# INLINE divMod #-} - div = P.div - mod = P.mod - divMod = P.divMod - -instance C Word16 where - {-# INLINE div #-} - {-# INLINE mod #-} - {-# INLINE divMod #-} - div = P.div - mod = P.mod - divMod = P.divMod - -instance C Word32 where - {-# INLINE div #-} - {-# INLINE mod #-} - {-# INLINE divMod #-} - div = P.div - mod = P.mod - divMod = P.divMod - -instance C Word64 where - {-# INLINE div #-} - {-# INLINE mod #-} - {-# INLINE divMod #-} - div = P.div - mod = P.mod - divMod = P.divMod - - - - --- Ring.propCommutative and ... -propInverse :: (Eq a, C a, ZeroTestable.C a) => a -> a -> Property -propMultipleDiv :: (Eq a, C a, ZeroTestable.C a) => a -> a -> Property -propMultipleMod :: (Eq a, C a, ZeroTestable.C a) => a -> a -> Property -propProjectAddition :: (Eq a, C a, ZeroTestable.C a) => a -> a -> a -> Property -propProjectMultiplication :: (Eq a, C a, ZeroTestable.C a) => a -> a -> a -> Property -propSameResidueClass :: (Eq a, C a, ZeroTestable.C a) => a -> a -> a -> Property -propUniqueRepresentative :: (Eq a, C a, ZeroTestable.C a) => a -> a -> a -> Property -propZeroRepresentative :: (Eq a, C a, ZeroTestable.C a) => a -> Property - - -propInverse m a = - not (isZero m) ==> (a `div` m) * m + (a `mod` m) == a -propMultipleDiv m a = - not (isZero m) ==> (a*m) `div` m == a -propMultipleMod m a = - not (isZero m) ==> (a*m) `mod` m == 0 -propProjectAddition m a b = - not (isZero m) ==> - (a+b) `mod` m == ((a`mod`m)+(b`mod`m)) `mod` m -propProjectMultiplication m a b = - not (isZero m) ==> - (a*b) `mod` m == ((a`mod`m)*(b`mod`m)) `mod` m -propUniqueRepresentative m k a = - not (isZero m) ==> - (a+k*m) `mod` m == a `mod` m -propZeroRepresentative m = - not (isZero m) ==> - zero `mod` m == zero -propSameResidueClass m a b = - not (isZero m) ==> - a `mod` m == b `mod` m `implies` sameResidueClass m a b diff --git a/src-ghc-6.12/Algebra/Lattice.hs b/src-ghc-6.12/Algebra/Lattice.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Lattice.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.Lattice ( - C(up, dn) - , max, min, abs - , propUpCommutative, propDnCommutative - , propUpAssociative, propDnAssociative - , propUpDnDistributive, propDnUpDistributive -) where - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Additive as Additive -import qualified Number.Ratio as Ratio - -import qualified Algebra.Laws as Laws - -import NumericPrelude.Numeric hiding (abs) -import NumericPrelude.Base hiding (max, min) -import qualified Prelude as P - -infixl 5 `up`, `dn` - -class C a where - up, dn :: a -> a -> a - - -{- * Properties -} - -propUpCommutative, propDnCommutative :: - (Eq a, C a) => a -> a -> Bool -propUpCommutative = Laws.commutative up -propDnCommutative = Laws.commutative dn - -propUpAssociative, propDnAssociative :: - (Eq a, C a) => a -> a -> a -> Bool -propUpAssociative = Laws.associative up -propDnAssociative = Laws.associative dn - -propUpDnDistributive, propDnUpDistributive :: - (Eq a, C a) => a -> a -> a -> Bool -propUpDnDistributive = Laws.leftDistributive up dn -propDnUpDistributive = Laws.leftDistributive dn up - - - - --- With @up == gcd@ and @dn == lcm@ we have also a lattice. -instance C Integer where - up = P.max - dn = P.min - -instance (Ord a, PID.C a) => C (Ratio.T a) where - up = P.max - dn = P.min - -instance C Bool where - up = (P.||) - dn = (P.&&) - -instance (C a, C b) => C (a,b) where - (x1,y1)`up`(x2,y2) = (x1`up`x2, y1`up`y2) - (x1,y1)`dn`(x2,y2) = (x1`dn`x2, y1`dn`y2) - - -max, min :: (C a) => a -> a -> a -max = up -min = dn - -abs :: (C a, Additive.C a) => a -> a -abs x = x `up` negate x diff --git a/src-ghc-6.12/Algebra/Laws.hs b/src-ghc-6.12/Algebra/Laws.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Laws.hs +++ /dev/null @@ -1,57 +0,0 @@ -{- | -Define common properties that can be used e.g. for automated tests. -Cf. to "Test.QuickCheck.Utils". --} -module Algebra.Laws where - - -commutative :: Eq a => (b -> b -> a) -> b -> b -> Bool -commutative op x y = x `op` y == y `op` x - -associative :: Eq a => (a -> a -> a) -> a -> a -> a -> Bool -associative op x y z = (x `op` y) `op` z == x `op` (y `op` z) - -leftIdentity :: Eq a => (b -> a -> a) -> b -> a -> Bool -leftIdentity op y x = y `op` x == x - -rightIdentity :: Eq a => (a -> b -> a) -> b -> a -> Bool -rightIdentity op y x = x `op` y == x - -identity :: Eq a => (a -> a -> a) -> a -> a -> Bool -identity op x y = leftIdentity op x y && rightIdentity op x y - -leftZero :: Eq a => (a -> a -> a) -> a -> a -> Bool -leftZero = flip . rightIdentity - -rightZero :: Eq a => (a -> a -> a) -> a -> a -> Bool -rightZero = flip . leftIdentity - -zero :: Eq a => (a -> a -> a) -> a -> a -> Bool -zero op x y = leftZero op x y && rightZero op x y - -leftInverse :: Eq a => (b -> b -> a) -> (b -> b) -> a -> b -> Bool -leftInverse op inv y x = inv x `op` x == y - -rightInverse :: Eq a => (b -> b -> a) -> (b -> b) -> a -> b -> Bool -rightInverse op inv y x = x `op` inv x == y - -inverse :: Eq a => (b -> b -> a) -> (b -> b) -> a -> b -> Bool -inverse op inv y x = leftInverse op inv y x && rightInverse op inv y x - -leftDistributive :: Eq a => (a -> b -> a) -> (a -> a -> a) -> b -> a -> a -> Bool -leftDistributive ( # ) op x y z = (y `op` z) # x == (y # x) `op` (z # x) - -rightDistributive :: Eq a => (b -> a -> a) -> (a -> a -> a) -> b -> a -> a -> Bool -rightDistributive ( # ) op x y z = x # (y `op` z) == (x # y) `op` (x # z) - -homomorphism :: Eq a => - (b -> a) -> (b -> b -> b) -> (a -> a -> a) -> b -> b -> Bool -homomorphism f op0 op1 x y = f (x `op0` y) == f x `op1` f y - -rightCascade :: Eq a => - (b -> b -> b) -> (a -> b -> a) -> a -> b -> b -> Bool -rightCascade ( # ) op x i j = (x `op` i) `op` j == x `op` (i#j) - -leftCascade :: Eq a => - (b -> b -> b) -> (b -> a -> a) -> a -> b -> b -> Bool -leftCascade ( # ) op x i j = j `op` (i `op` x) == (j#i) `op` x diff --git a/src-ghc-6.12/Algebra/Module.hs b/src-ghc-6.12/Algebra/Module.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Module.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- | -Copyright : (c) Dylan Thurston, Henning Thielemann 2004-2005 - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : requires multi-parameter type classes - -Abstraction of modules --} - -module Algebra.Module where - -import qualified Number.Ratio as Ratio - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ToInteger as ToInteger - -import qualified Algebra.Laws as Laws - -import Algebra.Ring ((*), fromInteger, ) -import Algebra.Additive ((+), zero, sum, ) - -import qualified NumericPrelude.Elementwise as Elem -import Control.Applicative (Applicative(pure, (<*>)), ) - -import Data.Function.HT (powerAssociative, ) -import Data.List (map, zipWith, ) -import Data.Tuple.HT (fst3, snd3, thd3, ) -import Data.Tuple (fst, snd, ) - -import Prelude((.), Eq, Bool, Int, Integer, Float, Double, ($), ) --- import qualified Prelude as P - - --- Is this right? -infixr 7 *> - -{- -Functional dependency can't be used -since @Complex.T a@ is a module -with respect to both @a@ and @Complex.T a@. - -class Algebra.Module.C a v | v -> a where --} - -{-| -A Module over a ring satisfies: - -> a *> (b + c) === a *> b + a *> c -> (a * b) *> c === a *> (b *> c) -> (a + b) *> c === a *> c + b *> c --} -class (Ring.C a, Additive.C v) => C a v where - -- | scale a vector by a scalar - (*>) :: a -> v -> v - - -{-# INLINE (<*>.*>) #-} -(<*>.*>) :: - (C a x) => - Elem.T (a,v) (x -> c) -> (v -> x) -> Elem.T (a,v) c -(<*>.*>) f acc = - f <*> Elem.element (\(a,v) -> a *> acc v) - - - -{-* Instances for atomic types -} - -instance C Float Float where - {-# INLINE (*>) #-} - (*>) = (*) - -instance C Double Double where - {-# INLINE (*>) #-} - (*>) = (*) - -instance C Int Int where - {-# INLINE (*>) #-} - (*>) = (*) - -instance C Integer Integer where - {-# INLINE (*>) #-} - (*>) = (*) - -instance (PID.C a) => C (Ratio.T a) (Ratio.T a) where - {-# INLINE (*>) #-} - (*>) = (*) - -instance (PID.C a) => C Integer (Ratio.T a) where - {-# INLINE (*>) #-} - x *> y = fromInteger x * y - - - -{-* Instances for composed types -} - -instance (C a b0, C a b1) => C a (b0, b1) where - {-# INLINE (*>) #-} - (*>) = Elem.run2 $ pure (,) <*>.*> fst <*>.*> snd - -- s *> (x0,x1) = (s *> x0, s *> x1) - -instance (C a b0, C a b1, C a b2) => C a (b0, b1, b2) where - {-# INLINE (*>) #-} - (*>) = Elem.run2 $ pure (,,) <*>.*> fst3 <*>.*> snd3 <*>.*> thd3 - -- s *> (x0,x1,x2) = (s *> x0, s *> x1, s *> x2) - -instance (C a v) => C a [v] where - {-# INLINE (*>) #-} - (*>) = map . (*>) - -instance (C a v) => C a (c -> v) where - {-# INLINE (*>) #-} - (*>) s f = (*>) s . f - - -{-* Related functions -} - -{-| -Compute the linear combination of a list of vectors. - -ToDo: -Should it use 'NumericPrelude.List.Checked.zipWith' ? --} -linearComb :: C a v => [a] -> [v] -> v -linearComb c = sum . zipWith (*>) c - -{-| -This function can be used to define any -'Additive.C' as a module over 'Integer'. - -Better move to "Algebra.Additive"? --} -{-# INLINE integerMultiply #-} -integerMultiply :: (ToInteger.C a, Additive.C v) => a -> v -> v -integerMultiply a v = - powerAssociative (+) zero v (ToInteger.toInteger a) - - -{- * Properties -} - -propCascade :: (Eq v, C a v) => v -> a -> a -> Bool -propCascade = Laws.leftCascade (*) (*>) - -propRightDistributive :: (Eq v, C a v) => a -> v -> v -> Bool -propRightDistributive = Laws.rightDistributive (*>) (+) - -propLeftDistributive :: (Eq v, C a v) => v -> a -> a -> Bool -propLeftDistributive x = Laws.homomorphism (*>x) (+) (+) diff --git a/src-ghc-6.12/Algebra/ModuleBasis.hs b/src-ghc-6.12/Algebra/ModuleBasis.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/ModuleBasis.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- | -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : requires multi-parameter type classes - -Abstraction of bases of finite dimensional modules --} - -module Algebra.ModuleBasis where - -import qualified Number.Ratio as Ratio - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Module as Module --- import qualified Algebra.Additive as Additive -import Algebra.Ring (one, fromInteger) -import Algebra.Additive ((+), zero) - -import Data.List (map, length, (++)) - -import Prelude(Eq, (==), Bool, Int, Integer, Float, Double, asTypeOf, ) --- import qualified Prelude as P - -{- | -It must hold: - -> Module.linearComb (flatten v `asTypeOf` [a]) (basis a) == v -> dimension a v == length (flatten v `asTypeOf` [a]) --} -class (Module.C a v) => C a v where - {- | basis of the module with respect to the scalar type, - the result must be independent of argument, 'Prelude.undefined' should suffice. -} - basis :: a -> [v] - -- | scale a vector by a scalar - flatten :: v -> [a] - {- | the size of the basis, should also work for undefined argument, - the result must be independent of argument, 'Prelude.undefined' should suffice. -} - dimension :: a -> v -> Int - -{-* Instances for atomic types -} - -instance C Float Float where - basis _ = [one] - flatten = (:[]) - dimension _ _ = 1 - -instance C Double Double where - basis _ = [one] - flatten = (:[]) - dimension _ _ = 1 - -instance C Int Int where - basis _ = [one] - flatten = (:[]) - dimension _ _ = 1 - -instance C Integer Integer where - basis _ = [one] - flatten = (:[]) - dimension _ _ = 1 - -instance (PID.C a) => C (Ratio.T a) (Ratio.T a) where - basis _ = [one] - flatten = (:[]) - dimension _ _ = 1 - - - -{-* Instances for composed types -} - -instance (C a v0, C a v1) => C a (v0, v1) where - basis s = map (\v -> (v,zero)) (basis s) ++ - map (\v -> (zero,v)) (basis s) - flatten (x0,x1) = flatten x0 ++ flatten x1 - dimension s ~(x0,x1) = dimension s x0 + dimension s x1 - -instance (C a v0, C a v1, C a v2) => C a (v0, v1, v2) where - basis s = map (\v -> (v,zero,zero)) (basis s) ++ - map (\v -> (zero,v,zero)) (basis s) ++ - map (\v -> (zero,zero,v)) (basis s) - flatten (x0,x1,x2) = flatten x0 ++ flatten x1 ++ flatten x2 - dimension s ~(x0,x1,x2) = dimension s x0 + dimension s x1 + dimension s x2 - - - -{- * Properties -} - -propFlatten :: (Eq v, C a v) => a -> v -> Bool -propFlatten a v = Module.linearComb (flatten v `asTypeOf` [a]) (basis a) == v - -propDimension :: (C a v) => a -> v -> Bool -propDimension a v = dimension a v == length (flatten v `asTypeOf` [a]) diff --git a/src-ghc-6.12/Algebra/Monoid.hs b/src-ghc-6.12/Algebra/Monoid.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Monoid.hs +++ /dev/null @@ -1,72 +0,0 @@ -{- | -Copyright : (c) Henning Thielemann 2009-2010, Mikael Johansson 2006 -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : - -Abstract concept of a Monoid. -Will be used in order to generate type classes for generic algebras. -An algebra is a vector space that also is a monoid. -Should we use the Monoid class from base library -despite its unfortunate method name @mappend@? --} - -module Algebra.Monoid where - -import qualified Algebra.Additive as Additive -import qualified Algebra.Ring as Ring - -import Data.Monoid as Mn - -{- | -We expect a monoid to adher to associativity and -the identity behaving decently. -Nothing more, really. --} -class C a where - idt :: a - (<*>) :: a -> a -> a - cumulate :: [a] -> a - cumulate = foldr (<*>) idt - - -instance C All where - idt = mempty - (<*>) = mappend - cumulate = mconcat - -instance C Any where - idt = mempty - (<*>) = mappend - cumulate = mconcat - -instance C a => C (Dual a) where - idt = Mn.Dual idt - (Mn.Dual x) <*> (Mn.Dual y) = Mn.Dual (y <*> x) - cumulate = Mn.Dual . cumulate . reverse . map Mn.getDual - -instance C (Endo a) where - idt = mempty - (<*>) = mappend - cumulate = mconcat - -instance C (First a) where - idt = mempty - (<*>) = mappend - cumulate = mconcat - -instance C (Last a) where - idt = mempty - (<*>) = mappend - cumulate = mconcat - - -instance Ring.C a => C (Product a) where - idt = Mn.Product Ring.one - (Mn.Product x) <*> (Mn.Product y) = Mn.Product (x Ring.* y) - cumulate = Mn.Product . Ring.product . map Mn.getProduct - -instance Additive.C a => C (Sum a) where - idt = Mn.Sum Additive.zero - (Mn.Sum x) <*> (Mn.Sum y) = Mn.Sum (x Additive.+ y) - cumulate = Mn.Sum . Additive.sum . map Mn.getSum diff --git a/src-ghc-6.12/Algebra/NonNegative.hs b/src-ghc-6.12/Algebra/NonNegative.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/NonNegative.hs +++ /dev/null @@ -1,130 +0,0 @@ -{- | -Copyright : (c) Henning Thielemann 2007-2010 - -Maintainer : haskell@henning-thielemann.de -Stability : stable -Portability : Haskell 98 - -A type class for non-negative numbers. -Prominent instances are 'Number.NonNegative.T' and 'Number.Peano.T' numbers. -This class cannot do any checks, -but it let you show to the user what arguments your function expects. -Thus you must define class instances with care. -In fact many standard functions ('take', '(!!)', ...) -should have this type class constraint. --} -module Algebra.NonNegative ( - C(..), - splitDefault, - - (-|), --- (-?), - zero, - add, - sum, - ) where - -import qualified Algebra.Additive as Additive --- import qualified Algebra.RealRing as RealRing - -import qualified Algebra.Monoid as Monoid - --- import Algebra.Absolute (abs, ) -import Algebra.Additive ((-), ) - -import Prelude hiding (sum, (-), abs, ) - - -infixl 6 -| -- , -? - - -{- | -Instances of this class must ensure non-negative values. -We cannot enforce this by types, but the type class constraint @NonNegative.C@ -avoids accidental usage of types which allow for negative numbers. - -The Monoid superclass contributes a zero and an addition. --} -class (Ord a, Monoid.C a) => C a where - {- | - @split x y == (m,(b,d))@ means that - @b == (x<=y)@, - @m == min x y@, - @d == max x y - min x y@, that is @d == abs(x-y)@. - - We have chosen this function as base function, - since it provides comparison and subtraction in one go, - which is important for replacing common structures like - - > if x<=y - > then f(x-y) - > else g(y-x) - - that lead to a memory leak for peano numbers. - We have choosen the simple check @x<=y@ - instead of a full-blown @compare@, - since we want @Zero <= undefined@ for peano numbers. - Because of undefined values 'split' is in general - not commutative in the sense - - > let (m0,(b0,d0)) = split x y - > (m1,(b1,d1)) = split y x - > in m0==m1 && d0==d1 - - The result values are in the order - in which they are generated for Peano numbers. - We have chosen the nested pair instead of a triple - in order to prevent a memory leak - that occurs if you only use @b@ and @d@ and ignore @m@. - This is demonstrated by test cases - Chunky.splitSpaceLeak3 and Chunky.splitSpaceLeak4. - -} - split :: a -> a -> (a, (Bool, a)) - - -{- | -Default implementation for wrapped types of 'Ord' and 'Num' class. --} -{-# INLINE splitDefault #-} -splitDefault :: - (Ord b, Additive.C b) => - (a -> b) -> (b -> a) -> a -> a -> (a, (Bool, a)) -splitDefault unpack pack px py = - let x = unpack px - y = unpack py - in if x<=y - then (pack x, (True, pack (y-x))) - else (pack y, (False, pack (x-y))) - - -zero :: C a => a -zero = Monoid.idt - --- like (+) -infixl 6 `add` - -add :: C a => a -> a -> a -add = (Monoid.<*>) - -sum :: C a => [a] -> a -sum = Monoid.cumulate - - -{- | -@x -| y == max 0 (x-y)@ - -The default implementation is not efficient, -because it compares the values and then subtracts, again, if safe. -@max 0 (x-y)@ is more elegant and efficient -but not possible in the general case, -since @x-y@ may already yield a negative number. --} -(-|) :: C a => a -> a -> a -x -| y = - let (b,d) = snd $ split y x - in if b then d else zero - -{- -(-?) :: (RealRing.C a) => a -> a -> (Bool, a) -(-?) x y = snd $ split y x --} diff --git a/src-ghc-6.12/Algebra/NormedSpace/Euclidean.hs b/src-ghc-6.12/Algebra/NormedSpace/Euclidean.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/NormedSpace/Euclidean.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -{- | -Copyright : (c) Henning Thielemann 2005-2010 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : requires multi-parameter type classes - -Abstraction of normed vector spaces --} - -module Algebra.NormedSpace.Euclidean where - -import NumericPrelude.Base -import NumericPrelude.Numeric (sqr, abs, zero, (+), sum, Float, Double, Int, Integer, ) - -import qualified Number.Ratio as Ratio - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Module as Module - -import qualified Data.Foldable as Fold - - -{-| -Helper class for 'C' that does not need an algebraic type @a@. - -Minimal definition: -'normSqr' --} -class (Absolute.C a, Module.C a v) => Sqr a v where - {-| Square of the Euclidean norm of a vector. - This is sometimes easier to implement. -} - normSqr :: v -> a --- normSqr = sqr . norm - -{- | -Default definition for 'normSqr' that is based on 'Fold.Foldable' class. --} -{-# INLINE normSqrFoldable #-} -normSqrFoldable :: - (Sqr a v, Fold.Foldable f) => f v -> a -normSqrFoldable = - Fold.foldl (\a v -> a + normSqr v) zero - -{- | -Default definition for 'normSqr' that is based on 'Fold.Foldable' class -and the argument vector has at least one component. --} -{-# INLINE normSqrFoldable1 #-} -normSqrFoldable1 :: - (Sqr a v, Fold.Foldable f, Functor f) => f v -> a -normSqrFoldable1 = - Fold.foldl1 (+) . fmap normSqr - - -{-| -A vector space equipped with an Euclidean or a Hilbert norm. - -Minimal definition: -'norm' --} -class (Sqr a v) => C a v where - {-| Euclidean norm of a vector. -} - norm :: v -> a - - -defltNorm :: (Algebraic.C a, Sqr a v) => v -> a -defltNorm = Algebraic.sqrt . normSqr - - -{-* Instances for atomic types -} - -instance Sqr Float Float where - normSqr = sqr - -instance C Float Float where - norm = abs - -instance Sqr Double Double where - normSqr = sqr - -instance C Double Double where - norm = abs - -instance Sqr Int Int where - normSqr = sqr - -instance C Int Int where - norm = abs - -instance Sqr Integer Integer where - normSqr = sqr - -instance C Integer Integer where - norm = abs - - -{-* Instances for composed types -} - -instance (Absolute.C a, PID.C a) => Sqr (Ratio.T a) (Ratio.T a) where - normSqr = sqr - -instance (Sqr a v0, Sqr a v1) => Sqr a (v0, v1) where - normSqr (x0,x1) = normSqr x0 + normSqr x1 - -instance (Algebraic.C a, Sqr a v0, Sqr a v1) => C a (v0, v1) where - norm = defltNorm - -instance (Sqr a v0, Sqr a v1, Sqr a v2) => Sqr a (v0, v1, v2) where - normSqr (x0,x1,x2) = normSqr x0 + normSqr x1 + normSqr x2 - -instance (Algebraic.C a, Sqr a v0, Sqr a v1, Sqr a v2) => C a (v0, v1, v2) where - norm = defltNorm - -instance (Sqr a v) => Sqr a [v] where - normSqr = sum . map normSqr - -instance (Algebraic.C a, Sqr a v) => C a [v] where - norm = defltNorm diff --git a/src-ghc-6.12/Algebra/NormedSpace/Maximum.hs b/src-ghc-6.12/Algebra/NormedSpace/Maximum.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/NormedSpace/Maximum.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -{- | -Copyright : (c) Henning Thielemann 2005-2010 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : requires multi-parameter type classes - -Abstraction of normed vector spaces --} - -module Algebra.NormedSpace.Maximum where - -import NumericPrelude.Base -import NumericPrelude.Numeric - -import qualified Number.Ratio as Ratio - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.ToInteger as ToInteger -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Module as Module - -import qualified Data.Foldable as Fold - - -class (RealRing.C a, Module.C a v) => C a v where - norm :: v -> a - -{- | -Default definition for 'norm' that is based on 'Fold.Foldable' class. --} -{-# INLINE normFoldable #-} -normFoldable :: - (C a v, Fold.Foldable f) => f v -> a -normFoldable = - Fold.foldl (\a v -> max a (norm v)) zero - -{- | -Default definition for 'norm' that is based on 'Fold.Foldable' class -and the argument vector has at least one component. --} -{-# INLINE normFoldable1 #-} -normFoldable1 :: - (C a v, Fold.Foldable f, Functor f) => f v -> a -normFoldable1 = - Fold.foldl1 max . fmap norm - -{- -instance (Ring.C a, Algebra.Module a a) => C a a where - norm = abs --} -instance C Float Float where - norm = abs - -instance C Double Double where - norm = abs - -instance C Int Int where - norm = abs - -instance C Integer Integer where - norm = abs - - -instance (RealRing.C a, ToInteger.C a, PID.C a) => C (Ratio.T a) (Ratio.T a) where - norm = abs - -instance (Ord a, C a v0, C a v1) => C a (v0, v1) where - norm (x0,x1) = max (norm x0) (norm x1) - -instance (Ord a, C a v0, C a v1, C a v2) => C a (v0, v1, v2) where - norm (x0,x1,x2) = (norm x0) `max` (norm x1) `max` (norm x2) - -instance (Ord a, C a v) => C a [v] where - norm = foldl max zero . map norm -{- -Since the norm is always non-negative, -we can use zero as identity element. - norm = maximum . map norm --} diff --git a/src-ghc-6.12/Algebra/NormedSpace/Sum.hs b/src-ghc-6.12/Algebra/NormedSpace/Sum.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/NormedSpace/Sum.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -{- | -Copyright : (c) Henning Thielemann 2005-2010 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : requires multi-parameter type classes - -Abstraction of normed vector spaces --} - -module Algebra.NormedSpace.Sum where - -import NumericPrelude.Base -import NumericPrelude.Numeric - -import qualified Number.Ratio as Ratio - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Additive as Additive -import qualified Algebra.Module as Module - -import qualified Data.Foldable as Fold - - -{-| - The super class is only needed to state the laws - @ - v == zero == norm v == zero - norm (scale x v) == abs x * norm v - norm (u+v) <= norm u + norm v - @ --} -class (Absolute.C a, Module.C a v) => C a v where - norm :: v -> a - -{- | -Default definition for 'norm' that is based on 'Fold.Foldable' class. --} -{-# INLINE normFoldable #-} -normFoldable :: - (C a v, Fold.Foldable f) => f v -> a -normFoldable = - Fold.foldl (\a v -> a + norm v) zero - -{- | -Default definition for 'norm' that is based on 'Fold.Foldable' class -and the argument vector has at least one component. --} -{-# INLINE normFoldable1 #-} -normFoldable1 :: - (C a v, Fold.Foldable f, Functor f) => f v -> a -normFoldable1 = - Fold.foldl1 (+) . fmap norm - - -{- -instance (Ring.C a, Algebra.Module a a) => C a a where - norm = abs --} - -instance C Float Float where - norm = abs - -instance C Double Double where - norm = abs - -instance C Int Int where - norm = abs - -instance C Integer Integer where - norm = abs - - -instance (Absolute.C a, PID.C a) => C (Ratio.T a) (Ratio.T a) where - norm = abs - -instance (Additive.C a, C a v0, C a v1) => C a (v0, v1) where - norm (x0,x1) = norm x0 + norm x1 - -instance (Additive.C a, C a v0, C a v1, C a v2) => C a (v0, v1, v2) where - norm (x0,x1,x2) = norm x0 + norm x1 + norm x2 - -instance (Additive.C a, C a v) => C a [v] where - norm = sum . map norm diff --git a/src-ghc-6.12/Algebra/OccasionallyScalar.hs b/src-ghc-6.12/Algebra/OccasionallyScalar.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/OccasionallyScalar.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -{- | - -There are several types of numbers -where a subset of numbers can be considered as set of scalars. - - * A '(Complex.T Double)' value can be converted to 'Double' if the imaginary part is zero. - - * A value with physical units can be converted to a scalar if there is no unit. - -Of course this can be cascaded, -e.g. a complex number with physical units can be converted to a scalar -if there is both no imaginary part and no unit. - -This is somewhat similar to the multi-type classes NormedMax.C and friends. - -I hesitate to define an instance for lists -to avoid the mess known of MatLab. -But if you have an application where you think -you need this instance definitely -I'll think about that, again. - --} - -module Algebra.OccasionallyScalar where - --- import qualified Algebra.RealRing as RealRing -import qualified Algebra.ZeroTestable as ZeroTestable -import qualified Algebra.Additive as Additive -import qualified Number.Complex as Complex - -import Data.Maybe (fromMaybe, ) - -import Number.Complex((+:)) - -import NumericPrelude.Base -import NumericPrelude.Numeric - - --- this is somehow similar to Normalized classes -class C a v where - toScalar :: v -> a - toMaybeScalar :: v -> Maybe a - fromScalar :: a -> v - -toScalarDefault :: (C a v) => v -> a -toScalarDefault v = - fromMaybe (error ("The value is not scalar.")) - (toMaybeScalar v) - -toScalarShow :: (C a v, Show v) => v -> a -toScalarShow v = - fromMaybe (error (show v ++ " is not a scalar value.")) - (toMaybeScalar v) - - -instance C Float Float where - toScalar = id - toMaybeScalar = Just - fromScalar = id - -instance C Double Double where - toScalar = id - toMaybeScalar = Just - fromScalar = id - --- this instance should be defined in Number.Complex -instance (Show v, ZeroTestable.C v, Additive.C v, C a v) => C a (Complex.T v) where - toScalar = toScalarShow - toMaybeScalar x = if isZero (Complex.imag x) - then toMaybeScalar (Complex.real x) - else Nothing - fromScalar x = fromScalar x +: zero - -{- converting values automatically to integers is a bad idea -instance (Integral b, RealRing.C a) - => C b a where - toScalar = toScalarDefault - toMaybeScalar x = mapMaybe round (toMaybeScalar x) --} diff --git a/src-ghc-6.12/Algebra/OrderDecision.hs b/src-ghc-6.12/Algebra/OrderDecision.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/OrderDecision.hs +++ /dev/null @@ -1,244 +0,0 @@ -{- | -Combination of @compare@ and @if then else@ -that can be instantiated for more types than @Ord@ -or can be instantiated in a way -that allows more defined results (\"more total\" functions): - -* Reader like types for representing a context - like 'Number.ResidueClass.Reader' - -* Expressions in an EDSL - -* More generally every type based on an applicative functor - -* Tuples and Vector types - -* Positional and Peano numbers, - a common prefix of two numbers can be emitted - before the comparison is done. - (This could also be done with an overloaded 'if', - what we also do not have.) --} -module Algebra.OrderDecision where - -import qualified Algebra.EqualityDecision as Equality -import Algebra.EqualityDecision ((==?), ) - -import qualified NumericPrelude.Elementwise as Elem -import Control.Applicative (Applicative(pure, (<*>)), ) -import Data.Tuple.HT (fst3, snd3, thd3, ) -import Data.List (zipWith4, zipWith5, ) - -import Prelude hiding (compare, min, max, minimum, maximum, ) -import qualified Prelude as P - - - -{- | -For atomic types this could be a superclass of 'Ord'. -However for composed types like tuples, lists, functions -we do elementwise comparison -which is incompatible with the complete comparison performed by 'P.compare'. --} -class Equality.C a => C a where - {- | - It holds - - > (compare a b) lt eq gt == - > case Prelude.compare a b of - > LT -> lt - > EQ -> eq - > GT -> gt - - for atomic types where the right hand side can be defined. - - Minimal complete definition: - 'compare' or '(<=?)'. - -} - compare :: a -> a -> a -> a -> a -> a - compare x y lt eq gt = - (x ==? y) eq ((x <=? y) lt gt) - - {-# INLINE (<=?) #-} - (<=?) :: a -> a -> a -> a -> a - (<=?) x y le gt = - compare x y le le gt - - {-# INLINE (>=?) #-} - (>=?) :: a -> a -> a -> a -> a - (>=?) = flip (<=?) - - ( a -> a -> a -> a - (=? y) - - {-# INLINE (>?) #-} - (>?) :: a -> a -> a -> a -> a - (>?) = flip ( a -> a -> a -> a - (?) :: a -> a -> a -> a -> a - (>?) x y gt le = - compare x y le le gt - - (<=?) :: a -> a -> a -> a -> a - (<=?) x y le gt = - compare x y le le gt - - (>=?) :: a -> a -> a -> a -> a - (>=?) x y ge lt = - compare x y lt ge ge --} - - -max :: C a => a -> a -> a -max x y = (x>?y) x y - -min :: C a => a -> a -> a -min x y = (x a -> [a] -> a -maximum x xs = foldl max x xs - -minimum :: C a => a -> [a] -> a -minimum x xs = foldl min x xs - - - -{-# INLINE compareOrd #-} -compareOrd :: Ord a => a -> a -> a -> a -> a -> a -compareOrd a b lt eq gt = - case P.compare a b of - LT -> lt - EQ -> eq - GT -> gt - -instance C Int where - {-# INLINE compare #-} - compare = compareOrd - -instance C Integer where - {-# INLINE compare #-} - compare = compareOrd - -instance C Float where - {-# INLINE compare #-} - compare = compareOrd - -instance C Double where - {-# INLINE compare #-} - compare = compareOrd - -instance C Bool where - {-# INLINE compare #-} - compare = compareOrd - -instance C Ordering where - {-# INLINE compare #-} - compare = compareOrd - - - -{-# INLINE elementCompare #-} -elementCompare :: - (C x) => - (v -> x) -> Elem.T (v,v,v,v,v) x -elementCompare f = - Elem.element (\(x,y,lt,eq,gt) -> - compare (f x) (f y) (f lt) (f eq) (f gt)) - -{-# INLINE (<*>.<=>?) #-} -(<*>.<=>?) :: - (C x) => - Elem.T (v,v,v,v,v) (x -> a) -> (v -> x) -> Elem.T (v,v,v,v,v) a -(<*>.<=>?) f acc = - f <*> elementCompare acc - - -{-# INLINE element #-} -element :: - (C x) => - (x -> x -> x -> x -> x) -> - (v -> x) -> Elem.T (v,v,v,v) x -element cmp f = - Elem.element (\(x,y,true,false) -> cmp (f x) (f y) (f true) (f false)) - -{-# INLINE (<*>.<=?) #-} -(<*>.<=?) :: - (C x) => - Elem.T (v,v,v,v) (x -> a) -> (v -> x) -> Elem.T (v,v,v,v) a -(<*>.<=?) f acc = - f <*> element (<=?) acc - -{-# INLINE (<*>.>=?) #-} -(<*>.>=?) :: - (C x) => - Elem.T (v,v,v,v) (x -> a) -> (v -> x) -> Elem.T (v,v,v,v) a -(<*>.>=?) f acc = - f <*> element (>=?) acc - -{-# INLINE (<*>.. - Elem.T (v,v,v,v) (x -> a) -> (v -> x) -> Elem.T (v,v,v,v) a -(<*>. element (.>?) #-} -(<*>.>?) :: - (C x) => - Elem.T (v,v,v,v) (x -> a) -> (v -> x) -> Elem.T (v,v,v,v) a -(<*>.>?) f acc = - f <*> element (>?) acc - - -instance (C a, C b) => C (a,b) where - {-# INLINE compare #-} - compare = Elem.run5 $ pure (,) <*>.<=>? fst <*>.<=>? snd - {-# INLINE (<=?) #-} - (<=?) = Elem.run4 $ pure (,) <*>.<=? fst <*>.<=? snd - {-# INLINE (>=?) #-} - (>=?) = Elem.run4 $ pure (,) <*>.>=? fst <*>.>=? snd - {-# INLINE (..?) #-} - (>?) = Elem.run4 $ pure (,) <*>.>? fst <*>.>? snd - -instance (C a, C b, C c) => C (a,b,c) where - {-# INLINE compare #-} - compare = Elem.run5 $ pure (,,) <*>.<=>? fst3 <*>.<=>? snd3 <*>.<=>? thd3 - {-# INLINE (<=?) #-} - (<=?) = Elem.run4 $ pure (,,) <*>.<=? fst3 <*>.<=? snd3 <*>.<=? thd3 - {-# INLINE (>=?) #-} - (>=?) = Elem.run4 $ pure (,,) <*>.>=? fst3 <*>.>=? snd3 <*>.>=? thd3 - {-# INLINE (...?) #-} - (>?) = Elem.run4 $ pure (,,) <*>.>? fst3 <*>.>? snd3 <*>.>? thd3 - -instance C a => C [a] where - {-# INLINE compare #-} - compare = zipWith5 compare - {-# INLINE (<=?) #-} - (<=?) = zipWith4 (<=?) - {-# INLINE (>=?) #-} - (>=?) = zipWith4 (>=?) - {-# INLINE (?) #-} - (>?) = zipWith4 (>?) - -instance (C a) => C (b -> a) where - {-# INLINE compare #-} - compare x y lt eq gt c = compare (x c) (y c) (lt c) (eq c) (gt c) - {-# INLINE (<=?) #-} - (<=?) x y true false c = (x c <=? y c) (true c) (false c) - {-# INLINE (>=?) #-} - (>=?) x y true false c = (x c >=? y c) (true c) (false c) - {-# INLINE (?) #-} - (>?) x y true false c = (x c >? y c) (true c) (false c) diff --git a/src-ghc-6.12/Algebra/PrincipalIdealDomain.hs b/src-ghc-6.12/Algebra/PrincipalIdealDomain.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/PrincipalIdealDomain.hs +++ /dev/null @@ -1,384 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.PrincipalIdealDomain ( - {- * Class -} - C, - extendedGCD, - gcd, - lcm, - coprime, - - {- * Standard implementations for instances -} - euclid, - extendedEuclid, - - {- * Algorithms -} - extendedGCDMulti, - diophantine, - diophantineMin, - diophantineMulti, - chineseRemainder, - chineseRemainderMulti, - - {- * Properties -} - propMaximalDivisor, - propGCDDiophantine, - propExtendedGCDMulti, - propDiophantine, - propDiophantineMin, - propDiophantineMulti, - propDiophantineMultiMin, - propChineseRemainder, - propDivisibleGCD, - propDivisibleLCM, - propGCDIdentity, - propGCDCommutative, - propGCDAssociative, - propGCDHomogeneous, - propGCD_LCM, - ) where - -import qualified Algebra.Units as Units -import qualified Algebra.IntegralDomain as Integral --- import qualified Algebra.Ring as Ring --- import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import qualified Algebra.Laws as Laws - -import Algebra.Units (stdAssociate, stdUnitInv) -import Algebra.IntegralDomain (mod, divChecked, divMod, divides, divModZero) -import Algebra.Ring (one, (*), scalarProduct) -import Algebra.Additive (zero, (+), (-)) -import Algebra.ZeroTestable (isZero) - -import Data.Maybe.HT (toMaybe, ) - -import Control.Monad (foldM, liftM) -import Data.List (mapAccumL, mapAccumR, unfoldr) - -import Data.Int (Int, Int8, Int16, Int32, Int64, ) - -import NumericPrelude.Base -import Prelude (Integer, ) -import Test.QuickCheck ((==>), Property) - - - -{- | -A principal ideal domain is a ring in which every ideal -(the set of multiples of some generating set of elements) -is principal: -That is, -every element can be written as the multiple of some generating element. -@gcd a b@ gives a generator for the ideal generated by @a@ and @b@. -The algorithm above works whenever @mod x y@ is smaller -(in a suitable sense) than both @x@ and @y@; -otherwise the algorithm may run forever. - -Laws: - -> divides x (lcm x y) -> x `gcd` (y `gcd` z) == (x `gcd` y) `gcd` z -> gcd x y * z == gcd (x*z) (y*z) -> gcd x y * lcm x y == x * y - -(etc: canonical) - -Minimal definition: - * nothing, if the standard Euclidean algorithm work - * if 'extendedGCD' is implemented customly, 'gcd' and 'lcm' make use of it --} -class (Units.C a, ZeroTestable.C a) => C a where - {- | - Compute the greatest common divisor and - solve a respective Diophantine equation. - - > (g,(a,b)) = extendedGCD x y ==> - > g==a*x+b*y && g == gcd x y - - TODO: This method is not appropriate for the PID class, - because there are rings like the one of the multivariate polynomials, - where for all x and y greatest common divisors of x and y exist, - but they cannot be represented as a linear combination of x and y. - TODO: The definition of extendedGCD does not return the canonical associate. - -} - extendedGCD :: a -> a -> (a,(a,a)) - extendedGCD = extendedEuclid divMod - - {- | - The Greatest Common Divisor is defined by: - - > gcd x y == gcd y x - > divides z x && divides z y ==> divides z (gcd x y) (specification) - > divides (gcd x y) x - -} - gcd :: a -> a -> a - gcd x y = fst $ extendedGCD x y - - {- | - Least common multiple - -} - lcm :: a -> a -> a - lcm x y = - if isZero x - then x -- avoid computing undefined (gcd 0 0) - else divChecked x (gcd x y) * y -- avoid big temporary results - -- lcm x y = divChecked (x * y) (gcd x y) - - -{- -These do only work if zero and one are really identity elements. - -gcdMulti :: (C a) => [a] -> a -gcdMulti = foldl gcd zero - -lcmMulti :: (C a) => [a] -> a -lcmMulti = foldl lcm one --} - -coprime :: (C a) => a -> a -> Bool -coprime x y = - Units.isUnit (gcd x y) - - - -{- -We could implement a helper function, -which exposes the temporary results. -This could be re-used for extendedEuclid. --} -euclid :: (Units.C a, ZeroTestable.C a) => - (a -> a -> a) -> a -> a -> a -euclid genMod = - let aux x y = - if isZero y - then stdAssociate x - else aux y (x `genMod` y) - in aux - --- could be implemented in a tail-recursive manner -{- -Unfortunately, with the normalization to the stdAssociate, -@gcd 0@ is no longer the identity function, -since @gcd 0 (-2) = 2@. --} -extendedEuclid :: (Units.C a, ZeroTestable.C a) => - (a -> a -> (a,a)) -> a -> a -> (a,(a,a)) -extendedEuclid genDivMod = - let aux x y = - if isZero y - then (stdAssociate x, (stdUnitInv x, zero)) - else - let (d,m) = x `genDivMod` y -- x == d*y + m - (g,(a,b)) = aux y m -- g == a*y + b*m - in (g,(b,a-b*d)) -- g == a*y + b*(x-d*y) - in aux - - -{- | -Compute the greatest common divisor for multiple numbers -by repeated application of the two-operand-gcd. --} -extendedGCDMulti :: C a => [a] -> (a,[a]) -extendedGCDMulti xs = - let (g,cs) = mapAccumL extendedGCD zero xs - in (g, snd $ mapAccumR (\acc (c0,c1) -> (acc*c0,acc*c1)) one cs) - -{- | -A variant with small coefficients. --} - - -{- | -@Just (a,b) = diophantine z x y@ -means -@a*x+b*y = z@. -It is required that @gcd(y,z) `divides` x@. --} -diophantine :: C a => a -> a -> a -> Maybe (a,a) -diophantine z x y = - fmap snd $ diophantineAux z x y - -{- | -Like 'diophantine', but @a@ is minimal -with respect to the measure function of the Euclidean algorithm. --} -diophantineMin :: C a => a -> a -> a -> Maybe (a,a) -diophantineMin z x y = - fmap (uncurry (minimizeFirstOperand (x,y))) $ - diophantineAux z x y - -minimizeFirstOperand :: C a => (a,a) -> a -> (a,a) -> (a,a) -minimizeFirstOperand (x,y) g (a,b) = - if isZero g - then (zero,zero) - else - let xl = divChecked x g - yl = divChecked y g - (d,aRed) = divModZero a yl - in (aRed, b + d*xl) - -diophantineAux :: C a => a -> a -> a -> Maybe (a, (a,a)) -diophantineAux z x y = - let (g,(a,b)) = extendedGCD x y - (q,r) = divModZero z g - in toMaybe (isZero r) (g, (q*a, q*b)) - - -{- | --} -diophantineMulti :: C a => a -> [a] -> Maybe [a] -diophantineMulti z xs = - let (g,as) = extendedGCDMulti xs - (q,r) = divModZero z g - in toMaybe (isZero r) (map (q*) as) - -{- | -Not efficient because it requires duplicate computations of GCDs. -However GCDs of neighbouring list elements were not computed before. -It is also quite arbitrary, -because only neighbouring elements are used for balancing. -There are certainly more sophisticated solutions. --} -diophantineMultiMin :: C a => a -> [a] -> Maybe [a] -diophantineMultiMin z xs = - do as <- diophantineMulti z xs - return $ unfoldr - (\as' -> case as' of - ((x0,a0):(x1,a1):aRest) -> - let (b0,b1) = minimizeFirstOperand (x0,x1) (gcd x0 x1) (a0,a1) - in Just (b0, (x1,b1):aRest) - (_,a):[] -> Just (a,[]) - [] -> Nothing) $ - zip xs as - -{- -diophantineMultiMin :: C a => a -> [a] -> Maybe [a] -diophantineMultiMin z xs = - do as <- diophantineMulti z xs - return $ - case as of - (c:cs'@(_:_)) -> - let (cs,cLast) = splitLast cs' - (d,as') = mapAccumL (\a b -> swap $ minimizeFirstOperand (gcd a b) (a,b)) c cs - (d',cLast') = minimizeFirstOperand (gcd d cLast) d cLast - in as' ++ [d',cLast'] - _ -> as --} - -{- | -Not efficient enough, because GCD\/LCM is computed twice. --} -chineseRemainder :: C a => (a,a) -> (a,a) -> Maybe (a,a) -chineseRemainder (m0,a0) (m1,a1) = - liftM (\(k,_) -> let m = lcm m0 m1 in (m, mod (a0-k*m0) m)) $ - diophantineMin (a0-a1) m0 m1 -{- -a0-k*m0 == a1+l*m1 -a0-a1 == k*m0+l*m1 --} - -{- | -For @Just (b,n) = chineseRemainder [(a0,m0), (a1,m1), ..., (an,mn)]@ -and all @x@ with @x = b mod n@ the congruences -@x=a0 mod m0, x=a1 mod m1, ..., x=an mod mn@ -are fulfilled. --} -chineseRemainderMulti :: C a => [(a,a)] -> Maybe (a,a) -chineseRemainderMulti congs = - case congs of - [] -> Nothing - (c:cs) -> foldM chineseRemainder c cs - - - -{- * Instances for atomic types -} - - -{- -There is the binary GCD algorithm, -that is specialised for integers in binary representation. -It does not need a division. -However, since we have an optimized division, -the standard implementation is probably faster. - -TODO: Can Integer make use of the GMP GCD routine? --} - -instance C Integer where - -- possibly more efficient than the default method - gcd = euclid mod - -instance C Int where - gcd = euclid mod - -instance C Int8 where - gcd = euclid mod - -instance C Int16 where - gcd = euclid mod - -instance C Int32 where - gcd = euclid mod - -instance C Int64 where - gcd = euclid mod - - -propGCDIdentity :: (Eq a, C a) => a -> Bool -propGCDAssociative :: (Eq a, C a) => a -> a -> a -> Bool -propGCDCommutative :: (Eq a, C a) => a -> a -> Bool -propGCDDiophantine :: (Eq a, C a) => a -> a -> Bool -propExtendedGCDMulti :: (Eq a, C a) => [a] -> Bool -propDiophantineGen :: (Eq a, C a) => - (a -> a -> a -> Maybe (a,a)) -> a -> a -> a -> a -> Bool -propDiophantine :: (Eq a, C a) => a -> a -> a -> a -> Bool -propDiophantineMin :: (Eq a, C a) => a -> a -> a -> a -> Bool -propDiophantineMultiGen :: (Eq a, C a) => - (a -> [a] -> Maybe [a]) -> [(a,a)] -> Bool -propDiophantineMulti :: (Eq a, C a) => [(a,a)] -> Bool -propDiophantineMultiMin :: (Eq a, C a) => [(a,a)] -> Bool -propDivisibleGCD :: C a => a -> a -> Bool -propDivisibleLCM :: C a => a -> a -> Bool -propGCD_LCM :: (Eq a, C a) => a -> a -> Bool -propGCDHomogeneous :: (Eq a, C a) => a -> a -> a -> Bool -propMaximalDivisor :: C a => a -> a -> a -> Property -propChineseRemainder :: (Eq a, C a) => a -> a -> [a] -> Property - -propMaximalDivisor x y z = - divides z x && divides z y ==> divides z (gcd x y) -propGCDDiophantine x y = - let (g,(a,b)) = extendedGCD x y - in g == gcd x y && g == a*x+b*y -propExtendedGCDMulti xs = - let (g,as) = extendedGCDMulti xs - in g == scalarProduct as xs && - (isZero g || all (divides g) xs) -propDiophantineGen dio a b x y = - let z = a*x+b*y - in maybe False (\(a',b') -> z == a'*x+b'*y) (dio z x y) -propDiophantine = propDiophantineGen diophantine -propDiophantineMin = propDiophantineGen diophantineMin -propDiophantineMultiGen dio axs = - let (as,xs) = unzip axs - z = scalarProduct as xs - in maybe False (\as' -> z == scalarProduct as' xs) (dio z xs) -propDiophantineMulti = propDiophantineMultiGen diophantineMulti -propDiophantineMultiMin = propDiophantineMultiGen diophantineMultiMin -propDivisibleGCD x y = divides (gcd x y) x -propDivisibleLCM x y = divides x (lcm x y) - -propGCDIdentity = Laws.identity gcd zero . stdAssociate -propGCDCommutative = Laws.commutative gcd -propGCDAssociative = Laws.associative gcd -propGCDHomogeneous = Laws.leftDistributive (*) gcd . stdAssociate -propGCD_LCM x y = gcd x y * lcm x y == x * y -propChineseRemainder k x ms = - not (null ms) && all (not . isZero) ms ==> - -- cf. Useful.functionToGraph - let congs = zip ms (map (mod x) ms) - in maybe False - (\(mGlob,y) -> - let yk = y+mGlob*k - in all (\(m,a) -> Integral.sameResidueClass m a yk) congs) - (chineseRemainderMulti congs) diff --git a/src-ghc-6.12/Algebra/RealField.hs b/src-ghc-6.12/Algebra/RealField.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/RealField.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.RealField ( - C, - ) where - -import qualified Algebra.Field as Field -import qualified Algebra.RealRing as RealRing -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.ToInteger as ToInteger - -import qualified Number.Ratio as Ratio - --- import NumericPrelude.Base --- import qualified Prelude as P -import Prelude (Float, Double, ) - -{- | -This is a convenient class for common types -that both form a field and have a notion of ordering by magnitude. --} -class (RealRing.C a, Field.C a) => C a where - -instance C Float where -instance C Double where - -instance (ToInteger.C a, PID.C a) => C (Ratio.T a) where diff --git a/src-ghc-6.12/Algebra/RealIntegral.hs b/src-ghc-6.12/Algebra/RealIntegral.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/RealIntegral.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Generally before using 'quot' and 'rem', think twice. -In most cases 'divMod' and friends are the right choice, -because they fulfill more of the wanted properties. -On some systems 'quot' and 'rem' are more efficient -and if you only use positive numbers, you may be happy with them. -But we cannot warrant the efficiency advantage. - -See also: -Daan Leijen: Division and Modulus for Computer Scientists -, - --} -module Algebra.RealIntegral ( - C(quot, rem, quotRem), - ) where - -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Absolute as Absolute --- import qualified Algebra.Ring as Ring --- import qualified Algebra.Additive as Additive - -import Algebra.Absolute (signum, ) -import Algebra.IntegralDomain (divMod, ) -import Algebra.Ring (one, ) -- fromInteger -import Algebra.Additive (zero, (+), (-), ) - -import Data.Int (Int, Int8, Int16, Int32, Int64, ) -import Data.Word (Word, Word8, Word16, Word32, Word64, ) - -import NumericPrelude.Base -import qualified Prelude as P -import Prelude (Integer, ) - - -infixl 7 `quot`, `rem` - -{- | -Remember that 'divMod' does not specify exactly what @a `quot` b@ should be, -mainly because there is no sensible way to define it in general. -For an instance of @Algebra.RealIntegral.C a@, -it is expected that @a `quot` b@ will round towards 0 and -@a `Prelude.div` b@ will round towards minus infinity. - -Minimal definition: nothing required --} - -class (Absolute.C a, Ord a, Integral.C a) => C a where - quot, rem :: a -> a -> a - quotRem :: a -> a -> (a,a) - - {-# INLINE quot #-} - {-# INLINE rem #-} - {-# INLINE quotRem #-} - quot a b = fst (quotRem a b) - rem a b = snd (quotRem a b) - quotRem a b = let (d,m) = divMod a b in - if (signum d < zero) then - (d+one,m-b) else (d,m) - - -instance C Integer where - {-# INLINE quot #-} - {-# INLINE rem #-} - {-# INLINE quotRem #-} - quot = P.quot - rem = P.rem - quotRem = P.quotRem - -instance C Int where - {-# INLINE quot #-} - {-# INLINE rem #-} - {-# INLINE quotRem #-} - quot = P.quot - rem = P.rem - quotRem = P.quotRem - -instance C Int8 where - {-# INLINE quot #-} - {-# INLINE rem #-} - {-# INLINE quotRem #-} - quot = P.quot - rem = P.rem - quotRem = P.quotRem - -instance C Int16 where - {-# INLINE quot #-} - {-# INLINE rem #-} - {-# INLINE quotRem #-} - quot = P.quot - rem = P.rem - quotRem = P.quotRem - -instance C Int32 where - {-# INLINE quot #-} - {-# INLINE rem #-} - {-# INLINE quotRem #-} - quot = P.quot - rem = P.rem - quotRem = P.quotRem - -instance C Int64 where - {-# INLINE quot #-} - {-# INLINE rem #-} - {-# INLINE quotRem #-} - quot = P.quot - rem = P.rem - quotRem = P.quotRem - - -instance C Word where - {-# INLINE quot #-} - {-# INLINE rem #-} - {-# INLINE quotRem #-} - quot = P.quot - rem = P.rem - quotRem = P.quotRem - -instance C Word8 where - {-# INLINE quot #-} - {-# INLINE rem #-} - {-# INLINE quotRem #-} - quot = P.quot - rem = P.rem - quotRem = P.quotRem - -instance C Word16 where - {-# INLINE quot #-} - {-# INLINE rem #-} - {-# INLINE quotRem #-} - quot = P.quot - rem = P.rem - quotRem = P.quotRem - -instance C Word32 where - {-# INLINE quot #-} - {-# INLINE rem #-} - {-# INLINE quotRem #-} - quot = P.quot - rem = P.rem - quotRem = P.quotRem - -instance C Word64 where - {-# INLINE quot #-} - {-# INLINE rem #-} - {-# INLINE quotRem #-} - quot = P.quot - rem = P.rem - quotRem = P.quotRem - diff --git a/src-ghc-6.12/Algebra/RealRing.hs b/src-ghc-6.12/Algebra/RealRing.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/RealRing.hs +++ /dev/null @@ -1,584 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.RealRing where - -import qualified Algebra.Field as Field -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.ToRational as ToRational -import qualified Algebra.ToInteger as ToInteger - -import qualified Algebra.OrderDecision as OrdDec -import Algebra.OrderDecision ((=?), ) - -import Algebra.Field (fromRational, ) -import Algebra.RealIntegral (quotRem, ) -import Algebra.IntegralDomain (divMod, even, ) -import Algebra.Ring ((*), fromInteger, one, ) -import Algebra.Additive ((+), (-), negate, zero, ) -import Algebra.ZeroTestable (isZero, ) -import Algebra.ToInteger (fromIntegral, ) - -import qualified Number.Ratio as Ratio -import Number.Ratio (T((:%)), Rational) - -import Data.Int (Int, Int8, Int16, Int32, Int64, ) -import Data.Word (Word, Word8, Word16, Word32, Word64, ) - -import qualified GHC.Float as GHC -import Data.List as List -import Data.Tuple.HT (mapFst, mapPair, ) -import Prelude (Integer, Float, Double, ) -import qualified Prelude as P -import NumericPrelude.Base - - -{- | -Minimal complete definition: - 'splitFraction' or 'floor' - -There are probably more laws, but some laws are - -> splitFraction x === (fromInteger (floor x), fraction x) -> fromInteger (floor x) + fraction x === x -> floor x <= x x < floor x + 1 -> ceiling x - 1 < x x <= ceiling x -> 0 <= fraction x fraction x < 1 - -> - ceiling x === floor (-x) -> truncate x === signum x * floor (abs x) -> ceiling (toRational x) === ceiling x :: Integer -> truncate (toRational x) === truncate x :: Integer -> floor (toRational x) === floor x :: Integer - -The new function 'fraction' doesn't return the integer part of the number. -This also removes a type ambiguity if the integer part is not needed. - -Many people will associate rounding with fractional numbers, -and thus they are surprised about the superclass being @Ring@ not @Field@. -The reason is that all of these methods can be defined -exclusively with functions from @Ord@ and @Ring@. -The implementations of 'genericFloor' and other functions demonstrate that. -They implement power-of-two-algorithms -like the one for finding the number of digits of an 'Integer' -in FixedPoint-fractions module. -They are even reasonably efficient. - -I am still uncertain whether it was a good idea -to add instances for @Integer@ and friends, -since calling @floor@ or @fraction@ on an integer may well indicate a bug. -The rounding functions are just the identity function -and 'fraction' is constant zero. -However, I decided to associate our class with @Ring@ rather than @Field@, -after I found myself using repeated subtraction and testing -rather than just calling @fraction@, -just in order to get the constraint @(Ring a, Ord a)@ -that was more general than @(RealField a)@. - -For the results of the rounding functions -we have chosen the constraint @Ring@ instead of @ToInteger@, -since this is more flexible to use, -but it still signals to the user that only integral numbers can be returned. -This is so, because the plain @Ring@ class only provides -@zero@, @one@ and operations that allow to reach all natural numbers but not more. - - -As an aside, let me note the similarities -between @splitFraction x@ and @divMod x 1@ (if that were defined). -In particular, it might make sense to unify the rounding modes somehow. - -The new methods 'fraction' and 'splitFraction' -differ from 'Prelude.properFraction' semantics. -They always round to 'floor'. -This means that the fraction is always non-negative and -is always smaller than 1. -This is more useful in practice and -can be generalised to more than real numbers. -Since every 'Number.Ratio.T' denominator type -supports 'Algebra.IntegralDomain.divMod', -every 'Number.Ratio.T' can provide 'fraction' and 'splitFraction', -e.g. fractions of polynomials. -However the @Ring@ constraint for the ''integral'' part of 'splitFraction' -is too weak in order to generate polynomials. -After all, I am uncertain whether this would be useful or not. - -Can there be a separate class for -'fraction', 'splitFraction', 'floor' and 'ceiling' -since they do not need reals and their ordering? - -We might also add a round method, -that rounds 0.5 always up or always down. -This is much more efficient in inner loops -and is acceptable or even preferable for many applications. --} - -class (Absolute.C a, Ord a) => C a where - splitFraction :: (Ring.C b) => a -> (b,a) - fraction :: a -> a - ceiling, floor :: (Ring.C b) => a -> b - truncate :: (Ring.C b) => a -> b - round :: (ToInteger.C b) => a -> b - - - splitFraction x = (floor x, fraction x) - - fraction x = x - fromInteger (floor x) - - floor x = fromInteger (fst (splitFraction x)) - - ceiling x = - floor (-x) - --- truncate x = signum x * floor (abs x) - truncate x = - if x>=0 - then floor x - else ceiling x - - {- - The ToInteger constraint can be lifted to Ring - if use Integer temporarily. - I expect this would not be efficient in many cases. - -} - round x = - let (n,r) = splitFraction x - in case compare (2*r) one of - LT -> n - EQ -> if even n then n else n+1 - GT -> n+1 - - -{- | -This function rounds to the closest integer. -For @fraction x == 0.5@ it rounds away from zero. -This function is not the result of an ingenious mathematical insight, -but is simply a kind of rounding that is the fastest -on IEEE floating point architectures. --} -roundSimple :: (C a, Ring.C b) => a -> b -roundSimple x = - let (n,r) = splitFraction x - in case compare (2*r) one of - LT -> n - EQ -> if x<0 then n else n+1 - GT -> n+1 - - -instance (ToInteger.C a, PID.C a) => C (Ratio.T a) where - splitFraction (x:%y) = (fromIntegral q, r:%y) - where (q,r) = divMod x y - -instance C Int where - {-# INLINE splitFraction #-} - {-# INLINE fraction #-} - {-# INLINE floor #-} - {-# INLINE ceiling #-} - {-# INLINE round #-} - {-# INLINE truncate #-} - splitFraction x = (fromIntegral x, zero) - fraction _ = zero - floor x = fromIntegral x - ceiling x = fromIntegral x - round x = fromIntegral x - truncate x = fromIntegral x - -instance C Integer where - {-# INLINE splitFraction #-} - {-# INLINE fraction #-} - {-# INLINE floor #-} - {-# INLINE ceiling #-} - {-# INLINE round #-} - {-# INLINE truncate #-} - splitFraction x = (fromInteger x, zero) - fraction _ = zero - floor x = fromInteger x - ceiling x = fromInteger x - round x = fromInteger x - truncate x = fromInteger x - -instance C Float where - {-# INLINE splitFraction #-} - {-# INLINE fraction #-} - {-# INLINE floor #-} - {-# INLINE ceiling #-} - {-# INLINE round #-} - {-# INLINE truncate #-} - splitFraction = fastSplitFraction GHC.float2Int GHC.int2Float - fraction = fastFraction (GHC.int2Float . GHC.float2Int) - floor = fromInteger . P.floor - ceiling = fromInteger . P.ceiling - round = fromInteger . P.round - truncate = fromInteger . P.truncate - -instance C Double where - {-# INLINE splitFraction #-} - {-# INLINE fraction #-} - {-# INLINE floor #-} - {-# INLINE ceiling #-} - {-# INLINE round #-} - {-# INLINE truncate #-} - splitFraction = fastSplitFraction GHC.double2Int GHC.int2Double - fraction = fastFraction (GHC.int2Double . GHC.double2Int) - floor = fromInteger . P.floor - ceiling = fromInteger . P.ceiling - round = fromInteger . P.round - truncate = fromInteger . P.truncate - - -{-# INLINE fastSplitFraction #-} -fastSplitFraction :: (P.RealFrac a, Absolute.C a, Ring.C b) => - (a -> Int) -> (Int -> a) -> a -> (b,a) -fastSplitFraction trunc toFloat x = - fixSplitFraction $ - if toFloat minBound <= x && x <= toFloat maxBound - then case trunc x of n -> (fromIntegral n, x - toFloat n) - else case P.properFraction x of (n,f) -> (fromInteger n, f) - -{-# INLINE fixSplitFraction #-} -fixSplitFraction :: (Ring.C a, Ring.C b, Ord a) => (b,a) -> (b,a) -fixSplitFraction (n,f) = - -- if x>=0 || f==0 - if f>=0 - then (n, f) - else (n-1, f+1) - -{-# INLINE fastFraction #-} -fastFraction :: (P.RealFrac a, Absolute.C a) => (a -> a) -> a -> a -fastFraction trunc x = - fixFraction $ - if fromIntegral (minBound :: Int) <= x && x <= fromIntegral (maxBound :: Int) - then x - trunc x - else preludeFraction x - -{-# INLINE preludeFraction #-} -preludeFraction :: (P.RealFrac a, Ring.C a) => a -> a -preludeFraction x = - let second :: (Integer, a) -> a - second = snd - in second (P.properFraction x) - -{-# INLINE fixFraction #-} -fixFraction :: (Ring.C a, Ord a) => a -> a -fixFraction y = - if y>=0 then y else y+1 - -{- -mapM_ (\n -> let x = fromInteger n / 10 in print (x, floorInt GHC.double2Int GHC.int2Double x)) [-20,-19..20] --} - -{-# INLINE splitFractionInt #-} -splitFractionInt :: (Ring.C a, Ord a) => (a -> Int) -> (Int -> a) -> a -> (Int, a) -splitFractionInt trunc toFloat x = - let n = trunc x - in fixSplitFraction (n, x - toFloat n) - -{-# INLINE floorInt #-} -floorInt :: (Ring.C a, Ord a) => (a -> Int) -> (Int -> a) -> a -> Int -floorInt trunc toFloat x = - let n = trunc x - in if x >= toFloat n - then n - else pred n - -{-# INLINE ceilingInt #-} -ceilingInt :: (Ring.C a, Ord a) => (a -> Int) -> (Int -> a) -> a -> Int -ceilingInt trunc toFloat x = - let n = trunc x - in if x <= toFloat n - then n - else succ n - -{-# INLINE roundInt #-} -roundInt :: (Field.C a, Ord a) => (a -> Int) -> (Int -> a) -> a -> Int -roundInt trunc toFloat x = - let half = 0.5 -- P.fromRational - halfUp = x+half - n = floorInt trunc toFloat halfUp - in if toFloat n == halfUp && P.odd n - then pred n - else n - -{-# INLINE roundSimpleInt #-} -roundSimpleInt :: - (Field.C a, Absolute.C a, Ord a) => - (a -> Int) -> (Int -> a) -> a -> Int -roundSimpleInt trunc _toFloat x = - trunc (x + Absolute.signum x * 0.5) - - - -{- RULES maybe used, when Prelude implementations become more efficient - "NP.round :: Float -> Int" round = P.round :: Float -> Int; - "NP.truncate :: Float -> Int" truncate = P.truncate :: Float -> Int; - "NP.floor :: Float -> Int" floor = P.floor :: Float -> Int; - "NP.ceiling :: Float -> Int" ceiling = P.ceiling :: Float -> Int; - "NP.round :: Double -> Int" round = P.round :: Double -> Int; - "NP.truncate :: Double -> Int" truncate = P.truncate :: Double -> Int; - "NP.floor :: Double -> Int" floor = P.floor :: Double -> Int; - "NP.ceiling :: Double -> Int" ceiling = P.ceiling :: Double -> Int; - -} - --- these rules will also be needed for Int16 et.al. -{-# RULES - "NP.round :: Float -> Int" round = roundInt GHC.float2Int GHC.int2Float; - "NP.roundSimple :: Float -> Int" round = roundSimpleInt GHC.float2Int GHC.int2Float; - "NP.truncate :: Float -> Int" truncate = GHC.float2Int ; - "NP.floor :: Float -> Int" floor = floorInt GHC.float2Int GHC.int2Float; - "NP.ceiling :: Float -> Int" ceiling = ceilingInt GHC.float2Int GHC.int2Float; - "NP.round :: Double -> Int" round = roundInt GHC.double2Int GHC.int2Double; - "NP.roundSimple :: Double -> Int" round = roundSimpleInt GHC.double2Int GHC.int2Double; - "NP.truncate :: Double -> Int" truncate = GHC.double2Int ; - "NP.floor :: Double -> Int" floor = floorInt GHC.double2Int GHC.int2Double; - "NP.ceiling :: Double -> Int" ceiling = ceilingInt GHC.double2Int GHC.int2Double; - - "NP.splitFraction :: Float -> (Int, Float)" splitFraction = splitFractionInt GHC.float2Int GHC.int2Float; - "NP.splitFraction :: Double -> (Int, Double)" splitFraction = splitFractionInt GHC.double2Int GHC.int2Double; - #-} - --- generated by GenerateRules.hs -{-# RULES - "NP.round :: a -> Int8" round = (P.fromIntegral :: Int -> Int8) . round; - "NP.roundSimple :: a -> Int8" roundSimple = (P.fromIntegral :: Int -> Int8) . roundSimple; - "NP.truncate :: a -> Int8" truncate = (P.fromIntegral :: Int -> Int8) . truncate; - "NP.floor :: a -> Int8" floor = (P.fromIntegral :: Int -> Int8) . floor; - "NP.ceiling :: a -> Int8" ceiling = (P.fromIntegral :: Int -> Int8) . ceiling; - "NP.round :: a -> Int16" round = (P.fromIntegral :: Int -> Int16) . round; - "NP.roundSimple :: a -> Int16" roundSimple = (P.fromIntegral :: Int -> Int16) . roundSimple; - "NP.truncate :: a -> Int16" truncate = (P.fromIntegral :: Int -> Int16) . truncate; - "NP.floor :: a -> Int16" floor = (P.fromIntegral :: Int -> Int16) . floor; - "NP.ceiling :: a -> Int16" ceiling = (P.fromIntegral :: Int -> Int16) . ceiling; - "NP.round :: a -> Int32" round = (P.fromIntegral :: Int -> Int32) . round; - "NP.roundSimple :: a -> Int32" roundSimple = (P.fromIntegral :: Int -> Int32) . roundSimple; - "NP.truncate :: a -> Int32" truncate = (P.fromIntegral :: Int -> Int32) . truncate; - "NP.floor :: a -> Int32" floor = (P.fromIntegral :: Int -> Int32) . floor; - "NP.ceiling :: a -> Int32" ceiling = (P.fromIntegral :: Int -> Int32) . ceiling; - "NP.round :: a -> Int64" round = (P.fromIntegral :: Int -> Int64) . round; - "NP.roundSimple :: a -> Int64" roundSimple = (P.fromIntegral :: Int -> Int64) . roundSimple; - "NP.truncate :: a -> Int64" truncate = (P.fromIntegral :: Int -> Int64) . truncate; - "NP.floor :: a -> Int64" floor = (P.fromIntegral :: Int -> Int64) . floor; - "NP.ceiling :: a -> Int64" ceiling = (P.fromIntegral :: Int -> Int64) . ceiling; - "NP.round :: a -> Word" round = (P.fromIntegral :: Int -> Word) . round; - "NP.roundSimple :: a -> Word" roundSimple = (P.fromIntegral :: Int -> Word) . roundSimple; - "NP.truncate :: a -> Word" truncate = (P.fromIntegral :: Int -> Word) . truncate; - "NP.floor :: a -> Word" floor = (P.fromIntegral :: Int -> Word) . floor; - "NP.ceiling :: a -> Word" ceiling = (P.fromIntegral :: Int -> Word) . ceiling; - "NP.round :: a -> Word8" round = (P.fromIntegral :: Int -> Word8) . round; - "NP.roundSimple :: a -> Word8" roundSimple = (P.fromIntegral :: Int -> Word8) . roundSimple; - "NP.truncate :: a -> Word8" truncate = (P.fromIntegral :: Int -> Word8) . truncate; - "NP.floor :: a -> Word8" floor = (P.fromIntegral :: Int -> Word8) . floor; - "NP.ceiling :: a -> Word8" ceiling = (P.fromIntegral :: Int -> Word8) . ceiling; - "NP.round :: a -> Word16" round = (P.fromIntegral :: Int -> Word16) . round; - "NP.roundSimple :: a -> Word16" roundSimple = (P.fromIntegral :: Int -> Word16) . roundSimple; - "NP.truncate :: a -> Word16" truncate = (P.fromIntegral :: Int -> Word16) . truncate; - "NP.floor :: a -> Word16" floor = (P.fromIntegral :: Int -> Word16) . floor; - "NP.ceiling :: a -> Word16" ceiling = (P.fromIntegral :: Int -> Word16) . ceiling; - "NP.round :: a -> Word32" round = (P.fromIntegral :: Int -> Word32) . round; - "NP.roundSimple :: a -> Word32" roundSimple = (P.fromIntegral :: Int -> Word32) . roundSimple; - "NP.truncate :: a -> Word32" truncate = (P.fromIntegral :: Int -> Word32) . truncate; - "NP.floor :: a -> Word32" floor = (P.fromIntegral :: Int -> Word32) . floor; - "NP.ceiling :: a -> Word32" ceiling = (P.fromIntegral :: Int -> Word32) . ceiling; - "NP.round :: a -> Word64" round = (P.fromIntegral :: Int -> Word64) . round; - "NP.roundSimple :: a -> Word64" roundSimple = (P.fromIntegral :: Int -> Word64) . roundSimple; - "NP.truncate :: a -> Word64" truncate = (P.fromIntegral :: Int -> Word64) . truncate; - "NP.floor :: a -> Word64" floor = (P.fromIntegral :: Int -> Word64) . floor; - "NP.ceiling :: a -> Word64" ceiling = (P.fromIntegral :: Int -> Word64) . ceiling; - - "NP.splitFraction :: a -> (Int8,a)" splitFraction = mapFst (P.fromIntegral :: Int -> Int8) . splitFraction; - "NP.splitFraction :: a -> (Int16,a)" splitFraction = mapFst (P.fromIntegral :: Int -> Int16) . splitFraction; - "NP.splitFraction :: a -> (Int32,a)" splitFraction = mapFst (P.fromIntegral :: Int -> Int32) . splitFraction; - "NP.splitFraction :: a -> (Int64,a)" splitFraction = mapFst (P.fromIntegral :: Int -> Int64) . splitFraction; - "NP.splitFraction :: a -> (Word,a)" splitFraction = mapFst (P.fromIntegral :: Int -> Word) . splitFraction; - "NP.splitFraction :: a -> (Word8,a)" splitFraction = mapFst (P.fromIntegral :: Int -> Word8) . splitFraction; - "NP.splitFraction :: a -> (Word16,a)" splitFraction = mapFst (P.fromIntegral :: Int -> Word16) . splitFraction; - "NP.splitFraction :: a -> (Word32,a)" splitFraction = mapFst (P.fromIntegral :: Int -> Word32) . splitFraction; - "NP.splitFraction :: a -> (Word64,a)" splitFraction = mapFst (P.fromIntegral :: Int -> Word64) . splitFraction; - #-} - - -{- | TODO: Should be moved to a continued fraction module. -} - -approxRational :: (ToRational.C a, C a) => a -> a -> Rational -approxRational rat eps = simplest (rat-eps) (rat+eps) - where simplest x y | y < x = simplest y x - | x == y = xr - | x > 0 = simplest' n d n' d' - | y < 0 = - simplest' (-n') d' (-n) d - | otherwise = 0 :% 1 - where xr@(n:%d) = ToRational.toRational x - (n':%d') = ToRational.toRational y - - simplest' n d n' d' -- assumes 0 < n%d < n'%d' - | isZero r = q :% 1 - | q /= q' = (q+1) :% 1 - | otherwise = (q*n''+d'') :% n'' - where (q,r) = quotRem n d - (q',r') = quotRem n' d' - (n'':%d'') = simplest' d' r' d r - - --- * generic implementation of round functions - -powersOfTwo :: (Ring.C a) => [a] -powersOfTwo = iterate (2*) one - -pairsOfPowersOfTwo :: (Ring.C a, Ring.C b) => [(a,b)] -pairsOfPowersOfTwo = - zip powersOfTwo powersOfTwo - -{- | -The generic rounding functions need a number of operations -proportional to the number of binary digits of the integer portion. -If operations like multiplication with two and comparison -need time proportional to the number of binary digits, -then the overall rounding requires quadratic time. --} -genericFloor :: (Ord a, Ring.C a, Ring.C b) => a -> b -genericFloor a = - if a>=zero - then genericPosFloor a - else negate $ genericPosCeiling $ negate a - -genericCeiling :: (Ord a, Ring.C a, Ring.C b) => a -> b -genericCeiling a = - if a>=zero - then genericPosCeiling a - else negate $ genericPosFloor $ negate a - -genericTruncate :: (Ord a, Ring.C a, Ring.C b) => a -> b -genericTruncate a = - if a>=zero - then genericPosFloor a - else negate $ genericPosFloor $ negate a - -genericRound :: (Ord a, Ring.C a, Ring.C b) => a -> b -genericRound a = - if a>=zero - then genericPosRound a - else negate $ genericPosRound $ negate a - -genericFraction :: (Ord a, Ring.C a) => a -> a -genericFraction a = - if a>=zero - then genericPosFraction a - else fixFraction $ negate $ genericPosFraction $ negate a - -genericSplitFraction :: (Ord a, Ring.C a, Ring.C b) => a -> (b,a) -genericSplitFraction a = - if a>=zero - then genericPosSplitFraction a - else fixSplitFraction $ mapPair (negate, negate) $ - genericPosSplitFraction $ negate a - - -genericPosFloor :: (Ord a, Ring.C a, Ring.C b) => a -> b -genericPosFloor a = - snd $ - foldr - (\(pa,pb) acc@(accA,accB) -> - let newA = accA+pa - in if newA>a then acc else (newA,accB+pb)) - (zero,zero) $ - takeWhile ((a>=) . fst) $ - pairsOfPowersOfTwo - -genericPosCeiling :: (Ord a, Ring.C a, Ring.C b) => a -> b -genericPosCeiling a = - snd $ - (\(ps,u:_) -> - foldr - (\(pa,pb) acc@(accA,accB) -> - let newA = accA-pa - in if newA>=a then (newA,accB-pb) else acc) - u ps) $ - span ((a>) . fst) $ - (zero,zero) : pairsOfPowersOfTwo - -{- -genericPosFloorDigits :: (Ord a, Ring.C a, Ring.C b) => a -> ((a,b), [Bool]) -genericPosFloorDigits a = - List.mapAccumR - (\acc@(accA,accB) (pa,pb) -> - let newA = accA+pa - b = newA<=a - in (if b then (newA,accB+pb) else acc, b)) - (zero,zero) $ - takeWhile ((a>=) . fst) $ - pairsOfPowersOfTwo --} - -genericHalfPosFloorDigits :: (Ord a, Ring.C a, Ring.C b) => a -> ((a,b), [Bool]) -genericHalfPosFloorDigits a = - List.mapAccumR - (\acc@(accA,accB) (pa,pb) -> - let newA = accA+pa - b = newA<=a - in (if b then (newA,accB+pb) else acc, b)) - (zero,zero) $ - takeWhile ((a>=) . fst) $ - zip powersOfTwo (zero:powersOfTwo) - -genericPosRound :: (Ord a, Ring.C a, Ring.C b) => a -> b -genericPosRound a = - let a2 = 2*a - ((ai,bi), ds) = genericHalfPosFloorDigits a2 - in if ai==a2 - then - case ds of - True : True : _ -> bi+one - _ -> bi - else - case ds of - True : _ -> bi+one - _ -> bi - -genericPosFraction :: (Ord a, Ring.C a) => a -> a -genericPosFraction a = - foldr - (\p acc -> - if p>acc then acc else acc-p) - a $ - takeWhile (a>=) $ - powersOfTwo - -genericPosSplitFraction :: (Ord a, Ring.C a, Ring.C b) => a -> (b,a) -genericPosSplitFraction a = - foldr - (\(pb,pa) acc@(accB,accA) -> - if pa>accA then acc else (accB+pb,accA-pa)) - (zero,a) $ - takeWhile ((a>=) . snd) $ - pairsOfPowersOfTwo - - -{- | -Needs linear time with respect to the number of digits. - -This and other functions using OrderDecision -like @floor@ where argument and result are the same -may be moved to a new module. --} -decisionPosFraction :: (OrdDec.C a, Ring.C a) => a -> a -decisionPosFraction a0 = - (\ps -> - foldr - (\p cont a -> - (a=?p) (a-p) a) - (error "decisionPosFraction: end of list should never be reached") - ps a0) $ - concatMap (reverse . flip take powersOfTwo) powersOfTwo - -{- -Works but needs quadratic time with respect to the number of digits. -I feel that there must be something more efficient. --} -decisionPosFractionSqrTime :: (OrdDec.C a, Ring.C a) => a -> a -decisionPosFractionSqrTime a0 = - (\ps -> - foldr - (\p cont a -> - (a=?p) (a-p) a) - (error "decisionPosFraction: end of list should never be reached") - ps a0) $ - concatMap reverse $ - inits powersOfTwo diff --git a/src-ghc-6.12/Algebra/RealTranscendental.hs b/src-ghc-6.12/Algebra/RealTranscendental.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/RealTranscendental.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.RealTranscendental where - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealField as RealField - -import Algebra.Transcendental (atan, pi) -import Algebra.Field ((/)) -import Algebra.Ring (fromInteger) -import Algebra.Additive ((+), negate) - -import Data.Bool.HT (select, ) - -import qualified Prelude as P -import NumericPrelude.Base - - - -{-| -This class collects all functions for _scalar_ floating point numbers. -E.g. computing 'atan2' for complex floating numbers makes certainly no sense. --} -class (RealField.C a, Trans.C a) => C a where - atan2 :: a -> a -> a - - atan2 y x = select 0 -- must be after the other double zero tests - [(x>0, atan (y/x)), - (x==0 && y>0, pi/2), - (x<0 && y>0, pi + atan (y/x)), - (x<=0 && y<0, -atan2 (-y) x), - (y==0 && x<0, pi)] -- must be after the previous test on zero y - -instance C P.Float where - atan2 = P.atan2 - -instance C P.Double where - atan2 = P.atan2 diff --git a/src-ghc-6.12/Algebra/RightModule.hs b/src-ghc-6.12/Algebra/RightModule.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/RightModule.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Algebra.RightModule where - -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive - --- import NumericPrelude.Numeric --- import qualified Prelude - - --- Is this right? -infixl 7 <* - -class (Ring.C a, Additive.C b) => C a b where - (<*) :: b -> a -> b diff --git a/src-ghc-6.12/Algebra/Ring.hs b/src-ghc-6.12/Algebra/Ring.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Ring.hs +++ /dev/null @@ -1,257 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.Ring ( - {- * Class -} - C, - - (*), - one, - fromInteger, - (^), sqr, - - {- * Complex functions -} - product, product1, scalarProduct, - - {- * Properties -} - propAssociative, - propLeftDistributive, - propRightDistributive, - propLeftIdentity, - propRightIdentity, - propPowerCascade, - propPowerProduct, - propPowerDistributive, - propCommutative, - ) where - -import qualified Algebra.Additive as Additive -import qualified Algebra.Laws as Laws - -import Algebra.Additive(zero, (+), negate, sum) - -import Data.Function.HT (powerAssociative, ) -import NumericPrelude.List (zipWithChecked, ) - -import Test.QuickCheck ((==>), Property) - -import Data.Int (Int, Int8, Int16, Int32, Int64, ) -import Data.Word (Word, Word8, Word16, Word32, Word64, ) - -import NumericPrelude.Base -import Prelude (Integer, Float, Double, ) -import qualified Data.Ratio as Ratio98 -import qualified Prelude as P --- import Test.QuickCheck - - -infixl 7 * -infixr 8 ^ - - -{- | -Ring encapsulates the mathematical structure -of a (not necessarily commutative) ring, with the laws - -@ - a * (b * c) === (a * b) * c - one * a === a - a * one === a - a * (b + c) === a * b + a * c -@ - -Typical examples include integers, polynomials, matrices, and quaternions. - -Minimal definition: '*', ('one' or 'fromInteger') --} - -class (Additive.C a) => C a where - (*) :: a -> a -> a - one :: a - fromInteger :: Integer -> a - {- | - The exponent has fixed type 'Integer' in order - to avoid an arbitrarily limitted range of exponents, - but to reduce the need for the compiler to guess the type (default type). - In practice the exponent is most oftenly fixed, and is most oftenly @2@. - Fixed exponents can be optimized away and - thus the expensive computation of 'Integer's doesn't matter. - The previous solution used a 'Algebra.ToInteger.C' constrained type - and the exponent was converted to Integer before computation. - So the current solution is not less efficient. - - A variant of '^' with more flexibility is provided by 'Algebra.Core.ringPower'. - -} - (^) :: a -> Integer -> a - - {-# INLINE fromInteger #-} - fromInteger n = if n < 0 - then powerAssociative (+) zero (negate one) (negate n) - else powerAssociative (+) zero one n - {-# INLINE (^) #-} - a ^ n = if n >= zero - then powerAssociative (*) one a n - else error "(^): Illegal negative exponent" - {-# INLINE one #-} - one = fromInteger 1 - - -sqr :: C a => a -> a -sqr x = x*x - -product :: (C a) => [a] -> a -product = foldl (*) one - -product1 :: (C a) => [a] -> a -product1 = foldl1 (*) - - -scalarProduct :: C a => [a] -> [a] -> a -scalarProduct as bs = sum (zipWithChecked (*) as bs) - - -{- * Instances for atomic types -} - -instance C Integer where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - -instance C Float where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - -instance C Double where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - - -instance C Int where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - -instance C Int8 where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - -instance C Int16 where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - -instance C Int32 where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - -instance C Int64 where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - - -instance C Word where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - -instance C Word8 where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - -instance C Word16 where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - -instance C Word32 where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - -instance C Word64 where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = P.fromInteger 1 - fromInteger = P.fromInteger - (*) = (P.*) - - - - - -propAssociative :: (Eq a, C a) => a -> a -> a -> Bool -propLeftDistributive :: (Eq a, C a) => a -> a -> a -> Bool -propRightDistributive :: (Eq a, C a) => a -> a -> a -> Bool -propLeftIdentity :: (Eq a, C a) => a -> Bool -propRightIdentity :: (Eq a, C a) => a -> Bool - -propAssociative = Laws.associative (*) -propLeftDistributive = Laws.leftDistributive (*) (+) -propRightDistributive = Laws.rightDistributive (*) (+) -propLeftIdentity = Laws.leftIdentity (*) one -propRightIdentity = Laws.rightIdentity (*) one - -propPowerCascade :: (Eq a, C a) => a -> Integer -> Integer -> Property -propPowerProduct :: (Eq a, C a) => a -> Integer -> Integer -> Property -propPowerDistributive :: (Eq a, C a) => Integer -> a -> a -> Property - -propPowerCascade x i j = i>=0 && j>=0 ==> Laws.rightCascade (*) (^) x i j -propPowerProduct x i j = i>=0 && j>=0 ==> Laws.homomorphism (x^) (+) (*) i j -propPowerDistributive i x y = i>=0 ==> Laws.leftDistributive (^) (*) i x y - -{- | Commutativity need not be satisfied by all instances of 'Algebra.Ring.C'. -} -propCommutative :: (Eq a, C a) => a -> a -> Bool - -propCommutative = Laws.commutative (*) - - --- legacy - -instance (P.Integral a) => C (Ratio98.Ratio a) where - {-# INLINE one #-} - {-# INLINE fromInteger #-} - {-# INLINE (*) #-} - one = 1 - fromInteger = P.fromInteger - (*) = (P.*) diff --git a/src-ghc-6.12/Algebra/ToInteger.hs b/src-ghc-6.12/Algebra/ToInteger.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/ToInteger.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- -The orphan instance could be fixed -by making this module mutually recursive with ToRational.hs, -but that's not worth the complication. --} - -module Algebra.ToInteger where - -import qualified Number.Ratio as Ratio - -import qualified Algebra.ToRational as ToRational -import qualified Algebra.Field as Field -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.RealIntegral as RealIntegral -import qualified Algebra.Ring as Ring - -import Number.Ratio (T((:%)), ) - -import Algebra.Field ((^-), ) -import Algebra.Ring ((^), fromInteger, ) - -import Data.Int (Int, Int8, Int16, Int32, Int64, ) -import Data.Word (Word, Word8, Word16, Word32, Word64, ) - -import qualified Prelude as P -import NumericPrelude.Base -import Prelude (Integer, Float, Double, ) - - -{- | -The two classes 'Algebra.ToInteger.C' and 'Algebra.ToRational.C' -exist to allow convenient conversions, -primarily between the built-in types. -They should satisfy - -> fromInteger . toInteger === id -> toRational . toInteger === toRational - -Conversions must be lossless, -that is, they do not round in any way. -For rounding see "Algebra.RealRing". -With the instances for 'Prelude.Float' and 'Prelude.Double' -we acknowledge that these types actually represent rationals -rather than (approximated) real numbers. -However, this contradicts to the 'Algebra.Transcendental.C' instance. --} -class (ToRational.C a, RealIntegral.C a) => C a where - toInteger :: a -> Integer - - -fromIntegral :: (C a, Ring.C b) => a -> b -fromIntegral = fromInteger . toInteger - - --- generated by GenerateRules.hs -{-# RULES - "NP.fromIntegral :: Integer -> Int" fromIntegral = P.fromIntegral :: Integer -> Int; - "NP.fromIntegral :: Integer -> Integer" fromIntegral = P.fromIntegral :: Integer -> Integer; - "NP.fromIntegral :: Integer -> Float" fromIntegral = P.fromIntegral :: Integer -> Float; - "NP.fromIntegral :: Integer -> Double" fromIntegral = P.fromIntegral :: Integer -> Double; - "NP.fromIntegral :: Int -> Int" fromIntegral = P.fromIntegral :: Int -> Int; - "NP.fromIntegral :: Int -> Integer" fromIntegral = P.fromIntegral :: Int -> Integer; - "NP.fromIntegral :: Int -> Float" fromIntegral = P.fromIntegral :: Int -> Float; - "NP.fromIntegral :: Int -> Double" fromIntegral = P.fromIntegral :: Int -> Double; - "NP.fromIntegral :: Int8 -> Int" fromIntegral = P.fromIntegral :: Int8 -> Int; - "NP.fromIntegral :: Int8 -> Integer" fromIntegral = P.fromIntegral :: Int8 -> Integer; - "NP.fromIntegral :: Int8 -> Float" fromIntegral = P.fromIntegral :: Int8 -> Float; - "NP.fromIntegral :: Int8 -> Double" fromIntegral = P.fromIntegral :: Int8 -> Double; - "NP.fromIntegral :: Int16 -> Int" fromIntegral = P.fromIntegral :: Int16 -> Int; - "NP.fromIntegral :: Int16 -> Integer" fromIntegral = P.fromIntegral :: Int16 -> Integer; - "NP.fromIntegral :: Int16 -> Float" fromIntegral = P.fromIntegral :: Int16 -> Float; - "NP.fromIntegral :: Int16 -> Double" fromIntegral = P.fromIntegral :: Int16 -> Double; - "NP.fromIntegral :: Int32 -> Int" fromIntegral = P.fromIntegral :: Int32 -> Int; - "NP.fromIntegral :: Int32 -> Integer" fromIntegral = P.fromIntegral :: Int32 -> Integer; - "NP.fromIntegral :: Int32 -> Float" fromIntegral = P.fromIntegral :: Int32 -> Float; - "NP.fromIntegral :: Int32 -> Double" fromIntegral = P.fromIntegral :: Int32 -> Double; - "NP.fromIntegral :: Int64 -> Int" fromIntegral = P.fromIntegral :: Int64 -> Int; - "NP.fromIntegral :: Int64 -> Integer" fromIntegral = P.fromIntegral :: Int64 -> Integer; - "NP.fromIntegral :: Int64 -> Float" fromIntegral = P.fromIntegral :: Int64 -> Float; - "NP.fromIntegral :: Int64 -> Double" fromIntegral = P.fromIntegral :: Int64 -> Double; - "NP.fromIntegral :: Word -> Int" fromIntegral = P.fromIntegral :: Word -> Int; - "NP.fromIntegral :: Word -> Integer" fromIntegral = P.fromIntegral :: Word -> Integer; - "NP.fromIntegral :: Word -> Float" fromIntegral = P.fromIntegral :: Word -> Float; - "NP.fromIntegral :: Word -> Double" fromIntegral = P.fromIntegral :: Word -> Double; - "NP.fromIntegral :: Word8 -> Int" fromIntegral = P.fromIntegral :: Word8 -> Int; - "NP.fromIntegral :: Word8 -> Integer" fromIntegral = P.fromIntegral :: Word8 -> Integer; - "NP.fromIntegral :: Word8 -> Float" fromIntegral = P.fromIntegral :: Word8 -> Float; - "NP.fromIntegral :: Word8 -> Double" fromIntegral = P.fromIntegral :: Word8 -> Double; - "NP.fromIntegral :: Word16 -> Int" fromIntegral = P.fromIntegral :: Word16 -> Int; - "NP.fromIntegral :: Word16 -> Integer" fromIntegral = P.fromIntegral :: Word16 -> Integer; - "NP.fromIntegral :: Word16 -> Float" fromIntegral = P.fromIntegral :: Word16 -> Float; - "NP.fromIntegral :: Word16 -> Double" fromIntegral = P.fromIntegral :: Word16 -> Double; - "NP.fromIntegral :: Word32 -> Int" fromIntegral = P.fromIntegral :: Word32 -> Int; - "NP.fromIntegral :: Word32 -> Integer" fromIntegral = P.fromIntegral :: Word32 -> Integer; - "NP.fromIntegral :: Word32 -> Float" fromIntegral = P.fromIntegral :: Word32 -> Float; - "NP.fromIntegral :: Word32 -> Double" fromIntegral = P.fromIntegral :: Word32 -> Double; - "NP.fromIntegral :: Word64 -> Int" fromIntegral = P.fromIntegral :: Word64 -> Int; - "NP.fromIntegral :: Word64 -> Integer" fromIntegral = P.fromIntegral :: Word64 -> Integer; - "NP.fromIntegral :: Word64 -> Float" fromIntegral = P.fromIntegral :: Word64 -> Float; - "NP.fromIntegral :: Word64 -> Double" fromIntegral = P.fromIntegral :: Word64 -> Double; - #-} - - -instance C Integer where {-#INLINE toInteger #-}; toInteger = id - -instance C Int where {-#INLINE toInteger #-}; toInteger = P.toInteger -instance C Int8 where {-#INLINE toInteger #-}; toInteger = P.toInteger -instance C Int16 where {-#INLINE toInteger #-}; toInteger = P.toInteger -instance C Int32 where {-#INLINE toInteger #-}; toInteger = P.toInteger -instance C Int64 where {-#INLINE toInteger #-}; toInteger = P.toInteger - -instance C Word where {-#INLINE toInteger #-}; toInteger = P.toInteger -instance C Word8 where {-#INLINE toInteger #-}; toInteger = P.toInteger -instance C Word16 where {-#INLINE toInteger #-}; toInteger = P.toInteger -instance C Word32 where {-#INLINE toInteger #-}; toInteger = P.toInteger -instance C Word64 where {-#INLINE toInteger #-}; toInteger = P.toInteger - - -instance (C a, PID.C a) => ToRational.C (Ratio.T a) where - toRational (x:%y) = toInteger x :% toInteger y - - -{-| -A prefix function of '(Algebra.Ring.^)' -with a parameter order that fits the needs of partial application -and function composition. -It has generalised exponent. - -See: Argument order of @expNat@ on - --} -ringPower :: (Ring.C a, C b) => b -> a -> a -ringPower exponent basis = basis ^ toInteger exponent - -{- | -A prefix function of '(Algebra.Field.^-)'. -It has a generalised exponent. --} -fieldPower :: (Field.C a, C b) => b -> a -> a -fieldPower exponent basis = basis ^- toInteger exponent diff --git a/src-ghc-6.12/Algebra/ToRational.hs b/src-ghc-6.12/Algebra/ToRational.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/ToRational.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.ToRational where - -import qualified Algebra.Field as Field -import qualified Algebra.Absolute as Absolute -import Algebra.Field (fromRational, ) -import Algebra.Ring (fromInteger, ) - -import Number.Ratio (Rational, ) - -import Data.Int (Int, Int8, Int16, Int32, Int64, ) -import Data.Word (Word, Word8, Word16, Word32, Word64, ) - -import qualified Prelude as P -import NumericPrelude.Base -import Prelude (Integer, Float, Double, ) - -{- | -This class allows lossless conversion -from any representation of a rational to the fixed 'Rational' type. -\"Lossless\" means - don't do any rounding. -For rounding see "Algebra.RealRing". -With the instances for 'Float' and 'Double' -we acknowledge that these types actually represent rationals -rather than (approximated) real numbers. -However, this contradicts to the 'Algebra.Transcendental' class. - -Laws that must be satisfied by instances: - -> fromRational' . toRational === id --} -class (Absolute.C a) => C a where - -- | Lossless conversion from any representation of a rational to 'Rational' - toRational :: a -> Rational - -instance C Integer where - {-# INLINE toRational #-} - toRational = fromInteger - -instance C Float where - {-# INLINE toRational #-} - toRational = fromRational . P.toRational - -instance C Double where - {-# INLINE toRational #-} - toRational = fromRational . P.toRational - -instance C Int where {-# INLINE toRational #-}; toRational = toRational . P.toInteger -instance C Int8 where {-# INLINE toRational #-}; toRational = toRational . P.toInteger -instance C Int16 where {-# INLINE toRational #-}; toRational = toRational . P.toInteger -instance C Int32 where {-# INLINE toRational #-}; toRational = toRational . P.toInteger -instance C Int64 where {-# INLINE toRational #-}; toRational = toRational . P.toInteger - -instance C Word where {-# INLINE toRational #-}; toRational = toRational . P.toInteger -instance C Word8 where {-# INLINE toRational #-}; toRational = toRational . P.toInteger -instance C Word16 where {-# INLINE toRational #-}; toRational = toRational . P.toInteger -instance C Word32 where {-# INLINE toRational #-}; toRational = toRational . P.toInteger -instance C Word64 where {-# INLINE toRational #-}; toRational = toRational . P.toInteger - - -{- | -It should hold - -> realToField = fromRational' . toRational - -but it should be much more efficient for particular pairs of types, -such as converting 'Float' to 'Double'. -This achieved by optimizer rules. --} -realToField :: (C a, Field.C b) => a -> b -realToField = Field.fromRational' . toRational - -{-# RULES - "NP.realToField :: Integer -> Float " realToField = P.realToFrac :: Integer -> Float ; - "NP.realToField :: Int -> Float " realToField = P.realToFrac :: Int -> Float ; - "NP.realToField :: Int8 -> Float " realToField = P.realToFrac :: Int8 -> Float ; - "NP.realToField :: Int16 -> Float " realToField = P.realToFrac :: Int16 -> Float ; - "NP.realToField :: Int32 -> Float " realToField = P.realToFrac :: Int32 -> Float ; - "NP.realToField :: Int64 -> Float " realToField = P.realToFrac :: Int64 -> Float ; - "NP.realToField :: Word -> Float " realToField = P.realToFrac :: Word -> Float ; - "NP.realToField :: Word8 -> Float " realToField = P.realToFrac :: Word8 -> Float ; - "NP.realToField :: Word16 -> Float " realToField = P.realToFrac :: Word16 -> Float ; - "NP.realToField :: Word32 -> Float " realToField = P.realToFrac :: Word32 -> Float ; - "NP.realToField :: Word64 -> Float " realToField = P.realToFrac :: Word64 -> Float ; - "NP.realToField :: Float -> Float " realToField = P.realToFrac :: Float -> Float ; - "NP.realToField :: Double -> Float " realToField = P.realToFrac :: Double -> Float ; - "NP.realToField :: Integer -> Double" realToField = P.realToFrac :: Integer -> Double; - "NP.realToField :: Int -> Double" realToField = P.realToFrac :: Int -> Double; - "NP.realToField :: Int8 -> Double" realToField = P.realToFrac :: Int8 -> Double; - "NP.realToField :: Int16 -> Double" realToField = P.realToFrac :: Int16 -> Double; - "NP.realToField :: Int32 -> Double" realToField = P.realToFrac :: Int32 -> Double; - "NP.realToField :: Int64 -> Double" realToField = P.realToFrac :: Int64 -> Double; - "NP.realToField :: Word -> Double" realToField = P.realToFrac :: Word -> Double; - "NP.realToField :: Word8 -> Double" realToField = P.realToFrac :: Word8 -> Double; - "NP.realToField :: Word16 -> Double" realToField = P.realToFrac :: Word16 -> Double; - "NP.realToField :: Word32 -> Double" realToField = P.realToFrac :: Word32 -> Double; - "NP.realToField :: Word64 -> Double" realToField = P.realToFrac :: Word64 -> Double; - "NP.realToField :: Float -> Double" realToField = P.realToFrac :: Float -> Double; - "NP.realToField :: Double -> Double" realToField = P.realToFrac :: Double -> Double; - #-} diff --git a/src-ghc-6.12/Algebra/Transcendental.hs b/src-ghc-6.12/Algebra/Transcendental.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Transcendental.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.Transcendental where - -import qualified Algebra.Algebraic as Algebraic --- import qualified Algebra.Ring as Ring --- import qualified Algebra.Additive as Additive - -import qualified Algebra.Laws as Laws - -import Algebra.Algebraic (sqrt) -import Algebra.Field ((/), recip) -import Algebra.Ring ((*), (^), fromInteger) -import Algebra.Additive ((+), (-), negate) - -import qualified Prelude as P -import NumericPrelude.Base - - -infixr 8 **, ^? - -{-| -Transcendental is the type of numbers supporting the elementary -transcendental functions. Examples include real numbers, complex -numbers, and computable reals represented as a lazy list of rational -approximations. - -Note the default declaration for a superclass. See the comments -below, under "Instance declaractions for superclasses". - -The semantics of these operations are rather ill-defined because of -branch cuts, etc. - -Minimal complete definition: - pi, exp, log, sin, cos, asin, acos, atan --} -class (Algebraic.C a) => C a where - pi :: a - exp, log :: a -> a - logBase, (**) :: a -> a -> a - sin, cos, tan :: a -> a - asin, acos, atan :: a -> a - sinh, cosh, tanh :: a -> a - asinh, acosh, atanh :: a -> a - - {-# INLINE pi #-} - {-# INLINE exp #-} - {-# INLINE log #-} - {-# INLINE logBase #-} - {-# INLINE (**) #-} - {-# INLINE sin #-} - {-# INLINE tan #-} - {-# INLINE cos #-} - {-# INLINE asin #-} - {-# INLINE atan #-} - {-# INLINE acos #-} - {-# INLINE sinh #-} - {-# INLINE tanh #-} - {-# INLINE cosh #-} - {-# INLINE asinh #-} - {-# INLINE atanh #-} - {-# INLINE acosh #-} - - x ** y = exp (log x * y) - logBase x y = log y / log x - - tan x = sin x / cos x - - asin x = atan (x / sqrt (1-x^2)) - acos x = pi/2 - asin x - - -- if these definitions have errors, then those in FMP.Types have them, too - sinh x = (exp x - exp (-x)) / 2 - cosh x = (exp x + exp (-x)) / 2 - -- tanh x = (exp x - exp (-x)) / (exp x + exp (-x)) - tanh x = sinh x / cosh x - - asinh x = log (sqrt (x^2+1) + x) - acosh x = log (sqrt (x^2-1) + x) - atanh x = (log (1+x) - log (1-x)) / 2 - - -instance C P.Float where - {-# INLINE pi #-} - {-# INLINE exp #-} - {-# INLINE log #-} - {-# INLINE logBase #-} - {-# INLINE (**) #-} - {-# INLINE sin #-} - {-# INLINE tan #-} - {-# INLINE cos #-} - {-# INLINE asin #-} - {-# INLINE atan #-} - {-# INLINE acos #-} - {-# INLINE sinh #-} - {-# INLINE tanh #-} - {-# INLINE cosh #-} - {-# INLINE asinh #-} - {-# INLINE atanh #-} - {-# INLINE acosh #-} - - (**) = (P.**) - exp = P.exp; log = P.log; logBase = P.logBase - pi = P.pi; - sin = P.sin; cos = P.cos; tan = P.tan - asin = P.asin; acos = P.acos; atan = P.atan - sinh = P.sinh; cosh = P.cosh; tanh = P.tanh - asinh = P.asinh; acosh = P.acosh; atanh = P.atanh - -instance C P.Double where - {-# INLINE pi #-} - {-# INLINE exp #-} - {-# INLINE log #-} - {-# INLINE logBase #-} - {-# INLINE (**) #-} - {-# INLINE sin #-} - {-# INLINE tan #-} - {-# INLINE cos #-} - {-# INLINE asin #-} - {-# INLINE atan #-} - {-# INLINE acos #-} - {-# INLINE sinh #-} - {-# INLINE tanh #-} - {-# INLINE cosh #-} - {-# INLINE asinh #-} - {-# INLINE atanh #-} - {-# INLINE acosh #-} - - (**) = (P.**) - exp = P.exp; log = P.log; logBase = P.logBase - pi = P.pi; - sin = P.sin; cos = P.cos; tan = P.tan - asin = P.asin; acos = P.acos; atan = P.atan - sinh = P.sinh; cosh = P.cosh; tanh = P.tanh - asinh = P.asinh; acosh = P.acosh; atanh = P.atanh - - - -{-# INLINE (^?) #-} -(^?) :: C a => a -> a -> a -(^?) = (**) - - -{-* Transcendental laws, will only hold approximately on floating point numbers -} - -propExpLog :: (Eq a, C a) => a -> Bool -propLogExp :: (Eq a, C a) => a -> Bool -propExpNeg :: (Eq a, C a) => a -> Bool -propLogRecip :: (Eq a, C a) => a -> Bool -propExpProduct :: (Eq a, C a) => a -> a -> Bool -propExpLogPower :: (Eq a, C a) => a -> a -> Bool -propLogSum :: (Eq a, C a) => a -> a -> Bool - -propExpLog x = exp (log x) == x -propLogExp x = log (exp x) == x -propExpNeg x = exp (negate x) == recip (exp x) -propLogRecip x = log (recip x) == negate (log x) -propExpProduct x y = Laws.homomorphism exp (+) (*) x y -propExpLogPower x y = exp (log x * y) == x ** y -propLogSum x y = Laws.homomorphism log (*) (+) x y - - -propPowerCascade :: (Eq a, C a) => a -> a -> a -> Bool -propPowerProduct :: (Eq a, C a) => a -> a -> a -> Bool -propPowerDistributive :: (Eq a, C a) => a -> a -> a -> Bool - -propPowerCascade x i j = Laws.rightCascade (*) (**) x i j -propPowerProduct x i j = Laws.homomorphism (x**) (+) (*) i j -propPowerDistributive i x y = Laws.rightDistributive (**) (*) i x y - -{- * Trigonometric laws, addition theorems -} - -propTrigonometricPythagoras :: (Eq a, C a) => a -> Bool -propTrigonometricPythagoras x = cos x ^ 2 + sin x ^ 2 == 1 - -propSinPeriod :: (Eq a, C a) => a -> Bool -propCosPeriod :: (Eq a, C a) => a -> Bool -propTanPeriod :: (Eq a, C a) => a -> Bool - -propSinPeriod x = sin (x+2*pi) == sin x -propCosPeriod x = cos (x+2*pi) == cos x -propTanPeriod x = tan (x+2*pi) == tan x - -propSinAngleSum :: (Eq a, C a) => a -> a -> Bool -propCosAngleSum :: (Eq a, C a) => a -> a -> Bool - -propSinAngleSum x y = sin (x+y) == sin x * cos y + cos x * sin y -propCosAngleSum x y = cos (x+y) == cos x * cos y - sin x * sin y - -propSinDoubleAngle :: (Eq a, C a) => a -> Bool -propCosDoubleAngle :: (Eq a, C a) => a -> Bool - -propSinDoubleAngle x = sin (2*x) == 2 * sin x * cos x -propCosDoubleAngle x = cos (2*x) == 2 * cos x ^ 2 - 1 - -propSinSquare :: (Eq a, C a) => a -> Bool -propCosSquare :: (Eq a, C a) => a -> Bool - -propSinSquare x = sin x ^ 2 == (1 - cos (2*x)) / 2 -propCosSquare x = cos x ^ 2 == (1 + cos (2*x)) / 2 - diff --git a/src-ghc-6.12/Algebra/Units.hs b/src-ghc-6.12/Algebra/Units.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Units.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.Units ( - {- * Class -} - C, - isUnit, - stdAssociate, - stdUnit, - stdUnitInv, - - {- * Standard implementations for instances -} - intQuery, - intAssociate, - intStandard, - intStandardInverse, - - {- * Properties -} - propComposition, - propInverseUnit, - propUniqueAssociate, - propAssociateProduct, - ) where - -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Ring as Ring --- import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import qualified Algebra.Laws as Laws - -import Algebra.IntegralDomain (div) -import Algebra.Ring (one, (*)) -import Algebra.Additive (negate) -import Algebra.ZeroTestable (isZero) - -import Data.Int (Int, Int8, Int16, Int32, Int64, ) - -import NumericPrelude.Base -import Prelude (Integer, ) -import qualified Prelude as P -import Test.QuickCheck ((==>), Property) - - -{- | -This class lets us deal with the units in a ring. -'isUnit' tells whether an element is a unit. -The other operations let us canonically -write an element as a unit times another element. -Two elements a, b of a ring R are _associates_ if a=b*u for a unit u. -For an element a, we want to write it as a=b*u where b is an associate of a. -The map (a->b) is called -"StandardAssociate" by Gap, -"unitCanonical" by Axiom, -and "canAssoc" by DoCon. -The map (a->u) is called -"canInv" by DoCon and -"unitNormal(x).unit" by Axiom. - -The laws are - -> stdAssociate x * stdUnit x === x -> stdUnit x * stdUnitInv x === 1 -> isUnit u ==> stdAssociate x === stdAssociate (x*u) - -Currently some algorithms assume - -> stdAssociate(x*y) === stdAssociate x * stdAssociate y - -Minimal definition: - 'isUnit' and ('stdUnit' or 'stdUnitInv') and optionally 'stdAssociate' --} - -class (Integral.C a) => C a where - isUnit :: a -> Bool - stdAssociate, stdUnit, stdUnitInv :: a -> a - - stdAssociate x = x * stdUnitInv x - stdUnit x = div one (stdUnitInv x) -- should be divChecked - stdUnitInv x = div one (stdUnit x) - - - - -{- * Instances for atomic types -} - -intQuery :: (P.Integral a, Ring.C a) => a -> Bool -intQuery = flip elem [one, negate one] -{- constraint must be replaced by NumericPrelude.Absolute -} -intAssociate, intStandard, intStandardInverse :: - (P.Integral a, Ring.C a, ZeroTestable.C a) => a -> a -intAssociate = P.abs -intStandard x = if isZero x then one else P.signum x -intStandardInverse = intStandard - -instance C Int where - isUnit = intQuery - stdAssociate = intAssociate - stdUnit = intStandard - stdUnitInv = intStandardInverse - -instance C Integer where - isUnit = intQuery - stdAssociate = intAssociate - stdUnit = intStandard - stdUnitInv = intStandardInverse - -instance C Int8 where - isUnit = intQuery - stdAssociate = intAssociate - stdUnit = intStandard - stdUnitInv = intStandardInverse - -instance C Int16 where - isUnit = intQuery - stdAssociate = intAssociate - stdUnit = intStandard - stdUnitInv = intStandardInverse - -instance C Int32 where - isUnit = intQuery - stdAssociate = intAssociate - stdUnit = intStandard - stdUnitInv = intStandardInverse - -instance C Int64 where - isUnit = intQuery - stdAssociate = intAssociate - stdUnit = intStandard - stdUnitInv = intStandardInverse - - -{- -fieldQuery = not . isZero -fieldAssociate = 1 -fieldStandard x = if isZero x then 1 else x -fieldStandardInverse x = if isZero x then 1 else recip x --} - - - -propComposition :: (Eq a, C a) => a -> Bool -propInverseUnit :: (Eq a, C a) => a -> Bool -propUniqueAssociate :: (Eq a, C a) => a -> a -> Property -propAssociateProduct :: (Eq a, C a) => a -> a -> Bool - -propComposition x = stdAssociate x * stdUnit x == x -propInverseUnit x = stdUnit x * stdUnitInv x == one -propUniqueAssociate u x = - isUnit u ==> stdAssociate x == stdAssociate (x*u) - -{- | Currently some algorithms assume this property. -} -propAssociateProduct = - Laws.homomorphism stdAssociate (*) (*) - diff --git a/src-ghc-6.12/Algebra/Vector.hs b/src-ghc-6.12/Algebra/Vector.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/Vector.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2004-2005 - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable - -Abstraction of vectors --} - -module Algebra.Vector where - -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive - -import Algebra.Ring ((*)) -import Algebra.Additive ((+)) - -import Data.List (zipWith, foldl) --- import Data.Functor (Functor, fmap) - -import Prelude((.), (==), Bool, Functor, fmap) -import qualified Prelude as P - - --- Is this right? -infixr 7 *> - -{-| -A Module over a ring satisfies: - -> a *> (b + c) === a *> b + a *> c -> (a * b) *> c === a *> (b *> c) -> (a + b) *> c === a *> c + b *> c --} -class C v where - -- duplicate some methods from Additive - -- | zero element of the vector space - zero :: (Additive.C a) => v a - -- | add and subtract elements - (<+>) :: (Additive.C a) => v a -> v a -> v a - -- | scale a vector by a scalar - (*>) :: (Ring.C a) => a -> v a -> v a - -infixl 6 <+> - - -{- | -We need a Haskell 98 type class -which provides equality test for Vector type constructors. --} -class Eq v where - eq :: P.Eq a => v a -> v a -> Bool - - -infix 4 `eq` - - -{-* Instances for standard type constructors -} - -functorScale :: (Functor v, Ring.C a) => a -> v a -> v a -functorScale = fmap . (*) - -instance C [] where - zero = Additive.zero - (<+>) = (Additive.+) - (*>) = functorScale - -instance C ((->) b) where - zero = Additive.zero - (<+>) = (Additive.+) - (*>) s f = (s*) . f - -instance Eq [] where - eq = (==) - - - -{-* Related functions -} - -{-| -Compute the linear combination of a list of vectors. --} -linearComb :: (Ring.C a, C v) => [a] -> [v a] -> v a -linearComb c = foldl (<+>) zero . zipWith (*>) c - - -{- * Properties -} - -propCascade :: (C v, Eq v, Ring.C a, P.Eq a) => - a -> a -> v a -> Bool -propCascade a b c = (a * b) *> c `eq` a *> (b *> c) - -propRightDistributive :: (C v, Eq v, Ring.C a, P.Eq a) => - a -> v a -> v a -> Bool -propRightDistributive a b c = a *> (b <+> c) `eq` a*>b <+> a*>c - -propLeftDistributive :: (C v, Eq v, Ring.C a, P.Eq a) => - a -> a -> v a -> Bool -propLeftDistributive a b c = (a+b) *> c `eq` a*>c <+> b*>c diff --git a/src-ghc-6.12/Algebra/VectorSpace.hs b/src-ghc-6.12/Algebra/VectorSpace.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/VectorSpace.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Algebra.VectorSpace where - -import qualified Algebra.Module as Module -import qualified Algebra.Field as Field -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Number.Ratio as Ratio - --- import NumericPrelude.Numeric -import qualified Prelude as P - - -class (Field.C a, Module.C a b) => C a b - - -{-* Instances for atomic types -} - -instance C P.Float P.Float - -instance C P.Double P.Double - -{-* Instances for composed types -} - -instance (PID.C a) => C (Ratio.T a) (Ratio.T a) - -instance (C a b0, C a b1) => C a (b0, b1) - -instance (C a b0, C a b1, C a b2) => C a (b0, b1, b2) - -instance (C a b) => C a [b] - -instance (C a b) => C a (c -> b) diff --git a/src-ghc-6.12/Algebra/ZeroTestable.hs b/src-ghc-6.12/Algebra/ZeroTestable.hs deleted file mode 100644 --- a/src-ghc-6.12/Algebra/ZeroTestable.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.ZeroTestable where - -import qualified Algebra.Additive as Additive - -import Data.Int (Int, Int8, Int16, Int32, Int64, ) -import Data.Word (Word, Word8, Word16, Word32, Word64, ) - --- import qualified Prelude as P -import Prelude (Integer, Float, Double, ) -import NumericPrelude.Base - -{- | -Maybe the naming should be according to Algebra.Unit: -Algebra.Zero as module name, and @query@ as method name. --} -class C a where - isZero :: a -> Bool - -{- | -Checks if a number is the zero element. -This test is not possible for all 'Additive.C' types, -since e.g. a function type does not belong to Eq. -isZero is possible for some types where (==zero) fails -because there is no unique zero. -Examples are -vector (the length of the zero vector is unknown), -physical values (the unit of a zero quantity is unknown), -residue class (the modulus is unknown). --} -defltIsZero :: (Eq a, Additive.C a) => a -> Bool -defltIsZero = (Additive.zero==) - - -{-* Instances for atomic types -} - -instance C Integer where isZero = defltIsZero -instance C Float where isZero = defltIsZero -instance C Double where isZero = defltIsZero - -instance C Int where isZero = defltIsZero -instance C Int8 where isZero = defltIsZero -instance C Int16 where isZero = defltIsZero -instance C Int32 where isZero = defltIsZero -instance C Int64 where isZero = defltIsZero - -instance C Word where isZero = defltIsZero -instance C Word8 where isZero = defltIsZero -instance C Word16 where isZero = defltIsZero -instance C Word32 where isZero = defltIsZero -instance C Word64 where isZero = defltIsZero - - - -{-* Instances for composed types -} - -instance (C v0, C v1) => C (v0, v1) where - isZero (x0,x1) = isZero x0 && isZero x1 - -instance (C v0, C v1, C v2) => C (v0, v1, v2) where - isZero (x0,x1,x2) = isZero x0 && isZero x1 && isZero x2 - - -instance (C v) => C [v] where - isZero = all isZero diff --git a/src-ghc-6.12/MathObj/Algebra.hs b/src-ghc-6.12/MathObj/Algebra.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Algebra.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Mikael Johansson 2006 -Maintainer : mik@math.uni-jena.de -Stability : provisional -Portability : requires multi-parameter type classes - -The generic case of a k-algebra generated by a monoid. --} - -module MathObj.Algebra where - -import qualified Algebra.Vector as Vector -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.Monoid as Monoid - -import Algebra.Ring((*)) -import Algebra.Additive((+),negate,zero) -import Algebra.Monoid((<*>)) - -import Control.Monad(liftM2,Functor,fmap) -import Data.Map(Map) -import qualified Data.Map as Map -import Data.List(intersperse) - -import NumericPrelude.Base(Ord,Eq,{-Read,-}Show,(++),($), - concat,map,show) - - -newtype {- (Ord a, Monoid.C a, Ring.C b) => -} - T a b = Cons (Map a b) - deriving (Eq {- ,Read -} ) - -instance Functor (T a) where - fmap f (Cons x) = Cons (fmap f x) - --- is an Indexable instance better than an Ord instance here? - -instance (Ord a, Additive.C b) => Additive.C (T a b) where - (+) = zipWith (+) - {- This implementation is attracting but wrong. - It fails if terms are present in b that are missing in a. - Default implementation is better here. - (-) = zipWith (-) - -} - negate = fmap negate - zero = Cons Map.empty - -zipWith :: (Ord a) => (b -> b -> b) -> (T a b -> T a b -> T a b) -zipWith op (Cons ma) (Cons mb) = Cons (Map.unionWith op ma mb) - -instance Ord a => Vector.C (T a) where - zero = zero - (<+>) = (+) - (*>) = Vector.functorScale - -instance (Ord a, Monoid.C a, Ring.C b) => Ring.C (T a b) where - one = Cons $ Map.singleton Monoid.idt Ring.one - (Cons ma) * (Cons mb) = - Cons $ Map.fromListWith (+) $ - liftM2 mulMonomial (Map.toList ma) (Map.toList mb) - -mulMonomial :: (Monoid.C a, Ring.C b) => (a,b) -> (a,b) -> (a,b) -mulMonomial (c1,m1) (c2,m2) = (c1<*>c2,m1*m2) - -instance (Show a, Show b) => Show (T a b) where - show (Cons ma) = concat $ - intersperse "+" $ - map (\(m,c) -> show c ++ "." ++ show m) - (Map.toList ma) - -monomial :: a -> b -> (T a b) -monomial index coefficient = Cons (Map.singleton index coefficient) diff --git a/src-ghc-6.12/MathObj/DiscreteMap.hs b/src-ghc-6.12/MathObj/DiscreteMap.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/DiscreteMap.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -{- FIXME: -Rationale for -fno-warn-orphans: - * The orphan instances can't be put into Numeric.NonNegative.Wrapper - since that's in another package. - * We had to spread the instance declarations - over the modules defining the typeclasses instantiated. - Do we want that? - * We could define the DiscreteMap as newtype. --} - -{- | -DiscreteMap was originally intended as a type class -that unifies Map and Array. -One should be able to simply choose between - - Map for sparse arrays - - Array for full arrays. - -However, the Edison package provides the class AssocX -which already exists for that purpose. - -Currently I use this module for some numeric instances of Data.Map. --} -module MathObj.DiscreteMap where - -import qualified Algebra.NormedSpace.Sum as NormedSum -import qualified Algebra.NormedSpace.Euclidean as NormedEuc -import qualified Algebra.NormedSpace.Maximum as NormedMax -import qualified Algebra.VectorSpace as VectorSpace -import qualified Algebra.Module as Module -import qualified Algebra.Vector as Vector -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Additive as Additive - -import Algebra.Module ((*>)) -import Algebra.Additive (zero,(+),negate) -import qualified Data.Map as Map -import Data.Map (Map) - --- import qualified Prelude as P -import NumericPrelude.Base - --- FIXME: Should this be implemented by isZero? --- | Remove all zero values from the map. -strip :: (Ord i, Eq v, Additive.C v) => Map i v -> Map i v -strip = Map.filter (zero /=) ---strip = Map.filter (((0 /=) .) . (flip const)) - -instance (Ord i, Eq v, Additive.C v) => Additive.C (Map i v) where - zero = Map.empty - (+) = (strip.). Map.unionWith (+) - --(+) y x = strip (Map.unionWith (+) y x) - (-) x y = (+) x (negate y) - {- won't work because Map.unionWith won't negate a value from y if no x value corresponds to it - (-) x y = strip (Map.unionWith sub x y) - -} - negate = fmap negate - -instance Ord i => Vector.C (Map i) where - zero = Map.empty - (<+>) = Map.unionWith (+) - -- requires Eq instance for expo - -- expo *> x = if expo == zero then zero else Vector.functorScale expo x - (*>) = Vector.functorScale - -instance (Ord i, Eq a, Eq v, Module.C a v) - => Module.C a (Map i v) where --- (*>) 0 = \_ -> zero --- (*>) expo = fmap ((*>) expo) - (*>) expo x = if expo == zero then zero else fmap (expo *>) x - -instance (Ord i, Eq a, Eq v, VectorSpace.C a v) - => VectorSpace.C a (Map i v) - -instance (Ord i, Eq a, Eq v, NormedSum.C a v) - => NormedSum.C a (Map i v) where - norm = foldl (+) zero . map NormedSum.norm . Map.elems - -instance (Ord i, Eq a, Eq v, NormedEuc.Sqr a v) - => NormedEuc.Sqr a (Map i v) where - normSqr = foldl (+) zero . map NormedEuc.normSqr . Map.elems - -instance (Ord i, Eq a, Eq v, Algebraic.C a, NormedEuc.Sqr a v) - => NormedEuc.C a (Map i v) where - norm = NormedEuc.defltNorm - -instance (Ord i, Eq a, Eq v, NormedMax.C a v) - => NormedMax.C a (Map i v) where - norm = foldl max zero . map NormedMax.norm . Map.elems diff --git a/src-ghc-6.12/MathObj/Gaussian/Bell.hs b/src-ghc-6.12/MathObj/Gaussian/Bell.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Gaussian/Bell.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- -Complex translated Gaussian bell curve -with amplitude abstracted away. --} -module MathObj.Gaussian.Bell where - -import qualified MathObj.Polynomial as Poly -import qualified Number.Complex as Complex - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Field as Field -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive - -import Number.Complex ((+:), ) - -import Test.QuickCheck (Arbitrary, arbitrary, ) -import Control.Monad (liftM4, ) - --- import Prelude (($)) -import NumericPrelude.Numeric -import NumericPrelude.Base hiding (reverse, ) - - -data T a = Cons {amp :: a, c0, c1 :: Complex.T a, c2 :: a} - deriving (Eq, Show) - -instance (Absolute.C a, Arbitrary a) => Arbitrary (T a) where - arbitrary = - liftM4 - (\k a b c -> Cons (abs k) a b (1 + abs c)) - arbitrary arbitrary arbitrary arbitrary - - -constant :: Ring.C a => T a -constant = Cons one zero zero zero - -{- | -eigenfunction of 'fourier' --} -unit :: Ring.C a => T a -unit = Cons one zero zero one - -{-# INLINE evaluate #-} -evaluate :: (Trans.C a) => - T a -> a -> Complex.T a -evaluate f x = - Complex.scale - (sqrt (amp f)) - (Complex.exp $ Complex.scale (-pi) $ - c0 f + Complex.scale x (c1 f) + Complex.fromReal (c2 f * x^2)) - -evaluateSqRt :: (Trans.C a) => - T a -> a -> Complex.T a -evaluateSqRt f x0 = - Complex.scale - (sqrt (amp f)) - (let x = sqrt pi * x0 - in Complex.exp $ negate $ - c0 f + Complex.scale x (c1 f) + Complex.fromReal (c2 f * x^2)) - -exponentPolynomial :: (Additive.C a) => - T a -> Poly.T (Complex.T a) -exponentPolynomial f = - Poly.fromCoeffs [c0 f, c1 f, Complex.fromReal (c2 f)] - - -variance :: (Trans.C a) => - T a -> a -variance f = - recip $ c2 f * 2*pi - -multiply :: (Ring.C a) => - T a -> T a -> T a -multiply f g = - Cons - (amp f * amp g) - (c0 f + c0 g) (c1 f + c1 g) (c2 f + c2 g) - -powerRing :: (Trans.C a) => - Integer -> T a -> T a -powerRing p f = - let pa = fromInteger p - in Cons - (amp f ^ p) - (pa * c0 f) (pa * c1 f) (fromInteger p * c2 f) - -{- -powerField does not makes sense, -since the reciprocal of a Gaussian diverges. --} - -powerAlgebraic :: (Trans.C a) => - Rational -> T a -> T a -powerAlgebraic p f = - let pa = fromRational' p - in Cons - (amp f ^/ p) - (pa * c0 f) (pa * c1 f) (fromRational' p * c2 f) - -powerTranscendental :: (Trans.C a) => - a -> T a -> T a -powerTranscendental p f = - Cons - (amp f ^? p) - (Complex.scale p $ c0 f) (Complex.scale p $ c1 f) (p * c2 f) - - -{- -let x=Cons 2 (1+:3) (4+:5) (7::Rational); y=Cons 7 (1+:4) (3+:2) (5::Rational) --} -convolve :: (Field.C a) => - T a -> T a -> T a -convolve f g = - let s = c2 f + c2 g - {- - fd = f1/(2*f2) - gd = g1/(2*g2) - c = f2*g2/(f2+g2) - - c*(fd+gd) = (f1*g2+f2*g1)/(2*(f2+g2)) = b/2 - - c*(fd+gd)^2 - fd^2*f2 - gd^2*g2 - = f2*g2*(fd+gd)^2/(f2 + g2) - (fd^2*f2 + gd^2*g2) - = (f2*g2*(fd+gd)^2 - (f2+g2)*(fd^2*f2+gd^2*g2)) / (f2 + g2) - = (2*f2*g2*fd*gd - (fd^2*f2^2+gd^2*g2^2)) / (f2 + g2) - = (2*f1*g1 - (f1^2+g1^2)) / (4*(f2 + g2)) - = -(f1 - g1)^2/(4*(f2 + g2)) - -} - in Cons - (amp f * amp g / s) - (c0 f + c0 g - - Complex.scale (recip (4*s)) ((c1 f - c1 g)^2)) - (Complex.scale (c2 g / s) (c1 f) + - Complex.scale (c2 f / s) (c1 g)) - (c2 f * c2 g / s) - -- recip $ recip (c2 f) + recip (c2 g) -{- - Cons - (c0 f + c0 g) (c1 f + c1 g) - (recip $ recip (c2 f) + recip (c2 g)) --} - -convolveByTranslation :: (Field.C a) => - T a -> T a -> T a -convolveByTranslation f0 g0 = - let fd = Complex.scale (recip (2 * c2 f0)) $ c1 f0 - gd = Complex.scale (recip (2 * c2 g0)) $ c1 g0 - f1 = translateComplex fd f0 - g1 = translateComplex gd g0 - s = c2 f1 + c2 g1 - in translateComplex (negate $ fd + gd) $ - Cons - (amp f1 * amp g1 / s) - (c0 f1 + c0 g1) zero - (c2 f1 * c2 g1 / s) - -convolveByFourier :: (Field.C a) => - T a -> T a -> T a -convolveByFourier f g = - reverse $ fourier $ multiply (fourier f) (fourier g) - -fourier :: (Field.C a) => - T a -> T a -fourier f = - let a = c0 f - b = c1 f - rc = recip $ c2 f - in Cons - (amp f * rc) - (Complex.scale (rc/4) (-b^2) + a) - (Complex.scale rc $ Complex.quarterRight b) - rc - -fourierByTranslation :: (Field.C a) => - T a -> T a -fourierByTranslation f = - translateComplex (Complex.scale (1/2) $ Complex.quarterLeft $ c1 f) $ - Cons (amp f / c2 f) (c0 f) zero (recip $ c2 f) - -{- -a + b*x + c*x^2 - = c*(a/c + b/c*x + x^2) - = c*((x-b/(2*c))^2 + (4*a*c+b^2)/(4*c^2)) - = c*(x-b/(2*c))^2 + (4*a*c+b^2)/(4*c) - -fourier -> - x^2/c - i*b/c*x + (4*a*c+b^2)/(4*c) - -fourier (x -> exp(-pi*c*(x-t)^2)) - = fourier $ translate t $ shrink (sqrt c) $ x -> exp(-pi*x^2) - = modulate t $ dilate (sqrt c) $ fourier $ x -> exp(-pi*x^2) - = modulate t $ dilate (sqrt c) $ x -> exp(-pi*x^2) - = modulate t $ x -> exp(-pi*x^2/c) - = x -> exp(-pi*x^2/c) * exp(-2*pi*i*x*t) - = x -> exp(-pi*(x^2/c - 2*i*x*t)) --} - -{- -b*x + c*x^2 - = c*(b/c*x + x^2) - = c*((x-br/(2*c))^2 + i*x*bi/c - br^2/(4*c^2)) - = c*(x-br/(2*c))^2 + i*x*bi - br^2/(4*c) - -fourier -> - (x+bi/2)^2/c - i*br/c*(x+bi/2) - br^2/(4*c) - = (1/c) * ((x+bi/2)^2 - i*br*(x+bi/2) + (br/2)^2) - = (1/c) * (x^2 - i*b*x + -(br/2)^2 + (bi/2)^2 - i*br*bi/2) - = (1/c) * (x^2 - i*b*x - (br^2-bi^2+2*br*bi*i)^2 /4) - = (1/c) * (x^2 - i*b*x - b^2 / 4) - = (1/c) * (x^2 - i*b*x + (i*b/2)^2) - = (1/c) * (x - i*b/2)^2 - -Example: - (x-b)^2 = b^2 - 2*b*x + x^2 - -> (- i*2*b*x + x^2) - - -fourier (x -> exp(-pi*(c*(x-t)^2 + 2*i*m*x))) - = fourier $ modulate m $ translate t $ shrink (sqrt c) $ x -> exp(-pi*x^2) - = translate (-m) $ modulate t $ dilate (sqrt c) $ fourier $ x -> exp(-pi*x^2) - = translate (-m) $ modulate t $ dilate (sqrt c) $ x -> exp(-pi*x^2) - = translate (-m) $ modulate t $ x -> exp(-pi*x^2/c) - = translate (-m) $ x -> exp(-pi*x^2/c) * exp(-2*pi*i*x*t) - = x -> exp(-pi*(x+m)^2/c) * exp(-2*pi*i*(x+m)*t) - = x -> exp(-pi*((x+m)^2/c - 2*i*(x+m)*t)) --} - -{- -fourier (Cons a 0 0) = - Cons a 0 infinity - -fourier (Cons 0 0 c) = - Cons 0 0 (recip c) - -fourier (Cons 0 b 1) = - Cons 0 (i*b) 1 --} - -translate :: Ring.C a => a -> T a -> T a -translate d f = - let a = c0 f - b = c1 f - c = c2 f - in Cons - (amp f) - (Complex.fromReal (c*d^2) - Complex.scale d b + a) - (Complex.fromReal (-2*c*d) + b) - c - -translateComplex :: Ring.C a => Complex.T a -> T a -> T a -translateComplex d f = - let a = c0 f - b = c1 f - c = c2 f - in Cons - (amp f) - (Complex.scale c (d^2) - b*d + a) - (Complex.scale (-2*c) d + b) - c - -modulate :: Ring.C a => a -> T a -> T a -modulate d f = - Cons - (amp f) - (c0 f) - (c1 f + (zero +: 2*d)) - (c2 f) - -turn :: Ring.C a => a -> T a -> T a -turn d f = - Cons - (amp f) - (c0 f + (zero +: 2*d)) - (c1 f) - (c2 f) - -reverse :: Additive.C a => T a -> T a -reverse f = - f{c1 = negate $ c1 f} - - -dilate :: Field.C a => a -> T a -> T a -dilate k f = - Cons - (amp f) - (c0 f) - (Complex.scale (recip k) $ c1 f) - (c2 f / k^2) - -shrink :: Ring.C a => a -> T a -> T a -shrink k f = - Cons - (amp f) - (c0 f) - (Complex.scale k $ c1 f) - (c2 f * k^2) - -amplify :: (Ring.C a) => a -> T a -> T a -amplify k f = - Cons - (k^2 * amp f) - (c0 f) - (c1 f) - (c2 f) - - -{- laws -fourier (convolve f g) = fourier f * fourier g - -fourier (fourier f) = reverse f --} diff --git a/src-ghc-6.12/MathObj/Gaussian/Example.hs b/src-ghc-6.12/MathObj/Gaussian/Example.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Gaussian/Example.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- -Reciprocal of variance of a Gaussian bell curve. -We describe the curve only in terms of its variance -thus we represent a bell curve at the coordinate origin -neglecting its amplitude. - -We could also define the amplitude as @root 4 c@, -thus preserving L2 norm being one, -but then @dilate@ and @shrink@ also include an amplification. - -We could do some projective geometry in the exponent -in order to also have zero variance, -which corresponds to the dirac impulse. --} -module MathObj.Gaussian.Example where - -import qualified MathObj.Gaussian.Polynomial as PolyBell -import qualified MathObj.Gaussian.Bell as Bell -import qualified MathObj.Gaussian.Variance as Var - -import qualified MathObj.Polynomial as Poly - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field --- import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring --- import qualified Algebra.Additive as Additive - -import qualified Number.Complex as Complex - -import Algebra.Transcendental (pi, ) -import Algebra.Algebraic (root, ) -import Algebra.Ring ((*), (^), ) - -import Number.Complex ((+:), ) - -import qualified Numerics.Function as Func -import qualified Numerics.Fourier as Fourier -import qualified Numerics.Integration as Integ -import qualified Numerics.Differentiation as Diff - -import qualified Graphics.Gnuplot.Simple as GP - -import Control.Applicative (liftA2, ) - --- import System.Exit (ExitCode, ) - --- import Prelude (($)) -import NumericPrelude.Numeric -import NumericPrelude.Base -import qualified Prelude as P - - -curve0 :: Var.T Double -curve0 = curve0a - -curve0a :: Var.T Double -curve0a = Var.Cons 1.4 3.3 - -curve0b :: Var.T Double -curve0b = Var.Cons 2.2 1.7 - -variance0 :: (Double, Double) -variance0 = - (Var.variance curve0, - (Integ.rectangular 1000 (-2,2) $ liftA2 (*) (^2) (Var.evaluate curve0)) / - (Integ.rectangular 1000 (-2,2) $ Var.evaluate curve0)) - -norm10 :: (Double, Double) -norm10 = - (Integ.rectangular 1000 (-2,2) $ Var.evaluate curve0, - Var.norm1 curve0) - -norm20 :: (Double, Double) -norm20 = - (sqrt $ Integ.rectangular 1000 (-2,2) $ (^2) . Var.evaluate curve0, - Var.norm2 curve0) - -norm30 :: (Double, Double) -norm30 = - (root 3 $ Integ.rectangular 1000 (-2,2) $ (^3) . Var.evaluate curve0, - Var.normP 3 curve0) - -fourier0 :: IO () -fourier0 = - GP.plotFuncs [] - (GP.linearScale 100 (-2,2)) - [Var.evaluate $ Var.fourier curve0, - Fourier.analysisTransformOneReal 100 (-2,2) $ Var.evaluate curve0] - -multiply0 :: IO () -multiply0 = - GP.plotFuncs [] - (GP.linearScale 100 (-1,1)) - [Var.evaluate $ Var.multiply curve0a curve0b, - liftA2 (*) (Var.evaluate curve0a) (Var.evaluate curve0b)] - -convolve0 :: IO () -convolve0 = - GP.plotFuncs [] - (GP.linearScale 100 (-2,2)) - [Var.evaluate $ Var.convolve curve0a curve0b, - Integ.convolve 1000 (-3,3) (Var.evaluate curve0a) (Var.evaluate curve0b)] - - -curve1 :: Bell.T Double -curve1 = curve1a - -curve1a :: Bell.T Double -curve1a = Bell.Cons 1.4 (0.1+:0.3) ((-0.2)+:1.4) 2.3 - -curve1b :: Bell.T Double -curve1b = Bell.Cons 2.2 ((-0.3)+:2.1) (0.2+:(-0.4)) 1.7 - -variance1 :: (Double, Double) -variance1 = - (Bell.variance curve1, - (Integ.rectangular 1000 (-2,2) $ - liftA2 (*) (^2) - (Complex.magnitudeSqr . - Func.translateRight - (Complex.real (Bell.c1 curve1) / (2 * Bell.c2 curve1)) - (Bell.evaluate curve1))) / - (Integ.rectangular 1000 (-2,2) $ Complex.magnitude . Bell.evaluate curve1)) - -{- the norm depends on too much things -norm0vs1 :: (Double, Double) -norm0vs1 = - ((Integ.rectangular 1000 (-5,5) $ Var.evaluate curve0) - * exp (- Complex.real (Bell.c0 curve1)), - Integ.rectangular 1000 (-5,5) $ Complex.magnitude . Bell.evaluate curve1) --} - -fourier1 :: IO () -fourier1 = - GP.plotFuncs [] - (GP.linearScale 100 (-5,5)) - [Complex.real . (Bell.evaluate $ Bell.fourier curve1), - fourierAnalysisReal 100 (-2,2) $ Bell.evaluate curve1] - - -curve2 :: PolyBell.T Double -curve2 = - PolyBell.Cons --- Bell.unit --- (Bell.Cons 1.4 (0.1+:0.3) 0 1.2) --- (Bell.Cons 1.4 (0.1+:0.3) ((-0.2)+:1.4) 1) - curve1 --- (Poly.fromCoeffs [one]) --- (Poly.fromCoeffs [zero,one]) --- (Poly.fromCoeffs [zero,zero,one]) --- (Poly.fromCoeffs [0,Complex.imaginaryUnit]) - (Poly.fromCoeffs [1.4+:(-0.1),0.8+:(0.1),(-1.1)+:0.3]) - -differentiate2 :: IO () -differentiate2 = - GP.plotFuncs [] - (GP.linearScale 100 (-2,2)) - [Complex.real . (PolyBell.evaluateSqRt $ PolyBell.differentiate curve2), - ((/ sqrt pi) . ) $ Diff.diff (1e-5) $ Complex.real . PolyBell.evaluateSqRt curve2] - -fourier2 :: IO () -fourier2 = - GP.plotFuncs [] - (GP.linearScale 100 (-5,5)) - [Complex.real . (PolyBell.evaluateSqRt $ PolyBell.fourier curve2), - fourierAnalysisReal 100 (-2,2) $ PolyBell.evaluateSqRt curve2] - - - -fourierAnalysisReal :: - (P.Floating a) => - Integer -> (a, a) -> (a -> Complex.T a) -> a -> a -fourierAnalysisReal n rng f = - liftA2 (P.-) - (Fourier.analysisTransformOneReal n rng (Complex.real . f)) - (Fourier.analysisTransformOneImag n rng (Complex.imag . f)) - - -{- | -Try to approximate @\x -> exp (-x^2) * x@ -by a difference of translated Gaussian bells. - -exp(-x^2) * x - == exp(-(a+b*x+c*x^2)) - exp(-(a-b*x+c*x^2)) - == exp(-(a+c*x^2)) * (exp(-b*x) - exp(b*x)) - == exp(-(a+c*x^2)) * 2*sinh (b*x) - -It holds - lim (\b x -> sinh (b*x) / b) = id --} -diffApprox :: IO () -diffApprox = - let amp = (2*b)^- (-2) - a = 0 - {- - amp = 1 - a = log (2 * abs b) - -} - b = -0.1 - c = 1 - ac = Complex.fromReal a - bc = Complex.fromReal b - in GP.plotFuncs [] - (GP.linearScale 100 (-2,2::Double)) - [Complex.real . - (PolyBell.evaluateSqRt $ - PolyBell.Cons Bell.unit (Poly.fromCoeffs [zero,one])), - Complex.real . - liftA2 (-) - (PolyBell.evaluateSqRt $ - PolyBell.Cons (Bell.Cons amp ac bc c) (Poly.fromCoeffs [one])) - (PolyBell.evaluateSqRt $ - PolyBell.Cons (Bell.Cons amp ac (-bc) c) (Poly.fromCoeffs [one]))] - - -polyApprox :: IO () -polyApprox = - GP.plotFuncs [] - (GP.linearScale 100 (-2,2::Double)) - [Complex.real . - PolyBell.evaluateSqRt curve2, - Complex.real . sum . - mapM (\(amp,b) -> \x -> amp * Bell.evaluateSqRt b x) - (PolyBell.approximateByBells 0.1 curve2)] diff --git a/src-ghc-6.12/MathObj/Gaussian/Polynomial.hs b/src-ghc-6.12/MathObj/Gaussian/Polynomial.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Gaussian/Polynomial.hs +++ /dev/null @@ -1,435 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- -Complex Gaussian bell multiplied with a polynomial. - -In order to make this free of @pi@ factors, -we have to choose @recip (sqrt pi)@ -as unit for translations and modulations, -for linear factors and in the differentiation. --} -{- -ToDo: - -* In order to avoid the weird @sqrt pi@ factor, - use a polynomial expression in @pi@. - -* sum of multiple bells using Data.Map from exponent polynomial to coefficient polynomial - use of Algebra object. - -* Projective geometry in order to support Dirac impulse. --} -module MathObj.Gaussian.Polynomial where - -import qualified MathObj.Gaussian.Bell as Bell - -import qualified MathObj.LaurentPolynomial as LPoly -import qualified MathObj.Polynomial.Core as PolyCore -import qualified MathObj.Polynomial as Poly -import qualified Number.Complex as Complex - -import qualified Algebra.ZeroTestable as ZeroTestable -import qualified Algebra.Differential as Differential -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Field as Field -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive - -import qualified Data.Record.HT as Rec -import qualified Data.List as List -import Data.Function.HT (nest, ) -import Data.Eq.HT (equating, ) -import Data.List.HT (mapAdjacent, ) -import Data.Tuple.HT (forcePair, ) - -import Test.QuickCheck (Arbitrary, arbitrary, ) -import Control.Monad (liftM2, ) - -import NumericPrelude.Numeric -import NumericPrelude.Base hiding (reverse, ) --- import Prelude () - - -data T a = Cons {bell :: Bell.T a, polynomial :: Poly.T (Complex.T a)} - deriving (Show) - -instance (Absolute.C a, Eq a) => Eq (T a) where - (==) = equal - - -{- -Helper data type for 'equal', -that allows to call the (not quite trivial) polynomial equality check. -@RootProduct r a@ represents @sqrt r * a@. -The test using 'signum' works for real numbers, -and I do not know, whether it is correct for other mathematical objects. -However I cannot imagine other mathematical objects, -that make sense at all, here. -Maybe elements of a finite field. --} -data RootProduct a = RootProduct a a - -instance (Absolute.C a, Eq a) => Eq (RootProduct a) where - (RootProduct xr xa) == (RootProduct yr ya) = - let xp = xr*xa^2 - yp = yr*ya^2 - in xp==yp && - (isZero xp || signum xa == signum ya) - -instance (ZeroTestable.C a) => ZeroTestable.C (RootProduct a) where - isZero (RootProduct r a) = isZero r || isZero a - - -{- -The derived Eq is not correct. -We have to combine the amplitude of the bell with the polynomial, -respecting signs and the square root of the bell amplitude. --} -equal :: (Absolute.C a, Eq a) => T a -> T a -> Bool -equal x y = - let bx = bell x - by = bell y - scaleSqr b = - (\p -> - (fmap (RootProduct (Bell.amp b) . Complex.real) p, - fmap (RootProduct (Bell.amp b) . Complex.imag) p)) - . polynomial - in Rec.equal - (equating Bell.c0 : - equating Bell.c1 : - equating Bell.c2 : - []) - bx by - && - scaleSqr bx x == scaleSqr by y - - -instance (Absolute.C a, Arbitrary a) => Arbitrary (T a) where - arbitrary = --- liftM2 Cons arbitrary arbitrary - liftM2 Cons - arbitrary - -- we have to restrict the number of polynomial coefficients, - -- since with the quadratic time algorithms like fourier and convolve, - -- in connection with Rational slow down tests too much. - (fmap (Poly.fromCoeffs . take 5 . Poly.coeffs) arbitrary) - - - -{-# INLINE evaluateSqRt #-} -evaluateSqRt :: (Trans.C a) => - T a -> a -> Complex.T a -evaluateSqRt f x = - Bell.evaluateSqRt (bell f) x * - Poly.evaluate (polynomial f) (Complex.fromReal $ sqrt pi * x) -{- ToDo: evaluating a complex polynomial for a real argument can be optimized -} - - -constant :: (Ring.C a) => T a -constant = - Cons Bell.constant (Poly.const one) - -scale :: (Ring.C a) => a -> T a -> T a -scale x f = - f{polynomial = fmap (Complex.scale x) $ polynomial f} - -scaleComplex :: (Ring.C a) => Complex.T a -> T a -> T a -scaleComplex x f = - f{polynomial = fmap (x*) $ polynomial f} - - -eigenfunction :: (Field.C a) => Int -> T a -eigenfunction = - eigenfunctionDifferential - -eigenfunction0 :: (Ring.C a) => T a -eigenfunction0 = - Cons Bell.unit (Poly.fromCoeffs [one]) - -eigenfunction1 :: (Ring.C a) => T a -eigenfunction1 = - Cons Bell.unit (Poly.fromCoeffs [zero, one]) - -eigenfunction2 :: (Field.C a) => T a -eigenfunction2 = - Cons Bell.unit (Poly.fromCoeffs [-(1/4), zero, one]) - -eigenfunction3 :: (Field.C a) => T a -eigenfunction3 = - Cons Bell.unit (Poly.fromCoeffs [zero, -(3/4), zero, one]) - - -eigenfunctionDifferential :: (Field.C a) => Int -> T a -eigenfunctionDifferential n = - (\f -> f{bell = Bell.unit}) $ - nest n (scale (-1/4) . differentiate) $ - Cons (Bell.Cons one zero zero 2) one - -eigenfunctionIterative :: (Field.C a, Absolute.C a, Eq a) => Int -> T a -eigenfunctionIterative n = - fst . head . dropWhile (uncurry (/=)) . mapAdjacent (,) $ - eigenfunctionIteration $ - Cons - Bell.unit - (Poly.fromCoeffs $ replicate n zero ++ [one]) - -eigenfunctionIteration :: (Field.C a) => T a -> [T a] -eigenfunctionIteration = - iterate (\x -> - let y = fourier x - px = polynomial x - py = polynomial y - c = last (Poly.coeffs px) / last (Poly.coeffs py) - in y{polynomial = fmap (0.5*) (px + fmap (c*) py)}) - - -multiply :: (Ring.C a) => - T a -> T a -> T a -multiply f g = - Cons - (Bell.multiply (bell f) (bell g)) - (polynomial f * polynomial g) - -convolve, {- convolveByDifferentiation, -} convolveByFourier :: (Field.C a) => - T a -> T a -> T a -convolve = convolveByFourier - -{- -f <*> g = - let (foff,fint) = integrate f - in fint <*> differentiate g + makeGaussPoly foff * g - -In principle this would work, -but (makeGaussPoly foff * g) contains a lot of -convolutions of Gaussian with Gaussian-polynomial-product, -where the Gaussians have different parameters. - -convolveByDifferentiation f g = - case polynomial f of - fpoly -> - if null $ Poly.coeffs fpoly - then ... - else ... --} - -convolveByFourier f g = - reverse $ fourier $ multiply (fourier f) (fourier g) - -{- -We use a Horner like scheme -in order to translate multiplications with @id@ -to differentations on the Fourier side. -Quadratic runtime. - -fourier (Cons bell (Poly.const a + Poly.shift f)) - = fourier (Cons bell (Poly.const a)) + fourier (Cons bell (Poly.shift f)) - = fourier (Cons bell (Poly.const a)) + differentiate (fourier (Cons bell f)) --} -fourier :: (Field.C a) => - T a -> T a -fourier f = - foldr - (\c p -> - let q = differentiate p - in q{polynomial = - Poly.const c + - fmap (Complex.scale (1/2) . Complex.quarterLeft) (polynomial q)}) - (Cons (Bell.fourier $ bell f) zero) $ - Poly.coeffs $ polynomial f - -{- | -Differentiate and divide by @sqrt pi@ in order to stay in a ring. -This way, we do not need to fiddle with pi factors. --} -differentiate :: (Ring.C a) => T a -> T a -differentiate f = - f{polynomial = - Differential.differentiate (polynomial f) - - Differential.differentiate (Bell.exponentPolynomial (bell f)) - * polynomial f} - -{- -snd $ integrate $ differentiate (Cons Bell.unit (Poly.fromCoeffs [7,7,7,7]) :: T Double) - -g = (bell f * poly f)' - = bell f * ((poly f)' - (exppoly (bell f))' * poly f) -poly g = (poly f)' - (exppoly (bell f))' * poly f - -Integration means we have g and ask for f. - -poly f = ((poly f)' - poly g) / (exppoly (bell f))' - -However must start with the highest term of 'poly f', -and thus we need to perform the division on reversed polynomials. --} -integrate :: - (Field.C a, ZeroTestable.C a) => - T a -> (Complex.T a, T a) -integrate f = - let fs = Poly.coeffs $ polynomial f - (ys,~[r]) = - PolyCore.divModRev - {- - We need the shortening convention of 'zipWith' - in order to limit the result list, - we cannot use list instance for (-). - -} - (zipWith (-) - (0 : 0 : diffRev ys) - (List.reverse fs)) - (List.reverse $ Poly.coeffs $ - Differential.differentiate $ - Bell.exponentPolynomial $ bell f) - in forcePair $ - if null fs - then (zero, f) - else (r, f{polynomial = Poly.fromCoeffs $ List.reverse ys}) - -diffRev :: Ring.C a => [a] -> [a] -diffRev xs = - zipWith (*) xs - (drop 1 (iterate (subtract 1) (fromIntegral $ length xs))) - -translate :: Ring.C a => a -> T a -> T a -translate d = - translateComplex (Complex.fromReal d) - -translateComplex :: Ring.C a => Complex.T a -> T a -> T a -translateComplex d f = - Cons - (Bell.translateComplex d $ bell f) - (Poly.translate d $ polynomial f) - -modulate :: Ring.C a => a -> T a -> T a -modulate d f = - Cons - (Bell.modulate d $ bell f) - (polynomial f) - -turn :: Ring.C a => a -> T a -> T a -turn d f = - Cons - (Bell.turn d $ bell f) - (polynomial f) - -reverse :: Additive.C a => T a -> T a -reverse f = - Cons - (Bell.reverse $ bell f) - (Poly.reverse $ polynomial f) - -dilate :: Field.C a => a -> T a -> T a -dilate k f = - Cons - (Bell.dilate k $ bell f) - (Poly.dilate (Complex.fromReal k) $ polynomial f) - -shrink :: Ring.C a => a -> T a -> T a -shrink k f = - Cons - (Bell.shrink k $ bell f) - (Poly.shrink (Complex.fromReal k) $ polynomial f) - -{- -We could also amplify the polynomial coefficients. --} -amplify :: Ring.C a => a -> T a -> T a -amplify k f = - Cons - (Bell.amplify k $ bell f) - (polynomial f) - - -{- | -Approximate a @T a@ using a linear combination of translated @Bell.T a@. -The smaller the unit (e.g. 0.1, 0.01, 0.001) -the better the approximation but the worse the numeric properties. - -We cannot put all information into @amp@ of @Bell@, -since @amp@ must be real, but is complex here by construction. -We really need at least signed amplitudes at this place, -since we want to represent differences of Gaussians. --} -approximateByBells :: - Field.C a => - a -> T a -> [(Complex.T a, Bell.T a)] -approximateByBells unit f = - let b = bell f - amps = - -- approximateByBellsByTranslation - approximateByBellsAtOnce - unit - (Complex.scale (recip (2 * Bell.c2 b)) (Bell.c1 b)) - (recip (2*unit*Bell.c2 b)) - (polynomial f) - in zip (LPoly.coeffs amps) $ - map - (\d -> Bell.translate d b) - (laurentAbscissas (unit/2) amps) - -approximateByBellsAtOnce :: - Field.C a => - a -> Complex.T a -> a -> Poly.T (Complex.T a) -> LPoly.T (Complex.T a) -approximateByBellsAtOnce unit d s p = - foldr - (\x amps0 -> - {- - Decompose (bell t * (t-d)) = bell t * t - bell t * d - -} - let y = fmap (Complex.scale s) amps0 - in -- \t -> bell t * t - -- ~ (translate unit bell - translate (-unit) bell) / unit - LPoly.shift 1 y - - LPoly.shift (-1) y + - -- bell t * d - zipWithAbscissas - (\t z -> (Complex.fromReal t - d) * z) - (unit/2) amps0 + - LPoly.const x) - (LPoly.fromCoeffs []) - (Poly.coeffs p) - -approximateByBellsByTranslation :: - Field.C a => - a -> Complex.T a -> a -> Poly.T (Complex.T a) -> LPoly.T (Complex.T a) -approximateByBellsByTranslation unit d s p = - foldr - (\x amps0 -> - {- - Decompose (bell t * (t-d)) = bell t * t - bell t * d - -} - let y = fmap (Complex.scale s) amps0 - in -- \t -> bell t * t - -- ~ (translate unit bell - translate (-unit) bell) / unit - LPoly.shift 1 y - - LPoly.shift (-1) y + - -- bell t * d - zipWithAbscissas Complex.scale (unit/2) amps0 + - LPoly.const x) - (LPoly.fromCoeffs []) - (Poly.coeffs $ Poly.translate d p) - -zipWithAbscissas :: - (Ring.C a) => - (a -> b -> c) -> a -> LPoly.T b -> LPoly.T c -zipWithAbscissas h unit y = - LPoly.fromShiftCoeffs (LPoly.expon y) $ - zipWith h - (laurentAbscissas unit y) - (LPoly.coeffs y) - -laurentAbscissas :: Ring.C a => a -> LPoly.T c -> [a] -laurentAbscissas unit = - map (\d -> fromIntegral d * unit) . - iterate (1+) . LPoly.expon - - -{- No Ring instance for Gaussians -instance (Ring.C a) => Differential.C (T a) where - differentiate = differentiate --} - -{- laws -differentiate (f*g) = - (differentiate f) * g + f * (differentiate g) --} diff --git a/src-ghc-6.12/MathObj/Gaussian/Variance.hs b/src-ghc-6.12/MathObj/Gaussian/Variance.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Gaussian/Variance.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- -We represent a Gaussian bell curve in terms of the reciprocal of its variance -and its value at the origin. - -We could do some projective geometry in the exponent -in order to also have zero variance, -which corresponds to the dirac impulse. --} -module MathObj.Gaussian.Variance where - -import qualified MathObj.Polynomial as Poly -import qualified Number.Root as Root - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive - -{- -import Algebra.Transcendental (pi, ) -import Algebra.Ring ((*), (^), ) -import Algebra.Additive ((+)) --} -import Test.QuickCheck (Arbitrary, arbitrary, ) -import Control.Monad (liftM2, ) - --- import Prelude (($)) -import NumericPrelude.Numeric -import NumericPrelude.Base - - -{- | -Since @amp@ is the square of the actual amplitude it must be non-negative. --} -data T a = Cons {amp, c :: a} - deriving (Eq, Show) - -instance (Absolute.C a, Arbitrary a) => Arbitrary (T a) where - arbitrary = - liftM2 Cons - (fmap abs arbitrary) - (fmap ((1+) . abs) arbitrary) - - -constant :: Ring.C a => T a -constant = Cons one zero - -{-# INLINE evaluate #-} -evaluate :: (Trans.C a) => - T a -> a -> a -evaluate f x = - sqrt (amp f) * exp (-pi * c f * x^2) - -exponentPolynomial :: (Additive.C a) => - T a -> Poly.T a -exponentPolynomial f = - Poly.fromCoeffs [zero, zero, c f] - - -integrateRoot :: (Field.C a) => T a -> Root.T a -integrateRoot f = - Root.sqrt $ Root.fromNumber $ amp f / c f - -scalarProductRoot :: (Field.C a) => T a -> T a -> Root.T a -scalarProductRoot f g = - integrateRoot (multiply f g) - - -norm1Root :: (Field.C a) => T a -> Root.T a -norm1Root = integrateRoot - -norm2Root :: (Field.C a) => T a -> Root.T a -norm2Root f = - Root.sqrt $ - Root.fromNumber (amp f) - `Root.div` - Root.sqrt (Root.fromNumber $ 2 * c f) - -normInfRoot :: (Field.C a) => T a -> Root.T a -normInfRoot f = - Root.sqrt $ Root.fromNumber $ amp f - -normPRoot :: (Field.C a) => Rational -> T a -> Root.T a -normPRoot p f = - Root.sqrt (Root.fromNumber (amp f)) - `Root.div` - Root.rationalPower (recip (2*p)) (Root.fromNumber (fromRational' p * c f)) - - -norm1 :: (Algebraic.C a) => T a -> a -norm1 f = - sqrt $ amp f / c f - -norm2 :: (Algebraic.C a) => T a -> a -norm2 f = - sqrt $ amp f / (sqrt $ 2 * c f) - -normInf :: (Algebraic.C a) => T a -> a -normInf f = - sqrt (amp f) - -normP :: (Trans.C a) => a -> T a -> a -normP p f = - sqrt (amp f) * (p * c f) ^? (- recip (2*p)) - - -variance :: (Trans.C a) => - T a -> a -variance f = - recip $ c f * 2*pi - -multiply :: (Ring.C a) => - T a -> T a -> T a -multiply f g = - Cons (amp f * amp g) (c f + c g) - -powerRing :: (Trans.C a) => - Integer -> T a -> T a -powerRing p f = - Cons (amp f ^ p) (fromInteger p * c f) - -{- -powerField does not makes sense, -since the reciprocal of a Gaussian diverges. --} - -powerAlgebraic :: (Trans.C a) => - Rational -> T a -> T a -powerAlgebraic p f = - Cons (amp f ^/ p) (fromRational' p * c f) - -powerTranscendental :: (Trans.C a) => - a -> T a -> T a -powerTranscendental p f = - Cons (amp f ^? p) (p * c f) - -{- | -> convolve x y t = -> integrate $ \s -> x s * y(t-s) - -Convergence only for @c f + c g > 0@. --} -convolve :: (Field.C a) => - T a -> T a -> T a -convolve f g = - let s = c f + c g - in Cons - (amp f * amp g / s) - (c f * c g / s) - -{- | -> fourier x f = -> integrate $ \t -> x t * cis (-2*pi*t*f) - -Convergence only for @c f > 0@. --} -fourier :: (Field.C a) => - T a -> T a -fourier f = - Cons (amp f / c f) (recip $ c f) -{- -fourier (t -> exp(-(a*t)^2)) --} - -dilate :: (Field.C a) => a -> T a -> T a -dilate k f = - Cons (amp f) $ c f / k^2 - -shrink :: (Ring.C a) => a -> T a -> T a -shrink k f = - Cons (amp f) $ c f * k^2 - -{- | -@amplify k@ scales by @abs k@! --} -amplify :: (Ring.C a) => a -> T a -> T a -amplify k f = - Cons (k^2 * amp f) $ c f - - -{- laws -fourier (convolve f g) = multiply (fourier f) (fourier g) - -dilate k (dilate m f) = dilate (k*m) f - -dilate k (shrink k f) = f - -variance (dilate k f) = k^2 * variance f - -variance (convolve f g) = variance f + variance g --} diff --git a/src-ghc-6.12/MathObj/LaurentPolynomial.hs b/src-ghc-6.12/MathObj/LaurentPolynomial.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/LaurentPolynomial.hs +++ /dev/null @@ -1,288 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- | -Copyright : (c) Henning Thielemann 2004-2006 - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : requires multi-parameter type classes - -Polynomials with negative and positive exponents. --} -module MathObj.LaurentPolynomial where - -import qualified MathObj.Polynomial as Poly -import qualified MathObj.PowerSeries as PS -import qualified MathObj.PowerSeries.Core as PSCore - -import qualified Algebra.VectorSpace as VectorSpace -import qualified Algebra.Module as Module -import qualified Algebra.Vector as Vector -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import qualified Number.Complex as Complex - -import Algebra.Module((*>)) - -import qualified NumericPrelude.Base as P -import qualified NumericPrelude.Numeric as NP - -import NumericPrelude.Base hiding (const, reverse, ) -import NumericPrelude.Numeric hiding (div, negate, ) - -import qualified Data.List as List -import Data.List.HT (mapAdjacent) - - -{- | Polynomial including negative exponents -} - -data T a = Cons {expon :: Int, coeffs :: [a]} - - -{- * Basic Operations -} - -const :: a -> T a -const x = fromCoeffs [x] - -(!) :: Additive.C a => T a -> Int -> a -(!) (Cons xt x) n = - if n T a -fromCoeffs = fromShiftCoeffs 0 - -fromShiftCoeffs :: Int -> [a] -> T a -fromShiftCoeffs = Cons - -fromPolynomial :: Poly.T a -> T a -fromPolynomial = fromCoeffs . Poly.coeffs - -fromPowerSeries :: PS.T a -> T a -fromPowerSeries = fromCoeffs . PS.coeffs - -bounds :: T a -> (Int, Int) -bounds (Cons xt x) = (xt, xt + length x - 1) - -shift :: Int -> T a -> T a -shift t (Cons xt x) = Cons (xt+t) x - -{-# DEPRECATED translate "In order to avoid confusion with Polynomial.translate, use 'shift' instead" #-} -translate :: Int -> T a -> T a -translate = shift - - -instance Functor T where - fmap f (Cons xt xs) = Cons xt (map f xs) - - -{- * Show -} - -appPrec :: Int -appPrec = 10 - -instance (Show a) => Show (T a) where - showsPrec p (Cons xt xs) = - showParen (p >= appPrec) - (showString "LaurentPolynomial.Cons " . shows xt . - showString " " . shows xs) - -{- * Additive -} - -add :: Additive.C a => T a -> T a -> T a -add (Cons _ []) y = y -add x (Cons _ []) = x -add (Cons xt x) (Cons yt y) = - if xt < yt - then Cons xt (addShifted (yt-xt) x y) - else Cons yt (addShifted (xt-yt) y x) - -{- -Compute the value of a series of Laurent polynomials. - -Requires that the start exponents constitute a (weakly) rising sequence, -where each exponent occurs only finitely often. - -Cf. Synthesizer.Cut.arrange --} -series :: (Additive.C a) => [T a] -> T a -series [] = fromCoeffs [] -series ps = - let es = map expon ps - xs = map coeffs ps - ds = mapAdjacent subtract es - in Cons (head es) (addShiftedMany ds xs) - -{- | -Add lists of numbers respecting a relative shift between the starts of the lists. -The shifts must be non-negative. -The list of relative shifts is one element shorter -than the list of summands. -Infinitely many summands are permitted, -provided that runs of zero shifts are all finite. - - -We could add the lists either with 'foldl' or with 'foldr', -'foldl' would be straightforward, but more time consuming (quadratic time) -whereas foldr is not so obvious but needs only linear time. - -(stars denote the coefficients, - frames denote what is contained in the interim results) -'foldl' sums this way: - -> | | | ******************************* -> | | +-------------------------------- -> | | ************************ -> | +---------------------------------- -> | ************ -> +------------------------------------ - -I.e. 'foldl' would use much time find the time differences -by successive subtraction 1. - -'foldr' mixes this way: - -> +-------------------------------- -> | ******************************* -> | +------------------------- -> | | ************************ -> | | +------------- -> | | | ************ - --} -addShiftedMany :: (Additive.C a) => [Int] -> [[a]] -> [a] -addShiftedMany ds xss = - foldr (uncurry addShifted) [] (zip (ds++[0]) xss) - - - -addShifted :: Additive.C a => Int -> [a] -> [a] -> [a] -addShifted del px py = - let recurse 0 x = PSCore.add x py - recurse d [] = replicate d zero ++ py - recurse d (x:xs) = x : recurse (d-1) xs - in if del >= 0 - then recurse del px - else error "LaurentPolynomial.addShifted: negative shift" - - -negate :: Additive.C a => T a -> T a -negate (Cons xt x) = Cons xt (map NP.negate x) - -sub :: Additive.C a => T a -> T a -> T a -sub x y = add x (negate y) - -instance Additive.C a => Additive.C (T a) where - zero = fromCoeffs [] - (+) = add - (-) = sub - negate = negate - - -{- * Module -} - -instance Vector.C T where - zero = zero - (<+>) = (+) - (*>) = Vector.functorScale - -instance (Module.C a b) => Module.C a (T b) where - x *> Cons yt ys = Cons yt (x *> ys) - -instance (Field.C a, Module.C a b) => VectorSpace.C a (T b) - - -{- * Ring -} - -mul :: Ring.C a => T a -> T a -> T a -mul (Cons xt x) (Cons yt y) = Cons (xt+yt) (PSCore.mul x y) - -instance (Ring.C a) => Ring.C (T a) where - one = const one - fromInteger n = const (fromInteger n) - (*) = mul - - -{- * Field.C -} - -div :: (Field.C a, ZeroTestable.C a) => T a -> T a -> T a -div (Cons xt xs) (Cons yt ys) = - let (xzero,x) = span isZero xs - (yzero,y) = span isZero ys - in Cons (xt - yt + length xzero - length yzero) - (PSCore.divide x y) - -instance (Field.C a, ZeroTestable.C a) => Field.C (T a) where - (/) = div - -divExample :: T NP.Rational -divExample = div (Cons 1 [0,0,1,2,1]) (Cons 1 [0,0,0,1,1]) - - - - -{- * Comparisons -} - -{- | -Two polynomials may be stored differently. -This function checks whether two values of type @LaurentPolynomial@ -actually represent the same polynomial. --} -equivalent :: (Eq a, ZeroTestable.C a) => T a -> T a -> Bool -equivalent xs ys = - let (Cons xt x, Cons yt y) = - if expon xs <= expon ys - then (xs,ys) - else (ys,xs) - (xPref, xSuf) = splitAt (yt-xt) x - aux (a:as) (b:bs) = a == b && aux as bs - aux [] bs = all isZero bs - aux as [] = all isZero as - in all isZero xPref && aux xSuf y - -instance (Eq a, ZeroTestable.C a) => Eq (T a) where - (==) = equivalent - - -identical :: (Eq a) => T a -> T a -> Bool -identical (Cons xt xs) (Cons yt ys) = - xt==yt && xs == ys - - -{- | -Check whether a Laurent polynomial has only the absolute term, -that is, it represents the constant polynomial. --} -isAbsolute :: (ZeroTestable.C a) => T a -> Bool -isAbsolute (Cons xt x) = - and (zipWith (\i xi -> isZero xi || i==0) [xt..] x) - - - -{- * Transformations of arguments -} - -{- | p(z) -> p(-z) -} -alternate :: Additive.C a => T a -> T a -alternate (Cons xt x) = - Cons xt (zipWith id (drop (mod xt 2) (cycle [id,NP.negate])) x) - -{- | p(z) -> p(1\/z) -} -reverse :: T a -> T a -reverse (Cons xt x) = - Cons (1 - xt - length x) (List.reverse x) - -{- | -p(exp(i·x)) -> conjugate(p(exp(i·x))) - -If you interpret @(p*)@ as a linear operator on the space of Laurent polynomials, -then @(adjoint p *)@ is the adjoint operator. --} -adjoint :: Additive.C a => T (Complex.T a) -> T (Complex.T a) -adjoint x = - let (Cons yt y) = reverse x - in (Cons yt (map Complex.conjugate y)) diff --git a/src-ghc-6.12/MathObj/Matrix.hs b/src-ghc-6.12/MathObj/Matrix.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Matrix.hs +++ /dev/null @@ -1,278 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- | -Copyright : (c) Henning Thielemann 2009, Mikael Johansson 2006 -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : requires multi-parameter type classes - -Routines and abstractions for Matrices and -basic linear algebra over fields or rings. - -We stick to simple Int indices. -Although advanced indices would be nice -e.g. for matrices with sub-matrices, -this is not easily implemented since arrays -do only support a lower and an upper bound -but no additional parameters. - -ToDo: - - Matrix inverse, determinant --} - -module MathObj.Matrix ( - T, Dimension, - format, - transpose, - rows, - columns, - index, - fromRows, - fromColumns, - fromList, - dimension, - numRows, - numColumns, - zipWith, - zero, - one, - diagonal, - scale, - random, - randomR, - ) where - -import qualified Algebra.Module as Module -import qualified Algebra.Vector as Vector -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive - -import Algebra.Module((*>), ) -import Algebra.Ring((*), fromInteger, scalarProduct, ) -import Algebra.Additive((+), (-), subtract, ) - -import qualified System.Random as Rnd -import Data.Array (Array, array, listArray, accumArray, elems, bounds, (!), ixmap, range, ) -import qualified Data.List as List - -import Control.Monad (liftM2, ) -import Control.Exception (assert, ) - -import Data.Function.HT (powerAssociative, ) -import Data.Tuple.HT (swap, mapFst, ) -import Data.List.HT (outerProduct, ) -import Text.Show.HT (concatS, ) - -import NumericPrelude.Numeric (Int, ) -import NumericPrelude.Base hiding (zipWith, ) - - -{- | -A matrix is a twodimensional array, indexed by integers. --} -data T a = - Cons (Array (Dimension, Dimension) a) - deriving (Eq,Ord,Read) - -type Dimension = Int - -{- | -Transposition of matrices is just transposition in the sense of Data.List. --} -transpose :: T a -> T a -transpose (Cons m) = - let (lower,upper) = bounds m - in Cons (ixmap (swap lower, swap upper) swap m) - -rows :: T a -> [[a]] -rows mM@(Cons m) = - let ((lr,lc), (ur,uc)) = bounds m - in outerProduct (index mM) (range (lr,ur)) (range (lc,uc)) - -columns :: T a -> [[a]] -columns mM@(Cons m) = - let ((lr,lc), (ur,uc)) = bounds m - in outerProduct (flip (index mM)) (range (lc,uc)) (range (lr,ur)) - -index :: T a -> Dimension -> Dimension -> a -index (Cons m) i j = m ! (i,j) - -fromRows :: Dimension -> Dimension -> [[a]] -> T a -fromRows m n = - Cons . - array (indexBounds m n) . - concat . - List.zipWith (\r -> map (\(c,x) -> ((r,c),x))) allIndices . - map (zip allIndices) - -fromColumns :: Dimension -> Dimension -> [[a]] -> T a -fromColumns m n = - Cons . - array (indexBounds m n) . - concat . - List.zipWith (\r -> map (\(c,x) -> ((c,r),x))) allIndices . - map (zip allIndices) - -fromList :: Dimension -> Dimension -> [a] -> T a -fromList m n xs = Cons (listArray (indexBounds m n) xs) - -appPrec :: Int -appPrec = 10 - -instance (Show a) => Show (T a) where - showsPrec p m = - showParen (p >= appPrec) - (showString "Matrix.fromRows " . showsPrec appPrec (rows m)) - -format :: (Show a) => T a -> String -format m = formatS m "" - -formatS :: (Show a) => T a -> ShowS -formatS = - concatS . - map (\r -> showString "(" . concatS r . showString ")\n") . - map (List.intersperse (' ':) . map (showsPrec 11)) . - rows - -dimension :: T a -> (Dimension,Dimension) -dimension (Cons m) = uncurry subtract (bounds m) + (1,1) - -numRows :: T a -> Dimension -numRows = fst . dimension - -numColumns :: T a -> Dimension -numColumns = snd . dimension - --- These implementations may benefit from a better exception than --- just assertions to validate dimensionalities -instance (Additive.C a) => Additive.C (T a) where - (+) = zipWith (+) - (-) = zipWith (-) - zero = zero 1 1 - -zipWith :: (a -> b -> c) -> T a -> T b -> T c -zipWith op mM@(Cons m) nM@(Cons n) = - let d = dimension mM - em = elems m - en = elems n - in assert (d == dimension nM) $ - uncurry fromList d (List.zipWith op em en) - -zero :: (Additive.C a) => Dimension -> Dimension -> T a -zero m n = - fromList m n $ - List.repeat Additive.zero --- List.replicate (fromInteger (m*n)) zero - -one :: (Ring.C a) => Dimension -> T a -one n = - Cons $ - accumArray (flip const) Additive.zero - (indexBounds n n) - (map (\i -> ((i,i), Ring.one)) (indexRange n)) - -diagonal :: (Additive.C a) => [a] -> T a -diagonal xs = - let n = List.length xs - in Cons $ - accumArray (flip const) Additive.zero - (indexBounds n n) - (zip (map (\i -> (i,i)) allIndices) xs) - -scale :: (Ring.C a) => a -> T a -> T a -scale s = Vector.functorScale s - -instance (Ring.C a) => Ring.C (T a) where - mM * nM = - assert (numColumns mM == numRows nM) $ - fromList (numRows mM) (numColumns nM) $ - liftM2 scalarProduct (rows mM) (columns nM) - fromInteger n = fromList 1 1 [fromInteger n] - mM ^ n = - assert (numColumns mM == numRows mM) $ - assert (n >= Additive.zero) $ - powerAssociative (*) (one (numColumns mM)) mM n - -instance Functor T where - fmap f (Cons m) = Cons (fmap f m) - -instance Vector.C T where - zero = Additive.zero - (<+>) = (+) - (*>) = scale - -instance Module.C a b => Module.C a (T b) where - x *> m = fmap (x*>) m - - -random :: (Rnd.RandomGen g, Rnd.Random a) => - Dimension -> Dimension -> g -> (T a, g) -random = - randomAux Rnd.random - -randomR :: (Rnd.RandomGen g, Rnd.Random a) => - Dimension -> Dimension -> (a,a) -> g -> (T a, g) -randomR m n rng = - randomAux (Rnd.randomR rng) m n - -{- -could be made nicer with the State monad, -but I like to keep dependencies minimal --} -randomAux :: (Rnd.RandomGen g, Rnd.Random a) => - (g -> (a,g)) -> Dimension -> Dimension -> g -> (T a, g) -randomAux rnd m n g0 = - mapFst (fromList m n) $ swap $ - List.mapAccumL (\g _i -> swap $ rnd g) g0 (indexRange (m*n)) - -{- -What more do we need from our matrix type? We have addition, -subtraction and multiplication, and thus composition of generic -free-module-maps. We're going to want to solve linear equations with -or without fields underneath, so we're going to want an implementation -of the Gaussian algorithm as well as most probably Smith normal -form. Determinants are cool, and these are to be calculated either -with the Gaussian algorithm or some other goodish method. --} - -{- -{- | - We'll want generic linear equation solving, returning one solution, -any solution really, or nothing. Basically, this is asking for the -preimage of a given vector over the given map, so - -a_11 x_1 + .. + a_1n x_n = y_1 - ... -a_m1 x_1 + .. + a_mn a_n = y_m - -has really x_1,...,x_n as a preimage of the vector y_1,..,y_m under -the map (a_ij), since obviously y_1,..,y_m = (a_ij) x_1,..,x_n - -So, generic linear equation solving boils down to the function --} -preimage :: (Ring.C a) => T a -> T a -> Maybe (T a) -preimage a y = assert - (numRows a == numRows y && -- they match - numColumns y == 1) -- and y is a column vector - Nothing --} - -{- -Cf. /usr/lib/hugs/demos/Matrix.hs --} - - --- these functions control whether we use 0 or 1 based indices - -indexRange :: Dimension -> [Dimension] -indexRange n = [0..(n-1)] - -indexBounds :: - Dimension -> Dimension -> - ((Dimension,Dimension), (Dimension,Dimension)) -indexBounds m n = - ((0,0), (m-1,n-1)) - -allIndices :: [Dimension] -allIndices = [0..] diff --git a/src-ghc-6.12/MathObj/Monoid.hs b/src-ghc-6.12/MathObj/Monoid.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Monoid.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module MathObj.Monoid where - -import qualified Algebra.PrincipalIdealDomain as PID - -import Algebra.PrincipalIdealDomain (gcd, lcm, ) -import Algebra.Additive (zero, ) -import Algebra.Monoid (C, idt, (<*>), ) - -import NumericPrelude.Base - -{- | -It is only a monoid for non-negative numbers. - -> idt <*> GCD (-2) = GCD 2 - -Thus, use this Monoid only for non-negative numbers! --} -newtype GCD a = GCD {runGCD :: a} - deriving (Show, Eq) - -instance PID.C a => C (GCD a) where - idt = GCD zero - (GCD x) <*> (GCD y) = GCD (gcd x y) - - -newtype LCM a = LCM {runLCM :: a} - deriving (Show, Eq) - -instance PID.C a => C (LCM a) where - idt = LCM zero - (LCM x) <*> (LCM y) = LCM (lcm x y) - - -{- | -@Nothing@ is the largest element. --} -newtype Min a = Min {runMin :: Maybe a} - deriving (Show, Eq) - -instance Ord a => C (Min a) where - idt = Min Nothing - (Min x) <*> (Min y) = Min $ - maybe y (\x' -> maybe x (Just . min x') y) x - - -{- | -@Nothing@ is the smallest element. --} -newtype Max a = Max {runMax :: Maybe a} - deriving (Show, Eq) - -instance Ord a => C (Max a) where - idt = Max Nothing - (Max x) <*> (Max y) = Max $ - maybe y (\x' -> maybe x (Just . max x') y) x diff --git a/src-ghc-6.12/MathObj/PartialFraction.hs b/src-ghc-6.12/MathObj/PartialFraction.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/PartialFraction.hs +++ /dev/null @@ -1,399 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2007 -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable - -Implementation of partial fractions. -Useful e.g. for fractions of integers and fractions of polynomials. - -For the considered ring the prime factorization must be unique. --} - -module MathObj.PartialFraction where - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.IntegralDomain as Integral -import qualified Number.Ratio as Ratio -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable -import qualified Algebra.Indexable as Indexable - -import Number.Ratio((%)) -import Algebra.IntegralDomain(divMod, divModZero, decomposeVarPositionalInf) -import Algebra.Units(stdAssociate, stdUnitInv) -import Algebra.Field((/)) -import Algebra.Ring((*), one, product) -import Algebra.Additive((+), zero, negate) -import Algebra.ZeroTestable (isZero) - -import qualified Data.List as List - -import Data.Map(Map) -import qualified Data.Map as Map -import Data.Maybe(fromMaybe, ) -import qualified Data.List.Match as Match -import Data.List.HT (dropWhileRev, ) -import Data.List (group, sortBy, mapAccumR, ) - -import NumericPrelude.Base hiding (zipWith) - -import NumericPrelude.Numeric(Int, fromInteger) - - - -{- | -@Cons z (indexMapFromList [(x0,[y00,y01]), (x1,[y10]), (x2,[y20,y21,y22])])@ -represents the partial fraction -@z + y00/x0 + y01/x0^2 + y10/x1 + y20/x2 + y21/x2^2 + y22/x2^3@ -The denominators @x0, x1, x2, ...@ must be irreducible, -but we can't check this in general. -It is also not enough to have relatively prime denominators, -because when adding two partial fraction representations -there might concur denominators that have non-trivial common divisors. --} -data T a = - Cons a (Map (Indexable.ToOrd a) [a]) - deriving (Eq) - -{- | -Unchecked construction. --} -fromFractionSum :: (Indexable.C a) => a -> [(a,[a])] -> T a -fromFractionSum z m = - Cons z (indexMapFromList m) - -toFractionSum :: (Indexable.C a) => T a -> (a, [(a,[a])]) -toFractionSum (Cons z m) = - (z, indexMapToList m) - -appPrec :: Int -appPrec = 10 - -instance (Show a) => Show (T a) where - showsPrec p (Cons z m) = - showParen (p >= appPrec) - (showString "PartialFraction.fromFractionSum " . - showsPrec (succ appPrec) z . showString " " . - shows (indexMapToList m)) - - -toFraction :: PID.C a => T a -> Ratio.T a -toFraction (Cons z m) = - let fracs = map (uncurry multiToFraction) (indexMapToList m) - in foldl (+) (Ratio.fromValue z) fracs - -{- | -'PrincipalIdealDomain.C' is not really necessary here and -only due to invokation of 'toFraction'. --} -toFactoredFraction :: (PID.C a) => T a -> ([a], a) -toFactoredFraction x@(Cons _ m) = - let r = toFraction x - denoms = concat $ Map.elems $ indexMapMapWithKey (flip Match.replicate) m - numer = foldl (flip Ratio.scale) r denoms - {- From the theory it must be Ratio.denominator denom==1. - We could check this dynamically, if there would be an Eq instance. - We could omit this completely, - if we would reimplement Ratio addition. -} - in (denoms, Ratio.numerator numer) - -{- | -'PrincipalIdealDomain.C' is not really necessary here and -only due to invokation of 'Ratio.%'. --} -multiToFraction :: PID.C a => a -> [a] -> Ratio.T a -multiToFraction denom = - foldr (\numer acc -> - (Ratio.fromValue numer + acc) / Ratio.fromValue denom) zero - -hornerRev :: Ring.C a => a -> [a] -> a -hornerRev x = foldl (\val c -> val*x+c) zero - - -{- | -@fromFactoredFraction x y@ -computes the partial fraction representation of @y % product x@, -where the elements of @x@ must be irreducible. -The function transforms the factors into their standard form -with respect to unit factors. - -There are more direct methods for special cases -like polynomials over rational numbers -where the denominators are linear factors. --} -fromFactoredFraction :: (PID.C a, Indexable.C a) => [a] -> a -> T a -fromFactoredFraction denoms0 numer0 = - let denoms = group $ sortBy Indexable.compare $ map stdAssociate denoms0 - numer = foldl (*) numer0 $ map stdUnitInv denoms0 - denomPowers = map product denoms - {- since the sub-lists contain the same value, - the products are powers, - which could be computed more efficiently -} - partProdLeft = scanl (*) one denomPowers - (prod:partProdRight) = scanr (*) one denomPowers - (intPart,numerRed) = divMod numer prod - facs = List.zipWith (*) partProdLeft partProdRight - numers = - fromMaybe - (error $ "PartialFraction.fromFactoredFraction: " ++ - "denominators must be relatively prime") - (PID.diophantineMulti numerRed facs) - pairs = List.zipWith multiFromFraction denoms numers - -- Is reduceHeads also necessary for polynomial partial fractions? - in removeZeros $ reduceHeads $ Cons intPart (indexMapFromList pairs) - -fromFactoredFractionAlt :: (PID.C a, Indexable.C a) => [a] -> a -> T a -fromFactoredFractionAlt denoms numer = - foldl (\p d -> scaleFrac (one%d) p) (fromValue numer) denoms - -{- | -The list of denominators must contain equal elements. -Sorry for this hack. --} -multiFromFraction :: PID.C a => [a] -> a -> (a,[a]) -multiFromFraction (d:ds) n = - (d, reverse $ decomposeVarPositionalInf ds n) -multiFromFraction [] _ = - error "PartialFraction.multiFromFraction: there must be one denominator" - -fromValue :: a -> T a -fromValue x = Cons x Map.empty - - -{- | -A normalization step which separates the integer part -from the leading fraction of each sub-list. --} -reduceHeads :: Integral.C a => T a -> T a -reduceHeads (Cons z m0) = - let m1 = indexMapMapWithKey (\x (y:ys) -> let (q,r) = divMod y x in (q,r:ys)) m0 - in Cons - (foldl (+) z (map fst $ Map.elems m1)) - (fmap snd m1) - -{- | -Cf. Number.Positional --} -carryRipple :: Integral.C a => a -> [a] -> (a,[a]) -carryRipple b = - mapAccumR (\carry y -> divMod (y+carry) b) zero - - -{- | -A normalization step which reduces all elements in sub-lists -modulo their denominators. -Zeros might be the result, that must be remove with 'removeZeros'. --} -normalizeModulo :: Integral.C a => T a -> T a -normalizeModulo (Cons z0 m0) = - let m1 = indexMapMapWithKey carryRipple m0 - -- would be nice to have a Map.unzip function - ints = Map.elems $ fmap fst m1 - in Cons (foldl (+) z0 ints) (fmap snd m1) - - - -{- | -Remove trailing zeros in sub-lists -because if lists are converted to fractions by 'multiToFraction' -we must be sure that the denominator of the (cancelled) fraction -is indeed the stored power of the irreducible denominator. -Otherwise 'mulFrac' leads to wrong results. --} -removeZeros :: (Indexable.C a, ZeroTestable.C a) => T a -> T a -removeZeros (Cons z m) = - Cons z $ - Map.filter (not . null) $ - Map.map (dropWhileRev isZero) m - - -{- -instance Functor (T a) where - fmap f (Cons x) = Cons (fmap f x) --} - -zipWith :: (Indexable.C a) => (a -> a -> a) -> ([a] -> [a] -> [a]) -> - (T a -> T a -> T a) -zipWith opS opV (Cons za ma) (Cons zb mb) = - Cons (opS za zb) (Map.unionWith opV ma mb) - -instance (Indexable.C a, Integral.C a, ZeroTestable.C a) => Additive.C (T a) where - a + b = removeZeros $ normalizeModulo $ zipWith (+) (+) a b - {- This implementation is attracting but wrong. - It fails if terms are present in b that are missing in a. - Default implementation is better here. - a - b = removeZeros $ normalizeModulo $ zipWith (-) (-) a b - -} - negate (Cons z m) = Cons (negate z) (fmap negate m) - zero = fromValue zero - -{- | -Transforms a product of two partial fractions -into a sum of two fractions. -The denominators must be at least relatively prime. -Since 'T' requires irreducible denominators, -these are also relatively prime. - -Example: @mulFrac (1%6) (1%4)@ fails because of the common divisor @2@. --} -mulFrac :: (PID.C a) => Ratio.T a -> Ratio.T a -> (a, a) -mulFrac x y = - let dx = Ratio.denominator x - dy = Ratio.denominator y - in fromMaybe - (error "PartialFraction.mulFrac: denominators must be relatively prime") - (PID.diophantine (Ratio.numerator x * Ratio.numerator y) dy dx) - -{- -nx/dx * ny/dy = a/dx + b/dy -nx*ny = a*dy + b*dx --} - -mulFrac' :: (PID.C a) => Ratio.T a -> Ratio.T a -> (Ratio.T a, Ratio.T a) -mulFrac' x y = - let (na,nb) = mulFrac x y - in (na % Ratio.denominator x, nb % Ratio.denominator y) - -{- -Also works if the operands share a non-trivial divisor. - -mulFracOverlap :: (PID.C a) => - Ratio.T a -> Ratio.T a -> ((Ratio.T a, Ratio.T a), Ratio.T a) -mulFracOverlap x y = - let dx = Ratio.denominator x - dy = Ratio.denominator y - (g,(a0,b0)) = extendedGCD dy dx - (q,r) = divModZero (Ratio.numerator x * Ratio.numerator y) g - in if (isZero r) - then ((q*a, q*b), zero) - else - let fx = divChecked dx g - fy = divChecked dy g - (g,(k,c)) = extendedGCD (g^2) (fx*fy) - -given dx=fx*g and dy=fy*g with fx and fy are relatively prime: -nx/(g*fx) * ny/(g*fy) = a/fx + b/fy + c/g^2 -nx*ny = a*fy*g^2 + b*fx*g^2 + c*fx*fy - = a*dy*g + b*dx*g + c*fx*fy -a0*dy + b0*dx = g -a=a0*k -b=b0*k - -This approach does still fail on 1%2 * 1%4. --} - -{- | -Works always but simply puts the product into the last fraction. --} -mulFracStupid :: (PID.C a) => - Ratio.T a -> Ratio.T a -> ((Ratio.T a, Ratio.T a), Ratio.T a) -mulFracStupid x y = - let dx = Ratio.denominator x - dy = Ratio.denominator y - [a,b,c] = - fromMaybe - (error "PartialFraction.mulFracOverlap: (gcd 1 x) must always be a unit") - (PID.diophantineMulti - (Ratio.numerator x * Ratio.numerator y) [dy, dx, one]) - in ((a % dx, b % dy), c%(dx*dy)) - -{- | -Also works if the operands share a non-trivial divisor. -However the results are quite arbitrary. --} -mulFracOverlap :: (PID.C a) => - Ratio.T a -> Ratio.T a -> ((Ratio.T a, Ratio.T a), Ratio.T a) -mulFracOverlap x y = - let dx = Ratio.denominator x - dy = Ratio.denominator y - nx = Ratio.numerator x - ny = Ratio.numerator y - (g,(a,b)) = PID.extendedGCD dy dx - (q,r) = divModZero (nx*ny) g - in (((q*a)%dx, (q*b)%dy), r%(dx*dy)) - - -{- | -Expects an irreducible denominator as associate in standard form. --} -scaleFrac :: (PID.C a, Indexable.C a) => Ratio.T a -> T a -> T a -scaleFrac s (Cons z0 m) = - let ns = Ratio.numerator s - ds = Ratio.denominator s - dsOrd = Indexable.toOrd ds - -- (z,zr) = Ratio.split (Ratio.scale z0 s) - (z,zr) = divMod (z0*ns) ds - scaleFracs = - (\(scs,fracs) -> - Map.insert dsOrd [foldl (+) zr scs] $ - indexMapFromList $ - map (uncurry multiFromFraction) fracs) . - unzip . - map (\(dis,r) -> - let (sc,rc) = mulFrac s r - in (sc, (dis, rc))) . - Map.elems . - indexMapMapWithKey - (\d l -> (Match.replicate l d, multiToFraction d l)) - in removeZeros $ reduceHeads $ Cons z - (mapApplySplit dsOrd (+) - (uncurry (:) . carryRipple ds . map (ns*)) - scaleFracs m) - -scaleInt :: (PID.C a, Indexable.C a) => a -> T a -> T a -scaleInt x (Cons z m) = - removeZeros $ normalizeModulo $ - Cons (x*z) (Map.map (map (x*)) m) - - -mul :: (PID.C a, Indexable.C a) => T a -> T a -> T a -mul (Cons z m) a = - foldl - (+) (scaleInt z a) - (map (\(d,l) -> - -- cf. to multiToFraction - foldr (\numer acc -> - scaleFrac (one%d) (scaleInt numer a + acc)) zero l) - (indexMapToList m)) - -mulFast :: (PID.C a, Indexable.C a) => T a -> T a -> T a -mulFast pa pb = - let ra = toFactoredFraction pa - rb = toFactoredFraction pb - in fromFactoredFraction (fst ra ++ fst rb) (snd ra * snd rb) - - -instance (PID.C a, Indexable.C a) => Ring.C (T a) where - one = fromValue one - (*) = mulFast - - -{- * Helper functions for work with Maps with Indexable keys -} - -indexMapMapWithKey :: (a -> b -> c) - -> Map (Indexable.ToOrd a) b - -> Map (Indexable.ToOrd a) c -indexMapMapWithKey f = Map.mapWithKey (f . Indexable.fromOrd) - -indexMapToList :: Map (Indexable.ToOrd a) b -> [(a, b)] -indexMapToList = map (\(k,e) -> (Indexable.fromOrd k, e)) . Map.toList - -indexMapFromList :: Indexable.C a => [(a, b)] -> Map (Indexable.ToOrd a) b -indexMapFromList = Map.fromList . map (\(k,e) -> (Indexable.toOrd k, e)) - -{- | -Apply a function on a specific element if it exists, -and another function to the rest of the map. --} -mapApplySplit :: Ord a => - a -> (c -> c -> c) -> - (b -> c) -> (Map a b -> Map a c) -> Map a b -> Map a c -mapApplySplit key addOp f g m = - maybe - (g m) - (\x -> Map.insertWith addOp key (f x) $ g (Map.delete key m)) - (Map.lookup key m) - diff --git a/src-ghc-6.12/MathObj/Permutation.hs b/src-ghc-6.12/MathObj/Permutation.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Permutation.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2006 -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : - -Routines and abstractions for permutations of Integers. - -*** -Seems to be a candidate for Algebra directory. -Algebra.PermutationGroup ? --} - -module MathObj.Permutation where - -import Data.Array(Ix) - --- import NumericPrelude.Numeric (Integer) --- import NumericPrelude.Base - - -{- | -There are quite a few way we could represent elements of permutation -groups: the images in a row, a list of the cycles, et.c. All of these -differ highly in how complex various operations end up being. --} - -class C p where - domain :: (Ix i) => p i -> (i, i) - apply :: (Ix i) => p i -> i -> i - inverse :: (Ix i) => p i -> p i diff --git a/src-ghc-6.12/MathObj/Permutation/CycleList.hs b/src-ghc-6.12/MathObj/Permutation/CycleList.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Permutation/CycleList.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Mikael Johansson 2006 -Maintainer : mik@math.uni-jena.de -Stability : provisional -Portability : requires multi-parameter type classes - -Permutation of Integers represented by cycles. --} - -module MathObj.Permutation.CycleList where - -import Data.Set(Set) -import qualified Data.Set as Set - -import Data.List (unfoldr) -import Data.Array(Ix) -import qualified Data.Array as Array - -import qualified Data.List.Match as Match -import Data.Maybe.HT (toMaybe) -import NumericPrelude.Numeric (fromInteger) -import NumericPrelude.Base - - -type Cycle i = [i] -type T i = [Cycle i] - - - -fromFunction :: (Ix i) => - (i, i) -> (i -> i) -> T i -fromFunction rng f = - let extractCycle available = - do el <- choose available - let orb = orbit f el - return (orb, Set.difference available (Set.fromList orb)) - cycles = unfoldr extractCycle (Set.fromList (Array.range rng)) - in keepEssentials cycles - - - --- right action of a cycle -cycleRightAction :: (Eq i) => i -> Cycle i -> i -x `cycleRightAction` c = cycleAction c x - --- left action of a cycle -cycleLeftAction :: (Eq i) => Cycle i -> i -> i -c `cycleLeftAction` x = cycleAction (reverse c) x - -cycleAction :: (Eq i) => [i] -> i -> i -cycleAction cyc x = - case dropWhile (x/=) (cyc ++ [head cyc]) of - _:y:_ -> y - _ -> x - - -cycleOrbit :: (Ord i) => Cycle i -> i -> [i] -cycleOrbit cyc = orbit (flip cycleRightAction cyc) - -{- | -Right (left?) group action on the Integers. -Close to, but not the same as the module action in Algebra.Module. --} -(*>) :: (Eq i) => T i -> i -> i -p *> x = foldr (flip cycleRightAction) x p - -cyclesOrbit ::(Ord i) => T i -> i -> [i] -cyclesOrbit p = orbit (p *>) - -orbit :: (Ord i) => (i -> i) -> i -> [i] -orbit op x0 = takeUntilRepetition (iterate op x0) - --- | candidates for Utility ? -takeUntilRepetition :: Ord a => [a] -> [a] -takeUntilRepetition xs = - let accs = scanl (flip Set.insert) Set.empty xs - lenlist = takeWhile not (zipWith Set.member xs accs) - in Match.take lenlist xs - -takeUntilRepetitionSlow :: Eq a => [a] -> [a] -takeUntilRepetitionSlow xs = - let accs = scanl (flip (:)) [] xs - lenlist = takeWhile not (zipWith elem xs accs) - in Match.take lenlist xs - - -{- -Alternative to Data.Set.minView in GHC-6.6. --} -choose :: Set a -> Maybe a -choose set = - toMaybe (not (Set.null set)) (Set.findMin set) - -keepEssentials :: T i -> T i -keepEssentials = filter isEssential - --- is more lazy than (length cyc > 1) -isEssential :: Cycle i -> Bool -isEssential = not . null . drop 1 - -inverse :: T i -> T i -inverse = map reverse diff --git a/src-ghc-6.12/MathObj/Permutation/CycleList/Check.hs b/src-ghc-6.12/MathObj/Permutation/CycleList/Check.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Permutation/CycleList/Check.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2006 -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : requires multi-parameter type classes --} - -module MathObj.Permutation.CycleList.Check where - -import qualified MathObj.Permutation.CycleList as PermCycle -import qualified MathObj.Permutation.Table as PermTable -import qualified MathObj.Permutation as Perm - -{- -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import Algebra.Ring((*),one,fromInteger) -import Algebra.Additive((+)) --} -import Algebra.Monoid((<*>)) -import qualified Algebra.Monoid as Monoid - -import Data.Array((!), Ix) -import qualified Data.Array as Array - --- import NumericPrelude.Numeric (Integer) -import NumericPrelude.Base hiding (cycle) - -{- | -We shall make a little bit of a hack here, enabling us to use additive -or multiplicative syntax for groups as we wish by simply instantiating -Num with both operations corresponding to the group operation of the -permutation group we're studying --} - -{- | -There are quite a few way we could represent elements of permutation -groups: the images in a row, a list of the cycles, et.c. All of these -differ highly in how complex various operations end up being. --} - -newtype Cycle i = Cycle { cycle :: [i] } deriving (Read,Eq) -data T i = Cons { range :: (i, i), cycles :: [Cycle i] } - -{- | -Does not check whether the input values are in range. --} -fromCycles :: (i, i) -> [[i]] -> T i -fromCycles rng = Cons rng . map Cycle - -toCycles :: T i -> [[i]] -toCycles = map cycle . cycles - -toTable :: (Ix i) => T i -> PermTable.T i -toTable x = PermTable.fromCycles (range x) (toCycles x) - -fromTable :: (Ix i) => PermTable.T i -> T i -fromTable x = - let rng = Array.bounds x - in fromCycles rng (PermCycle.fromFunction rng (x!)) - - -errIncompat :: a -errIncompat = error "Permutation.CycleList: Incompatible domains" - -liftCmpTable2 :: (Ix i) => - (PermTable.T i -> PermTable.T i -> a) -> T i -> T i -> a -liftCmpTable2 f x y = - if range x == range y - then f (toTable x) (toTable y) - else errIncompat - -liftTable2 :: (Ix i) => - (PermTable.T i -> PermTable.T i -> PermTable.T i) -> T i -> T i -> T i -liftTable2 f x y = fromTable (liftCmpTable2 f x y) - - -closure :: (Ix i) => [T i] -> [T i] -closure = map fromTable . PermTable.closure . map toTable - - -instance Perm.C T where - domain = range - apply p = ((toCycles p) PermCycle.*>) - inverse p = fromCycles (range p) (PermCycle.inverse (toCycles p)) - -instance Show i => Show (Cycle i) where - show c = "(" ++ - (unwords $ - map show $ - cycle c) ++ ")" - -instance Show i => Show (T i) where - show p = - case cycles p of - [] -> "Id" - cyc -> concatMap show cyc - - -{- | -These instances may need more work -They involve converting a permutation to a table. --} -instance Ix i => Eq (T i) where - (==) = liftCmpTable2 (==) - -instance Ix i => Ord (T i) where - compare = liftCmpTable2 compare - -{- Better: Group class and instances -instance Additive.C (T i) where - p + q = p * q - negate = inverse - zero = one - -instance Ring.C (T i) where - (Cons op cp) * (Cons oq cq) = reduceCycles $ - Cons (max op oq) (cp ++ cq) - one = Cons 1 [] --} - -instance Ix i => Monoid.C (T i) where - (<*>) = liftTable2 PermTable.compose - idt = error "There is no generic unit element" diff --git a/src-ghc-6.12/MathObj/Permutation/Table.hs b/src-ghc-6.12/MathObj/Permutation/Table.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Permutation/Table.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2006 -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : - -Permutation represented by an array of the images. --} - -module MathObj.Permutation.Table where - -import qualified MathObj.Permutation as Perm - -import Data.Set(Set) -import qualified Data.Set as Set - -import Data.Array(Array,(!),(//),Ix) -import qualified Data.Array as Array - -import Data.List ((\\), nub, unfoldr, ) - -import Data.Tuple.HT (swap, ) -import Data.Maybe.HT (toMaybe, ) - --- import NumericPrelude.Numeric (Integer) -import NumericPrelude.Base hiding (cycle) - - -type T i = Array i i - - -fromFunction :: (Ix i) => - (i, i) -> (i -> i) -> T i -fromFunction rng f = - Array.listArray rng (map f (Array.range rng)) - -toFunction :: (Ix i) => T i -> (i -> i) -toFunction = (!) - -{- -Create a permutation in table form -from any other permutation representation. --} -fromPermutation :: (Ix i, Perm.C p) => p i -> T i -fromPermutation x = - let rng = Perm.domain x - in Array.listArray rng (map (Perm.apply x) (Array.range rng)) - -fromCycles :: (Ix i) => (i, i) -> [[i]] -> T i -fromCycles rng = foldl (flip cycle) (identity rng) - - -identity :: (Ix i) => (i, i) -> T i -identity rng = Array.listArray rng (Array.range rng) - -cycle :: (Ix i) => [i] -> T i -> T i -cycle cyc p = - p // zipWith (\i j -> (j,p!i)) cyc (tail (cyc++cyc)) - -inverse :: (Ix i) => T i -> T i -inverse p = - let rng = Array.bounds p - in Array.array rng (map swap (Array.assocs p)) - -compose :: (Ix i) => T i -> T i -> T i -compose p q = - let pRng = Array.bounds p - qRng = Array.bounds q - in if pRng==qRng - then fmap (p!) q - else error "compose: ranges differ" --- ++ show pRng ++ " /= " ++ show qRng) - - -{- | -Extremely naïve algorithm -to generate a list of all elements in a group. -Should be replaced by a Schreier-Sims system -if this code is ever used for anything bigger than .. say .. -groups of order 512 or so. --} -{- -Alternative to Data.Set.minView in GHC-6.6. --} -choose :: Set a -> Maybe (a, Set a) -choose set = - toMaybe (not (Set.null set)) (Set.deleteFindMin set) - -closure :: (Ix i) => [T i] -> [T i] -closure [] = [] -closure generators@(gen:_) = - let genSet = Set.fromList generators - idSet = Set.singleton (identity (Array.bounds gen)) - generate (registered, candidates) = - do (cand, remCands) <- choose candidates - let newCands = - flip Set.difference registered $ - Set.map (compose cand) genSet - return (cand, (Set.union registered newCands, - Set.union remCands newCands)) - in unfoldr generate (idSet, idSet) - -closureSlow :: (Ix i) => [T i] -> [T i] -closureSlow [] = [] -closureSlow generators@(gen:_) = - let addElts grp [] = grp - addElts grp cands@(cand:remCands) = - let group' = grp ++ [cand] - newCands = map (compose cand) generators - cands' = nub (remCands ++ newCands) \\ (grp ++ cands) - in addElts group' cands' - in addElts [] [identity (Array.bounds gen)] diff --git a/src-ghc-6.12/MathObj/Polynomial.hs b/src-ghc-6.12/MathObj/Polynomial.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Polynomial.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -{- | -Polynomials and rational functions in a single indeterminate. -Polynomials are represented by a list of coefficients. -All non-zero coefficients are listed, but there may be extra '0's at the end. - -Usage: -Say you have the ring of 'Integer' numbers -and you want to add a transcendental element @x@, -that is an element, which does not allow for simplifications. -More precisely, for all positive integer exponents @n@ -the power @x^n@ cannot be rewritten as a sum of powers with smaller exponents. -The element @x@ must be represented by the polynomial @[0,1]@. - -In principle, you can have more than one transcendental element -by using polynomials whose coefficients are polynomials as well. -However, most algorithms on multi-variate polynomials -prefer a different (sparse) representation, -where the ordering of elements is not so fixed. - -If you want division, you need "Number.Ratio"s -of polynomials with coefficients from a "Algebra.Field". - -You can also compute with an algebraic element, -that is an element which satisfies an algebraic equation like -@x^3-x-1==0@. -Actually, powers of @x@ with exponents above @3@ can be simplified, -since it holds @x^3==x+1@. -You can perform these computations with "Number.ResidueClass" of polynomials, -where the divisor is the polynomial equation that determines @x@. -If the polynomial is irreducible -(in our case @x^3-x-1@ cannot be written as a non-trivial product) -then the residue classes also allow unrestricted division -(except by zero, of course). -That is, using residue classes of polynomials -you can work with roots of polynomial equations -without representing them by radicals -(powers with fractional exponents). -It is well-known, that roots of polynomials of degree above 4 -may not be representable by radicals. --} - -module MathObj.Polynomial - (T, fromCoeffs, coeffs, degree, - showsExpressionPrec, const, - evaluate, evaluateCoeffVector, evaluateArgVector, - collinear, - integrate, - compose, fromRoots, reverse, - translate, dilate, shrink, ) -where - -import qualified MathObj.Polynomial.Core as Core - -import qualified Algebra.Differential as Differential -import qualified Algebra.VectorSpace as VectorSpace -import qualified Algebra.Module as Module -import qualified Algebra.Vector as Vector -import qualified Algebra.Field as Field -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Units as Units -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable -import qualified Algebra.Indexable as Indexable - -import Algebra.Module((*>)) -import Algebra.ZeroTestable(isZero) - -import Control.Monad (liftM, ) -import qualified Data.List as List - -import Test.QuickCheck (Arbitrary(arbitrary)) - -import NumericPrelude.Base hiding (const, reverse, ) -import NumericPrelude.Numeric - -import qualified Prelude as P98 - - -newtype T a = Cons {coeffs :: [a]} - - -{-# INLINE fromCoeffs #-} -fromCoeffs :: [a] -> T a -fromCoeffs = lift0 - -{-# INLINE lift0 #-} -lift0 :: [a] -> T a -lift0 = Cons - -{-# INLINE lift1 #-} -lift1 :: ([a] -> [a]) -> (T a -> T a) -lift1 f (Cons x0) = Cons (f x0) - -{-# INLINE lift2 #-} -lift2 :: ([a] -> [a] -> [a]) -> (T a -> T a -> T a) -lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1) - -degree :: (ZeroTestable.C a) => T a -> Maybe Int -degree x = - case Core.normalize (coeffs x) of - [] -> Nothing - (_:xs) -> Just $ length xs - -{- -Functor instance is e.g. useful for showing polynomials in residue rings. -@fmap (ResidueClass.concrete 7) (polynomial [1,4,4::ResidueClass.T Integer] * polynomial [1,5,6])@ --} - -instance Functor T where - fmap f (Cons xs) = Cons (map f xs) - -{-# INLINE plusPrec #-} -{-# INLINE appPrec #-} -plusPrec, appPrec :: Int -plusPrec = 6 -appPrec = 10 - -instance (Show a) => Show (T a) where - showsPrec p (Cons xs) = - showParen (p >= appPrec) (showString "Polynomial.fromCoeffs " . shows xs) - -{-# INLINE showsExpressionPrec #-} -showsExpressionPrec :: (Show a, ZeroTestable.C a, Additive.C a) => - Int -> String -> T a -> String -> String -showsExpressionPrec p var poly = - if isZero poly - then showString "0" - else - let terms = filter (not . isZero . fst) - (zip (coeffs poly) monomials) - monomials = id : - showString "*" . showString var : - map (\k -> showString "*" . showString var - . showString "^" . shows k) - [(2::Int)..] - showsTerm x showsMon = showsPrec (plusPrec+1) x . showsMon - in showParen (p > plusPrec) - (foldl (.) id $ List.intersperse (showString " + ") $ - map (uncurry showsTerm) terms) - - -{-# INLINE evaluate #-} -evaluate :: Ring.C a => T a -> a -> a -evaluate (Cons y) x = Core.horner x y - -{- | -Here the coefficients are vectors, -for example the coefficients are real and the coefficents are real vectors. --} -{-# INLINE evaluateCoeffVector #-} -evaluateCoeffVector :: Module.C a v => T v -> a -> v -evaluateCoeffVector (Cons y) x = Core.hornerCoeffVector x y - -{- | -Here the argument is a vector, -for example the coefficients are complex numbers or square matrices -and the coefficents are reals. --} -{-# INLINE evaluateArgVector #-} -evaluateArgVector :: (Module.C a v, Ring.C v) => T a -> v -> v -evaluateArgVector (Cons y) x = Core.hornerArgVector x y - -{- | -'compose' is the functional composition of polynomials. - -It fulfills - @ eval x . eval y == eval (compose x y) @ --} - --- compose :: Module.C a b => T b -> T a -> T a --- compose (Cons x) y = Core.horner y (map const x) -{-# INLINE compose #-} -compose :: (Ring.C a) => T a -> T a -> T a -compose (Cons x) y = Core.horner y (map const x) - -{-# INLINE const #-} -const :: a -> T a -const x = lift0 [x] - - -collinear :: (Eq a, Ring.C a) => T a -> T a -> Bool -collinear (Cons x) (Cons y) = Core.collinear x y - - -instance (Eq a, ZeroTestable.C a) => Eq (T a) where - (Cons x) == (Cons y) = Core.equal x y - -instance (Indexable.C a, ZeroTestable.C a) => Indexable.C (T a) where - compare = Indexable.liftCompare coeffs - -instance (ZeroTestable.C a) => ZeroTestable.C (T a) where - isZero (Cons x) = isZero x - - -instance (Additive.C a) => Additive.C (T a) where - (+) = lift2 Core.add - (-) = lift2 Core.sub - zero = lift0 [] - negate = lift1 Core.negate - - -instance Vector.C T where - zero = zero - (<+>) = (+) - (*>) = Vector.functorScale - -instance (Module.C a b) => Module.C a (T b) where - (*>) x = lift1 (x *>) - -instance (Field.C a, Module.C a b) => VectorSpace.C a (T b) - - -instance (Ring.C a) => Ring.C (T a) where - one = const one - fromInteger = const . fromInteger - (*) = lift2 Core.mul - - -{- | -The 'Integral.C' instance is intensionally built -from the 'Field.C' structure of the polynomial coefficients. -If we would use @Integral.C a@ superclass, -then the Euclidean algorithm could not determine -the greatest common divisor of e.g. @[1,1]@ and @[2]@. --} -instance (ZeroTestable.C a, Field.C a) => Integral.C (T a) where - divMod (Cons x) (Cons y) = - let (d,m) = Core.divMod x y - in (Cons d, Cons m) - -instance (ZeroTestable.C a, Field.C a) => Units.C (T a) where - isUnit (Cons []) = False - isUnit (Cons (x0:xs)) = not (isZero x0) && all isZero xs - stdUnit (Cons x) = const (Core.stdUnit x) - stdUnitInv (Cons x) = const (recip (Core.stdUnit x)) - -{- -Polynomials are a Euclidean domain, so no instance is necessary -(although it might be faster). --} - -instance (ZeroTestable.C a, Field.C a) => PID.C (T a) - - -instance (Ring.C a) => Differential.C (T a) where - differentiate = lift1 Core.differentiate - - -{-# INLINE integrate #-} -integrate :: (Field.C a) => a -> T a -> T a -integrate = lift1 . Core.integrate - - - -{-# INLINE fromRoots #-} -fromRoots :: (Ring.C a) => [a] -> T a -fromRoots = Cons . foldl (flip Core.mulLinearFactor) [one] - -{-# INLINE reverse #-} -reverse :: Additive.C a => T a -> T a -reverse = lift1 Core.alternate - -translate :: Ring.C a => a -> T a -> T a -translate d = - lift1 $ foldr (\c p -> [c] + Core.mulLinearFactor d p) [] - -shrink :: Ring.C a => a -> T a -> T a -shrink k = - lift1 $ zipWith (*) (iterate (k*) one) - -dilate :: Field.C a => a -> T a -> T a -dilate = shrink . Field.recip - - -instance (Arbitrary a, ZeroTestable.C a) => Arbitrary (T a) where - arbitrary = liftM (fromCoeffs . Core.normalize) arbitrary - - -{- * legacy instances -} - -{- | -It is disputable whether polynomials shall be represented by number literals or not. -An advantage is, that one can write -let x = polynomial [0,1] -in (x^2+x+1)*(x-1) -However the output looks much different. --} -{-# INLINE legacyInstance #-} -legacyInstance :: a -legacyInstance = - error "legacy Ring.C instance for simple input of numeric literals" - -instance (Ring.C a, Eq a, Show a, ZeroTestable.C a) => P98.Num (T a) where - fromInteger = const . fromInteger - negate = Additive.negate -- for unary minus - (+) = legacyInstance - (*) = legacyInstance - abs = legacyInstance - signum = legacyInstance - -instance (Field.C a, Eq a, Show a, ZeroTestable.C a) => P98.Fractional (T a) where - fromRational = const . fromRational - (/) = legacyInstance diff --git a/src-ghc-6.12/MathObj/Polynomial/Core.hs b/src-ghc-6.12/MathObj/Polynomial/Core.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/Polynomial/Core.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -This module implements polynomial functions on plain lists. -We use such functions in order to implement methods of other datatypes. - -The module organization differs from that of @ResidueClass@: -Here the @Polynomial@ module exports the type -that fits to the NumericPrelude type classes, -whereas in @ResidueClass@ the sub-modules export various flavors of them. --} -module MathObj.Polynomial.Core ( - horner, hornerCoeffVector, hornerArgVector, - normalize, - shift, unShift, - equal, - add, sub, negate, - scale, collinear, - tensorProduct, tensorProductAlt, - mul, mulShear, mulShearTranspose, - divMod, divModRev, - stdUnit, - progression, differentiate, integrate, integrateInt, - mulLinearFactor, - alternate, - ) where - -import qualified Algebra.Module as Module -import qualified Algebra.Field as Field -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import qualified Data.List as List -import NumericPrelude.List (zipWithOverlap, ) -import Data.Tuple.HT (mapPair, mapFst, forcePair, ) -import Data.List.HT - (dropWhileRev, switchL, shear, shearTranspose, outerProduct, ) - -import qualified NumericPrelude.Base as P -import qualified NumericPrelude.Numeric as NP - -import NumericPrelude.Base hiding (const, reverse, ) -import NumericPrelude.Numeric hiding (divMod, negate, stdUnit, ) - - -{- | -Horner's scheme for evaluating a polynomial in a ring. --} -{-# INLINE horner #-} -horner :: Ring.C a => a -> [a] -> a -horner x = foldr (\c val -> c+x*val) zero - -{- | -Horner's scheme for evaluating a polynomial in a module. --} -{-# INLINE hornerCoeffVector #-} -hornerCoeffVector :: Module.C a v => a -> [v] -> v -hornerCoeffVector x = foldr (\c val -> c+x*>val) zero - -{-# INLINE hornerArgVector #-} -hornerArgVector :: (Module.C a v, Ring.C v) => v -> [a] -> v -hornerArgVector x = foldr (\c val -> c*>one+val*x) zero - - -{- | -It's also helpful to put a polynomial in canonical form. -'normalize' strips leading coefficients that are zero. --} -{-# INLINE normalize #-} -normalize :: (ZeroTestable.C a) => [a] -> [a] -normalize = dropWhileRev isZero - -{- | -Multiply by the variable, used internally. --} -{-# INLINE shift #-} -shift :: (Additive.C a) => [a] -> [a] -shift [] = [] -shift l = zero : l - -{-# INLINE unShift #-} -unShift :: [a] -> [a] -unShift [] = [] -unShift (_:xs) = xs - -{-# INLINE equal #-} -equal :: (Eq a, ZeroTestable.C a) => [a] -> [a] -> Bool -equal x y = and (zipWithOverlap isZero isZero (==) x y) - - -add, sub :: (Additive.C a) => [a] -> [a] -> [a] -add = (+) -sub = (-) - -{-# INLINE negate #-} -negate :: (Additive.C a) => [a] -> [a] -negate = map NP.negate - - -{-# INLINE scale #-} -scale :: Ring.C a => a -> [a] -> [a] -scale s = map (s*) - - -collinear :: (Eq a, Ring.C a) => [a] -> [a] -> Bool -collinear (x:xs) (y:ys) = - if x==zero && y==zero - then collinear xs ys - else scale x ys == scale y xs --- here at least one of xs and ys is empty -collinear xs ys = - all (==zero) xs && all (==zero) ys - - -{-# INLINE tensorProduct #-} -tensorProduct :: Ring.C a => [a] -> [a] -> [[a]] -tensorProduct = outerProduct (*) - -tensorProductAlt :: Ring.C a => [a] -> [a] -> [[a]] -tensorProductAlt xs ys = map (flip scale ys) xs - - -{- | -'mul' is fast if the second argument is a short polynomial, -'MathObj.PowerSeries.**' relies on that fact. --} - -{-# INLINE mul #-} -mul :: Ring.C a => [a] -> [a] -> [a] -{- prevent from generation of many zeros - if the first operand is the empty list -} -mul [] = P.const [] -mul xs = foldr (\y zs -> let (v:vs) = scale y xs in v : add vs zs) [] --- this one fails on infinite lists --- mul xs = foldr (\y zs -> add (scale y xs) (shift zs)) [] - -{-# INLINE mulShear #-} -mulShear :: Ring.C a => [a] -> [a] -> [a] -mulShear xs ys = map sum (shear (tensorProduct xs ys)) - -{-# INLINE mulShearTranspose #-} -mulShearTranspose :: Ring.C a => [a] -> [a] -> [a] -mulShearTranspose xs ys = map sum (shearTranspose (tensorProduct xs ys)) - - -divMod :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> ([a], [a]) -divMod x y = - mapPair (List.reverse, List.reverse) $ - divModRev (List.reverse x) (List.reverse y) - -{- -snd $ Poly.divMod (repeat (1::Double)) [1,1] --} -divModRev :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> ([a], [a]) -divModRev x y = - let (y0:ys) = dropWhile isZero y - -- the second parameter represents lazily (length x - length y) - aux xs' = - forcePair . - switchL - ([], xs') - (P.const $ - let (x0:xs) = xs' - q0 = x0/y0 - in mapFst (q0:) . aux (sub xs (scale q0 ys))) - in if isZero y - then error "MathObj.Polynomial: division by zero" - else aux x (drop (length y - 1) x) - -{-# INLINE stdUnit #-} -stdUnit :: (ZeroTestable.C a, Ring.C a) => [a] -> a -stdUnit x = case normalize x of - [] -> one - l -> last l - - -{-# INLINE progression #-} -progression :: Ring.C a => [a] -progression = iterate (one+) one - -{-# INLINE differentiate #-} -differentiate :: (Ring.C a) => [a] -> [a] -differentiate = zipWith (*) progression . drop 1 - -{-# INLINE integrate #-} -integrate :: (Field.C a) => a -> [a] -> [a] -integrate c x = c : zipWith (/) x progression - -{- | -Integrates if it is possible to represent the integrated polynomial -in the given ring. -Otherwise undefined coefficients occur. --} -{-# INLINE integrateInt #-} -integrateInt :: (ZeroTestable.C a, Integral.C a) => a -> [a] -> [a] -integrateInt c x = - c : zipWith Integral.divChecked x progression - - -{-# INLINE mulLinearFactor #-} -mulLinearFactor :: Ring.C a => a -> [a] -> [a] -mulLinearFactor x yt@(y:ys) = Additive.negate (x*y) : yt - scale x ys -mulLinearFactor _ [] = [] - -{-# INLINE alternate #-} -alternate :: Additive.C a => [a] -> [a] -alternate = zipWith ($) (cycle [id, Additive.negate]) - - -{- -see htam: Wavelet/DyadicResultant - -resultant :: Ring.C a => [a] -> [a] -> [a] -resultant xs ys = - -discriminant :: Ring.C a => [a] -> a -discriminant xs = - let degree = genericLength xs - in parityFlip (divChecked (degree*(degree-1)) 2) - (resultant xs (differentiate xs)) - `divChecked` last xs --} - diff --git a/src-ghc-6.12/MathObj/PowerSeries.hs b/src-ghc-6.12/MathObj/PowerSeries.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/PowerSeries.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -{- | -Power series, either finite or unbounded. -(zipWith does exactly the right thing to make it work almost transparently.) --} -module MathObj.PowerSeries where - -import qualified MathObj.PowerSeries.Core as Core -import qualified MathObj.Polynomial.Core as Poly - -import qualified Algebra.Differential as Differential -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.VectorSpace as VectorSpace -import qualified Algebra.Module as Module -import qualified Algebra.Vector as Vector -import qualified Algebra.Transcendental as Transcendental -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import Algebra.Module((*>)) - -import NumericPrelude.Base hiding (const) -import NumericPrelude.Numeric - - -newtype T a = Cons {coeffs :: [a]} deriving (Ord) - -{-# INLINE fromCoeffs #-} -fromCoeffs :: [a] -> T a -fromCoeffs = lift0 - -{-# INLINE lift0 #-} -lift0 :: [a] -> T a -lift0 = Cons - -{-# INLINE lift1 #-} -lift1 :: ([a] -> [a]) -> (T a -> T a) -lift1 f (Cons x0) = Cons (f x0) - -{-# INLINE lift2 #-} -lift2 :: ([a] -> [a] -> [a]) -> (T a -> T a -> T a) -lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1) - -{-# INLINE const #-} -const :: a -> T a -const x = lift0 [x] - -{- -Functor instance is e.g. useful for showing power series in residue rings. -@fmap (ResidueClass.concrete 7) (powerSeries [1,4,4::ResidueClass.T Integer] * powerSeries [1,5,6])@ --} - -instance Functor T where - fmap f (Cons xs) = Cons (map f xs) - -{-# INLINE appPrec #-} -appPrec :: Int -appPrec = 10 - -instance (Show a) => Show (T a) where - showsPrec p (Cons xs) = - showParen (p >= appPrec) (showString "PowerSeries.fromCoeffs " . shows xs) - - -{-# INLINE truncate #-} -truncate :: Int -> T a -> T a -truncate n = lift1 (take n) - -{- | -Evaluate (truncated) power series. --} -{-# INLINE evaluate #-} -evaluate :: Ring.C a => T a -> a -> a -evaluate (Cons y) = Core.evaluate y - -{- | -Evaluate (truncated) power series. --} -{-# INLINE evaluateCoeffVector #-} -evaluateCoeffVector :: Module.C a v => T v -> a -> v -evaluateCoeffVector (Cons y) = Core.evaluateCoeffVector y - - -{-# INLINE evaluateArgVector #-} -evaluateArgVector :: (Module.C a v, Ring.C v) => T a -> v -> v -evaluateArgVector (Cons y) = Core.evaluateArgVector y - -{- | -Evaluate approximations that is evaluate all truncations of the series. --} -{-# INLINE approximate #-} -approximate :: Ring.C a => T a -> a -> [a] -approximate (Cons y) = Core.approximate y - - -{- | -Evaluate approximations that is evaluate all truncations of the series. --} -{-# INLINE approximateCoeffVector #-} -approximateCoeffVector :: Module.C a v => T v -> a -> [v] -approximateCoeffVector (Cons y) = Core.approximateCoeffVector y - - -{- | -Evaluate approximations that is evaluate all truncations of the series. --} -{-# INLINE approximateArgVector #-} -approximateArgVector :: (Module.C a v, Ring.C v) => T a -> v -> [v] -approximateArgVector (Cons y) = Core.approximateArgVector y - - -{- -Note that the derived instances only make sense for finite series. --} - -instance (Eq a, ZeroTestable.C a) => Eq (T a) where - (Cons x) == (Cons y) = Poly.equal x y - -instance (Additive.C a) => Additive.C (T a) where - negate = lift1 Poly.negate - (+) = lift2 Poly.add - (-) = lift2 Poly.sub - zero = lift0 [] - -instance (Ring.C a) => Ring.C (T a) where - one = const one - fromInteger n = const (fromInteger n) - (*) = lift2 Core.mul - -instance Vector.C T where - zero = zero - (<+>) = (+) - (*>) = Vector.functorScale - -instance (Module.C a b) => Module.C a (T b) where - (*>) x = lift1 (x *>) - -instance (Field.C a, Module.C a b) => VectorSpace.C a (T b) - - -instance (Field.C a) => Field.C (T a) where - (/) = lift2 Core.divide - - -instance (ZeroTestable.C a, Field.C a) => Integral.C (T a) where - divMod (Cons x) (Cons y) = - let (d,m) = Core.divMod x y - in (Cons d, Cons m) - - -instance (Ring.C a) => Differential.C (T a) where - differentiate = lift1 Core.differentiate - - -instance (Algebraic.C a) => Algebraic.C (T a) where - sqrt = lift1 (Core.sqrt Algebraic.sqrt) - x ^/ y = lift1 (Core.pow (Algebraic.^/ y) - (fromRational' y)) x - - -instance (Transcendental.C a) => - Transcendental.C (T a) where - pi = const Transcendental.pi - exp = lift1 (Core.exp Transcendental.exp) - sin = lift1 (Core.sin Core.sinCosScalar) - cos = lift1 (Core.cos Core.sinCosScalar) - tan = lift1 (Core.tan Core.sinCosScalar) - x ** y = Transcendental.exp (Transcendental.log x * y) - {- This order of multiplication is especially fast - when y is a singleton. -} - log = lift1 (Core.log Transcendental.log) - asin = lift1 (Core.asin Algebraic.sqrt Transcendental.asin) - acos = lift1 (Core.acos Algebraic.sqrt Transcendental.acos) - atan = lift1 (Core.atan Transcendental.atan) - -{- | -It fulfills - @ evaluate x . evaluate y == evaluate (compose x y) @ --} - -compose :: (Ring.C a, ZeroTestable.C a) => T a -> T a -> T a -compose (Cons []) (Cons []) = Cons [] -compose (Cons (x:_)) (Cons []) = Cons [x] -compose (Cons x) (Cons (y:ys)) = - if isZero y - then Cons (Core.compose x ys) - else error "PowerSeries.compose: inner series must not have an absolute term." diff --git a/src-ghc-6.12/MathObj/PowerSeries/Core.hs b/src-ghc-6.12/MathObj/PowerSeries/Core.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/PowerSeries/Core.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module MathObj.PowerSeries.Core where - -import qualified MathObj.Polynomial.Core as Poly - -import qualified Algebra.Module as Module -import qualified Algebra.Transcendental as Transcendental -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import qualified Data.List.Match as Match -import qualified NumericPrelude.Numeric as NP -import qualified NumericPrelude.Base as P - -import NumericPrelude.Base hiding (const) -import NumericPrelude.Numeric hiding (negate, stdUnit, divMod, - sqrt, exp, log, - sin, cos, tan, asin, acos, atan) - - -{-# INLINE evaluate #-} -evaluate :: Ring.C a => [a] -> a -> a -evaluate = flip Poly.horner - -{-# INLINE evaluateCoeffVector #-} -evaluateCoeffVector :: Module.C a v => [v] -> a -> v -evaluateCoeffVector = flip Poly.hornerCoeffVector - -{-# INLINE evaluateArgVector #-} -evaluateArgVector :: (Module.C a v, Ring.C v) => [a] -> v -> v -evaluateArgVector = flip Poly.hornerArgVector - - -{-# INLINE approximate #-} -approximate :: Ring.C a => [a] -> a -> [a] -approximate y x = - scanl (+) zero (zipWith (*) (iterate (x*) 1) y) - -{-# INLINE approximateCoeffVector #-} -approximateCoeffVector :: Module.C a v => [v] -> a -> [v] -approximateCoeffVector y x = - scanl (+) zero (zipWith (*>) (iterate (x*) 1) y) - -{-# INLINE approximateArgVector #-} -approximateArgVector :: (Module.C a v, Ring.C v) => [a] -> v -> [v] -approximateArgVector y x = - scanl (+) zero (zipWith (*>) y (iterate (x*) 1)) - - -{- * Simple series manipulation -} - -{- | -For the series of a real function @f@ -compute the series for @\x -> f (-x)@ --} - -alternate :: Additive.C a => [a] -> [a] -alternate = zipWith id (cycle [id, NP.negate]) - -{- | -For the series of a real function @f@ -compute the series for @\x -> (f x + f (-x)) \/ 2@ --} - -holes2 :: Additive.C a => [a] -> [a] -holes2 = zipWith id (cycle [id, P.const zero]) - -{- | -For the series of a real function @f@ -compute the real series for @\x -> (f (i*x) + f (-i*x)) \/ 2@ --} -holes2alternate :: Additive.C a => [a] -> [a] -holes2alternate = - zipWith id (cycle [id, P.const zero, NP.negate, P.const zero]) - - -{- * Series arithmetic -} - -add, sub :: (Additive.C a) => [a] -> [a] -> [a] -add = Poly.add -sub = Poly.sub - -negate :: (Additive.C a) => [a] -> [a] -negate = Poly.negate - -scale :: Ring.C a => a -> [a] -> [a] -scale = Poly.scale - -mul :: Ring.C a => [a] -> [a] -> [a] -mul = Poly.mul - - -stripLeadZero :: (ZeroTestable.C a) => [a] -> [a] -> ([a],[a]) -stripLeadZero (x:xs) (y:ys) = - if isZero x && isZero y - then stripLeadZero xs ys - else (x:xs,y:ys) -stripLeadZero xs ys = (xs,ys) - - -divMod :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> ([a],[a]) -divMod xs ys = - let (yZero,yRem) = span isZero ys - (xMod, xRem) = Match.splitAt yZero xs - in (divide xRem yRem, xMod) - -{- | -Divide two series where the absolute term of the divisor is non-zero. -That is, power series with leading non-zero terms are the units -in the ring of power series. - -Knuth: Seminumerical algorithms --} -divide :: (Field.C a) => [a] -> [a] -> [a] -divide (x:xs) (y:ys) = - let zs = map (/y) (x : sub xs (mul zs ys)) - in zs -divide [] _ = [] -divide _ [] = error "PowerSeries.divide: division by empty series" - -{- | -Divide two series also if the divisor has leading zeros. --} -divideStripZero :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> [a] -divideStripZero x' y' = - let (x0,y0) = stripLeadZero x' y' - in if null y0 || isZero (head y0) - then error "PowerSeries.divideStripZero: Division by zero." - else divide x0 y0 - - -progression :: Ring.C a => [a] -progression = Poly.progression - -recipProgression :: (Field.C a) => [a] -recipProgression = map recip progression - -differentiate :: (Ring.C a) => [a] -> [a] -differentiate = Poly.differentiate - -integrate :: (Field.C a) => a -> [a] -> [a] -integrate = Poly.integrate - - -{- | -We need to compute the square root only of the first term. -That is, if the first term is rational, -then all terms of the series are rational. --} -sqrt :: Field.C a => (a -> a) -> [a] -> [a] -sqrt _ [] = [] -sqrt f0 (x:xs) = - let y = f0 x - ys = map (/(y+y)) (xs - (0 : mul ys ys)) - in y:ys - -{- -pow alpha t = t^alpha -(pow alpha . x)' = alpha * (pow (alpha-1) . x) * x' -alpha * (pow alpha . x) = x * x' * (pow alpha . x)' -y = pow alpha . x -alpha * y = x * x' * y' --} - -{- | -Input series must start with non-zero term. --} -pow :: (Field.C a) => (a -> a) -> a -> [a] -> [a] -pow f0 expon x = - let y = integrate (f0 (head x)) y' - y' = scale expon (divide y (mul x (differentiate x))) - in y - - -{- | -The first term needs a transcendent computation but the others do not. -That's why we accept a function which computes the first term. - -> (exp . x)' = (exp . x) * x' -> (sin . x)' = (cos . x) * x' -> (cos . x)' = - (sin . x) * x' --} -exp :: Field.C a => (a -> a) -> [a] -> [a] -exp f0 x = - let x' = differentiate x - y = integrate (f0 (head x)) (mul y x') - in y - -sinCos :: Field.C a => (a -> (a,a)) -> [a] -> ([a],[a]) -sinCos f0 x = - let (y0Sin, y0Cos) = f0 (head x) - x' = differentiate x - ySin = integrate y0Sin (mul yCos x') - yCos = integrate y0Cos (negate (mul ySin x')) - in (ySin, yCos) - -sinCosScalar :: Transcendental.C a => a -> (a,a) -sinCosScalar x = (Transcendental.sin x, Transcendental.cos x) - -sin, cos :: Field.C a => (a -> (a,a)) -> [a] -> [a] -sin f0 = fst . sinCos f0 -cos f0 = snd . sinCos f0 - -tan :: (Field.C a) => (a -> (a,a)) -> [a] -> [a] -tan f0 = uncurry divide . sinCos f0 - -{- -(log x)' == x'/x -(asin x)' == (acos x) == x'/sqrt(1-x^2) -(atan x)' == x'/(1+x^2) --} - -{- | -Input series must start with non-zero term. --} -log :: (Field.C a) => (a -> a) -> [a] -> [a] -log f0 x = integrate (f0 (head x)) (derivedLog x) - -{- | -Computes @(log x)'@, that is @x'\/x@ --} -derivedLog :: (Field.C a) => [a] -> [a] -derivedLog x = divide (differentiate x) x - -atan :: (Field.C a) => (a -> a) -> [a] -> [a] -atan f0 x = - let x' = differentiate x - in integrate (f0 (head x)) (divide x' ([1] + mul x x)) - -asin, acos :: (Field.C a) => - (a -> a) -> (a -> a) -> [a] -> [a] -asin sqrt0 f0 x = - let x' = differentiate x - in integrate (f0 (head x)) - (divide x' (sqrt sqrt0 ([1] - mul x x))) -acos = asin - -{- | -Since the inner series must start with a zero, -the first term is omitted in y. --} -compose :: (Ring.C a) => [a] -> [a] -> [a] -compose xs y = foldr (\x acc -> x : mul y acc) [] xs - - -{- | -Compose two power series where the outer series -can be developed for any expansion point. -To be more precise: -The outer series must be expanded with respect to the leading term -of the inner series. --} -composeTaylor :: Ring.C a => (a -> [a]) -> [a] -> [a] -composeTaylor x (y:ys) = compose (x y) ys -composeTaylor x [] = x 0 - - - -{- -(x . y) = id -(x' . y) * y' = 1 -y' = 1 / (x' . y) --} - -{- | -This function returns the series of the function in the form: -(point of the expansion, power series) - -This is exceptionally slow and needs cubic run-time. --} - -inv :: (Field.C a) => [a] -> (a, [a]) -inv x = - let y' = divide [1] (compose (differentiate x) (tail y)) - y = integrate 0 y' - -- the first term is zero, which is required for composition - in (head x, y) diff --git a/src-ghc-6.12/MathObj/PowerSeries/DifferentialEquation.hs b/src-ghc-6.12/MathObj/PowerSeries/DifferentialEquation.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/PowerSeries/DifferentialEquation.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Lazy evaluation allows for the solution - of differential equations in terms of power series. -Whenever you can express the highest derivative of the solution - as explicit expression of the lower derivatives - where each coefficient of the solution series - depends only on lower coefficients, - the recursive algorithm will work. --} - -module MathObj.PowerSeries.DifferentialEquation where - -import qualified MathObj.PowerSeries.Core as PS -import qualified MathObj.PowerSeries.Example as PSE - -import qualified Algebra.Field as Field -import qualified Algebra.ZeroTestable as ZeroTestable - -import NumericPrelude.Numeric -import NumericPrelude.Base - - -{- | -Example for a linear equation: - Setup a differential equation for @y@ with - -> y t = (exp (-t)) * (sin t) -> y' t = -(exp (-t)) * (sin t) + (exp (-t)) * (cos t) -> y'' t = -2 * (exp (-t)) * (cos t) - -Thus the differential equation - -> y'' = -2 * (y' + y) - -holds. - -The following function generates -a power series for @exp (-t) * sin t@ -by solving the differential equation. --} - -solveDiffEq0 :: (Field.C a) => [a] -solveDiffEq0 = - let -- the initial conditions are passed to "PS.integrate" - y = PS.integrate 0 y' - y' = PS.integrate 1 y'' - y'' = PS.scale (-2) (PS.add y' y) - in y - -verifyDiffEq0 :: (Field.C a) => [a] -verifyDiffEq0 = - PS.mul (zipWith (*) (iterate negate 1) PSE.exp) PSE.sin - -propDiffEq0 :: Bool -propDiffEq0 = solveDiffEq0 == (verifyDiffEq0 :: [Rational]) - - -{- | -We are not restricted to linear equations! - Let the solution be y with - y t = (1-t)^-1 - y' t = (1-t)^-2 - y'' t = 2*(1-t)^-3 - then it holds - y'' = 2 * y' * y --} - -solveDiffEq1 :: (ZeroTestable.C a, Field.C a) => [a] -solveDiffEq1 = - let -- the initial conditions are passed to "PS.integrate" - y = PS.integrate 1 y' - y' = PS.integrate 1 y'' - y'' = PS.scale 2 (PS.mul y' y) - in y - -verifyDiffEq1 :: (ZeroTestable.C a, Field.C a) => [a] -verifyDiffEq1 = PS.divide [1] [1, -1] - -propDiffEq1 :: Bool -propDiffEq1 = solveDiffEq1 == (verifyDiffEq1 :: [Rational]) diff --git a/src-ghc-6.12/MathObj/PowerSeries/Example.hs b/src-ghc-6.12/MathObj/PowerSeries/Example.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/PowerSeries/Example.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module MathObj.PowerSeries.Example where - -import qualified MathObj.PowerSeries.Core as PS - -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring --- import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable -import qualified Algebra.Transcendental as Transcendental - -import Algebra.Additive (zero, subtract, negate) - -import Data.List (intersperse, ) -import Data.List.HT (sieve, ) - -import NumericPrelude.Numeric (one, (*), (/), - fromInteger, {-fromRational,-} pi) -import NumericPrelude.Base -- (Bool, const, map, zipWith, id, (&&), (==)) - - -{- * Default implementations. -} - -recip :: (Ring.C a) => [a] -recip = recipExpl - -exp, sin, cos, - log, asin, atan, sqrt :: (Field.C a) => [a] -acos :: (Transcendental.C a) => [a] -tan :: (ZeroTestable.C a, Field.C a) => [a] -exp = expODE -sin = sinODE -cos = cosODE -tan = tanExplSieve -log = logODE -asin = asinODE -acos = acosODE -atan = atanODE - -sinh, cosh, atanh :: (Field.C a) => [a] -sinh = sinhODE -cosh = coshODE -atanh = atanhODE - -pow :: (Field.C a) => a -> [a] -pow = powExpl -sqrt = sqrtExpl - - -{- * Generate Taylor series explicitly. -} - -recipExpl :: (Ring.C a) => [a] -recipExpl = cycle [1,-1] - -expExpl, sinExpl, cosExpl :: (Field.C a) => [a] -expExpl = scanl (*) one PS.recipProgression -sinExpl = zero : PS.holes2alternate (tail expExpl) -cosExpl = PS.holes2alternate expExpl - -tanExpl, tanExplSieve :: (ZeroTestable.C a, Field.C a) => [a] -tanExpl = PS.divide sinExpl cosExpl --- ignore zero values -tanExplSieve = - concatMap - (\x -> [zero,x]) - (PS.divide (sieve 2 (tail sin)) (sieve 2 cos)) - -logExpl, atanExpl, sqrtExpl :: (Field.C a) => [a] -logExpl = zero : PS.alternate PS.recipProgression -atanExpl = zero : PS.holes2alternate PS.recipProgression - -sinhExpl, coshExpl, atanhExpl :: (Field.C a) => [a] -sinhExpl = zero : PS.holes2 (tail expExpl) -coshExpl = PS.holes2 expExpl -atanhExpl = zero : PS.holes2 PS.recipProgression - -{- * Power series of (1+x)^expon using the binomial series. -} - -powExpl :: (Field.C a) => a -> [a] -powExpl expon = - scanl (*) 1 (zipWith (/) - (iterate (subtract 1) expon) PS.progression) -sqrtExpl = powExpl (1/2) - -{- | -Power series of error function (almost). -More precisely @ erf = 2 \/ sqrt pi * integrate (\x -> exp (-x^2)) @, -with @erf 0 = 0@. --} - -erf :: (Field.C a) => [a] -erf = PS.integrate 0 $ intersperse 0 $ PS.alternate exp - -{- -integrate (\x -> exp (-x^2/2)) : - -erf = PS.integrate 0 $ intersperse 0 $ - snd $ mapAccumL (\twoPow c -> (twoPow/(-2), twoPow*c)) 1 exp --} - - -{- * Generate Taylor series from differential equations. -} - -{- -exp' x == exp x -sin' x == cos x -cos' x == - sin x - -tan' x == 1 + tan x ^ 2 - == cos x ^ (-2) --} - -expODE, sinODE, cosODE, tanODE, tanODESieve :: (Field.C a) => [a] -expODE = PS.integrate 1 expODE -sinODE = PS.integrate 0 cosODE -cosODE = PS.integrate 1 (PS.negate sinODE) -tanODE = PS.integrate 0 (PS.add [1] (PS.mul tanODE tanODE)) -tanODESieve = - -- sieve is too strict here because it wants to detect end of lists - let tan2 = map head (iterate (drop 2) (tail tanODESieve)) - in PS.integrate 0 (intersperse zero (1 : PS.mul tan2 tan2)) - -{- -log' (1+x) == 1/(1+x) -asin' x == acos' x == 1/sqrt(1-x^2) -atan' x == 1/(1+x^2) --} - -logODE, recipCircle, asinODE, atanODE, sqrtODE :: (Field.C a) => [a] -logODE = PS.integrate zero recip -recipCircle = intersperse zero (PS.alternate (powODE (-1/2))) -asinODE = PS.integrate 0 recipCircle -atanODE = PS.integrate zero (cycle [1,0,-1,0]) -sqrtODE = powODE (1/2) - -acosODE :: (Transcendental.C a) => [a] -acosODE = PS.integrate (pi/2) recipCircle - -sinhODE, coshODE, atanhODE :: (Field.C a) => [a] -sinhODE = PS.integrate 0 coshODE -coshODE = PS.integrate 1 sinhODE -atanhODE = PS.integrate zero (cycle [1,0]) - - -{- -Power series for y with - y x = (1+x) ** alpha -by solving the differential equation - alpha * y x = (1+x) * y' x --} - -powODE :: (Field.C a) => a -> [a] -powODE expon = - let y = PS.integrate 1 y' - y' = PS.scale expon (scanl1 subtract y) - in y diff --git a/src-ghc-6.12/MathObj/PowerSeries/Mean.hs b/src-ghc-6.12/MathObj/PowerSeries/Mean.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/PowerSeries/Mean.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -This module computes power series for -representing some means as generalized $f$-means. --} -module MathObj.PowerSeries.Mean where - -import qualified MathObj.PowerSeries2 as PS2 -import qualified MathObj.PowerSeries2.Core as PS2Core -import qualified MathObj.PowerSeries as PS -import qualified MathObj.PowerSeries.Core as PSCore -import qualified MathObj.PowerSeries.Example as PSE - -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring - -import Data.List.HT (shearTranspose) - -import NumericPrelude.Numeric -import NumericPrelude.Base - -{- -$M_f$ is a generalized $f$-mean (quasi-arithmetic) if -\[M_f x = f^{ -1}\right(\frac{1}{n}\cdot\sum_{k=1}^{n} f(x_k)\left)\] - -For instance there is the logarithmic mean -defined by -\[\frac{x-y}{\ln x - \ln y}\] -whose definition is inherently bound to two variables. -If we find a representation as a generalized $f$-mean -we can generalize this mean to more than two variables. - -Btw. we can easily see that the logarithmic mean is not a quasi-arithmetic mean, -because \[ \anonymfunc{(a,b,c,d)}{L(L(a,b),L(c,d))} \] -is not commutative, but quasi-arithmetic means are always commutative. - -First we note that an arbitrary constant offset and -an arbitrary scaling of $f$ does not alter the mean. -Therefore we choose $f(1)=0, f'(1)=1$ -and we expand $f$ into a Taylor series with respect to 1. - -For the logarithmic mean we will choose $y=0$. -This way we might get additional virtual solutions, -but we can identify them afterwards by a test. -\begin{eqnarray*} -f^{ -1}\left(\frac{f(1+x)+f(1+y)}{2}\right) - &=& \frac{x-y}{\ln(1+x) - \ln(1+y)} \\ -f^{ -1}\left(\frac{f(1+x)}{2}\right) - &=& \frac{x}{\ln(1+x)} \\ -f(1+x) - &=& 2 \cdot f\left(\frac{x}{\ln(1+x)}\right) -\end{eqnarray*} -This cannot be solved immediately -because in the power series expansions on both sides -unknown coefficients occur at the same monomials. -We can resolve that by subtracting the series of $2\cdot f(1+x/2)$ -off both sides. -\begin{eqnarray*} -f(1+x) - 2\cdot f(1+x/2) - &=& 2 \cdot (f\left(\frac{x}{\ln(1+x)}\right) - f(1+x/2)) -\end{eqnarray*} -We note that $1+x/2$ is the truncated series of $\frac{x}{\ln(1+x)}$. -This is also necessary in order to obtain an equation. - -Now we have to derive an implementation of the right-hand side. -This is a difference of two series compositions, namely -$f(x+a*x^2+b*x^3+\dots) - f(x)$ . -The implementation takes care that the vanishing terms are not computed -and thus allows solution of series fixed point equations. -It is just done by throwing away the leading terms of all powers -of the series $x+a*x^2+b*x^3+\dots$. -In $x$ the constant monomial is omitted, -in the result both the constant and the linear term are omitted. --} - -diffComp :: (Ring.C a) => [a] -> [a] -> [a] -diffComp ys x = - map sum (shearTranspose (tail (zipWith PSCore.scale ys - (map tail (iterate (PSCore.mul x) [1]))))) - -{- -Now we solve -\[ -\frac{1}{2}\cdot f(1+2\cdot x) - f(1+x) - &=& f\left(\frac{2\cdot x}{\ln(1+2\cdot x)}\right) - f(1+x) -\] --} - -logarithmic :: (Field.C a) => [a] -logarithmic = - let -- series for \frac{2\cdot x}{\ln(1+2\cdot x)} - fracLn = PSCore.divide [2] - (tail (zipWith (*) (iterate (2*) 1) PSE.log)) - fDiffFracLn = diffComp f (tail fracLn) - f = 0 : 1 : zipWith (/) fDiffFracLn - (map (subtract 1) (iterate (2*) 2)) - in f - -elemSym3_2 :: (Field.C a) => [a] -elemSym3_2 = - let -- series for \frac{2\cdot x}{\ln(1+2\cdot x)} - root = zipWith (*) (iterate (2*) 1) PSE.sqrt - fDiffRoot = diffComp f (tail root) - f = 0 : 1 : zipWith (/) fDiffRoot - (map (subtract 1) (iterate (3*) 3)) - in f - - -{- -Means constructed by mean value theorem. - -\[ M(x,y) = f'^{ -1}((f(x)-f(y))/(x-y)) \] - -\[ f(x) = x^2 \implies M - arithmetic mean \] -\[ f(x) = 1/x \implies M - geometric mean \] - -Try to find a power series for $f$ for $M(x,y) = \sqrt{(x^2+y^2)/2}$ -(quadratic mean). -Expansion point: 1. -$M(1+t,1) = \sqrt{1+t+t^2/2}$ --} -quadratic :: (Field.C a, Eq a) => [a] -quadratic = PSCore.sqrt (\1 -> 1) [1,1,1/2] - -quadraticMVF :: (Field.C a) => [a] -quadraticMVF = - -- [1,1,1,1,1/2,3/23,2/143] - -- [1,1,1,1,1/2,1/2] - [1,1,1,1,1/2,-1/14] - --- map (\x -> PSCore.coeffs (meanValueDiff2 quadratic2 [1,1,1,1,1/2,x] !! 4) !! 2) (GNUPlot.linearScale 10 (-0.071429,-1/14::Double)) --- take 20 $ Numerics.ZeroFinder.RegulaFalsi.zero (-1,0) (\x -> PSCore.coeffs (meanValueDiff2 quadratic2 [1::Double,1,1,1,1/2,x] !! 4) !! 2) - -{- -Result: It seems, -that we cannot find an appropriate coefficient for the 5th power. -This indicates that it is not possible to represent -the quadratic mean as mean value mean. --} - -quadraticDiff :: (Field.C a, Eq a) => [a] -quadraticDiff = - let divDiffPS = tail quadraticMVF -- (f(1+t)-f(1))/((1+t)-1) - (1, invPS) = PSCore.inv (PSCore.differentiate quadraticMVF) - meanValuePS = PSCore.composeTaylor (\1 -> invPS) divDiffPS - {- instead of computing an inverse series - we could also apply (compose) the derived series - to the series of the quadratic mean. -} - in quadratic - meanValuePS - -{- -Represent quadratic mean with a two-variate power series. - -$M(1+x,1+y) = \sqrt{1+x+y+(x^2+y^2)/2}$ --} -quadratic2 :: (Field.C a, Eq a) => PS2Core.T a -quadratic2 = - PS2Core.sqrt (\1 -> 1) [[1],[1,1],[1/2,0,1/2]] - -quadraticDiff2 :: (Field.C a, Eq a) => PS2Core.T a -quadraticDiff2 = - meanValueDiff2 quadratic2 quadraticMVF - - - -{- -We can alter the square coefficient, -but consequently we have to scale the sub-sequent coefficients. -If the square coefficient is zero then the equation is fulfilled, -but this is a non-solution because it is degenerate. --} -harmonicMVF :: (Field.C a) => [a] -harmonicMVF = - -- [1,1,1,-2,7/2,-62/11] - -- [1,1,2,-4,7,-124/11] - [1,1,3,-6,21/2,-186/11] - -{- -$M(1+x,1+y) = 2/(recip (1+x) + recip (1+y))$ --} -harmonic2 :: (Field.C a, Eq a) => PS2Core.T a -harmonic2 = - let rec = PS.fromCoeffs PSE.recip - in PS2Core.divide [[2]] $ - PS2.coeffs $ - PS2.fromPowerSeries0 rec + - PS2.fromPowerSeries1 rec - -harmonicDiff2 :: (Field.C a, Eq a) => PS2Core.T a -harmonicDiff2 = - meanValueDiff2 harmonic2 harmonicMVF - - - -arithmeticMVF :: (Field.C a) => [a] -arithmeticMVF = [1,2,1] - -{- -$M(1+x,1+y) = 1+x/2+y/2$ --} -arithmetic2 :: (Field.C a, Eq a) => PS2Core.T a -arithmetic2 = [[1],[1/2,1/2]] - -arithmeticDiff2 :: (Field.C a, Eq a) => PS2Core.T a -arithmeticDiff2 = - meanValueDiff2 arithmetic2 arithmeticMVF - - -geometricMVF :: (Field.C a) => [a] -geometricMVF = PSE.recip - -{- -$M(1+x,1+y) = \sqrt{(1+x)·(1+y)}$ --} -geometric2 :: (Field.C a, Eq a) => PS2Core.T a -geometric2 = - PS2Core.sqrt (\1 -> 1) [[1],[1,1],[0,1,0]] - -geometricDiff2 :: (Field.C a, Eq a) => PS2Core.T a -geometricDiff2 = - meanValueDiff2 geometric2 geometricMVF - - - - -meanValueDiff2 :: (Field.C a, Eq a) => - PS2Core.T a -> [a] -> PS2Core.T a -meanValueDiff2 mean2 curve = - let -- (f(1+x)-f(1+y)) / (x-y) - divDiffPS = - zipWith replicate [1..] $ tail curve - meanValuePS = - PS2Core.compose (PSCore.differentiate curve) (tail mean2) - in meanValuePS - divDiffPS diff --git a/src-ghc-6.12/MathObj/PowerSeries2.hs b/src-ghc-6.12/MathObj/PowerSeries2.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/PowerSeries2.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -{- | -Two-variate power series. --} - -module MathObj.PowerSeries2 where - -import qualified MathObj.PowerSeries2.Core as Core -import qualified MathObj.PowerSeries as PS -import qualified MathObj.Polynomial.Core as Poly - -import qualified Algebra.Vector as Vector -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import qualified NumericPrelude.Numeric as NP -import qualified NumericPrelude.Base as P - -import Data.List (isPrefixOf, ) -import qualified Data.List.Match as Match - -import NumericPrelude.Base hiding (const) -import NumericPrelude.Numeric - -{- | -In order to handle both variables equivalently -we maintain a list of coefficients for terms of the same total degree. -That is - -> eval [[a], [b,c], [d,e,f]] (x,y) == -> a + b*x+c*y + d*x^2+e*x*y+f*y^2 - -Although the sub-lists are always finite and thus are more like polynomials than power series, -division and square root computation are easier to implement for power series. --} -newtype T a = Cons {coeffs :: Core.T a} deriving (Ord) - - -isValid :: [[a]] -> Bool -isValid = flip isPrefixOf [1..] . map length - -check :: [[a]] -> [[a]] -check xs = - zipWith (\n x -> - if Match.compareLength n x == EQ - then x - else error "PowerSeries2.check: invalid length of sub-list") - (iterate (():) [()]) xs - - -fromCoeffs :: [[a]] -> T a -fromCoeffs = Cons . check - -fromPowerSeries0 :: Ring.C a => PS.T a -> T a -fromPowerSeries0 x = - fromCoeffs $ - zipWith (:) (PS.coeffs x) $ - iterate (0:) [] - -fromPowerSeries1 :: Ring.C a => PS.T a -> T a -fromPowerSeries1 x = - fromCoeffs $ - zipWith (++) (iterate (0:) []) $ - map (:[]) (PS.coeffs x) - - -lift0 :: Core.T a -> T a -lift0 = Cons - -lift1 :: (Core.T a -> Core.T a) -> (T a -> T a) -lift1 f (Cons x0) = Cons (f x0) - -lift2 :: (Core.T a -> Core.T a -> Core.T a) -> (T a -> T a -> T a) -lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1) - - -const :: a -> T a -const x = lift0 [[x]] - - -instance Functor T where - fmap f (Cons xs) = Cons (map (map f) xs) - -appPrec :: Int -appPrec = 10 - -instance (Show a) => Show (T a) where - showsPrec p (Cons xs) = - showParen (p >= appPrec) (showString "PowerSeries2.fromCoeffs " . shows xs) - - -instance (Eq a, ZeroTestable.C a) => Eq (T a) where - (Cons x) == (Cons y) = Poly.equal x y - -instance (Additive.C a) => Additive.C (T a) where - negate = lift1 Core.negate - (+) = lift2 Core.add - (-) = lift2 Core.sub - zero = lift0 [] - - -instance (Ring.C a) => Ring.C (T a) where - one = const one - fromInteger n = const (fromInteger n) - (*) = lift2 Core.mul - -instance Vector.C T where - zero = zero - (<+>) = (+) - (*>) = Vector.functorScale - - -instance (Field.C a) => Field.C (T a) where - (/) = lift2 Core.divide - - -instance (Algebraic.C a) => Algebraic.C (T a) where - sqrt = lift1 (Core.sqrt Algebraic.sqrt) --- x ^/ y = lift1 (Core.pow (Algebraic.^/ y) --- (fromRational' y)) x diff --git a/src-ghc-6.12/MathObj/PowerSeries2/Core.hs b/src-ghc-6.12/MathObj/PowerSeries2/Core.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/PowerSeries2/Core.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module MathObj.PowerSeries2.Core where - -import qualified MathObj.PowerSeries as PS -import qualified MathObj.PowerSeries.Core as PSCore - -import qualified Algebra.Differential as Differential -import qualified Algebra.Vector as Vector -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive - -import NumericPrelude.Base --- import NumericPrelude.Numeric hiding (negate, sqrt, ) - - -type T a = [[a]] - - -lift0fromPowerSeries :: [PS.T a] -> T a -lift0fromPowerSeries = map PS.coeffs - -lift1fromPowerSeries :: - ([PS.T a] -> [PS.T a]) -> (T a -> T a) -lift1fromPowerSeries f x0 = - map PS.coeffs (f (map PS.fromCoeffs x0)) - -lift2fromPowerSeries :: - ([PS.T a] -> [PS.T a] -> [PS.T a]) -> (T a -> T a -> T a) -lift2fromPowerSeries f x0 x1 = - map PS.coeffs (f (map PS.fromCoeffs x0) (map PS.fromCoeffs x1)) - - -{- * Series arithmetic -} - -add, sub :: (Additive.C a) => T a -> T a -> T a -add = PSCore.add -sub = PSCore.sub - -negate :: (Additive.C a) => T a -> T a -negate = PSCore.negate - - -scale :: Ring.C a => a -> T a -> T a -scale = map . (Vector.*>) - -mul :: Ring.C a => T a -> T a -> T a -mul = lift2fromPowerSeries PSCore.mul - - -divide :: (Field.C a) => - T a -> T a -> T a -divide = lift2fromPowerSeries PSCore.divide - - -sqrt :: (Field.C a) => - (a -> a) -> T a -> T a -sqrt fSqRt = - lift1fromPowerSeries $ - PSCore.sqrt (PS.const . (\[x] -> fSqRt x) . PS.coeffs) - - - -swapVariables :: T a -> T a -swapVariables = map reverse - - -differentiate0 :: (Ring.C a) => T a -> T a -differentiate0 = - swapVariables . differentiate1 . swapVariables - -differentiate1 :: (Ring.C a) => T a -> T a -differentiate1 = lift1fromPowerSeries $ map Differential.differentiate - -integrate0 :: (Field.C a) => [a] -> T a -> T a -integrate0 cs = - swapVariables . integrate1 cs . swapVariables - -integrate1 :: (Field.C a) => [a] -> T a -> T a -integrate1 = zipWith PSCore.integrate - - - -{- | -Since the inner series must start with a zero, -the first term is omitted in y. --} -compose :: (Ring.C a) => [a] -> T a -> T a -compose = lift1fromPowerSeries . PSCore.compose . map PS.const diff --git a/src-ghc-6.12/MathObj/PowerSum.hs b/src-ghc-6.12/MathObj/PowerSum.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/PowerSum.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- | -Copyright : (c) Henning Thielemann 2004-2005 - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : requires multi-parameter type classes - - -For a multi-set of numbers, -we describe a sequence of the sums of powers of the numbers in the set. -These can be easily converted to polynomials and back. -Thus they provide an easy way for computations on the roots of a polynomial. --} -module MathObj.PowerSum where - -import qualified MathObj.Polynomial as Poly -import qualified MathObj.Polynomial.Core as PolyCore -import qualified MathObj.PowerSeries.Core as PS - -import qualified Algebra.VectorSpace as VectorSpace -import qualified Algebra.Module as Module -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import Algebra.Module((*>)) - -import Control.Monad(liftM2) -import qualified Data.List as List -import Data.List.HT (shearTranspose, sieve) - -import NumericPrelude.Base as P hiding (const) -import NumericPrelude.Numeric as NP - - -newtype T a = Cons {sums :: [a]} - - -{- * Conversions -} - -lift0 :: [a] -> T a -lift0 = Cons - -lift1 :: ([a] -> [a]) -> (T a -> T a) -lift1 f (Cons x0) = Cons (f x0) - -lift2 :: ([a] -> [a] -> [a]) -> (T a -> T a -> T a) -lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1) - - -const :: (Ring.C a) => a -> T a -const x = Cons [1,x] - -{- Newton-Girard formulas, cf. Modula-3: arithmetic/RootBasic.mg - s'/s = p -} - -{- - s[k] - the elementary symmetric polynomial of degree k - p[k] - sum of the k-th power - - s[0](x0,x1,x2) = 1 - s[1](x0,x1,x2) = x0+x1+x2 - s[2](x0,x1,x2) = x0*x1+x1*x2+x2*x0 - s[3](x0,x1,x2) = x0*x1*x2 - s[4](x0,x1,x2) = 0 - - p[0](x0,x1,x2) = 1 + 1 + 1 - p[1](x0,x1,x2) = x0 + x1 + x2 - p[2](x0,x1,x2) = x0^2 + x1^2 + x2^2 - p[3](x0,x1,x2) = x0^3 + x1^3 + x2^3 - p[4](x0,x1,x2) = x0^4 + x1^4 + x2^4 - - s(t) := s[0] + s[1]*t + s[2]*t^2 + ... - p(t) := p[1]*t + p[2]*t^2 + ... - - Then it holds - t*s'(t) + p(-t)*s(t) = 0 - This can be proven by considering p as sum of geometric series - and differentiating s in the root-wise factored form. - - Note that we index the coefficients the other way round - and that the coefficients of the polynomial - are not pure elementary symmetric polynomials of the roots - but have alternating signs, too. --} -fromElemSym :: (Eq a, Ring.C a) => [a] -> [a] -fromElemSym s = - fromIntegral (length s - 1) : - PolyCore.alternate (divOneFlip s (PolyCore.differentiate s)) - -divOneFlip :: (Eq a, Ring.C a) => [a] -> [a] -> [a] -divOneFlip (1:xs) = - let aux (y:ys) = y : aux (ys - PolyCore.scale y xs) - aux [] = [] - in aux -divOneFlip _ = - error "divOneFlip: first element must be one" - -fromElemSymDenormalized :: (Field.C a, ZeroTestable.C a) => [a] -> [a] -fromElemSymDenormalized s = - fromIntegral (length s - 1) : - PolyCore.alternate (PS.derivedLog s) - - -toElemSym :: (Field.C a, ZeroTestable.C a) => [a] -> [a] -toElemSym p = - let s' = PolyCore.mul (PolyCore.alternate (tail p)) s - s = PolyCore.integrate 1 s' - in s - -toElemSymInt :: (Integral.C a, ZeroTestable.C a) => [a] -> [a] -toElemSymInt p = - let s' = PolyCore.mul (PolyCore.alternate (tail p)) s - s = PolyCore.integrateInt 1 s' - in s - - - -fromPolynomial :: (Field.C a, ZeroTestable.C a) => Poly.T a -> [a] -fromPolynomial = - let aux s = - fromIntegral (length s - 1) : - PolyCore.negate (PS.derivedLog s) - in aux . reverse . Poly.coeffs - -elemSymFromPolynomial :: Additive.C a => Poly.T a -> [a] -elemSymFromPolynomial = PolyCore.alternate . reverse . Poly.coeffs - -{- toPolynomial is not possible because this had to consume the whole sum sequence. -} - - - -binomials :: Ring.C a => [[a]] -binomials = [1] : binomials + map (0:) binomials - -{- * Show -} - -appPrec :: Int -appPrec = 10 - -instance (Show a) => Show (T a) where - showsPrec p (Cons xs) = - showParen (p >= appPrec) - (showString "PowerSum.Cons " . shows xs) - - -{- * Additive -} - -{- Use binomial expansion of (x+y)^n -} -add :: (Ring.C a) => [a] -> [a] -> [a] -add xs ys = - let powers = shearTranspose (PolyCore.tensorProduct xs ys) - in zipWith Ring.scalarProduct binomials powers - -instance (Ring.C a) => Additive.C (T a) where - zero = const zero - (+) = lift2 add - negate = lift1 PolyCore.alternate - - -{- * Ring -} - -mul :: (Ring.C a) => [a] -> [a] -> [a] -mul xs ys = zipWith (*) xs ys - -pow :: Integer -> [a] -> [a] -pow n = - if n<0 - then error "PowerSum.pow: negative exponent" - else sieve (fromInteger n) - -- map head . iterate (List.genericDrop (toInteger n)) - -instance (Ring.C a) => Ring.C (T a) where - one = const one - fromInteger n = const (fromInteger n) - (*) = lift2 mul - x^n = lift1 (pow n) x - - -{- * Module -} - -instance (Module.C a v, Ring.C v) => Module.C a (T v) where - x *> y = lift1 (zipWith (*>) (iterate (x*) one)) y - -instance (VectorSpace.C a v, Ring.C v) => VectorSpace.C a (T v) - - -{- * Field.C -} - -instance (Field.C a, ZeroTestable.C a) => Field.C (T a) where - recip = lift1 (fromElemSymDenormalized . reverse . toElemSym) - - -{- * Algebra -} - -root :: (Ring.C a) => Integer -> [a] -> [a] -root n xs = - let upsample m ys = - concat (List.intersperse - (List.genericReplicate (m - 1) zero) - (map (:[]) ys)) - in case compare n 0 of - LT -> upsample (-n) (reverse xs) - GT -> upsample n xs - EQ -> [1] - -instance (Field.C a, ZeroTestable.C a) => Algebraic.C (T a) where - root n = lift1 (fromElemSymDenormalized . root n . toElemSym) - - -{- given the list of power sums @x1^j + ... + xn^j@ - and a power series for the function @f@, - compute the series approximations of @f(x1) + ... + f(xn)@. -} -approxSeries :: Module.C a b => [b] -> [a] -> [b] -approxSeries y x = - scanl (+) zero (zipWith (*>) x y) - - -{- input lists contain roots -} -propOp :: (Eq a, Field.C a, ZeroTestable.C a) => - ([a] -> [a] -> [a]) -> (a -> a -> a) -> [a] -> [a] -> [Bool] -propOp powerOp op xs ys = - let zs = liftM2 op xs ys - xp = fromPolynomial (Poly.fromRoots xs) - yp = fromPolynomial (Poly.fromRoots ys) - ze = elemSymFromPolynomial (Poly.fromRoots zs) - in zipWith (==) (toElemSym (powerOp xp yp)) ze - -- PolyCore.equal (toElemSym (powerOp xp yp)) ze diff --git a/src-ghc-6.12/MathObj/RefinementMask2.hs b/src-ghc-6.12/MathObj/RefinementMask2.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/RefinementMask2.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module MathObj.RefinementMask2 ( - T, coeffs, fromCoeffs, - fromPolynomial, - toPolynomial, - toPolynomialFast, - refinePolynomial, - ) where - -import qualified MathObj.Polynomial as Poly -import qualified Algebra.RealField as RealField -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Vector as Vector - -import qualified Data.List as List -import qualified Data.List.HT as ListHT -import qualified Data.List.Match as Match -import Control.Monad (liftM2, ) - -import qualified Test.QuickCheck as QC - -import qualified NumericPrelude.List.Generic as NPList -import NumericPrelude.Base -import NumericPrelude.Numeric - - -newtype T a = Cons {coeffs :: [a]} - - -{-# INLINE fromCoeffs #-} -fromCoeffs :: [a] -> T a -fromCoeffs = lift0 - -{-# INLINE lift0 #-} -lift0 :: [a] -> T a -lift0 = Cons - -{- -{-# INLINE lift1 #-} -lift1 :: ([a] -> [a]) -> (T a -> T a) -lift1 f (Cons x0) = Cons (f x0) - -{-# INLINE lift2 #-} -lift2 :: ([a] -> [a] -> [a]) -> (T a -> T a -> T a) -lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1) --} - -{- -Functor instance is e.g. useful for converting number types, -say 'Rational' to 'Double'. --} - -instance Functor T where - fmap f (Cons xs) = Cons (map f xs) - -{-# INLINE appPrec #-} -appPrec :: Int -appPrec = 10 - -instance (Show a) => Show (T a) where - showsPrec p (Cons xs) = - showParen (p >= appPrec) - (showString "RefinementMask2.fromCoeffs " . shows xs) - -instance (QC.Arbitrary a, Field.C a) => QC.Arbitrary (T a) where - arbitrary = - liftM2 - (\degree body -> - let s = sum body - in Cons $ map ((2 ^- degree - s) / NPList.lengthLeft body +) body) - (QC.choose (-5,0)) QC.arbitrary - - -{- | -Determine mask by Gauss elimination. - -R - alternating binomial coefficients -L - differences of translated polynomials in columns - -p2 = L * R^(-1) * m - -R * L^(-1) * p2 = m --} -fromPolynomial :: - (Field.C a) => Poly.T a -> T a -fromPolynomial poly = - fromCoeffs $ - foldr (\p ps -> - ListHT.mapAdjacent (-) (p:ps++[0])) - [] $ - foldr (\(db,dp) cs -> - ListHT.switchR - (error "RefinementMask2.fromPolynomial: polynomial should be non-empty") - (\dps dpe -> - cs ++ [(db - Ring.scalarProduct dps cs) / dpe]) - dp) [] $ - zip - (Poly.coeffs $ Poly.dilate 2 poly) - (List.transpose $ - Match.take (Poly.coeffs poly) $ - map Poly.coeffs $ - iterate polynomialDifference poly) - -polynomialDifference :: - (Ring.C a) => Poly.T a -> Poly.T a -polynomialDifference poly = - Poly.fromCoeffs $ init $ Poly.coeffs $ - Poly.translate 1 poly - poly - -{- | -If the mask does not sum up to a power of @1/2@ -then the function returns 'Nothing'. --} -toPolynomial :: - (RealField.C a) => T a -> Maybe (Poly.T a) -toPolynomial (Cons []) = Just $ Poly.fromCoeffs [] -toPolynomial mask = - let s = sum $ coeffs mask - ks = reverse $ takeWhile (<=1) $ iterate (2*) s - in case ks of - 1:ks0 -> - Just $ - foldl - (\p k -> - let ip = Poly.integrate zero p - in ip + Poly.const (correctConstant (fmap (k/s*) mask) ip)) - (Poly.const 1) ks0 - _ -> Nothing -{- -> fmap (6 Vector.*>) $ toPolynomial (Cons [0.1, 0.02, 0.005::Rational]) -Just (Polynomial.fromCoeffs [-12732 % 109375, 272 % 625, -18 % 25, 1 % 1]) --} - -{- -The constant term must be zero, -higher terms must already satisfy the refinement constraint. --} -correctConstant :: - (Field.C a) => T a -> Poly.T a -> a -correctConstant mask poly = - let refined = refinePolynomial mask poly - in head (Poly.coeffs refined) / (1 - sum (coeffs mask)) - -toPolynomialFast :: - (RealField.C a) => T a -> Maybe (Poly.T a) -toPolynomialFast mask = - let s = sum $ coeffs mask - ks = reverse $ takeWhile (<=1) $ iterate (2*) s - in case ks of - 1:ks0 -> - Just $ - foldl - (\p k -> - let ip = Poly.integrate zero p - c = head (Poly.coeffs (refinePolynomial mask ip)) - in ip + Poly.const (c*k / ((1-k)*s))) - (Poly.const 1) ks0 - _ -> Nothing - -refinePolynomial :: - (Ring.C a) => T a -> Poly.T a -> Poly.T a -refinePolynomial mask = - Poly.shrink 2 . - Vector.linearComb (coeffs mask) . - iterate (Poly.translate 1) -{- -> mapM_ print $ take 50 $ iterate (refinePolynomial (Cons [0.1, 0.02, 0.005])) (Poly.fromCoeffs [0,0,0,1::Double]) -... -Polynomial.fromCoeffs [-0.11640685714285712,0.4351999999999999,-0.7199999999999999,1.0] --} diff --git a/src-ghc-6.12/MathObj/RootSet.hs b/src-ghc-6.12/MathObj/RootSet.hs deleted file mode 100644 --- a/src-ghc-6.12/MathObj/RootSet.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2004-2005 - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : requires multi-parameter type classes - -Computations on the set of roots of a polynomial. -These are represented as the list of their elementar symmetric terms. -The difference between a polynomial and the list of elementar symmetric terms -is the reversed order and the alternated signs. - -Cf. /MathObj.PowerSum/ . --} -module MathObj.RootSet where - -import qualified MathObj.Polynomial as Poly -import qualified MathObj.Polynomial.Core as PolyCore -import qualified MathObj.PowerSum as PowerSum - -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import qualified Data.List.Match as Match -import Control.Monad (liftM2) - -import NumericPrelude.Base as P hiding (const) -import NumericPrelude.Numeric as NP - - -newtype T a = Cons {coeffs :: [a]} - - -{- * Conversions -} - -lift0 :: [a] -> T a -lift0 = Cons - -lift1 :: ([a] -> [a]) -> (T a -> T a) -lift1 f (Cons x0) = Cons (f x0) - -lift2 :: ([a] -> [a] -> [a]) -> (T a -> T a -> T a) -lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1) - - -const :: (Ring.C a) => a -> T a -const x = Cons [1,x] - - -toPolynomial :: T a -> Poly.T a -toPolynomial (Cons xs) = Poly.fromCoeffs (reverse xs) - -fromPolynomial :: Poly.T a -> T a -fromPolynomial xs = Cons (reverse (Poly.coeffs xs)) - - - -toPowerSums :: (Field.C a, ZeroTestable.C a) => [a] -> [a] -toPowerSums = PowerSum.fromElemSymDenormalized - -fromPowerSums :: (Field.C a, ZeroTestable.C a) => [a] -> [a] -fromPowerSums = PowerSum.toElemSym - - -{- | cf. 'MathObj.Polynomial.mulLinearFactor' -} -addRoot :: Ring.C a => a -> [a] -> [a] -addRoot x yt@(y:ys) = - y : (ys + PolyCore.scale x yt) -addRoot _ [] = - error "addRoot: list of elementar symmetric terms must consist at least of a 1" - -fromRoots :: Ring.C a => [a] -> [a] -fromRoots = foldl (flip addRoot) [1] - - - -liftPowerSum1Gen :: ([a] -> [a]) -> ([a] -> [a]) -> - ([a] -> [a]) -> ([a] -> [a]) -liftPowerSum1Gen fromPS toPS op x = - Match.take x (fromPS (op (toPS x))) - -liftPowerSum2Gen :: ([a] -> [a]) -> ([a] -> [a]) -> - ([a] -> [a] -> [a]) -> ([a] -> [a] -> [a]) -liftPowerSum2Gen fromPS toPS op x y = - Match.take (undefined : liftM2 (,) (tail x) (tail y)) - (fromPS (op (toPS x) (toPS y))) - - -liftPowerSum1 :: (Field.C a, ZeroTestable.C a) => - ([a] -> [a]) -> ([a] -> [a]) -liftPowerSum1 = liftPowerSum1Gen fromPowerSums toPowerSums - -liftPowerSum2 :: (Field.C a, ZeroTestable.C a) => - ([a] -> [a] -> [a]) -> ([a] -> [a] -> [a]) -liftPowerSum2 = liftPowerSum2Gen fromPowerSums toPowerSums - -liftPowerSumInt1 :: (Integral.C a, Eq a, ZeroTestable.C a) => - ([a] -> [a]) -> ([a] -> [a]) -liftPowerSumInt1 = liftPowerSum1Gen PowerSum.toElemSymInt PowerSum.fromElemSym - -liftPowerSumInt2 :: (Integral.C a, Eq a, ZeroTestable.C a) => - ([a] -> [a] -> [a]) -> ([a] -> [a] -> [a]) -liftPowerSumInt2 = liftPowerSum2Gen PowerSum.toElemSymInt PowerSum.fromElemSym - - - - -{- * Show -} - -appPrec :: Int -appPrec = 10 - -instance (Show a) => Show (T a) where - showsPrec p (Cons xs) = - showParen (p >= appPrec) - (showString "RootSet.Cons " . shows xs) - - -{- * Additive -} - -{- Use binomial expansion of (x+y)^n -} -add :: (Field.C a, ZeroTestable.C a) => [a] -> [a] -> [a] -add = liftPowerSum2 PowerSum.add - -addInt :: (Integral.C a, Eq a, ZeroTestable.C a) => [a] -> [a] -> [a] -addInt = liftPowerSumInt2 PowerSum.add - -instance (Field.C a, ZeroTestable.C a) => Additive.C (T a) where - zero = const zero - (+) = lift2 add - negate = lift1 PolyCore.alternate - - -{- * Ring -} - -mul :: (Field.C a, ZeroTestable.C a) => [a] -> [a] -> [a] -mul = liftPowerSum2 PowerSum.mul - -mulInt :: (Integral.C a, Eq a, ZeroTestable.C a) => [a] -> [a] -> [a] -mulInt = liftPowerSumInt2 PowerSum.mul - - -pow :: (Field.C a, ZeroTestable.C a) => Integer -> [a] -> [a] -pow n = liftPowerSum1 (PowerSum.pow n) - -powInt :: (Integral.C a, Eq a, ZeroTestable.C a) => Integer -> [a] -> [a] -powInt n = liftPowerSumInt1 (PowerSum.pow n) - - -instance (Field.C a, ZeroTestable.C a) => Ring.C (T a) where - one = const one - fromInteger n = const (fromInteger n) - (*) = lift2 mul - x^n = lift1 (pow n) x - - -{- * Field.C -} - -instance (Field.C a, ZeroTestable.C a) => Field.C (T a) where - recip = lift1 reverse - - -{- * Algebra -} - -instance (Field.C a, ZeroTestable.C a) => Algebraic.C (T a) where - root n = lift1 (PowerSum.root n) diff --git a/src-ghc-6.12/Number/Complex.hs b/src-ghc-6.12/Number/Complex.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/Complex.hs +++ /dev/null @@ -1,575 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- Rules should be processed -} -{- | -Module : Number.Complex -Copyright : (c) The University of Glasgow 2001 -License : BSD-style (see the file libraries/base/LICENSE) - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable (?) - -Complex numbers. --} - -module Number.Complex - ( - -- * Cartesian form - T(real,imag), - imaginaryUnit, - fromReal, - - (+:), - (-:), - scale, - exp, - quarterLeft, - quarterRight, - - -- * Polar form - fromPolar, - cis, - signum, - signumNorm, - toPolar, - magnitude, - magnitudeSqr, - phase, - -- * Conjugate - conjugate, - - -- * Properties - propPolar, - - -- * Auxiliary classes - Power(power), - defltPow, - ) where - --- import qualified Number.Ratio as Ratio - -import qualified Algebra.NormedSpace.Euclidean as NormedEuc -import qualified Algebra.NormedSpace.Sum as NormedSum -import qualified Algebra.NormedSpace.Maximum as NormedMax - -import qualified Algebra.VectorSpace as VectorSpace -import qualified Algebra.Module as Module -import qualified Algebra.Vector as Vector -import qualified Algebra.RealTranscendental as RealTrans -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field -import qualified Algebra.Units as Units -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable -import qualified Algebra.Indexable as Indexable - -import Algebra.ZeroTestable(isZero) -import Algebra.Module((*>), (<*>.*>), ) -import Algebra.Algebraic((^/), ) - -import qualified NumericPrelude.Elementwise as Elem -import Algebra.Additive ((<*>.+), (<*>.-), (<*>.-$), ) - -import Foreign.Storable (Storable (..), ) -import qualified Foreign.Storable.Record as Store -import Control.Applicative (liftA2, ) - -import Test.QuickCheck (Arbitrary, arbitrary, ) -import Control.Monad (liftM2, ) - -import qualified Prelude as P -import NumericPrelude.Base -import NumericPrelude.Numeric hiding (signum, exp, ) -import Text.Show.HT (showsInfixPrec, ) -import Text.Read.HT (readsInfixPrec, ) - - --- import qualified Data.Typeable as Ty - -infix 6 +:, `Cons` - -{- * The Complex type -} - --- | Complex numbers are an algebraic type. -data T a - = Cons {real :: !a -- ^ real part - ,imag :: !a -- ^ imaginary part - } - deriving (Eq) - -{-# INLINE imaginaryUnit #-} -imaginaryUnit :: Ring.C a => T a -imaginaryUnit = zero +: one - -{-# INLINE fromReal #-} -fromReal :: Additive.C a => a -> T a -fromReal x = Cons x zero - - -{-# INLINE plusPrec #-} -plusPrec :: Int -plusPrec = 6 - -instance (Show a) => Show (T a) where - showsPrec prec (Cons x y) = showsInfixPrec "+:" plusPrec prec x y - -instance (Read a) => Read (T a) where - readsPrec prec = readsInfixPrec "+:" plusPrec prec (+:) - -instance Functor T where - {-# INLINE fmap #-} - fmap f (Cons x y) = Cons (f x) (f y) - -instance (Arbitrary a) => Arbitrary (T a) where - {-# INLINE arbitrary #-} - arbitrary = liftM2 Cons arbitrary arbitrary - -instance (Storable a) => Storable (T a) where - sizeOf = Store.sizeOf store - alignment = Store.alignment store - peek = Store.peek store - poke = Store.poke store - -store :: - (Storable a) => - Store.Dictionary (T a) -store = - Store.run $ - liftA2 (+:) - (Store.element real) - (Store.element imag) - - - -{- * Functions -} - --- | Construct a complex number from real and imaginary part. -{-# INLINE (+:) #-} -(+:) :: a -> a -> T a -(+:) = Cons - --- | Construct a complex number with negated imaginary part. -{-# INLINE (-:) #-} -(-:) :: Additive.C a => a -> a -> T a -(-:) x y = Cons x (-y) - --- | The conjugate of a complex number. -{- SPECIALISE conjugate :: T Double -> T Double -} -{-# INLINE conjugate #-} -conjugate :: (Additive.C a) => T a -> T a -conjugate (Cons x y) = Cons x (-y) - --- | Scale a complex number by a real number. -{- SPECIALISE scale :: Double -> T Double -> T Double -} -{-# INLINE scale #-} -scale :: (Ring.C a) => a -> T a -> T a -scale r = fmap (r*) - --- | Exponential of a complex number with minimal type class constraints. -{-# INLINE exp #-} -exp :: (Trans.C a) => T a -> T a -exp (Cons x y) = scale (Trans.exp x) (cis y) - --- | Turn the point one quarter to the right. -{-# INLINE quarterRight #-} -{-# INLINE quarterLeft #-} -quarterRight, quarterLeft :: (Additive.C a) => T a -> T a -quarterRight (Cons x y) = Cons y (-x) -quarterLeft (Cons x y) = Cons (-y) x - -{- | Scale a complex number to magnitude 1. - -For a complex number @z@, -@'abs' z@ is a number with the magnitude of @z@, -but oriented in the positive real direction, -whereas @'signum' z@ has the phase of @z@, but unit magnitude. --} - -{- SPECIALISE signum :: T Double -> T Double -} -signum :: (Algebraic.C a, ZeroTestable.C a) => T a -> T a -signum z = - if isZero z - then zero - else scale (recip (magnitude z)) z - -{- SPECIALISE signumNorm :: T Double -> T Double -} -{-# INLINE signumNorm #-} -signumNorm :: (Algebraic.C a, NormedEuc.C a a, ZeroTestable.C a) => T a -> T a -signumNorm z = - if isZero z - then zero - else scale (recip (NormedEuc.norm z)) z - --- | Form a complex number from polar components of magnitude and phase. -{- SPECIALISE fromPolar :: Double -> Double -> T Double -} -{-# INLINE fromPolar #-} -fromPolar :: (Trans.C a) => a -> a -> T a -fromPolar r theta = scale r (cis theta) - --- | @'cis' t@ is a complex value with magnitude @1@ --- and phase @t@ (modulo @2*'pi'@). -{- SPECIALISE cis :: Double -> T Double -} -{-# INLINE cis #-} -cis :: (Trans.C a) => a -> T a -cis theta = Cons (cos theta) (sin theta) - -propPolar :: (RealTrans.C a) => T a -> Bool -propPolar z = uncurry fromPolar (toPolar z) == z - - -{- | -The nonnegative magnitude of a complex number. -This implementation respects the limited range of floating point numbers. -The trivial implementation 'magnitude' -would overflow for floating point exponents greater than -the half of the maximum admissible exponent. -We automatically drop in this implementation for 'Float' and 'Double' -by optimizer rules. -You should do so for your custom floating point types. --} -{-# INLINE floatMagnitude #-} -floatMagnitude :: (P.RealFloat a, Algebraic.C a) => T a -> a -floatMagnitude (Cons x y) = - let k = max (P.exponent x) (P.exponent y) - mk = - k - in P.scaleFloat k - (sqrt (P.scaleFloat mk x ^ 2 + - P.scaleFloat mk y ^ 2)) - -{-# INLINE [1] magnitude #-} -magnitude :: (Algebraic.C a) => T a -> a -magnitude = sqrt . magnitudeSqr - -{-# RULES - "Complex.magnitude :: Double" - magnitude = floatMagnitude :: T Double -> Double; - - "Complex.magnitude :: Float" - magnitude = floatMagnitude :: T Float -> Float; - #-} - --- like NormedEuc.normSqr with lifted class constraints -{-# INLINE magnitudeSqr #-} -magnitudeSqr :: (Ring.C a) => T a -> a -magnitudeSqr (Cons x y) = x^2 + y^2 - --- | The phase of a complex number, in the range @(-'pi', 'pi']@. --- If the magnitude is zero, then so is the phase. -{-# INLINE phase #-} -phase :: (RealTrans.C a, ZeroTestable.C a) => T a -> a -phase z = - if isZero z - then zero -- SLPJ July 97 from John Peterson - else case z of (Cons x y) -> atan2 y x - - -{- | -The function 'toPolar' takes a complex number and -returns a (magnitude, phase) pair in canonical form: -the magnitude is nonnegative, and the phase in the range @(-'pi', 'pi']@; -if the magnitude is zero, then so is the phase. --} -toPolar :: (RealTrans.C a) => T a -> (a,a) -toPolar z = (magnitude z, phase z) - - - -{- * Instances of T -} - -{- -complexTc = Ty.mkTyCon "Complex.T" -instance Ty.Typeable1 T where { typeOf1 _ = Ty.mkTyConApp complexTc [] } -instance Ty.Typeable a => Ty.Typeable (T a) where { typeOf = Ty.typeOfDefault } --} - -instance (Indexable.C a) => Indexable.C (T a) where - {-# INLINE compare #-} - compare (Cons x y) (Cons x' y') = Indexable.compare (x,y) (x',y') - -instance (ZeroTestable.C a) => ZeroTestable.C (T a) where - {-# INLINE isZero #-} - isZero (Cons x y) = isZero x && isZero y - -instance (Additive.C a) => Additive.C (T a) where - {- SPECIALISE instance Additive.C (T Float) -} - {- SPECIALISE instance Additive.C (T Double) -} - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = Cons zero zero - (+) = Elem.run2 $ Elem.with Cons <*>.+ real <*>.+ imag - (-) = Elem.run2 $ Elem.with Cons <*>.- real <*>.- imag - negate = Elem.run $ Elem.with Cons <*>.-$ real <*>.-$ imag - -instance (Ring.C a) => Ring.C (T a) where - {- SPECIALISE instance Ring.C (T Float) -} - {- SPECIALISE instance Ring.C (T Double) -} - {-# INLINE one #-} - one = Cons one zero - {-# INLINE (*) #-} - (Cons x y) * (Cons x' y') = Cons (x*x'-y*y') (x*y'+y*x') - {-# INLINE fromInteger #-} - fromInteger = fromReal . fromInteger - -instance (Absolute.C a, Algebraic.C a) => Absolute.C (T a) where - {- SPECIALISE instance Absolute.C (T Float) -} - {- SPECIALISE instance Absolute.C (T Double) -} - {-# INLINE abs #-} - {-# INLINE signum #-} - abs x = Cons (magnitude x) zero - signum = signum - -instance Vector.C T where - {-# INLINE zero #-} - zero = zero - {-# INLINE (<+>) #-} - (<+>) = (+) - {-# INLINE (*>) #-} - (*>) = scale - --- | The '(*>)' method can't replace 'scale' --- because it requires the Algebra.Module constraint -instance (Module.C a b) => Module.C a (T b) where - {-# INLINE (*>) #-} - (*>) = Elem.run2 $ Elem.with Cons <*>.*> real <*>.*> imag - -- s *> (Cons x y) = Cons (s *> x) (s *> y) - -instance (VectorSpace.C a b) => VectorSpace.C a (T b) - -instance (Additive.C a, NormedSum.C a v) => NormedSum.C a (T v) where - {-# INLINE norm #-} - norm x = NormedSum.norm (real x) + NormedSum.norm (imag x) - -instance (NormedEuc.Sqr a b) => NormedEuc.Sqr a (T b) where - {-# INLINE normSqr #-} - normSqr x = NormedEuc.normSqr (real x) + NormedEuc.normSqr (imag x) - -instance (Algebraic.C a, NormedEuc.Sqr a b) => NormedEuc.C a (T b) where - {-# INLINE norm #-} - norm = NormedEuc.defltNorm - -instance (Ord a, NormedMax.C a v) => NormedMax.C a (T v) where - {-# INLINE norm #-} - norm x = max (NormedMax.norm (real x)) (NormedMax.norm (imag x)) - - -{- - In this implementation the complex plane is structured - as an orthogonal grid induced by the divisor z'. - The coordinate of a cell within this grid is returned as quotient - and the position of the cell in the grid is returned as remainder. - The magnitude of the remainder might be larger than that of the divisor - thus the Euclidean algorithm can fail. --} - -instance (Integral.C a) => Integral.C (T a) where - divMod z z' = - let denom = magnitudeSqr z' - zBig = z * conjugate z' - q = fmap (flip div denom) zBig - in (q, z-q*z') - - -{- - This variant of divMod tries to come close to the origin. - Thus the remainder has smaller magnitude than the divisor. - This variant of divModCent can be used for Euclidean's algorithm. --} -{-# INLINE divModCent #-} -divModCent :: (Ord a, Integral.C a) => T a -> T a -> (T a, T a) -divModCent z z' = - let denom = magnitudeSqr z' - zBig = z * conjugate z' - re = divMod (real zBig) denom - im = divMod (imag zBig) denom - q = Cons (fst re) (fst im) - r = Cons (snd re) (snd im) - q' = Cons - (real q + if 2 * real r > denom then one else zero) - (imag q + if 2 * imag r > denom then one else zero) - in (q', z-q'*z') - -{-# INLINE modCent #-} -modCent :: (Ord a, Integral.C a) => T a -> T a -> T a -modCent z z' = snd (divModCent z z') - -instance (Ord a, Units.C a) => Units.C (T a) where - {-# INLINE isUnit #-} - isUnit (Cons x y) = - isUnit x && y==zero || - isUnit y && x==zero - {-# INLINE stdAssociate #-} - stdAssociate z@(Cons x y) = - let z' = if y<0 || y==0 && x<0 then negate z else z - in if real z'<=0 then quarterRight z' else z' - {-# INLINE stdUnit #-} - stdUnit z@(Cons x y) = - if z==zero - then 1 - else - let (x',sgn') = if y<0 || y==0 && x<0 - then (negate x, -1) - else (x, 1) - in if x'<=0 then quarterLeft sgn' else sgn' - - -instance (Ord a, ZeroTestable.C a, Units.C a) => PID.C (T a) where - {-# INLINE gcd #-} - gcd = euclid modCent - {-# INLINE extendedGCD #-} - extendedGCD = extendedEuclid divModCent - - -{-# INLINE [1] divide #-} -divide :: (Field.C a) => T a -> T a -> T a -divide (Cons x y) z'@(Cons x' y') = - let d = magnitudeSqr z' - in Cons ((x*x'+y*y') / d) ((y*x'-x*y') / d) - --- | Special implementation of @(\/)@ for floating point numbers --- which prevent intermediate overflows. -{-# INLINE floatDivide #-} -floatDivide :: (P.RealFloat a, Field.C a) => T a -> T a -> T a -floatDivide (Cons x y) (Cons x' y') = - let k = - max (P.exponent x') (P.exponent y') - x'' = P.scaleFloat k x' - y'' = P.scaleFloat k y' - d = x'*x'' + y'*y'' - in Cons ((x*x''+y*y'') / d) ((y*x''-x*y'') / d) - -{-# RULES - "Complex.divide :: Double" - divide = floatDivide :: T Double -> T Double -> T Double; - - "Complex.divide :: Float" - divide = floatDivide :: T Float -> T Float -> T Float; - #-} - - - - -instance (Field.C a) => Field.C (T a) where - {-# INLINE (/) #-} - (/) = divide - {-# INLINE fromRational' #-} - fromRational' = fromReal . fromRational' - -{-| - We like to build the Complex Algebraic instance - on top of the Algebraic instance of the scalar type. - This poses no problem to 'sqrt'. - However, 'Number.Complex.root' requires computing the complex argument - which is a transcendent operation. - In order to keep the type class dependencies clean - for more sophisticated algebraic number types, - we introduce a type class which actually performs the radix operation. --} -class (Algebraic.C a) => (Power a) where - power :: Rational -> T a -> T a - - -{-# INLINE defltPow #-} -defltPow :: (RealTrans.C a) => - Rational -> T a -> T a -defltPow r x = - let (mag,arg) = toPolar x - in fromPolar (mag ^/ r) - (arg * fromRational' r) - - -instance Power Float where - {-# INLINE power #-} - power = defltPow - -instance Power Double where - {-# INLINE power #-} - power = defltPow - - -instance (RealRing.C a, Algebraic.C a, Power a) => - Algebraic.C (T a) where - -- | the real part of the result is always non-negative - {-# INLINE sqrt #-} - sqrt z@(Cons x y) = if z == zero - then zero - else - let u' = sqrt ((magnitude z + abs x) / 2) - v' = abs y / (u'*2) - (u,v) = if x < 0 then (v',u') else (u',v') - in Cons u (if y < 0 then -v else v) - {-# INLINE (^/) #-} - (^/) = flip power - - -instance (RealRing.C a, RealTrans.C a, Power a) => - Trans.C (T a) where - {- SPECIALISE instance Trans.C (T Float) -} - {- SPECIALISE instance Trans.C (T Double) -} - {-# INLINE pi #-} - pi = fromReal pi - {-# INLINE exp #-} - exp = exp - {-# INLINE log #-} - log z = let (m,p) = toPolar z in Cons (log m) p - - -- use defaults for tan, tanh - - {-# INLINE sin #-} - sin (Cons x y) = Cons (sin x * cosh y) ( cos x * sinh y) - {-# INLINE cos #-} - cos (Cons x y) = Cons (cos x * cosh y) (- sin x * sinh y) - - {-# INLINE sinh #-} - sinh (Cons x y) = Cons (cos y * sinh x) (sin y * cosh x) - {-# INLINE cosh #-} - cosh (Cons x y) = Cons (cos y * cosh x) (sin y * sinh x) - - {-# INLINE asin #-} - asin z = quarterRight (log (quarterLeft z + sqrt (1 - z^2))) - {-# INLINE acos #-} - acos z = quarterRight (log (z + quarterLeft (sqrt (1 - z^2)))) - {-# INLINE atan #-} - atan z@(Cons x y) = quarterRight (log (Cons (1-y) x / sqrt (1+z^2))) - -{- use the default implementation - asinh z = log (z + sqrt (1+z^2)) - acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1))) - atanh z = log ((1+z) / sqrt (1-z^2)) --} - - -{- * legacy instances -} - -{-# INLINE legacyInstance #-} -legacyInstance :: a -legacyInstance = - error "legacy Ring.C instance for simple input of numeric literals" - -instance (Ring.C a, Eq a, Show a) => P.Num (T a) where - {-# INLINE fromInteger #-} - fromInteger = fromReal . fromInteger - {-# INLINE negate #-} - negate = negate -- for unary minus - {-# INLINE (+) #-} - (+) = legacyInstance - {-# INLINE (*) #-} - (*) = legacyInstance - {-# INLINE abs #-} - abs = legacyInstance - {-# INLINE signum #-} - signum = legacyInstance - -instance (Field.C a, Eq a, Show a) => P.Fractional (T a) where - {-# INLINE fromRational #-} - fromRational = fromRational - {-# INLINE (/) #-} - (/) = legacyInstance diff --git a/src-ghc-6.12/Number/ComplexSquareRoot.hs b/src-ghc-6.12/Number/ComplexSquareRoot.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/ComplexSquareRoot.hs +++ /dev/null @@ -1,119 +0,0 @@ -module Number.ComplexSquareRoot where - --- import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.RealField as RealField -import qualified Algebra.RealRing as RealRing --- import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import qualified Number.Complex as Complex - -import Algebra.ZeroTestable(isZero, ) - -import Test.QuickCheck (Arbitrary, arbitrary, ) - -import Control.Monad (liftM2, ) - -import qualified NumericPrelude.Numeric as NP -import NumericPrelude.Numeric hiding (recip, ) -import NumericPrelude.Base -import Prelude () - -{- | -Represent the square root of a complex number -without actually having to compute a square root. -If the Bool is False, -then the square root is represented with positive real part -or zero real part and positive imaginary part. -If the Bool is True the square root is negated. --} -data T a = Cons Bool (Complex.T a) - deriving (Show) - -{- | -You must use @fmap@ only for number type conversion. --} -instance Functor T where - fmap f (Cons n x) = Cons n (fmap f x) - -instance (ZeroTestable.C a) => ZeroTestable.C (T a) where - isZero (Cons _b s) = isZero s - -instance (ZeroTestable.C a, Eq a) => Eq (T a) where - (Cons xb xs) == (Cons yb ys) = - isZero xs && isZero ys || - xb==yb && xs==ys - -instance (Arbitrary a) => Arbitrary (T a) where - arbitrary = liftM2 Cons arbitrary arbitrary - - -fromNumber :: (RealRing.C a) => Complex.T a -> T a -fromNumber x = - Cons - (case compare zero (Complex.real x) of - LT -> False - GT -> True - EQ -> Complex.imag x < zero) - (x^2) - --- htam:Wavelet.DyadicResultant.parityFlip -toNumber :: (RealRing.C a, Complex.Power a) => T a -> Complex.T a -toNumber (Cons n x) = - case sqrt x of y -> if n then NP.negate y else y - - -one :: (Ring.C a) => T a -one = Cons False NP.one - -inUpperHalfplane :: (Additive.C a, Ord a) => Complex.T a -> Bool -inUpperHalfplane x = - case compare (Complex.imag x) zero of - GT -> True - LT -> False - EQ -> Complex.real x < zero - -mul, mulAlt, mulAlt2 :: (RealRing.C a) => T a -> T a -> T a -mul (Cons xb xs) (Cons yb ys) = - let zs = xs*ys - in Cons - ((xb /= yb) /= - case (inUpperHalfplane xs, - inUpperHalfplane ys, - inUpperHalfplane zs) of - (True,True,False) -> True - (False,False,True) -> True - _ -> False) - zs - -mulAlt (Cons xb xs) (Cons yb ys) = - let zs = xs*ys - in Cons - ((xb /= yb) /= - let xi = Complex.imag xs - yi = Complex.imag ys - zi = Complex.imag zs - in (xi>=zero) /= (yi>=zero) && - (xi>=zero) /= (zi>=zero)) - zs - -mulAlt2 (Cons xb xs) (Cons yb ys) = - let zs = xs*ys - in Cons - ((xb /= yb) /= - let xi = Complex.imag xs - yi = Complex.imag ys - zi = Complex.imag zs - in xi*yi T a -> T a -> T a -div x y = mul x (recip y) - -recip :: (RealField.C a) => T a -> T a -recip (Cons b s) = - Cons - (b /= (Complex.imag s == zero && Complex.real s < zero)) - (NP.recip s) diff --git a/src-ghc-6.12/Number/DimensionTerm.hs b/src-ghc-6.12/Number/DimensionTerm.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/DimensionTerm.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- | -Copyright : (c) Henning Thielemann 2008 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable - - -See "Algebra.DimensionTerm". --} - -module Number.DimensionTerm where - -import qualified Algebra.DimensionTerm as Dim - -import qualified Algebra.OccasionallyScalar as OccScalar -import qualified Algebra.Module as Module -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive - -import Algebra.Field ((/), fromRational', ) -import Algebra.Ring ((*), one, fromInteger, ) -import Algebra.Additive ((+), (-), zero, negate, ) -import Algebra.Module ((*>), ) - -import System.Random (Random, randomR, random) - -import Data.Tuple.HT (mapFst, ) -import NumericPrelude.Base -import Prelude () - - -{- * Number type -} - -newtype T u a = Cons a - deriving (Eq, Ord) - - -instance (Dim.C u, Show a) => Show (T u a) where - showsPrec p x = - let disect :: T u a -> (u,a) - disect (Cons y) = (undefined, y) - (u,z) = disect x - in showParen (p >= Dim.appPrec) - (showString "DimensionNumber.fromNumberWithDimension " . showsPrec Dim.appPrec u . - showString " " . showsPrec Dim.appPrec z) - - -fromNumber :: a -> Scalar a -fromNumber = Cons - -toNumber :: Scalar a -> a -toNumber (Cons x) = x - -fromNumberWithDimension :: Dim.C u => u -> a -> T u a -fromNumberWithDimension _ = Cons - -toNumberWithDimension :: Dim.C u => u -> T u a -> a -toNumberWithDimension _ (Cons x) = x - - -instance (Dim.C u, Additive.C a) => Additive.C (T u a) where - zero = Cons zero - (Cons a) + (Cons b) = Cons (a+b) - (Cons a) - (Cons b) = Cons (a-b) - negate (Cons a) = Cons (negate a) - -instance (Dim.C u, Module.C a b) => Module.C a (T u b) where - a *> (Cons b) = Cons (a *> b) - -instance (Dim.IsScalar u, Ring.C a) => Ring.C (T u a) where - one = Cons one - (Cons a) * (Cons b) = Cons (a*b) - fromInteger a = Cons (fromInteger a) - -instance (Dim.IsScalar u, Field.C a) => Field.C (T u a) where - (Cons a) / (Cons b) = Cons (a/b) - recip (Cons a) = Cons (Field.recip a) - fromRational' a = Cons (fromRational' a) - -instance (Dim.IsScalar u, OccScalar.C a b) => OccScalar.C a (T u b) where - toScalar = - OccScalar.toScalar . toNumber . rewriteDimension Dim.toScalar - toMaybeScalar = - OccScalar.toMaybeScalar . toNumber . rewriteDimension Dim.toScalar - fromScalar = - rewriteDimension Dim.fromScalar . fromNumber . OccScalar.fromScalar - -instance (Dim.C u, Random a) => Random (T u a) where - randomR (Cons l, Cons u) = mapFst Cons . randomR (l,u) - random = mapFst Cons . random - - -infixl 7 &*&, *& -infixl 7 &/& - -(&*&) :: (Dim.C u, Dim.C v, Ring.C a) => - T u a -> T v a -> T (Dim.Mul u v) a -(&*&) (Cons x) (Cons y) = Cons (x Ring.* y) - -(&/&) :: (Dim.C u, Dim.C v, Field.C a) => - T u a -> T v a -> T (Dim.Mul u (Dim.Recip v)) a -(&/&) (Cons x) (Cons y) = Cons (x Field./ y) - -mulToScalar :: (Dim.C u, Ring.C a) => - T u a -> T (Dim.Recip u) a -> a -mulToScalar x y = cancelToScalar (x &*& y) - -divToScalar :: (Dim.C u, Field.C a) => - T u a -> T u a -> a -divToScalar x y = cancelToScalar (x &/& y) - -cancelToScalar :: (Dim.C u) => - T (Dim.Mul u (Dim.Recip u)) a -> a -cancelToScalar = - toNumber . rewriteDimension Dim.cancelRight - - -recip :: (Dim.C u, Field.C a) => - T u a -> T (Dim.Recip u) a -recip (Cons x) = Cons (Field.recip x) - -unrecip :: (Dim.C u, Field.C a) => - T (Dim.Recip u) a -> T u a -unrecip (Cons x) = Cons (Field.recip x) - -sqr :: (Dim.C u, Ring.C a) => - T u a -> T (Dim.Sqr u) a -sqr x = x &*& x - -sqrt :: (Dim.C u, Algebraic.C a) => - T (Dim.Sqr u) a -> T u a -sqrt (Cons x) = Cons (Algebraic.sqrt x) - - -abs :: (Dim.C u, Absolute.C a) => T u a -> T u a -abs (Cons x) = Cons (Absolute.abs x) - -absSignum :: (Dim.C u, Absolute.C a) => T u a -> (T u a, a) -absSignum x0@(Cons x) = (abs x0, Absolute.signum x) - -scale, (*&) :: (Dim.C u, Ring.C a) => - a -> T u a -> T u a -scale x (Cons y) = Cons (x Ring.* y) - -(*&) = scale - - -rewriteDimension :: (Dim.C u, Dim.C v) => (u -> v) -> T u a -> T v a -rewriteDimension _ (Cons x) = Cons x - - -{- -type class for converting Dim types to Dim value is straight-forward - class SIDimensionType u where - dynamic :: DimensionNumber u a -> SIValue a - - instance SIDimensionType Scalar where - dynamic (DimensionNumber.Cons x) = SIValue.scalar x - - instance SIDimensionType Length where - dynamic (DimensionNumber.Cons x) = SIValue.meter * dynamic x --} - - -{- * Example constructors -} - -type Scalar a = T Dim.Scalar a -type Length a = T Dim.Length a -type Time a = T Dim.Time a -type Mass a = T Dim.Mass a -type Charge a = T Dim.Charge a -type Angle a = T Dim.Angle a -type Temperature a = T Dim.Temperature a -type Information a = T Dim.Information a - -type Frequency a = T Dim.Frequency a -type Voltage a = T Dim.Voltage a - - -scalar :: a -> Scalar a -scalar = fromNumber - -length :: a -> Length a -length = Cons - -time :: a -> Time a -time = Cons - -mass :: a -> Mass a -mass = Cons - -charge :: a -> Charge a -charge = Cons - -frequency :: a -> Frequency a -frequency = Cons - -angle :: a -> Angle a -angle = Cons - -temperature :: a -> Temperature a -temperature = Cons - -information :: a -> Information a -information = Cons - - -voltage :: a -> Voltage a -voltage = Cons diff --git a/src-ghc-6.12/Number/DimensionTerm/SI.hs b/src-ghc-6.12/Number/DimensionTerm/SI.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/DimensionTerm/SI.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2003 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable - -Special physical units: SI unit system --} - -module Number.DimensionTerm.SI ( - second, minute, hour, day, year, - hertz, - meter, - -- liter, - gramm, tonne, - -- newton, - -- pascal, - -- bar, - -- joule, - -- watt, - coulomb, - -- ampere, - volt, - -- ohm, - -- farad, - kelvin, - bit, byte, - -- baud, - - inch, foot, yard, astronomicUnit, parsec, - - SI.yocto, SI.zepto, SI.atto, SI.femto, SI.pico, SI.nano, - SI.micro, SI.milli, SI.centi, SI.deci, SI.one, SI.deca, - SI.hecto, SI.kilo, SI.mega, SI.giga, SI.tera, SI.peta, - SI.exa, SI.zetta, SI.yotta, - ) where - --- import qualified Algebra.Transcendental as Trans -import qualified Algebra.Field as Field - --- import qualified Algebra.DimensionTerm as Dim -import qualified Number.DimensionTerm as DN -import qualified Number.SI.Unit as SI - --- aimport NumericPrelude.Base hiding (length) -import NumericPrelude.Numeric hiding (one) - - -second :: Field.C a => DN.Time a -second = DN.time 1e+0 -minute :: Field.C a => DN.Time a -minute = DN.time SI.secondsPerMinute -hour :: Field.C a => DN.Time a -hour = DN.time SI.secondsPerHour -day :: Field.C a => DN.Time a -day = DN.time SI.secondsPerDay -year :: Field.C a => DN.Time a -year = DN.time SI.secondsPerYear -hertz :: Field.C a => DN.Frequency a -hertz = DN.frequency 1e+0 -meter :: Field.C a => DN.Length a -meter = DN.length 1e+0 --- liter :: Field.C a => DN.Volume a --- liter = DN.volume 1e-3 -gramm :: Field.C a => DN.Mass a -gramm = DN.mass 1e-3 -tonne :: Field.C a => DN.Mass a -tonne = DN.mass 1e+3 --- newton :: Field.C a => DN.Force a --- newton = DN.force 1e+0 --- pascal :: Field.C a => DN.Pressure a --- pascal = DN.pressure 1e+0 --- bar :: Field.C a => DN.Pressure a --- bar = DN.pressure 1e+5 --- joule :: Field.C a => DN.Energy a --- joule = DN.energy 1e+0 --- watt :: Field.C a => DN.Power a --- watt = DN.power 1e+0 -coulomb :: Field.C a => DN.Charge a -coulomb = DN.charge 1e+0 --- ampere :: Field.C a => DN.Current a --- ampere = DN.current 1e+0 -volt :: Field.C a => DN.Voltage a -volt = DN.voltage 1e+0 --- ohm :: Field.C a => DN.Resistance a --- ohm = DN.resistance 1e+0 --- farad :: Field.C a => DN.Capacitance a --- farad = DN.capacitance 1e+0 -kelvin :: Field.C a => DN.Temperature a -kelvin = DN.temperature 1e+0 -bit :: Field.C a => DN.Information a -bit = DN.information 1e+0 -byte :: Field.C a => DN.Information a -byte = DN.information SI.bytesize --- baud :: Field.C a => DN.DataRate a --- baud = DN.dataRate 1e+0 - -inch, foot, yard, astronomicUnit, parsec - :: Field.C a => DN.Length a - -inch = DN.length SI.meterPerInch -foot = DN.length SI.meterPerFoot -yard = DN.length SI.meterPerYard -astronomicUnit = DN.length SI.meterPerAstronomicUnit -parsec = DN.length SI.meterPerParsec - -{- -accelerationOfEarthGravity :: Field.C a => DN.Acceleration a -accelerationOfEarthGravity = DN.acceleration SI.accelerationOfEarthGravity - -mach :: Field.C a => DN.Speed a -speedOfLight :: Field.C a => DN.Speed a -electronVolt :: Field.C a => DN.Energy a -calorien :: Field.C a => DN.Energy a -horsePower :: Field.C a => DN.Power a - -mach = DN.speed SI.mach -speedOfLight = DN.speed SI.speedOfLight -electronVolt = DN.energy SI.electronVolt -calorien = DN.energy SI.calorien -horsePower = DN.power SI.horsePower --} diff --git a/src-ghc-6.12/Number/FixedPoint.hs b/src-ghc-6.12/Number/FixedPoint.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/FixedPoint.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2006 - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : requires multi-parameter type classes - -Fixed point numbers. -They are implemented as ratios with fixed denominator. -Many routines fail for some arguments. -When they work, -they can be useful for obtaining approximations of some constants. -We have not paid attention to rounding errors -and thus some of the trailing digits may be wrong. --} -module Number.FixedPoint where - -import qualified Algebra.RealRing as RealRing --- import qualified Algebra.Additive as Additive --- import qualified Algebra.ZeroTestable as ZeroTestable -import qualified Algebra.Transcendental as Trans -import qualified MathObj.PowerSeries.Example as PSE - -import NumericPrelude.List (mapLast, ) -import Data.Function.HT (powerAssociative, ) -import Data.List.HT (dropWhileRev, padLeft, ) -import Data.Maybe.HT (toMaybe, ) -import Data.List (transpose, unfoldr, ) -import Data.Char (intToDigit, ) - -import NumericPrelude.Base -import NumericPrelude.Numeric hiding (recip, sqrt, exp, sin, cos, tan, - fromRational') - -import qualified NumericPrelude.Numeric as NP - - -{- ** Conversion -} - -{- ** other number types -} - -fromFloat :: RealRing.C a => Integer -> a -> Integer -fromFloat den x = - round (x * NP.fromInteger den) - --- | denominator conversion -fromFixedPoint :: Integer -> Integer -> Integer -> Integer -fromFixedPoint denDst denSrc x = div (x*denDst) denSrc - - -{- ** text -} - -{- | -very efficient because it can make use of the decimal output of 'show' --} -showPositionalDec :: Integer -> Integer -> String -showPositionalDec den = liftShowPosToInt $ \x -> - let packetSize = 50 -- process digits in packets of this size - basis = ringPower packetSize 10 - (int,frac) = toPositional basis den x - in show int ++ "." ++ - concat (mapLast (dropWhileRev ('0'==)) - (map (padLeft '0' packetSize . show) frac)) - -showPositionalHex :: Integer -> Integer -> String -showPositionalHex = showPositionalBasis 16 - -showPositionalBin :: Integer -> Integer -> String -showPositionalBin = showPositionalBasis 2 - -showPositionalBasis :: Integer -> Integer -> Integer -> String -showPositionalBasis basis den = liftShowPosToInt $ \x -> - let (int,frac) = toPositional basis den x - in show int ++ "." ++ map (intToDigit . fromInteger) frac - -liftShowPosToInt :: (Integer -> String) -> (Integer -> String) -liftShowPosToInt f n = - if n>=0 - then f n - else '-' : f (-n) - -toPositional :: Integer -> Integer -> Integer -> (Integer, [Integer]) -toPositional basis den x = - let (int, frac) = divMod x den - in (int, unfoldr (\rm -> toMaybe (rm/=0) (divMod (basis*rm) den)) frac) - - -{- * Additive -} - -add :: Integer -> Integer -> Integer -> Integer -add _ = (+) - -sub :: Integer -> Integer -> Integer -> Integer -sub _ = (-) - - -{- * Ring -} - -mul :: Integer -> Integer -> Integer -> Integer -mul den x y = div (x*y) den - - -{- * Field -} - -divide :: Integer -> Integer -> Integer -> Integer -divide den x y = div (x*den) y - -recip :: Integer -> Integer -> Integer -recip den x = div (den^2) x - - -{- * Algebra -} - -{- -Newton's method for computing roots. --} - -magnitudes :: [Integer] -magnitudes = - concat (transpose [iterate (^2) 4, iterate (^2) 8]) - -{- -Maybe we can speed up the algorithm -by calling sqrt recursively on deflated arguments. --} -sqrt :: Integer -> Integer -> Integer -sqrt den x = - let xden = x*den - initial = fst (head (dropWhile ((<= xden) . snd) - (zip magnitudes (tail (tail magnitudes))))) - approxs = iterate (\y -> div (y + div xden y) 2) initial - isRoot y = y^2 <= xden && xden < (y+1)^2 - in head (dropWhile (not . isRoot) approxs) - --- bug: needs too long: root (12::Int) (fromIntegerBase 10 1000 2) -root :: Integer -> Integer -> Integer -> Integer -root n den x = - let n1 = n-1 - xden = x * den^n1 - initial = fst (head (dropWhile ((\y -> y^n <= xden) . snd) - (zip magnitudes (tail magnitudes)))) - approxs = iterate (\y -> div (n1*y + div xden (y^n1)) n) initial - isRoot y = y^n <= xden && xden < (y+1)^n - in head (dropWhile (not . isRoot) approxs) - - - -{- * Transcendental -} - --- very simple evaluation by power series with lots of rounding errors -evalPowerSeries :: [Rational] -> Integer -> Integer -> Integer -evalPowerSeries series den x = - let powers = iterate (mul den x) den - summands = zipWith (\c p -> round (c * fromInteger p)) series powers - in sum (map snd (takeWhile (\(c,s) -> s/=0 || c==0) - (zip series summands))) - -cos, sin, tan :: Integer -> Integer -> Integer -cos = evalPowerSeries PSE.cos -sin = evalPowerSeries PSE.sin --- tan will suffer from inaccuracies for small cosine -tan den x = divide den (sin den x) (cos den x) - --- it must abs x <= den -arctanSmall :: Integer -> Integer -> Integer -arctanSmall = evalPowerSeries PSE.atan - --- will fail for large inputs -arctan :: Integer -> Integer -> Integer -arctan den x = - let estimate = fromFloat den - (Trans.atan (NP.fromRational' (x % den)) :: Double) - tanEst = tan den estimate - residue = divide den (x-tanEst) (den + mul den x tanEst) - in estimate + arctanSmall den residue - -piConst :: Integer -> Integer -piConst den = - let den4 = 4*den - stArcTan k x = let d = k*den4 in arctanSmall d (div d x) - in {- formula 4 * (8 * arctan (1/10) - arctan (1/239) - 4 * arctan (1/515)) - from "Bartsch: Mathematische Formeln" -} - -- (stArcTan 8 10 - stArcTan 1 239 - stArcTan 4 515) - -- formula by Stoermer - (stArcTan 44 57 + stArcTan 7 239 - stArcTan 12 682 + stArcTan 24 12943) - - -expSmall :: Integer -> Integer -> Integer -expSmall = evalPowerSeries PSE.exp - -eConst :: Integer -> Integer -eConst den = expSmall den den - -recipEConst :: Integer -> Integer -recipEConst den = expSmall den (-den) - -exp :: Integer -> Integer -> Integer -exp den x = - let den2 = div den 2 - (int,frac) = divMod (x + den2) den - expFrac = expSmall den (frac-den2) - in case compare int 0 of - EQ -> expFrac - GT -> powerAssociative (mul den) expFrac (eConst den) int - LT -> powerAssociative (mul den) expFrac (recipEConst den) (-int) - -- LT -> nest (-int) (divide den e) expFrac - - -approxLogBase :: Integer -> Integer -> (Int, Integer) -approxLogBase base x = - until ((<=base) . snd) (\(xE,xM) -> (succ xE, div xM base)) (0,x) - -lnSmall :: Integer -> Integer -> Integer -lnSmall den x = - evalPowerSeries PSE.log den (x-den) - --- uses Double's log for an estimate and dramatic speed up -ln :: Integer -> Integer -> Integer -ln den x = - let fac = 10^50 {- A constant which is representable by Double - and which will quickly split our number it pieces - small enough for Double. -} - (denE, denM) = approxLogBase fac den - (xE, xM) = approxLogBase fac x - approxDouble :: Double - approxDouble = - log (NP.fromInteger fac) * fromIntegral (xE-denE) + - log (NP.fromInteger xM / NP.fromInteger denM) - {- We convert first with respect to @fac@ - in order to keep in the range of Double values. -} - approxFac = round (approxDouble * NP.fromInteger fac) - approx = fromFixedPoint den fac approxFac - xSmall = divide den x (exp den approx) - in add den approx (lnSmall den xSmall) diff --git a/src-ghc-6.12/Number/FixedPoint/Check.hs b/src-ghc-6.12/Number/FixedPoint/Check.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/FixedPoint/Check.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Number.FixedPoint.Check where - -import qualified Number.FixedPoint as FP - -import qualified MathObj.PowerSeries.Example as PSE - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Field as Field -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import NumericPrelude.Base -import NumericPrelude.Numeric hiding (fromRational') - -import qualified Prelude as P98 -import qualified NumericPrelude.Numeric as NP - - -{- * Types -} - -data T = Cons {denominator :: Integer, numerator :: Integer} - - -{- * Conversion -} - -cons :: Integer -> Integer -> T -cons = Cons - -{- ** other number types -} - -fromFloat :: RealRing.C a => Integer -> a -> T -fromFloat den x = - cons den (FP.fromFloat den x) - -fromInteger' :: Integer -> Integer -> T -fromInteger' den x = - cons den (x * den) - -fromRational' :: Integer -> Rational -> T -fromRational' den x = - cons den (round (x * NP.fromInteger den)) - -fromFloatBasis :: RealRing.C a => Integer -> Int -> a -> T -fromFloatBasis basis numDigits = - fromFloat (ringPower numDigits basis) - -fromIntegerBasis :: Integer -> Int -> Integer -> T -fromIntegerBasis basis numDigits = - fromInteger' (ringPower numDigits basis) - -fromRationalBasis :: Integer -> Int -> Rational -> T -fromRationalBasis basis numDigits = - fromRational' (ringPower numDigits basis) - --- | denominator conversion -fromFixedPoint :: Integer -> T -> T -fromFixedPoint denDst (Cons denSrc x) = - cons denDst (FP.fromFixedPoint denDst denSrc x) - - -{- * Lift core function -} - -lift0 :: Integer -> (Integer -> Integer) -> T -lift0 den f = Cons den (f den) - -lift1 :: (Integer -> Integer -> Integer) -> (T -> T) -lift1 f (Cons xd xn) = Cons xd (f xd xn) - -lift2 :: (Integer -> Integer -> Integer -> Integer) -> (T -> T -> T) -lift2 f (Cons xd xn) (Cons yd yn) = - commonDenominator xd yd $ Cons xd (f xd xn yn) - -commonDenominator :: Integer -> Integer -> a -> a -commonDenominator xd yd z = - if xd == yd - then z - else error "Number.FixedPoint: denominators differ" - - -{- * Show -} - -appPrec :: Int -appPrec = 10 - -instance Show T where - showsPrec p (Cons den num) = - showParen (p >= appPrec) - (showString "FixedPoint.cons " . shows den - . showString " " . shows num) - - -defltDenominator :: Integer -defltDenominator = 10^100 - -defltShow :: T -> String -defltShow (Cons den x) = - FP.showPositionalDec den x - - - -instance Additive.C T where - zero = cons defltDenominator zero - (+) = lift2 FP.add - (-) = lift2 FP.sub - negate (Cons xd xn) = Cons xd (negate xn) - - -instance Ring.C T where - one = cons defltDenominator defltDenominator - fromInteger = fromInteger' defltDenominator . NP.fromInteger - (*) = lift2 FP.mul - -- the default instance of (^) cumulates rounding errors but is faster - -- x^n = lift1 (pow n) x - - -instance Field.C T where - (/) = lift2 FP.divide - recip = lift1 FP.recip - fromRational' = fromRational' defltDenominator . NP.fromRational' - - -instance Algebraic.C T where - sqrt = lift1 FP.sqrt - root n = lift1 (FP.root n) - - --- these function are only implemented for the convergence radius of their Taylor expansions -instance Trans.C T where - pi = lift0 defltDenominator FP.piConst - exp = lift1 FP.exp - log = lift1 FP.ln - {- - logBase - (**) - -} - sin = lift1 (FP.evalPowerSeries PSE.sin) - cos = lift1 (FP.evalPowerSeries PSE.cos) - -- tan = lift1 (FP.evalPowerSeries PSE.tan) - asin = lift1 (FP.evalPowerSeries PSE.asin) - atan = lift1 FP.arctan - {- - acos = lift1 (FP.evalPowerSeries PSE.acos) - sinh = lift1 (FP.evalPowerSeries PSE.sinh) - tanh = lift1 (FP.evalPowerSeries PSE.tanh) - cosh = lift1 (FP.evalPowerSeries PSE.cosh) - asinh = lift1 (FP.evalPowerSeries PSE.asinh) - atanh = lift1 (FP.evalPowerSeries PSE.atanh) - acosh = lift1 (FP.evalPowerSeries PSE.acosh) - -} - - -instance ZeroTestable.C T where - isZero (Cons _ xn) = isZero xn - -instance Eq T where - (Cons xd xn) == (Cons yd yn) = - commonDenominator xd yd (xn==yn) - -instance Ord T where - compare (Cons xd xn) (Cons yd yn) = - commonDenominator xd yd (compare xn yn) - -instance Absolute.C T where - abs = lift1 (const abs) - signum = Absolute.signumOrd - -instance RealRing.C T where - splitFraction (Cons xd xn) = - let (int, frac) = divMod xd xn - in (fromInteger int, Cons xd frac) - - - --- legacy instances for work with GHCi -legacyInstance :: a -legacyInstance = - error "legacy Ring.C instance for simple input of numeric literals" - -instance P98.Num T where - fromInteger = fromInteger' defltDenominator - negate = negate --for unary minus - (+) = legacyInstance - (*) = legacyInstance - abs = legacyInstance - signum = legacyInstance - -instance P98.Fractional T where - fromRational = fromRational' defltDenominator . fromRational - (/) = legacyInstance diff --git a/src-ghc-6.12/Number/GaloisField2p32m5.hs b/src-ghc-6.12/Number/GaloisField2p32m5.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/GaloisField2p32m5.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{- | -This number type is intended for tests of functions over fields, -where the field elements need constant space. -This way we can provide a Storable instance. -For 'Rational' this would not be possible. - -However, be aware that sums of non-zero elements may yield zero. -Thus division is not always safe, where it is for rational numbers. --} -module Number.GaloisField2p32m5 where - -import qualified Number.ResidueClass as RC -import qualified Algebra.Module as Module -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive - -import Data.Int (Int64, ) -import Data.Word (Word32, Word64, ) - -import qualified Foreign.Storable.Newtype as SN -import qualified Foreign.Storable as St - -import Test.QuickCheck (Arbitrary(arbitrary), ) - -import NumericPrelude.Base -import NumericPrelude.Numeric - - -newtype T = Cons {decons :: Word32} - deriving Eq - -{-# INLINE appPrec #-} -appPrec :: Int -appPrec = 10 - -instance Show T where - showsPrec p (Cons x) = - showsPrec p x -{- - showParen (p >= appPrec) - (showString "GF2p32m5.Cons " . shows x) --} - -instance Arbitrary T where - arbitrary = fmap (Cons . fromInteger . flip mod base) arbitrary - -instance St.Storable T where - sizeOf = SN.sizeOf decons - alignment = SN.alignment decons - peek = SN.peek Cons - poke = SN.poke decons - - -base :: Ring.C a => a -base = 2^32-5 - - -{-# INLINE lift2 #-} -lift2 :: (Word64 -> Word64 -> Word64) -> (T -> T -> T) -lift2 f (Cons x) (Cons y) = - Cons (fromIntegral (mod (f (fromIntegral x) (fromIntegral y)) base)) - -{-# INLINE lift2Integer #-} -lift2Integer :: (Int64 -> Int64 -> Int64) -> (T -> T -> T) -lift2Integer f (Cons x) (Cons y) = - Cons (fromIntegral (mod (f (fromIntegral x) (fromIntegral y)) base)) - - -instance Additive.C T where - zero = Cons zero - (+) = lift2 (+) --- (-) = lift2 (-) - x-y = x + negate y - negate n@(Cons x) = - if x==0 - then n - else Cons (base-x) - -instance Ring.C T where - one = Cons one - (*) = lift2 (*) - fromInteger = - Cons . fromInteger . flip mod base - -instance Field.C T where - (/) = lift2Integer (RC.divide base) - -instance Module.C T T where - (*>) = (*) diff --git a/src-ghc-6.12/Number/NonNegative.hs b/src-ghc-6.12/Number/NonNegative.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/NonNegative.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{- -Rationale for -fno-warn-orphans: - * The orphan instances can't be put into Numeric.NonNegative.Wrapper - since that's in another package. - * We had to spread the instance declarations - over the modules defining the typeclasses instantiated. - Do we want that? --} - -{- | -Copyright : (c) Henning Thielemann 2007 - -Maintainer : haskell@henning-thielemann.de -Stability : stable -Portability : Haskell 98 - -A type for non-negative numbers. -It performs a run-time check at construction time (i.e. at run-time) -and is a member of the non-negative number type class -'Numeric.NonNegative.Class.C'. --} -module Number.NonNegative - (T, fromNumber, fromNumberMsg, fromNumberClip, fromNumberUnsafe, toNumber, - NonNegW.Int, NonNegW.Integer, NonNegW.Float, NonNegW.Double, - Ratio, Rational) where - -import Numeric.NonNegative.Wrapper - (T, fromNumberUnsafe, toNumber, ) -import qualified Numeric.NonNegative.Wrapper as NonNegW - -import qualified Algebra.NonNegative as NonNeg -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Field as Field -import qualified Algebra.RealIntegral as RealIntegral -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.Monoid as Monoid -import qualified Algebra.ZeroTestable as ZeroTestable - -import qualified Algebra.ToInteger as ToInteger -import qualified Algebra.ToRational as ToRational --- import Test.QuickCheck (Arbitrary(arbitrary)) - -import qualified Number.Ratio as R - -import NumericPrelude.Base -import Data.Tuple.HT (mapSnd, mapPair, ) -import NumericPrelude.Numeric hiding (Int, Integer, Float, Double, Rational, ) - - -{- | -Convert a number to a non-negative number. -If a negative number is given, an error is raised. --} -fromNumber :: (Ord a, Additive.C a) => - a - -> T a -fromNumber = fromNumberMsg "fromNumber" - -fromNumberMsg :: (Ord a, Additive.C a) => - String {- ^ name of the calling function to be used in the error message -} - -> a - -> T a -fromNumberMsg funcName x = - if x>=zero - then fromNumberUnsafe x - else error (funcName++": negative number") - -fromNumberWrap :: (Ord a, Additive.C a) => - String - -> a - -> T a -fromNumberWrap funcName = - fromNumberMsg ("Number.NonNegative."++funcName) - -{- | -Convert a number to a non-negative number. -A negative number will be replaced by zero. -Use this function with care since it may hide bugs. --} -fromNumberClip :: (Ord a, Additive.C a) => - a - -> T a -fromNumberClip = fromNumberUnsafe . max zero - - - -{- | -Results are not checked for positivity. --} -lift :: (a -> a) -> (T a -> T a) -lift f = fromNumberUnsafe . f . toNumber - -liftWrap :: (Ord a, Additive.C a) => String -> (a -> a) -> (T a -> T a) -liftWrap msg f = fromNumberWrap msg . f . toNumber - - -{- | -Results are not checked for positivity. --} -lift2 :: (a -> a -> a) -> (T a -> T a -> T a) -lift2 f x y = - fromNumberUnsafe $ f (toNumber x) (toNumber y) - - - -instance ZeroTestable.C a => ZeroTestable.C (T a) where - isZero = isZero . toNumber - -instance (Additive.C a) => Monoid.C (T a) where - idt = fromNumberUnsafe Additive.zero - x <*> y = fromNumberUnsafe (toNumber x + toNumber y) --- mconcat = fromNumberUnsafe . sum . map toNumber - -instance (Ord a, Additive.C a) => NonNeg.C (T a) where - split = NonNeg.splitDefault toNumber fromNumberUnsafe - -instance (Ord a, Additive.C a) => Additive.C (T a) where - zero = fromNumberUnsafe zero - (+) = lift2 (+) - (-) = liftWrap "-" . (-) . toNumber - negate = liftWrap "negate" negate - -instance (Ord a, Ring.C a) => Ring.C (T a) where - (*) = lift2 (*) - fromInteger = fromNumberWrap "fromInteger" . fromInteger - -instance (Ord a, ToRational.C a) => ToRational.C (T a) where - toRational = ToRational.toRational . toNumber - -instance ToInteger.C a => ToInteger.C (T a) where - toInteger = toInteger . toNumber - -{- already defined in the imported module -instance (Ord a, Additive.C a, Enum a) => Enum (T a) where - toEnum = fromNumberWrap "toEnum" . toEnum - fromEnum = fromEnum . toNumber - -instance (Ord a, Additive.C a, Bounded a) => Bounded (T a) where - minBound = fromNumberClip minBound - maxBound = fromNumberWrap "maxBound" maxBound - -instance (Additive.C a, Arbitrary a) => Arbitrary (T a) where - arbitrary = liftM (fromNumberUnsafe . abs) arbitrary --} - -instance RealIntegral.C a => RealIntegral.C (T a) where - quot = lift2 quot - rem = lift2 rem - quotRem x y = - mapPair - (fromNumberUnsafe, fromNumberUnsafe) - (quotRem (toNumber x) (toNumber y)) - -instance (Ord a, Integral.C a) => Integral.C (T a) where - div = lift2 div - mod = lift2 mod - divMod x y = - mapPair - (fromNumberUnsafe, fromNumberUnsafe) - (divMod (toNumber x) (toNumber y)) - -instance (Ord a, Field.C a) => Field.C (T a) where - fromRational' = fromNumberWrap "fromRational" . fromRational' - (/) = lift2 (/) - - -instance (ZeroTestable.C a, Ord a, Absolute.C a) => Absolute.C (T a) where - abs = lift abs - signum = lift signum - -instance (RealRing.C a) => RealRing.C (T a) where - splitFraction = mapSnd fromNumberUnsafe . splitFraction . toNumber - truncate = truncate . toNumber - round = round . toNumber - ceiling = ceiling . toNumber - floor = floor . toNumber - -instance (Ord a, Algebraic.C a) => Algebraic.C (T a) where - sqrt = lift sqrt - (^/) x r = lift (^/ r) x - -instance (Ord a, Trans.C a) => Trans.C (T a) where - pi = fromNumber pi - exp = lift exp - log = liftWrap "log" log - (**) = lift2 (**) - logBase = liftWrap "logBase" . logBase . toNumber - sin = liftWrap "sin" sin - tan = liftWrap "tan" tan - cos = liftWrap "cos" cos - asin = liftWrap "asin" asin - atan = liftWrap "atan" atan - acos = liftWrap "acos" acos - sinh = liftWrap "sinh" sinh - tanh = liftWrap "tanh" tanh - cosh = liftWrap "cosh" cosh - asinh = liftWrap "asinh" asinh - atanh = liftWrap "atanh" atanh - acosh = liftWrap "acosh" acosh - - -type Ratio a = T (R.T a) -type Rational = T R.Rational - - -{- legacy instances already defined in non-negative package -} diff --git a/src-ghc-6.12/Number/NonNegativeChunky.hs b/src-ghc-6.12/Number/NonNegativeChunky.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/NonNegativeChunky.hs +++ /dev/null @@ -1,311 +0,0 @@ -{- | -Copyright : (c) Henning Thielemann 2007-2010 - -Maintainer : haskell@henning-thielemann.de -Stability : stable -Portability : Haskell 98 - -A lazy number type, which is a generalization of lazy Peano numbers. -Comparisons can be made lazy and -thus computations are possible which are impossible with strict number types, -e.g. you can compute @let y = min (1+y) 2 in y@. -You can even work with infinite values. -However, depending on the granularity, -the memory consumption is higher than that for strict number types. -This number type is of interest for the merge operation of event lists, -which allows for co-recursive merges. --} -module Number.NonNegativeChunky - (T, fromChunks, toChunks, fromNumber, toNumber, fromChunky98, toChunky98, - minMaxDiff, normalize, isNull, isPositive, - divModLazy, divModStrict, ) where - -import qualified Numeric.NonNegative.Chunky as Chunky98 -import qualified Numeric.NonNegative.Class as NonNeg98 - -import qualified Algebra.NonNegative as NonNeg -import qualified Algebra.Field as Field -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ToInteger as ToInteger -import qualified Algebra.ToRational as ToRational -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.RealIntegral as RealIntegral -import qualified Algebra.ZeroTestable as ZeroTestable -import Algebra.ZeroTestable (isZero, ) - -import qualified Algebra.Monoid as Monoid -import qualified Data.Monoid as Mn98 - -import Control.Monad (liftM, liftM2, ) -import Data.Tuple.HT (mapFst, mapSnd, mapPair, ) - -import Test.QuickCheck (Arbitrary(arbitrary)) - -import NumericPrelude.Numeric -import NumericPrelude.Base -import qualified Prelude as P98 (Num(..), Fractional(..), ) - - -{- | -A chunky non-negative number is a list of non-negative numbers. -It represents the sum of the list elements. -It is possible to represent a finite number with infinitely many chunks -by using an infinite number of zeros. - -Note the following problems: - -Addition is commutative only for finite representations. -E.g. @let y = min (1+y) 2 in y@ is defined, -@let y = min (y+1) 2 in y@ is not. - -The type is equivalent to 'Numeric.NonNegative.Chunky'. --} -newtype T a = Cons {decons :: [a]} - - -fromChunks :: NonNeg.C a => [a] -> T a -fromChunks = Cons - -toChunks :: NonNeg.C a => T a -> [a] -toChunks = decons - -fromChunky98 :: (NonNeg.C a, NonNeg98.C a) => Chunky98.T a -> T a -fromChunky98 = fromChunks . Chunky98.toChunks - -toChunky98 :: (NonNeg.C a, NonNeg98.C a) => T a -> Chunky98.T a -toChunky98 = Chunky98.fromChunks . toChunks - -fromNumber :: NonNeg.C a => a -> T a -fromNumber = fromChunks . (:[]) - -toNumber :: NonNeg.C a => T a -> a -toNumber = Monoid.cumulate . toChunks - - - -lift2 :: NonNeg.C a => ([a] -> [a] -> [a]) -> (T a -> T a -> T a) -lift2 f x y = - fromChunks $ f (toChunks x) (toChunks y) - -{- | -Remove zero chunks. --} -normalize :: NonNeg.C a => T a -> T a -normalize = fromChunks . filter (> NonNeg.zero) . toChunks - -isNullList :: NonNeg.C a => [a] -> Bool -isNullList = null . filter (> NonNeg.zero) - -isNull :: NonNeg.C a => T a -> Bool -isNull = isNullList . toChunks - -- null . toChunks . normalize - -isPositive :: NonNeg.C a => T a -> Bool -isPositive = not . isNull - - - -{- -normalizeZT :: ZeroTestable.C a => T a -> T a -normalizeZT = fromChunks . filter (not . isZero) . toChunks --} - -isNullListZT :: ZeroTestable.C a => [a] -> Bool -isNullListZT = null . filter (not . isZero) - -isNullZT :: ZeroTestable.C a => T a -> Bool -isNullZT = isNullListZT . decons - -- null . toChunks . normalize -{- -isPositiveZT :: ZeroTestable.C a => T a -> Bool -isPositiveZT = not . isNull --} - - -check :: String -> Bool -> a -> a -check funcName b x = - if b - then x - else error ("Numeric.NonNegative.Chunky."++funcName++": negative number") - - -glue :: (NonNeg.C a) => [a] -> [a] -> ([a], (Bool, [a])) -glue [] ys = ([], (True, ys)) -glue xs [] = ([], (False, xs)) -glue (x:xs) (y:ys) = - let (z,~(zs,brs)) = - flip mapSnd (NonNeg.split x y) $ - \(b,d) -> - if b - then glue xs $ - if NonNeg.zero == d - then ys else d:ys - else glue (d:xs) ys - in (z:zs,brs) - -minMaxDiff :: (NonNeg.C a) => T a -> T a -> (T a, (Bool, T a)) -minMaxDiff (Cons xs) (Cons ys) = - let (zs, (b, rs)) = glue xs ys - in (Cons zs, (b, Cons rs)) - -equalList :: (NonNeg.C a) => [a] -> [a] -> Bool -equalList x y = - isNullList $ snd $ snd $ glue x y - -compareList :: (NonNeg.C a) => [a] -> [a] -> Ordering -compareList x y = - let (b,r) = snd $ glue x y - in if isNullList r - then EQ - else if b then LT else GT - -minList :: (NonNeg.C a) => [a] -> [a] -> [a] -minList x y = - fst $ glue x y - -maxList :: (NonNeg.C a) => [a] -> [a] -> [a] -maxList x y = - -- matching the inner pair lazily is important - let (z,~(_,r)) = glue x y in z++r - - -instance (NonNeg.C a) => Eq (T a) where - (Cons x) == (Cons y) = equalList x y - -instance (NonNeg.C a) => Ord (T a) where - compare (Cons x) (Cons y) = compareList x y - min = lift2 minList - max = lift2 maxList - - -instance (NonNeg.C a) => NonNeg.C (T a) where - split (Cons xs) (Cons ys) = - let (zs, ~(b, rs)) = glue xs ys - in (Cons zs, (b, Cons rs)) - -instance (ZeroTestable.C a) => ZeroTestable.C (T a) where - isZero = isNullZT - -instance (NonNeg.C a) => Additive.C (T a) where - zero = Monoid.idt - (+) = (Monoid.<*>) - (Cons x) - (Cons y) = - let (b,d) = snd $ glue x y - d' = Cons d - in check "-" (not b || isNull d') d' - negate x = check "negate" (isNull x) x -{- - x0 - y0 = - let d' = lift2 (\x y -> let (_,d,b) = glue x y in d) x0 y0 - in check "-" (not b || isNull d') d' --} - -instance (Ring.C a, NonNeg.C a) => Ring.C (T a) where - one = fromNumber one - (*) = lift2 (liftM2 (*)) - fromInteger = fromNumber . fromInteger - -instance (Ring.C a, ZeroTestable.C a, NonNeg.C a) => Absolute.C (T a) where - abs = id - signum = fromNumber . (\b -> if b then one else zero) . isPositive - -instance (ToInteger.C a, NonNeg.C a) => ToInteger.C (T a) where - toInteger = sum . map toInteger . toChunks - -instance (ToRational.C a, NonNeg.C a) => ToRational.C (T a) where - toRational = sum . map toRational . toChunks - - -instance (RealIntegral.C a, NonNeg.C a) => RealIntegral.C (T a) where - quot = div - rem = mod - quotRem = divMod - -{- | -'divMod' is implemented in terms of 'divModStrict'. -If it is needed we could also provide a function -that accesses the divisor first in a lazy way -and then uses a strict divisor for subsequent rounds of the subtraction loop. -This way we can handle the cases \"dividend smaller than divisor\" -and \"dividend greater than divisor\" in a lazy and efficient way. -However changing the way of operation within one number is also not nice. --} -instance (Ord a, Integral.C a, NonNeg.C a) => Integral.C (T a) where - divMod x y = - mapSnd fromNumber $ - divModStrict x (toNumber y) - -{- | -divModLazy accesses the divisor in a lazy way. -However this is only relevant if the dividend is smaller than the divisor. -For large dividends the divisor will be accessed multiple times -but since it is already fully evaluated it could also be strict. --} -divModLazy :: - (Ring.C a, NonNeg.C a) => - T a -> T a -> (T a, T a) -divModLazy x0 y0 = - let y = toChunks y0 - recourse x = - let (r,~(b,d)) = glue y x - in if not b - then ([], r) - else mapFst (one:) (recourse d) - in mapPair - (fromChunks, fromChunks) - (recourse (toChunks x0)) - -{- | -This function has a strict divisor -and maintains the chunk structure of the dividend at a smaller scale. --} -divModStrict :: - (Integral.C a, NonNeg.C a) => - T a -> a -> (T a, a) -divModStrict x0 y = - let recourse [] r = ([], r) - recourse (x:xs) r0 = - case divMod (x+r0) y of - (q,r1) -> mapFst (q:) $ recourse xs r1 - in mapFst fromChunks $ recourse (toChunks x0) zero - - - -instance (Show a) => Show (T a) where - showsPrec p x = - showParen (p>10) - (showString "Chunky.fromChunks " . showsPrec 10 (decons x)) - - -instance (NonNeg.C a, Arbitrary a) => Arbitrary (T a) where - arbitrary = liftM Cons arbitrary - - - -{- * legacy instances -} - -legacyInstance :: a -legacyInstance = - error "legacy Ring.C instance for simple input of numeric literals" - -instance (Ring.C a, Eq a, Show a, NonNeg.C a) => P98.Num (T a) where - fromInteger = fromNumber . fromInteger - negate = Additive.negate -- for unary minus - (+) = legacyInstance - (*) = legacyInstance - abs = legacyInstance - signum = legacyInstance - -instance (Field.C a, Eq a, Show a, NonNeg.C a) => P98.Fractional (T a) where - fromRational = fromNumber . fromRational - (/) = legacyInstance - -instance (NonNeg.C a) => Mn98.Monoid (T a) where - mempty = Monoid.idt - mappend = (Monoid.<*>) - -instance (NonNeg.C a) => Monoid.C (T a) where - idt = Cons [] - (<*>) = lift2 (++) diff --git a/src-ghc-6.12/Number/OccasionallyScalarExpression.hs b/src-ghc-6.12/Number/OccasionallyScalarExpression.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/OccasionallyScalarExpression.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- | -Copyright : (c) Henning Thielemann 2004 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : multi-type parameter classes (vector space) - -Physical expressions track the operations made on physical values -so we are able to give detailed information on how to resolve -unit violations. --} - -module Number.OccasionallyScalarExpression where - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import Algebra.Algebraic (sqrt, (^/)) -import qualified Algebra.OccasionallyScalar as OccScalar - -import Data.Maybe(fromMaybe) -import Data.Array(listArray,(!)) - -import NumericPrelude.Base -import NumericPrelude.Numeric - - -{- | A value of type 'T' stores information on how to resolve unit violations. - The main application of the module are certainly - Number.Physical type instances - but in principle it can also be applied to other occasionally scalar types. -} -data T a v = Cons (Term a v) v - -data Term a v = - Const - | Add (T a v) (T a v) - | Mul (T a v) (T a v) - | Div (T a v) (T a v) - -fromValue :: v -> T a v -fromValue = Cons Const - - -makeLine :: Int -> String -> String -makeLine indent str = replicate indent ' ' ++ str ++ "\n" - -showUnitError :: (Show v) => Bool -> Int -> v -> T a v -> String -showUnitError divide indent x (Cons expr y) = - let indent' = indent+2 - showSub d = showUnitError d (indent'+2) x - mulDivArr = listArray (False, True) ["multiply", "divide"] - in makeLine indent - (mulDivArr ! divide ++ - " " ++ show y ++ " by " ++ show x) ++ - case expr of - (Const) -> "" - (Add y0 y1) -> - makeLine indent' "e.g." ++ - showSub divide y0 ++ - makeLine indent' "and " ++ - showSub divide y1 - (Mul y0 y1) -> - makeLine indent' "e.g." ++ - showSub divide y0 ++ - makeLine indent' "or " ++ - showSub divide y1 - (Div y0 y1) -> - makeLine indent' "e.g." ++ - showSub divide y0 ++ - makeLine indent' "or " ++ - showSub (not divide) y1 - - -lift :: (v -> v) -> (T a v -> T a v) -lift f (Cons xe x) = Cons xe (f x) - -fromScalar :: (Show v, OccScalar.C a v) => - a -> T a v -fromScalar = OccScalar.fromScalar - -scalarMap :: (Show v, OccScalar.C a v) => - (a -> a) -> (T a v -> T a v) -scalarMap f x = OccScalar.fromScalar (f (OccScalar.toScalar x)) - -scalarMap2 :: (Show v, OccScalar.C a v) => - (a -> a -> a) -> (T a v -> T a v -> T a v) -scalarMap2 f x y = OccScalar.fromScalar (f (OccScalar.toScalar x) (OccScalar.toScalar y)) - - -instance (Show v) => Show (T a v) where - show (Cons _ x) = show x - -instance (Eq v) => Eq (T a v) where - (Cons _ x) == (Cons _ y) = x==y - -instance (Ord v) => Ord (T a v) where - compare (Cons _ x) (Cons _ y) = compare x y - -instance (Additive.C v) => Additive.C (T a v) where - zero = Cons Const zero - xe@(Cons _ x) + ye@(Cons _ y) = Cons (Add xe ye) (x+y) - xe@(Cons _ x) - ye@(Cons _ y) = Cons (Add xe ye) (x-y) - negate = lift negate - -instance (Ring.C v) => Ring.C (T a v) where - xe@(Cons _ x) * ye@(Cons _ y) = Cons (Mul xe ye) (x*y) - - fromInteger = fromValue . fromInteger - -instance (Field.C v) => Field.C (T a v) where - xe@(Cons _ x) / ye@(Cons _ y) = Cons (Div xe ye) (x/y) - fromRational' = fromValue . fromRational' - -instance (ZeroTestable.C v) => ZeroTestable.C (T a v) where - isZero (Cons _ x) = isZero x - -instance (Absolute.C v) => Absolute.C (T a v) where - {- are these definitions sensible? -} - abs = lift abs - signum = lift signum - - -{- This instance is not quite satisfying. - The expression data structure should also keep track of powers - in order to report according errors. -} -instance (Algebraic.C a, Field.C v, Show v, OccScalar.C a v) => - Algebraic.C (T a v) where - sqrt = scalarMap sqrt - x ^/ y = scalarMap (^/ y) x - -instance (Trans.C a, Field.C v, Show v, OccScalar.C a v) => - Trans.C (T a v) where - pi = fromScalar pi - log = scalarMap log - exp = scalarMap exp - logBase = scalarMap2 logBase - (**) = scalarMap2 (**) - cos = scalarMap cos - tan = scalarMap tan - sin = scalarMap sin - acos = scalarMap acos - atan = scalarMap atan - asin = scalarMap asin - cosh = scalarMap cosh - tanh = scalarMap tanh - sinh = scalarMap sinh - acosh = scalarMap acosh - atanh = scalarMap atanh - asinh = scalarMap asinh - - -instance (OccScalar.C a v, Show v) - => OccScalar.C a (T a v) where - toScalar xe@(Cons _ x) = - fromMaybe - (error (show xe ++ " is not a scalar value.\n" ++ - showUnitError True 0 x xe)) - (OccScalar.toMaybeScalar x) - toMaybeScalar (Cons _ x) = OccScalar.toMaybeScalar x - fromScalar = fromValue . OccScalar.fromScalar - - -{- - I would like to use OccasionallyScalar.toScalar - in fmap and (>>=) to allow more sophisticated error messages - for types that support more descriptive error messages. - But this requires constraints to the type arguments of - Functor and Monad. --} - - -{- Operators for lifting scalar operations to - operations on physical values -} -{- -instance Functor (T i) where - fmap f (Cons xu x) = - if Unit.isScalar xu - then OccScalar.fromScalar (f x) - else error "Physics.Quantity.Value.fmap: function for scalars, only" - -instance Monad (T i) where - (>>=) (Cons xu x) f = - if Unit.isScalar xu - then f x - else error "Physics.Quantity.Value.(>>=): function for scalars, only" - return = OccScalar.fromScalar --} diff --git a/src-ghc-6.12/Number/PartiallyTranscendental.hs b/src-ghc-6.12/Number/PartiallyTranscendental.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/PartiallyTranscendental.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Define Transcendental functions on arbitrary fields. -These functions are defined for only a few (in most cases only one) arguments, -that's why discourage making these types instances of 'Algebra.Transcendental.C'. -But instances of 'Algebra.Transcendental.C' can be useful when working with power series. -If you intent to work with power series with 'Rational' coefficients, -you might consider using @MathObj.PowerSeries.T (Number.PartiallyTranscendental.T Rational)@ -instead of @MathObj.PowerSeries.T Rational@. --} -module Number.PartiallyTranscendental (T, fromValue, toValue) where - -import qualified Algebra.Transcendental as Transcendental -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive --- import qualified Algebra.ZeroTestable as ZeroTestable - -import NumericPrelude.Numeric -import NumericPrelude.Base - -import qualified Prelude as P - - -newtype T a = Cons {toValue :: a} - deriving (Eq, Ord, Show) - -fromValue :: a -> T a -fromValue = lift0 - -lift0 :: a -> T a -lift0 = Cons - -lift1 :: (a -> a) -> (T a -> T a) -lift1 f (Cons x0) = Cons (f x0) - -lift2 :: (a -> a -> a) -> (T a -> T a -> T a) -lift2 f (Cons x0) (Cons x1) = Cons (f x0 x1) - - -instance (Additive.C a) => Additive.C (T a) where - negate = lift1 negate - (+) = lift2 (+) - (-) = lift2 (-) - zero = lift0 zero - -instance (Ring.C a) => Ring.C (T a) where - one = lift0 one - fromInteger n = lift0 (fromInteger n) - (*) = lift2 (*) - -instance (Field.C a) => Field.C (T a) where - (/) = lift2 (/) - -instance (Algebraic.C a) => Algebraic.C (T a) where - sqrt x = lift1 sqrt x - root n = lift1 (Algebraic.root n) - (^/) x y = lift1 (^/y) x - -instance (Algebraic.C a, Eq a) => Transcendental.C (T a) where - pi = undefined - exp = \0 -> 1 - sin = \0 -> 0 - cos = \0 -> 1 - tan = \0 -> 0 - x ** y = if x==1 || y==0 - then 1 - else error "partially transcendental power undefined" - log = \1 -> 0 - asin = \0 -> 0 - acos = \1 -> 0 - atan = \0 -> 0 - - - -legacyInstance :: a -legacyInstance = error "legacy Ring instance for simple input of numeric literals" - - -instance (P.Num a) => P.Num (T a) where - fromInteger n = lift0 $ P.fromInteger n - negate = P.negate -- for unary minus - (+) = legacyInstance - (*) = legacyInstance - abs = legacyInstance - signum = legacyInstance - -instance (P.Num a) => P.Fractional (T a) where - fromRational = P.fromRational - (/) = legacyInstance diff --git a/src-ghc-6.12/Number/Peano.hs b/src-ghc-6.12/Number/Peano.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/Peano.hs +++ /dev/null @@ -1,432 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2007 -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable - -Lazy Peano numbers represent natural numbers inclusive infinity. -Since they are lazily evaluated, -they are optimally for use as number type of 'Data.List.genericLength' et.al. --} -module Number.Peano where - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Units as Units -import qualified Algebra.RealIntegral as RealIntegral -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable -import qualified Algebra.Indexable as Indexable -import qualified Algebra.Monoid as Monoid - -import qualified Algebra.ToInteger as ToInteger -import qualified Algebra.ToRational as ToRational -import qualified Algebra.NonNegative as NonNeg - -import qualified Algebra.EqualityDecision as EqDec -import qualified Algebra.OrderDecision as OrdDec - -import Data.Maybe (catMaybes, ) -import Data.Array(Ix(..)) - -import qualified Prelude as P98 -import qualified NumericPrelude.Base as P -import qualified NumericPrelude.Numeric as NP -import Data.List.HT (mapAdjacent, shearTranspose, ) -import Data.Tuple.HT (mapFst, ) - -import NumericPrelude.Base -import NumericPrelude.Numeric - - -data T = Zero - | Succ T - deriving (Show, Read, Eq) - -infinity :: T -infinity = Succ infinity - -err :: String -> String -> a -err func msg = error ("Number.Peano."++func++": "++msg) - - -instance ZeroTestable.C T where - isZero Zero = True - isZero (Succ _) = False - -add :: T -> T -> T -add Zero y = y -add (Succ x) y = Succ (add x y) - -sub :: T -> T -> T -sub x y = - let (sign,z) = subNeg y x - in if sign - then err "sub" "negative difference" - else z - -subNeg :: T -> T -> (Bool, T) -subNeg Zero y = (False, y) -subNeg x Zero = (True, x) -subNeg (Succ x) (Succ y) = subNeg x y - - -mul :: T -> T -> T -mul Zero _ = Zero -mul _ Zero = Zero -mul (Succ x) y = add y (mul x y) - -fromPosEnum :: (ZeroTestable.C a, Enum a) => a -> T -fromPosEnum n = - if isZero n - then Zero - else Succ (fromPosEnum (pred n)) - -toPosEnum :: (Additive.C a, Enum a) => T -> a -toPosEnum Zero = zero -toPosEnum (Succ x) = succ (toPosEnum x) - -instance Additive.C T where - zero = Zero - (+) = add - (-) = sub - negate Zero = Zero - negate (Succ _) = err "negate" "cannot negate positive number" - -instance Ring.C T where - one = Succ Zero - (*) = mul - fromInteger n = - if n<0 - then err "fromInteger" "Peano numbers are always non-negative" - else fromPosEnum n - -instance Enum T where - pred Zero = err "pred" "Zero has no predecessor" - pred (Succ x) = x - succ = Succ - toEnum n = - if n<0 - then err "toEnum" "Peano numbers are always non-negative" - else fromPosEnum n - fromEnum = toPosEnum - enumFrom x = iterate Succ x - enumFromThen x y = - let (sign,d) = subNeg x y - in if sign - then iterate (sub d) x - else iterate (add d) x - {- - enumFromTo = - enumFromThenTo = - -} - - -{- | -If all values are completely defined, -then it holds - -> if b then x else y == ifLazy b x y - -However if @b@ is undefined, -then it is at least known that the result is larger than @min x y@. --} -ifLazy :: Bool -> T -> T -> T -ifLazy b (Succ x) (Succ y) = Succ (ifLazy b x y) -ifLazy b x y = if b then x else y - -instance EqDec.C T where - (==?) x y = ifLazy (x==y) - -instance OrdDec.C T where - (<=?) x y le gt = ifLazy (x<=y) le gt - -{- -The default instance is good for compare, -but fails for min and max. --} -instance Ord T where - compare (Succ x) (Succ y) = compare x y - compare Zero (Succ _) = LT - compare (Succ _) Zero = GT - compare Zero Zero = EQ - - min (Succ x) (Succ y) = Succ (min x y) - min _ _ = Zero - - max (Succ x) (Succ y) = Succ (max x y) - max Zero y = y - max x Zero = x - - {- - This special implementation works also for undefined < Zero. - Thanks to Peter Divianszky for the hint. - -} - _ < Zero = False - Zero < _ = True - Succ n < Succ m = n < m - - x > y = y < x - - x <= y = not (y < x) - - x >= y = not (x < y) - - -{- | cf. -To how to find the shortest list in a list of lists efficiently, -this means, also in the presence of infinite lists. - --} -argMinFull :: (T,a) -> (T,a) -> (T,a) -argMinFull (x0,xv) (y0,yv) = - let recourse (Succ x) (Succ y) = - let (z,zv) = recourse x y - in (Succ z, zv) - recourse Zero _ = (Zero,xv) - recourse _ _ = (Zero,yv) - in recourse x0 y0 - -{- | -On equality the first operand is returned. --} -argMin :: (T,a) -> (T,a) -> a -argMin x y = snd $ argMinFull x y - -argMinimum :: [(T,a)] -> a -argMinimum = snd . foldl1 argMinFull - - -argMaxFull :: (T,a) -> (T,a) -> (T,a) -argMaxFull (x0,xv) (y0,yv) = - let recourse (Succ x) (Succ y) = - let (z,zv) = recourse x y - in (Succ z, zv) - recourse x Zero = (x,xv) - recourse _ y = (y,yv) - in recourse x0 y0 - -{- | -On equality the first operand is returned. --} -argMax :: (T,a) -> (T,a) -> a -argMax x y = snd $ argMaxFull x y - -argMaximum :: [(T,a)] -> a -argMaximum = snd . foldl1 argMaxFull - - - --- isAscending - naive implementations - -{- | -@x0 <= x1 && x1 <= x2 ... @ -for possibly infinite numbers in finite lists. --} -isAscendingFiniteList :: [T] -> Bool -isAscendingFiniteList [] = True -isAscendingFiniteList (x:xs) = - let decrement (Succ y) = Just y - decrement _ = Nothing - in case x of - Zero -> isAscendingFiniteList xs - Succ xd -> - case mapM decrement xs of - Nothing -> False - Just xsd -> isAscendingFiniteList (xd : xsd) - -isAscendingFiniteNumbers :: [T] -> Bool -isAscendingFiniteNumbers = and . mapAdjacent (<=) - - --- isAscending - sophisticated implementations - explicit - -toListMaybe :: a -> T -> [Maybe a] -toListMaybe a = - let recourse Zero = [Just a] - recourse (Succ x) = Nothing : recourse x - in recourse - -{- | -In @glue x y == (z,(b,r))@ -@z@ represents @min x y@, -@r@ represents @max x y - min x y@, -and @x<=y == b@. - -Cf. Numeric.NonNegative.Chunky --} -glue :: T -> T -> (T, (Bool, T)) -glue Zero ys = (Zero, (True, ys)) -glue xs Zero = (Zero, (False, xs)) -glue (Succ xs) (Succ ys) = - mapFst Succ $ glue xs ys - -{- -Implementation notes: -We check all pairs of adjacent numbers for correct order. -We obtain a set of booleans, which must all be True. -The order of checking these booleans is crucial. -Pairs of numbers that are infinitely big or infinitely far in the list -must be checked \"last\". -Thus we order the booleans according to their computation costs -(list position + magnitude of number) -using 'shearTranspose'. --} -isAscending :: [T] -> Bool -isAscending = - and . catMaybes . concat . - shearTranspose . - mapAdjacent (\x y -> - let (costs0,(le,_)) = glue x y - in toListMaybe le costs0) - - --- isAscending - use a cost measuring data type (could generalized to a monad, when considered as Writer monad, see htam and unique-logic packages - --- following an idea of vixy http://moonpatio.com:8080/fastcgi/hpaste.fcgi/view?id=562 - -data Valuable a = Valuable {costs :: T, value :: a} - deriving (Show, Eq, Ord) - - -increaseCosts :: T -> Valuable a -> Valuable a -increaseCosts inc ~(Valuable c x) = Valuable (inc+c) x - -{- | -Compute '(&&)' with minimal costs. --} -infixr 3 &&~ -(&&~) :: Valuable Bool -> Valuable Bool -> Valuable Bool -(&&~) (Valuable xc xb) (Valuable yc yb) = - let (minc,~(le,difc)) = glue xc yc - (bCheap,bExpensive) = - if le - then (xb,yb) - else (yb,xb) - in increaseCosts minc $ - uncurry Valuable $ - if bCheap - then (difc, bExpensive) - else (Zero, False) - -andW :: [Valuable Bool] -> Valuable Bool -andW = - foldr - (\b acc -> b &&~ increaseCosts one acc) - (Valuable Zero True) - -leW :: T -> T -> Valuable Bool -leW x y = - let (minc,~(le,_difc)) = glue x y - in Valuable minc le - -isAscendingW :: [T] -> Valuable Bool -isAscendingW = - andW . mapAdjacent leW - -{- -test with - -*Number.Peano> isAscendingW [0,infinity,infinity,5] -False --} - - --- instances - -instance Absolute.C T where - signum Zero = zero - signum (Succ _) = one - abs = id - -instance ToInteger.C T where - toInteger = toPosEnum - -instance ToRational.C T where - toRational = toRational . toInteger - -instance RealIntegral.C T where - quot = div - rem = mod - quotRem = divMod - -instance Integral.C T where - div x y = fst (divMod x y) - mod x y = snd (divMod x y) - divMod x y = - let (isNeg,d) = subNeg y x - in if isNeg - then (zero,x) - else let (q,r) = divMod d y in (succ q,r) - -instance Monoid.C T where - idt = zero - (<*>) = add - cumulate = foldr add Zero - -instance NonNeg.C T where - split = glue - -instance Ix T where - range = uncurry enumFromTo - index (lower,_) i = - let (sign,offset) = subNeg lower i - in if sign - then err "index" "index out of range" - else toPosEnum offset - inRange (lower,upper) i = - isAscending [lower, i, upper] - rangeSize (lower,upper) = - toPosEnum (sub lower (succ upper)) - -instance Indexable.C T where - compare = Indexable.ordCompare - -instance Units.C T where - isUnit x = x == one - stdAssociate = id - stdUnit _ = one - stdUnitInv _ = one - -instance PID.C T where - gcd = PID.euclid mod - extendedGCD = PID.extendedEuclid divMod - -instance Bounded T where - minBound = Zero - maxBound = infinity - - - -legacyInstance :: a -legacyInstance = - error "legacy Ring.C instance for simple input of numeric literals" - -instance P98.Num T where - fromInteger = Ring.fromInteger - negate = Additive.negate -- for unary minus - (+) = add - (-) = sub - (*) = mul - signum = legacyInstance - abs = legacyInstance - --- for use with genericLength et.al. -instance P98.Real T where - toRational = P98.toRational . toInteger - -instance P98.Integral T where - rem = div - quot = mod - quotRem = divMod - div x y = fst (divMod x y) - mod x y = snd (divMod x y) - divMod x y = - let (sign,d) = subNeg y x - in if sign - then (0,x) - else let (q,r) = divMod d y in (succ q,r) - toInteger = toPosEnum diff --git a/src-ghc-6.12/Number/Physical.hs b/src-ghc-6.12/Number/Physical.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/Physical.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- | -Copyright : (c) Henning Thielemann 2003-2006 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : generic instances - -Numeric values combined with abstract Physical Units --} - -module Number.Physical where - -import qualified Number.Physical.Unit as Unit - -import Algebra.OccasionallyScalar as OccScalar -import qualified Algebra.VectorSpace as VectorSpace -import qualified Algebra.Module as Module -import qualified Algebra.Vector as Vector -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import qualified Algebra.ToInteger as ToInteger - -import Algebra.Algebraic (sqrt, (^/)) - -import qualified Number.Ratio as Ratio - -import Control.Monad(guard,liftM,liftM2) - -import Data.Maybe.HT(toMaybe) -import Data.Maybe(fromMaybe) - -import NumericPrelude.Numeric -import NumericPrelude.Base - - --- | A Physics.Quantity.Value.T combines a numeric value with a physical unit. -data T i a = Cons (Unit.T i) a - --- | Construct a physical value from a numeric value and --- the full vector representation of a unit. -quantity :: (Ord i, Enum i, Ring.C a) => [Int] -> a -> T i a -quantity v = Cons (Unit.fromVector v) - -fromScalarSingle :: a -> T i a -fromScalarSingle = Cons Unit.scalar - --- | Test for the neutral Unit.T. Also a zero has a unit! -isScalar :: T i a -> Bool -isScalar (Cons u _) = Unit.isScalar u - - -{- Using (((join.).).liftM2) you can turn madd and msub - into operations that map Maybes to Maybes -} - --- | apply a function to the numeric value while preserving the unit -lift :: (a -> b) -> T i a -> T i b -lift f (Cons xu x) = Cons xu (f x) - -lift2 :: (Eq i) => String -> (a -> b -> c) -> T i a -> T i b -> T i c -lift2 opName op x y = - fromMaybe (errorUnitMismatch opName) (lift2Maybe op x y) - -lift2Maybe :: (Eq i) => (a -> b -> c) -> T i a -> T i b -> Maybe (T i c) -lift2Maybe op (Cons xu x) (Cons yu y) = - toMaybe (xu==yu) (Cons xu (op x y)) - -lift2Gen :: (Eq i) => String -> (a -> b -> c) -> T i a -> T i b -> c -lift2Gen opName op (Cons xu x) (Cons yu y) = - if (xu==yu) - then op x y - else errorUnitMismatch opName - -errorUnitMismatch :: String -> a -errorUnitMismatch opName = - error ("Physics.Quantity.Value."++opName++": units mismatch") - - - --- | Add two values if the units match, otherwise return Nothing -addMaybe :: (Eq i, Additive.C a) => - T i a -> T i a -> Maybe (T i a) -addMaybe = lift2Maybe (+) - --- | Subtract two values if the units match, otherwise return Nothing -subMaybe :: (Eq i, Additive.C a) => - T i a -> T i a -> Maybe (T i a) -subMaybe = lift2Maybe (-) - - -scale :: (Ord i, Ring.C a) => a -> T i a -> T i a -scale x = lift (x*) - -ratPow :: Trans.C a => Ratio.T Int -> T i a -> T i a -ratPow expo (Cons xu x) = - Cons (Unit.ratScale expo xu) (x ** fromRatio expo) - -ratPowMaybe :: (Trans.C a) => - Ratio.T Int -> T i a -> Maybe (T i a) -ratPowMaybe expo (Cons xu x) = - fmap (flip Cons (x ** fromRatio expo)) (Unit.ratScaleMaybe expo xu) - -fromRatio :: (Field.C b, ToInteger.C a) => Ratio.T a -> b -fromRatio expo = fromIntegral (numerator expo) / - fromIntegral (denominator expo) - - - -instance (ZeroTestable.C v) => ZeroTestable.C (T a v) where - isZero (Cons _ x) = isZero x - -instance (Eq i, Eq a) => Eq (T i a) where - (==) = lift2Gen "(==)" (==) - -instance (Ord i, Enum i, Show a) => Show (T i a) where - --show (Cons xu x) = show x ++ " !* " ++ show (Unit.toVector xu) - show (Cons xu x) = "quantity " ++ show (Unit.toVector xu) ++ " " ++ show x - -instance (Ord i, Additive.C a) => Additive.C (T i a) where - zero = fromScalarSingle zero - -- Add two values if the units match, otherwise raise an error - (+) = lift2 "(+)" (+) - -- Subtract two values if the units match, otherwise raise an error - (-) = lift2 "(-)" (-) - negate = lift negate - -instance (Ord i, Ring.C a) => Ring.C (T i a) where - (Cons xu x) * (Cons yu y) = Cons (xu+yu) (x*y) - fromInteger = fromScalarSingle . fromInteger - -instance (Ord i, Ord a) => Ord (T i a) where - max = lift2 "max" max - min = lift2 "min" min - compare = lift2Gen "compare" compare - (<) = lift2Gen "(<)" (<) - (>) = lift2Gen "(>)" (>) - (<=) = lift2Gen "(<=)" (<=) - (>=) = lift2Gen "(>=)" (>=) - -{- - Are absolute value and signum sensible for unit values? - What is the sign, what is the absolute value? - We could see it this way: - The absolute value has no unit and - the signum contains the unit and the scalar's sign. - However the units contain also information of magnitude. - E.g. if the base unit would be gramm instead kilogramm - then the scalars would grow to a factor thousand. - - So is it better to give - the absolute value unit and the absolute value of the scalar and - the signum has no unit and the signum of the scalar? - But the unit may also carry a kind of 'negativity' inside, - e.g. the electric charge. - - It seems that there is no clear answer. - However in my synthesizer application - I need absolute values for sample rates and amplitudes. - There the second interpretation is needed. --} -instance (Ord i, Absolute.C a) => Absolute.C (T i a) where - abs = lift abs - signum (Cons _ x) = fromScalarSingle (signum x) - - -instance (Ord i, Field.C a) => Field.C (T i a) where - (Cons xu x) / (Cons yu y) = Cons (xu-yu) (x/y) - fromRational' = fromScalarSingle . fromRational' - -instance (Ord i, Algebraic.C a) => Algebraic.C (T i a) where - sqrt (Cons xu x) = Cons (Unit.ratScale 0.5 xu) (sqrt x) - Cons xu x ^/ y = - Cons (Unit.ratScale (fromRational' y) xu) (x ^/ y) - -instance (Ord i, Trans.C a) => Trans.C (T i a) where - pi = fromScalarSingle pi - log = liftM log - exp = liftM exp - logBase = liftM2 logBase - (**) = liftM2 (**) - cos = liftM cos - tan = liftM tan - sin = liftM sin - acos = liftM acos - atan = liftM atan - asin = liftM asin - cosh = liftM cosh - tanh = liftM tanh - sinh = liftM sinh - acosh = liftM acosh - atanh = liftM atanh - asinh = liftM asinh - -instance Ord i => Vector.C (T i) where - zero = zero - (<+>) = (+) - (*>) = scale - -instance (Ord i, Module.C a v) => Module.C a (T i v) where - x *> (Cons yu y) = Cons yu (x Module.*> y) - -instance (Ord i, VectorSpace.C a v) => VectorSpace.C a (T i v) - - -instance (OccScalar.C a v) - => OccScalar.C a (T i v) where - toScalar = toScalarDefault - toMaybeScalar (Cons xu x) - = guard (Unit.isScalar xu) >> toMaybeScalar x - fromScalar = fromScalarSingle . fromScalar - - - -{- Operators for lifting scalar operations to - operations on physical values -} -instance Functor (T i) where - fmap f (Cons xu x) = - if Unit.isScalar xu - then fromScalarSingle (f x) - else error "Physics.Quantity.Value.fmap: function for scalars, only" - -instance Monad (T i) where - (>>=) (Cons xu x) f = - if Unit.isScalar xu - then f x - else error "Physics.Quantity.Value.(>>=): function for scalars, only" - return = fromScalarSingle diff --git a/src-ghc-6.12/Number/Physical/Read.hs b/src-ghc-6.12/Number/Physical/Read.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/Physical/Read.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2004 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : multi-parameter type classes (VectorSpace.hs) - -Convert a human readable string to a physical value. --} - -module Number.Physical.Read where - -import qualified Number.Physical as Value -import qualified Number.Physical.UnitDatabase as Db -import qualified Algebra.VectorSpace as VectorSpace --- import Algebra.Module((*>)) -import qualified Algebra.Field as Field -import qualified Data.Map as Map -import Data.Map (Map) -import Text.ParserCombinators.Parsec -import Control.Monad(liftM) - -import NumericPrelude.Base -import NumericPrelude.Numeric - -mulPrec :: Int -mulPrec = 7 - --- How to handle the 'prec' argument? -readsNat :: (Enum i, Ord i, Read v, VectorSpace.C a v) => - Db.T i a -> Int -> ReadS (Value.T i v) -readsNat db prec = - readParen (prec>=mulPrec) - (map (\(x, rest) -> - let (Value.Cons cu c, rest') = readUnitPart (createDict db) rest - in (Value.Cons cu (c *> x), rest')) - . - readsPrec mulPrec) - -readUnitPart :: (Ord i, Field.C a) => - Map String (Value.T i a) - -> String -> (Value.T i a, String) -readUnitPart dict str = - let parseUnit = - do p <- parseProduct - rest <- many anyChar - return (product (map (\(unit,n) -> - Map.findWithDefault - (error ("unknown unit '" ++ unit ++ "'")) unit dict - ^ n) p), - rest) - in case parse parseUnit "unit" str of - Left msg -> error (show msg) - Right val -> val - - -{-| This function could also return the value, - but a list of pairs (String, Integer) is easier for testing. -} -parseProduct :: Parser [(String, Integer)] -parseProduct = - skipMany space >> - ((do p <- ignoreSpace parsePower - t <- parseProductTail - return (p : t)) <|> - parseProductTail) - -parseProductTail :: Parser [(String, Integer)] -parseProductTail = - let parseTail c f = - do _ <- ignoreSpace (char c) - p <- ignoreSpace parsePower - t <- parseProductTail - return (f p : t) - in parseTail '*' id <|> - parseTail '/' (\(x,n) -> (x,-n)) <|> - return [] - -parsePower :: Parser (String, Integer) -parsePower = - do w <- ignoreSpace (many1 (letter <|> char '\181')) - e <- liftM read (ignoreSpace (char '^') >> many1 digit) <|> return 1 - return (w,e) - -{- Turns a parser into one that ignores subsequent whitespaces. -} -ignoreSpace :: Parser a -> Parser a -ignoreSpace p = - do x <- p - skipMany space - return x - - -createDict :: Db.T i a -> Map String (Value.T i a) -createDict db = - Map.fromList (concatMap - (\Db.UnitSet {Db.unit = xu, Db.scales = s} - -> map (\Db.Scale {Db.symbol = sym, Db.magnitude = x} - -> (sym, Value.Cons xu x)) s) db) diff --git a/src-ghc-6.12/Number/Physical/Show.hs b/src-ghc-6.12/Number/Physical/Show.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/Physical/Show.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2004 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : multi-parameter type classes (VectorSpace.hs, Normalization.hs) - -Convert a physical value to a human readable string. --} - -module Number.Physical.Show where - -import qualified Number.Physical as Value -import qualified Number.Physical.UnitDatabase as Db -import Number.Physical.UnitDatabase - (UnitSet, Scale, reciprocal, magnitude, symbol, scales) - -import qualified Algebra.NormedSpace.Maximum as NormedMax -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring - -import Data.List(find) -import Data.Maybe(mapMaybe) - -import NumericPrelude.Numeric -import NumericPrelude.Base - - -mulPrec :: Int -mulPrec = 7 - -{-| Show the physical quantity in a human readable form - with respect to a given unit data base. -} -showNat :: (Ord i, Show v, Field.C a, Ord a, NormedMax.C a v) => - Db.T i a -> Value.T i v -> String -showNat db x = - let (y, unitStr) = showSplit db x - in if null unitStr - then show y - else showsPrec mulPrec y unitStr - -{-| Returns the rescaled value as number - and the unit as string. - The value can be used re-scale connected values - and display them under the label of the unit -} -showSplit :: (Ord i, Show v, Field.C a, Ord a, NormedMax.C a v) => - Db.T i a -> Value.T i v -> (v, String) -showSplit db (Value.Cons xu x) = - showScaled x (Db.positiveToFront (Db.decompose xu db)) - - -showScaled :: (Ord i, Show v, Ord a, Field.C a, NormedMax.C a v) => - v -> [UnitSet i a] -> (v, String) -showScaled x [] = (x, "") -showScaled x (us:uss) = - let (scaledX, sc) = chooseScale x us - in (scaledX, showUnitPart False (reciprocal us) sc ++ - concatMap (\us' -> - showUnitPart True (reciprocal us') (defScale us')) uss) - -{-| Choose a scale where the number becomes handy - and return the scaled number and the corresponding scale. -} -chooseScale :: (Ord i, Show v, Ord a, Field.C a, NormedMax.C a v) => - v -> UnitSet i a -> (v, Scale a) -chooseScale x us = - let sc = findCloseScale (NormedMax.norm x) ( - {- you should not reverse earlier, - otherwise the index of the default unit is wrong -} - if reciprocal us - then scales us - else reverse (scales us)) - in ((1 / magnitude sc) *> x, sc) - - -showUnitPart :: Bool -> Bool -> Scale a -> String -showUnitPart multSign rec sc = - if rec - then "/" ++ symbol sc - else -- the multiplication sign can be omitted before the first unit component - (if multSign then "*" else " ") ++ symbol sc - -defScale :: UnitSet i v -> Scale v -defScale Db.UnitSet{Db.defScaleIx=def, Db.scales=scs} = scs!!def - -findCloseScale :: (Ord a, Field.C a) => a -> [Scale a] -> Scale a -findCloseScale _ [sc] = sc -findCloseScale x (sc:scs) = - if 0.9 * magnitude sc < x - then sc - else findCloseScale x scs -findCloseScale _ _ = - error "There must be at least one scale for a unit." - -{-| unused -} -totalDefScale :: Ring.C a => Db.T i a -> a -totalDefScale = - foldr (\us -> (magnitude (defScale us) *)) 1 - -{-| unused -} -getUnit :: Ring.C a => String -> Db.T i a -> Value.T i a -getUnit sym = Db.extractOne . - (mapMaybe (\Db.UnitSet{Db.unit=u, scales=scs} -> - fmap (Value.Cons u . magnitude) (find ((sym==) . symbol) scs))) diff --git a/src-ghc-6.12/Number/Physical/Unit.hs b/src-ghc-6.12/Number/Physical/Unit.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/Physical/Unit.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2003-2006 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable - -Abstract Physical Units --} - -module Number.Physical.Unit where - -import MathObj.DiscreteMap (strip) -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Maybe(fromJust,fromMaybe) - -import qualified Number.Ratio as Ratio - -import Data.Maybe.HT(toMaybe) - -import NumericPrelude.Base -import NumericPrelude.Numeric - -{- | A Unit.T is a sparse vector with integer entries - Each map n->m means that the unit of the n-th dimension - is given m times. - - Example: Let the quantity of length (meter, m) be the zeroth dimension - and let the quantity of time (second, s) be the first dimension, - then the composed unit "m_s²" corresponds to the Map - [(0,1),(1,-2)] - - In future I want to have more abstraction here, - e.g. a type class from the Edison project - that abstracts from the underlying implementation. - Then one can easily switch between - Arrays, Binary trees (like Map) and what know I. --} -type T i = Map i Int - --- | The neutral Unit.T -scalar :: T i -scalar = Map.empty - --- | Test for the neutral Unit.T -isScalar :: T i -> Bool -isScalar = Map.null - --- | Convert a List to sparse Map representation --- Example: [-1,0,-2] -> [(0,-1),(2,-2)] -fromVector :: (Enum i, Ord i) => [Int] -> T i -fromVector x = strip (Map.fromList (zip [toEnum 0 .. toEnum ((length x)-1)] x)) - --- | Convert Map to a List -toVector :: (Enum i, Ord i) => T i -> [Int] -toVector x = map (flip (Map.findWithDefault 0) x) - [(toEnum 0)..(maximum (Map.keys x))] - - -ratScale :: Ratio.T Int -> T i -> T i -ratScale expo = - fmap (fromMaybe (error "Physics.Quantity.Unit.ratScale: fractional result")) . - ratScaleMaybe2 expo - -ratScaleMaybe :: Ratio.T Int -> T i -> Maybe (T i) -ratScaleMaybe expo u = - let fmMaybe = ratScaleMaybe2 expo u - in toMaybe (not (Nothing `elem` Map.elems fmMaybe)) - (fmap fromJust fmMaybe) - --- helper function for ratScale and ratScaleMaybe -ratScaleMaybe2 :: Ratio.T Int -> T i -> Map i (Maybe Int) -ratScaleMaybe2 expo = - fmap (\c -> let y = Ratio.scale c expo - in toMaybe (denominator y == 1) (numerator y)) - - -{- impossible because Unit.T is a type synonyme but not a data type -instance Show (Unit.T i) where - show = show.toVector --} diff --git a/src-ghc-6.12/Number/Physical/UnitDatabase.hs b/src-ghc-6.12/Number/Physical/UnitDatabase.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/Physical/UnitDatabase.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2003 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable - -Tools for creating a data base of physical units -and for extracting data from it --} - -module Number.Physical.UnitDatabase where - -import qualified Number.Physical.Unit as Unit -import qualified Algebra.Field as Field - --- import Algebra.Module((*>)) -import Algebra.NormedSpace.Sum(norm) - -import Data.Maybe.HT (toMaybe) -import Data.List (findIndices, partition, unfoldr, find, minimumBy) - -import NumericPrelude.Base -import NumericPrelude.Numeric - -type T i a = [UnitSet i a] - --- since field names are reused for accessor functions --- they are global identifiers and can't be reused -data InitUnitSet i a = - InitUnitSet { - initUnit :: Unit.T i, - initIndependent :: Bool, - initScales :: [InitScale a] - } - -data InitScale a = - InitScale { - initSymbol :: String, - initMag :: a, - initIsUnit :: Bool, - initDefault :: Bool - } - --- | An entry for a unit and there scalings. -data UnitSet i a = - UnitSet { - unit :: Unit.T i, - independent :: Bool, - defScaleIx :: Int, - reciprocal :: Bool, {-^ If True the symbols must be preceded with a '/'. - Though it sounds like an attribute of Scale - it must be the same for all scales and we need it - to sort positive powered unitsets to the front - of the list of unit components. -} - scales :: [Scale a] - } - deriving Show - --- | A common scaling for a unit. -data Scale a = - Scale { - symbol :: String, - magnitude :: a - } - deriving Show - - --- extract the element from a list containing exact one element --- fails if there are zero or more than one element --- 'head' fails only if there are zero elements -extractOne :: [a] -> a -extractOne (x:[]) = x -extractOne _ = error "There must be exactly one default unit in the data base." - -initScale :: String -> a -> Bool -> Bool -> InitScale a -initScale = InitScale -initUnitSet :: Unit.T i -> Bool -> [InitScale a] -> InitUnitSet i a -initUnitSet = InitUnitSet - -createScale :: InitScale a -> Scale a -createScale (InitScale sym mg _ _) = (Scale sym mg) - -createUnitSet :: InitUnitSet i a -> UnitSet i a -createUnitSet (InitUnitSet u ind scs) = (UnitSet u ind - (extractOne (findIndices initDefault scs)) - False - (map createScale scs) - ) - -{- Filter out all scales intended for showing. - If there is none return Nothing. -} -showableUnit :: InitUnitSet i a -> Maybe (InitUnitSet i a) -showableUnit (InitUnitSet u ind scs) = - let sscs = filter initIsUnit scs - in toMaybe (not (null sscs)) (InitUnitSet u ind sscs) - - -{- | Raise all scales of a unit and the unit itself to the n-th power -} -powerOfUnitSet :: (Ord i, Field.C a) => Int -> UnitSet i a -> UnitSet i a -powerOfUnitSet n us@UnitSet { unit = u, reciprocal = rec, scales = scs } = - us { unit = n *> u, - reciprocal = rec == (n>0), -- flip sign - scales = map (powerOfScale n) scs } - - -powerOfScale :: Field.C a => Int -> Scale a -> Scale a -powerOfScale n Scale { symbol = sym, magnitude = mag } = - if n>0 - then Scale { symbol = sym ++ showExp n, magnitude = ringPower n mag } - else Scale { symbol = sym ++ showExp (-n), magnitude = fieldPower n mag } - -showExp :: Int -> String -showExp 1 = "" ---showExp 2 = "²" ---showExp 3 = "³" -showExp expo = "^" ++ show expo - - -{- | Reorder the unit components in a way - that the units with positive exponents lead the list. -} -positiveToFront :: [UnitSet i a] -> [UnitSet i a] -positiveToFront = uncurry (++) . partition (not . reciprocal) - --- | Decompose a complex unit into common ones -decompose :: (Ord i, Field.C a) => Unit.T i -> T i a -> [UnitSet i a] -decompose u db = - case (findIndep u db) of - Just us -> [us] - Nothing -> - unfoldr (\urem -> - toMaybe (not (Unit.isScalar urem)) - (let us = findClosest urem db - in (us, subtract (unit us) urem)) - ) u - -findIndep :: (Eq i) => Unit.T i -> T i a -> Maybe (UnitSet i a) -findIndep u = find (\UnitSet {unit=un} -> u==un) . filter independent - -findClosest :: (Ord i, Field.C a) => Unit.T i -> T i a -> UnitSet i a -findClosest u = - fst . minimumBy (\(_,dist0) (_,dist1) -> compare dist0 dist1) . - evalDist u . filter (not.independent) - -evalDist :: (Ord i, Field.C a) - => Unit.T i - -> T i a - -> [(UnitSet i a, Int)] {-^ (UnitSet,distance) the UnitSet may contain powered units -} -evalDist target = map (\us-> - let (expo,dist)=findBestExp target (unit us) - in (powerOfUnitSet expo us, dist) - ) - -findBestExp :: (Ord i) => Unit.T i -> Unit.T i -> (Int, Int) -findBestExp target u = - let bestl = findMinExp (distances target (listMultiples (subtract u) (-1))) - bestr = findMinExp (distances target (listMultiples ((+) u) 1 )) - in if distLE bestl bestr - then bestl - else bestr - -{-| - Find the exponent that lead to minimal distance - Since the list is infinite 'maximum' will fail - but the sequence is convex - and thus we can abort when the distance stop falling --} -findMinExp :: [(Int, Int)] -> (Int, Int) -findMinExp (x0:x1:rest) = - if distLE x0 x1 - then x0 - else findMinExp (x1:rest) -findMinExp _ = error "List of unit approximations with respect to the unit exponent must be infinite." - -distLE :: (Int, Int) -> (Int, Int) -> Bool -distLE (_,dist0) (_,dist1) = dist0<=dist1 ---distLE (exp0,dist0) (exp1,dist1) = (dist0 [(exponent,distance)] -distances :: (Ord i) => Unit.T i -> [(Int, Unit.T i)] -> [(Int, Int)] -distances targetu = map (\(expo,u)->(expo, norm (subtract u targetu))) - -listMultiples :: (Unit.T i -> Unit.T i) -> Int -> [(Int, Unit.T i)] -listMultiples f dir = iterate (\(expo,u)->(expo+dir,f u)) (0,Unit.scalar) diff --git a/src-ghc-6.12/Number/Positional.hs b/src-ghc-6.12/Number/Positional.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/Positional.hs +++ /dev/null @@ -1,1465 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2006 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional - - -Exact Real Arithmetic - Computable reals. -Inspired by ''The most unreliable technique for computing pi.'' -See also . --} -module Number.Positional where - -import qualified MathObj.LaurentPolynomial as LPoly -import qualified MathObj.Polynomial.Core as Poly - -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Ring as Ring --- import qualified Algebra.Additive as Additive -import qualified Algebra.ToInteger as ToInteger - -import qualified Prelude as P98 -import qualified NumericPrelude.Numeric as NP - -import NumericPrelude.Base -import NumericPrelude.Numeric hiding (sqrt, tan, one, zero, ) - -import qualified Data.List as List -import Data.Char (intToDigit) - -import qualified Data.List.Match as Match -import Data.Function.HT (powerAssociative, nest, ) -import Data.Tuple.HT (swap, ) -import Data.Maybe.HT (toMaybe, ) -import Data.Bool.HT (select, if', ) -import NumericPrelude.List (mapLast, ) -import Data.List.HT - (sliceVertical, mapAdjacent, - padLeft, padRight, ) - - -{- -FIXME: - -defltBase = 10 -defltExp = 4 - -(sqrt 0.5) -- wrong result, probably due to undetected overflows --} - -{- * types -} - -type T = (Exponent, Mantissa) -type FixedPoint = (Integer, Mantissa) -type Mantissa = [Digit] -type Digit = Int -type Exponent = Int -type Basis = Int - - -{- * basic helpers -} - -moveToZero :: Basis -> Digit -> (Digit,Digit) -moveToZero b n = - let b2 = div b 2 - (q,r) = divMod (n+b2) b - in (q,r-b2) - -checkPosDigit :: Basis -> Digit -> Digit -checkPosDigit b d = - if d>=0 && d Digit -> Digit -checkDigit b d = - if abs d < b - then d - else error ("digit " ++ show d ++ " out of range (" - ++ show (-b) ++ "," ++ show b ++ ")") - -{- | -Converts all digits to non-negative digits, -that is the usual positional representation. -However the conversion will fail -when the remaining digits are all zero. -(This cannot be improved!) --} -nonNegative :: Basis -> T -> T -nonNegative b x = - let (xe,xm) = compress b x - in (xe, nonNegativeMant b xm) - -{- | -Requires, that no digit is @(basis-1)@ or @(1-basis)@. -The leading digit might be negative and might be @-basis@ or @basis@. --} -nonNegativeMant :: Basis -> Mantissa -> Mantissa -nonNegativeMant b = - let recurse (x0:x1:xs) = - select (replaceZeroChain x0 (x1:xs)) - [(x1 >= 1, x0 : recurse (x1:xs)), - (x1 <= -1, (x0-1) : recurse ((x1+b):xs))] - recurse xs = xs - - replaceZeroChain x xs = - let (xZeros,xRem) = span (0==) xs - in case xRem of - [] -> (x:xs) -- keep trailing zeros, because they show precision in 'show' functions - (y:ys) -> - if y>=0 -- equivalent to y>0 - then x : Match.replicate xZeros 0 ++ recurse xRem - else (x-1) : Match.replicate xZeros (b-1) ++ recurse ((y+b) : ys) - - in recurse - - -{- | -May prepend a digit. --} -compress :: Basis -> T -> T -compress _ x@(_, []) = x -compress b (xe, xm) = - let (hi:his,los) = unzip (map (moveToZero b) xm) - in prependDigit hi (xe, Poly.add his los) - -{- | -Compress first digit. -May prepend a digit. --} -compressFirst :: Basis -> T -> T -compressFirst _ x@(_, []) = x -compressFirst b (xe, x:xs) = - let (hi,lo) = moveToZero b x - in prependDigit hi (xe, lo:xs) - -{- | -Does not prepend a digit. --} -compressMant :: Basis -> Mantissa -> Mantissa -compressMant _ [] = [] -compressMant b (x:xs) = - let (his,los) = unzip (map (moveToZero b) xs) - in Poly.add his (x:los) - -{- | -Compress second digit. -Sometimes this is enough to keep the digits in the admissible range. -Does not prepend a digit. --} -compressSecondMant :: Basis -> Mantissa -> Mantissa -compressSecondMant b (x0:x1:xs) = - let (hi,lo) = moveToZero b x1 - in x0+hi : lo : xs -compressSecondMant _ xm = xm - -prependDigit :: Basis -> T -> T -prependDigit 0 x = x -prependDigit x (xe, xs) = (xe+1, x:xs) - -{- | -Eliminate leading zero digits. -This will fail for zero. --} -trim :: T -> T -trim (xe,xm) = - let (xZero, xNonZero) = span (0 ==) xm - in (xe - length xZero, xNonZero) - -{- | -Trim until a minimum exponent is reached. -Safe for zeros. --} -trimUntil :: Exponent -> T -> T -trimUntil e = - until (\(xe,xm) -> xe<=e || - not (null xm || head xm == 0)) trimOnce - -trimOnce :: T -> T -trimOnce (xe,[]) = (xe-1,[]) -trimOnce (xe,0:xm) = (xe-1,xm) -trimOnce x = x - -{- | -Accept a high leading digit for the sake of a reduced exponent. -This eliminates one leading digit. -Like 'pumpFirst' but with exponent management. --} -decreaseExp :: Basis -> T -> T -decreaseExp b (xe,xm) = - (xe-1, pumpFirst b xm) - -{- | -Merge leading and second digit. -This is somehow an inverse of 'compressMant'. --} -pumpFirst :: Basis -> Mantissa -> Mantissa -pumpFirst b xm = - case xm of - (x0:x1:xs) -> x0*b+x1:xs - (x0:[]) -> x0*b:[] - [] -> [] - -decreaseExpFP :: Basis -> (Exponent, FixedPoint) -> - (Exponent, FixedPoint) -decreaseExpFP b (xe,xm) = - (xe-1, pumpFirstFP b xm) - -pumpFirstFP :: Basis -> FixedPoint -> FixedPoint -pumpFirstFP b (x,xm) = - let xb = x * fromIntegral b - in case xm of - (x0:xs) -> (xb + fromIntegral x0, xs) - [] -> (xb, []) - -{- | -Make sure that a number with absolute value less than 1 -has a (small) negative exponent. -Also works with zero because it chooses an heuristic exponent for stopping. --} -negativeExp :: Basis -> T -> T -negativeExp b x = - let tx = trimUntil (-10) x - in if fst tx >=0 then decreaseExp b tx else tx - - -{- * conversions -} - -{- ** integer -} - -fromBaseCardinal :: Basis -> Integer -> T -fromBaseCardinal b n = - let mant = mantissaFromCard b n - in (length mant - 1, mant) - -fromBaseInteger :: Basis -> Integer -> T -fromBaseInteger b n = - if n<0 - then neg b (fromBaseCardinal b (negate n)) - else fromBaseCardinal b n - -mantissaToNum :: Ring.C a => Basis -> Mantissa -> a -mantissaToNum bInt = - let b = fromIntegral bInt - in foldl (\x d -> x*b + fromIntegral d) 0 - -mantissaFromCard :: (ToInteger.C a) => Basis -> a -> Mantissa -mantissaFromCard bInt n = - let b = NP.fromIntegral bInt - in reverse (map NP.fromIntegral - (Integral.decomposeVarPositional (repeat b) n)) - -mantissaFromInt :: (ToInteger.C a) => Basis -> a -> Mantissa -mantissaFromInt b n = - if n<0 - then negate (mantissaFromCard b (negate n)) - else mantissaFromCard b n - -mantissaFromFixedInt :: Basis -> Exponent -> Integer -> Mantissa -mantissaFromFixedInt bInt e n = - let b = NP.fromIntegral bInt - in map NP.fromIntegral (uncurry (:) (List.mapAccumR - (\x () -> divMod x b) - n (replicate (pred e) ()))) - - -{- ** rational -} - -fromBaseRational :: Basis -> Rational -> T -fromBaseRational bInt x = - let b = NP.fromIntegral bInt - xDen = denominator x - (xInt,xNum) = divMod (numerator x) xDen - (xe,xm) = fromBaseInteger bInt xInt - xFrac = List.unfoldr - (\num -> toMaybe (num/=0) (divMod (num*b) xDen)) xNum - in (xe, xm ++ map NP.fromInteger xFrac) - -{- ** fixed point -} - -{- | -Split into integer and fractional part. --} -toFixedPoint :: Basis -> T -> FixedPoint -toFixedPoint b (xe,xm) = - if xe>=0 - then let (x0,x1) = splitAtPadZero (xe+1) xm - in (mantissaToNum b x0, x1) - else (0, replicate (- succ xe) 0 ++ xm) - -fromFixedPoint :: Basis -> FixedPoint -> T -fromFixedPoint b (xInt,xFrac) = - let (xe,xm) = fromBaseInteger b xInt - in (xe, xm++xFrac) - - -{- ** floating point -} - -toDouble :: Basis -> T -> Double -toDouble b (xe,xm) = - let txm = take (mantLengthDouble b) xm - bf = fromIntegral b - br = recip bf - in fieldPower xe bf * foldr (\xi y -> fromIntegral xi + y*br) 0 txm - -{- | -cf. 'Numeric.floatToDigits' --} -fromDouble :: Basis -> Double -> T -fromDouble b x = - let (n,frac) = splitFraction x - (mant,e) = P98.decodeFloat frac - fracR = alignMant b (-1) - (fromBaseRational b (mant % ringPower (-e) 2)) - in fromFixedPoint b (n, fracR) - -{- | -Only return as much digits as are contained in Double. -This will speedup further computations. --} -fromDoubleApprox :: Basis -> Double -> T -fromDoubleApprox b x = - let (xe,xm) = fromDouble b x - in (xe, take (mantLengthDouble b) xm) - -fromDoubleRough :: Basis -> Double -> T -fromDoubleRough b x = - let (xe,xm) = fromDouble b x - in (xe, take 2 xm) - -mantLengthDouble :: Basis -> Exponent -mantLengthDouble b = - let fi = fromIntegral :: Int -> Double - x = undefined :: Double - in ceiling - (logBase (fi b) (fromInteger (P98.floatRadix x)) * - fi (P98.floatDigits x)) - -liftDoubleApprox :: Basis -> (Double -> Double) -> T -> T -liftDoubleApprox b f = fromDoubleApprox b . f . toDouble b - -liftDoubleRough :: Basis -> (Double -> Double) -> T -> T -liftDoubleRough b f = fromDoubleRough b . f . toDouble b - - -{- ** text -} - -{- | -Show a number with respect to basis @10^e@. --} -showDec :: Exponent -> T -> String -showDec = showBasis 10 - -showHex :: Exponent -> T -> String -showHex = showBasis 16 - -showBin :: Exponent -> T -> String -showBin = showBasis 2 - -showBasis :: Basis -> Exponent -> T -> String -showBasis b e xBig = - let x = rootBasis b e xBig - (sign,absX) = - case cmp b x (fst x,[]) of - LT -> ("-", neg b x) - _ -> ("", x) - (int, frac) = toFixedPoint b (nonNegative b absX) - checkedFrac = map (checkPosDigit b) frac - intStr = - if b==10 - then show int - else map intToDigit (mantissaFromInt b int) - in sign ++ intStr ++ '.' : map intToDigit checkedFrac - - -{- ** basis -} - -{- | -Convert from a @b@ basis representation to a @b^e@ basis. - -Works well with every exponent. --} -powerBasis :: Basis -> Exponent -> T -> T -powerBasis b e (xe,xm) = - let (ye,r) = divMod xe e - (y0,y1) = splitAtPadZero (r+1) xm - y1pad = mapLast (padRight 0 e) (sliceVertical e y1) - in (ye, map (mantissaToNum b) (y0 : y1pad)) - -{- | -Convert from a @b^e@ basis representation to a @b@ basis. - -Works well with every exponent. --} -rootBasis :: Basis -> Exponent -> T -> T -rootBasis b e (xe,xm) = - let splitDigit d = padLeft 0 e (mantissaFromInt b d) - in nest (e-1) trimOnce - ((xe+1)*e-1, concatMap splitDigit (map (checkDigit (ringPower e b)) xm)) - -{- | -Convert between arbitrary bases. -This conversion is expensive (quadratic time). --} -fromBasis :: Basis -> Basis -> T -> T -fromBasis bDst bSrc x = - let (int,frac) = toFixedPoint bSrc x - in fromFixedPoint bDst (int, fromBasisMant bDst bSrc frac) - -fromBasisMant :: Basis -> Basis -> Mantissa -> Mantissa -fromBasisMant _ _ [] = [] -fromBasisMant bDst bSrc xm = - let {- We use a counter that alerts us, - when the digits are grown too much by Poly.scale. - Then it is time to do some carry/compression. - 'inc' is essentially the fractional number digits - needed to represent the destination base in the source base. - It is multiplied by 'unit' in order to allow integer computation. -} - inc = ceiling - (logBase (fromIntegral bSrc) (fromIntegral bDst) - * unit * 1.1 :: Double) - -- Without the correction factor, invalid digits are emitted - why? - unit :: Ring.C a => a - unit = 10000 - {- - This would create finite representations - in some cases (input is finite, and the result is finite) - but will cause infinite loop otherwise. - dropWhileRev (0==) . compressMant bDst - -} - cmpr (mag,xs) = (mag - unit, compressMant bSrc xs) - - scl (_,[]) = Nothing - scl (mag,xs) = - let (newMag,y:ys) = - until (( T -> T -> Ordering -cmp b x y = - let (_,dm) = sub b x y - {- Only differences above 2 allow a safe decision, - because 1(-9)(-9)(-9)(-9)... and (-1)9999... - represent the same number, namely zero. -} - recurse [] = EQ - recurse (d:[]) = compare d 0 - recurse (d0:d1:ds) = - select (recurse (d0*b+d1 : ds)) - [(d0 < -2, LT), - (d0 > 2, GT)] - in recurse dm - -{- -Compare two numbers approximately. -This circumvents the infinite loop if both numbers are equal. -If @lessApprox bnd b x y@ -then @x@ is definitely smaller than @y@. -The converse is not true. -You should use this one instead of 'cmp' for checking for bounds. --} -lessApprox :: Basis -> Exponent -> T -> T -> Bool -lessApprox b bnd x y = - let tx = trunc bnd x - ty = trunc bnd y - in LT == cmp b (liftLaurent2 LPoly.add (bnd,[2]) tx) ty - -trunc :: Exponent -> T -> T -trunc bnd (xe, xm) = - if bnd > xe - then (bnd, []) - else (xe, take (1+xe-bnd) xm) - -equalApprox :: Basis -> Exponent -> T -> T -> Bool -equalApprox b bnd x y = - fst (trimUntil bnd (sub b x y)) == bnd - - -{- | -If all values are completely defined, -then it holds - -> if b then x else y == ifLazy b x y - -However if @b@ is undefined, -then it is at least known that the result is between @x@ and @y@. --} -ifLazy :: Basis -> Bool -> T -> T -> T -ifLazy b c x@(xe, _) y@(ye, _) = - let ze = max xe ye - xm = alignMant b ze x - ym = alignMant b ze y - recurse :: Mantissa -> Mantissa -> Mantissa - recurse xs0 ys0 = - withTwoMantissas xs0 ys0 [] $ \(x0,xs1) (y0,ys1) -> - if abs (y0-x0) > 2 - then if c then xs0 else ys0 - else - {- - @x0==y0 || c@ means that in case of @x0==y0@ - we do not have to check @c@. - -} - withTwoMantissas xs1 ys1 ((if x0==y0 || c then x0 else y0) : []) $ - \(x1,xs2) (y1,ys2) -> - {- - We can choose @z0@ only when knowing also x1 and y1. - Because of x0x1 = 09 and y0y1 = 19 - we may always choose the larger one of x0 and y0 - in order to get admissible digit z1. - But this would be wrong for x0x1 = 0(-9) and y0y1 = 1(-9). - -} - let z0 = mean2 b (x0,x1) (y0,y1) - x1' = x1+(x0-z0)*b - y1' = y1+(y0-z0)*b - in if abs x1' < b && abs y1' < b - then z0 : recurse (x1':xs2) (y1':ys2) - else if c then xs0 else ys0 - in (ze, recurse xm ym) - -{- | -> mean2 b (x0,x1) (y0,y1) - -computes @ round ((x0.x1 + y0.y1)/2) @, -where @x0.x1@ and @y0.y1@ are positional rational numbers -with respect to basis @b@ --} -{-# INLINE mean2 #-} -mean2 :: Basis -> (Digit,Digit) -> (Digit,Digit) -> Digit -mean2 b (x0,x1) (y0,y1) = - ((x0+y0+1)*b + (x1+y1)) `div` (2*b) - -{- -In a first trial I used - -> zipMantissas :: Mantissa -> Mantissa -> [(Digit, Digit)] - -for implementation of ifLazy. -However, this required to extract digits from the pairs -after the decision for an argument. -With withTwoMantissas we can just return a pointer to the original list. --} -withTwoMantissas :: - Mantissa -> Mantissa -> - a -> - ((Digit,Mantissa) -> (Digit,Mantissa) -> a) -> - a -withTwoMantissas [] [] r _ = r -withTwoMantissas [] (y:ys) _ f = f (0,[]) (y,ys) -withTwoMantissas (x:xs) [] _ f = f (x,xs) (0,[]) -withTwoMantissas (x:xs) (y:ys) _ f = f (x,xs) (y,ys) - - -align :: Basis -> Exponent -> T -> T -align b ye x = (ye, alignMant b ye x) - -{- | -Get the mantissa in such a form -that it fits an expected exponent. - -@x@ and @(e, alignMant b e x)@ represent the same number. --} -alignMant :: Basis -> Exponent -> T -> Mantissa -alignMant b e (xe,xm) = - if e>=xe - then replicate (e-xe) 0 ++ xm - else let (xm0,xm1) = splitAtPadZero (xe-e+1) xm - in mantissaToNum b xm0 : xm1 - -absolute :: T -> T -absolute (xe,xm) = (xe, absMant xm) - -absMant :: Mantissa -> Mantissa -absMant xa@(x:xs) = - case compare x 0 of - EQ -> x : absMant xs - LT -> Poly.negate xa - GT -> xa -absMant [] = [] - - -{- * arithmetic -} - -fromLaurent :: LPoly.T Int -> T -fromLaurent (LPoly.Cons nxe xm) = (NP.negate nxe, xm) - -toLaurent :: T -> LPoly.T Int -toLaurent (xe, xm) = LPoly.Cons (NP.negate xe) xm - -liftLaurent2 :: - (LPoly.T Int -> LPoly.T Int -> LPoly.T Int) -> - (T -> T -> T) -liftLaurent2 f x y = - fromLaurent (f (toLaurent x) (toLaurent y)) - -liftLaurentMany :: - ([LPoly.T Int] -> LPoly.T Int) -> - ([T] -> T) -liftLaurentMany f = - fromLaurent . f . map toLaurent - -{- | -Add two numbers but do not eliminate leading zeros. --} -add :: Basis -> T -> T -> T -add b x y = compress b (liftLaurent2 LPoly.add x y) - -sub :: Basis -> T -> T -> T -sub b x y = compress b (liftLaurent2 LPoly.sub x y) - -neg :: Basis -> T -> T -neg _ (xe, xm) = (xe, Poly.negate xm) - - -{- | -Add at most @basis@ summands. -More summands will violate the allowed digit range. --} -addSome :: Basis -> [T] -> T -addSome b = compress b . liftLaurentMany sum - -{- | -Add many numbers efficiently by computing sums of sub lists -with only little carry propagation. --} -addMany :: Basis -> [T] -> T -addMany _ [] = zero -addMany b ys = - let recurse xs = - case map (addSome b) (sliceVertical b xs) of - [s] -> s - sums -> recurse sums - in recurse ys - - -type Series = [(Exponent, T)] - -{- | -Add an infinite number of numbers. -You must provide a list of estimate of the current remainders. -The estimates must be given as exponents of the remainder. -If such an exponent is too small, the summation will be aborted. -If exponents are too big, computation will become inefficient. --} -series :: Basis -> Series -> T -series _ [] = error "empty series: don't know a good exponent" --- series _ [] = (0,[]) -- unfortunate choice of exponent -series b summands = - {- Some pre-processing that asserts decreasing exponents. - Increasing coefficients can appear legally - due to non-unique number representation. -} - let (es,xs) = unzip summands - safeSeries = zip (scanl1 min es) xs - in seriesPlain b safeSeries - -seriesPlain :: Basis -> Series -> T -seriesPlain _ [] = error "empty series: don't know a good exponent" -seriesPlain b summands = - let (es,m:ms) = unzip (map (uncurry (align b)) summands) - eDifs = mapAdjacent (-) es - eDifLists = sliceVertical (pred b) eDifs - mLists = sliceVertical (pred b) ms - accum sumM (eDifList,mList) = - let subM = LPoly.addShiftedMany eDifList (sumM:mList) - -- lazy unary sum - len = concatMap (flip replicate ()) eDifList - (high,low) = splitAtMatchPadZero len subM - {- - 'compressMant' looks unsafe - when the residue doesn't decrease for many summands. - Then there is a leading digit of a chunk - which is not compressed for long time. - However, if the residue is estimated correctly - there can be no overflow. - -} - in (compressMant b low, high) - (trailingDigits, chunks) = - List.mapAccumL accum m (zip eDifLists mLists) - in compress b (head es, concat chunks ++ trailingDigits) - -{- -An alternative series implementation -could reduce carries by do the following cycle -(split, add sub-lists). -This would reduce carries to the minimum -but we must work hard in order to find out lazily -how many digits can be emitted. --} - - -{- | -Like 'splitAt', -but it pads with zeros if the list is too short. -This way it preserves - @ length (fst (splitAtPadZero n xs)) == n @ --} -splitAtPadZero :: Int -> Mantissa -> (Mantissa, Mantissa) -splitAtPadZero n [] = (replicate n 0, []) -splitAtPadZero 0 xs = ([], xs) -splitAtPadZero n (x:xs) = - let (ys, zs) = splitAtPadZero (n-1) xs - in (x:ys, zs) --- must get a case for negative index - -splitAtMatchPadZero :: [()] -> Mantissa -> (Mantissa, Mantissa) -splitAtMatchPadZero n [] = (Match.replicate n 0, []) -splitAtMatchPadZero [] xs = ([], xs) -splitAtMatchPadZero n (x:xs) = - let (ys, zs) = splitAtMatchPadZero (tail n) xs - in (x:ys, zs) - - -{- | -help showing series summands --} -truncSeriesSummands :: Series -> Series -truncSeriesSummands = map (\(e,x) -> (e,trunc (-20) x)) - - - -scale :: Basis -> Digit -> T -> T -scale b y x = compress b (scaleSimple y x) - -{- -scaleSimple :: ToInteger.C a => a -> T -> T -scaleSimple y (xe, xm) = (xe, Poly.scale (fromIntegral y) xm) --} - -scaleSimple :: Basis -> T -> T -scaleSimple y (xe, xm) = (xe, Poly.scale y xm) - -scaleMant :: Basis -> Digit -> Mantissa -> Mantissa -scaleMant b y xm = compressMant b (Poly.scale y xm) - - - -mulSeries :: Basis -> T -> T -> Series -mulSeries _ (xe,[]) (ye,_) = [(xe+ye, zero)] -mulSeries b (xe,xm) (ye,ym) = - let zes = iterate pred (xe+ye+1) - zs = zipWith (\xd e -> scale b xd (e,ym)) xm (tail zes) - in zip zes zs - -{- | -For obtaining n result digits it is mathematically sufficient -to know the first (n+1) digits of the operands. -However this implementation needs (n+2) digits, -because of calls to 'compress' in both 'scale' and 'series'. -We should fix that. --} -mul :: Basis -> T -> T -> T -mul b x y = trimOnce (seriesPlain b (mulSeries b x y)) - - - -{- | -Undefined if the divisor is zero - of course. -Because it is impossible to assert that a real is zero, -the routine will not throw an error in general. - -ToDo: Rigorously derive the minimal required magnitude of the leading divisor digit. --} -divide :: Basis -> T -> T -> T -divide b (xe,xm) (ye',ym') = - let (ye,ym) = until ((>=b) . abs . head . snd) - (decreaseExp b) - (ye',ym') - in nest 3 trimOnce (compress b (xe-ye, divMant b ym xm)) - -divMant :: Basis -> Mantissa -> Mantissa -> Mantissa -divMant _ [] _ = error "Number.Positional: division by zero" -divMant b ym xm0 = - snd $ - List.mapAccumL - (\xm fullCompress -> - let z = div (head xm) (head ym) - {- 'scaleMant' contains compression, - which is not much of a problem, - because it is always applied to @ym@. - That is, there is no nested call. -} - dif = pumpFirst b (Poly.sub xm (scaleMant b z ym)) - cDif = if fullCompress - then compressMant b dif - else compressSecondMant b dif - in (cDif, z)) - xm0 (cycle (replicate (b-1) False ++ [True])) - -divMantSlow :: Basis -> Mantissa -> Mantissa -> Mantissa -divMantSlow _ [] = error "Number.Positional: division by zero" -divMantSlow b ym = - List.unfoldr - (\xm -> - let z = div (head xm) (head ym) - d = compressMant b (pumpFirst b - (Poly.sub xm (Poly.scale z ym))) - in Just (z, d)) - -reciprocal :: Basis -> T -> T -reciprocal b = divide b one - - -{- | -Fast division for small integral divisors, -which occur for instance in summands of power series. --} -divIntMant :: Basis -> Int -> Mantissa -> Mantissa -divIntMant b y xInit = - List.unfoldr (\(r,rxs) -> - let rb = r*b - (rbx, xs', run) = - case rxs of - [] -> (rb, [], r/=0) - (x:xs) -> (rb+x, xs, True) - (d,m) = divMod rbx y - in toMaybe run (d, (m, xs'))) - (0,xInit) - --- this version is simple but ignores the possibility of a terminating result -divIntMantInf :: Basis -> Int -> Mantissa -> Mantissa -divIntMantInf b y = - map fst . tail . - scanl (\(_,r) x -> divMod (r*b+x) y) (undefined,0) . - (++ repeat 0) - -divInt :: Basis -> Digit -> T -> T -divInt b y (xe,xm) = - -- (xe, divIntMant b y xm) - let z = (xe, divIntMant b y xm) - {- Division by big integers may cause leading zeros. - Eliminate as many as we can expect from the division. - If the input number has leading zeros (it might be equal to zero), - then the result may have, too. -} - tz = until ((<=1) . fst) (\(yi,zi) -> (div yi b, trimOnce zi)) (y,z) - in snd tz - - -{- * algebraic functions -} - - -sqrt :: Basis -> T -> T -sqrt b = sqrtDriver b sqrtFP - -sqrtDriver :: Basis -> (Basis -> FixedPoint -> Mantissa) -> T -> T -sqrtDriver _ _ (xe,[]) = (div xe 2, []) -sqrtDriver b sqrtFPworker x = - let (exe,ex0:exm) = if odd (fst x) then decreaseExp b x else x - (nxe,(nx0,nxm)) = - until (\xi -> fst (snd xi) >= fromIntegral b ^ 2) - (nest 2 (decreaseExpFP b)) - (exe, (fromIntegral ex0, exm)) - in compress b (div nxe 2, sqrtFPworker b (nx0,nxm)) - - -sqrtMant :: Basis -> Mantissa -> Mantissa -sqrtMant _ [] = [] -sqrtMant b (x:xs) = - sqrtFP b (fromIntegral x, xs) - -{- | -Square root. - -We need a leading digit of type Integer, -because we have to collect up to 4 digits. -This presentation can also be considered as 'FixedPoint'. - -ToDo: -Rigorously derive the minimal required magnitude -of the leading digit of the root. - -Mathematically the @n@th digit of the square root -depends roughly only on the first @n@ digits of the input. -This is because @sqrt (1+eps) `equalApprox` 1 + eps\/2@. -However this implementation requires @2*n@ input digits -for emitting @n@ digits. -This is due to the repeated use of 'compressMant'. -It would suffice to fully compress only every @basis@th iteration (digit) -and compress only the second leading digit in each iteration. - - -Can the involved operations be made lazy enough to solve -@y = (x+frac)^2@ -by -@frac = (y-x^2-frac^2) \/ (2*x)@ ? --} -sqrtFP :: Basis -> FixedPoint -> Mantissa -sqrtFP b (x0,xs) = - let y0 = round (NP.sqrt (fromInteger x0 :: Double)) - dyx0 = fromInteger (x0 - fromIntegral y0 ^ 2) - - accum dif (e,ty) = - -- (e,ty) == xm - (trunc j y)^2 - let yj = div (head dif + y0) (2*y0) - newDif = pumpFirst b $ - LPoly.addShifted e - (Poly.sub dif (scaleMant b (2*yj) ty)) - [yj*yj] - {- We could always compress the full difference number, - but it is not necessary, - and we save dependencies on less significant digits. -} - cNewDif = - if mod e b == 0 - then compressMant b newDif - else compressSecondMant b newDif - in (cNewDif, yj) - - truncs = lazyInits y - y = y0 : snd (List.mapAccumL - accum - (pumpFirst b (dyx0 : xs)) - (zip [1..] (drop 2 truncs))) - in y - - -sqrtNewton :: Basis -> T -> T -sqrtNewton b = sqrtDriver b sqrtFPNewton - -{- | -Newton iteration doubles the number of correct digits in every step. -Thus we process the data in chunks of sizes of powers of two. -This way we get fastest computation possible with Newton -but also more dependencies on input than necessary. -The question arises whether this implementation still fits the needs -of computational reals. -The input is requested as larger and larger chunks, -and the input itself might be computed this way, -e.g. a repeated square root. -Requesting one digit too much, -requires the double amount of work for the input computation, -which in turn multiplies time consumption by a factor of four, -and so on. - -Optimal fast implementation of one routine -does not preserve fast computation of composed computations. - -The routine assumes, that the integer parts is at least @b^2.@ --} -sqrtFPNewton :: Basis -> FixedPoint -> Mantissa -sqrtFPNewton bInt (x0,xs) = - let b = fromIntegral bInt - chunkLengths = iterate (2*) 1 - xChunks = map (mantissaToNum bInt) $ snd $ - List.mapAccumL (\x cl -> swap (splitAtPadZero cl x)) - xs chunkLengths - basisPowers = iterate (^2) b - truncXs = scanl (\acc (bp,frac) -> acc*bp+frac) x0 - (zip basisPowers xChunks) - accum y (bp, x) = - let ybp = y * bp - newY = div (ybp + div (x * div bp b) y) 2 - in (newY, newY-ybp) - y0 = round (NP.sqrt (fromInteger x0 :: Double)) - yChunks = snd $ List.mapAccumL accum - y0 (zip basisPowers (tail truncXs)) - yFrac = concat $ zipWith (mantissaFromFixedInt bInt) chunkLengths yChunks - in fromInteger y0 : yFrac - - -{- | -List.inits is defined by -@inits = foldr (\x ys -> [] : map (x:) ys) [[]]@ - -This is too strict for our application. - -> Prelude> List.inits (0:1:2:undefined) -> [[],[0],[0,1]*** Exception: Prelude.undefined - -The following routine is more lazy than 'List.inits' -and even lazier than 'Data.List.HT.inits' from @utility-ht@ package, -but it is restricted to infinite lists. -This degree of laziness is needed for @sqrtFP@. - -> Prelude> lazyInits (0:1:2:undefined) -> [[],[0],[0,1],[0,1,2],[0,1,2,*** Exception: Prelude.undefined --} -lazyInits :: [a] -> [[a]] -lazyInits ~(x:xs) = [] : map (x:) (lazyInits xs) -{- -The lazy match above is irrefutable, -so the pattern @[]@ would never be reached. --} - - - -{- * transcendent functions -} - -{- ** exponential functions -} - -expSeries :: Basis -> T -> Series -expSeries b xOrig = - let x = negativeExp b xOrig - xps = scanl (\p n -> divInt b n (mul b x p)) one [1..] - in map (\xp -> (fst xp, xp)) xps - -{- | -Absolute value of argument should be below 1. --} -expSmall :: Basis -> T -> T -expSmall b x = series b (expSeries b x) - - -expSeriesLazy :: Basis -> T -> Series -expSeriesLazy b x@(xe,_) = - let xps = scanl (\p n -> divInt b n (mul b x p)) one [1..] - {- much effort for computing the residue exponents - without touching the arguments mantissa -} - es :: [Double] - es = zipWith (-) - (map fromIntegral (iterate ((1+xe)+) 0)) - (scanl (+) 0 - (map (logBase (fromIntegral b) - . fromInteger) [1..])) - in zip (map ceiling es) xps - -expSmallLazy :: Basis -> T -> T -expSmallLazy b x = series b (expSeriesLazy b x) - - -exp :: Basis -> T -> T -exp b x = - let (xInt,xFrac) = toFixedPoint b (compress b x) - yFrac = expSmall b (-1,xFrac) - {- - (xFrac0,xFrac1) = splitAt 2 xFrac - yFrac = mul b - -- slow convergence but simple argument - (expSmall b (-1, xFrac0)) - -- fast convergence but big argument - (expSmall b (-3, xFrac1)) - -} - in intPower b xInt yFrac (recipEConst b) (eConst b) - -intPower :: Basis -> Integer -> T -> T -> T -> T -intPower b expon neutral recipX x = - if expon >= 0 - then cardPower b expon neutral x - else cardPower b (-expon) neutral recipX - -cardPower :: Basis -> Integer -> T -> T -> T -cardPower b expon neutral x = - if expon >= 0 - then powerAssociative (mul b) neutral x expon - else error "negative exponent - use intPower" - - -{- | -Residue estimates will only hold for exponents -with absolute value below one. - -The computation is based on 'Int', -thus the denominator should not be too big. -(Say, at most 1000 for 1000000 digits.) - -It is not optimal to split the power into pure root and pure power -(that means, with integer exponents). -The root series can nicely handle all exponents, -but for exponents above 1 the series summands rises at the beginning -and thus make the residue estimate complicated. -For powers with integer exponents the root series turns -into the binomial formula, -which is just a complicated way to compute a power -which can also be determined by simple multiplication. --} -powerSeries :: Basis -> Rational -> T -> Series -powerSeries b expon xOrig = - let scaleRat ni yi = - divInt b (fromInteger (denominator yi) * ni) . - scaleSimple (fromInteger (numerator yi)) - x = negativeExp b (sub b xOrig one) - xps = scanl (\p fac -> uncurry scaleRat fac (mul b x p)) - one (zip [1..] (iterate (subtract 1) expon)) - in map (\xp -> (fst xp, xp)) xps - -powerSmall :: Basis -> Rational -> T -> T -powerSmall b y x = series b (powerSeries b y x) - -power :: Basis -> Rational -> T -> T -power b expon x = - let num = numerator expon - den = denominator expon - rootX = root b den x - in intPower b num one (reciprocal b rootX) rootX - -root :: Basis -> Integer -> T -> T -root b expon x = - let estimate = liftDoubleApprox b (** (1 / fromInteger expon)) x - estPower = cardPower b expon one estimate - residue = divide b x estPower - in mul b estimate (powerSmall b (1 % fromIntegral expon) residue) - - - -{- | -Absolute value of argument should be below 1. --} -cosSinhSmall :: Basis -> T -> (T, T) -cosSinhSmall b x = - let (coshXps, sinhXps) = unzip (sliceVertPair (expSeries b x)) - in (series b coshXps, - series b sinhXps) - -{- | -Absolute value of argument should be below 1. --} -cosSinSmall :: Basis -> T -> (T, T) -cosSinSmall b x = - let (coshXps, sinhXps) = unzip (sliceVertPair (expSeries b x)) - alternate s = - zipWith3 if' (cycle [True,False]) - s (map (\(e,y) -> (e, neg b y)) s) - in (series b (alternate coshXps), - series b (alternate sinhXps)) - - -{- | -Like 'cosSinSmall' but converges faster. -It calls @cosSinSmall@ with reduced arguments -using the trigonometric identities -@ -cos (4*x) = 8 * cos x ^ 2 * (cos x ^ 2 - 1) + 1 -sin (4*x) = 4 * sin x * cos x * (1 - 2 * sin x ^ 2) -@ - -Note that the faster convergence is hidden by the overhead. - -The same could be achieved with a fourth power of a complex number. --} -cosSinFourth :: Basis -> T -> (T, T) -cosSinFourth b x = - let (cosx, sinx) = cosSinSmall b (divInt b 4 x) - sinx2 = mul b sinx sinx - cosx2 = mul b cosx cosx - sincosx = mul b sinx cosx - in (add b one (scale b 8 (mul b cosx2 (sub b cosx2 one))), - scale b 4 (mul b sincosx (sub b one (scale b 2 sinx2)))) - - -cosSin :: Basis -> T -> (T, T) -cosSin b x = - let pi2 = divInt b 2 (piConst b) - {- @compress@ ensures that the leading digit of the fractional part - is close to zero -} - (quadrant, frac) = toFixedPoint b (compress b (divide b x pi2)) - -- it's possibly faster if we subtract quadrant*pi/4 - wrapped = if quadrant==0 then x else mul b pi2 (-1, frac) - (cosW,sinW) = cosSinSmall b wrapped - in case mod quadrant 4 of - 0 -> ( cosW, sinW) - 1 -> (neg b sinW, cosW) - 2 -> (neg b cosW, neg b sinW) - 3 -> ( sinW, neg b cosW) - _ -> error "error in implementation of 'mod'" - -tan :: Basis -> T -> T -tan b x = uncurry (flip (divide b)) (cosSin b x) - -cot :: Basis -> T -> T -cot b x = uncurry (divide b) (cosSin b x) - - -{- ** logarithmic functions -} - -lnSeries :: Basis -> T -> Series -lnSeries b xOrig = - let x = negativeExp b (sub b xOrig one) - mx = neg b x - xps = zipWith (divInt b) [1..] (iterate (mul b mx) x) - in map (\xp -> (fst xp, xp)) xps - -lnSmall :: Basis -> T -> T -lnSmall b x = series b (lnSeries b x) - -{- | -@ -x' = x - (exp x - y) \/ exp x - = x + (y * exp (-x) - 1) -@ - -First, the dependencies on low-significant places are currently -much more than mathematically necessary. -Check -@ -*Number.Positional> expSmall 1000 (-1,100 : replicate 16 0 ++ [undefined]) -(0,[1,105,171,-82,76*** Exception: Prelude.undefined -@ -Every multiplication cut off two trailing digits. -@ -*Number.Positional> nest 8 (mul 1000 (-1,repeat 1)) (-1,100 : replicate 16 0 ++ [undefined]) -(-9,[101,*** Exception: Prelude.undefined -@ - -Possibly the dependencies of expSmall -could be resolved by not computing @mul@ immediately -but computing @mul@ series which are merged and subsequently added. -But this would lead to an explosion of series. - -Second, even if the dependencies of all atomic operations -are reduced to a minimum, -the mathematical dependencies of the whole iteration function -are less than the sums of the parts. -Lets demonstrate this with the square root iteration. -It is -@ -(1.4140 + 2/1.4140) / 2 == 1.414213578500707 -(1.4149 + 2/1.4149) / 2 == 1.4142137288854335 -@ -That is, the digits @213@ do not depend mathematically on @x@ of @1.414x@, -but their computation depends. -Maybe there is a glorious trick to reduce the computational dependencies -to the mathematical ones. --} -lnNewton :: Basis -> T -> T -lnNewton b y = - let estimate = liftDoubleApprox b log y - expRes = mul b y (expSmall b (neg b estimate)) - -- try to reduce dependencies by feeding expSmall with a small argument - residue = - sub b (mul b expRes (expSmallLazy b (neg b resTrim))) one - resTrim = - -- (-3, replicate 4 0 ++ alignMant b (-7) residue) - align b (- mantLengthDouble b) residue - lazyAdd (xe,xm) (ye,ym) = - (xe, LPoly.addShifted (xe-ye) xm ym) - x = lazyAdd estimate resTrim - in x - -lnNewton' :: Basis -> T -> T -lnNewton' b y = - let estimate = liftDoubleApprox b log y - residue = - sub b (mul b y (expSmall b (neg b x))) one - -- sub b (mul b y (expSmall b (neg b estimate))) one - -- sub b (mul b y (expSmall b (neg b - -- (fst estimate, snd estimate ++ [undefined])))) one - resTrim = - -- align b (-6) residue - align b (- mantLengthDouble b) residue - -- align returns the new exponent immediately - -- nest (mantLengthDouble b) trimOnce residue - -- negativeExp b residue - lazyAdd (xe,xm) (ye,ym) = - (xe, LPoly.addShifted (xe-ye) xm ym) - x = lazyAdd estimate resTrim - -- add b estimate resTrim - -- LPoly.add checks for empty lists and is thus too strict - in x - - -ln :: Basis -> T -> T -ln b x@(xe,_) = - let e = round (log (fromIntegral b) * fromIntegral xe :: Double) - ei = fromIntegral e - y = trim $ - if e<0 - then powerAssociative (mul b) x (eConst b) (-ei) - else powerAssociative (mul b) x (recipEConst b) ei - estimate = liftDoubleApprox b log y - residue = mul b (expSmall b (neg b estimate)) y - in addSome b [(0,[e]), estimate, lnSmall b residue] - - -{- | -This is an inverse of 'cosSin', -also known as @atan2@ with flipped arguments. -It's very slow because of the computation of sinus and cosinus. -However, because it uses the 'atan2' implementation as estimator, -the final application of arctan series should converge rapidly. - -It could be certainly accelerated by not using cosSin -and its fiddling with pi. -Instead we could analyse quadrants before calling atan2, -then calling cosSinSmall immediately. --} -angle :: Basis -> (T,T) -> T -angle b (cosx, sinx) = - let wd = atan2 (toDouble b sinx) (toDouble b cosx) - wApprox = fromDoubleApprox b wd - (cosApprox, sinApprox) = cosSin b wApprox - (cosD,sinD) = - (add b (mul b cosx cosApprox) - (mul b sinx sinApprox), - sub b (mul b sinx cosApprox) - (mul b cosx sinApprox)) - sinDSmall = negativeExp b sinD - in add b wApprox (arctanSmall b (divide b sinDSmall cosD)) - - -{- | -Arcus tangens of arguments with absolute value less than @1 \/ sqrt 3@. --} -arctanSeries :: Basis -> T -> Series -arctanSeries b xOrig = - let x = negativeExp b xOrig - mx2 = neg b (mul b x x) - xps = zipWith (divInt b) [1,3..] (iterate (mul b mx2) x) - in map (\xp -> (fst xp, xp)) xps - -arctanSmall :: Basis -> T -> T -arctanSmall b x = series b (arctanSeries b x) - -{- | -Efficient computation of Arcus tangens of an argument of the form @1\/n@. --} -arctanStem :: Basis -> Int -> T -arctanStem b n = - let x = (0, divIntMant b n [1]) - divN2 = divInt b n . divInt b (-n) - {- this one can cause overflows in piConst too easily - mn2 = - n*n - divN2 = divInt b mn2 - -} - xps = zipWith (divInt b) [1,3..] (iterate (trim . divN2) x) - in series b (map (\xp -> (fst xp, xp)) xps) - - -{- | -This implementation gets the first decimal place for free -by calling the arcus tangens implementation for 'Double's. --} -arctan :: Basis -> T -> T -arctan b x = - let estimate = liftDoubleRough b atan x - tanEst = tan b estimate - residue = divide b (sub b x tanEst) (add b one (mul b x tanEst)) - in addSome b [estimate, arctanSmall b residue] - -{- | -A classic implementation without ''cheating'' -with floating point implementations. - -For @x < 1 \/ sqrt 3@ -(@1 \/ sqrt 3 == tan (pi\/6)@) -use @arctan@ power series. -(@sqrt 3@ is approximately @19\/11@.) - -For @x > sqrt 3@ -use -@arctan x = pi\/2 - arctan (1\/x)@ - -For other @x@ use - -@arctan x = pi\/4 - 0.5*arctan ((1-x^2)\/2*x)@ -(which follows from -@arctan x + arctan y == arctan ((x+y) \/ (1-x*y))@ -which in turn follows from complex multiplication -@(1:+x)*(1:+y) == ((1-x*y):+(x+y))@ - -If @x@ is close to @sqrt 3@ or @1 \/ sqrt 3@ the computation is quite inefficient. --} -arctanClassic :: Basis -> T -> T -arctanClassic b x = - let absX = absolute x - pi2 = divInt b 2 (piConst b) - in select - (divInt b 2 (sub b pi2 - (arctanSmall b - (divInt b 2 (sub b (reciprocal b x) x))))) - [(lessApprox b (-5) absX (fromBaseRational b (11%19)), - arctanSmall b x), - (lessApprox b (-5) (fromBaseRational b (19%11)) absX, - sub b pi2 (arctanSmall b (reciprocal b x)))] - - - -{- * constants -} - -{- ** elementary -} - -zero :: T -zero = (0,[]) - -one :: T -one = (0,[1]) - -minusOne :: T -minusOne = (0,[-1]) - - -{- ** transcendental -} - -eConst :: Basis -> T -eConst b = expSmall b one - -recipEConst :: Basis -> T -recipEConst b = expSmall b minusOne - -piConst :: Basis -> T -piConst b = - let numCompress = takeWhile (0/=) - (iterate (flip div b) (4*(44+7+12+24))) - stArcTan k den = scaleSimple k (arctanStem b den) - sum' = addSome b - [stArcTan 44 57, - stArcTan 7 239, - stArcTan (-12) 682, - stArcTan 24 12943] - in foldl (const . compress b) - (scaleSimple 4 sum') numCompress - - - -{- * auxilary functions -} - -sliceVertPair :: [a] -> [(a,a)] -sliceVertPair (x0:x1:xs) = (x0,x1) : sliceVertPair xs -sliceVertPair [] = [] -sliceVertPair _ = error "odd number of elements" - - - -{- -Pi as a zero of trigonometric functions. - - Is a corresponding computation that bad? -Newton converges quadratically, - but the involved trigonometric series converge only slightly more than linearly. - --- lift cos to higher frequencies, in order to shift the zero to smaller values, which let trigonometric series converge faster - -take 10 $ Numerics.Newton.zero 0.7 (\x -> (cos (2*x), -2 * sin (2*x))) - -(\x -> (2 * cos x ^ 2 - 1, -4 * cos x * sin x)) -(\x -> (cos x ^ 2 - sin x ^ 2, -4 * cos x * sin x)) -(\x -> (tan x ^ 2 - 1, 4 * tan x)) - - --- compute arctan as inverse of tan by Newton - -zero 0.7 (\x -> (tan x - 1, 1 + tan x ^ 2)) -zero 0.7 (\x -> (tan x - 1, 1 / cos x ^ 2)) -iterate (\x -> x + (cos x - sin x) * cos x) 0.7 -iterate (\x -> x + (cos x - sin x) * sqrt 0.5) 0.7 -iterate (\x -> x + cos x ^ 2 - sin x * cos x) 0.7 -iterate (\x -> x + 0.5 - sin x * cos x) 0.7 -iterate (\x -> x + cos x ^ 2 - 0.5) 0.7 - - --- compute section of tan and cot - -zero 0.7 (\x -> (tan x - 1 / tan x, (1 + tan x ^ 2) * (1 + 1 / tan x ^ 2)) -zero 0.7 (\x -> ((tan x ^ 2 - 1) * tan x, (1 + tan x ^ 2) ^ 2) -iterate (\x -> x - (sin x ^ 2 - cos x ^ 2) * sin x * cos x) 0.7 -iterate (\x -> x - (sin x ^ 2 - cos x ^ 2) * 0.5) 0.7 -iterate (\x -> x + 1/2 - sin x ^ 2) 0.7 - -For using the last formula, -the n-th digit of (sin x) must depend only on the n-th digit of x. -The same holds for (^2). -This means that no interim carry compensation is possible. -This will certainly force usage of Integer for digits, -otherwise the multiplication will overflow sooner or later. --} diff --git a/src-ghc-6.12/Number/Positional/Check.hs b/src-ghc-6.12/Number/Positional/Check.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/Positional/Check.hs +++ /dev/null @@ -1,260 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2006 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional - - -Interface to "Number.Positional" which dynamically checks for equal bases. --} -module Number.Positional.Check where - -import qualified Number.Positional as Pos - -import qualified Number.Complex as Complex - --- import qualified Algebra.Module as Module -import qualified Algebra.RealTranscendental as RealTrans -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.RealField as RealField -import qualified Algebra.Field as Field -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import qualified Algebra.EqualityDecision as EqDec -import qualified Algebra.OrderDecision as OrdDec - -import qualified NumericPrelude.Base as P -import qualified Prelude as P98 - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - -{- | -The value @Cons b e m@ -represents the number @b^e * (m!!0 \/ 1 + m!!1 \/ b + m!!2 \/ b^2 + ...)@. -The interpretation of exponent is chosen such that -@floor (logBase b (Cons b e m)) == e@. -That is, it is good for multiplication and logarithms. -(Because of the necessity to normalize the multiplication result, -the alternative interpretation wouldn't be more complicated.) -However for base conversions, roots, conversion to fixed point and -working with the fractional part -the interpretation -@b^e * (m!!0 \/ b + m!!1 \/ b^2 + m!!2 \/ b^3 + ...)@ -would fit better. -The digits in the mantissa range from @1-base@ to @base-1@. -The representation is not unique -and cannot be made unique in finite time. -This way we avoid infinite carry ripples. --} -data T = Cons {base :: Int, exponent :: Int, mantissa :: Pos.Mantissa} - deriving (Show) - - -{- * basic helpers -} - -{- | -Shift digits towards zero by partial application of carries. -E.g. 1.8 is converted to 2.(-2) -If the digits are in the range @(1-base, base-1)@ -the resulting digits are in the range @((1-base)/2-2, (base-1)/2+2)@. -The result is still not unique, -but may be useful for further processing. --} -compress :: T -> T -compress = lift1 Pos.compress - - -{- | perfect carry resolution, works only on finite numbers -} -carry :: T -> T -carry (Cons b ex xs) = - let ys = scanr (\x (c,_) -> divMod (x+c) b) (0,undefined) xs - digits = map snd (init ys) - in prependDigit (fst (head ys)) (Cons b ex digits) - - -prependDigit :: Int -> T -> T -prependDigit 0 x = x -prependDigit x (Cons b ex xs) = - Cons b (ex+1) (x:xs) - - - -{- * conversions -} - -lift0 :: (Int -> Pos.T) -> T -lift0 op = - uncurry (Cons defltBase) (op defltBase) - -lift1 :: (Int -> Pos.T -> Pos.T) -> T -> T -lift1 op (Cons xb xe xm) = - uncurry (Cons xb) (op xb (xe, xm)) - -lift2 :: (Int -> Pos.T -> Pos.T -> Pos.T) -> T -> T -> T -lift2 op (Cons xb xe xm) (Cons yb ye ym) = - let b = commonBasis xb yb - in uncurry (Cons b) (op b (xe, xm) (ye, ym)) - -{- -lift4 :: (Int -> Pos.T -> Pos.T -> Pos.T -> Pos.T -> Pos.T) -> T -> T -> T -> T -> T -lift4 op (Cons xb xe xm) (Cons yb ye ym) (Cons zb ze zm) (Cons wb we wm) = - let b = xb `commonBasis` yb `commonBasis` zb `commonBasis` wb - in uncurry (Cons b) (op b (xe, xm) (ye, ym) (ze, zm) (we, wm)) --} - -commonBasis :: Pos.Basis -> Pos.Basis -> Pos.Basis -commonBasis xb yb = - if xb == yb - then xb - else error "Number.Positional: bases differ" - -fromBaseInteger :: Int -> Integer -> T -fromBaseInteger b n = - uncurry (Cons b) (Pos.fromBaseInteger b n) - -fromBaseRational :: Int -> Rational -> T -fromBaseRational b r = - uncurry (Cons b) (Pos.fromBaseRational b r) - - - - - -defltBaseRoot :: Pos.Basis -defltBaseRoot = 10 - -defltBaseExp :: Pos.Exponent -defltBaseExp = 3 --- exp 4 let (sqrt 0.5) fail - -defltBase :: Pos.Basis -defltBase = ringPower defltBaseExp defltBaseRoot - - - -defltShow :: T -> String -defltShow (Cons xb xe xm) = - if xb == defltBase - then Pos.showBasis defltBaseRoot defltBaseExp (xe,xm) - else error "defltShow: wrong base" - - -instance Additive.C T where - zero = fromBaseInteger defltBase 0 - (+) = lift2 Pos.add - (-) = lift2 Pos.sub - negate = lift1 Pos.neg - -instance Ring.C T where - one = fromBaseInteger defltBase 1 - fromInteger n = fromBaseInteger defltBase n - (*) = lift2 Pos.mul - -{- -instance Module.C T T where - (*>) = (*) --} - -instance Field.C T where - (/) = lift2 Pos.divide - recip = lift1 Pos.reciprocal - -instance Algebraic.C T where - sqrt = lift1 Pos.sqrtNewton - root n = lift1 (flip Pos.root n) - x ^/ y = lift1 (flip Pos.power y) x - -instance Trans.C T where - pi = lift0 Pos.piConst - - exp = lift1 Pos.exp - log = lift1 Pos.ln - - sin = lift1 (\b -> snd . Pos.cosSin b) - cos = lift1 (\b -> fst . Pos.cosSin b) - tan = lift1 Pos.tan - - atan = lift1 Pos.arctan - - {- - sinh = lift1 (\b -> snd . Pos.cosSinh b) - cosh = lift1 (\b -> snd . Pos.cosSinh b) - -} - -{- -The way EqDec and OrdDec are instantiated -it is possible to have different bases -for the arguments for comparison -and the arguments between we decide. -However, I would not rely on this. --} -instance EqDec.C T where - x==?y = lift2 (\b -> Pos.ifLazy b (x==y)) - -instance OrdDec.C T where - x<=?y = lift2 (\b -> Pos.ifLazy b (x<=y)) - -instance ZeroTestable.C T where - isZero (Cons xb xe xm) = - Pos.cmp xb (xe,xm) Pos.zero == EQ - -instance Eq T where - (Cons xb xe xm) == (Cons yb ye ym) = - Pos.cmp (commonBasis xb yb) (xe,xm) (ye,ym) == EQ - -instance Ord T where - compare (Cons xb xe xm) (Cons yb ye ym) = - Pos.cmp (commonBasis xb yb) (xe,xm) (ye,ym) - -instance Absolute.C T where - abs = lift1 (const Pos.absolute) - signum = Absolute.signumOrd - -instance RealRing.C T where - splitFraction (Cons xb xe xm) = - let (int, frac) = Pos.toFixedPoint xb (xe,xm) - in (fromInteger int, Cons xb (-1) frac) - -instance RealField.C T where - -instance RealTrans.C T where - atan2 = lift2 (curry . Pos.angle) - - --- for complex numbers - -instance Complex.Power T where - power = Complex.defltPow - - - - --- legacy instances for work with GHCi -legacyInstance :: a -legacyInstance = - error "legacy Ring.C instance for simple input of numeric literals" - -instance P98.Num T where - fromInteger = fromBaseInteger defltBase - negate = negate --for unary minus - (+) = legacyInstance - (*) = legacyInstance - abs = legacyInstance - signum = legacyInstance - -instance P98.Fractional T where - fromRational = fromBaseRational defltBase . fromRational - (/) = legacyInstance - - -{- -MathObj.PowerSeries.approx MathObj.PowerSeries.Example.exp (Number.Positional.fromBaseInteger 10 1) List.!! 30 :: Number.Positional.Check.T --} diff --git a/src-ghc-6.12/Number/Quaternion.hs b/src-ghc-6.12/Number/Quaternion.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/Quaternion.hs +++ /dev/null @@ -1,296 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- | -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable (?) - -Quaternions --} - -module Number.Quaternion - ( - -- * Cartesian form - T(real,imag), - fromReal, - (+::), - - -- * Conversions - toRotationMatrix, - fromRotationMatrix, - fromRotationMatrixDenorm, - toComplexMatrix, - fromComplexMatrix, - - -- * Operations - scalarProduct, - crossProduct, - conjugate, - scale, - norm, - normSqr, - normalize, - similarity, - slerp, - ) where - -import qualified Algebra.NormedSpace.Euclidean as NormedEuc -import qualified Algebra.VectorSpace as VectorSpace -import qualified Algebra.Module as Module -import qualified Algebra.Vector as Vector -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import Algebra.ZeroTestable(isZero) -import Algebra.Module((*>), (<*>.*>), ) - -import qualified Number.Complex as Complex - -import Number.Complex ((+:)) - -import qualified NumericPrelude.Elementwise as Elem -import Algebra.Additive ((<*>.+), (<*>.-), (<*>.-$), ) - --- import qualified Data.Typeable as Ty -import Data.Array (Array, (!)) -import qualified Data.Array as Array - -import qualified Prelude as P -import NumericPrelude.Base -import NumericPrelude.Numeric hiding (signum) -import Text.Show.HT (showsInfixPrec, ) -import Text.Read.HT (readsInfixPrec, ) - - -{- TODO: -conversion to and from complex matrix --} - - -infix 6 +::, `Cons` - -{- | -Quaternions could be defined based on Complex numbers. -However quaternions are often considered as real part and three imaginary parts. --} -data T a - = Cons {real :: !a -- ^ real part - ,imag :: !(a, a, a) -- ^ imaginary parts - } - deriving (Eq) - -fromReal :: Additive.C a => a -> T a -fromReal x = Cons x zero - - -plusPrec :: Int -plusPrec = 6 - -instance (Show a) => Show (T a) where - showsPrec prec (x `Cons` y) = showsInfixPrec "+::" plusPrec prec x y - -instance (Read a) => Read (T a) where - readsPrec prec = readsInfixPrec "+::" plusPrec prec (+::) - - --- | Construct a quaternion from real and imaginary part. -(+::) :: a -> (a,a,a) -> T a -(+::) = Cons - --- | The conjugate of a quaternion. -{-# SPECIALISE conjugate :: T Double -> T Double #-} -conjugate :: (Additive.C a) => T a -> T a -conjugate (Cons r i) = Cons r (negate i) - --- | Scale a quaternion by a real number. -{-# SPECIALISE scale :: Double -> T Double -> T Double #-} -scale :: (Ring.C a) => a -> T a -> T a -scale r (Cons xr xi) = Cons (r * xr) (scaleImag r xi) - --- | like Module.*> but without additional class dependency -scaleImag :: (Ring.C a) => a -> (a,a,a) -> (a,a,a) -scaleImag r (xi,xj,xk) = (r * xi, r * xj, r * xk) - --- | the same as NormedEuc.normSqr but with a simpler type class constraint -normSqr :: (Ring.C a) => T a -> a -normSqr (Cons xr xi) = xr*xr + scalarProduct xi xi - -norm :: (Algebraic.C a) => T a -> a -norm x = sqrt (normSqr x) - --- | scale a quaternion into a unit quaternion -normalize :: (Algebraic.C a) => T a -> T a -normalize x = scale (recip (norm x)) x - -scalarProduct :: (Ring.C a) => (a,a,a) -> (a,a,a) -> a -scalarProduct (xi,xj,xk) (yi,yj,yk) = - xi*yi + xj*yj + xk*yk - -crossProduct :: (Ring.C a) => (a,a,a) -> (a,a,a) -> (a,a,a) -crossProduct (xi,xj,xk) (yi,yj,yk) = - (xj*yk - xk*yj, xk*yi - xi*yk, xi*yj - xj*yi) - -{- | similarity mapping as needed for rotating 3D vectors - -It holds -@similarity (cos(a\/2) +:: scaleImag (sin(a\/2)) v) (0 +:: x) == (0 +:: y)@ -where @y@ results from rotating @x@ around the axis @v@ by the angle @a@. --} -similarity :: (Field.C a) => T a -> T a -> T a -similarity c x = c*x/c - -{- -rotate :: (Field.C a) => - (a,a,a) {- ^ rotation axis, must be normalized -} - -> T a - -> T a -rotate c x = c*x/c --} - -{- | -Let @c@ be a unit quaternion, then it holds -@similarity c (0+::x) == toRotationMatrix c * x@ --} -toRotationMatrix :: (Ring.C a) => T a -> Array (Int,Int) a -toRotationMatrix (Cons r (i,j,k)) = - let r2 = r^2 - i2 = i^2; j2 = j^2; k2 = k^2 - ri = 2*r*i; rj = 2*r*j; rk = 2*r*k - jk = 2*j*k; ki = 2*k*i; ij = 2*i*j - in Array.listArray ((0,0),(2,2)) $ concat $ - [r2+i2-j2-k2, ij-rk, ki+rj ] : - [ij+rk, r2-i2+j2-k2, jk-ri ] : - [ki-rj, jk+ri, r2-i2-j2+k2] : - [] - -fromRotationMatrix :: (Algebraic.C a) => Array (Int,Int) a -> T a -fromRotationMatrix = - normalize . fromRotationMatrixDenorm - - -checkBounds :: (Int,Int) -> Array (Int,Int) a -> Array (Int,Int) a -checkBounds (c,r) arr = - let bnds@((c0,r0), (c1,r1)) = Array.bounds arr - in if c1-c0==c && r1-r0==r - then Array.listArray ((0,0), (c1-c0, r1-r0)) - (Array.elems arr) - else error ("Quaternion.checkBounds: invalid matrix size " - ++ show bnds) - - -{- | -The rotation matrix must be normalized. -(I.e. no rotation with scaling) -The computed quaternion is not normalized. --} -fromRotationMatrixDenorm :: (Ring.C a) => Array (Int,Int) a -> T a -fromRotationMatrixDenorm mat' = - let mat = checkBounds (2,2) mat' - trace = sum (map (\i -> mat ! (i,i)) [0..2]) - dif (i,j) = mat!(i,j) - mat!(j,i) - in Cons (trace+1) (dif (2,1), dif (0,2), dif (1,0)) - -{- | -Map a quaternion to complex valued 2x2 matrix, -such that quaternion addition and multiplication -is mapped to matrix addition and multiplication. -The determinant of the matrix equals the squared quaternion norm ('normSqr'). -Since complex numbers can be turned into real (orthogonal) matrices, -a quaternion could also be converted into a real matrix. --} -toComplexMatrix :: (Additive.C a) => - T a -> Array (Int,Int) (Complex.T a) -toComplexMatrix (Cons r (i,j,k)) = - Array.listArray ((0,0), (1,1)) - [r+:i, (-j)+:(-k), j+:(-k), r+:(-i)] - - -{- | -Revert 'toComplexMatrix'. --} -fromComplexMatrix :: (Field.C a) => - Array (Int,Int) (Complex.T a) -> T a -fromComplexMatrix mat = - let xs = Array.elems (checkBounds (1,1) mat) - [ar,br,cr,dr] = map Complex.real xs - [ai,bi,ci,di] = map Complex.imag xs - in scale (1/2) (Cons (ar+dr) (ai-di, cr-br, -ci-bi)) - - -{- | -Spherical Linear Interpolation - -Can be generalized to any transcendent Hilbert space. -In fact, we should also include the real part in the interpolation. --} -slerp :: (Trans.C a) => - a {- ^ For @0@ return vector @v@, - for @1@ return vector @w@ -} - -> (a,a,a) {- ^ vector @v@, must be normalized -} - -> (a,a,a) {- ^ vector @w@, must be normalized -} - -> (a,a,a) -slerp c v w = - let scal = scalarProduct v w / - sqrt (scalarProduct v v * scalarProduct w w) - angle = Trans.acos scal - in scaleImag (recip (Algebraic.sqrt (1-scal^2))) - (scaleImag (Trans.sin ((1-c)*angle)) v + - scaleImag (Trans.sin ( c *angle)) w) - - - -instance (NormedEuc.Sqr a b) => NormedEuc.Sqr a (T b) where - normSqr (Cons r i) = NormedEuc.normSqr r + NormedEuc.normSqr i - -instance (Algebraic.C a, NormedEuc.Sqr a b) => NormedEuc.C a (T b) where - norm = NormedEuc.defltNorm - - - -instance (ZeroTestable.C a) => ZeroTestable.C (T a) where - isZero (Cons r i) = isZero r && isZero i - -instance (Additive.C a) => Additive.C (T a) where - {-# SPECIALISE instance Additive.C (T Float) #-} - {-# SPECIALISE instance Additive.C (T Double) #-} - zero = Cons zero zero - (+) = Elem.run2 $ Elem.with Cons <*>.+ real <*>.+ imag - (-) = Elem.run2 $ Elem.with Cons <*>.- real <*>.- imag - negate = Elem.run $ Elem.with Cons <*>.-$ real <*>.-$ imag - -instance (Ring.C a) => Ring.C (T a) where - {-# SPECIALISE instance Ring.C (T Float) #-} - {-# SPECIALISE instance Ring.C (T Double) #-} - one = Cons one zero - fromInteger = fromReal . fromInteger - (Cons xr xi) * (Cons yr yi) = - Cons (xr*yr - scalarProduct xi yi) - (scaleImag xr yi + scaleImag yr xi + - crossProduct xi yi) - -instance (Field.C a) => Field.C (T a) where - {-# SPECIALISE instance Field.C (T Float) #-} - {-# SPECIALISE instance Field.C (T Double) #-} - recip x = scale (recip (normSqr x)) (conjugate x) - (Cons xr xi) / y@(Cons yr yi) = - scale (recip (normSqr y)) - (Cons (xr*yr + scalarProduct xi yi) - (scaleImag yr xi - scaleImag xr yi - crossProduct xi yi)) - -instance Vector.C T where - zero = zero - (<+>) = (+) - (*>) = scale - --- | The '(*>)' method can't replace 'scale' --- because it requires the Algebra.Module constraint -instance (Module.C a b) => Module.C a (T b) where - (*>) = Elem.run2 $ Elem.with Cons <*>.*> real <*>.*> imag - -instance (VectorSpace.C a b) => VectorSpace.C a (T b) - diff --git a/src-ghc-6.12/Number/Ratio.hs b/src-ghc-6.12/Number/Ratio.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/Ratio.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Module : Number.Ratio -Copyright : (c) Henning Thielemann, Dylan Thurston 2006 - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable (?) - -Ratios of mathematical objects. --} - -module Number.Ratio - ( - T((:%), numerator, denominator), (%), - Rational, - fromValue, - - scale, - split, - showsPrecAuto, - - toRational98, - ) where - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable -import qualified Algebra.Indexable as Indexable - -import Algebra.PrincipalIdealDomain (gcd, ) -import Algebra.Units (stdUnitInv, stdAssociate, ) -import Algebra.IntegralDomain (div, divMod, ) -import Algebra.Ring (one, (*), (^), fromInteger, ) -import Algebra.Additive (zero, (+), (-), negate, ) -import Algebra.ZeroTestable (isZero, ) - -import Control.Monad(liftM, liftM2, ) - -import Foreign.Storable (Storable (..), ) -import qualified Foreign.Storable.Record as Store -import Control.Applicative (liftA2, ) - -import Test.QuickCheck (Arbitrary(arbitrary)) -import System.Random (Random(..), RandomGen, ) - -import qualified Data.Ratio as Ratio98 - -import qualified Prelude as P -import NumericPrelude.Base - - -infixl 7 % - -data {- (PID.C a) => -} T a = (:%) { - numerator :: !a, - denominator :: !a - } deriving (Eq) -type Rational = T P.Integer - - -fromValue :: Ring.C a => a -> T a -fromValue x = x :% one - -scale :: (PID.C a) => a -> T a -> T a -scale s (x:%y) = - let {- x and y are cancelled, - thus we can only have common divisors in s and y -} - (n:%d) = s%y - in ((n*x):%d) - -{- | similar to 'Algebra.RealRing.splitFraction' -} -split :: (PID.C a) => T a -> (a, T a) -split (x:%y) = - let (q,r) = divMod x y - in (q, r:%y) - -ratioPrec :: P.Int -ratioPrec = 7 - -(%) :: (PID.C a) => a -> a -> T a -x % y = - if isZero y - then error "NumericPrelude.% : zero denominator" - else - let d = gcd x y - y0 = div y d - x0 = div x d - in (stdUnitInv y0 * x0) :% stdAssociate y0 - -instance (PID.C a) => Additive.C (T a) where - zero = fromValue zero --- (x:%y) + (x':%y') = (x*y' + x'*y) % (y*y') - {- - This version reduces the size of intermediate results. - Is it also faster than the naive version? - The final (%) includes another gcd computation, - but it is still needed since e.g. - 5:%7 + (-5):%7 shall be simplified to 0:%1, not 0:%7 . - -} - (x:%y) + (x':%y') = - let d = gcd y y' - y0 = div y d - y0' = div y' d - in (x*y0' + x'*y0) % (y0*y') - negate (x:%y) = (-x) :% y - -instance (PID.C a) => Ring.C (T a) where - one = fromValue one - fromInteger x = fromValue $ fromInteger x - (x:%y) * (x':%y') = (x * x') % (y * y') - (x:%y) ^ n = (x ^ n) :% (y ^ n) - -instance (Absolute.C a, PID.C a) => Absolute.C (T a) where - abs (x:%y) = Absolute.abs x :% y - signum (x:%_) = Absolute.signum x :% one - - -liftOrd :: Ring.C a => (a -> a -> b) -> (T a -> T a -> b) -liftOrd f (x:%y) (x':%y') = f (x * y') (x' * y) - -instance (Ord a, PID.C a) => Ord (T a) where - (<=) = liftOrd (<=) - (<) = liftOrd (<) - (>=) = liftOrd (>=) - (>) = liftOrd (>) - compare = liftOrd compare - -instance (Ord a, PID.C a) => Indexable.C (T a) where - compare = compare - -instance (ZeroTestable.C a, PID.C a) => ZeroTestable.C (T a) where - isZero = isZero . numerator - -instance (Read a, PID.C a) => Read (T a) where - readsPrec p = - readParen (p >= ratioPrec) - (\r -> [(x%y,u) | (x,s) <- readsPrec ratioPrec r, - ("%",t) <- lex s, - (y,u) <- readsPrec ratioPrec t ]) - -instance (Show a, PID.C a) => Show (T a) where - showsPrec p (x:%y) = showParen (p >= ratioPrec) - (shows x . showString " % " . shows y) - -{- | -This is an alternative show method -that is more user-friendly but also potentially more ambigious. --} - -showsPrecAuto :: (Eq a, PID.C a, Show a) => - P.Int -> T a -> String -> String -showsPrecAuto p (x:%y) = - if y == 1 - then showsPrec p x - else showParen (p > ratioPrec) - (showsPrec (ratioPrec+1) x . showString "/" . - showsPrec (ratioPrec+1) y) - - -instance (Arbitrary a, PID.C a, ZeroTestable.C a) => Arbitrary (T a) where -{- - arbitrary = liftM2 (%) arbitrary (untilM (not . isZero) arbitrary) - -This implementation leads to blocking: - -*Main> Test.QuickCheck.test (\x -> x==(x::Rational)) -Interrupted. --} - arbitrary = - liftM2 (%) arbitrary - (liftM (\x -> if isZero x then one else x) arbitrary) - - -instance (Storable a, PID.C a) => Storable (T a) where - sizeOf = Store.sizeOf store - alignment = Store.alignment store - peek = Store.peek store - poke = Store.poke store - -store :: - (Storable a, PID.C a) => - Store.Dictionary (T a) -store = - Store.run $ - liftA2 (%) - (Store.element numerator) - (Store.element denominator) - -{- -This instance may not be appropriate for mathematical objects other than numbers. -If we encounter such a type of object -we should define an intermediate class -which provides the necessary functions. -I should remark that methods of Random like 'randomR' -cannot sensibly be defined for ratios of polynomials. --} -instance (Random a, PID.C a, ZeroTestable.C a) => Random (T a) where - random g0 = - let (numer, g1) = random g0 - (denom, g2) = random g1 - in (numer % if isZero denom then one else denom, g2) - randomR (lower,upper) g0 = - let (k, g1) = randomR01 g0 - in (lower + k*(upper-lower), g1) - - -randomR01 :: - (Random a, PID.C a, RandomGen g) => - g -> (T a, g) -randomR01 g0 = - let (denom0, g1) = random g0 - denom = if isZero denom0 then one else denom0 - (numer, g2) = randomR (zero,denom) g1 - in (numer % denom, g2) - - --- * Legacy Instances - - --- | Necessary when mixing NumericPrelude.Numeric Rationals with Prelude98 Rationals - -toRational98 :: (P.Integral a, PID.C a) => T a -> Ratio98.Ratio a -toRational98 x = numerator x Ratio98.% denominator x - - -legacyInstance :: String -> a -legacyInstance op = - error ("Ratio." ++ op ++ ": legacy Ring instance for simple input of numeric literals") - - --- instance (P.Num a, PID.C a) => P.Num (T a) where -instance (P.Num a, PID.C a, Absolute.C a) => P.Num (T a) where - fromInteger n = P.fromInteger n % 1 - negate = negate -- for unary minus - (+) = legacyInstance "(+)" - (*) = legacyInstance "(*)" - abs = Absolute.abs -- needed for Arbitrary instance of NonNegative.Ratio - signum = legacyInstance "signum" - --- instance (P.Num a, PID.C a) => P.Fractional (T a) where -instance (P.Num a, PID.C a, Absolute.C a) => P.Fractional (T a) where --- fromRational = Field.fromRational - fromRational x = - fromInteger (Ratio98.numerator x) :% - fromInteger (Ratio98.denominator x) - (/) = legacyInstance "(/)" diff --git a/src-ghc-6.12/Number/ResidueClass.hs b/src-ghc-6.12/Number/ResidueClass.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/ResidueClass.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Number.ResidueClass where - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.IntegralDomain as Integral --- import qualified Algebra.Additive as Additive --- import qualified Algebra.ZeroTestable as ZeroTestable - -import NumericPrelude.Base -import NumericPrelude.Numeric hiding (recip) -import Data.Maybe.HT (toMaybe) -import Data.Maybe (fromMaybe) - - -add, sub :: (Integral.C a) => a -> a -> a -> a -add m x y = mod (x+y) m -sub m x y = mod (x-y) m - -neg :: (Integral.C a) => a -> a -> a -neg m x = mod (-x) m - -mul :: (Integral.C a) => a -> a -> a -> a -mul m x y = mod (x*y) m - - -{- | -The division may be ambiguous. -In this case an arbitrary quotient is returned. - -@ -0/:4 * 2/:4 == 0/:4 -2/:4 * 2/:4 == 0/:4 -@ --} -divideMaybe :: (PID.C a) => a -> a -> a -> Maybe a -divideMaybe m x y = - let (d,(_,z)) = extendedGCD m y - (q,r) = divMod x d - in toMaybe (isZero r) (mod (q*z) m) - -divide :: (PID.C a) => a -> a -> a -> a -divide m x y = - fromMaybe (error "ResidueClass.divide: indivisible") - (divideMaybe m x y) - -recip :: (PID.C a) => a -> a -> a -recip m = divide m one diff --git a/src-ghc-6.12/Number/ResidueClass/Check.hs b/src-ghc-6.12/Number/ResidueClass/Check.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/ResidueClass/Check.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Number.ResidueClass.Check where - -import qualified Number.ResidueClass as Res - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import Algebra.ZeroTestable(isZero) - -import qualified Data.Function.HT as Func -import Data.Maybe.HT (toMaybe, ) -import Text.Show.HT (showsInfixPrec, ) -import Text.Read.HT (readsInfixPrec, ) - -import NumericPrelude.Base -import NumericPrelude.Numeric (Int, Integer, mod, (*), ) - - -infix 7 /:, `Cons` - -{- | -The best solution seems to let 'modulus' be part of the type. -This could happen with a phantom type for modulus -and a @run@ function like 'Control.Monad.ST.runST'. -Then operations with non-matching moduli could be detected at compile time -and 'zero' and 'one' could be generated with the correct modulus. -An alternative trial can be found in module ResidueClassMaybe. --} -data T a - = Cons {modulus :: !a - ,representative :: !a - } - -factorPrec :: Int -factorPrec = read "7" - -instance (Show a) => Show (T a) where - showsPrec prec (Cons m r) = showsInfixPrec "/:" factorPrec prec r m - -instance (Read a, Integral.C a) => Read (T a) where - readsPrec prec = readsInfixPrec "/:" factorPrec prec (/:) - - --- | @r \/: m@ is the residue class containing @r@ with respect to the modulus @m@ -(/:) :: (Integral.C a) => a -> a -> T a -(/:) r m = Cons m (mod r m) - --- | Check if two residue classes share the same modulus -isCompatible :: (Eq a) => T a -> T a -> Bool -isCompatible x y = modulus x == modulus y - -maybeCompatible :: (Eq a) => T a -> T a -> Maybe a -maybeCompatible x y = - let mx = modulus x - my = modulus y - in toMaybe (mx==my) mx - - -fromRepresentative :: (Integral.C a) => a -> a -> T a -fromRepresentative m x = Cons m (mod x m) - -lift1 :: (Eq a) => (a -> a -> a) -> T a -> T a -lift1 f x = - let m = modulus x - in Cons m (f m (representative x)) - -lift2 :: (Eq a) => (a -> a -> a -> a) -> T a -> T a -> T a -lift2 f x y = - maybe - (errIncompat) - (\m -> Cons m (f (modulus x) (representative x) (representative y))) - (maybeCompatible x y) - -errIncompat :: a -errIncompat = error "Residue class: Incompatible operands" - - -zero :: (Additive.C a) => a -> T a -zero m = Cons m Additive.zero - -one :: (Ring.C a) => a -> T a -one m = Cons m Ring.one - -fromInteger :: (Integral.C a) => a -> Integer -> T a -fromInteger m x = fromRepresentative m (Ring.fromInteger x) - - - -instance (Eq a) => Eq (T a) where - (==) x y = - maybe errIncompat - (const (representative x == representative y)) - (maybeCompatible x y) - -instance (ZeroTestable.C a) => ZeroTestable.C (T a) where - isZero (Cons _ r) = isZero r - -instance (Eq a, Integral.C a) => Additive.C (T a) where - zero = error "no generic zero in a residue class, use ResidueClass.zero" - (+) = lift2 Res.add - (-) = lift2 Res.sub - negate = lift1 Res.neg - -instance (Eq a, Integral.C a) => Ring.C (T a) where - one = error "no generic one in a residue class, use ResidueClass.one" - (*) = lift2 Res.mul - fromInteger = error "no generic integer in a residue class, use ResidueClass.fromInteger" - x^n = Func.powerAssociative (*) (one (modulus x)) x n - -instance (Eq a, PID.C a) => Field.C (T a) where - (/) = lift2 Res.divide - recip = lift1 (flip Res.divide Ring.one) - fromRational' = error "no conversion from rational to residue class" diff --git a/src-ghc-6.12/Number/ResidueClass/Func.hs b/src-ghc-6.12/Number/ResidueClass/Func.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/ResidueClass/Func.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Number.ResidueClass.Func where - -import qualified Number.ResidueClass as Res - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.EqualityDecision as EqDec - -import Algebra.EqualityDecision ((==?), ) -import NumericPrelude.Base -import NumericPrelude.Numeric hiding (zero, one, ) - -import qualified Prelude as P -import qualified NumericPrelude.Numeric as NP - -{- | -Here a residue class is a representative -and the modulus is an argument. -You cannot show a value of type 'T', -you can only show it with respect to a concrete modulus. -Values cannot be compared, -because the comparison result depends on the modulus. --} -newtype T a = Cons (a -> a) - -concrete :: a -> T a -> a -concrete m (Cons r) = r m - -fromRepresentative :: (Integral.C a) => a -> T a -fromRepresentative = Cons . mod - -lift0 :: (a -> a) -> T a -lift0 = Cons - -lift1 :: (a -> a -> a) -> T a -> T a -lift1 f (Cons x) = Cons $ \m -> f m (x m) - -lift2 :: (a -> a -> a -> a) -> T a -> T a -> T a -lift2 f (Cons x) (Cons y) = Cons $ \m -> f m (x m) (y m) - - -zero :: (Additive.C a) => T a -zero = Cons $ const Additive.zero - -one :: (Ring.C a) => T a -one = Cons $ const NP.one - -fromInteger :: (Integral.C a) => Integer -> T a -fromInteger = fromRepresentative . NP.fromInteger - -equal :: Eq a => a -> T a -> T a -> Bool -equal m (Cons x) (Cons y) = x m == y m - - -instance (EqDec.C a) => EqDec.C (T a) where - (==?) (Cons x) (Cons y) (Cons eq) (Cons noteq) = - Cons (\m -> (x m ==? y m) (eq m) (noteq m)) - -instance (Integral.C a) => Additive.C (T a) where - zero = zero - (+) = lift2 Res.add - (-) = lift2 Res.sub - negate = lift1 Res.neg - -instance (Integral.C a) => Ring.C (T a) where - one = one - (*) = lift2 Res.mul - fromInteger = Number.ResidueClass.Func.fromInteger - -instance (PID.C a) => Field.C (T a) where - (/) = lift2 Res.divide - recip = (NP.one /) - fromRational' = error "no conversion from rational to residue class" - - -{- -NumericPrelude.fromInteger seems to be not available at GHCi's prompt sometimes. -But Prelude.fromInteger requires Prelude.Num instance. --} - --- legacy instances for work with GHCi -legacyInstance :: a -legacyInstance = - error "legacy Ring.C instance for simple input of numeric literals" - -instance (P.Num a, Integral.C a) => P.Num (T a) where - fromInteger = Number.ResidueClass.Func.fromInteger - negate = negate --for unary minus - (+) = legacyInstance - (*) = legacyInstance - abs = legacyInstance - signum = legacyInstance - -instance Eq (T a) where - (==) = error "ResidueClass.Func: (==) not implemented" - -instance Show (T a) where - show = error "ResidueClass.Func: 'show' not implemented" diff --git a/src-ghc-6.12/Number/ResidueClass/Maybe.hs b/src-ghc-6.12/Number/ResidueClass/Maybe.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/ResidueClass/Maybe.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Number.ResidueClass.Maybe where - -import qualified Number.ResidueClass as Res - -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import NumericPrelude.Base -import NumericPrelude.Numeric - -infix 7 /:, `Cons` - - -{- | -Here we try to provide implementations for 'zero' and 'one' -by making the modulus optional. -We have to provide non-modulus operations for the cases -where both operands have Nothing modulus. -This is problematic since operations like '(\/)' -depend essentially on the modulus. - -A working version with disabled 'zero' and 'one' can be found ResidueClass. --} -data T a - = Cons {modulus :: !(Maybe a) -- ^ the modulus can be Nothing to denote a generic constant like 'zero' and 'one' which could not be bound to a specific modulus so far - ,representative :: !a - } - deriving (Show, Read) - - --- | @r \/: m@ is the residue class containing @r@ with respect to the modulus @m@ -(/:) :: (Integral.C a) => a -> a -> T a -(/:) r m = Cons (Just m) (mod r m) - - -matchMaybe :: Maybe a -> Maybe a -> Maybe a -matchMaybe Nothing y = y -matchMaybe x _ = x - -isCompatibleMaybe :: (Eq a) => Maybe a -> Maybe a -> Bool -isCompatibleMaybe Nothing _ = True -isCompatibleMaybe _ Nothing = True -isCompatibleMaybe (Just x) (Just y) = x == y - --- | Check if two residue classes share the same modulus -isCompatible :: (Eq a) => T a -> T a -> Bool -isCompatible x y = isCompatibleMaybe (modulus x) (modulus y) - - -lift2 :: (Eq a) => (a -> a -> a -> a) -> (a -> a -> a) -> (T a -> T a -> T a) -lift2 f g x y = - if isCompatible x y - then let m = matchMaybe (modulus x) (modulus y) - in Cons m - (maybe g f m (representative x) (representative y)) - else error "ResidueClass: Incompatible operands" - - -instance (Eq a, ZeroTestable.C a, Integral.C a) => Eq (T a) where - (==) x y = - if isCompatible x y - then maybe (==) - (\m x' y' -> isZero (mod (x'-y') m)) - (matchMaybe (modulus x) (modulus y)) - (representative x) (representative y) - else error "ResidueClass.(==): Incompatible operands" - -instance (Eq a, Integral.C a) => Additive.C (T a) where - zero = Cons Nothing zero - (+) = lift2 Res.add (+) - (-) = lift2 Res.sub (-) - negate (Cons m r) = Cons m (negate r) - -instance (Eq a, Integral.C a) => Ring.C (T a) where - one = Cons Nothing one - (*) = lift2 Res.mul (*) - fromInteger = Cons Nothing . fromInteger diff --git a/src-ghc-6.12/Number/ResidueClass/Reader.hs b/src-ghc-6.12/Number/ResidueClass/Reader.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/ResidueClass/Reader.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Number.ResidueClass.Reader where - -import qualified Number.ResidueClass as Res - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive - -import NumericPrelude.Base -import NumericPrelude.Numeric - -import Control.Monad (liftM2, liftM4) --- import Control.Monad.Reader (MonadReader) - -import qualified Prelude as P -import qualified NumericPrelude.Numeric as NP - - -{- | -T is a Reader monad but does not need functional dependencies -like that from the Monad Transformer Library. --} -newtype T a b = Cons {toFunc :: a -> b} - -concrete :: a -> T a b -> b -concrete m (Cons r) = r m - -fromRepresentative :: (Integral.C a) => a -> T a a -fromRepresentative = Cons . mod - - -getZero :: (Additive.C a) => T a a -getZero = Cons $ const Additive.zero - -getOne :: (Ring.C a) => T a a -getOne = Cons $ const NP.one - -fromInteger :: (Integral.C a) => Integer -> T a a -fromInteger = fromRepresentative . NP.fromInteger - - -instance Monad (T a) where - (Cons x) >>= y = Cons (\r -> toFunc (y (x r)) r) - return = Cons . const - - - -getAdd :: Integral.C a => T a (a -> a -> a) -getAdd = Cons Res.add - -getSub :: Integral.C a => T a (a -> a -> a) -getSub = Cons Res.sub - -getNeg :: Integral.C a => T a (a -> a) -getNeg = Cons Res.neg - -getAdditiveVars :: Integral.C a => T a (a, a -> a -> a, a -> a -> a, a -> a) -getAdditiveVars = liftM4 (,,,) getZero getAdd getSub getNeg - - - -getMul :: Integral.C a => T a (a -> a -> a) -getMul = Cons Res.mul - -getRingVars :: Integral.C a => T a (a, a -> a -> a) -getRingVars = liftM2 (,) getOne getMul - - - -getDivide :: PID.C a => T a (a -> a -> a) -getDivide = Cons Res.divide - -getRecip :: PID.C a => T a (a -> a) -getRecip = Cons Res.recip - -getFieldVars :: PID.C a => T a (a -> a -> a, a -> a) -getFieldVars = liftM2 (,) getDivide getRecip - -monadExample :: PID.C a => T a [a] -monadExample = - do (zero',(+~),(-~),negate') <- getAdditiveVars - (one',(*~)) <- getRingVars - ((/~),recip') <- getFieldVars - let three = one'+one'+one' -- is easier if only NP.fromInteger is visible - let seven = three+three+one' - return [zero'*~three, one'/~three, recip' three, - three *~ seven, one' +~ three +~ seven, - zero' -~ three, negate' three +~ seven] - -runExample :: [Integer] -runExample = - let three = one+one+one - eleven = three+three+three + one+one - in concrete eleven monadExample diff --git a/src-ghc-6.12/Number/Root.hs b/src-ghc-6.12/Number/Root.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/Root.hs +++ /dev/null @@ -1,97 +0,0 @@ -module Number.Root where - -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field -import qualified Algebra.Ring as Ring - -import qualified MathObj.RootSet as RootSet -import qualified Number.Ratio as Ratio - -import Algebra.IntegralDomain (divChecked, ) - -import qualified NumericPrelude.Numeric as NP -import NumericPrelude.Numeric hiding (recip, ) -import NumericPrelude.Base -import Prelude () - -{- | -The root degree must be positive. -This way we can implement multiplication -using only multiplication from type @a@. --} -data T a = Cons Integer a - deriving (Show) - -{- | -When you use @fmap@ you must assert that -@forall n. fmap f (Cons d x) == fmap f (Cons (n*d) (x^n))@ --} -instance Functor T where - fmap f (Cons d x) = Cons d (f x) - -fromNumber :: a -> T a -fromNumber = Cons 1 - -toNumber :: Algebraic.C a => T a -> a -toNumber (Cons n x) = Algebraic.root n x - -toRootSet :: Ring.C a => T a -> RootSet.T a -toRootSet (Cons d x) = - RootSet.lift0 ([negate x] ++ replicate (pred (fromInteger d)) zero ++ [one]) - - -commonDegree :: Ring.C a => T a -> T a -> T (a,a) -commonDegree (Cons xd x) (Cons yd y) = - let zd = lcm xd yd - in Cons zd (x ^ divChecked zd xd, y ^ divChecked zd yd) - -instance (Eq a, Ring.C a) => Eq (T a) where - x == y = - case commonDegree x y of - Cons _ (xn,yn) -> xn==yn - -instance (Ord a, Ring.C a) => Ord (T a) where - compare x y = - case commonDegree x y of - Cons _ (xn,yn) -> compare xn yn - - -mul :: Ring.C a => T a -> T a -> T a -mul x y = fmap (uncurry (*)) $ commonDegree x y - -div :: Field.C a => T a -> T a -> T a -div x y = fmap (uncurry (/)) $ commonDegree x y - -recip :: Field.C a => T a -> T a -recip = fmap NP.recip - -{- | -exponent must be non-negative --} -cardinalPower :: Ring.C a => Integer -> T a -> T a -cardinalPower n (Cons d x) = - let m = gcd n d - in Cons (divChecked d m) (x ^ divChecked n m) - -{- | -exponent can be negative --} -integerPower :: Field.C a => Integer -> T a -> T a -integerPower n = - if n<0 - then cardinalPower (-n) . recip - else cardinalPower n - -rationalPower :: Field.C a => Rational -> T a -> T a -rationalPower n = - integerPower (Ratio.numerator n) . - root (Ratio.denominator n) - -{- | -exponent must be positive --} -root :: Ring.C a => Integer -> T a -> T a -root n (Cons d x) = Cons (d*n) x - -sqrt :: Ring.C a => T a -> T a -sqrt = root 2 diff --git a/src-ghc-6.12/Number/SI.hs b/src-ghc-6.12/Number/SI.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/SI.hs +++ /dev/null @@ -1,271 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- | -Copyright : (c) Henning Thielemann 2003-2006 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable - -Numerical values equipped with SI units. -This is considered as the user front-end. --} - -module Number.SI where - -import qualified Number.SI.Unit as SIUnit -import Number.SI.Unit (Dimension, bytesize) - -import qualified Number.Physical as Value -import qualified Number.Physical.Unit as Unit -import qualified Number.Physical.Show as PVShow -import qualified Number.Physical.Read as PVRead -import qualified Number.Physical.UnitDatabase as UnitDatabase - -import Algebra.OccasionallyScalar as OccScalar -import qualified Algebra.NormedSpace.Maximum as NormedMax - -import qualified Algebra.VectorSpace as VectorSpace -import qualified Algebra.Module as Module -import qualified Algebra.Vector as Vector -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field -import qualified Algebra.Absolute as Absolute -import qualified Algebra.Ring as Ring -import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable - -import Algebra.Algebraic (sqrt, (^/), ) - -import Data.Tuple.HT (mapFst, ) - -import qualified Prelude as P - -import NumericPrelude.Numeric -import NumericPrelude.Base - - -newtype T a v = Cons (PValue v) -{- LANGUAGE GeneralizedNewtypeDeriving allows even this - deriving (Monad, Functor) --} - -type PValue v = Value.T Dimension v - -{- -import Control.Monad - -instance Functor (SIValue.T a) where - fmap f (SIValue.Cons x) = SIValue.Cons (f x) - -instance Monad (SIValue.T a) where - (>>=) (SIValue.Cons x) f = f x - return = SIValue.Cons --} - -{- I hoped it would be possible to replace these functions - by fmap and monadic liftM, liftM2, return - - but SIValue.Cons lifts from the base type 'v' to 'SIValue.T a v' - rather than the type 'PValue v' to 'SIValue.T a v'. - - I.e. - fmap :: (v -> v) -> SIValue.T a v -> SIValue.T a v --} -lift :: (PValue v0 -> PValue v1) -> - (T a v0 -> T a v1) -lift f (Cons x) = (Cons (f x)) - -lift2 :: (PValue v0 -> PValue v1 -> PValue v2) -> - (T a v0 -> T a v1 -> T a v2) -lift2 f (Cons x) (Cons y) = (Cons (f x y)) - -liftGen :: (PValue v -> x) -> (T a v -> x) -liftGen f (Cons x) = f x - -lift2Gen :: (PValue v0 -> PValue v1 -> x) -> - (T a v0 -> T a v1 -> x) -lift2Gen f (Cons x) (Cons y) = f x y - - -{- There is almost nothing new to implement for SIValues. - We have to lift existing functions to SIValues mainly. -} - -scale :: Ring.C v => v -> T a v -> T a v -scale = lift . Value.scale - -fromScalarSingle :: v -> T a v -fromScalarSingle = Cons . Value.fromScalarSingle - - -instance (ZeroTestable.C v) => ZeroTestable.C (T a v) where - isZero = liftGen isZero - -instance Eq v => Eq (T a v) where - (==) = lift2Gen (==) - -showNat :: (Show v, Field.C a, Ord a, NormedMax.C a v) => - UnitDatabase.T Dimension a -> T a v -> String -showNat db = - liftGen (PVShow.showNat db) - -instance (Show v, Ord a, Trans.C a, NormedMax.C a v) => - Show (T a v) where - showsPrec prec x = - showParen (prec > PVShow.mulPrec) - (showNat SIUnit.databaseShow x ++) - -readsNat :: (Read v, VectorSpace.C a v) => - UnitDatabase.T Dimension a -> Int -> ReadS (T a v) -readsNat db prec = - map (mapFst Cons) . PVRead.readsNat db prec - -instance (Read v, Ord a, Trans.C a, VectorSpace.C a v) => - Read (T a v) where - readsPrec = readsNat SIUnit.databaseRead - -instance (Additive.C v) => Additive.C (T a v) where - zero = Cons zero - (+) = lift2 (+) - (-) = lift2 (-) - negate = lift negate - -instance (Ring.C v) => Ring.C (T a v) where - (*) = lift2 (*) - fromInteger = Cons . fromInteger - -instance (Ord v) => Ord (T a v) where - max = lift2 max - min = lift2 min - compare = lift2Gen compare - (<) = lift2Gen (<) - (>) = lift2Gen (>) - (<=) = lift2Gen (<=) - (>=) = lift2Gen (>=) - -instance (Absolute.C v) => Absolute.C (T a v) where - abs = lift abs - signum = lift signum - -instance (Field.C v) => Field.C (T a v) where - (/) = lift2 (/) - fromRational' = Cons . fromRational' - -instance (Algebraic.C v) => Algebraic.C (T a v) where - sqrt = lift sqrt - x ^/ y = lift (^/ y) x - -instance (Trans.C v) => Trans.C (T a v) where - pi = Cons pi - log = lift log - exp = lift exp - logBase = lift2 logBase - (**) = lift2 (**) - cos = lift cos - tan = lift tan - sin = lift sin - acos = lift acos - atan = lift atan - asin = lift asin - cosh = lift cosh - tanh = lift tanh - sinh = lift sinh - acosh = lift acosh - atanh = lift atanh - asinh = lift asinh - - -instance Vector.C (T a) where - zero = zero - (<+>) = (+) - (*>) = scale - -instance (Module.C a v) => Module.C a (T b v) where - (*>) x = lift (x Module.*>) - -instance (VectorSpace.C a v) => VectorSpace.C a (T b v) - -instance (Trans.C a, Ord a, OccScalar.C a v, - Show v, NormedMax.C a v) - => OccScalar.C a (T a v) where - toScalar = toScalarShow - toMaybeScalar = liftGen toMaybeScalar - fromScalar = Cons . fromScalar - - - -quantity :: (Field.C a, Field.C v) => Unit.T Dimension -> v -> T a v -quantity xu = Cons . Value.Cons xu - -hertz, second, minute, hour, day, year, - meter, liter, gramm, tonne, - newton, pascal, bar, joule, watt, - kelvin, - coulomb, ampere, volt, ohm, farad, - bit, byte, baud, - inch, foot, yard, astronomicUnit, parsec, - mach, speedOfLight, electronVolt, - calorien, horsePower, accelerationOfEarthGravity :: - (Field.C a, Field.C v) => T a v - -hertz = quantity SIUnit.frequency 1e+0 -second = quantity SIUnit.time 1e+0 -minute = quantity SIUnit.time SIUnit.secondsPerMinute -hour = quantity SIUnit.time SIUnit.secondsPerHour -day = quantity SIUnit.time SIUnit.secondsPerDay -year = quantity SIUnit.time SIUnit.secondsPerYear -meter = quantity SIUnit.length 1e+0 -liter = quantity SIUnit.volume 1e-3 -gramm = quantity SIUnit.mass 1e-3 -tonne = quantity SIUnit.mass 1e+3 -newton = quantity SIUnit.force 1e+0 -pascal = quantity SIUnit.pressure 1e+0 -bar = quantity SIUnit.pressure 1e+5 -joule = quantity SIUnit.energy 1e+0 -watt = quantity SIUnit.power 1e+0 -coulomb = quantity SIUnit.charge 1e+0 -ampere = quantity SIUnit.current 1e+0 -volt = quantity SIUnit.voltage 1e+0 -ohm = quantity SIUnit.resistance 1e+0 -farad = quantity SIUnit.capacitance 1e+0 -kelvin = quantity SIUnit.temperature 1e+0 -bit = quantity SIUnit.information 1e+0 -byte = quantity SIUnit.information bytesize -baud = quantity SIUnit.dataRate 1e+0 - -inch = quantity SIUnit.length SIUnit.meterPerInch -foot = quantity SIUnit.length SIUnit.meterPerFoot -yard = quantity SIUnit.length SIUnit.meterPerYard -astronomicUnit = quantity SIUnit.length SIUnit.meterPerAstronomicUnit -parsec = quantity SIUnit.length SIUnit.meterPerParsec - -accelerationOfEarthGravity - = quantity SIUnit.acceleration SIUnit.accelerationOfEarthGravity -mach = quantity SIUnit.speed SIUnit.mach -speedOfLight = quantity SIUnit.speed SIUnit.speedOfLight -electronVolt = quantity SIUnit.energy SIUnit.electronVolt -calorien = quantity SIUnit.energy SIUnit.calorien -horsePower = quantity SIUnit.power SIUnit.horsePower - - - --- legacy instances for work with GHCi -legacyInstance :: a -legacyInstance = - error "legacy Ring.C instance for simple input of numeric literals" - -instance (Ord a, Trans.C a, NormedMax.C a v, P.Num v, Ring.C v) => - P.Num (T a v) where - fromInteger = fromInteger - negate = negate -- for unary minus - (+) = legacyInstance - (*) = legacyInstance - abs = legacyInstance - signum = legacyInstance - -instance (Ord a, Trans.C a, NormedMax.C a v, P.Num v, Field.C v) => - P.Fractional (T a v) where - fromRational = fromRational - (/) = legacyInstance diff --git a/src-ghc-6.12/Number/SI/Unit.hs b/src-ghc-6.12/Number/SI/Unit.hs deleted file mode 100644 --- a/src-ghc-6.12/Number/SI/Unit.hs +++ /dev/null @@ -1,293 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Copyright : (c) Henning Thielemann 2003 -License : GPL - -Maintainer : numericprelude@henning-thielemann.de -Stability : provisional -Portability : portable - -Special physical units: SI unit system --} - -module Number.SI.Unit where - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.Field as Field - -import qualified Number.Physical.Unit as Unit -import qualified Number.Physical.UnitDatabase as UnitDatabase -import Number.Physical.UnitDatabase(initScale, initUnitSet) -import Data.Maybe(catMaybes) - -import NumericPrelude.Base hiding (length) -import NumericPrelude.Numeric hiding (one) - -data Dimension = - Length | Time | Mass | Charge | - Angle | Temperature | Information - deriving (Eq, Ord, Enum, Show) - - --- | Some common quantity classes. -angle, angularSpeed, -- needs explicit signature because it does not occur in the database - length, distance, area, volume, time, - frequency, speed, acceleration, mass, - force, pressure, energy, power, - charge, current, voltage, resistance, - capacitance, temperature, - information, dataRate - :: Unit.T Dimension - -length = Unit.fromVector [ 1, 0, 0, 0, 0, 0, 0] --- synonym for 'length' which is distinct from List.length -distance = Unit.fromVector [ 1, 0, 0, 0, 0, 0, 0] -area = Unit.fromVector [ 2, 0, 0, 0, 0, 0, 0] -volume = Unit.fromVector [ 3, 0, 0, 0, 0, 0, 0] -time = Unit.fromVector [ 0, 1, 0, 0, 0, 0, 0] -frequency = Unit.fromVector [ 0,-1, 0, 0, 0, 0, 0] -speed = Unit.fromVector [ 1,-1, 0, 0, 0, 0, 0] -acceleration = Unit.fromVector [ 1,-2, 0, 0, 0, 0, 0] -mass = Unit.fromVector [ 0, 0, 1, 0, 0, 0, 0] -force = Unit.fromVector [ 1,-2, 1, 0, 0, 0, 0] -pressure = Unit.fromVector [-1,-2, 1, 0, 0, 0, 0] -energy = Unit.fromVector [ 2,-2, 1, 0, 0, 0, 0] -power = Unit.fromVector [ 2,-3, 1, 0, 0, 0, 0] -charge = Unit.fromVector [ 0, 0, 0, 1, 0, 0, 0] -current = Unit.fromVector [ 0,-1, 0, 1, 0, 0, 0] -voltage = Unit.fromVector [ 2,-2, 1,-1, 0, 0, 0] -resistance = Unit.fromVector [ 2,-1, 1,-2, 0, 0, 0] -capacitance = Unit.fromVector [-2, 2,-1, 2, 0, 0, 0] -angle = Unit.fromVector [ 0, 0, 0, 0, 1, 0, 0] -angularSpeed = Unit.fromVector [ 0,-1, 0, 0, 1, 0, 0] -temperature = Unit.fromVector [ 0, 0, 0, 0, 0, 1, 0] -information = Unit.fromVector [ 0, 0, 0, 0, 0, 0, 1] -dataRate = Unit.fromVector [ 0,-1, 0, 0, 0, 0, 1] - - -percent, fourth, half, threeFourth :: Field.C a => a - -secondsPerMinute, secondsPerHour, secondsPerDay, secondsPerYear, - meterPerInch, meterPerFoot, meterPerYard, - meterPerAstronomicUnit, meterPerParsec, - accelerationOfEarthGravity, - k2, deg180, grad200, bytesize :: Field.C a => a - -radPerDeg, radPerGrad :: Trans.C a => a - -mach, speedOfLight, electronVolt, - calorien, horsePower :: Field.C a => a - -yocto, zepto, atto, femto, pico, - nano, micro, milli, centi, deci, - one, deca, hecto, kilo, mega, - giga, tera, peta, exa, zetta, yotta :: Field.C a => a - --- | Common constants -percent = 0.01 -fourth = 0.25 -half = 0.50 -threeFourth = 0.75 - --- | Conversion factors -secondsPerMinute = 60 -secondsPerHour = 60*secondsPerMinute -secondsPerDay = 24*secondsPerHour -- 86400.0 -secondsPerYear = 365.2422*secondsPerDay - -meterPerInch = 0.0254 -meterPerFoot = 0.3048 -meterPerYard = 0.9144 -meterPerAstronomicUnit = 149.6e6 -meterPerParsec = 30.857e12 - -k2 = 1024 -deg180 = 180 -grad200 = 200 -radPerDeg = pi/deg180; -radPerGrad = pi/grad200; -bytesize = 8 - - - --- | Physical constants -accelerationOfEarthGravity = 9.80665 -mach = 332.0 -speedOfLight = 299792458.0 -electronVolt = 1.602e-19 -calorien = 4.19 -horsePower = 736.0 - --- | Prefixes used for SI units -yocto = 1.0e-24 -zepto = 1.0e-21 -atto = 1.0e-18 -femto = 1.0e-15 -pico = 1.0e-12 -nano = 1.0e-9 -micro = 1.0e-6 -milli = 1.0e-3 -centi = 1.0e-2 -deci = 1.0e-1 -one = 1.0e0 -deca = 1.0e1 -hecto = 1.0e2 -kilo = 1.0e3 -mega = 1.0e6 -giga = 1.0e9 -tera = 1.0e12 -peta = 1.0e15 -exa = 1.0e18 -zetta = 1.0e21 -yotta = 1.0e24 - - - -{- | UnitDatabase.T of units and their common scalings -} -databaseRead, databaseShow :: Trans.C a => UnitDatabase.T Dimension a -databaseRead = map UnitDatabase.createUnitSet database -databaseShow = - map UnitDatabase.createUnitSet $ - catMaybes $ map UnitDatabase.showableUnit database - -database :: Trans.C a => [UnitDatabase.InitUnitSet Dimension a] -database = [ - (initUnitSet Unit.scalar False [ - (initScale "pi" pi False False), - (initScale "e" (exp 1) False False), - (initScale "i" (sqrt (-1)) False False), - (initScale "%" percent False False), - (initScale "\188" fourth False False), - (initScale "\189" half False False), - (initScale "\190" threeFourth False False) - ]), - (initUnitSet angle False [ - (initScale "''" (radPerDeg/secondsPerHour) True False), - (initScale "'" (radPerDeg/secondsPerMinute) True False), - (initScale "grad" radPerGrad False False), - (initScale "\176" radPerDeg True True ), - (initScale "rad" one False False) - ]), - (initUnitSet frequency True [ - (initScale "bpm" (one/secondsPerMinute) False False), - (initScale "Hz" one True True ), - (initScale "kHz" kilo True False), - (initScale "MHz" mega True False), - (initScale "GHz" giga True False) - ]), - (initUnitSet time False [ - (initScale "ns" nano True False), - (initScale "\181s" micro True False), - (initScale "ms" milli True False), - (initScale "s" one True True ), - (initScale "min" secondsPerMinute True False), - (initScale "h" secondsPerHour True False), - (initScale "d" secondsPerDay True False), - (initScale "a" secondsPerYear True False) - ]), --- (initUnitSet distance False [ - (initUnitSet length False [ - (initScale "nm" nano True False), - (initScale "\181m" micro True False), - (initScale "mm" milli True False), - (initScale "cm" centi True False), - (initScale "dm" deci True False), - (initScale "m" one True True ), - (initScale "km" kilo True False) - ]), - (initUnitSet area False [ - (initScale "ha" (hecto*hecto) False False) - ]), - (initUnitSet volume False [ - (initScale "ml" (milli*milli) False False), - (initScale "cl" (milli*centi) False False), - (initScale "l" milli False False) - ]), - (initUnitSet speed False [ - (initScale "mach" mach False False), - (initScale "c" speedOfLight False False) - ]), - (initUnitSet acceleration False [ - (initScale "G" accelerationOfEarthGravity False False) - ]), - (initUnitSet mass False [ - (initScale "\181g" nano True False), - (initScale "mg" micro True False), - (initScale "g" milli True False), - (initScale "kg" one True True ), - (initScale "dt" hecto True False), - (initScale "t" kilo True False), - (initScale "kt" mega True False) - ]), - (initUnitSet force False [ - (initScale "N" one True True ), - (initScale "kp" accelerationOfEarthGravity False False), - (initScale "kN" kilo True False) - ]), - (initUnitSet pressure False [ - (initScale "Pa" one True True ), - (initScale "mbar" hecto False False), - (initScale "kPa" kilo True False), - (initScale "bar" (hecto*kilo) False False) - ]), - (initUnitSet energy False [ - (initScale "eV" electronVolt False False), - (initScale "J" one True True ), - (initScale "cal" calorien False False), - (initScale "kJ" kilo True False), - (initScale "kcal" (kilo*calorien) False False), - (initScale "MJ" mega True False) - ]), - (initUnitSet power False [ - (initScale "mW" milli True False), - (initScale "W" one True True ), - (initScale "HP" horsePower False False), - (initScale "kW" kilo True False), - (initScale "MW" mega True False) - ]), - (initUnitSet charge False [ - (initScale "C" one True True ) - ]), - (initUnitSet current False [ - (initScale "\181A" micro True False), - (initScale "mA" milli True False), - (initScale "A" one True True ) - ]), - (initUnitSet voltage False [ - (initScale "mV" milli True False), - (initScale "V" one True True ), - (initScale "kV" kilo True False), - (initScale "MV" mega True False), - (initScale "GV" giga True False) - ]), - (initUnitSet resistance False [ - (initScale "Ohm" one True True ), - (initScale "kOhm" kilo True False), - (initScale "MOhm" mega True False) - ]), - (initUnitSet capacitance False [ - (initScale "pF" pico True False), - (initScale "nF" nano True False), - (initScale "\181F" micro True False), - (initScale "mF" milli True False), - (initScale "F" one True True ) - ]), - (initUnitSet temperature False [ - (initScale "K" one True True ) - ]), - (initUnitSet information False [ - (initScale "bit" one True True ), - (initScale "B" bytesize True False), - (initScale "kB" (kilo*bytesize) False False), - (initScale "KB" (k2*bytesize) True False), - (initScale "MB" (k2*k2*bytesize) True False), - (initScale "GB" (k2*k2*k2*bytesize) True False) - ]), - (initUnitSet dataRate True [ - (initScale "baud" one True True ), - (initScale "kbaud" kilo False False), - (initScale "Kbaud" k2 True False), - (initScale "Mbaud" (k2*k2) True False), - (initScale "Gbaud" (k2*k2*k2) True False) - ]) - ] diff --git a/src-ghc-6.12/NumericPrelude.hs b/src-ghc-6.12/NumericPrelude.hs deleted file mode 100644 --- a/src-ghc-6.12/NumericPrelude.hs +++ /dev/null @@ -1,9 +0,0 @@ -module NumericPrelude - (module NumericPrelude.Numeric, - module NumericPrelude.Base, - max, min, abs, ) where - -import NumericPrelude.Numeric hiding (abs, ) -import NumericPrelude.Base hiding (max, min, ) -import Prelude () -import Algebra.Lattice (max, min, abs, ) diff --git a/src-ghc-6.12/NumericPrelude/Base.hs b/src-ghc-6.12/NumericPrelude/Base.hs deleted file mode 100644 --- a/src-ghc-6.12/NumericPrelude/Base.hs +++ /dev/null @@ -1,12 +0,0 @@ -{- | -The only point of this module is -to reexport items that we want from the standard Prelude. --} - -module NumericPrelude.Base (module Prelude) where -import Prelude hiding ( - Int, Integer, Float, Double, Rational, Num(..), Real(..), - Integral(..), Fractional(..), Floating(..), RealFrac(..), - RealFloat(..), subtract, even, odd, - gcd, lcm, (^), (^^), sum, product, - fromIntegral, fromRational, ) diff --git a/src-ghc-6.12/NumericPrelude/Elementwise.hs b/src-ghc-6.12/NumericPrelude/Elementwise.hs deleted file mode 100644 --- a/src-ghc-6.12/NumericPrelude/Elementwise.hs +++ /dev/null @@ -1,54 +0,0 @@ -module NumericPrelude.Elementwise where - -import Control.Applicative (Applicative(pure, (<*>)), ) - -{- | -A reader monad for the special purpose -of defining instances of certain operations on tuples and records. -It does not add any new functionality to the common Reader monad, -but it restricts the functions to the required ones -and exports them from one module. -That is you do not have to import -both Control.Monad.Trans.Reader and Control.Applicative. -The type also tells the user, for what the Reader monad is used. -We can more easily replace or extend the implementation when needed. --} -newtype T v a = Cons {run :: v -> a} - -{-# INLINE with #-} -with :: a -> T v a -with e = Cons $ \ _v -> e - -{-# INLINE element #-} -element :: (v -> a) -> T v a -element = Cons - - -{-# INLINE run2 #-} -run2 :: T (x,y) a -> x -> y -> a -run2 = curry . run - -{-# INLINE run3 #-} -run3 :: T (x,y,z) a -> x -> y -> z -> a -run3 e x y z = run e (x,y,z) - -{-# INLINE run4 #-} -run4 :: T (x,y,z,w) a -> x -> y -> z -> w -> a -run4 e x y z w = run e (x,y,z,w) - -{-# INLINE run5 #-} -run5 :: T (x,y,z,u,w) a -> x -> y -> z -> u -> w -> a -run5 e x y z u w = run e (x,y,z,u,w) - - -instance Functor (T v) where - {-# INLINE fmap #-} - fmap f (Cons e) = - Cons $ \v -> f $ e v - -instance Applicative (T v) where - {-# INLINE pure #-} - {-# INLINE (<*>) #-} - pure = with - Cons f <*> Cons e = - Cons $ \v -> f v $ e v diff --git a/src-ghc-6.12/NumericPrelude/List.hs b/src-ghc-6.12/NumericPrelude/List.hs deleted file mode 100644 --- a/src-ghc-6.12/NumericPrelude/List.hs +++ /dev/null @@ -1,71 +0,0 @@ -module NumericPrelude.List where - -import Data.List.HT (switchL, switchR, ) - - -{- * Zip lists -} - -{- | zip two lists using an arbitrary function, the shorter list is padded -} -{-# INLINE zipWithPad #-} -zipWithPad :: a {-^ padding value -} - -> (a -> a -> b) {-^ function applied to corresponding elements of the lists -} - -> [a] - -> [a] - -> [b] -zipWithPad z f = - let aux l [] = map (\x -> f x z) l - aux [] l = map (\y -> f z y) l - aux (x:xs) (y:ys) = f x y : aux xs ys - in aux - -{-# INLINE zipWithOverlap #-} -zipWithOverlap :: (a -> c) -> (b -> c) -> (a -> b -> c) -> [a] -> [b] -> [c] -zipWithOverlap fa fb fab = - let aux (x:xs) (y:ys) = fab x y : aux xs ys - aux xs [] = map fa xs - aux [] ys = map fb ys - in aux - -{- -This is exported Checked.zipWith. -We need to define it here in order to prevent an import cycle. --} -zipWithChecked - :: (a -> b -> c) {-^ function applied to corresponding elements of the lists -} - -> [a] - -> [b] - -> [c] -zipWithChecked f = - let aux (x:xs) (y:ys) = f x y : aux xs ys - aux [] [] = [] - aux _ _ = error "Checked.zipWith: lists must have the same length" - in aux - - -{- | -Apply a function to the last element of a list. -If the list is empty, nothing changes. --} -{-# INLINE mapLast #-} -mapLast :: (a -> a) -> [a] -> [a] -mapLast f = - switchL [] - (\x xs -> - uncurry (:) $ - foldr (\x1 k x0 -> (x0, uncurry (:) (k x1))) - (\x0 -> (f x0, [])) xs x) - -mapLast' :: (a -> a) -> [a] -> [a] -mapLast' f = - let recourse [] = [] -- behaviour as needed in powerBasis - -- otherwise: error "mapLast: empty list" - recourse (x:xs) = - uncurry (:) $ - if null xs - then (f x, []) - else (x, recourse xs) - in recourse - -mapLast'' :: (a -> a) -> [a] -> [a] -mapLast'' f = - switchR [] (\xs x -> xs ++ [f x]) diff --git a/src-ghc-6.12/NumericPrelude/List/Checked.hs b/src-ghc-6.12/NumericPrelude/List/Checked.hs deleted file mode 100644 --- a/src-ghc-6.12/NumericPrelude/List/Checked.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Some functions that are counterparts of functions from "Data.List" -using NumericPrelude.Numeric type classes. -They are distinct in that they check for valid arguments, -e.g. the length argument of 'take' must be at most the length of the input list. -However, since many Haskell programs rely on the absence of such checks, -we did not make these the default implementations -as in "NumericPrelude.List.Generic". --} -module NumericPrelude.List.Checked - (take, drop, splitAt, (!!), zipWith, - ) where - -import qualified Algebra.ToInteger as ToInteger --- import qualified Algebra.Ring as Ring -import Algebra.Ring (one, ) -import Algebra.Additive (zero, (-), ) - -import Data.Tuple.HT (mapFst, ) - -import qualified NumericPrelude.List as NPList - -import NumericPrelude.Base hiding (take, drop, splitAt, length, replicate, (!!), zipWith, ) - - -moduleError :: String -> String -> a -moduleError name msg = - error $ "NumericPrelude.List.Left." ++ name ++ ": " ++ msg - -{- | -Taken number of elements must be at most the length of the list, -otherwise the end of the list is undefined. --} -take :: (ToInteger.C n) => n -> [a] -> [a] -take n = - if n<=zero - then const [] - else \xt -> - case xt of - [] -> moduleError "take" "index out of range" - (x:xs) -> x : take (n-one) xs - -{- | -Dropped number of elements must be at most the length of the list, -otherwise the end of the list is undefined. --} -drop :: (ToInteger.C n) => n -> [a] -> [a] -drop n = - if n<=zero - then id - else \xt -> - case xt of - [] -> moduleError "drop" "index out of range" - (_:xs) -> drop (n-one) xs - -{- | -Split position must be at most the length of the list, -otherwise the end of the first list and the second list are undefined. --} -splitAt :: (ToInteger.C n) => n -> [a] -> ([a], [a]) -splitAt n xt = - if n<=zero - then ([], xt) - else - case xt of - [] -> moduleError "splitAt" "index out of range" - (x:xs) -> mapFst (x:) $ splitAt (n-one) xs - -{- | -The index must be smaller than the length of the list, -otherwise the result is undefined. --} -(!!) :: (ToInteger.C n) => [a] -> n -> a -(!!) [] _ = moduleError "(!!)" "index out of range" -(!!) (x:xs) n = - if n<=zero - then x - else (!!) xs (n-one) - - -{- | -Zip two lists which must be of the same length. -This is checked only lazily, that is unequal lengths are detected only -if the list is evaluated completely. -But it is more strict than @zipWithPad undefined f@ -since the latter one may succeed on unequal length list if @f@ is lazy. --} -zipWith - :: (a -> b -> c) {-^ function applied to corresponding elements of the lists -} - -> [a] - -> [b] - -> [c] -zipWith = NPList.zipWithChecked diff --git a/src-ghc-6.12/NumericPrelude/List/Generic.hs b/src-ghc-6.12/NumericPrelude/List/Generic.hs deleted file mode 100644 --- a/src-ghc-6.12/NumericPrelude/List/Generic.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{- | -Functions that are counterparts of the @generic@ functions in "Data.List" -using NumericPrelude.Numeric type classes. -For input arguments we use the restrictive @ToInteger@ constraint, -although in principle @RealRing@ would be enough. -However we think that @take 0.5 xs@ is rather a bug than a feature, -thus we forbid fractional types. -On the other hand fractional types as result can be quite handy, -e.g. in @average xs = sum xs / length xs@. --} -module NumericPrelude.List.Generic - ((!!), lengthLeft, lengthRight, replicate, - take, drop, splitAt, - findIndex, elemIndex, findIndices, elemIndices, - ) where - -import NumericPrelude.List.Checked ((!!), ) - -import qualified Algebra.ToInteger as ToInteger -import qualified Algebra.Ring as Ring -import Algebra.Ring (one, ) -import Algebra.Additive (zero, (+), (-), ) - -import qualified Data.Maybe as Maybe -import Data.Tuple.HT (mapFst, ) - -import NumericPrelude.Base as List - hiding (take, drop, splitAt, length, replicate, (!!), ) - - -replicate :: (ToInteger.C n) => n -> a -> [a] -replicate n x = take n (List.repeat x) - -take :: (ToInteger.C n) => n -> [a] -> [a] -take _ [] = [] -take n (x:xs) = - if n<=zero - then [] - else x : take (n-one) xs - -drop :: (ToInteger.C n) => n -> [a] -> [a] -drop _ [] = [] -drop n xt@(_:xs) = - if n<=zero - then xt - else drop (n-one) xs - -splitAt :: (ToInteger.C n) => n -> [a] -> ([a], [a]) -splitAt _ [] = ([], []) -splitAt n xt@(x:xs) = - if n<=zero - then ([], xt) - else mapFst (x:) $ splitAt (n-one) xs - - -{- | -Left associative length computation -that is appropriate for types like @Integer@. --} -lengthLeft :: (Ring.C n) => [a] -> n -lengthLeft = List.foldl (\n _ -> n+one) zero - -{- | -Right associative length computation -that is appropriate for types like @Peano@ number. --} -lengthRight :: (Ring.C n) => [a] -> n -lengthRight = List.foldr (\_ n -> one+n) zero - -elemIndex :: (Ring.C n, Eq a) => a -> [a] -> Maybe n -elemIndex e = findIndex (e==) - -elemIndices :: (Ring.C n, Eq a) => a -> [a] -> [n] -elemIndices e = findIndices (e==) - -findIndex :: Ring.C n => (a -> Bool) -> [a] -> Maybe n -findIndex p = Maybe.listToMaybe . findIndices p - -findIndices :: Ring.C n => (a -> Bool) -> [a] -> [n] -findIndices p = - map fst . - filter (p . snd) . - zip (iterate (one+) zero) diff --git a/src-ghc-6.12/NumericPrelude/Numeric.hs b/src-ghc-6.12/NumericPrelude/Numeric.hs deleted file mode 100644 --- a/src-ghc-6.12/NumericPrelude/Numeric.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module NumericPrelude.Numeric ( - {- Additive -} (+), (-), negate, zero, subtract, sum, sum1, - {- ZeroTestable -} isZero, - {- Ring -} (*), one, fromInteger, (^), ringPower, sqr, product, product1, - {- IntegralDomain -} div, mod, divMod, divides, even, odd, - {- Field -} (/), recip, fromRational', (^-), fieldPower, fromRational, - {- Algebraic -} (^/), sqrt, - {- Transcendental -} - pi, exp, log, logBase, (**), (^?), sin, cos, tan, - asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh, - {- Absolute -} abs, signum, - {- RealIntegral -} quot, rem, quotRem, - {- RealFrac -} splitFraction, fraction, truncate, round, ceiling, floor, approxRational, - {- RealTrans -} atan2, - {- ToRational -} toRational, - {- ToInteger -} toInteger, fromIntegral, - {- Units -} isUnit, stdAssociate, stdUnit, stdUnitInv, - {- PID -} extendedGCD, gcd, lcm, euclid, extendedEuclid, - {- Ratio -} Rational, (%), numerator, denominator, - Integer, Int, Float, Double, - {- Module -} (*>) -) where - -import Number.Ratio (Rational, (%), numerator, denominator) - -import Algebra.Module((*>)) -import Algebra.RealTranscendental(atan2) -import Algebra.Transcendental -import Algebra.Algebraic((^/), sqrt) -import Algebra.RealRing(splitFraction, fraction, truncate, round, ceiling, floor, approxRational, ) -import Algebra.Field((/), (^-), recip, fromRational', fromRational, ) -import Algebra.PrincipalIdealDomain (extendedGCD, gcd, lcm, euclid, extendedEuclid) -import Algebra.Units (isUnit, stdAssociate, stdUnit, stdUnitInv) -import Algebra.RealIntegral (quot, rem, quotRem, ) -import Algebra.IntegralDomain (div, mod, divMod, divides, even, odd) -import Algebra.Absolute (abs, signum, ) -import Algebra.Ring (one, fromInteger, (*), (^), sqr, product, product1) -import Algebra.Additive (zero, (+), (-), negate, subtract, sum, sum1) -import Algebra.ZeroTestable (isZero) -import Algebra.ToInteger (ringPower, fieldPower, toInteger, fromIntegral, ) -import Algebra.ToRational (toRational, ) - -import Prelude (Int, Integer, Float, Double) diff --git a/src/Algebra/Absolute.hs b/src/Algebra/Absolute.hs --- a/src/Algebra/Absolute.hs +++ b/src/Algebra/Absolute.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.Absolute ( C(abs, signum), absOrd, signumOrd, @@ -6,7 +6,6 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import qualified Algebra.ZeroTestable as ZeroTestable import Algebra.Ring (one, ) -- fromInteger import Algebra.Additive (zero, negate,) @@ -38,8 +37,17 @@ > a * (max b c) === max (a*b) (a*c) where a >= 0 > absOrd a === max a (-a) +If the type is @ZeroTestable@, then it should hold + +> isZero a === signum a == signum (negate a) + We do not require 'Ord' as superclass since we also want to have "Number.Complex" as instance. +We also do not require @ZeroTestable@ as superclass, +because we like to have expressions of foreign languages +to be instances (cf. embedded domain specific language approach, EDSL), +as well as function types. + 'abs' for complex numbers alone may have an inappropriate type, because it does not reflect that the absolute value is a real number. You might prefer 'Number.Complex.magnitude'. @@ -53,7 +61,7 @@ we could relax the superclasses to @Additive@ and 'Ord' if his class would only contain 'signum'. -} -class (Ring.C a, ZeroTestable.C a) => C a where +class (Ring.C a) => C a where abs :: a -> a signum :: a -> a diff --git a/src/Algebra/Additive.hs b/src/Algebra/Additive.hs --- a/src/Algebra/Additive.hs +++ b/src/Algebra/Additive.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.Additive ( -- * Class C, @@ -8,6 +8,8 @@ -- * Complex functions sum, sum1, + sumNestedAssociative, + sumNestedCommutative, -- * Instance definition helpers elementAdd, elementSub, elementNeg, @@ -28,6 +30,7 @@ import qualified NumericPrelude.Elementwise as Elem import Control.Applicative (Applicative(pure, (<*>)), ) import Data.Tuple.HT (fst3, snd3, thd3, ) +import qualified Data.List.Match as Match import qualified Data.Ratio as Ratio98 import qualified Prelude as P @@ -95,6 +98,50 @@ -} sum1 :: (C a) => [a] -> a sum1 = foldl1 (+) + + +{- | +Sum the operands in an order, +such that the dependencies are minimized. +Does this have a measurably effect on speed? + +Requires associativity. +-} +sumNestedAssociative :: (C a) => [a] -> a +sumNestedAssociative [] = zero +sumNestedAssociative [x] = x +sumNestedAssociative xs = sumNestedAssociative (sum2 xs) + +{- +Make sure that the last entries in the list +are equally often part of an addition. +Maybe this can reduce rounding errors. +The list that sum2 computes is a breadth-first-flattened binary tree. + +Requires associativity and commutativity. +-} +sumNestedCommutative :: (C a) => [a] -> a +sumNestedCommutative [] = zero +sumNestedCommutative xs@(_:rs) = + let ys = xs ++ Match.take rs (sum2 ys) + in last ys + +_sumNestedCommutative :: (C a) => [a] -> a +_sumNestedCommutative [] = zero +_sumNestedCommutative xs@(_:rs) = + let ys = xs ++ take (length rs) (sum2 ys) + in last ys + +{- +[a,b,c, a+b,c+(a+b)] +[a,b,c,d, a+b,c+d,(a+b)+(c+d)] +[a,b,c,d,e, a+b,c+d,e+(a+b),(c+d)+e+(a+b)] +[a,b,c,d,e,f, a+b,c+d,e+f,(a+b)+(c+d),(e+f)+((a+b)+(c+d))] +-} + +sum2 :: (C a) => [a] -> [a] +sum2 (x:y:rest) = (x+y) : sum2 rest +sum2 xs = xs diff --git a/src/Algebra/Algebraic.hs b/src/Algebra/Algebraic.hs --- a/src/Algebra/Algebraic.hs +++ b/src/Algebra/Algebraic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.Algebraic where import qualified Algebra.Field as Field diff --git a/src/Algebra/Differential.hs b/src/Algebra/Differential.hs --- a/src/Algebra/Differential.hs +++ b/src/Algebra/Differential.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.Differential where import qualified Algebra.Ring as Ring diff --git a/src/Algebra/DivisibleSpace.hs b/src/Algebra/DivisibleSpace.hs --- a/src/Algebra/DivisibleSpace.hs +++ b/src/Algebra/DivisibleSpace.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Algebra.DivisibleSpace where diff --git a/src/Algebra/Field.hs b/src/Algebra/Field.hs --- a/src/Algebra/Field.hs +++ b/src/Algebra/Field.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.Field ( {- * Class -} C, diff --git a/src/Algebra/IntegralDomain.hs b/src/Algebra/IntegralDomain.hs --- a/src/Algebra/IntegralDomain.hs +++ b/src/Algebra/IntegralDomain.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.IntegralDomain ( {- * Class -} C, @@ -321,7 +321,7 @@ propMultipleDiv m a = not (isZero m) ==> (a*m) `div` m == a propMultipleMod m a = - not (isZero m) ==> (a*m) `mod` m == zero + not (isZero m) ==> (a*m) `mod` m == 0 propProjectAddition m a b = not (isZero m) ==> (a+b) `mod` m == ((a`mod`m)+(b`mod`m)) `mod` m diff --git a/src/Algebra/Lattice.hs b/src/Algebra/Lattice.hs --- a/src/Algebra/Lattice.hs +++ b/src/Algebra/Lattice.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.Lattice ( C(up, dn) , max, min, abs diff --git a/src/Algebra/Module.hs b/src/Algebra/Module.hs --- a/src/Algebra/Module.hs +++ b/src/Algebra/Module.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | diff --git a/src/Algebra/ModuleBasis.hs b/src/Algebra/ModuleBasis.hs --- a/src/Algebra/ModuleBasis.hs +++ b/src/Algebra/ModuleBasis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | diff --git a/src/Algebra/NormedSpace/Euclidean.hs b/src/Algebra/NormedSpace/Euclidean.hs --- a/src/Algebra/NormedSpace/Euclidean.hs +++ b/src/Algebra/NormedSpace/Euclidean.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Algebra/NormedSpace/Maximum.hs b/src/Algebra/NormedSpace/Maximum.hs --- a/src/Algebra/NormedSpace/Maximum.hs +++ b/src/Algebra/NormedSpace/Maximum.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Algebra/NormedSpace/Sum.hs b/src/Algebra/NormedSpace/Sum.hs --- a/src/Algebra/NormedSpace/Sum.hs +++ b/src/Algebra/NormedSpace/Sum.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Algebra/OccasionallyScalar.hs b/src/Algebra/OccasionallyScalar.hs --- a/src/Algebra/OccasionallyScalar.hs +++ b/src/Algebra/OccasionallyScalar.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Algebra/PrincipalIdealDomain.hs b/src/Algebra/PrincipalIdealDomain.hs --- a/src/Algebra/PrincipalIdealDomain.hs +++ b/src/Algebra/PrincipalIdealDomain.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.PrincipalIdealDomain ( {- * Class -} C, diff --git a/src/Algebra/RealField.hs b/src/Algebra/RealField.hs --- a/src/Algebra/RealField.hs +++ b/src/Algebra/RealField.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.RealField ( C, ) where diff --git a/src/Algebra/RealIntegral.hs b/src/Algebra/RealIntegral.hs --- a/src/Algebra/RealIntegral.hs +++ b/src/Algebra/RealIntegral.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Generally before using 'quot' and 'rem', think twice. In most cases 'divMod' and friends are the right choice, @@ -16,6 +16,7 @@ C(quot, rem, quotRem), ) where +import qualified Algebra.ZeroTestable as ZeroTestable import qualified Algebra.IntegralDomain as Integral import qualified Algebra.Absolute as Absolute -- import qualified Algebra.Ring as Ring @@ -46,7 +47,7 @@ Minimal definition: nothing required -} -class (Absolute.C a, Ord a, Integral.C a) => C a where +class (Absolute.C a, ZeroTestable.C a, Ord a, Integral.C a) => C a where quot, rem :: a -> a -> a quotRem :: a -> a -> (a,a) diff --git a/src/Algebra/RealRing.hs b/src/Algebra/RealRing.hs --- a/src/Algebra/RealRing.hs +++ b/src/Algebra/RealRing.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.RealRing where -import qualified Algebra.Field as Field +import qualified Algebra.RealRing98 as RealRing98 + import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Absolute as Absolute +import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring import qualified Algebra.ToRational as ToRational import qualified Algebra.ToInteger as ToInteger +import qualified Algebra.Absolute as Absolute import qualified Algebra.OrderDecision as OrdDec import Algebra.OrderDecision ((=?), ) @@ -203,7 +205,7 @@ {-# INLINE round #-} {-# INLINE truncate #-} splitFraction = fastSplitFraction GHC.float2Int GHC.int2Float - fraction = fastFraction (GHC.int2Float . GHC.float2Int) + fraction = RealRing98.fastFraction (GHC.int2Float . GHC.float2Int) floor = fromInteger . P.floor ceiling = fromInteger . P.ceiling round = fromInteger . P.round @@ -217,7 +219,7 @@ {-# INLINE round #-} {-# INLINE truncate #-} splitFraction = fastSplitFraction GHC.double2Int GHC.int2Double - fraction = fastFraction (GHC.int2Double . GHC.double2Int) + fraction = RealRing98.fastFraction (GHC.int2Double . GHC.double2Int) floor = fromInteger . P.floor ceiling = fromInteger . P.ceiling round = fromInteger . P.round @@ -240,21 +242,6 @@ if f>=0 then (n, f) else (n-1, f+1) - -{-# INLINE fastFraction #-} -fastFraction :: (P.RealFrac a, Absolute.C a) => (a -> a) -> a -> a -fastFraction trunc x = - fixFraction $ - if fromIntegral (minBound :: Int) <= x && x <= fromIntegral (maxBound :: Int) - then x - trunc x - else preludeFraction x - -{-# INLINE preludeFraction #-} -preludeFraction :: (P.RealFrac a, Ring.C a) => a -> a -preludeFraction x = - let second :: (Integer, a) -> a - second = snd - in second (P.properFraction x) {-# INLINE fixFraction #-} fixFraction :: (Ring.C a, Ord a) => a -> a diff --git a/src/Algebra/RealRing98.hs b/src/Algebra/RealRing98.hs new file mode 100644 --- /dev/null +++ b/src/Algebra/RealRing98.hs @@ -0,0 +1,39 @@ +module Algebra.RealRing98 where + +{-# INLINE fastSplitFraction #-} +fastSplitFraction :: (RealFrac a, Integral b) => + (a -> Int) -> (Int -> a) -> a -> (b,a) +fastSplitFraction trunc toFloat x = + fixSplitFraction $ + if toFloat minBound <= x && x <= toFloat maxBound + then case trunc x of n -> (fromIntegral n, x - toFloat n) + else case properFraction x of (n,f) -> (fromInteger n, f) + +{-# INLINE fixSplitFraction #-} +fixSplitFraction :: (Num a, Num b, Ord a) => (b,a) -> (b,a) +fixSplitFraction (n,f) = + -- if x>=0 || f==0 + if f>=0 + then (n, f) + else (n-1, f+1) + + +{-# INLINE fastFraction #-} +fastFraction :: (RealFrac a) => (a -> a) -> a -> a +fastFraction trunc x = + fixFraction $ + if fromIntegral (minBound :: Int) <= x && x <= fromIntegral (maxBound :: Int) + then x - trunc x + else signedFraction x + +{-# INLINE signedFraction #-} +signedFraction :: (RealFrac a) => a -> a +signedFraction x = + let second :: (Integer, a) -> a + second = snd + in second (properFraction x) + +{-# INLINE fixFraction #-} +fixFraction :: (Real a) => a -> a +fixFraction y = + if y>=0 then y else y+1 diff --git a/src/Algebra/RealTranscendental.hs b/src/Algebra/RealTranscendental.hs --- a/src/Algebra/RealTranscendental.hs +++ b/src/Algebra/RealTranscendental.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.RealTranscendental where import qualified Algebra.Transcendental as Trans diff --git a/src/Algebra/RightModule.hs b/src/Algebra/RightModule.hs --- a/src/Algebra/RightModule.hs +++ b/src/Algebra/RightModule.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Algebra.RightModule where diff --git a/src/Algebra/Ring.hs b/src/Algebra/Ring.hs --- a/src/Algebra/Ring.hs +++ b/src/Algebra/Ring.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.Ring ( {- * Class -} C, diff --git a/src/Algebra/ToInteger.hs b/src/Algebra/ToInteger.hs --- a/src/Algebra/ToInteger.hs +++ b/src/Algebra/ToInteger.hs @@ -40,10 +40,10 @@ Conversions must be lossless, that is, they do not round in any way. For rounding see "Algebra.RealRing". -With the instances for 'Prelude.Float' and 'Prelude.Double' -we acknowledge that these types actually represent rationals -rather than (approximated) real numbers. -However, this contradicts to the 'Algebra.Transcendental.C' instance. + +I think that the RealIntegral superclass is too restrictive. +Non-negative numbers are not a ring, +but can be easily converted to Integers. -} class (ToRational.C a, RealIntegral.C a) => C a where toInteger :: a -> Integer diff --git a/src/Algebra/ToRational.hs b/src/Algebra/ToRational.hs --- a/src/Algebra/ToRational.hs +++ b/src/Algebra/ToRational.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.ToRational where +import qualified Algebra.ZeroTestable as ZeroTestable import qualified Algebra.Field as Field import qualified Algebra.Absolute as Absolute import Algebra.Field (fromRational, ) @@ -29,7 +30,7 @@ > fromRational' . toRational === id -} -class (Absolute.C a) => C a where +class (Absolute.C a, ZeroTestable.C a, Ord a) => C a where -- | Lossless conversion from any representation of a rational to 'Rational' toRational :: a -> Rational diff --git a/src/Algebra/Transcendental.hs b/src/Algebra/Transcendental.hs --- a/src/Algebra/Transcendental.hs +++ b/src/Algebra/Transcendental.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.Transcendental where import qualified Algebra.Algebraic as Algebraic diff --git a/src/Algebra/Units.hs b/src/Algebra/Units.hs --- a/src/Algebra/Units.hs +++ b/src/Algebra/Units.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.Units ( {- * Class -} C, diff --git a/src/Algebra/Vector.hs b/src/Algebra/Vector.hs --- a/src/Algebra/Vector.hs +++ b/src/Algebra/Vector.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2004-2005 diff --git a/src/Algebra/VectorSpace.hs b/src/Algebra/VectorSpace.hs --- a/src/Algebra/VectorSpace.hs +++ b/src/Algebra/VectorSpace.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Algebra.VectorSpace where diff --git a/src/Algebra/ZeroTestable.hs b/src/Algebra/ZeroTestable.hs --- a/src/Algebra/ZeroTestable.hs +++ b/src/Algebra/ZeroTestable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Algebra.ZeroTestable where import qualified Algebra.Additive as Additive diff --git a/src/MathObj/Algebra.hs b/src/MathObj/Algebra.hs --- a/src/MathObj/Algebra.hs +++ b/src/MathObj/Algebra.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Mikael Johansson 2006 Maintainer : mik@math.uni-jena.de diff --git a/src/MathObj/DiscreteMap.hs b/src/MathObj/DiscreteMap.hs --- a/src/MathObj/DiscreteMap.hs +++ b/src/MathObj/DiscreteMap.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/MathObj/Gaussian/Bell.hs b/src/MathObj/Gaussian/Bell.hs --- a/src/MathObj/Gaussian/Bell.hs +++ b/src/MathObj/Gaussian/Bell.hs @@ -1,7 +1,11 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- -Complex translated Gaussian bell curve -with amplitude abstracted away. +Complex translated and modulated Gaussian bell curve. + +It could be extended to chirps +using a complex valued quadratic term with (real c >= 0). +This allows for a new test: +Express the Fourier transform in terms of a convolution with a chirp. -} module MathObj.Gaussian.Bell where @@ -66,6 +70,12 @@ exponentPolynomial f = Poly.fromCoeffs [c0 f, c1 f, Complex.fromReal (c2 f)] + +{- +norm functions depend on interpretation +and would have to return both a rational and transcendental part +expressed as @exp a@. +-} variance :: (Trans.C a) => T a -> a diff --git a/src/MathObj/Gaussian/Example.hs b/src/MathObj/Gaussian/Example.hs --- a/src/MathObj/Gaussian/Example.hs +++ b/src/MathObj/Gaussian/Example.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- Reciprocal of variance of a Gaussian bell curve. We describe the curve only in terms of its variance @@ -29,6 +29,7 @@ -- import qualified Algebra.Additive as Additive import qualified Number.Complex as Complex +import qualified Number.Root as Root import Algebra.Transcendental (pi, ) import Algebra.Algebraic (root, ) @@ -68,20 +69,23 @@ (Integ.rectangular 1000 (-2,2) $ liftA2 (*) (^2) (Var.evaluate curve0)) / (Integ.rectangular 1000 (-2,2) $ Var.evaluate curve0)) -norm10 :: (Double, Double) +norm10 :: (Double, Double, Double) norm10 = (Integ.rectangular 1000 (-2,2) $ Var.evaluate curve0, - Var.norm1 curve0) + Var.norm1 curve0, + Root.toNumber (Var.norm1Root curve0)) -norm20 :: (Double, Double) +norm20 :: (Double, Double, Double) norm20 = (sqrt $ Integ.rectangular 1000 (-2,2) $ (^2) . Var.evaluate curve0, - Var.norm2 curve0) + Var.norm2 curve0, + Root.toNumber (Var.norm2Root curve0)) -norm30 :: (Double, Double) +norm30 :: (Double, Double, Double) norm30 = (root 3 $ Integ.rectangular 1000 (-2,2) $ (^3) . Var.evaluate curve0, - Var.normP 3 curve0) + Var.normP 3 curve0, + Root.toNumber (Var.normPRoot 3 curve0)) fourier0 :: IO () fourier0 = diff --git a/src/MathObj/Gaussian/Polynomial.hs b/src/MathObj/Gaussian/Polynomial.hs --- a/src/MathObj/Gaussian/Polynomial.hs +++ b/src/MathObj/Gaussian/Polynomial.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- Complex Gaussian bell multiplied with a polynomial. @@ -16,7 +16,15 @@ * sum of multiple bells using Data.Map from exponent polynomial to coefficient polynomial use of Algebra object. -* Projective geometry in order to support Dirac impulse. +* Discrete Fourier Transform and its eigenvectors + +* Use projective geometry in order to support Dirac impulse. + There are many open questions: + 1. What shall be the product of two Dirac impulses - + whether they are at the same location or not. + 2. How to organize coefficients + such that the constant function can be modulated + and the Dirac impulse can be translated. -} module MathObj.Gaussian.Polynomial where @@ -31,7 +39,7 @@ import qualified Algebra.Differential as Differential import qualified Algebra.Transcendental as Trans import qualified Algebra.Field as Field -import qualified Algebra.Absolute as Absolute +import qualified Algebra.Absolute as Absolute import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive @@ -53,7 +61,7 @@ data T a = Cons {bell :: Bell.T a, polynomial :: Poly.T (Complex.T a)} deriving (Show) -instance (Absolute.C a, Eq a) => Eq (T a) where +instance (Absolute.C a, ZeroTestable.C a, Eq a) => Eq (T a) where (==) = equal @@ -69,7 +77,7 @@ -} data RootProduct a = RootProduct a a -instance (Absolute.C a, Eq a) => Eq (RootProduct a) where +instance (Absolute.C a, ZeroTestable.C a, Eq a) => Eq (RootProduct a) where (RootProduct xr xa) == (RootProduct yr ya) = let xp = xr*xa^2 yp = yr*ya^2 @@ -85,7 +93,7 @@ We have to combine the amplitude of the bell with the polynomial, respecting signs and the square root of the bell amplitude. -} -equal :: (Absolute.C a, Eq a) => T a -> T a -> Bool +equal :: (Absolute.C a, ZeroTestable.C a, Eq a) => T a -> T a -> Bool equal x y = let bx = bell x by = bell y @@ -104,7 +112,7 @@ scaleSqr bx x == scaleSqr by y -instance (Absolute.C a, Arbitrary a) => Arbitrary (T a) where +instance (Absolute.C a, ZeroTestable.C a, Arbitrary a) => Arbitrary (T a) where arbitrary = -- liftM2 Cons arbitrary arbitrary liftM2 Cons @@ -138,6 +146,9 @@ f{polynomial = fmap (x*) $ polynomial f} +unit :: (Ring.C a) => T a +unit = eigenfunction0 + eigenfunction :: (Field.C a) => Int -> T a eigenfunction = eigenfunctionDifferential @@ -165,7 +176,8 @@ nest n (scale (-1/4) . differentiate) $ Cons (Bell.Cons one zero zero 2) one -eigenfunctionIterative :: (Field.C a, Absolute.C a, Eq a) => Int -> T a +eigenfunctionIterative :: + (Field.C a, Absolute.C a, ZeroTestable.C a, Eq a) => Int -> T a eigenfunctionIterative n = fst . head . dropWhile (uncurry (/=)) . mapAdjacent (,) $ eigenfunctionIteration $ @@ -224,6 +236,10 @@ fourier (Cons bell (Poly.const a + Poly.shift f)) = fourier (Cons bell (Poly.const a)) + fourier (Cons bell (Poly.shift f)) = fourier (Cons bell (Poly.const a)) + differentiate (fourier (Cons bell f)) + +We can certainly speed this up considerably +by decomposing the polynomial into four polynomials, +one for each of the four eigenvalues 1, i, -1, -i. -} fourier :: (Field.C a) => T a -> T a @@ -290,6 +306,35 @@ zipWith (*) xs (drop 1 (iterate (subtract 1) (fromIntegral $ length xs))) +{- +integrateDefinite + (maybe rename integrate to antiderivative and call this one integrate) + +int(x^(2*n)*exp(-x^2),x=-infinity..infinity) + = 2 * int(x^(2*n)*exp(-x^2),x=0..infinity) + substitute t=x^2, dt = dx * 2 * sqrt t + = int(t^(n-1/2)*exp(-t),x=0..infinity) + = Gamma(n+1/2) + = (2n-1)!!/2^n * sqrt pi + +int(pi^n*x^(2*n)*exp(-pi*x^2),x=-infinity..infinity) + = (2n-1)!!/2^n + + +The remainder value of 'integrate' +is the coefficient of the error function +and this is the only part that does not vanish when approaching the limit. + + +In order to stay in a field, +we have to return a rational number +and a transcendental part written es @exp a@. + +It would be interesting to see how integral inequalities +translate to scalar inequalities containing exponential functions. +-} + + translate :: Ring.C a => a -> T a -> T a translate d = translateComplex (Complex.fromReal d) @@ -353,24 +398,24 @@ approximateByBells :: Field.C a => a -> T a -> [(Complex.T a, Bell.T a)] -approximateByBells unit f = +approximateByBells unit_ f = let b = bell f amps = -- approximateByBellsByTranslation approximateByBellsAtOnce - unit + unit_ (Complex.scale (recip (2 * Bell.c2 b)) (Bell.c1 b)) - (recip (2*unit*Bell.c2 b)) + (recip (2*unit_*Bell.c2 b)) (polynomial f) in zip (LPoly.coeffs amps) $ map (\d -> Bell.translate d b) - (laurentAbscissas (unit/2) amps) + (laurentAbscissas (unit_/2) amps) approximateByBellsAtOnce :: Field.C a => a -> Complex.T a -> a -> Poly.T (Complex.T a) -> LPoly.T (Complex.T a) -approximateByBellsAtOnce unit d s p = +approximateByBellsAtOnce unit_ d s p = foldr (\x amps0 -> {- @@ -378,13 +423,13 @@ -} let y = fmap (Complex.scale s) amps0 in -- \t -> bell t * t - -- ~ (translate unit bell - translate (-unit) bell) / unit + -- ~ (translate unit_ bell - translate (-unit_) bell) / unit_ LPoly.shift 1 y - LPoly.shift (-1) y + -- bell t * d zipWithAbscissas (\t z -> (Complex.fromReal t - d) * z) - (unit/2) amps0 + + (unit_/2) amps0 + LPoly.const x) (LPoly.fromCoeffs []) (Poly.coeffs p) @@ -392,7 +437,7 @@ approximateByBellsByTranslation :: Field.C a => a -> Complex.T a -> a -> Poly.T (Complex.T a) -> LPoly.T (Complex.T a) -approximateByBellsByTranslation unit d s p = +approximateByBellsByTranslation unit_ d s p = foldr (\x amps0 -> {- @@ -400,11 +445,11 @@ -} let y = fmap (Complex.scale s) amps0 in -- \t -> bell t * t - -- ~ (translate unit bell - translate (-unit) bell) / unit + -- ~ (translate unit_ bell - translate (-unit_) bell) / unit_ LPoly.shift 1 y - LPoly.shift (-1) y + -- bell t * d - zipWithAbscissas Complex.scale (unit/2) amps0 + + zipWithAbscissas Complex.scale (unit_/2) amps0 + LPoly.const x) (LPoly.fromCoeffs []) (Poly.coeffs $ Poly.translate d p) @@ -412,15 +457,15 @@ zipWithAbscissas :: (Ring.C a) => (a -> b -> c) -> a -> LPoly.T b -> LPoly.T c -zipWithAbscissas h unit y = +zipWithAbscissas h unit_ y = LPoly.fromShiftCoeffs (LPoly.expon y) $ zipWith h - (laurentAbscissas unit y) + (laurentAbscissas unit_ y) (LPoly.coeffs y) laurentAbscissas :: Ring.C a => a -> LPoly.T c -> [a] -laurentAbscissas unit = - map (\d -> fromIntegral d * unit) . +laurentAbscissas unit_ = + map (\d -> fromIntegral d * unit_) . iterate (1+) . LPoly.expon diff --git a/src/MathObj/Gaussian/Variance.hs b/src/MathObj/Gaussian/Variance.hs --- a/src/MathObj/Gaussian/Variance.hs +++ b/src/MathObj/Gaussian/Variance.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- We represent a Gaussian bell curve in terms of the reciprocal of its variance and its value at the origin. @@ -6,6 +6,11 @@ We could do some projective geometry in the exponent in order to also have zero variance, which corresponds to the dirac impulse. + +The Gaussians form a nice multiplicative commutative monoid. +Maybe we should have such a structure. +It would also be useful for the Root data type +and a new Exponential data type. -} module MathObj.Gaussian.Variance where @@ -48,6 +53,12 @@ constant :: Ring.C a => T a constant = Cons one zero +{- | +eigenfunction of 'fourier' +-} +unit :: Ring.C a => T a +unit = Cons one one + {-# INLINE evaluate #-} evaluate :: (Trans.C a) => T a -> a -> a @@ -90,6 +101,7 @@ Root.rationalPower (recip (2*p)) (Root.fromNumber (fromRational' p * c f)) +-- ToDo: implement NormedSpace.Sum et.al. norm1 :: (Algebraic.C a) => T a -> a norm1 f = sqrt $ amp f / c f diff --git a/src/MathObj/LaurentPolynomial.hs b/src/MathObj/LaurentPolynomial.hs --- a/src/MathObj/LaurentPolynomial.hs +++ b/src/MathObj/LaurentPolynomial.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | @@ -26,9 +26,7 @@ import qualified Number.Complex as Complex -import Algebra.Module((*>)) - -import qualified NumericPrelude.Base as P +-- import qualified NumericPrelude.Base as P import qualified NumericPrelude.Numeric as NP import NumericPrelude.Base hiding (const, reverse, ) diff --git a/src/MathObj/Matrix.hs b/src/MathObj/Matrix.hs --- a/src/MathObj/Matrix.hs +++ b/src/MathObj/Matrix.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | diff --git a/src/MathObj/Monoid.hs b/src/MathObj/Monoid.hs --- a/src/MathObj/Monoid.hs +++ b/src/MathObj/Monoid.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module MathObj.Monoid where import qualified Algebra.PrincipalIdealDomain as PID diff --git a/src/MathObj/PartialFraction.hs b/src/MathObj/PartialFraction.hs --- a/src/MathObj/PartialFraction.hs +++ b/src/MathObj/PartialFraction.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2007 Maintainer : numericprelude@henning-thielemann.de diff --git a/src/MathObj/Permutation.hs b/src/MathObj/Permutation.hs --- a/src/MathObj/Permutation.hs +++ b/src/MathObj/Permutation.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2006 Maintainer : numericprelude@henning-thielemann.de diff --git a/src/MathObj/Permutation/CycleList.hs b/src/MathObj/Permutation/CycleList.hs --- a/src/MathObj/Permutation/CycleList.hs +++ b/src/MathObj/Permutation/CycleList.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Mikael Johansson 2006 Maintainer : mik@math.uni-jena.de diff --git a/src/MathObj/Permutation/CycleList/Check.hs b/src/MathObj/Permutation/CycleList/Check.hs --- a/src/MathObj/Permutation/CycleList/Check.hs +++ b/src/MathObj/Permutation/CycleList/Check.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2006 Maintainer : numericprelude@henning-thielemann.de diff --git a/src/MathObj/Permutation/Table.hs b/src/MathObj/Permutation/Table.hs --- a/src/MathObj/Permutation/Table.hs +++ b/src/MathObj/Permutation/Table.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2006 Maintainer : numericprelude@henning-thielemann.de diff --git a/src/MathObj/Polynomial.hs b/src/MathObj/Polynomial.hs --- a/src/MathObj/Polynomial.hs +++ b/src/MathObj/Polynomial.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -67,9 +67,6 @@ import qualified Algebra.Additive as Additive import qualified Algebra.ZeroTestable as ZeroTestable import qualified Algebra.Indexable as Indexable - -import Algebra.Module((*>)) -import Algebra.ZeroTestable(isZero) import Control.Monad (liftM, ) import qualified Data.List as List diff --git a/src/MathObj/Polynomial/Core.hs b/src/MathObj/Polynomial/Core.hs --- a/src/MathObj/Polynomial/Core.hs +++ b/src/MathObj/Polynomial/Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | This module implements polynomial functions on plain lists. We use such functions in order to implement methods of other datatypes. diff --git a/src/MathObj/PowerSeries.hs b/src/MathObj/PowerSeries.hs --- a/src/MathObj/PowerSeries.hs +++ b/src/MathObj/PowerSeries.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -22,8 +22,6 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive import qualified Algebra.ZeroTestable as ZeroTestable - -import Algebra.Module((*>)) import NumericPrelude.Base hiding (const) import NumericPrelude.Numeric diff --git a/src/MathObj/PowerSeries/Core.hs b/src/MathObj/PowerSeries/Core.hs --- a/src/MathObj/PowerSeries/Core.hs +++ b/src/MathObj/PowerSeries/Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module MathObj.PowerSeries.Core where import qualified MathObj.Polynomial.Core as Poly diff --git a/src/MathObj/PowerSeries/DifferentialEquation.hs b/src/MathObj/PowerSeries/DifferentialEquation.hs --- a/src/MathObj/PowerSeries/DifferentialEquation.hs +++ b/src/MathObj/PowerSeries/DifferentialEquation.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Lazy evaluation allows for the solution of differential equations in terms of power series. diff --git a/src/MathObj/PowerSeries/Example.hs b/src/MathObj/PowerSeries/Example.hs --- a/src/MathObj/PowerSeries/Example.hs +++ b/src/MathObj/PowerSeries/Example.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module MathObj.PowerSeries.Example where import qualified MathObj.PowerSeries.Core as PS diff --git a/src/MathObj/PowerSeries/Mean.hs b/src/MathObj/PowerSeries/Mean.hs --- a/src/MathObj/PowerSeries/Mean.hs +++ b/src/MathObj/PowerSeries/Mean.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | This module computes power series for representing some means as generalized $f$-means. diff --git a/src/MathObj/PowerSeries2.hs b/src/MathObj/PowerSeries2.hs --- a/src/MathObj/PowerSeries2.hs +++ b/src/MathObj/PowerSeries2.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -19,8 +19,10 @@ import qualified Algebra.Additive as Additive import qualified Algebra.ZeroTestable as ZeroTestable +{- import qualified NumericPrelude.Numeric as NP import qualified NumericPrelude.Base as P +-} import Data.List (isPrefixOf, ) import qualified Data.List.Match as Match diff --git a/src/MathObj/PowerSeries2/Core.hs b/src/MathObj/PowerSeries2/Core.hs --- a/src/MathObj/PowerSeries2/Core.hs +++ b/src/MathObj/PowerSeries2/Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module MathObj.PowerSeries2.Core where import qualified MathObj.PowerSeries as PS diff --git a/src/MathObj/PowerSum.hs b/src/MathObj/PowerSum.hs --- a/src/MathObj/PowerSum.hs +++ b/src/MathObj/PowerSum.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | @@ -28,8 +28,6 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive import qualified Algebra.ZeroTestable as ZeroTestable - -import Algebra.Module((*>)) import Control.Monad(liftM2) import qualified Data.List as List diff --git a/src/MathObj/RefinementMask2.hs b/src/MathObj/RefinementMask2.hs --- a/src/MathObj/RefinementMask2.hs +++ b/src/MathObj/RefinementMask2.hs @@ -1,13 +1,16 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module MathObj.RefinementMask2 ( T, coeffs, fromCoeffs, fromPolynomial, toPolynomial, toPolynomialFast, refinePolynomial, + convolvePolynomial, + convolveTruncatedPowerPolynomials, ) where import qualified MathObj.Polynomial as Poly +import qualified MathObj.Polynomial.Core as PolyCore import qualified Algebra.RealField as RealField import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring @@ -16,6 +19,7 @@ import qualified Data.List as List import qualified Data.List.HT as ListHT import qualified Data.List.Match as Match +import Data.Maybe (fromMaybe, ) import Control.Monad (liftM2, ) import qualified Test.QuickCheck as QC @@ -169,3 +173,54 @@ ... Polynomial.fromCoeffs [-0.11640685714285712,0.4351999999999999,-0.7199999999999999,1.0] -} + +convolve :: + (Ring.C a) => T a -> T a -> T a +convolve x y = + fromCoeffs $ + PolyCore.mul (coeffs x) (coeffs y) + +{- | +Convolve polynomials via refinement mask. + +(mask x + ux*(-1,1)^degree x) * (mask y + uy*(-1,1)^degree y) +-} +convolvePolynomial :: + (RealField.C a) => + Poly.T a -> Poly.T a -> Poly.T a +convolvePolynomial x y = + fromMaybe + (error "RefinementMask2.convolvePolynomial: leading term should always be correct") $ + toPolynomial $ fmap (/2) $ + convolve (fromPolynomial x) (fromPolynomial y) + +{- +This function interprets all monomials as truncated power functions, +that is power functions that are set to zero for negative arguments. +However the convolution implied by this interpretation +cannot be represented by means of mask convolution. +See for instance: + +*MathObj.RefinementMask2> let x = Poly.fromCoeffs [1,1] :: Poly.T Rational +*MathObj.RefinementMask2> fromPolynomial $ convolvePolynomial2 x x +RefinementMask2.fromCoeffs [1 % 3,-1 % 8,-1 % 8,1 % 24] + +The obtained mask cannot be factored, +thus it is not a complete square. +But maybe it becomes a square if we add u*(-1,1)^4. +However this mask has sum 1/8 and the added term has sum 0, +thus the sum of the modified mask is still 1/8 and thus not a square. +-} +convolveTruncatedPowerPolynomials :: + (RealField.C a) => + Poly.T a -> Poly.T a -> Poly.T a +convolveTruncatedPowerPolynomials x y = + let facs = scanl (*) 1 $ iterate (1+) 1 + xl = Poly.coeffs x + yl = Poly.coeffs y + in Poly.integrate 0 $ + Poly.fromCoeffs $ + zipWith (flip (/)) facs $ + PolyCore.mul + (zipWith (*) facs xl) + (zipWith (*) facs yl) diff --git a/src/MathObj/RootSet.hs b/src/MathObj/RootSet.hs --- a/src/MathObj/RootSet.hs +++ b/src/MathObj/RootSet.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2004-2005 @@ -26,8 +26,11 @@ import qualified Algebra.Additive as Additive import qualified Algebra.ZeroTestable as ZeroTestable +import qualified Algebra.RealRing as RealRing + import qualified Data.List.Match as Match -import Control.Monad (liftM2) +import qualified Data.List.Key as Key +import Control.Monad (liftM2, replicateM, ) import NumericPrelude.Base as P hiding (const) import NumericPrelude.Numeric as NP @@ -169,3 +172,32 @@ instance (Field.C a, ZeroTestable.C a) => Algebraic.C (T a) where root n = lift1 (PowerSum.root n) + + + +{- | +Given an approximation of a root, +the degree of the polynomial and maximum value of coefficients, +find candidates of polynomials that have approximately this root +and show the actual value of the polynomial at the given root approximation. + +This algorithm runs easily into a stack overflow, I do not know why. +We may also employ a more sophisticated integer relation algorithm, +like PSLQ and friends. +-} +{-# SPECIALISE approxPolynomial :: + Int -> Integer -> Double -> (Double, Poly.T Double) #-} +{-# SPECIALISE approxPolynomial :: + Int -> Integer -> Float -> (Float, Poly.T Float) #-} +approxPolynomial :: + (RealRing.C a) => + Int -> Integer -> a -> (a, Poly.T a) +approxPolynomial d maxCoeff x = + let powers = take (d+1) $ iterate (x*) one + in -- List.minimumBy (\a b -> compare (abs (fst a)) (abs (fst b))) $ + Key.minimum (abs . fst) $ + map + ((\cs -> (sum $ zipWith (*) powers cs, Poly.fromCoeffs cs)) . reverse) + (liftM2 (:) + (map fromInteger [1 .. maxCoeff]) + (replicateM d $ map fromInteger [-maxCoeff .. maxCoeff])) diff --git a/src/MathObj/Wrapper/Haskell98.hs b/src/MathObj/Wrapper/Haskell98.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/Wrapper/Haskell98.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{- | +A wrapper that provides instances of Haskell 98 and NumericPrelude +numeric type classes +for types that have Haskell 98 instances. +-} +module MathObj.Wrapper.Haskell98 where + +import qualified Algebra.Absolute as Absolute +import qualified Algebra.Additive as Additive +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.IntegralDomain as Integral +import qualified Algebra.PrincipalIdealDomain as PID +import qualified Algebra.RealField as RealField +import qualified Algebra.RealIntegral as RealIntegral +import qualified Algebra.RealRing as RealRing +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Ring as Ring +import qualified Algebra.ToInteger as ToInteger +import qualified Algebra.ToRational as ToRational +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Units as Units +import qualified Algebra.ZeroTestable as ZeroTestable + +import qualified Number.Ratio as Ratio + +import qualified Algebra.RealRing98 as RealRing98 + +import Data.Ix (Ix, ) + +import Data.Tuple.HT (mapPair, ) + + +{- | +This makes a type usable in the NumericPrelude framework +that was initially implemented for Haskell98 typeclasses. +E.g. if @a@ is in class 'Num', +then @T a@ is both in class 'Num' and in 'Ring.C'. + +You can even lift container types. +If @Polynomial a@ is in 'Num' for all types @a@ that are in 'Num', +then @T (Polynomial (MathObj.Wrapper.NumericPrelude.T a))@ +is in 'Ring.C' for all types @a@ that are in 'Ring.C'. +-} +newtype T a = Cons a + deriving + (Show, Eq, Ord, Ix, Bounded, Enum, + Num, Integral, Fractional, Floating, + Real, RealFrac, RealFloat) + + +{-# INLINE lift1 #-} +lift1 :: (a -> b) -> T a -> T b +lift1 f (Cons a) = Cons (f a) + +{-# INLINE lift2 #-} +lift2 :: (a -> b -> c) -> T a -> T b -> T c +lift2 f (Cons a) (Cons b) = Cons (f a b) + + +instance Functor T where + {-# INLINE fmap #-} + fmap f (Cons a) = Cons (f a) + + +instance Num a => Additive.C (T a) where + zero = 0 + (+) = lift2 (+) + (-) = lift2 (-) + negate = lift1 negate + +instance (Num a) => Ring.C (T a) where + fromInteger = Cons . fromInteger + (*) = lift2 (*) + (^) a n = lift1 (^n) a + +instance (Fractional a) => Field.C (T a) where + fromRational' r = Cons (fromRational (Ratio.toRational98 r)) + (/) = lift2 (/) + recip = lift1 recip + (^-) a n = lift1 (^^n) a + +instance (Floating a) => Algebraic.C (T a) where + sqrt = lift1 sqrt + (^/) a r = lift1 (** fromRational (Ratio.toRational98 r)) a + root n a = lift1 (** recip (fromInteger n)) a + +instance (Floating a) => Trans.C (T a) where + pi = Cons pi + log = lift1 log + exp = lift1 exp + logBase = lift2 logBase + (**) = lift2 (**) + cos = lift1 cos + tan = lift1 tan + sin = lift1 sin + acos = lift1 acos + atan = lift1 atan + asin = lift1 asin + cosh = lift1 cosh + tanh = lift1 tanh + sinh = lift1 sinh + acosh = lift1 acosh + atanh = lift1 atanh + asinh = lift1 asinh + +instance (Integral a) => Integral.C (T a) where + div = lift2 div + mod = lift2 mod + divMod (Cons a) (Cons b) = + mapPair (Cons, Cons) (divMod a b) + +instance (Integral a) => Units.C (T a) where + isUnit = unimplemented "isUnit" + stdAssociate = unimplemented "stdAssociate" + stdUnit = unimplemented "stdUnit" + stdUnitInv = unimplemented "stdUnitInv" + +instance (Integral a) => PID.C (T a) where + gcd = gcd + lcm = lcm + +instance (Num a) => ZeroTestable.C (T a) where + isZero (Cons a) = a==0 + +instance (Num a) => Absolute.C (T a) where + abs = abs + signum = signum + +instance (RealFrac a) => RealRing.C (T a) where + splitFraction (Cons a) = + mapPair (Ring.fromInteger, Cons) + (RealRing98.fixSplitFraction (properFraction a)) + fraction (Cons a) = + Cons (RealRing98.fixFraction (RealRing98.signedFraction a)) + ceiling (Cons a) = Ring.fromInteger (ceiling a) + floor (Cons a) = Ring.fromInteger (floor a) + truncate (Cons a) = Ring.fromInteger (truncate a) + round (Cons a) = Ring.fromInteger (round a) + +instance (RealFrac a) => RealField.C (T a) where + +instance (RealFloat a) => RealTrans.C (T a) where + atan2 = atan2 + +instance (Integral a) => RealIntegral.C (T a) where + quot = lift2 quot + rem = lift2 rem + quotRem (Cons a) (Cons b) = + mapPair (Cons, Cons) (quotRem a b) + +instance (Integral a) => ToInteger.C (T a) where + toInteger (Cons a) = toInteger a + +instance (Real a) => ToRational.C (T a) where + toRational (Cons a) = Field.fromRational (toRational a) + + + +unimplemented :: String -> a +unimplemented name = + error (name ++ "cannot be implemented in terms of Haskell98 type classes") diff --git a/src/MathObj/Wrapper/NumericPrelude.hs b/src/MathObj/Wrapper/NumericPrelude.hs new file mode 100644 --- /dev/null +++ b/src/MathObj/Wrapper/NumericPrelude.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{- | +A wrapper that provides instances of Haskell 98 and NumericPrelude +numeric type classes +for types that have NumericPrelude instances. +-} +module MathObj.Wrapper.NumericPrelude where + +import qualified Algebra.Absolute as Absolute +import qualified Algebra.Additive as Additive +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.IntegralDomain as Integral +import qualified Algebra.PrincipalIdealDomain as PID +import qualified Algebra.RealField as RealField +import qualified Algebra.RealIntegral as RealIntegral +import qualified Algebra.RealRing as RealRing +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Ring as Ring +import qualified Algebra.ToInteger as ToInteger +import qualified Algebra.ToRational as ToRational +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Units as Units +import qualified Algebra.ZeroTestable as ZeroTestable + +import qualified Algebra.NormedSpace.Euclidean as NormEuc +import qualified Algebra.NormedSpace.Maximum as NormMax +import qualified Algebra.NormedSpace.Sum as NormSum +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Differential as Differential +import qualified Algebra.DivisibleSpace as Divisible +import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.Module as Module + +import qualified Number.Ratio as Ratio + +import Data.Ix (Ix, ) + +import Data.Tuple.HT (mapPair, ) + + +{- | +This makes a type usable with Haskell98 type classes +that was initially implemented for NumericPrelude typeclasses. +E.g. if @a@ is in class 'Ring.C', +then @T a@ is both in class 'Num' and in 'Ring.C'. + +You can even lift container types. +If @Polynomial a@ is in 'Ring.C' for all types @a@ that are in 'Ring.C', +then @T (Polynomial (MathObj.Wrapper.Haskell98.T a))@ +is in 'Num' for all types @a@ that are in 'Num'. +-} +newtype T a = Cons a + deriving + (Show, Eq, Ord, Ix, Bounded, Enum, + Ring.C, Additive.C, Field.C, Algebraic.C, Trans.C, + Integral.C, PID.C, Units.C, + Absolute.C, ZeroTestable.C, + RealField.C, RealIntegral.C, RealRing.C, RealTrans.C, + ToInteger.C, ToRational.C, + Differential.C) + +{-# INLINE lift1 #-} +lift1 :: (a -> b) -> T a -> T b +lift1 f (Cons a) = Cons (f a) + +{-# INLINE lift2 #-} +lift2 :: (a -> b -> c) -> T a -> T b -> T c +lift2 f (Cons a) (Cons b) = Cons (f a b) + + +instance Functor T where + {-# INLINE fmap #-} + fmap f (Cons a) = Cons (f a) + + +{- +instance Enum a => Enum (T a) where + succ (Cons n) = Cons (succ n) + pred (Cons n) = Cons (pred n) + toEnum n = Cons (toEnum n) + fromEnum (Cons n) = fromEnum n + enumFrom (Cons n) = + map Cons (enumFrom n) + enumFromThen (Cons n) (Cons m) = + map Cons (enumFromThen n m) + enumFromTo (Cons n) (Cons m) = + map Cons (enumFromTo n m) + enumFromThenTo (Cons n) (Cons m) (Cons p) = + map Cons (enumFromThenTo n m p) +-} + +instance (Ring.C a, Absolute.C a, Eq a, Show a) => Num (T a) where + (+) = lift2 (Additive.+) + (-) = lift2 (Additive.-) + negate = lift1 Additive.negate + + fromInteger = Cons . Ring.fromInteger + (*) = lift2 (Ring.*) + + abs = lift1 Absolute.abs + signum = lift1 Absolute.signum + +instance (RealIntegral.C a, Absolute.C a, ToInteger.C a, Ord a, Enum a, Show a) => Integral (T a) where + quot = lift2 RealIntegral.quot + rem = lift2 RealIntegral.rem + quotRem (Cons a) (Cons b) = + mapPair (Cons, Cons) (RealIntegral.quotRem a b) + div = lift2 Integral.div + mod = lift2 Integral.mod + divMod (Cons a) (Cons b) = + mapPair (Cons, Cons) (Integral.divMod a b) + toInteger (Cons a) = ToInteger.toInteger a + +instance (Field.C a, Absolute.C a, Eq a, Show a) => Fractional (T a) where + (/) = lift2 (Field./) + recip = lift1 Field.recip + fromRational = Cons . Field.fromRational + +instance (Trans.C a, Absolute.C a, Eq a, Show a) => Floating (T a) where + sqrt = lift1 Algebraic.sqrt + pi = Cons Trans.pi + log = lift1 Trans.log + exp = lift1 Trans.exp + logBase = lift2 Trans.logBase + (**) = lift2 (Trans.**) + cos = lift1 Trans.cos + tan = lift1 Trans.tan + sin = lift1 Trans.sin + acos = lift1 Trans.acos + atan = lift1 Trans.atan + asin = lift1 Trans.asin + cosh = lift1 Trans.cosh + tanh = lift1 Trans.tanh + sinh = lift1 Trans.sinh + acosh = lift1 Trans.acosh + atanh = lift1 Trans.atanh + asinh = lift1 Trans.asinh + +instance (ToRational.C a, Absolute.C a, Ord a, Show a) => Real (T a) where + toRational (Cons a) = + Ratio.toRational98 (ToRational.toRational a) + +instance (Field.C a, RealRing.C a, ToRational.C a, Absolute.C a, Ord a, Show a) => RealFrac (T a) where + properFraction (Cons a) = + let b = RealRing.truncate a + in (fromInteger b, Cons (a Additive.- Ring.fromInteger b)) + ceiling (Cons a) = fromInteger (RealRing.ceiling a) + floor (Cons a) = fromInteger (RealRing.floor a) + truncate (Cons a) = fromInteger (RealRing.truncate a) + round (Cons a) = fromInteger (RealRing.round a) + +instance (Trans.C a, RealRing.C a, ToRational.C a, Absolute.C a, Ord a, Show a) => RealFloat (T a) where + atan2 = atan2 + floatRadix = unimplemented "floatRadix" + floatDigits = unimplemented "floatDigits" + floatRange = unimplemented "floatRange" + decodeFloat = unimplemented "decodeFloat" + encodeFloat = unimplemented "encodeFloat" + exponent = unimplemented "exponent" + significand = unimplemented "significand" + scaleFloat = unimplemented "scaleFloat" + isNaN = unimplemented "isNaN" + isInfinite = unimplemented "isInfinite" + isDenormalized = unimplemented "isDenormalized" + isNegativeZero = unimplemented "isNegativeZero" + isIEEE = unimplemented "isIEEE" + +{- +instance Additive.C (T a) where +instance Ring.C (T a) where +instance Field.C (T a) where +instance Algebraic.C (T a) where +instance Trans.C (T a) where + +instance Units.C (T a) where +instance Integral.C (T a) where +instance PID.C (T a) where + +instance ZeroTestable.C (T a) where +instance Absolute.C (T a) where +instance (Ord a) => RealField.C (T a) where +instance (Ord a) => RealIntegral.C (T a) where +instance (Ord a) => RealRing.C (T a) where +instance (Ord a) => RealTrans.C (T a) where + +instance (Ord a) => ToInteger.C (T a) where +instance (Ord a) => ToRational.C (T a) where +-} + +instance Module.C a v => Module.C (T a) (T v) where + (*>) = lift2 (Module.*>) + +instance VectorSpace.C a v => VectorSpace.C (T a) (T v) where + +instance Divisible.C a v => Divisible.C (T a) (T v) where + () = lift2 (Divisible.) + +instance OccScalar.C a v => OccScalar.C (T a) (T v) where + toScalar = lift1 OccScalar.toScalar + toMaybeScalar (Cons a) = fmap Cons (OccScalar.toMaybeScalar a) + fromScalar = lift1 OccScalar.fromScalar + +instance NormEuc.Sqr a v => NormEuc.Sqr (T a) (T v) where + normSqr = lift1 NormEuc.normSqr + +instance NormEuc.C a v => NormEuc.C (T a) (T v) where + norm = lift1 NormEuc.norm + +instance NormMax.C a v => NormMax.C (T a) (T v) where + norm = lift1 NormMax.norm + +instance NormSum.C a v => NormSum.C (T a) (T v) where + norm = lift1 NormSum.norm + + +unimplemented :: String -> a +unimplemented name = + error (name ++ "cannot be implemented in terms of NumericPrelude type classes") diff --git a/src/Number/Complex.hs b/src/Number/Complex.hs --- a/src/Number/Complex.hs +++ b/src/Number/Complex.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- Rules should be processed -} @@ -71,9 +71,7 @@ import qualified Algebra.ZeroTestable as ZeroTestable import qualified Algebra.Indexable as Indexable -import Algebra.ZeroTestable(isZero) -import Algebra.Module((*>), (<*>.*>), ) -import Algebra.Algebraic((^/), ) +import Algebra.Module((<*>.*>), ) import qualified NumericPrelude.Elementwise as Elem import Algebra.Additive ((<*>.+), (<*>.-), (<*>.-$), ) @@ -221,7 +219,7 @@ cis :: (Trans.C a) => a -> T a cis theta = Cons (cos theta) (sin theta) -propPolar :: (RealTrans.C a) => T a -> Bool +propPolar :: (RealTrans.C a, ZeroTestable.C a) => T a -> Bool propPolar z = uncurry fromPolar (toPolar z) == z @@ -277,7 +275,7 @@ the magnitude is nonnegative, and the phase in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase. -} -toPolar :: (RealTrans.C a) => T a -> (a,a) +toPolar :: (RealTrans.C a, ZeroTestable.C a) => T a -> (a,a) toPolar z = (magnitude z, phase z) @@ -320,7 +318,7 @@ {-# INLINE fromInteger #-} fromInteger = fromReal . fromInteger -instance (Absolute.C a, Algebraic.C a) => Absolute.C (T a) where +instance (Absolute.C a, Algebraic.C a, ZeroTestable.C a) => Absolute.C (T a) where {- SPECIALISE instance Absolute.C (T Float) -} {- SPECIALISE instance Absolute.C (T Double) -} {-# INLINE abs #-} @@ -478,7 +476,7 @@ {-# INLINE defltPow #-} -defltPow :: (RealTrans.C a) => +defltPow :: (RealTrans.C a, ZeroTestable.C a) => Rational -> T a -> T a defltPow r x = let (mag,arg) = toPolar x @@ -510,7 +508,7 @@ (^/) = flip power -instance (RealRing.C a, RealTrans.C a, Power a) => +instance (RealRing.C a, RealTrans.C a, ZeroTestable.C a, Power a) => Trans.C (T a) where {- SPECIALISE instance Trans.C (T Float) -} {- SPECIALISE instance Trans.C (T Double) -} diff --git a/src/Number/ComplexSquareRoot.hs b/src/Number/ComplexSquareRoot.hs --- a/src/Number/ComplexSquareRoot.hs +++ b/src/Number/ComplexSquareRoot.hs @@ -10,8 +10,6 @@ import qualified Number.Complex as Complex -import Algebra.ZeroTestable(isZero, ) - import Test.QuickCheck (Arbitrary, arbitrary, ) import Control.Monad (liftM2, ) diff --git a/src/Number/DimensionTerm.hs b/src/Number/DimensionTerm.hs --- a/src/Number/DimensionTerm.hs +++ b/src/Number/DimensionTerm.hs @@ -20,7 +20,7 @@ import qualified Algebra.Module as Module import qualified Algebra.Algebraic as Algebraic import qualified Algebra.Field as Field -import qualified Algebra.Absolute as Absolute +import qualified Algebra.Absolute as Absolute import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive @@ -31,6 +31,8 @@ import System.Random (Random, randomR, random) +import Control.DeepSeq (NFData(rnf), ) + import Data.Tuple.HT (mapFst, ) import NumericPrelude.Base import Prelude () @@ -50,6 +52,9 @@ in showParen (p >= Dim.appPrec) (showString "DimensionNumber.fromNumberWithDimension " . showsPrec Dim.appPrec u . showString " " . showsPrec Dim.appPrec z) + +instance NFData a => NFData (T u a) where + rnf (Cons x) = rnf x fromNumber :: a -> Scalar a diff --git a/src/Number/DimensionTerm/SI.hs b/src/Number/DimensionTerm/SI.hs --- a/src/Number/DimensionTerm/SI.hs +++ b/src/Number/DimensionTerm/SI.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2003 License : GPL diff --git a/src/Number/FixedPoint.hs b/src/Number/FixedPoint.hs --- a/src/Number/FixedPoint.hs +++ b/src/Number/FixedPoint.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2006 @@ -123,6 +123,12 @@ {- Maybe we can speed up the algorithm by calling sqrt recursively on deflated arguments. + +ToDo: +The algorithm just computes floor(sqrt(den*x)). +We might factor out the algorithm for (floor.sqrt) +and move it to a different module +together with Fermat factors and so on. -} sqrt :: Integer -> Integer -> Integer sqrt den x = diff --git a/src/Number/FixedPoint/Check.hs b/src/Number/FixedPoint/Check.hs --- a/src/Number/FixedPoint/Check.hs +++ b/src/Number/FixedPoint/Check.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Number.FixedPoint.Check where import qualified Number.FixedPoint as FP diff --git a/src/Number/GaloisField2p32m5.hs b/src/Number/GaloisField2p32m5.hs --- a/src/Number/GaloisField2p32m5.hs +++ b/src/Number/GaloisField2p32m5.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {- | This number type is intended for tests of functions over fields, diff --git a/src/Number/NonNegative.hs b/src/Number/NonNegative.hs --- a/src/Number/NonNegative.hs +++ b/src/Number/NonNegative.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- @@ -176,7 +176,7 @@ abs = lift abs signum = lift signum -instance (RealRing.C a) => RealRing.C (T a) where +instance (ZeroTestable.C a, RealRing.C a) => RealRing.C (T a) where splitFraction = mapSnd fromNumberUnsafe . splitFraction . toNumber truncate = truncate . toNumber round = round . toNumber diff --git a/src/Number/NonNegativeChunky.hs b/src/Number/NonNegativeChunky.hs --- a/src/Number/NonNegativeChunky.hs +++ b/src/Number/NonNegativeChunky.hs @@ -33,7 +33,6 @@ import qualified Algebra.IntegralDomain as Integral import qualified Algebra.RealIntegral as RealIntegral import qualified Algebra.ZeroTestable as ZeroTestable -import Algebra.ZeroTestable (isZero, ) import qualified Algebra.Monoid as Monoid import qualified Data.Monoid as Mn98 diff --git a/src/Number/OccasionallyScalarExpression.hs b/src/Number/OccasionallyScalarExpression.hs --- a/src/Number/OccasionallyScalarExpression.hs +++ b/src/Number/OccasionallyScalarExpression.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | @@ -24,7 +24,6 @@ import qualified Algebra.Additive as Additive import qualified Algebra.ZeroTestable as ZeroTestable -import Algebra.Algebraic (sqrt, (^/)) import qualified Algebra.OccasionallyScalar as OccScalar import Data.Maybe(fromMaybe) diff --git a/src/Number/PartiallyTranscendental.hs b/src/Number/PartiallyTranscendental.hs --- a/src/Number/PartiallyTranscendental.hs +++ b/src/Number/PartiallyTranscendental.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Define Transcendental functions on arbitrary fields. These functions are defined for only a few (in most cases only one) arguments, diff --git a/src/Number/Peano.hs b/src/Number/Peano.hs --- a/src/Number/Peano.hs +++ b/src/Number/Peano.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2007 Maintainer : numericprelude@henning-thielemann.de @@ -33,8 +33,10 @@ import Data.Array(Ix(..)) import qualified Prelude as P98 +{- import qualified NumericPrelude.Base as P import qualified NumericPrelude.Numeric as NP +-} import Data.List.HT (mapAdjacent, shearTranspose, ) import Data.Tuple.HT (mapFst, ) diff --git a/src/Number/Physical.hs b/src/Number/Physical.hs --- a/src/Number/Physical.hs +++ b/src/Number/Physical.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | @@ -29,8 +29,6 @@ import qualified Algebra.ZeroTestable as ZeroTestable import qualified Algebra.ToInteger as ToInteger - -import Algebra.Algebraic (sqrt, (^/)) import qualified Number.Ratio as Ratio diff --git a/src/Number/Physical/Read.hs b/src/Number/Physical/Read.hs --- a/src/Number/Physical/Read.hs +++ b/src/Number/Physical/Read.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2004 License : GPL diff --git a/src/Number/Physical/Show.hs b/src/Number/Physical/Show.hs --- a/src/Number/Physical/Show.hs +++ b/src/Number/Physical/Show.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2004 License : GPL diff --git a/src/Number/Physical/Unit.hs b/src/Number/Physical/Unit.hs --- a/src/Number/Physical/Unit.hs +++ b/src/Number/Physical/Unit.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2003-2006 License : GPL diff --git a/src/Number/Physical/UnitDatabase.hs b/src/Number/Physical/UnitDatabase.hs --- a/src/Number/Physical/UnitDatabase.hs +++ b/src/Number/Physical/UnitDatabase.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2003 License : GPL diff --git a/src/Number/Positional.hs b/src/Number/Positional.hs --- a/src/Number/Positional.hs +++ b/src/Number/Positional.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2006 License : GPL diff --git a/src/Number/Positional/Check.hs b/src/Number/Positional/Check.hs --- a/src/Number/Positional/Check.hs +++ b/src/Number/Positional/Check.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2006 License : GPL @@ -30,7 +30,7 @@ import qualified Algebra.EqualityDecision as EqDec import qualified Algebra.OrderDecision as OrdDec -import qualified NumericPrelude.Base as P +-- import qualified NumericPrelude.Base as P import qualified Prelude as P98 import NumericPrelude.Base as P diff --git a/src/Number/Quaternion.hs b/src/Number/Quaternion.hs --- a/src/Number/Quaternion.hs +++ b/src/Number/Quaternion.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | @@ -46,8 +46,7 @@ import qualified Algebra.Additive as Additive import qualified Algebra.ZeroTestable as ZeroTestable -import Algebra.ZeroTestable(isZero) -import Algebra.Module((*>), (<*>.*>), ) +import Algebra.Module((<*>.*>), ) import qualified Number.Complex as Complex @@ -60,7 +59,7 @@ import Data.Array (Array, (!)) import qualified Data.Array as Array -import qualified Prelude as P +-- import qualified Prelude as P import NumericPrelude.Base import NumericPrelude.Numeric hiding (signum) import Text.Show.HT (showsInfixPrec, ) diff --git a/src/Number/Ratio.hs b/src/Number/Ratio.hs --- a/src/Number/Ratio.hs +++ b/src/Number/Ratio.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Module : Number.Ratio Copyright : (c) Henning Thielemann, Dylan Thurston 2006 diff --git a/src/Number/ResidueClass.hs b/src/Number/ResidueClass.hs --- a/src/Number/ResidueClass.hs +++ b/src/Number/ResidueClass.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Number.ResidueClass where import qualified Algebra.PrincipalIdealDomain as PID diff --git a/src/Number/ResidueClass/Check.hs b/src/Number/ResidueClass/Check.hs --- a/src/Number/ResidueClass/Check.hs +++ b/src/Number/ResidueClass/Check.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Number.ResidueClass.Check where import qualified Number.ResidueClass as Res diff --git a/src/Number/ResidueClass/Func.hs b/src/Number/ResidueClass/Func.hs --- a/src/Number/ResidueClass/Func.hs +++ b/src/Number/ResidueClass/Func.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Number.ResidueClass.Func where import qualified Number.ResidueClass as Res diff --git a/src/Number/ResidueClass/Maybe.hs b/src/Number/ResidueClass/Maybe.hs --- a/src/Number/ResidueClass/Maybe.hs +++ b/src/Number/ResidueClass/Maybe.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Number.ResidueClass.Maybe where import qualified Number.ResidueClass as Res diff --git a/src/Number/ResidueClass/Reader.hs b/src/Number/ResidueClass/Reader.hs --- a/src/Number/ResidueClass/Reader.hs +++ b/src/Number/ResidueClass/Reader.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Number.ResidueClass.Reader where import qualified Number.ResidueClass as Res @@ -14,7 +14,7 @@ import Control.Monad (liftM2, liftM4) -- import Control.Monad.Reader (MonadReader) -import qualified Prelude as P +-- import qualified Prelude as P import qualified NumericPrelude.Numeric as NP diff --git a/src/Number/Root.hs b/src/Number/Root.hs --- a/src/Number/Root.hs +++ b/src/Number/Root.hs @@ -1,3 +1,8 @@ +{- +ToDo: +having the root exponent as type-level number would be nice +there is a package for basic type-level number support +-} module Number.Root where import qualified Algebra.Algebraic as Algebraic diff --git a/src/Number/SI.hs b/src/Number/SI.hs --- a/src/Number/SI.hs +++ b/src/Number/SI.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | @@ -37,8 +37,6 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive import qualified Algebra.ZeroTestable as ZeroTestable - -import Algebra.Algebraic (sqrt, (^/), ) import Data.Tuple.HT (mapFst, ) diff --git a/src/Number/SI/Unit.hs b/src/Number/SI/Unit.hs --- a/src/Number/SI/Unit.hs +++ b/src/Number/SI/Unit.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright : (c) Henning Thielemann 2003 License : GPL diff --git a/src/NumericPrelude/List/Checked.hs b/src/NumericPrelude/List/Checked.hs --- a/src/NumericPrelude/List/Checked.hs +++ b/src/NumericPrelude/List/Checked.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Some functions that are counterparts of functions from "Data.List" using NumericPrelude.Numeric type classes. diff --git a/src/NumericPrelude/List/Generic.hs b/src/NumericPrelude/List/Generic.hs --- a/src/NumericPrelude/List/Generic.hs +++ b/src/NumericPrelude/List/Generic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {- | Functions that are counterparts of the @generic@ functions in "Data.List" using NumericPrelude.Numeric type classes. diff --git a/src/NumericPrelude/Numeric.hs b/src/NumericPrelude/Numeric.hs --- a/src/NumericPrelude/Numeric.hs +++ b/src/NumericPrelude/Numeric.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module NumericPrelude.Numeric ( {- Additive -} (+), (-), negate, zero, subtract, sum, sum1, {- ZeroTestable -} isZero, diff --git a/test-ghc-6.12/Gaussian.hs b/test-ghc-6.12/Gaussian.hs deleted file mode 100644 --- a/test-ghc-6.12/Gaussian.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import qualified MathObj.Gaussian.Example as Example - -main :: IO () -main = Example.polyApprox diff --git a/test-ghc-6.12/Test.hs b/test-ghc-6.12/Test.hs deleted file mode 100644 --- a/test-ghc-6.12/Test.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Main where - -import Number.Complex((+:), (-:), ) -import qualified Number.Complex as Complex -import Number.Physical as Value -import Number.SI as SIValue -- units -import Number.SI.Unit as SIUnit -- unit prefixes - (pico, nano, micro, milli, centi, deci, - deca, hecto, kilo, mega, giga, tera, peta) -import Number.OccasionallyScalarExpression as Expr - -import qualified Number.Positional.Check as Absolute -import qualified Number.FixedPoint.Check as FixedPoint -import qualified Number.ResidueClass.Func as ResidueClass -import qualified Number.Peano as Peano - -import qualified MathObj.Polynomial as Polynomial -import qualified MathObj.LaurentPolynomial as LaurentPolynomial -import qualified MathObj.PowerSeries as PowerSeries -import qualified MathObj.PowerSeries.Example as PowerSeriesExample -import qualified MathObj.PartialFraction as PartialFraction - -import qualified Algebra.PrincipalIdealDomain as PID -import qualified Algebra.Field as Field -import qualified Algebra.ZeroTestable as ZeroTestable -import qualified Algebra.Indexable as Indexable - -import Data.List (genericTake, genericLength) - -import NumericPrelude.Base -import NumericPrelude.Numeric - - -{- * Physical units -} - --- some shorthands for common usage -type SIDouble = SIValue.T Double Double -type SIComplex = SIValue.T Double (Complex.T Double) - -{- this advice seems not to be targeted to ghc's interactive mode -default (SIDouble) --} - - - - -test :: [SIDouble] -test = - let lengthScales = map (\n->10^-n*meter) [-10..6] - areaScales = map (\n->10^-n*meter^2) [-10..6] - in lengthScales ++ map recip lengthScales ++ - areaScales ++ map recip areaScales ++ - map ((meter*gramm/second)^-) [-5..5] ++ - take 16 (iterate (10*) (10e-10*meter/gramm)) ++ - [1/meter^2, 1/meter, meter, meter^2, - second, hertz, - meter*second, second/meter, meter/second, 1/meter/second, - volt/meter,newton/meter, - gramm] - -testComplex :: SIComplex -testComplex = (2 :: Double) *> (SIValue.fromScalarSingle (3+:4)*milli*second) - -testMagnitude :: SIDouble -testMagnitude = SIValue.lift (Value.lift Complex.magnitude) testComplex - -testExpr :: Expr.T Double SIDouble -testExpr = sin (5 / (3+1) * fromValue meter) - -testPrefixes :: [SIDouble] -testPrefixes = - [pico, nano, micro, milli, centi, deci, - deca, hecto, kilo, mega, giga, tera, peta] - - -{- * Reals -} - -testReal :: String -testReal = Absolute.defltShow (sqrt 2 + log 2 * pi) - -testComplexReal :: Complex.T Absolute.T -testComplexReal = exp (0 +: pi) + exp (0 -: pi) - -showReal :: Absolute.T -> String -showReal = Absolute.defltShow - - -{- * Fixed point numbers -} - -testFixedPoint :: String -testFixedPoint = FixedPoint.defltShow (sqrt 2 + log 2 * pi) - -showFixedPoint :: FixedPoint.T -> String -showFixedPoint = FixedPoint.defltShow - - -{- * Residue classes -} - -testResidueClass :: Integer -testResidueClass = ResidueClass.concrete 7 (5*3/2) - -polyResidueClass :: (ZeroTestable.C a, Field.C a) => - [a] -> ResidueClass.T (Polynomial.T a) -polyResidueClass = ResidueClass.fromRepresentative . polynomial - -{- That's strange: -The residue class implementation should constantly compute mod -and thus should be much faster. -I assume that this is an effect of missing sharing. -The functions which represent a residue class are shared, -but not their values. - -*Main> mod (3^3000000) 2 :: Integer -1 -(2.47 secs, 24541080 bytes) -*Main> ResidueClass.concrete 2 (3^3000000) :: Integer -1 -(7.33 secs, 515047072 bytes) --} - - -{- * Polynomials and power series -} - -polynomial :: [a] -> Polynomial.T a -polynomial = Polynomial.fromCoeffs - -powerSeries :: [a] -> PowerSeries.T a -powerSeries = PowerSeries.fromCoeffs - -laurentPolynomial :: Int -> [a] -> LaurentPolynomial.T a -laurentPolynomial = LaurentPolynomial.fromShiftCoeffs - -tanSeries :: PowerSeries.T Rational -tanSeries = powerSeries PowerSeriesExample.tan - - -{- * Partial fractions -} - -partialFraction :: (PID.C a, Indexable.C a) => - [a] -> a -> PartialFraction.T a -partialFraction = PartialFraction.fromFactoredFraction - -{- | -An example from wavelet theory: lifting coefficients of the CDF wavelet family. --} -cdfFraction :: PartialFraction.T (Polynomial.T Rational) -cdfFraction = - partialFraction - (map polynomial [[-4,1],[0,1],[4,1]]) - (product (map polynomial [[-2,1],[2,1]])) - -{- | -The same example with different notation, -that relies on numerical literals being used for polynomials. --} -cdfFractionNum :: PartialFraction.T (Polynomial.T Rational) -cdfFractionNum = - let x = polynomial [0,1] - in partialFraction [x-4,x,x+4] ((x-2)*(x+2)) - - -{- * Peano numbers -} -testPeano :: Peano.T -testPeano = minimum [Peano.infinity, 2, Peano.infinity, 4] - -testPeanoList :: [Char] -testPeanoList = - genericTake (genericLength (repeat 'a') :: Peano.T) ['a'..'z'] - - -main :: IO () -main = print test diff --git a/test-ghc-6.12/Test/Algebra/IntegralDomain.hs b/test-ghc-6.12/Test/Algebra/IntegralDomain.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/Algebra/IntegralDomain.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Test.Algebra.IntegralDomain where - -import Algebra.IntegralDomain (roundDown, roundUp, divUp, ) - -import Test.NumericPrelude.Utility (testUnit, ) -import Test.QuickCheck (Testable, quickCheck, (==>), ) -import qualified Test.HUnit as HUnit - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - -test :: - (Testable t) => - (Integer -> t) -> IO () -test = quickCheck - - -tests :: HUnit.Test -tests = - HUnit.TestLabel "integral domain functions" $ - HUnit.TestList $ - map testUnit $ - testList - -testList :: [(String, IO ())] -testList = - ("divMod", test $ \n m -> - m/=0 ==> let (q,r) = divMod n m in n == q*m+r) : - ("divRound", test $ \n m -> - m/=0 ==> div n m * m == roundDown n m) : - ("divUpRound", test $ \n m -> - m/=0 ==> divUp n m * m == roundUp n m) : - ("floorLimit", test $ \n m0 -> - let m = 1 + abs m0 - x = roundDown n m - in n-m < x && x <=n) : - ("floorCeiling", test $ \n m -> - m/=0 ==> - roundDown n m == roundUp (-n) m) : - [] diff --git a/test-ghc-6.12/Test/Algebra/RealRing.hs b/test-ghc-6.12/Test/Algebra/RealRing.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/Algebra/RealRing.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Test.Algebra.RealRing where - -import qualified Algebra.RealRing as RealRing - -import Test.NumericPrelude.Utility (testUnit, ) -import Test.QuickCheck (quickCheck, ) -import qualified Test.HUnit as HUnit - -import Data.Tuple.HT (mapFst, ) - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - -test :: (Eq a) => (Double -> a) -> (Double -> a) -> IO () -test f g = - quickCheck (\x -> f x == g x) - - -tests :: HUnit.Test -tests = - HUnit.TestLabel "rounding functions" $ - HUnit.TestList $ - map testUnit $ - ("round", test RealRing.genericRound (NP.round :: Double -> Integer)) : - ("truncate", test RealRing.genericTruncate (NP.truncate :: Double -> Integer)) : - ("ceiling", test RealRing.genericCeiling (NP.ceiling :: Double -> Integer)) : - ("floor", test RealRing.genericFloor (NP.floor :: Double -> Integer)) : - ("fraction", test RealRing.genericFraction (NP.fraction :: Double -> Double)) : - ("splitFraction", test RealRing.genericSplitFraction (NP.splitFraction :: Double -> (Integer, Double))) : - -{- - ("splitFractionId", quickCheck (\x -> (x::Double) == (uncurry (+) $ mapFst fromInteger $ splitFraction x))) : --} - ("splitFractionId", quickCheck (\x -> uncurry (==) $ mapFst (((x::Double)-) . fromInteger) $ splitFraction x)) : - ("splitFractionFloorFraction", quickCheck (\x -> (floor (x::Double) :: Integer, fraction x) == splitFraction x)) : - ("fractionBound", quickCheck (\x -> let y = fraction (x::Double) in 0<=y && y<1)) : - ("floorCeiling", quickCheck (\x -> negate (floor (x::Double) :: Integer) == ceiling (-x))) : - [] diff --git a/test-ghc-6.12/Test/MathObj/Gaussian/Bell.hs b/test-ghc-6.12/Test/MathObj/Gaussian/Bell.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/MathObj/Gaussian/Bell.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Test.MathObj.Gaussian.Bell where - -import qualified MathObj.Gaussian.Bell as G - --- import qualified Algebra.Ring as Ring - -import qualified Algebra.Laws as Laws - -import qualified Number.Complex as Complex - -import Test.NumericPrelude.Utility (testUnit) -import Test.QuickCheck (Testable, quickCheck, (==>)) -import qualified Test.HUnit as HUnit - -import Data.Function.HT (nest, ) - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - -simple :: - (Testable t) => - (G.T Rational -> t) -> IO () -simple f = - quickCheck (\x -> f (x :: G.T Rational)) - -tests :: HUnit.Test -tests = - HUnit.TestLabel "polynomial" $ - HUnit.TestList $ - map testUnit $ -{- - ("convolution, dirac", - simple $ Laws.identity (+) zero) : --} - ("convolution, commutative", - simple $ Laws.commutative G.convolve) : - ("convolution, associative", - simple $ Laws.associative G.convolve) : - ("multiplication, one", - simple $ Laws.identity G.multiply G.constant) : - ("multiplication, commutative", - simple $ Laws.commutative G.multiply) : - ("multiplication, associative", - simple $ Laws.associative G.multiply) : - ("convolution, multplication, fourier", - simple $ \x y -> - G.fourier (G.convolve x y) - == G.multiply (G.fourier x) (G.fourier y)) : - ("convolution via translation", - simple $ \x y -> - G.convolve x y - == G.convolveByTranslation x y) : - ("convolution via fourier", - simple $ \x y -> - G.convolve x y - == G.convolveByFourier x y) : - ("fourier reverse", - simple $ \x -> nest 2 G.fourier x == G.reverse x) : - ("reverse identity", - simple $ \x -> nest 2 G.reverse x == x) : - ("fourier unit", - quickCheck $ G.fourier G.unit == (G.unit :: G.T Rational)) : - ("translate additive", - simple $ \x a b -> - G.translate a (G.translate b x) == G.translate (a+b) x) : - ("translateComplex additive", - simple $ \x a b -> - G.translateComplex a (G.translateComplex b x) == G.translateComplex (a+b) x) : - ("translateComplex real", - simple $ \x a -> - G.translateComplex (Complex.fromReal a) x == G.translate a x) : - ("modulate additive", - simple $ \x a b -> - G.modulate a (G.modulate b x) == G.modulate (a+b) x) : - ("commute translate modulate", - simple $ \x a b -> - G.modulate b (G.translate a x) - == G.turn (a*b) (G.translate a (G.modulate b x))) : - ("fourier translate", - simple $ \x a -> - G.fourier (G.translate a x) - == G.modulate a (G.fourier x)) : - ("dilate multiplicative", - simple $ \x a b -> a>0 && b>0 ==> - G.dilate a (G.dilate b x) == G.dilate (a*b) x) : - ("dilate by shrink", - simple $ \x a -> a>0 ==> - G.shrink a x == G.dilate (recip a) x) : - ("fourier dilate", - simple $ \x a -> a>0 ==> - G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x))) : - [] diff --git a/test-ghc-6.12/Test/MathObj/Gaussian/Polynomial.hs b/test-ghc-6.12/Test/MathObj/Gaussian/Polynomial.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/MathObj/Gaussian/Polynomial.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Test.MathObj.Gaussian.Polynomial where - -import qualified MathObj.Gaussian.Polynomial as G -import qualified MathObj.Gaussian.Bell as B - -import qualified MathObj.Polynomial as Poly - --- import qualified Algebra.Ring as Ring - -import qualified Algebra.Laws as Laws - -import qualified Number.Complex as Complex - -import Test.NumericPrelude.Utility (testUnit) -import Test.QuickCheck (Testable, quickCheck, (==>)) -import qualified Test.HUnit as HUnit - -import qualified Number.NonNegative as NonNeg -import Data.Function.HT (nest, ) -import Data.Tuple.HT (mapSnd, ) - --- import Debug.Trace (trace, ) - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - -simple :: - (Testable t) => - (G.T Rational -> t) -> IO () -simple f = - quickCheck (\x -> f (x :: G.T Rational)) - -tests :: HUnit.Test -tests = - HUnit.TestLabel "polynomial" $ - HUnit.TestList $ - map testUnit $ - testList - -testList :: [(String, IO ())] -testList = -{- - ("convolution, dirac", - simple $ Laws.identity (+) zero) : --} - ("convolution, commutative", - simple $ Laws.commutative G.convolve) : --- simple $ \x -> Laws.commutative G.convolve (trace (show x) x)) : - ("convolution, associative", - simple $ Laws.associative G.convolve) : -{- - ("convolution by differentiation vs. fourier", - simple $ \x y -> - G.convolveByDifferentiation x y - == G.convolveByFourier x y) : --} - ("multiplication, one", - simple $ Laws.identity G.multiply G.constant) : - ("multiplication, commutative", - simple $ Laws.commutative G.multiply) : - ("multiplication, associative", - simple $ Laws.associative G.multiply) : - ("convolution, multplication, fourier", - simple $ \x y -> - G.fourier (G.convolve x y) - == G.multiply (G.fourier x) (G.fourier y)) : - ("fourier reverse", - simple $ \x -> nest 2 G.fourier x == G.reverse x) : - ("reverse identity", - simple $ \x -> nest 2 G.reverse x == x) : - ("fourier eigenfunction differential", - quickCheck $ \m -> - m <= 15 ==> - let n = NonNeg.toNumber m - x = G.eigenfunctionDifferential n :: G.T Rational - k = Complex.conjugate Complex.imaginaryUnit ^ fromIntegral n - in G.fourier x == G.scaleComplex k x) : - ("fourier eigenfunction iterative", - quickCheck $ \m -> - m <= 15 ==> - let n = NonNeg.toNumber m - x = G.eigenfunctionIterative n :: G.T Rational - k = Complex.conjugate Complex.imaginaryUnit ^ fromIntegral n - in G.fourier x == G.scaleComplex k x) : -{- this does not hold, both functions compute different eigenbases - ("fourier eigenfunction diff vs. iterative", - quickCheck $ \n -> - n <= 15 ==> - G.eigenfunctionDifferential n == - (G.eigenfunctionIterative n :: G.T Rational)) : --} - ("translate additive", - simple $ \x a b -> - G.translate a (G.translate b x) == G.translate (a+b) x) : - ("translateComplex additive", - simple $ \x a b -> - G.translateComplex a (G.translateComplex b x) == G.translateComplex (a+b) x) : - ("translateComplex real", - simple $ \x a -> - G.translateComplex (Complex.fromReal a) x == G.translate a x) : - ("modulate additive", - simple $ \x a b -> - G.modulate a (G.modulate b x) == G.modulate (a+b) x) : - ("commute translate modulate", - simple $ \x a b -> - G.modulate b (G.translate a x) - == G.turn (a*b) (G.translate a (G.modulate b x))) : - ("fourier translate", - simple $ \x a -> - G.fourier (G.translate a x) - == G.modulate a (G.fourier x)) : - ("dilate multiplicative", - simple $ \x a b -> a>0 && b>0 ==> - G.dilate a (G.dilate b x) == G.dilate (a*b) x) : - ("dilate by shrink", - simple $ \x a -> a>0 ==> - G.shrink a x == G.dilate (recip a) x) : - ("fourier dilate", - simple $ \x a -> a>0 ==> - G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x))) : - ("integrate differentiate", - simple $ \x -> - G.integrate (G.differentiate x) == (zero, x)) : - ("differentiate integrate", - simple $ \x@(G.Cons b p) -> - let (xoff,xint) = G.integrate x - in G.differentiate xint == G.Cons b (p + Poly.const xoff)) : - ("fourier differentiate", - simple $ \x -> - G.fourier (G.differentiate x) == - let y = G.fourier x - in y{G.polynomial = - Poly.fromCoeffs [0, 0 Complex.+: 2] * G.polynomial y}) : - ("differentiate convolve", - simple $ \x y -> - G.convolve (G.differentiate x) y == - G.convolve x (G.differentiate y)) : - ("approximate by bells, translate", - simple $ \x unit d -> unit/=0 ==> - G.approximateByBells unit (G.translateComplex d x) == - map (mapSnd (B.translateComplex d)) (G.approximateByBells unit x)) : - ("approximate by bells, dilate", - simple $ \x unit d -> unit/=0 && d/=0 ==> - G.approximateByBells unit (G.dilate d x) == - map (mapSnd (B.dilate d)) (G.approximateByBells (unit/d) x)) : - ("approximate by bells, shrink", - simple $ \x unit d -> unit/=0 && d/=0 ==> - G.approximateByBells unit (G.shrink d x) == - map (mapSnd (B.shrink d)) (G.approximateByBells (unit*d) x)) : - ("approximate by bells, different implementations", - quickCheck $ \unit d s p -> unit/=0 ==> - G.approximateByBellsAtOnce unit d s (p::Poly.T (Complex.T Rational)) == - G.approximateByBellsByTranslation unit d s p) : - [] diff --git a/test-ghc-6.12/Test/MathObj/Gaussian/Variance.hs b/test-ghc-6.12/Test/MathObj/Gaussian/Variance.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/MathObj/Gaussian/Variance.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Test.MathObj.Gaussian.Variance where - -import qualified MathObj.Gaussian.Variance as G -import qualified Number.Root as Root - --- import qualified Algebra.Ring as Ring - -import qualified Algebra.Laws as Laws - -import Test.NumericPrelude.Utility (testUnit) -import Test.QuickCheck (Testable, quickCheck, (==>), Arbitrary, arbitrary, ) -import qualified Test.HUnit as HUnit - -import Control.Monad (liftM2, liftM3, ) - -import Data.Function.HT (nest, compose2, ) - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - -newtype PositiveInteger = PositiveInteger Integer - deriving Show - -instance Arbitrary PositiveInteger where - arbitrary = - fmap (\p -> PositiveInteger $ 1 + abs p) arbitrary - - -{- | -For @(HoelderConjugates p q)@ it holds - -> 1/p + 1/q = 1 --} -data HoelderConjugates = HoelderConjugates Rational Rational - deriving Show - -{- -instance Arbitrary HoelderConjugates where - arbitrary = liftM2 - (\(PositiveInteger p) (PositiveInteger q) -> - let s = 1%p + 1%q - in HoelderConjugates (fromInteger p * s) (fromInteger q * s)) - arbitrary arbitrary --} -instance Arbitrary HoelderConjugates where - arbitrary = liftM2 - (\(PositiveInteger p) (PositiveInteger q) -> - let s = p + q - in HoelderConjugates (s % p) (s % q)) - arbitrary arbitrary - -{- | -For @(YoungConjugates p q r)@ it holds - -> 1/p + 1/q = 1/r + 1 --} -data YoungConjugates = YoungConjugates Rational Rational Rational - deriving Show - -{- -Find positive natural numbers @a, b, c, d@ with - -> a + b = c + d - -and - -> d >= a, d >= b, d >= c - -then set - -> p=d/a, q=d/b, r=d/c - - -a+b<=c -b+c<=a --> 2b <= 0 --} -instance Arbitrary YoungConjugates where - arbitrary = liftM3 - (\(PositiveInteger a0) (PositiveInteger b0) (PositiveInteger c0) -> - let guardSwap cond (x,y) = - if cond x y then (x,y) else (y,x) - {- - If a+b<=c, then from b>0 it follows aa. - Swapping a and c is enough and we have not to consider more cases. - -} - (a1,c1) = guardSwap (\a c -> a+b0>c) (a0,c0) - b1 = b0 - d1 = a1+b1-c1 - ((a2,b2),(c2,d2)) = - guardSwap (compose2 (<=) snd) - (guardSwap (<=) (a1,b1), - guardSwap (<=) (c1,d1)) - in YoungConjugates (d2%a2) (d2%b2) (d2%c2)) - arbitrary arbitrary arbitrary - - -simple :: - (Testable t) => - (G.T Rational -> t) -> IO () -simple f = - quickCheck (\x -> f (x :: G.T Rational)) - -tests :: HUnit.Test -tests = - HUnit.TestLabel "variance" $ - HUnit.TestList $ - map testUnit $ - testList - -testList :: [(String, IO ())] -testList = -{- - ("convolution, dirac", - simple $ Laws.identity (+) zero) : --} - ("convolution, commutative", - simple $ Laws.commutative G.convolve) : - ("convolution, associative", - simple $ Laws.associative G.convolve) : - ("multiplication, one", - simple $ Laws.identity G.multiply G.constant) : - ("multiplication, commutative", - simple $ Laws.commutative G.multiply) : - ("multiplication, associative", - simple $ Laws.associative G.multiply) : - ("convolution via fourier", - simple $ \x y -> - G.fourier (G.convolve x y) - == G.multiply (G.fourier x) (G.fourier y)) : - ("fourier identity", - simple $ \x -> nest 4 G.fourier x == x) : - ("dilate multiplicative", - simple $ \x a b -> a>0 && b>0 ==> - G.dilate a (G.dilate b x) == G.dilate (a*b) x) : - ("dilate by shrink", - simple $ \x a -> a>0 ==> - G.shrink a x == G.dilate (recip a) x) : - ("fourier dilate", - simple $ \x a -> a>0 ==> - G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x))) : - ("fourier, unitary", - simple $ \x y -> - G.scalarProductRoot x y - == G.scalarProductRoot (G.fourier x) (G.fourier y)) : - ("norm1 vs. normP 1", - simple $ \x -> G.norm1Root x == G.normPRoot 1 x) : - ("norm2 vs. normP 2", - simple $ \x -> G.norm2Root x == G.normPRoot 2 x) : -{- -I would have liked to test for a monotony of norms. -Unfortunately, it does not hold. - -Means contain a division by the size of the domain. -Norms do not have this division. -Means are monotonic with respect to the degree. -Norms are not. -We cannot turn the norms into means since the size of the domain -(the complete real axis) is infinitely large. - ("norm monotony", - simple $ \x p0 q0 -> - let p = 1 + abs p0 - q = 1 + abs q0 - in case compare p q of - EQ -> G.normPRoot p x == G.normPRoot q x - LT -> G.normPRoot p x <= G.normPRoot q x - GT -> G.normPRoot p x >= G.normPRoot q x) : - -This should also fail, -but QuickCheck does not seem to try counterexamples. - ("infinity norm upper bound", - simple $ \x p0 -> - let p = 1 + abs p0 - in G.normPRoot p x <= G.normInfRoot x) : --} - ("Cauchy-Schwarz inequality", - simple $ \x y -> - G.scalarProductRoot x y - <= G.norm2Root x `Root.mul` G.norm2Root y) : - ("Hoelder conjugates", - quickCheck $ \(HoelderConjugates p q) -> - p>=1 && q>=1 && 1/p + 1/q == 1) : - ("Hoelder inequality with infinity norm", - simple $ \x y -> - G.scalarProductRoot x y - <= G.norm1Root x `Root.mul` G.normInfRoot y) : - ("Hoelder inequality", - simple $ \x y (HoelderConjugates p q) -> - G.scalarProductRoot x y - <= G.normPRoot p x `Root.mul` G.normPRoot q y) : - ("Young inequality with two infinity norms", - simple $ \x y -> - G.normInfRoot (G.convolve x y) - <= G.norm1Root x `Root.mul` G.normInfRoot y) : - ("Young inequality with infinity norm", - simple $ \x y (HoelderConjugates p q) -> - G.normInfRoot (G.convolve x y) - <= G.normPRoot p x `Root.mul` G.normPRoot q y) : - ("Young conjugates", - quickCheck $ \(YoungConjugates p q r) -> - p>=1 && q>=1 && r>=1 && 1/p + 1/q == 1/r + 1) : - ("Young inequality", - simple $ \x y (YoungConjugates p q r) -> - G.normPRoot r (G.convolve x y) - <= G.normPRoot p x `Root.mul` G.normPRoot q y) : - [] diff --git a/test-ghc-6.12/Test/MathObj/Matrix.hs b/test-ghc-6.12/Test/MathObj/Matrix.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/MathObj/Matrix.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Test.MathObj.Matrix where - -import qualified MathObj.Matrix as Matrix - -import qualified Algebra.Ring as Ring - -import qualified Algebra.Laws as Laws - -import qualified Number.NonNegative as NonNeg - -import qualified System.Random as Random - -import Data.Function.HT (nest, ) - -import Test.NumericPrelude.Utility (testUnit, ) -import Test.QuickCheck (quickCheck, ) -import qualified Test.HUnit as HUnit - - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - -type Seed = Int -type Dimension = NonNeg.Int - -random :: Dimension -> Dimension -> Seed -> Matrix.T Integer -random mn nn seed = - fst $ - Matrix.random (NonNeg.toNumber mn) (NonNeg.toNumber nn) $ - Random.mkStdGen seed - - -tests :: HUnit.Test -tests = - HUnit.TestLabel "matrix" $ - HUnit.TestList $ - map testUnit $ - ("dimension", - quickCheck (\m n a -> - (NonNeg.toNumber m, NonNeg.toNumber n) == Matrix.dimension (random m n a))) : - ("to and from rows", - quickCheck (\m n a' -> - let a = random m n a' - in a == Matrix.fromRows (NonNeg.toNumber m) (NonNeg.toNumber n) (Matrix.rows a))) : - ("to and from columns", - quickCheck (\m n a' -> - let a = random m n a' - in a == Matrix.fromColumns (NonNeg.toNumber m) (NonNeg.toNumber n) (Matrix.columns a))) : - ("transpose, rows, columns", - quickCheck (\m n a' -> - let a = random m n a' - in Matrix.rows a == Matrix.columns (Matrix.transpose a))) : - ("transpose, columns, rows", - quickCheck (\m n a' -> - let a = random m n a' - in Matrix.columns a == Matrix.rows (Matrix.transpose a))) : - ("addition, zero", - quickCheck (\m n a -> - Laws.identity (+) (Matrix.zero (NonNeg.toNumber m) (NonNeg.toNumber n)) (random m n a))) : - ("addition, commutative", - quickCheck (\m n a b -> - Laws.commutative (+) (random m n a) (random m n b))) : - ("addition, associative", - quickCheck (\m n a b c -> - Laws.associative (+) (random m n a) (random m n b) (random m n c))) : - ("addition, transpose", - quickCheck (\m n a b -> - Laws.homomorphism Matrix.transpose (+) (+) (random m n a) (random m n b))) : - ("one, diagonal", - quickCheck (\n' -> - let n = NonNeg.toNumber n' - in Matrix.one n == (Matrix.diagonal $ replicate n Ring.one :: Matrix.T Integer))) : - ("multiplication, one left", - quickCheck (\m n a -> - Laws.leftIdentity (*) (Matrix.one (NonNeg.toNumber m)) (random m n a))) : - ("multiplication, one right", - quickCheck (\m n a -> - Laws.rightIdentity (*) (Matrix.one (NonNeg.toNumber n)) (random m n a))) : - ("multiplication, associative", - quickCheck (\k l m n a b c -> - Laws.associative (*) (random k l a) (random l m b) (random m n c))) : - ("multiplication and addition, distributive left", - quickCheck (\l m n a b c -> - Laws.leftDistributive (*) (+) (random n l a) (random m n b) (random m n c))) : - ("multiplication and addition, distributive right", - quickCheck (\l m n a b c -> - Laws.rightDistributive (*) (+) (random l m a) (random m n b) (random m n c))) : - ("multiplication, transpose", - quickCheck (\l m n a b -> - Laws.homomorphism Matrix.transpose (*) (flip (*)) (random l m a) (random m n b))) : - ("multiplication vs. power", - quickCheck (\m a n0 -> - let x = random m m a - n = mod n0 10 - in x^n == nest (fromInteger n) (x*) (Matrix.one (NonNeg.toNumber m)))) : -{- - ("division", quickCheck (\x -> Integral.propInverse (x :: Poly.T Rational))) : --} - [] diff --git a/test-ghc-6.12/Test/MathObj/PartialFraction.hs b/test-ghc-6.12/Test/MathObj/PartialFraction.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/MathObj/PartialFraction.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Test.MathObj.PartialFraction where - -import qualified MathObj.PartialFraction as PartialFraction -import qualified MathObj.Polynomial as Poly -import qualified Number.Ratio as Ratio - -import qualified Algebra.PrincipalIdealDomain as PID --- import qualified Algebra.Ring as Ring -import qualified Algebra.Indexable as Indexable -import qualified Algebra.Vector as Vector --- import Algebra.Vector((*>)) - -import qualified Algebra.Laws as Laws -import qualified Test.QuickCheck as QC - -import Control.Monad.HT as M -import Test.NumericPrelude.Utility (testUnit) -import Test.QuickCheck (quickCheck) -import qualified Test.HUnit as HUnit - - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - -{- * Properties for generic types -} - -fractionConv :: (PID.C a, Indexable.C a) => [a] -> a -> Bool -fractionConv xs y = - PartialFraction.toFraction (PartialFraction.fromFactoredFraction xs y) == - y % product xs - -fractionConvAlt :: (PID.C a, Indexable.C a) => [a] -> a -> Bool -fractionConvAlt xs y = - PartialFraction.fromFactoredFraction xs y == - PartialFraction.fromFactoredFractionAlt xs y - -scaleInt :: (PID.C a, Indexable.C a) => a -> PartialFraction.T a -> Bool -scaleInt k a = - PartialFraction.toFraction (PartialFraction.scaleInt k a) == - Ratio.scale k (PartialFraction.toFraction a) - -add :: (PID.C a, Indexable.C a) => PartialFraction.T a -> PartialFraction.T a -> Bool -add = Laws.homomorphism PartialFraction.toFraction (+) (+) - -sub :: (PID.C a, Indexable.C a) => PartialFraction.T a -> PartialFraction.T a -> Bool -sub = Laws.homomorphism PartialFraction.toFraction (-) (-) - -mul :: (PID.C a, Indexable.C a) => PartialFraction.T a -> PartialFraction.T a -> Bool -mul = Laws.homomorphism PartialFraction.toFraction (*) (*) - - - -{- * Properties for Integers -} - -{- | -Arbitrary instance of that type generates irreducible elements for tests. -Choosing from a list of examples is a simple yet effective design. -If we would construct irreducible elements by a clever algorithm -we might obtain multiple primes only rarely. --} -newtype SmallPrime = SmallPrime {intFromSmallPrime :: Integer} - -type IntFraction = ([SmallPrime],Integer) - -instance QC.Arbitrary SmallPrime where - arbitrary = - let primes = [2,3,5,7,11,13] - in fmap SmallPrime $ QC.elements (primes ++ map negate primes) - -instance Show SmallPrime where - show = show . intFromSmallPrime - - -fractionConvInt :: [SmallPrime] -> Integer -> Bool -fractionConvInt = - fractionConv . map intFromSmallPrime - -fractionConvAltInt :: [SmallPrime] -> Integer -> Bool -fractionConvAltInt = - fractionConvAlt . map intFromSmallPrime - -fromSmallPrimes :: IntFraction -> PartialFraction.T Integer -fromSmallPrimes (xs,y) = - PartialFraction.fromFactoredFraction (map intFromSmallPrime xs) y - - -scaleIntInt :: Integer -> IntFraction -> Bool -scaleIntInt k a = - scaleInt k (fromSmallPrimes a) - -addInt :: IntFraction -> IntFraction -> Bool -addInt q0 q1 = - add - (fromSmallPrimes q0) - (fromSmallPrimes q1) - -subInt :: IntFraction -> IntFraction -> Bool -subInt q0 q1 = - sub - (fromSmallPrimes q0) - (fromSmallPrimes q1) - -mulInt :: IntFraction -> IntFraction -> Bool -mulInt q0 q1 = - mul - (fromSmallPrimes q0) - (fromSmallPrimes q1) - - -intTests :: HUnit.Test -intTests = - HUnit.TestLabel "integer" $ - HUnit.TestList $ - map testUnit $ - ("conversion between partial and ordinary fraction", quickCheck fractionConvInt) : - ("two conversion routines from factored fractions", quickCheck fractionConvAltInt) : - ("integer scaling", quickCheck scaleIntInt) : - ("addition", quickCheck addInt) : - ("subtraction", quickCheck subInt) : - ("multiplication", quickCheck mulInt) : - [] - - -{- * Properties for Polynomials -} - -newtype IrredPoly = IrredPoly {polyFromIrredPoly :: Poly.T Rational} - -type RatPolynomial = Poly.T Rational -type PolyFraction = ([IrredPoly],RatPolynomial) - -instance QC.Arbitrary IrredPoly where - arbitrary = - do poly <- QC.elements (map Poly.fromCoeffs [[2,3],[2,0,1],[3,0,1],[1,-3,0,1]]) - unit <- M.until (not. isZero) QC.arbitrary - return (IrredPoly (unit Vector.*> poly)) - -instance Show IrredPoly where - show = show . polyFromIrredPoly - - -fractionConvPoly :: [IrredPoly] -> RatPolynomial -> Bool -fractionConvPoly = - fractionConv . map polyFromIrredPoly - -fractionConvAltPoly :: [IrredPoly] -> RatPolynomial -> Bool -fractionConvAltPoly = - fractionConvAlt . map polyFromIrredPoly - -fromIrredPolys :: PolyFraction -> PartialFraction.T RatPolynomial -fromIrredPolys (xs,y) = - PartialFraction.fromFactoredFraction (map polyFromIrredPoly xs) y - - -scaleIntPoly :: RatPolynomial -> PolyFraction -> Bool -scaleIntPoly k a = - scaleInt k (fromIrredPolys a) - -addPoly :: PolyFraction -> PolyFraction -> Bool -addPoly q0 q1 = - add - (fromIrredPolys q0) - (fromIrredPolys q1) - -subPoly :: PolyFraction -> PolyFraction -> Bool -subPoly q0 q1 = - sub - (fromIrredPolys q0) - (fromIrredPolys q1) - -mulPoly :: PolyFraction -> PolyFraction -> Bool -mulPoly q0 q1 = - mul - (fromIrredPolys q0) - (fromIrredPolys q1) - - - -polyTests :: HUnit.Test -polyTests = - HUnit.TestLabel "polynomial" $ - HUnit.TestList $ - map testUnit $ -{- this test fails, because addition may result in leading zero coefficients, - that is, polynomial addition does not contain a normalization - if it would contain one, we would exclude computable reals -} --- wrong ("conversion between partial and ordinary fraction", quickCheck fractionConvPoly) : --- wrong ("two conversion routines from factored fractions", quickCheck fractionConvAltPoly) : --- too slow ("integer scaling", quickCheck scaleIntPoly) : --- too slow ("addition", quickCheck addPoly) : --- too slow ("subtraction", quickCheck subPoly) : --- too slow ("multiplication", quickCheck mulPoly) : - [] - - -tests :: HUnit.Test -tests = - HUnit.TestLabel "partial fraction" $ - HUnit.TestList $ - intTests : --- polyTests : - [] diff --git a/test-ghc-6.12/Test/MathObj/Polynomial.hs b/test-ghc-6.12/Test/MathObj/Polynomial.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/MathObj/Polynomial.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Test.MathObj.Polynomial where - -import qualified MathObj.Polynomial as Poly -import qualified MathObj.Polynomial.Core as PolyCore - -import qualified Algebra.IntegralDomain as Integral -import qualified Algebra.Ring as Ring - -import qualified Algebra.ZeroTestable as ZeroTestable -import qualified Algebra.Laws as Laws - -import qualified Data.List as List - -import Test.NumericPrelude.Utility (testUnit) -import Test.QuickCheck (Property, quickCheck, (==>), Testable, ) -import qualified Test.HUnit as HUnit - - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - -tensorProductTranspose :: (Ring.C a, Eq a) => [a] -> [a] -> Property -tensorProductTranspose xs ys = - not (null xs) && not (null ys) ==> - PolyCore.tensorProduct xs ys == List.transpose (PolyCore.tensorProduct ys xs) - - -mul :: (Ring.C a, Eq a, ZeroTestable.C a) => [a] -> [a] -> Bool -mul xs ys = PolyCore.equal (PolyCore.mul xs ys) (PolyCore.mulShear xs ys) - - -test :: Testable a => (Poly.T Integer -> a) -> IO () -test = quickCheck - -testRat :: Testable a => (Poly.T Rational -> a) -> IO () -testRat = quickCheck - - -tests :: HUnit.Test -tests = - HUnit.TestLabel "polynomial" $ - HUnit.TestList $ - map testUnit $ - ("tensor product", quickCheck (tensorProductTranspose :: [Integer] -> [Integer] -> Property)) : - ("mul speed", quickCheck (mul :: [Integer] -> [Integer] -> Bool)) : - ("addition, zero", test (Laws.identity (+) zero)) : - ("addition, commutative", test (Laws.commutative (+))) : - ("addition, associative", test (Laws.associative (+))) : - ("multiplication, one", test (Laws.identity (*) one)) : - ("multiplication, commutative", test (Laws.commutative (*))) : - ("multiplication, associative", test (Laws.associative (*))) : - ("multiplication and addition, distributive", test (Laws.leftDistributive (*) (+))) : - ("division", testRat (Integral.propInverse)) : - [] diff --git a/test-ghc-6.12/Test/MathObj/PowerSeries.hs b/test-ghc-6.12/Test/MathObj/PowerSeries.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/MathObj/PowerSeries.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Test.MathObj.PowerSeries where - -import qualified MathObj.PowerSeries.Core as PS -import qualified MathObj.PowerSeries.Example as PSE - -import Test.NumericPrelude.Utility (equalInfLists {- , testUnit -} ) --- import Test.QuickCheck (Property, quickCheck, (==>)) -import qualified Test.HUnit as HUnit - - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - -identitiesExplODE, identitiesSeriesFunction, identitiesInverses :: - [(String, Int, [Rational],[Rational])] - -identitiesExplODE = - ("exp", 500, PSE.expExpl, PSE.expODE) : - ("sin", 500, PSE.sinExpl, PSE.sinODE) : - ("cos", 500, PSE.cosExpl, PSE.cosODE) : - ("tan", 50, PSE.tanExpl, PSE.tanODE) : - ("tan", 50, PSE.tanExpl, PSE.tanExplSieve) : - ("tan", 50, PSE.tanODE, PSE.tanODESieve) : - ("log", 500, PSE.logExpl, PSE.logODE) : - ("asin", 50, PSE.asinODE, snd (PS.inv PSE.sinODE)) : - ("atan", 500, PSE.atanExpl, PSE.atanODE) : - ("sinh", 500, PSE.sinhExpl, PSE.sinhODE) : - ("cosh", 500, PSE.coshExpl, PSE.coshODE) : - ("atanh", 500, PSE.atanhExpl, PSE.atanhODE) : - ("sqrt", 100, PSE.sqrtExpl, PSE.sqrtODE) : - [] - -identitiesSeriesFunction = - ("exp", 500, PSE.expExpl, PS.exp (\0 -> 1) [0,1]) : - ("sin", 500, PSE.sinExpl, PS.sin (\0 -> (0,1)) [0,1]) : - ("cos", 500, PSE.cosExpl, PS.cos (\0 -> (0,1)) [0,1]) : - ("tan", 50, PSE.tanExpl, PS.tan (\0 -> (0,1)) [0,1]) : - ("sqrt", 50, PSE.sqrtExpl, PS.sqrt (\1 -> 1) [1,1]) : - ("power", 500, PSE.powExpl (-1/3), PS.pow (\1 -> 1) (-1/3) [1,1]) : - ("power", 50, PSE.powExpl (-1/3), PS.exp (\0 -> 1) (PS.scale (-1/3) PSE.log)) : - ("log", 500, PSE.logExpl, PS.log (\1 -> 0) [1,1]) : - ("asin", 50, PSE.asin, PS.asin (\1 -> 1) (\0 -> 0) [0,1]) : - -- ("acos", 50, PSE.acos, PS.acos (\1 -> 1) (\0 -> pi/2) [0,1]) : - ("atan", 500, PSE.atan, PS.atan (\0 -> 0) [0,1]) : - [] - -identitiesInverses = - ("exp", 100, 1:1:repeat 0, PS.exp (\0 -> 1) PSE.log) : - ("log", 100, 0:1:repeat 0, PS.log (\1 -> 0) PSE.exp) : - ("tan", 50, 0:1:repeat 0, PS.tan (\0 -> (0,1)) PSE.atan) : - ("atan", 50, 0:1:repeat 0, PS.atan (\0 -> 0) PSE.tan) : - ("sin", 50, 0:1:repeat 0, PS.sin (\0 -> (0,1)) PSE.asin) : - ("asin", 100, 0:1:repeat 0, PS.asin (\1 -> 1) (\0 -> 0) PSE.sin) : - ("sqrt", 500, 1:1:repeat 0, PS.sqrt (\1 -> 1) (PS.mul [1,1] [1,1])) : - [] - -testSeriesIdentity :: (String, Int, [Rational], [Rational]) -> HUnit.Test -testSeriesIdentity (label, len, x, y) = - HUnit.test (HUnit.assertBool label (equalInfLists len [x,y])) - -testSeriesIdentities :: - String -> [(String, Int, [Rational], [Rational])] -> HUnit.Test -testSeriesIdentities label ids = - HUnit.TestLabel label $ - HUnit.TestList $ map testSeriesIdentity ids - -checkSeriesIdentities :: - [(String, Int, [Rational], [Rational])] -> [(String,Bool)] -checkSeriesIdentities = - map (\(label, len, x, y) -> (label, equalInfLists len [x,y])) - - - - -powerMult :: Rational -> Rational -> Bool -powerMult exp0 exp1 = - PS.mul (PSE.pow exp0) (PSE.pow exp1) == PSE.pow (exp0+exp1) - -powerExplODE :: Rational -> Bool -powerExplODE expon = - PSE.powODE expon == PSE.powExpl expon - - -tests :: HUnit.Test -tests = - HUnit.TestLabel "power series" $ - HUnit.TestList [ - testSeriesIdentities "explicit vs. ODE solution" identitiesExplODE, - testSeriesIdentities "transcendent functions of series" identitiesSeriesFunction, - testSeriesIdentities "inverses of some series" identitiesInverses -{- - HUnit.TestLabel "laws" $ - HUnit.TestList $ - map testUnit $ - ("products of powers", quickCheck (powerMult)) : - ("power explicit vs. ODE", quickCheck (powerExplODE)) : - [] --} - ] diff --git a/test-ghc-6.12/Test/MathObj/RefinementMask2.hs b/test-ghc-6.12/Test/MathObj/RefinementMask2.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/MathObj/RefinementMask2.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Test.MathObj.RefinementMask2 where - -import qualified MathObj.RefinementMask2 as Mask -import qualified Algebra.Differential as D - -import qualified MathObj.Polynomial as Poly -import qualified MathObj.Polynomial.Core as PolyCore - -import qualified Algebra.RealField as RealField -import qualified Algebra.Ring as Ring - -import qualified Algebra.ZeroTestable as ZeroTestable - -import Data.Maybe (fromMaybe, ) - -import Test.NumericPrelude.Utility (testUnit) -import Test.QuickCheck (Property, quickCheck, (==>), Testable, ) -import qualified Test.HUnit as HUnit - - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - - -hasMultipleZero :: (Ring.C a, Eq a) => Int -> a -> Poly.T a -> Bool -hasMultipleZero n x poly = - all (zero==) $ take n $ - map (flip Poly.evaluate x) $ - iterate D.differentiate poly - -inverse0 :: (RealField.C a) => Mask.T a -> Property -inverse0 mask0 = - let (b,poly) = - case Mask.toPolynomial mask0 of - Just p -> (True, p) - Nothing -> (False, error "RefinementMask2.inverse0: no admissible mask") - mask1 = Mask.fromPolynomial poly - maskD = - Poly.fromCoeffs (Mask.coeffs mask1) - - Poly.fromCoeffs (Mask.coeffs mask0) - in b ==> - hasMultipleZero (fromMaybe 0 $ Poly.degree poly) - 1 maskD - -truncatePolynomial :: (ZeroTestable.C a) => Int -> Poly.T a -> Poly.T a -truncatePolynomial n = - Poly.fromCoeffs . PolyCore.normalize . take n . Poly.coeffs - -inverse1 :: (RealField.C a) => Poly.T a -> Bool -inverse1 poly0 = - case Mask.toPolynomial (Mask.fromPolynomial poly0) of - Just poly1 -> Poly.collinear poly0 poly1 - Nothing -> False - -refining :: (RealField.C a) => Poly.T a -> Bool -refining poly = - poly == Mask.refinePolynomial (Mask.fromPolynomial poly) poly - - - -test :: Testable a => (Poly.T Integer -> a) -> IO () -test = quickCheck - -testRat :: Testable a => (Poly.T Rational -> a) -> IO () -testRat = quickCheck - - -tests :: HUnit.Test -tests = - HUnit.TestLabel "refinement mask" $ - HUnit.TestList $ - map testUnit $ - ("inverse0", quickCheck (inverse0 :: Mask.T Rational -> Property)) : - ("inverse1", quickCheck (inverse1 . truncatePolynomial 5 :: Poly.T Rational -> Bool)) : - ("refining", quickCheck (refining . truncatePolynomial 5 :: Poly.T Rational -> Bool)) : - [] diff --git a/test-ghc-6.12/Test/Number/ComplexSquareRoot.hs b/test-ghc-6.12/Test/Number/ComplexSquareRoot.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/Number/ComplexSquareRoot.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Test.Number.ComplexSquareRoot where - -import qualified Number.ComplexSquareRoot as S -import qualified Number.Complex as Complex - --- import qualified Algebra.Ring as Ring - -import qualified Algebra.Laws as Laws - -import Test.NumericPrelude.Utility (testUnit) -import Test.QuickCheck (Testable, quickCheck, (==>), ) -import qualified Test.HUnit as HUnit - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - -simple :: - (Testable t) => - (S.T Rational -> t) -> IO () -simple = quickCheck - -tests :: HUnit.Test -tests = - HUnit.TestLabel "complex square root" $ - HUnit.TestList $ - map testUnit $ - testList - -testList :: [(String, IO ())] -testList = - ("multiplication, one", - simple $ Laws.identity S.mul S.one) : - ("multiplication, commutative", - simple $ Laws.commutative S.mul) : - ("multiplication, associative", - simple $ Laws.associative S.mul) : - ("multiplication, homomorphism", - quickCheck $ Laws.homomorphism S.fromNumber - (\x y -> (x :: Complex.T Rational) * y) S.mul) : - ("division, one", - simple $ Laws.rightIdentity S.div S.one) : - ("recip recip", - simple $ \x -> not (isZero x) ==> S.recip (S.recip x) == x) : - ("recip inverts multiplication", - simple $ \x -> not (isZero x) ==> Laws.inverse S.mul S.recip S.one x) : - [] diff --git a/test-ghc-6.12/Test/Number/GaloisField2p32m5.hs b/test-ghc-6.12/Test/Number/GaloisField2p32m5.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/Number/GaloisField2p32m5.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Test.Number.GaloisField2p32m5 where - -import qualified Number.GaloisField2p32m5 as GF - -import qualified Algebra.Laws as Laws - -import Test.NumericPrelude.Utility (testUnit) -import Test.QuickCheck (Testable, quickCheck, (==>)) -import qualified Test.HUnit as HUnit - - -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP - - -test :: Testable a => (GF.T -> a) -> IO () -test = quickCheck - - -tests :: HUnit.Test -tests = - HUnit.TestLabel "galois field 2^32-5" $ - HUnit.TestList $ - map testUnit $ - ("addition, zero", test (Laws.identity (+) zero)) : - ("addition, commutative", test (Laws.commutative (+))) : - ("addition, associative", test (Laws.associative (+))) : - ("addition, negate", test (Laws.inverse (+) negate zero)) : - ("addition, subtract", test (\x -> Laws.inverse (+) (x-) x)) : - ("multiplication, one", test (Laws.identity (*) one)) : - ("multiplication, commutative", test (Laws.commutative (*))) : - ("multiplication, associative", test (Laws.associative (*))) : - ("multiplication, recip", test (\y -> y /= 0 ==> Laws.inverse (*) recip one y)) : - ("multiplication, division", test (\y x -> y /= 0 ==> Laws.inverse (*) (x/) x y)) : - ("multiplication and addition, distributive", test (Laws.leftDistributive (*) (+))) : - [] diff --git a/test-ghc-6.12/Test/NumericPrelude/Utility.hs b/test-ghc-6.12/Test/NumericPrelude/Utility.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/NumericPrelude/Utility.hs +++ /dev/null @@ -1,21 +0,0 @@ --- cf. utility-ht Test.Utility -module Test.NumericPrelude.Utility where - -import Data.List.HT (mapAdjacent, ) -import qualified Data.List as List -import qualified Test.HUnit as HUnit - - -testUnit :: (String, IO ()) -> HUnit.Test -testUnit (label, check) = - HUnit.TestLabel label (HUnit.TestCase check) - --- compare the lists simultaneously -equalLists :: Eq a => [[a]] -> Bool -equalLists xs = - let equalElems ys = - and (mapAdjacent (==) ys) && length xs == length ys - in all equalElems (List.transpose xs) - -equalInfLists :: Eq a => Int -> [[a]] -> Bool -equalInfLists n xs = equalLists (map (take n) xs) diff --git a/test-ghc-6.12/Test/Run.hs b/test-ghc-6.12/Test/Run.hs deleted file mode 100644 --- a/test-ghc-6.12/Test/Run.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Main where - -import qualified Test.MathObj.RefinementMask2 as RefinementMask2 -import qualified Test.Algebra.RealRing as RealRing -import qualified Test.Algebra.IntegralDomain as Integral -import qualified Test.MathObj.Gaussian.Polynomial as GaussPoly -import qualified Test.MathObj.Gaussian.Variance as GaussVariance -import qualified Test.MathObj.Gaussian.Bell as GaussBell -import qualified Test.MathObj.PartialFraction as PartialFraction -import qualified Test.MathObj.Matrix as Matrix -import qualified Test.MathObj.Polynomial as Polynomial -import qualified Test.MathObj.PowerSeries as PowerSeries -import qualified Test.Number.ComplexSquareRoot as CSqRt -import qualified Test.Number.GaloisField2p32m5 as GF -import qualified Test.HUnit.Text as HUnitText -import qualified Test.HUnit as HUnit - -main :: IO () -main = - print =<< - HUnitText.runTestTT (HUnit.TestList $ - RefinementMask2.tests : - RealRing.tests : - Integral.tests : - GaussVariance.tests : - GaussBell.tests : - GaussPoly.tests : - PartialFraction.tests : - Matrix.tests : - Polynomial.tests : - PowerSeries.tests : - CSqRt.tests : - GF.tests : - []) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Main where import Number.Complex((+:), (-:), ) diff --git a/test/Test/Algebra/Additive.hs b/test/Test/Algebra/Additive.hs new file mode 100644 --- /dev/null +++ b/test/Test/Algebra/Additive.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Test.Algebra.Additive where + +import qualified Algebra.Additive as A + +import Test.NumericPrelude.Utility (testUnit, ) +import Test.QuickCheck (Testable, quickCheck, ) +import qualified Test.HUnit as HUnit + +import NumericPrelude.Base as P +import NumericPrelude.Numeric as NP + + +test :: + (Testable t) => + ([Integer] -> t) -> IO () +test = quickCheck + + +tests :: HUnit.Test +tests = + HUnit.TestLabel "additive group" $ + HUnit.TestList $ + map testUnit $ + testList + +testList :: [(String, IO ())] +testList = + ("sum1", test $ \ns n -> + A.sum (n:ns) == A.sum1 (n:ns)) : + ("sumNestedAssociative", test $ \ns -> + A.sum ns == A.sumNestedAssociative ns) : + ("sumNestedCommutative", test $ \ns -> + A.sum ns == A.sumNestedCommutative ns) : + [] diff --git a/test/Test/Algebra/IntegralDomain.hs b/test/Test/Algebra/IntegralDomain.hs --- a/test/Test/Algebra/IntegralDomain.hs +++ b/test/Test/Algebra/IntegralDomain.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Test.Algebra.IntegralDomain where import Algebra.IntegralDomain (roundDown, roundUp, divUp, ) diff --git a/test/Test/Algebra/RealRing.hs b/test/Test/Algebra/RealRing.hs --- a/test/Test/Algebra/RealRing.hs +++ b/test/Test/Algebra/RealRing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Test.Algebra.RealRing where import qualified Algebra.RealRing as RealRing diff --git a/test/Test/MathObj/Gaussian/Bell.hs b/test/Test/MathObj/Gaussian/Bell.hs --- a/test/Test/MathObj/Gaussian/Bell.hs +++ b/test/Test/MathObj/Gaussian/Bell.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Test.MathObj.Gaussian.Bell where import qualified MathObj.Gaussian.Bell as G --- import qualified Algebra.Ring as Ring - import qualified Algebra.Laws as Laws import qualified Number.Complex as Complex @@ -24,8 +22,7 @@ simple :: (Testable t) => (G.T Rational -> t) -> IO () -simple f = - quickCheck (\x -> f (x :: G.T Rational)) +simple = quickCheck tests :: HUnit.Test tests = @@ -40,6 +37,14 @@ simple $ Laws.commutative G.convolve) : ("convolution, associative", simple $ Laws.associative G.convolve) : + ("convolution by constant function", + {- + using a G.norm1 we could exactly compute the amplitude + of the resulting constant function. + -} + simple $ \x -> + case G.convolve x (G.constant) of + G.Cons _amp _a b c -> isZero b && isZero c) : ("multiplication, one", simple $ Laws.identity G.multiply G.constant) : ("multiplication, commutative", @@ -58,6 +63,8 @@ simple $ \x y -> G.convolve x y == G.convolveByFourier x y) : + ("fourier by translation", + simple $ \x -> G.fourier x == G.fourierByTranslation x) : ("fourier reverse", simple $ \x -> nest 2 G.fourier x == G.reverse x) : ("reverse identity", diff --git a/test/Test/MathObj/Gaussian/Polynomial.hs b/test/Test/MathObj/Gaussian/Polynomial.hs --- a/test/Test/MathObj/Gaussian/Polynomial.hs +++ b/test/Test/MathObj/Gaussian/Polynomial.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Test.MathObj.Gaussian.Polynomial where @@ -156,3 +156,10 @@ G.approximateByBellsAtOnce unit d s (p::Poly.T (Complex.T Rational)) == G.approximateByBellsByTranslation unit d s p) : [] + +{- +inequalities: + +Heisenberg's uncertainty relation + needs integrals and thus needs product of exponential numbers and roots +-} diff --git a/test/Test/MathObj/Gaussian/Variance.hs b/test/Test/MathObj/Gaussian/Variance.hs --- a/test/Test/MathObj/Gaussian/Variance.hs +++ b/test/Test/MathObj/Gaussian/Variance.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Test.MathObj.Gaussian.Variance where @@ -97,6 +97,23 @@ guardSwap (<=) (c1,d1)) in YoungConjugates (d2%a2) (d2%b2) (d2%c2)) arbitrary arbitrary arbitrary + +{- +This is simpler, but may yield exponents smaller than 1. + +instance Arbitrary YoungConjugates where + arbitrary = liftM3 + (\(PositiveInteger a0) (PositiveInteger b0) (PositiveInteger c0) -> + let {- + If a+b<=c, then from b>0 it follows aa. + Swapping a and c is enough and we have not to consider more cases. + -} + (a1,c1) = if a0+b0<=c0 then (c0,a0) else (a0,c0) + b1 = b0 + d1 = a1+b1-c1 + in YoungConjugates (d1%a1) (d1%b1) (d1%c1)) + arbitrary arbitrary arbitrary +-} simple :: diff --git a/test/Test/MathObj/Matrix.hs b/test/Test/MathObj/Matrix.hs --- a/test/Test/MathObj/Matrix.hs +++ b/test/Test/MathObj/Matrix.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Test.MathObj.Matrix where diff --git a/test/Test/MathObj/PartialFraction.hs b/test/Test/MathObj/PartialFraction.hs --- a/test/Test/MathObj/PartialFraction.hs +++ b/test/Test/MathObj/PartialFraction.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Test.MathObj.PartialFraction where diff --git a/test/Test/MathObj/Polynomial.hs b/test/Test/MathObj/Polynomial.hs --- a/test/Test/MathObj/Polynomial.hs +++ b/test/Test/MathObj/Polynomial.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Test.MathObj.Polynomial where import qualified MathObj.Polynomial as Poly diff --git a/test/Test/MathObj/PowerSeries.hs b/test/Test/MathObj/PowerSeries.hs --- a/test/Test/MathObj/PowerSeries.hs +++ b/test/Test/MathObj/PowerSeries.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Test.MathObj.PowerSeries where diff --git a/test/Test/MathObj/RefinementMask2.hs b/test/Test/MathObj/RefinementMask2.hs --- a/test/Test/MathObj/RefinementMask2.hs +++ b/test/Test/MathObj/RefinementMask2.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Test.MathObj.RefinementMask2 where import qualified MathObj.RefinementMask2 as Mask @@ -30,7 +30,7 @@ map (flip Poly.evaluate x) $ iterate D.differentiate poly -inverse0 :: (RealField.C a) => Mask.T a -> Property +inverse0 :: (RealField.C a, ZeroTestable.C a) => Mask.T a -> Property inverse0 mask0 = let (b,poly) = case Mask.toPolynomial mask0 of @@ -54,7 +54,7 @@ Just poly1 -> Poly.collinear poly0 poly1 Nothing -> False -refining :: (RealField.C a) => Poly.T a -> Bool +refining :: (RealField.C a, ZeroTestable.C a) => Poly.T a -> Bool refining poly = poly == Mask.refinePolynomial (Mask.fromPolynomial poly) poly diff --git a/test/Test/Number/ComplexSquareRoot.hs b/test/Test/Number/ComplexSquareRoot.hs --- a/test/Test/Number/ComplexSquareRoot.hs +++ b/test/Test/Number/ComplexSquareRoot.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Test.Number.ComplexSquareRoot where diff --git a/test/Test/Number/GaloisField2p32m5.hs b/test/Test/Number/GaloisField2p32m5.hs --- a/test/Test/Number/GaloisField2p32m5.hs +++ b/test/Test/Number/GaloisField2p32m5.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} module Test.Number.GaloisField2p32m5 where import qualified Number.GaloisField2p32m5 as GF diff --git a/test/Test/Run.hs b/test/Test/Run.hs --- a/test/Test/Run.hs +++ b/test/Test/Run.hs @@ -3,6 +3,7 @@ import qualified Test.MathObj.RefinementMask2 as RefinementMask2 import qualified Test.Algebra.RealRing as RealRing import qualified Test.Algebra.IntegralDomain as Integral +import qualified Test.Algebra.Additive as Additive import qualified Test.MathObj.Gaussian.Polynomial as GaussPoly import qualified Test.MathObj.Gaussian.Variance as GaussVariance import qualified Test.MathObj.Gaussian.Bell as GaussBell @@ -22,6 +23,7 @@ RefinementMask2.tests : RealRing.tests : Integral.tests : + Additive.tests : GaussVariance.tests : GaussBell.tests : GaussPoly.tests :