diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -17,5 +17,16 @@ ghci-compile: $(HCI7) -Wall -i:src:test +RTS -M256m -c30 -RTS -fobject-code -O -hidir=dist/build -odir=dist/build test/Demo.hs + +run-test: update-test + runhaskell Setup configure --user -fbuildExamples --enable-tests + runhaskell Setup build + runhaskell Setup haddock + ./dist/build/numeric-prelude-test/numeric-prelude-test + +update-test: + doctest-extract-0.1 -i src/ -i gaussian/ -i playground/ -o test/ --executable-main=Test/Run.hs $$(cat test-module.list) + + %.html: %.md pandoc $< --output=$@ diff --git a/gaussian/MathObj/Gaussian/Bell.hs b/gaussian/MathObj/Gaussian/Bell.hs --- a/gaussian/MathObj/Gaussian/Bell.hs +++ b/gaussian/MathObj/Gaussian/Bell.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- Complex translated and modulated Gaussian bell curve. @@ -23,11 +23,33 @@ import Test.QuickCheck (Arbitrary, arbitrary, ) import Control.Monad (liftM4, ) --- import Prelude (($)) import NumericPrelude.Numeric import NumericPrelude.Base hiding (reverse, ) +{- $setup +>>> import qualified MathObj.Gaussian.Bell as G +>>> import qualified Algebra.ZeroTestable as ZeroTestable +>>> import qualified Algebra.Laws as Laws +>>> import qualified Number.Complex as Complex +>>> import Number.Complex ((+:)) +>>> import NumericPrelude.Base as P +>>> import NumericPrelude.Numeric as NP +>>> import Prelude () +>>> import qualified Test.QuickCheck as QC +>>> import Data.Function.HT (Id, nest) +>>> +>>> asRational :: Id (G.T Rational) +>>> asRational = id +>>> +>>> withRational :: Id (G.T Rational -> a) +>>> withRational = id +>>> +>>> isConstant :: ZeroTestable.C a => G.T a -> Bool +>>> isConstant (G.Cons _amp _a b c) = isZero b && isZero c +-} + + data T a = Cons {amp :: a, c0, c1 :: Complex.T a, c2 :: a} deriving (Eq, Show) @@ -82,6 +104,11 @@ variance f = recip $ c2 f * 2*pi +{- | +prop> Laws.identity G.multiply G.constant . asRational +prop> Laws.commutative G.multiply . asRational +prop> Laws.associative G.multiply . asRational +-} multiply :: (Ring.C a) => T a -> T a -> T a multiply f g = @@ -118,8 +145,24 @@ (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) +{- | +>>> let x=G.Cons 2 (1+:3) (4+:5) (7::Rational); y=G.Cons 7 (1+:4) (3+:2) (5::Rational) in G.convolve x y +Cons {amp = 7 % 6, c0 = 13 % 6 +: 55 % 8, c1 = 41 % 12 +: 13 % 4, c2 = 35 % 12} + +prop> Laws.commutative G.convolve . asRational +prop> Laws.associative G.convolve . asRational + +Would be nice to have something like: + +> Laws.identity G.convolve G.dirac + +but we cannot represent @G.dirac@. + +prop> isConstant . G.convolve G.constant . asRational + +Using a @G.norm1@ we could exactly compute the amplitude +of the resulting constant function. +But that would require transcendent operations. -} convolve :: (Field.C a) => T a -> T a -> T a @@ -153,6 +196,9 @@ (recip $ recip (c2 f) + recip (c2 g)) -} +{- | +prop> withRational $ \x y -> G.convolve x y == G.convolveByTranslation x y +-} convolveByTranslation :: (Field.C a) => T a -> T a -> T a convolveByTranslation f0 g0 = @@ -167,11 +213,21 @@ (c0 f1 + c0 g1) zero (c2 f1 * c2 g1 / s) +{- | +prop> withRational $ \x y -> G.convolve x y == G.convolveByFourier x y +-} convolveByFourier :: (Field.C a) => T a -> T a -> T a convolveByFourier f g = reverse $ fourier $ multiply (fourier f) (fourier g) +{- | +prop> withRational $ \x y -> G.fourier (G.convolve x y) == G.multiply (G.fourier x) (G.fourier y) +prop> withRational $ \x -> nest 2 G.fourier x == G.reverse x +prop> G.fourier G.unit == (asRational G.unit) +prop> withRational $ \x a -> G.fourier (G.translate a x) == G.modulate a (G.fourier x) +prop> withRational $ \x (QC.Positive a) -> G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x)) +-} fourier :: (Field.C a) => T a -> T a fourier f = @@ -184,6 +240,9 @@ (Complex.scale rc $ Complex.quarterRight b) rc +{- | +prop> withRational $ \x -> G.fourier x == G.fourierByTranslation x +-} fourierByTranslation :: (Field.C a) => T a -> T a fourierByTranslation f = @@ -249,6 +308,9 @@ Cons 0 (i*b) 1 -} +{- | +prop> withRational $ \x a b -> G.translate a (G.translate b x) == G.translate (a+b) x +-} translate :: Ring.C a => a -> T a -> T a translate d f = let a = c0 f @@ -260,6 +322,10 @@ (Complex.fromReal (-2*c*d) + b) c +{- | +prop> withRational $ \x a b -> G.translateComplex a (G.translateComplex b x) == G.translateComplex (a+b) x +prop> withRational $ \x a -> G.translateComplex (Complex.fromReal a) x == G.translate a x +-} translateComplex :: Ring.C a => Complex.T a -> T a -> T a translateComplex d f = let a = c0 f @@ -271,6 +337,10 @@ (Complex.scale (-2*c) d + b) c +{- | +prop> withRational $ \x a b -> G.modulate a (G.modulate b x) == G.modulate (a+b) x +prop> withRational $ \x a b -> G.modulate b (G.translate a x) == G.turn (a*b) (G.translate a (G.modulate b x)) +-} modulate :: Ring.C a => a -> T a -> T a modulate d f = Cons @@ -287,11 +357,18 @@ (c1 f) (c2 f) +{- | +prop> withRational $ \x -> nest 2 G.reverse x == x +-} reverse :: Additive.C a => T a -> T a reverse f = f{c1 = negate $ c1 f} +{- | +prop> withRational $ \x (QC.Positive a) (QC.Positive b) -> G.dilate a (G.dilate b x) == G.dilate (a*b) x +prop> withRational $ \x (QC.Positive a) -> G.shrink a x == G.dilate (recip a) x +-} dilate :: Field.C a => a -> T a -> T a dilate k f = Cons @@ -300,6 +377,10 @@ (Complex.scale (recip k) $ c1 f) (c2 f / k^2) +{- | +prop> withRational $ \x (QC.Positive a) -> G.dilate a (G.shrink a x) == x +prop> withRational $ \x (QC.Positive a) -> G.shrink a (G.dilate a x) == x +-} shrink :: Ring.C a => a -> T a -> T a shrink k f = Cons @@ -315,10 +396,3 @@ (c0 f) (c1 f) (c2 f) - - -{- laws -fourier (convolve f g) = fourier f * fourier g - -fourier (fourier f) = reverse f --} diff --git a/gaussian/MathObj/Gaussian/Example.hs b/gaussian/MathObj/Gaussian/Example.hs --- a/gaussian/MathObj/Gaussian/Example.hs +++ b/gaussian/MathObj/Gaussian/Example.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- Reciprocal of variance of a Gaussian bell curve. We describe the curve only in terms of its variance @@ -24,9 +24,7 @@ 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 qualified Number.Root as Root @@ -46,9 +44,6 @@ import Control.Applicative (liftA2, ) --- import System.Exit (ExitCode, ) - --- import Prelude (($)) import NumericPrelude.Numeric import NumericPrelude.Base import qualified Prelude as P diff --git a/gaussian/MathObj/Gaussian/ExponentTuple.hs b/gaussian/MathObj/Gaussian/ExponentTuple.hs new file mode 100644 --- /dev/null +++ b/gaussian/MathObj/Gaussian/ExponentTuple.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE RebindableSyntax #-} +module MathObj.Gaussian.ExponentTuple where + +import qualified Test.QuickCheck as QC + +import Control.Applicative (liftA2, liftA3) + +import Data.Function.HT (compose2) + +import NumericPrelude.Base as P +import NumericPrelude.Numeric as NP + + +{- $setup +>>> import MathObj.Gaussian.ExponentTuple (HoelderConjugates(HoelderConjugates)) +>>> import MathObj.Gaussian.ExponentTuple (YoungConjugates(YoungConjugates)) +>>> import NumericPrelude.Base as P +>>> import NumericPrelude.Numeric as NP +>>> import Prelude () +-} + + +{- | +For @(HoelderConjugates p q)@ it holds + +prop> \(HoelderConjugates p q) -> p>=1 && q>=1 && 1/p + 1/q == 1 +-} +data HoelderConjugates = HoelderConjugates Rational Rational + deriving Show + +instance QC.Arbitrary HoelderConjugates where + arbitrary = genHoelderConjugates0 + +genHoelderConjugates0 :: QC.Gen HoelderConjugates +genHoelderConjugates0 = + liftA2 + (\(QC.Positive p) (QC.Positive q) -> + let s = p + q in HoelderConjugates (s % p) (s % q)) + QC.arbitrary QC.arbitrary + +genHoelderConjugates1 :: QC.Gen HoelderConjugates +genHoelderConjugates1 = + liftA2 + (\(QC.Positive p) (QC.Positive q) -> + let s = 1%p + 1%q + in HoelderConjugates (fromInteger p * s) (fromInteger q * s)) + QC.arbitrary QC.arbitrary + + +{- | +For @(YoungConjugates p q r)@ it holds + +prop> \(YoungConjugates p q r) -> p>=1 && q>=1 && r>=1 && 1/p + 1/q == 1/r + 1 +-} +data YoungConjugates = YoungConjugates Rational Rational Rational + deriving Show + +instance QC.Arbitrary YoungConjugates where + arbitrary = genYoungConjugates0 + +{- +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 +-} +genYoungConjugates0 :: QC.Gen YoungConjugates +genYoungConjugates0 = + liftA3 + (\(QC.Positive a0) (QC.Positive b0) (QC.Positive 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)) + QC.arbitrary QC.arbitrary QC.arbitrary + +{- | +This one is simpler, but may yield exponents smaller than 1. +-} +genYoungConjugates1 :: QC.Gen YoungConjugates +genYoungConjugates1 = + liftA3 + (\(QC.Positive a0) (QC.Positive b0) (QC.Positive 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)) + QC.arbitrary QC.arbitrary QC.arbitrary diff --git a/gaussian/MathObj/Gaussian/Polynomial.hs b/gaussian/MathObj/Gaussian/Polynomial.hs --- a/gaussian/MathObj/Gaussian/Polynomial.hs +++ b/gaussian/MathObj/Gaussian/Polynomial.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- Complex Gaussian bell multiplied with a polynomial. @@ -55,9 +55,39 @@ import NumericPrelude.Numeric import NumericPrelude.Base hiding (reverse, ) --- import Prelude () +{- $setup +>>> :set -XRebindableSyntax +>>> +>>> import qualified MathObj.Gaussian.Polynomial as G +>>> import qualified MathObj.Gaussian.Bell as Bell +>>> import qualified MathObj.Polynomial as Poly +>>> import qualified Algebra.Laws as Laws +>>> import qualified Number.Complex as Complex +>>> import Number.Complex ((+:)) +>>> import NumericPrelude.Base as P +>>> import NumericPrelude.Numeric as NP +>>> import qualified Test.QuickCheck as QC +>>> import Data.Function.HT (Id, nest) +>>> import Data.Tuple.HT (mapSnd) +>>> +>>> asRational :: Id (G.T Rational) +>>> asRational = id +>>> +>>> withRational :: Id (G.T Rational -> a) +>>> withRational = id +>>> +>>> mulLinear2i :: Id (G.T Rational) +>>> mulLinear2i x = +>>> x{G.polynomial = Poly.fromCoeffs [0, 0+:2] * G.polynomial x} +>>> +>>> rotateQuarter :: Int -> Id (G.T Rational) +>>> rotateQuarter n = +>>> G.scaleComplex (negate Complex.imaginaryUnit ^ fromIntegral n) +-} + + data T a = Cons {bell :: Bell.T a, polynomial :: Poly.T (Complex.T a)} deriving (Show) @@ -149,33 +179,50 @@ unit :: (Ring.C a) => T a unit = eigenfunction0 +{- | +This one does not hold for larger degrees, although it would be nice: + +prop> QC.forAll (QC.choose (0,3)) $ \n -> G.eigenfunctionDifferential n == asRational (G.eigenfunctionIterative n) + +Unfortunately, both implementations compute different eigenbases. +-} eigenfunction :: (Field.C a) => Int -> T a eigenfunction = eigenfunctionDifferential +-- | prop> G.eigenfunction0 == asRational (G.eigenfunctionDifferential 0) eigenfunction0 :: (Ring.C a) => T a eigenfunction0 = Cons Bell.unit (Poly.fromCoeffs [one]) +-- | prop> G.eigenfunction1 == asRational (G.eigenfunctionDifferential 1) eigenfunction1 :: (Ring.C a) => T a eigenfunction1 = Cons Bell.unit (Poly.fromCoeffs [zero, one]) +-- | prop> G.eigenfunction2 == asRational (G.eigenfunctionDifferential 2) eigenfunction2 :: (Field.C a) => T a eigenfunction2 = Cons Bell.unit (Poly.fromCoeffs [-(1/4), zero, one]) +-- | prop> G.eigenfunction3 == asRational (G.eigenfunctionDifferential 3) eigenfunction3 :: (Field.C a) => T a eigenfunction3 = Cons Bell.unit (Poly.fromCoeffs [zero, -(3/4), zero, one]) +{- | +prop> QC.forAll (QC.choose (0,15)) $ \n -> let x = G.eigenfunctionDifferential n in G.fourier x == rotateQuarter n x +-} 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 +{- | +prop> QC.forAll (QC.choose (0,15)) $ \n -> let x = G.eigenfunctionIterative n in G.fourier x == rotateQuarter n x +-} eigenfunctionIterative :: (Field.C a, Absolute.C a, ZeroTestable.C a, Eq a) => Int -> T a eigenfunctionIterative n = @@ -195,6 +242,11 @@ in y{polynomial = fmap (0.5*) (px + fmap (c*) py)}) +{- | +prop> withRational $ Laws.identity G.multiply G.constant +prop> withRational $ Laws.commutative G.multiply +prop> withRational $ Laws.associative G.multiply +-} multiply :: (Ring.C a) => T a -> T a -> T a multiply f g = @@ -202,6 +254,10 @@ (Bell.multiply (bell f) (bell g)) (polynomial f * polynomial g) +{- | +prop> withRational $ Laws.commutative G.convolve +prop> withRational $ Laws.associative G.convolve +-} convolve, {- convolveByDifferentiation, -} convolveByFourier :: (Field.C a) => T a -> T a -> T a convolve = convolveByFourier @@ -241,6 +297,13 @@ by decomposing the polynomial into four polynomials, one for each of the four eigenvalues 1, i, -1, -i. -} +{- | +prop> withRational $ \x y -> G.fourier (G.convolve x y) == G.multiply (G.fourier x) (G.fourier y) +prop> withRational $ \x -> nest 2 G.fourier x == G.reverse x +prop> withRational $ \x a -> G.fourier (G.translate a x) == G.modulate a (G.fourier x) +prop> withRational $ \x (QC.Positive a) -> G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x)) +prop> withRational $ \x -> G.fourier (G.differentiate x) == mulLinear2i (G.fourier x) +-} fourier :: (Field.C a) => T a -> T a fourier f = @@ -256,6 +319,8 @@ {- | Differentiate and divide by @sqrt pi@ in order to stay in a ring. This way, we do not need to fiddle with pi factors. + +prop> withRational $ \x y -> G.convolve (G.differentiate x) y == G.convolve x (G.differentiate y) -} differentiate :: (Ring.C a) => T a -> T a differentiate f = @@ -265,8 +330,6 @@ * 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 @@ -278,6 +341,13 @@ However must start with the highest term of 'poly f', and thus we need to perform the division on reversed polynomials. -} +{- | +>>> snd $ G.integrate $ G.differentiate $ G.Cons Bell.unit (Poly.fromCoeffs [7,7,7,7 :: Complex.T Rational]) +Cons {bell = Cons {amp = 1 % 1, c0 = 0 % 1 +: 0 % 1, c1 = 0 % 1 +: 0 % 1, c2 = 1 % 1}, polynomial = Polynomial.fromCoeffs [7 % 1 +: 0 % 1,7 % 1 +: 0 % 1,7 % 1 +: 0 % 1,7 % 1 +: 0 % 1]} + +prop> withRational $ \x -> G.integrate (G.differentiate x) == (zero, x) +prop> withRational $ \x@(G.Cons b p) -> let (xoff,xint) = G.integrate x in G.differentiate xint == G.Cons b (p + Poly.const xoff) +-} integrate :: (Field.C a, ZeroTestable.C a) => T a -> (Complex.T a, T a) @@ -335,16 +405,27 @@ -} +{- | +prop> withRational $ \x a b -> G.translate a (G.translate b x) == G.translate (a+b) x +-} translate :: Ring.C a => a -> T a -> T a translate d = translateComplex (Complex.fromReal d) +{- | +prop> withRational $ \x a b -> G.translateComplex a (G.translateComplex b x) == G.translateComplex (a+b) x +prop> withRational $ \x a -> G.translateComplex (Complex.fromReal a) x == G.translate a x +-} 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) +{- | +prop> withRational $ \x a b -> G.modulate a (G.modulate b x) == G.modulate (a+b) x +prop> withRational $ \x a b -> G.modulate b (G.translate a x) == G.turn (a*b) (G.translate a (G.modulate b x)) +-} modulate :: Ring.C a => a -> T a -> T a modulate d f = Cons @@ -357,18 +438,29 @@ (Bell.turn d $ bell f) (polynomial f) +{- | +prop> withRational $ \x -> nest 2 G.reverse x == x +-} reverse :: Additive.C a => T a -> T a reverse f = Cons (Bell.reverse $ bell f) (Poly.reverse $ polynomial f) +{- | +prop> withRational $ \x (QC.Positive a) (QC.Positive b) -> G.dilate a (G.dilate b x) == G.dilate (a*b) x +prop> withRational $ \x (QC.Positive a) -> G.shrink a x == G.dilate (recip a) x +-} 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) +{- | +prop> withRational $ \x (QC.Positive a) -> G.dilate a (G.shrink a x) == x +prop> withRational $ \x (QC.Positive a) -> G.shrink a (G.dilate a x) == x +-} shrink :: Ring.C a => a -> T a -> T a shrink k f = Cons @@ -394,6 +486,10 @@ 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. + +prop> withRational $ \x (QC.NonZero unit) d -> G.approximateByBells unit (G.translateComplex d x) == map (mapSnd (Bell.translateComplex d)) (G.approximateByBells unit x) +prop> withRational $ \x (QC.NonZero unit) (QC.NonZero d) -> G.approximateByBells unit (G.dilate d x) == map (mapSnd (Bell.dilate d)) (G.approximateByBells (unit/d) x) +prop> withRational $ \x (QC.NonZero unit) (QC.NonZero d) -> G.approximateByBells unit (G.shrink d x) == map (mapSnd (Bell.shrink d)) (G.approximateByBells (unit*d) x) -} approximateByBells :: Field.C a => @@ -412,6 +508,9 @@ (\d -> Bell.translate d b) (laurentAbscissas (unit_/2) amps) +{- | +prop> \(QC.NonZero unit) d s p0 -> let p = Poly.fromCoeffs $ take 10 p0 in G.approximateByBellsAtOnce unit d s p == G.approximateByBellsByTranslation unit d (s::Rational) p +-} approximateByBellsAtOnce :: Field.C a => a -> Complex.T a -> a -> Poly.T (Complex.T a) -> LPoly.T (Complex.T a) @@ -477,4 +576,9 @@ {- laws differentiate (f*g) = (differentiate f) * g + f * (differentiate g) + +inequalities: + +Heisenberg's uncertainty relation + needs integrals and thus needs product of exponential numbers and roots -} diff --git a/gaussian/MathObj/Gaussian/Variance.hs b/gaussian/MathObj/Gaussian/Variance.hs --- a/gaussian/MathObj/Gaussian/Variance.hs +++ b/gaussian/MathObj/Gaussian/Variance.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- We represent a Gaussian bell curve in terms of the reciprocal of its variance and its value at the origin. @@ -24,19 +24,33 @@ 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 +{- $setup +>>> import qualified MathObj.Gaussian.Variance as G +>>> import MathObj.Gaussian.ExponentTuple (HoelderConjugates(HoelderConjugates)) +>>> import MathObj.Gaussian.ExponentTuple (YoungConjugates(YoungConjugates)) +>>> import qualified Algebra.Laws as Laws +>>> import qualified Number.Root as Root +>>> import NumericPrelude.Base as P +>>> import NumericPrelude.Numeric as NP +>>> import Prelude () +>>> import qualified Test.QuickCheck as QC +>>> import Data.Function.HT (Id, nest) +>>> +>>> asRational :: Id (G.T Rational) +>>> asRational = id +>>> +>>> withRational :: Id (G.T Rational -> a) +>>> withRational = id +-} + + {- | Since @amp@ is the square of the actual amplitude it must be non-negative. -} @@ -75,14 +89,30 @@ integrateRoot f = Root.sqrt $ Root.fromNumber $ amp f / c f +{- | +Cauchy-Schwarz inequality: + +prop> withRational $ \x y -> G.scalarProductRoot x y <= G.norm2Root x `Root.mul` G.norm2Root y + +Hoelder inequality: + +prop> withRational $ \x y -> G.scalarProductRoot x y <= G.norm1Root x `Root.mul` G.normInfRoot y +prop> withRational $ \x y (HoelderConjugates p q) -> G.scalarProductRoot x y <= G.normPRoot p x `Root.mul` G.normPRoot q y +-} scalarProductRoot :: (Field.C a) => T a -> T a -> Root.T a scalarProductRoot f g = integrateRoot (multiply f g) +{- | +prop> withRational $ \x -> G.norm1Root x == G.normPRoot 1 x +-} norm1Root :: (Field.C a) => T a -> Root.T a norm1Root = integrateRoot +{- | +prop> withRational $ \x -> G.norm2Root x == G.normPRoot 2 x +-} norm2Root :: (Field.C a) => T a -> Root.T a norm2Root f = Root.sqrt $ @@ -94,6 +124,34 @@ normInfRoot f = Root.sqrt $ Root.fromNumber $ amp f +{- +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. + +prop> :{ withRational $ \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. + +prop> :{ withRational $ \x p0 -> + let p = 1 + abs p0 + in G.normPRoot p x <= G.normInfRoot x +:} +-} normPRoot :: (Field.C a) => Rational -> T a -> Root.T a normPRoot p f = Root.sqrt (Root.fromNumber (amp f)) @@ -124,6 +182,18 @@ variance f = recip $ c f * 2*pi +{- | +prop> withRational $ \x (QC.Positive a) -> G.varianceRational (G.dilate a x) == a^2 * G.varianceRational x +prop> withRational $ \x y -> G.varianceRational (G.convolve x y) == G.varianceRational x + G.varianceRational y +-} +varianceRational :: (Field.C a) => T a -> a +varianceRational f = recip $ c f + +{- | +prop> Laws.identity G.multiply G.constant . asRational +prop> Laws.commutative G.multiply . asRational +prop> Laws.associative G.multiply . asRational +-} multiply :: (Ring.C a) => T a -> T a -> T a multiply f g = @@ -154,6 +224,15 @@ > integrate $ \s -> x s * y(t-s) Convergence only for @c f + c g > 0@. + +prop> Laws.commutative G.convolve . asRational +prop> Laws.associative G.convolve . asRational + +Young inequality: + +prop> withRational $ \x y -> G.normInfRoot (G.convolve x y) <= G.norm1Root x `Root.mul` G.normInfRoot y +prop> withRational $ \x y (HoelderConjugates p q) -> G.normInfRoot (G.convolve x y) <= G.normPRoot p x `Root.mul` G.normPRoot q y +prop> withRational $ \x y (YoungConjugates p q r) -> G.normPRoot r (G.convolve x y) <= G.normPRoot p x `Root.mul` G.normPRoot q y -} convolve :: (Field.C a) => T a -> T a -> T a @@ -168,6 +247,11 @@ > integrate $ \t -> x t * cis (-2*pi*t*f) Convergence only for @c f > 0@. + +prop> withRational $ \x y -> G.fourier (G.convolve x y) == G.multiply (G.fourier x) (G.fourier y) +prop> withRational $ \x -> nest 4 G.fourier x == x +prop> withRational $ \x (QC.Positive a) -> G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x)) +prop> withRational $ \x y -> G.scalarProductRoot x y == G.scalarProductRoot (G.fourier x) (G.fourier y) -} fourier :: (Field.C a) => T a -> T a @@ -177,10 +261,18 @@ fourier (t -> exp(-(a*t)^2)) -} +{- | +prop> withRational $ \x (QC.Positive a) (QC.Positive b) -> G.dilate a (G.dilate b x) == G.dilate (a*b) x +prop> withRational $ \x (QC.Positive a) -> G.shrink a x == G.dilate (recip a) x +-} dilate :: (Field.C a) => a -> T a -> T a dilate k f = Cons (amp f) $ c f / k^2 +{- | +prop> withRational $ \x (QC.Positive a) -> G.dilate a (G.shrink a x) == x +prop> withRational $ \x (QC.Positive a) -> G.shrink a (G.dilate a x) == x +-} shrink :: (Ring.C a) => a -> T a -> T a shrink k f = Cons (amp f) $ c f * k^2 @@ -191,16 +283,3 @@ 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/numeric-prelude.cabal b/numeric-prelude.cabal --- a/numeric-prelude.cabal +++ b/numeric-prelude.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: numeric-prelude -Version: 0.4.3.2 +Version: 0.4.3.3 License: BSD-3-Clause License-File: LICENSE Author: Dylan Thurston , Henning Thielemann , Mikael Johansson @@ -9,7 +9,7 @@ Category: Math Stability: Experimental Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.3 -Tested-With: GHC==8.4.1 +Tested-With: GHC==8.4.4, GHC==8.6.5, GHC==9.0.1 Build-Type: Simple Synopsis: An experimental alternative hierarchy of numeric type classes Description: @@ -30,22 +30,22 @@ default: False Source-Repository this - Tag: 0.4.3.2 + Tag: 0.4.3.3 Type: darcs - Location: http://hub.darcs.net/thielema/numeric-prelude/ + Location: https://hub.darcs.net/thielema/numeric-prelude/ Source-Repository head Type: darcs - Location: http://hub.darcs.net/thielema/numeric-prelude/ + Location: https://hub.darcs.net/thielema/numeric-prelude/ Library Build-Depends: parsec >=1 && <4, - QuickCheck >=1 && <3, + QuickCheck >=2.10 && <3, storable-record >=0.0.1 && <0.1, non-negative >=0.0.5 && <0.2, semigroups >=0.1 && <1.0, - utility-ht >=0.0.6 && <0.1, + utility-ht >=0.0.13 && <0.1, deepseq >=1.1 && <1.5 Build-Depends: @@ -54,10 +54,6 @@ random >=1.0 && <1.3, base >=4.5 && <5 - If impl(ghc>=7.0) - CPP-Options: -DNoImplicitPrelude=RebindableSyntax - Default-Extensions: CPP - Default-Language: Haskell98 GHC-Options: -Wall Hs-source-dirs: src @@ -176,47 +172,50 @@ Else Buildable: False - If impl(ghc>=7.0) - CPP-Options: -DNoImplicitPrelude=RebindableSyntax - Default-Extensions: CPP - Test-Suite numeric-prelude-test Type: exitcode-stdio-1.0 - Hs-Source-Dirs: test, gaussian GHC-Options: -Wall Default-Language: Haskell98 + Hs-Source-Dirs: test Other-modules: Test.NumericPrelude.Utility Test.Number.GaloisField2p32m5 Test.Number.ComplexSquareRoot Test.Algebra.IntegralDomain + Test.Algebra.PrincipalIdealDomain Test.Algebra.RealRing Test.Algebra.Additive Test.MathObj.RefinementMask2 Test.MathObj.PartialFraction Test.MathObj.Matrix Test.MathObj.Polynomial + Test.MathObj.Polynomial.Core Test.MathObj.PowerSeries + Test.MathObj.PowerSeries.Core + Test.MathObj.PowerSeries.Example + Test.MathObj.Gaussian.ExponentTuple Test.MathObj.Gaussian.Variance Test.MathObj.Gaussian.Bell Test.MathObj.Gaussian.Polynomial + Hs-Source-Dirs: playground + Other-modules: Number.ComplexSquareRoot + Hs-Source-Dirs: gaussian + Other-Modules: + MathObj.Gaussian.Bell + MathObj.Gaussian.Polynomial + MathObj.Gaussian.Variance + MathObj.Gaussian.ExponentTuple Main-Is: Test/Run.hs - If flag(buildExamples) - Build-Depends: - HUnit >=1 && <2, - numeric-prelude, - QuickCheck, - utility-ht, - random, - base - Else - Buildable: False - - If impl(ghc>=7.0) - CPP-Options: -DNoImplicitPrelude=RebindableSyntax - Default-Extensions: CPP + Build-Depends: + doctest-exitcode-stdio >=0.0 && <0.1, + doctest-lib >=0.1 && <0.1.1, + numeric-prelude, + QuickCheck, + utility-ht, + random, + base Executable numeric-prelude-gaussian Hs-Source-Dirs: gaussian @@ -238,7 +237,3 @@ base Else Buildable: False - - If impl(ghc>=7.0) - CPP-Options: -DNoImplicitPrelude=RebindableSyntax - Default-Extensions: CPP diff --git a/playground/Number/ComplexSquareRoot.hs b/playground/Number/ComplexSquareRoot.hs new file mode 100644 --- /dev/null +++ b/playground/Number/ComplexSquareRoot.hs @@ -0,0 +1,137 @@ +module Number.ComplexSquareRoot where + +import qualified Algebra.RealField as RealField +import qualified Algebra.RealRing as RealRing +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 Test.QuickCheck (Arbitrary, arbitrary, ) + +import Control.Monad (liftM2, ) + +import qualified NumericPrelude.Numeric as NP +import NumericPrelude.Numeric hiding (recip, ) +import NumericPrelude.Base +import Prelude () + + +{- $setup +>>> import qualified Number.ComplexSquareRoot as SR +>>> import qualified Number.Complex as Complex +>>> import qualified Algebra.Laws as Laws +>>> import Test.QuickCheck ((==>)) +>>> import NumericPrelude.Numeric +>>> import NumericPrelude.Base +>>> import Prelude () +>>> +>>> sr :: SR.T Rational -> SR.T Rational +>>> sr = id +-} + +{- | +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. + +prop> Laws.identity SR.mul SR.one . sr +prop> Laws.commutative SR.mul . sr +prop> Laws.associative SR.mul . sr +prop> Laws.homomorphism SR.fromNumber (\x y -> x * (y :: Complex.T Rational)) SR.mul +prop> Laws.rightIdentity SR.div SR.one . sr +prop> \x -> not (isZero x) ==> SR.recip (SR.recip x) == sr x +prop> \x -> not (isZero x) ==> Laws.inverse SR.mul SR.recip SR.one (sr x) +-} +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/Algebra/Absolute.hs b/src/Algebra/Absolute.hs --- a/src/Algebra/Absolute.hs +++ b/src/Algebra/Absolute.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.Absolute ( C(abs, signum), absOrd, signumOrd, @@ -7,7 +7,7 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import Algebra.Ring (one, ) -- fromInteger +import Algebra.Ring (one, ) import Algebra.Additive (zero, negate,) import Data.Int (Int, Int8, Int16, Int32, Int64, ) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.Additive ( -- * Class C, @@ -39,6 +39,12 @@ import NumericPrelude.Base +{- $setup +>>> import qualified Algebra.Additive as A +>>> import qualified Test.QuickCheck as QC +-} + + infixl 6 +, - {- | @@ -98,6 +104,8 @@ This avoids including a zero which is useful for types where no universal zero is available. ToDo: Should have NonEmpty type. + +prop> \(QC.NonEmpty ns) -> A.sum ns == (A.sum1 ns :: Integer) -} sum1 :: (C a) => [a] -> a sum1 = foldl1 (+) @@ -109,19 +117,23 @@ Does this have a measurably effect on speed? Requires associativity. + +prop> \ns -> A.sum ns == (A.sumNestedAssociative ns :: Integer) -} 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. + +prop> \ns -> A.sum ns == (A.sumNestedCommutative ns :: Integer) -} sumNestedCommutative :: (C a) => [a] -> a sumNestedCommutative [] = zero diff --git a/src/Algebra/Algebraic.hs b/src/Algebra/Algebraic.hs --- a/src/Algebra/Algebraic.hs +++ b/src/Algebra/Algebraic.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} 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 diff --git a/src/Algebra/Differential.hs b/src/Algebra/Differential.hs --- a/src/Algebra/Differential.hs +++ b/src/Algebra/Differential.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.Differential where import qualified Algebra.Ring as Ring --- import NumericPrelude.Numeric --- import qualified Prelude {- | 'differentiate' is a general differentation operation 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.Field ( {- * Class -} C, diff --git a/src/Algebra/FloatingPoint.hs b/src/Algebra/FloatingPoint.hs --- a/src/Algebra/FloatingPoint.hs +++ b/src/Algebra/FloatingPoint.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.FloatingPoint where import qualified Algebra.RealRing as RealRing 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.IntegralDomain ( {- * Class -} C, @@ -32,7 +32,6 @@ ) where import qualified Algebra.Ring as Ring --- import qualified Algebra.Additive as Additive import qualified Algebra.ZeroTestable as ZeroTestable import Algebra.Ring ((*), fromInteger, ) @@ -52,7 +51,15 @@ import qualified Prelude as P +{- $setup +>>> import Algebra.IntegralDomain (roundDown, roundUp, divUp) +>>> import qualified Test.QuickCheck as QC +>>> import NumericPrelude.Base as P +>>> import NumericPrelude.Numeric as NP +>>> import Prelude () +-} + infixl 7 `div`, `mod` @@ -97,6 +104,9 @@ class (Ring.C a) => C a where {-# MINIMAL divMod | (div, mod) #-} div, mod :: a -> a -> a + {- | + prop> \n (QC.NonZero m) -> let (q,r) = divMod n m in n == (q*m+r :: Integer) + -} divMod :: a -> a -> (a,a) {-# INLINE div #-} @@ -184,6 +194,8 @@ that is at most @n@. The parameter order is consistent with @div@ and friends, but maybe not useful for partial application. + +prop> \n (QC.NonZero m) -> div n m * m == (roundDown n m :: Integer) -} roundDown :: C a => a -> a -> a roundDown n m = n - mod n m @@ -192,6 +204,10 @@ @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@. + +prop> \n (QC.NonZero m) -> divUp n m * m == (roundUp n m :: Integer) +prop> \n (QC.Positive m) -> let x = roundDown n m in n-m < x && x <= (n :: Integer) +prop> \n (QC.NonZero m) -> - roundDown n m == (roundUp (-n) m :: Integer) -} roundUp :: C a => a -> a -> a roundUp n m = n + mod (-n) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | @@ -15,14 +15,12 @@ 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: diff --git a/src/Algebra/NonNegative.hs b/src/Algebra/NonNegative.hs --- a/src/Algebra/NonNegative.hs +++ b/src/Algebra/NonNegative.hs @@ -25,11 +25,9 @@ ) 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, ) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.PrincipalIdealDomain ( {- * Class -} C, @@ -39,8 +39,6 @@ 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 @@ -63,7 +61,19 @@ import Test.QuickCheck ((==>), Property) +{- $setup +>>> import qualified Algebra.PrincipalIdealDomain as PID +>>> import Test.NumericPrelude.Utility ((/\)) +>>> import qualified Test.QuickCheck as QC +>>> +>>> genResidueClass :: QC.Gen (Integer,Integer) +>>> genResidueClass = do +>>> m <- fmap QC.getNonZero $ QC.arbitrary +>>> a <- QC.choose (min 0 $ 1+m, max 0 $ m-1) +>>> return (m,a) +-} + {- | A principal ideal domain is a ring in which every ideal (the set of multiples of some generating set of elements) @@ -235,9 +245,9 @@ {- | Not efficient because it requires duplicate computations of GCDs. -However GCDs of neighbouring list elements were not computed before. +However GCDs of adjacent list elements were not computed before. It is also quite arbitrary, -because only neighbouring elements are used for balancing. +because only adjacent elements are used for balancing. There are certainly more sophisticated solutions. -} diophantineMultiMin :: C a => a -> [a] -> Maybe [a] @@ -279,10 +289,21 @@ -} {- | -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@ +For @Just (n,b) = chineseRemainderMulti [(m0,a0), (m1,a1), ..., (mk,ak)]@ +and all @x@ with @x = b mod n@, the congruences +@x=a0 mod m0, x=a1 mod m1, ..., x=ak mod mk@ are fulfilled. +Also, @n@ is the least common multiplier of all @mi@. + +>>> PID.chineseRemainderMulti [(100,21), (10000,2021::Integer)] +Just (10000,2021) +>>> PID.chineseRemainderMulti [(97,90),(99,10),(100,0::Integer)] +Just (960300,100000) +>>> PID.chineseRemainderMulti [(95,30),(97,27),(98,8),(99,1::Integer)] +Just (89403930,1000000) + +prop> QC.listOf genResidueClass /\ \xs -> case PID.chineseRemainderMulti xs of Nothing -> True; Just (n,b) -> abs n == abs (foldl lcm 1 (map fst xs)) && map snd xs == map (mod b . fst) xs +prop> \(QC.NonEmpty ms) b -> let xs = map (\(QC.NonZero m) -> (m, mod b m)) ms in case PID.chineseRemainderMulti xs of Nothing -> False; Just (n,c) -> abs n == abs (foldl lcm 1 (map QC.getNonZero ms)) && mod b n == (c::Integer) -} chineseRemainderMulti :: C a => [(a,a)] -> Maybe (a,a) chineseRemainderMulti congs = 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.RealField ( C, ) where @@ -10,8 +10,6 @@ import qualified Number.Ratio as Ratio --- import NumericPrelude.Base --- import qualified Prelude as P import Prelude (Float, Double, ) {- | 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Generally before using 'quot' and 'rem', think twice. In most cases 'divMod' and friends are the right choice, @@ -19,8 +19,6 @@ import qualified Algebra.ZeroTestable as ZeroTestable 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, ) diff --git a/src/Algebra/RealRing.hs b/src/Algebra/RealRing.hs --- a/src/Algebra/RealRing.hs +++ b/src/Algebra/RealRing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.RealRing where import qualified Algebra.RealRing98 as RealRing98 @@ -35,6 +35,20 @@ import NumericPrelude.Base +{- $setup +>>> import qualified Algebra.RealRing as RealRing +>>> import Data.Tuple.HT (mapFst) +>>> import NumericPrelude.Numeric as NP +>>> import NumericPrelude.Base +>>> import Prelude () +>>> +>>> infix 4 =~= +>>> +>>> (=~=) :: (Eq b) => (a -> b) -> (a -> b) -> a -> Bool +>>> (f =~= g) x = f x == g x +-} + + {- | Minimal complete definition: 'splitFraction' or 'floor' @@ -116,8 +130,23 @@ class (Absolute.C a, Ord a) => C a where {-# MINIMAL splitFraction | floor #-} + {- | + prop> \x -> (x::Rational) == (uncurry (+) $ mapFst fromInteger $ splitFraction x) + prop> \x -> uncurry (==) $ mapFst (((x::Double)-) . fromInteger) $ splitFraction x + prop> \x -> uncurry (==) $ mapFst (((x::Rational)-) . fromInteger) $ splitFraction x + prop> \x -> splitFraction x == (floor (x::Double) :: Integer, fraction x) + prop> \x -> splitFraction x == (floor (x::Rational) :: Integer, fraction x) + -} splitFraction :: (Ring.C b) => a -> (b,a) - fraction :: a -> a + {- | + prop> \x -> let y = fraction (x::Double) in 0<=y && y<1 + prop> \x -> let y = fraction (x::Rational) in 0<=y && y<1 + -} + fraction :: a -> a + {- | + prop> \x -> ceiling (-x) == negate (floor (x::Double) :: Integer) + prop> \x -> ceiling (-x) == negate (floor (x::Rational) :: Integer) + -} ceiling, floor :: (Ring.C b) => a -> b truncate :: (Ring.C b) => a -> b round :: (ToInteger.C b) => a -> b @@ -157,6 +186,7 @@ but is simply a kind of rounding that is the fastest on IEEE floating point architectures. -} +{-# NOINLINE [2] roundSimple #-} roundSimple :: (C a, Ring.C b) => a -> b roundSimple x = let (n,r) = splitFraction x @@ -530,6 +560,9 @@ If operations like multiplication with two and comparison need time proportional to the number of binary digits, then the overall rounding requires quadratic time. + +prop> RealRing.genericFloor =~= (NP.floor :: Double -> Integer) +prop> RealRing.genericFloor =~= (NP.floor :: Rational -> Integer) -} genericFloor :: (Ord a, Ring.C a, Ring.C b) => a -> b genericFloor a = @@ -537,30 +570,50 @@ then genericPosFloor a else negate $ genericPosCeiling $ negate a +{- | +prop> RealRing.genericCeiling =~= (NP.ceiling :: Double -> Integer) +prop> RealRing.genericCeiling =~= (NP.ceiling :: Rational -> Integer) +-} genericCeiling :: (Ord a, Ring.C a, Ring.C b) => a -> b genericCeiling a = if a>=zero then genericPosCeiling a else negate $ genericPosFloor $ negate a +{- | +prop> RealRing.genericTruncate =~= (NP.truncate :: Double -> Integer) +prop> RealRing.genericTruncate =~= (NP.truncate :: Rational -> Integer) +-} genericTruncate :: (Ord a, Ring.C a, Ring.C b) => a -> b genericTruncate a = if a>=zero then genericPosFloor a else negate $ genericPosFloor $ negate a +{- | +prop> RealRing.genericRound =~= (NP.round :: Double -> Integer) +prop> RealRing.genericRound =~= (NP.round :: Rational -> Integer) +-} genericRound :: (Ord a, Ring.C a, Ring.C b) => a -> b genericRound a = if a>=zero then genericPosRound a else negate $ genericPosRound $ negate a +{- | +prop> RealRing.genericFraction =~= (NP.fraction :: Double -> Double) +prop> RealRing.genericFraction =~= (NP.fraction :: Rational -> Rational) +-} genericFraction :: (Ord a, Ring.C a) => a -> a genericFraction a = if a>=zero then genericPosFraction a else fixFraction $ negate $ genericPosFraction $ negate a +{- | +prop> RealRing.genericSplitFraction =~= (NP.splitFraction :: Double -> (Integer,Double)) +prop> RealRing.genericSplitFraction =~= (NP.splitFraction :: Rational -> (Integer,Rational)) +-} genericSplitFraction :: (Ord a, Ring.C a, Ring.C b) => a -> (b,a) genericSplitFraction a = if a>=zero 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Algebra.RightModule where @@ -6,8 +6,6 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive --- import NumericPrelude.Numeric --- import qualified Prelude -- Is this right? 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.Ring ( {- * Class -} C, @@ -41,7 +41,6 @@ import qualified Data.Complex as Complex98 import qualified Data.Ratio as Ratio98 import qualified Prelude as P --- import Test.QuickCheck infixl 7 * diff --git a/src/Algebra/ToInteger.hs b/src/Algebra/ToInteger.hs --- a/src/Algebra/ToInteger.hs +++ b/src/Algebra/ToInteger.hs @@ -49,6 +49,7 @@ toInteger :: a -> Integer +{-# NOINLINE [2] fromIntegral #-} fromIntegral :: (C a, Ring.C b) => a -> b fromIntegral = fromInteger . toInteger diff --git a/src/Algebra/ToRational.hs b/src/Algebra/ToRational.hs --- a/src/Algebra/ToRational.hs +++ b/src/Algebra/ToRational.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.ToRational where import qualified Algebra.ZeroTestable as ZeroTestable @@ -68,6 +68,7 @@ such as converting 'Float' to 'Double'. This achieved by optimizer rules. -} +{-# NOINLINE [2] realToField #-} realToField :: (C a, Field.C b) => a -> b realToField = Field.fromRational' . toRational diff --git a/src/Algebra/Transcendental.hs b/src/Algebra/Transcendental.hs --- a/src/Algebra/Transcendental.hs +++ b/src/Algebra/Transcendental.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} 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 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.Units ( {- * Class -} C, @@ -22,7 +22,6 @@ 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 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Copyright : (c) Henning Thielemann 2004-2005 @@ -18,7 +18,6 @@ import Algebra.Additive ((+)) import Data.List (zipWith, foldl) --- import Data.Functor (Functor, fmap) import Prelude((.), (==), Bool, Functor, fmap) import qualified Prelude as P 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Algebra.VectorSpace where @@ -10,7 +10,6 @@ import qualified Data.Complex as Complex98 --- import NumericPrelude.Numeric import qualified Prelude as P 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Algebra.ZeroTestable where import qualified Algebra.Additive as Additive @@ -6,7 +6,6 @@ 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 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -41,7 +41,6 @@ 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? 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | @@ -26,7 +26,6 @@ import qualified Number.Complex as Complex --- 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | @@ -68,6 +68,41 @@ import NumericPrelude.Base hiding (zipWith, ) +{- $setup +>>> import qualified MathObj.Matrix as Matrix +>>> import qualified Algebra.Ring as Ring +>>> import qualified Algebra.Laws as Laws +>>> import Test.NumericPrelude.Utility ((/\)) +>>> import qualified Test.QuickCheck as QC +>>> import NumericPrelude.Numeric as NP +>>> import NumericPrelude.Base as P +>>> import Prelude () +>>> +>>> import Control.Monad (replicateM, join) +>>> import Control.Applicative (liftA2) +>>> import Data.Function.HT (nest) +>>> +>>> genDimension :: QC.Gen Int +>>> genDimension = QC.choose (0,20) +>>> +>>> genMatrixFor :: (QC.Arbitrary a) => Int -> Int -> QC.Gen (Matrix.T a) +>>> genMatrixFor m n = +>>> fmap (Matrix.fromList m n) $ replicateM (m*n) QC.arbitrary +>>> +>>> genMatrix :: (QC.Arbitrary a) => QC.Gen (Matrix.T a) +>>> genMatrix = join $ liftA2 genMatrixFor genDimension genDimension +>>> +>>> genIntMatrix :: QC.Gen (Matrix.T Integer) +>>> genIntMatrix = genMatrix +>>> +>>> genFactorMatrix :: (QC.Arbitrary a) => Matrix.T a -> QC.Gen (Matrix.T a) +>>> genFactorMatrix a = genMatrixFor (Matrix.numColumns a) =<< genDimension +>>> +>>> genSameMatrix :: (QC.Arbitrary a) => Matrix.T a -> QC.Gen (Matrix.T a) +>>> genSameMatrix = uncurry genMatrixFor . Matrix.dimension +-} + + {- | A matrix is a twodimensional array, indexed by integers. -} @@ -79,6 +114,10 @@ {- | Transposition of matrices is just transposition in the sense of Data.List. + +prop> genIntMatrix /\ \a -> Matrix.rows a == Matrix.columns (Matrix.transpose a) +prop> genIntMatrix /\ \a -> Matrix.columns a == Matrix.rows (Matrix.transpose a) +prop> genIntMatrix /\ \a -> genSameMatrix a /\ \b -> Laws.homomorphism Matrix.transpose (+) (+) a b -} transpose :: T a -> T a transpose (Cons m) = @@ -98,6 +137,9 @@ index :: T a -> Dimension -> Dimension -> a index (Cons m) i j = m ! (i,j) +{- | +prop> genIntMatrix /\ \a -> a == uncurry Matrix.fromRows (Matrix.dimension a) (Matrix.rows a) +-} fromRows :: Dimension -> Dimension -> [[a]] -> T a fromRows m n = Cons . @@ -106,6 +148,9 @@ List.zipWith (\r -> map (\(c,x) -> ((r,c),x))) allIndices . map (zip allIndices) +{- | +prop> genIntMatrix /\ \a -> a == uncurry Matrix.fromColumns (Matrix.dimension a) (Matrix.columns a) +-} fromColumns :: Dimension -> Dimension -> [[a]] -> T a fromColumns m n = Cons . @@ -146,6 +191,10 @@ -- These implementations may benefit from a better exception than -- just assertions to validate dimensionalities +{- | +prop> genIntMatrix /\ \a -> genSameMatrix a /\ \b -> Laws.commutative (+) a b +prop> genIntMatrix /\ \a -> genSameMatrix a /\ \b -> genSameMatrix b /\ \c -> Laws.associative (+) a b c +-} instance (Additive.C a) => Additive.C (T a) where (+) = zipWith (+) (-) = zipWith (-) @@ -159,6 +208,9 @@ in assert (d == dimension nM) $ uncurry fromList d (List.zipWith op em en) +{- | +prop> genIntMatrix /\ \a -> Laws.identity (+) (uncurry Matrix.zero $ Matrix.dimension a) a +-} zero :: (Additive.C a) => Dimension -> Dimension -> T a zero m n = fromList m n $ @@ -172,6 +224,9 @@ (indexBounds n n) (map (\i -> ((i,i), Ring.one)) (indexRange n)) +{- | +prop> genDimension /\ \n -> Matrix.one n == Matrix.diagonal (replicate n Ring.one :: [Integer]) +-} diagonal :: (Additive.C a) => [a] -> T a diagonal xs = let n = List.length xs @@ -183,6 +238,15 @@ scale :: (Ring.C a) => a -> T a -> T a scale s = Vector.functorScale s +{- | +prop> genIntMatrix /\ \a -> Laws.leftIdentity (*) (Matrix.one (Matrix.numRows a)) a +prop> genIntMatrix /\ \a -> Laws.rightIdentity (*) (Matrix.one (Matrix.numColumns a)) a +prop> genIntMatrix /\ \a -> genFactorMatrix a /\ \b -> Laws.homomorphism Matrix.transpose (*) (flip (*)) a b +prop> genIntMatrix /\ \a -> genFactorMatrix a /\ \b -> genFactorMatrix b /\ \c -> Laws.associative (*) a b c +prop> genIntMatrix /\ \b -> genSameMatrix b /\ \c -> genFactorMatrix b /\ \a -> Laws.leftDistributive (*) (+) a b c +prop> genIntMatrix /\ \a -> genFactorMatrix a /\ \b -> genSameMatrix b /\ \c -> Laws.rightDistributive (*) (+) a b c +prop> QC.choose (0,10) /\ \k -> genDimension /\ \n -> genMatrixFor n n /\ \a -> a^k == nest (fromInteger k) ((a::Matrix.T Integer)*) (Matrix.one n) +-} instance (Ring.C a) => Ring.C (T a) where mM * nM = assert (numColumns mM == numRows nM) $ 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Copyright : (c) Henning Thielemann 2007 Maintainer : numericprelude@henning-thielemann.de @@ -29,21 +29,89 @@ import Algebra.Additive((+), zero, negate) import Algebra.ZeroTestable (isZero) +import qualified Data.List.Reverse.StrictSpine as Rev +import qualified Data.List.Match as Match 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 Data.Map (Map) +import Data.List (group, sortBy, mapAccumR) +import Data.Maybe (fromMaybe) import NumericPrelude.Base hiding (zipWith) import NumericPrelude.Numeric(Int, fromInteger) +{- $setup +>>> import qualified MathObj.PartialFraction as PartialFraction +>>> import qualified MathObj.Polynomial.Core as PolyCore +>>> import qualified MathObj.Polynomial as Poly +>>> import qualified Algebra.PrincipalIdealDomain as PID +>>> import qualified Algebra.Indexable as Indexable +>>> import qualified Algebra.Laws as Laws +>>> import qualified Number.Ratio as Ratio +>>> import Test.NumericPrelude.Utility ((/\)) +>>> import qualified Test.QuickCheck as QC +>>> import NumericPrelude.Numeric as NP +>>> import NumericPrelude.Base as P +>>> import Prelude () +>>> +>>> import Control.Applicative (liftA2) +>>> +>>> {- | +>>> Generator of 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. +>>> -} -- +>>> genSmallPrime :: QC.Gen Integer +>>> genSmallPrime = +>>> let primes = [2,3,5,7,11,13] +>>> in QC.elements (primes ++ map negate primes) +>>> +>>> genPartialFractionInt :: QC.Gen (PartialFraction.T Integer) +>>> genPartialFractionInt = +>>> liftA2 PartialFraction.fromFactoredFraction +>>> (QC.listOf genSmallPrime) QC.arbitrary +>>> +>>> +>>> genIrreduciblePolynomial :: QC.Gen (Poly.T Rational) +>>> genIrreduciblePolynomial = do +>>> QC.NonZero unit <- QC.arbitrary +>>> fmap (Poly.fromCoeffs . map (unit*)) $ +>>> QC.elements [[2,3],[2,0,1],[3,0,1],[1,-3,0,1]] +>>> +>>> genPartialFractionPoly :: QC.Gen (PartialFraction.T (Poly.T Rational)) +>>> genPartialFractionPoly = +>>> liftA2 PartialFraction.fromFactoredFraction +>>> (fmap (take 3) $ QC.listOf genIrreduciblePolynomial) +>>> (fmap (Poly.fromCoeffs . PolyCore.normalize . take 5) QC.arbitrary) +>>> +>>> +>>> 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, sub, mul :: +>>> (PID.C a, Indexable.C a) => +>>> PartialFraction.T a -> PartialFraction.T a -> Bool +>>> add = Laws.homomorphism PartialFraction.toFraction (+) (+) +>>> sub = Laws.homomorphism PartialFraction.toFraction (-) (-) +>>> mul = Laws.homomorphism PartialFraction.toFraction (*) (*) +-} + {- | @Cons z (indexMapFromList [(x0,[y00,y01]), (x1,[y10]), (x2,[y20,y21,y22])])@ represents the partial fraction @@ -123,6 +191,9 @@ There are more direct methods for special cases like polynomials over rational numbers where the denominators are linear factors. + +prop> QC.listOf genSmallPrime /\ fractionConv +prop> fmap (take 3) (QC.listOf genIrreduciblePolynomial) /\ fractionConv -} fromFactoredFraction :: (PID.C a, Indexable.C a) => [a] -> a -> T a fromFactoredFraction denoms0 numer0 = @@ -145,6 +216,10 @@ -- Is reduceHeads also necessary for polynomial partial fractions? in removeZeros $ reduceHeads $ Cons intPart (indexMapFromList pairs) +{- | +prop> QC.listOf genSmallPrime /\ fractionConvAlt +prop> fmap (take 3) (QC.listOf genIrreduciblePolynomial) /\ fractionConvAlt +-} fromFactoredFractionAlt :: (PID.C a, Indexable.C a) => [a] -> a -> T a fromFactoredFractionAlt denoms numer = foldl (\p d -> scaleFrac (one%d) p) (fromValue numer) denoms @@ -205,9 +280,7 @@ -} 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 + Cons z $ Map.filter (not . null) $ Map.map (Rev.dropWhile isZero) m {- @@ -220,7 +293,16 @@ 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 +{- | +prop> genPartialFractionInt /\ \x -> genPartialFractionInt /\ \y -> add x y +prop> genPartialFractionInt /\ \x -> genPartialFractionInt /\ \y -> sub x y + +prop> genPartialFractionPoly /\ \x -> genPartialFractionPoly /\ \y -> add x y +prop> genPartialFractionPoly /\ \x -> genPartialFractionPoly /\ \y -> sub x y +-} +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. @@ -343,6 +425,10 @@ (uncurry (:) . carryRipple ds . map (ns*)) scaleFracs m) +{- | +prop> genPartialFractionInt /\ \x k -> scaleInt k x +prop> genPartialFractionPoly /\ \x k -> scaleInt k x +-} scaleInt :: (PID.C a, Indexable.C a) => a -> T a -> T a scaleInt x (Cons z m) = removeZeros $ normalizeModulo $ @@ -359,6 +445,10 @@ scaleFrac (one%d) (scaleInt numer a + acc)) zero l) (indexMapToList m)) +{- | +prop> genPartialFractionInt /\ \x -> genPartialFractionInt /\ \y -> mul x y +prop> genPartialFractionPoly /\ \x -> genPartialFractionPoly /\ \y -> mul x y +-} mulFast :: (PID.C a, Indexable.C a) => T a -> T a -> T a mulFast pa pb = let ra = toFactoredFraction pa 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Copyright : (c) Henning Thielemann 2006 Maintainer : numericprelude@henning-thielemann.de @@ -16,8 +16,6 @@ import Data.Array(Ix) --- import NumericPrelude.Numeric (Integer) --- import NumericPrelude.Base {- | 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Copyright : (c) Henning Thielemann 2006 Maintainer : numericprelude@henning-thielemann.de @@ -12,19 +12,12 @@ 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 Algebra.Monoid((<*>)) -import Data.Array((!), Ix) import qualified Data.Array as Array +import Data.Array((!), Ix) --- import NumericPrelude.Numeric (Integer) import NumericPrelude.Base hiding (cycle) {- | 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Copyright : (c) Henning Thielemann 2006 Maintainer : numericprelude@henning-thielemann.de @@ -23,7 +23,6 @@ import Data.Tuple.HT (swap, ) import Data.Maybe.HT (toMaybe, ) --- import NumericPrelude.Numeric (Integer) import NumericPrelude.Base hiding (cycle) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -81,7 +81,36 @@ import qualified Prelude as P98 +{- $setup +>>> import qualified MathObj.Polynomial as Poly +>>> import qualified Algebra.IntegralDomain as Integral +>>> import qualified Algebra.Laws as Laws +>>> import NumericPrelude.Numeric +>>> import NumericPrelude.Base +>>> import Prelude () +>>> +>>> intPoly :: Poly.T Integer -> Poly.T Integer +>>> intPoly = id +>>> +>>> ratioPoly :: Poly.T Rational -> Poly.T Rational +>>> ratioPoly = id +-} + +{- | +prop> Laws.identity (+) zero . intPoly +prop> Laws.commutative (+) . intPoly +prop> Laws.associative (+) . intPoly +prop> Laws.identity (*) one . intPoly +prop> Laws.commutative (*) . intPoly +prop> Laws.associative (*) . intPoly +prop> Laws.leftDistributive (*) (+) . intPoly +prop> Integral.propInverse . ratioPoly +-} newtype T a = Cons {coeffs :: [a]} + +{- +>>> import Test.QuickCheck ((==>)) +-} {-# INLINE fromCoeffs #-} 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | This module implements polynomial functions on plain lists. We use such functions in order to implement methods of other datatypes. @@ -31,11 +31,11 @@ import qualified Algebra.Additive as Additive import qualified Algebra.ZeroTestable as ZeroTestable +import qualified Data.List.Reverse.StrictSpine as Rev 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 Data.List.HT (switchL, shear, shearTranspose, outerProduct) import qualified NumericPrelude.Base as P import qualified NumericPrelude.Numeric as NP @@ -44,6 +44,25 @@ import NumericPrelude.Numeric hiding (divMod, negate, stdUnit, ) +{- $setup +>>> import qualified MathObj.Polynomial.Core as PolyCore +>>> import qualified MathObj.Polynomial as Poly +>>> import qualified Data.List as List +>>> import qualified Test.QuickCheck as QC +>>> import Test.QuickCheck ((==>)) +>>> import Data.Tuple.HT (mapPair, mapSnd) +>>> import NumericPrelude.Numeric +>>> import NumericPrelude.Base +>>> import Prelude () +>>> +>>> intPoly :: [Integer] -> [Integer] +>>> intPoly = id +>>> +>>> ratioPoly :: [Rational] -> [Rational] +>>> ratioPoly = id +-} + + {- | Horner's scheme for evaluating a polynomial in a ring. -} @@ -69,7 +88,7 @@ -} {-# INLINE normalize #-} normalize :: (ZeroTestable.C a) => [a] -> [a] -normalize = dropWhileRev isZero +normalize = Rev.dropWhile isZero {- | Multiply by the variable, used internally. @@ -113,6 +132,9 @@ all (==zero) xs && all (==zero) ys +{- | +prop> \(QC.NonEmpty xs) (QC.NonEmpty ys) -> PolyCore.tensorProduct xs ys == List.transpose (PolyCore.tensorProduct ys (intPoly xs)) +-} {-# INLINE tensorProduct #-} tensorProduct :: Ring.C a => [a] -> [a] -> [[a]] tensorProduct = outerProduct (*) @@ -135,6 +157,9 @@ -- this one fails on infinite lists -- mul xs = foldr (\y zs -> add (scale y xs) (shift zs)) [] +{- | +prop> \xs ys -> PolyCore.equal (intPoly $ PolyCore.mul xs ys) (PolyCore.mulShear xs ys) +-} {-# INLINE mulShear #-} mulShear :: Ring.C a => [a] -> [a] -> [a] mulShear xs ys = map sum (shear (tensorProduct xs ys)) @@ -144,6 +169,11 @@ mulShearTranspose xs ys = map sum (shearTranspose (tensorProduct xs ys)) +{- | +prop> \x y -> case (PolyCore.normalize x, PolyCore.normalize y) of (nx, ny) -> not (null (ratioPoly ny)) ==> mapSnd PolyCore.normalize (PolyCore.divMod nx ny) == mapPair (PolyCore.normalize, PolyCore.normalize) (PolyCore.divMod x y) +prop> \x y -> not (isZero (ratioPoly y)) ==> let z = fst $ PolyCore.divMod (Poly.coeffs x) y in PolyCore.normalize z == z +prop> \x y -> case PolyCore.normalize $ ratioPoly y of ny -> not (null ny) ==> List.length (snd $ PolyCore.divMod x y) < List.length ny +-} divMod :: (ZeroTestable.C a, Field.C a) => [a] -> [a] -> ([a], [a]) divMod x y = mapPair (List.reverse, List.reverse) $ 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -27,6 +27,17 @@ import NumericPrelude.Numeric +{- $setup +>>> import qualified MathObj.PowerSeries.Core as PS +>>> import qualified MathObj.PowerSeries as PST +>>> import qualified Test.QuickCheck as QC +>>> import Test.NumericPrelude.Utility (equalTrunc, (/\)) +>>> import NumericPrelude.Numeric as NP +>>> import NumericPrelude.Base as P +>>> import Prelude () +-} + + newtype T a = Cons {coeffs :: [a]} deriving (Ord) {-# INLINE fromCoeffs #-} @@ -126,6 +137,9 @@ (-) = lift2 Poly.sub zero = lift0 [] +{- | +prop> QC.choose (1,10) /\ \expon (QC.Positive x) xs -> let xt = x:xs in equalTrunc 15 (PS.pow (const x) (1 % expon) (PST.coeffs (PST.fromCoeffs xt ^ expon)) ++ repeat zero) (xt ++ repeat zero) +-} instance (Ring.C a) => Ring.C (T a) where one = const one fromInteger n = const (fromInteger n) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module MathObj.PowerSeries.Core where import qualified MathObj.Polynomial.Core as Poly @@ -20,6 +20,32 @@ sin, cos, tan, asin, acos, atan) +{- $setup +>>> import qualified MathObj.PowerSeries.Core as PS +>>> import qualified MathObj.PowerSeries.Example as PSE +>>> import Test.NumericPrelude.Utility (equalTrunc, (/\)) +>>> import qualified Test.QuickCheck as QC +>>> import NumericPrelude.Numeric as NP +>>> import NumericPrelude.Base as P +>>> import Prelude () +>>> import Control.Applicative (liftA3) +>>> +>>> checkHoles :: +>>> Int -> ([Rational] -> [Rational]) -> +>>> Rational -> [Rational] -> QC.Property +>>> checkHoles trunc f x xs = +>>> QC.choose (1,10) /\ \expon -> +>>> equalTrunc trunc +>>> (f (PS.insertHoles expon (x:xs)) ++ repeat zero) +>>> (PS.insertHoles expon (f (x:xs)) ++ repeat zero) +>>> +>>> genInvertible :: QC.Gen [Rational] +>>> genInvertible = +>>> liftA3 (\x0 x1 xs -> x0:x1:xs) +>>> QC.arbitrary (fmap QC.getNonZero QC.arbitrary) QC.arbitrary +-} + + {-# INLINE evaluate #-} evaluate :: Ring.C a => [a] -> a -> a evaluate = flip Poly.horner @@ -78,6 +104,8 @@ {- | For power series of @f x@, compute the power series of @f(x^n)@. + +prop> QC.choose (1,10) /\ \m -> QC.choose (1,10) /\ \n xs -> equalTrunc 100 (PS.insertHoles m $ PS.insertHoles n xs) (PS.insertHoles (m*n) xs) -} insertHoles :: Additive.C a => Int -> [a] -> [a] insertHoles n = @@ -158,6 +186,10 @@ 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. + +prop> equalTrunc 50 PSE.sqrtExpl (PS.sqrt (\1 -> 1) [1,1]) +prop> equalTrunc 500 (1:1:repeat 0) (PS.sqrt (\1 -> 1) (PS.mul [1,1] [1,1])) +prop> checkHoles 50 (PS.sqrt (\1 -> 1)) 1 -} sqrt :: Field.C a => (a -> a) -> [a] -> [a] sqrt _ [] = [] @@ -181,6 +213,11 @@ {- | Input series must start with a non-zero term, even better with a positive one. + +prop> equalTrunc 100 (PSE.powExpl (-1/3)) (PS.pow (\1 -> 1) (-1/3) [1,1]) +prop> equalTrunc 50 (PSE.powExpl (-1/3)) (PS.exp (\0 -> 1) (PS.scale (-1/3) PSE.log)) +prop> checkHoles 30 (PS.pow (\1 -> 1) (1/3)) 1 +prop> checkHoles 30 (PS.pow (\1 -> 1) (2/5)) 1 -} pow :: (Field.C a) => (a -> a) -> a -> [a] -> [a] pow f0 expon x = @@ -196,6 +233,10 @@ > (exp . x)' = (exp . x) * x' > (sin . x)' = (cos . x) * x' > (cos . x)' = - (sin . x) * x' + +prop> equalTrunc 500 PSE.expExpl (PS.exp (\0 -> 1) [0,1]) +prop> equalTrunc 100 (1:1:repeat 0) (PS.exp (\0 -> 1) PSE.log) +prop> checkHoles 30 (PS.exp (\0 -> 1)) 0 -} exp :: Field.C a => (a -> a) -> [a] -> [a] exp f0 x = @@ -214,10 +255,25 @@ 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] +{- | +prop> equalTrunc 500 PSE.sinExpl (PS.sin (\0 -> (0,1)) [0,1]) +prop> equalTrunc 50 (0:1:repeat 0) (PS.sin (\0 -> (0,1)) PSE.asin) +prop> checkHoles 20 (PS.sin (\0 -> (0,1))) 0 +-} +sin :: Field.C a => (a -> (a,a)) -> [a] -> [a] sin f0 = fst . sinCos f0 +{- | +prop> equalTrunc 500 PSE.cosExpl (PS.cos (\0 -> (0,1)) [0,1]) +prop> checkHoles 20 (PS.cos (\0 -> (0,1))) 0 +-} +cos :: Field.C a => (a -> (a,a)) -> [a] -> [a] cos f0 = snd . sinCos f0 +{- | +prop> equalTrunc 50 PSE.tanExpl (PS.tan (\0 -> (0,1)) [0,1]) +prop> equalTrunc 50 (0:1:repeat 0) (PS.tan (\0 -> (0,1)) PSE.atan) +prop> checkHoles 20 (PS.tan (\0 -> (0,1))) 0 +-} tan :: (Field.C a) => (a -> (a,a)) -> [a] -> [a] tan f0 = uncurry divide . sinCos f0 @@ -229,6 +285,10 @@ {- | Input series must start with non-zero term. + +prop> equalTrunc 500 PSE.logExpl (PS.log (\1 -> 0) [1,1]) +prop> equalTrunc 100 (0:1:repeat 0) (PS.log (\1 -> 0) PSE.exp) +prop> checkHoles 30 (PS.log (\1 -> 0)) 1 -} log :: (Field.C a) => (a -> a) -> [a] -> [a] log f0 x = integrate (f0 (head x)) (derivedLog x) @@ -239,17 +299,33 @@ derivedLog :: (Field.C a) => [a] -> [a] derivedLog x = divide (differentiate x) x +{- | +prop> equalTrunc 500 PSE.atan (PS.atan (\0 -> 0) [0,1]) +prop> equalTrunc 50 (0:1:repeat 0) (PS.atan (\0 -> 0) PSE.tan) +prop> checkHoles 20 (PS.atan (\0 -> 0)) 0 +-} 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] +{- | +prop> equalTrunc 100 (0:1:repeat 0) (PS.asin (\1 -> 1) (\0 -> 0) PSE.sin) +prop> equalTrunc 50 PSE.asin (PS.asin (\1 -> 1) (\0 -> 0) [0,1]) +prop> checkHoles 30 (PS.asin (\1 -> 1) (\0 -> 0)) 0 +-} +asin :: (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))) + +{- | +Would be a nice test, but we cannot compute exactly with 'pi': + +> equalTrunc 50 PSE.acos (PS.acos (\1 -> 1) (\0 -> pi/2) [0,1]) +-} +acos :: (Field.C a) => (a -> a) -> (a -> a) -> [a] -> [a] acos = asin {- | @@ -303,6 +379,8 @@ This needs cubic run-time and thus is exceptionally slow. Computing inverse series for special power series might be faster. + +prop> genInvertible /\ \xs -> let (y,ys) = PS.inv xs; (z,zs) = PS.invDiff xs in y==z && equalTrunc 15 ys zs -} -- how about NonEmpty.T here? inv :: (Eq a, Field.C a) => [a] -> (a, [a]) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | 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,11 +1,10 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} 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 @@ -19,6 +18,16 @@ import NumericPrelude.Base -- (Bool, const, map, zipWith, id, (&&), (==)) +{- $setup +>>> import qualified MathObj.PowerSeries.Core as PS +>>> import qualified MathObj.PowerSeries.Example as PSE +>>> import Test.NumericPrelude.Utility (equalTrunc) +>>> import NumericPrelude.Numeric as NP +>>> import NumericPrelude.Base as P +>>> import Prelude () +-} + + {- * Default implementations. -} recip :: (Ring.C a) => [a] @@ -42,6 +51,8 @@ cosh = coshODE atanh = atanhODE + +-- | prop> \m n -> equalTrunc 30 (PS.mul (PSE.pow m) (PSE.pow n)) (PSE.pow (m+n)) pow :: (Field.C a) => a -> [a] pow = powExpl sqrt = sqrtExpl @@ -52,34 +63,54 @@ recipExpl :: (Ring.C a) => [a] recipExpl = cycle [1,-1] -expExpl, sinExpl, cosExpl :: (Field.C a) => [a] +-- | prop> equalTrunc 500 PSE.expExpl PSE.expODE +expExpl :: (Field.C a) => [a] expExpl = scanl (*) one PS.recipProgression +-- | prop> equalTrunc 500 PSE.sinExpl PSE.sinODE +sinExpl :: (Field.C a) => [a] sinExpl = zero : PS.holes2alternate (tail expExpl) -cosExpl = PS.holes2alternate expExpl +-- | prop> equalTrunc 500 PSE.cosExpl PSE.cosODE +cosExpl :: (Field.C a) => [a] +cosExpl = PS.holes2alternate expExpl -tanExpl, tanExplSieve :: (ZeroTestable.C a, Field.C a) => [a] +-- | prop> equalTrunc 50 PSE.tanExpl PSE.tanODE +tanExpl :: (ZeroTestable.C a, Field.C a) => [a] tanExpl = PS.divide sinExpl cosExpl -- ignore zero values +-- | prop> equalTrunc 50 PSE.tanExpl PSE.tanExplSieve +tanExplSieve :: (ZeroTestable.C a, Field.C a) => [a] tanExplSieve = concatMap (\x -> [zero,x]) (PS.divide (sieve 2 (tail sin)) (sieve 2 cos)) -logExpl, atanExpl, sqrtExpl :: (Field.C a) => [a] +-- | prop> equalTrunc 500 PSE.logExpl PSE.logODE +logExpl :: (Field.C a) => [a] logExpl = zero : PS.alternate PS.recipProgression +-- | prop> equalTrunc 500 PSE.atanExpl PSE.atanODE +atanExpl :: (Field.C a) => [a] atanExpl = zero : PS.holes2alternate PS.recipProgression -sinhExpl, coshExpl, atanhExpl :: (Field.C a) => [a] +-- | prop> equalTrunc 500 PSE.sinhExpl PSE.sinhODE +sinhExpl :: (Field.C a) => [a] sinhExpl = zero : PS.holes2 (tail expExpl) +-- | prop> equalTrunc 500 PSE.coshExpl PSE.coshODE +coshExpl :: (Field.C a) => [a] coshExpl = PS.holes2 expExpl +-- | prop> equalTrunc 500 PSE.atanhExpl PSE.atanhODE +atanhExpl :: (Field.C a) => [a] atanhExpl = zero : PS.holes2 PS.recipProgression {- * Power series of (1+x)^expon using the binomial series. -} +-- | prop> \expon -> equalTrunc 50 (PSE.powODE expon) (PSE.powExpl expon) powExpl :: (Field.C a) => a -> [a] powExpl expon = scanl (*) 1 (zipWith (/) (iterate (subtract 1) expon) PS.progression) + +-- | prop> equalTrunc 100 PSE.sqrtExpl PSE.sqrtODE +sqrtExpl :: (Field.C a) => [a] sqrtExpl = powExpl (1/2) {- | @@ -110,11 +141,13 @@ == cos x ^ (-2) -} -expODE, sinODE, cosODE, tanODE, tanODESieve :: (Field.C a) => [a] +expODE, sinODE, cosODE, tanODE :: (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)) +-- | prop> equalTrunc 50 PSE.tanODE PSE.tanODESieve +tanODESieve :: (Field.C a) => [a] tanODESieve = -- sieve is too strict here because it wants to detect end of lists let tan2 = map head (iterate (drop 2) (tail tanODESieve)) @@ -126,9 +159,11 @@ atan' x == 1/(1+x^2) -} -logODE, recipCircle, asinODE, atanODE, sqrtODE :: (Field.C a) => [a] +logODE, recipCircle, atanODE, sqrtODE :: (Field.C a) => [a] logODE = PS.integrate zero recip recipCircle = intersperse zero (PS.alternate (powODE (-1/2))) +-- | prop> equalTrunc 50 PSE.asinODE (snd $ PS.inv PSE.sinODE) +asinODE :: (Field.C a) => [a] asinODE = PS.integrate 0 recipCircle atanODE = PS.integrate zero (cycle [1,0,-1,0]) sqrtODE = powODE (1/2) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -18,11 +18,6 @@ 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 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module MathObj.PowerSeries2.Core where import qualified MathObj.PowerSeries as PS @@ -11,7 +11,6 @@ import qualified Algebra.Additive as Additive import NumericPrelude.Base --- import NumericPrelude.Numeric hiding (negate, sqrt, ) type T a = [[a]] 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | diff --git a/src/MathObj/RefinementMask2.hs b/src/MathObj/RefinementMask2.hs --- a/src/MathObj/RefinementMask2.hs +++ b/src/MathObj/RefinementMask2.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module MathObj.RefinementMask2 ( T, coeffs, fromCoeffs, fromPolynomial, @@ -29,6 +29,43 @@ import NumericPrelude.Numeric +{- $setup +>>> import qualified MathObj.RefinementMask2 as Mask +>>> import qualified MathObj.Polynomial as Poly +>>> import qualified MathObj.Polynomial.Core as PolyCore +>>> +>>> import qualified Algebra.Differential as D +>>> import qualified Algebra.Ring as Ring +>>> import Test.NumericPrelude.Utility ((/\)) +>>> import qualified Test.QuickCheck as QC +>>> import NumericPrelude.Numeric as NP +>>> import NumericPrelude.Base as P +>>> import Prelude () +>>> +>>> import Data.Function.HT (nest) +>>> import Data.Maybe (fromMaybe) +>>> +>>> +>>> 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 +>>> +>>> genAdmissibleMask :: QC.Gen (Mask.T Rational, Poly.T Rational) +>>> genAdmissibleMask = +>>> QC.suchThatMap QC.arbitrary $ +>>> \mask -> fmap ((,) mask) $ Mask.toPolynomial mask +>>> +>>> polyFromMask :: Mask.T a -> Poly.T a +>>> polyFromMask = Poly.fromCoeffs . Mask.coeffs +>>> +>>> genShortPolynomial :: Int -> QC.Gen (Poly.T Rational) +>>> genShortPolynomial n = +>>> fmap (Poly.fromCoeffs . PolyCore.normalize . take n) $ QC.arbitrary +-} + + newtype T a = Cons {coeffs :: [a]} @@ -85,6 +122,11 @@ p2 = L * R^(-1) * m R * L^(-1) * p2 = m + + +prop> genAdmissibleMask /\ \(mask,poly) -> hasMultipleZero (fromMaybe 0 $ Poly.degree poly) 1 (polyFromMask (Mask.fromPolynomial poly) - polyFromMask mask) + +prop> genShortPolynomial 5 /\ \poly -> maybe False (Poly.collinear poly) $ Mask.toPolynomial $ Mask.fromPolynomial poly -} fromPolynomial :: (Field.C a) => Poly.T a -> T a @@ -115,6 +157,9 @@ {- | If the mask does not sum up to a power of @1/2@ then the function returns 'Nothing'. + +>>> fmap ((6::Rational) *>) $ Mask.toPolynomial (Mask.fromCoeffs [0.1, 0.02, 0.005::Rational]) +Just (Polynomial.fromCoeffs [-12732 % 109375,272 % 625,-18 % 25,1 % 1]) -} toPolynomial :: (RealField.C a) => T a -> Maybe (Poly.T a) @@ -131,10 +176,6 @@ 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, @@ -162,17 +203,18 @@ (Poly.const 1) ks0 _ -> Nothing +{- | +prop> genShortPolynomial 5 /\ \poly -> poly == Mask.refinePolynomial (Mask.fromPolynomial poly) poly + +>>> fmap (round :: Double -> Integer) $ fmap (1000000*) $ nest 50 (Mask.refinePolynomial (Mask.fromCoeffs [0.1, 0.02, 0.005])) (Poly.fromCoeffs [0,0,0,1]) +Polynomial.fromCoeffs [-116407,435200,-720000,1000000] +-} 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] --} convolve :: (Ring.C a) => T a -> T a -> T a 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Copyright : (c) Henning Thielemann 2004-2005 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- Rules should be processed -} @@ -48,7 +48,6 @@ defltPow, ) where --- import qualified Number.Ratio as Ratio import qualified Algebra.NormedSpace.Euclidean as NormedEuc import qualified Algebra.NormedSpace.Sum as NormedSum @@ -93,7 +92,6 @@ import Text.Read.HT (readsInfixPrec, ) --- import qualified Data.Typeable as Ty infix 6 +:, `Cons` 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Special physical units: SI unit system -} @@ -31,10 +31,8 @@ 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 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Copyright : (c) Henning Thielemann 2006 @@ -17,14 +17,13 @@ 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 qualified Data.List.Reverse.StrictElement as Rev import NumericPrelude.List (mapLast, ) import Data.Function.HT (powerAssociative, ) -import Data.List.HT (dropWhileRev, padLeft, ) +import Data.List.HT (padLeft) import Data.Maybe.HT (toMaybe, ) import Data.List (transpose, unfoldr, ) import Data.Char (intToDigit, ) @@ -60,7 +59,7 @@ basis = ringPower packetSize 10 (int,frac) = toPositional basis den x in show int ++ "." ++ - concat (mapLast (dropWhileRev ('0'==)) + concat (mapLast (Rev.dropWhile ('0'==)) (map (padLeft '0' packetSize . show) frac)) showPositionalHex :: Integer -> Integer -> String 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {- | This number type is intended for tests of functions over fields, @@ -7,7 +7,7 @@ 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. +Thus division is not always defined, where it is for rational numbers. -} module Number.GaloisField2p32m5 where @@ -30,6 +30,30 @@ import NumericPrelude.Numeric +{- $setup +>>> import qualified Number.GaloisField2p32m5 as GF +>>> import qualified Algebra.Laws as Laws +>>> import Test.QuickCheck ((==>)) +>>> import NumericPrelude.Numeric +>>> import NumericPrelude.Base +>>> import Prelude () +>>> +>>> gf :: GF.T -> GF.T +>>> gf = id +-} + +{- | +prop> Laws.identity (+) zero . gf +prop> Laws.commutative (+) . gf +prop> Laws.associative (+) . gf +prop> Laws.inverse (+) negate zero . gf +prop> \x -> Laws.inverse (+) (x-) (gf x) +prop> Laws.identity (*) one . gf +prop> Laws.commutative (*) . gf +prop> Laws.associative (*) . gf +prop> \y -> gf y /= zero ==> Laws.inverse (*) recip one y +prop> \y x -> gf y /= zero ==> Laws.inverse (*) (x/) x y +-} newtype T = Cons {decons :: Word32} deriving Eq 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- @@ -46,7 +46,6 @@ import qualified Algebra.ToInteger as ToInteger import qualified Algebra.ToRational as ToRational --- import Test.QuickCheck (Arbitrary(arbitrary)) import qualified Number.Ratio as R 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Define Transcendental functions on arbitrary fields. These functions are defined for only a few (in most cases only one) arguments, @@ -15,7 +15,6 @@ 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 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Copyright : (c) Henning Thielemann 2007-2012 Maintainer : numericprelude@henning-thielemann.de @@ -32,14 +32,10 @@ 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 qualified Prelude as P98 import NumericPrelude.Base import NumericPrelude.Numeric 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Convert a human readable string to a physical value. -} @@ -8,7 +8,6 @@ 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) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Convert a physical value to a human readable string. -} 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Abstract Physical Units -} 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Tools for creating a data base of physical units and for extracting data from it @@ -9,7 +9,6 @@ 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) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Exact Real Arithmetic - Computable reals. Inspired by ''The most unreliable technique for computing pi.'' @@ -11,7 +11,6 @@ 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 @@ -421,7 +420,7 @@ 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 + Rev.dropWhile (0==) . compressMant bDst -} cmpr (mag,xs) = (mag - unit, compressMant bSrc xs) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Interface to "Number.Positional" which dynamically checks for equal bases. -} @@ -8,7 +8,6 @@ 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 @@ -23,7 +22,6 @@ 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 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- | @@ -55,11 +55,9 @@ 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, ) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Module : Number.Ratio Copyright : (c) Henning Thielemann 2011-2012 diff --git a/src/Number/ResidueClass.hs b/src/Number/ResidueClass.hs --- a/src/Number/ResidueClass.hs +++ b/src/Number/ResidueClass.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} 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) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Number.ResidueClass.Reader where import qualified Number.ResidueClass as Res @@ -13,9 +13,7 @@ import Control.Monad (liftM, liftM2, liftM4, ap) import Control.Applicative (Applicative(pure, (<*>))) --- import Control.Monad.Reader (MonadReader) --- import qualified Prelude as P import qualified NumericPrelude.Numeric as NP 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Special physical units: SI unit system -} 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | Some functions that are counterparts of functions from "Data.List" using NumericPrelude.Numeric type classes. @@ -13,7 +13,6 @@ ) where import qualified Algebra.ToInteger as ToInteger --- import qualified Algebra.Ring as Ring import Algebra.Ring (one, ) import Algebra.Additive (zero, (-), ) 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} {- | 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 NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module NumericPrelude.Numeric ( {- Additive -} (+), (-), negate, zero, subtract, sum, sum1, {- ZeroTestable -} isZero, diff --git a/test/Demo.hs b/test/Demo.hs --- a/test/Demo.hs +++ b/test/Demo.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} module Main where import Number.Complex((+:), (-:), ) diff --git a/test/Number/ComplexSquareRoot.hs b/test/Number/ComplexSquareRoot.hs deleted file mode 100644 --- a/test/Number/ComplexSquareRoot.hs +++ /dev/null @@ -1,117 +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 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/test/Test/Algebra/Additive.hs b/test/Test/Algebra/Additive.hs --- a/test/Test/Algebra/Additive.hs +++ b/test/Test/Algebra/Additive.hs @@ -1,35 +1,28 @@ -{-# 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 - +-- Do not edit! Automatically created with doctest-extract from src/Algebra/Additive.hs +{-# LINE 42 "src/Algebra/Additive.hs" #-} -test :: - (Testable t) => - ([Integer] -> t) -> IO () -test = quickCheck +module Test.Algebra.Additive where +import qualified Test.DocTest.Driver as DocTest -tests :: HUnit.Test -tests = - HUnit.TestLabel "additive group" $ - HUnit.TestList $ - map testUnit $ - testList +{-# LINE 43 "src/Algebra/Additive.hs" #-} +import qualified Algebra.Additive as A +import qualified Test.QuickCheck as QC -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) : - [] +test :: DocTest.T () +test = do + DocTest.printPrefix "Algebra.Additive:108: " +{-# LINE 108 "src/Algebra/Additive.hs" #-} + DocTest.property +{-# LINE 108 "src/Algebra/Additive.hs" #-} + (\(QC.NonEmpty ns) -> A.sum ns == (A.sum1 ns :: Integer)) + DocTest.printPrefix "Algebra.Additive:121: " +{-# LINE 121 "src/Algebra/Additive.hs" #-} + DocTest.property +{-# LINE 121 "src/Algebra/Additive.hs" #-} + (\ns -> A.sum ns == (A.sumNestedAssociative ns :: Integer)) + DocTest.printPrefix "Algebra.Additive:136: " +{-# LINE 136 "src/Algebra/Additive.hs" #-} + DocTest.property +{-# LINE 136 "src/Algebra/Additive.hs" #-} + (\ns -> A.sum ns == (A.sumNestedCommutative ns :: Integer)) 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,41 +1,41 @@ -{-# 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 - +-- Do not edit! Automatically created with doctest-extract from src/Algebra/IntegralDomain.hs +{-# LINE 54 "src/Algebra/IntegralDomain.hs" #-} -test :: - (Testable t) => - (Integer -> t) -> IO () -test = quickCheck +module Test.Algebra.IntegralDomain where +import qualified Test.DocTest.Driver as DocTest -tests :: HUnit.Test -tests = - HUnit.TestLabel "integral domain functions" $ - HUnit.TestList $ - map testUnit $ - testList +{-# LINE 55 "src/Algebra/IntegralDomain.hs" #-} +import Algebra.IntegralDomain (roundDown, roundUp, divUp) +import qualified Test.QuickCheck as QC +import NumericPrelude.Base as P +import NumericPrelude.Numeric as NP +import Prelude () -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) : - [] +test :: DocTest.T () +test = do + DocTest.printPrefix "Algebra.IntegralDomain:108: " +{-# LINE 108 "src/Algebra/IntegralDomain.hs" #-} + DocTest.property +{-# LINE 108 "src/Algebra/IntegralDomain.hs" #-} + (\n (QC.NonZero m) -> let (q,r) = divMod n m in n == (q*m+r :: Integer)) + DocTest.printPrefix "Algebra.IntegralDomain:198: " +{-# LINE 198 "src/Algebra/IntegralDomain.hs" #-} + DocTest.property +{-# LINE 198 "src/Algebra/IntegralDomain.hs" #-} + (\n (QC.NonZero m) -> div n m * m == (roundDown n m :: Integer)) + DocTest.printPrefix "Algebra.IntegralDomain:208: " +{-# LINE 208 "src/Algebra/IntegralDomain.hs" #-} + DocTest.property +{-# LINE 208 "src/Algebra/IntegralDomain.hs" #-} + (\n (QC.NonZero m) -> divUp n m * m == (roundUp n m :: Integer)) + DocTest.printPrefix "Algebra.IntegralDomain:209: " +{-# LINE 209 "src/Algebra/IntegralDomain.hs" #-} + DocTest.property +{-# LINE 209 "src/Algebra/IntegralDomain.hs" #-} + (\n (QC.Positive m) -> let x = roundDown n m in n-m < x && x <= (n :: Integer)) + DocTest.printPrefix "Algebra.IntegralDomain:210: " +{-# LINE 210 "src/Algebra/IntegralDomain.hs" #-} + DocTest.property +{-# LINE 210 "src/Algebra/IntegralDomain.hs" #-} + (\n (QC.NonZero m) -> - roundDown n m == (roundUp (-n) m :: Integer)) diff --git a/test/Test/Algebra/PrincipalIdealDomain.hs b/test/Test/Algebra/PrincipalIdealDomain.hs new file mode 100644 --- /dev/null +++ b/test/Test/Algebra/PrincipalIdealDomain.hs @@ -0,0 +1,49 @@ +-- Do not edit! Automatically created with doctest-extract from src/Algebra/PrincipalIdealDomain.hs +{-# LINE 64 "src/Algebra/PrincipalIdealDomain.hs" #-} + +module Test.Algebra.PrincipalIdealDomain where + +import Test.DocTest.Base +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 65 "src/Algebra/PrincipalIdealDomain.hs" #-} +import qualified Algebra.PrincipalIdealDomain as PID +import Test.NumericPrelude.Utility ((/\)) +import qualified Test.QuickCheck as QC + +genResidueClass :: QC.Gen (Integer,Integer) +genResidueClass = do + m <- fmap QC.getNonZero $ QC.arbitrary + a <- QC.choose (min 0 $ 1+m, max 0 $ m-1) + return (m,a) + +test :: DocTest.T () +test = do + DocTest.printPrefix "Algebra.PrincipalIdealDomain:305: " +{-# LINE 305 "src/Algebra/PrincipalIdealDomain.hs" #-} + DocTest.property +{-# LINE 305 "src/Algebra/PrincipalIdealDomain.hs" #-} + (QC.listOf genResidueClass /\ \xs -> case PID.chineseRemainderMulti xs of Nothing -> True; Just (n,b) -> abs n == abs (foldl lcm 1 (map fst xs)) && map snd xs == map (mod b . fst) xs) + DocTest.printPrefix "Algebra.PrincipalIdealDomain:306: " +{-# LINE 306 "src/Algebra/PrincipalIdealDomain.hs" #-} + DocTest.property +{-# LINE 306 "src/Algebra/PrincipalIdealDomain.hs" #-} + (\(QC.NonEmpty ms) b -> let xs = map (\(QC.NonZero m) -> (m, mod b m)) ms in case PID.chineseRemainderMulti xs of Nothing -> False; Just (n,c) -> abs n == abs (foldl lcm 1 (map QC.getNonZero ms)) && mod b n == (c::Integer)) + DocTest.printPrefix "Algebra.PrincipalIdealDomain:298: " +{-# LINE 298 "src/Algebra/PrincipalIdealDomain.hs" #-} + DocTest.example +{-# LINE 298 "src/Algebra/PrincipalIdealDomain.hs" #-} + (PID.chineseRemainderMulti [(100,21), (10000,2021::Integer)]) + [ExpectedLine [LineChunk "Just (10000,2021)"]] + DocTest.printPrefix "Algebra.PrincipalIdealDomain:300: " +{-# LINE 300 "src/Algebra/PrincipalIdealDomain.hs" #-} + DocTest.example +{-# LINE 300 "src/Algebra/PrincipalIdealDomain.hs" #-} + (PID.chineseRemainderMulti [(97,90),(99,10),(100,0::Integer)]) + [ExpectedLine [LineChunk "Just (960300,100000)"]] + DocTest.printPrefix "Algebra.PrincipalIdealDomain:302: " +{-# LINE 302 "src/Algebra/PrincipalIdealDomain.hs" #-} + DocTest.example +{-# LINE 302 "src/Algebra/PrincipalIdealDomain.hs" #-} + (PID.chineseRemainderMulti [(95,30),(97,27),(98,8),(99,1::Integer)]) + [ExpectedLine [LineChunk "Just (89403930,1000000)"]] 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,40 +1,126 @@ -{-# 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, ) +-- Do not edit! Automatically created with doctest-extract from src/Algebra/RealRing.hs +{-# LINE 38 "src/Algebra/RealRing.hs" #-} -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP +module Test.Algebra.RealRing where +import qualified Test.DocTest.Driver as DocTest -test :: (Eq a) => (Double -> a) -> (Double -> a) -> IO () -test f g = - quickCheck (\x -> f x == g x) +{-# LINE 39 "src/Algebra/RealRing.hs" #-} +import qualified Algebra.RealRing as RealRing +import Data.Tuple.HT (mapFst) +import NumericPrelude.Numeric as NP +import NumericPrelude.Base +import Prelude () +infix 4 =~= -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))) : +(=~=) :: (Eq b) => (a -> b) -> (a -> b) -> a -> Bool +(f =~= g) x = f x == g x -{- - ("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))) : - [] +test :: DocTest.T () +test = do + DocTest.printPrefix "Algebra.RealRing:134: " +{-# LINE 134 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 134 "src/Algebra/RealRing.hs" #-} + (\x -> (x::Rational) == (uncurry (+) $ mapFst fromInteger $ splitFraction x)) + DocTest.printPrefix "Algebra.RealRing:135: " +{-# LINE 135 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 135 "src/Algebra/RealRing.hs" #-} + (\x -> uncurry (==) $ mapFst (((x::Double)-) . fromInteger) $ splitFraction x) + DocTest.printPrefix "Algebra.RealRing:136: " +{-# LINE 136 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 136 "src/Algebra/RealRing.hs" #-} + (\x -> uncurry (==) $ mapFst (((x::Rational)-) . fromInteger) $ splitFraction x) + DocTest.printPrefix "Algebra.RealRing:137: " +{-# LINE 137 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 137 "src/Algebra/RealRing.hs" #-} + (\x -> splitFraction x == (floor (x::Double) :: Integer, fraction x)) + DocTest.printPrefix "Algebra.RealRing:138: " +{-# LINE 138 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 138 "src/Algebra/RealRing.hs" #-} + (\x -> splitFraction x == (floor (x::Rational) :: Integer, fraction x)) + DocTest.printPrefix "Algebra.RealRing:142: " +{-# LINE 142 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 142 "src/Algebra/RealRing.hs" #-} + (\x -> let y = fraction (x::Double) in 0<=y && y<1) + DocTest.printPrefix "Algebra.RealRing:143: " +{-# LINE 143 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 143 "src/Algebra/RealRing.hs" #-} + (\x -> let y = fraction (x::Rational) in 0<=y && y<1) + DocTest.printPrefix "Algebra.RealRing:147: " +{-# LINE 147 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 147 "src/Algebra/RealRing.hs" #-} + (\x -> ceiling (-x) == negate (floor (x::Double) :: Integer)) + DocTest.printPrefix "Algebra.RealRing:148: " +{-# LINE 148 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 148 "src/Algebra/RealRing.hs" #-} + (\x -> ceiling (-x) == negate (floor (x::Rational) :: Integer)) + DocTest.printPrefix "Algebra.RealRing:564: " +{-# LINE 564 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 564 "src/Algebra/RealRing.hs" #-} + (RealRing.genericFloor =~= (NP.floor :: Double -> Integer)) + DocTest.printPrefix "Algebra.RealRing:565: " +{-# LINE 565 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 565 "src/Algebra/RealRing.hs" #-} + (RealRing.genericFloor =~= (NP.floor :: Rational -> Integer)) + DocTest.printPrefix "Algebra.RealRing:574: " +{-# LINE 574 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 574 "src/Algebra/RealRing.hs" #-} + (RealRing.genericCeiling =~= (NP.ceiling :: Double -> Integer)) + DocTest.printPrefix "Algebra.RealRing:575: " +{-# LINE 575 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 575 "src/Algebra/RealRing.hs" #-} + (RealRing.genericCeiling =~= (NP.ceiling :: Rational -> Integer)) + DocTest.printPrefix "Algebra.RealRing:584: " +{-# LINE 584 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 584 "src/Algebra/RealRing.hs" #-} + (RealRing.genericTruncate =~= (NP.truncate :: Double -> Integer)) + DocTest.printPrefix "Algebra.RealRing:585: " +{-# LINE 585 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 585 "src/Algebra/RealRing.hs" #-} + (RealRing.genericTruncate =~= (NP.truncate :: Rational -> Integer)) + DocTest.printPrefix "Algebra.RealRing:594: " +{-# LINE 594 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 594 "src/Algebra/RealRing.hs" #-} + (RealRing.genericRound =~= (NP.round :: Double -> Integer)) + DocTest.printPrefix "Algebra.RealRing:595: " +{-# LINE 595 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 595 "src/Algebra/RealRing.hs" #-} + (RealRing.genericRound =~= (NP.round :: Rational -> Integer)) + DocTest.printPrefix "Algebra.RealRing:604: " +{-# LINE 604 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 604 "src/Algebra/RealRing.hs" #-} + (RealRing.genericFraction =~= (NP.fraction :: Double -> Double)) + DocTest.printPrefix "Algebra.RealRing:605: " +{-# LINE 605 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 605 "src/Algebra/RealRing.hs" #-} + (RealRing.genericFraction =~= (NP.fraction :: Rational -> Rational)) + DocTest.printPrefix "Algebra.RealRing:614: " +{-# LINE 614 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 614 "src/Algebra/RealRing.hs" #-} + (RealRing.genericSplitFraction =~= (NP.splitFraction :: Double -> (Integer,Double))) + DocTest.printPrefix "Algebra.RealRing:615: " +{-# LINE 615 "src/Algebra/RealRing.hs" #-} + DocTest.property +{-# LINE 615 "src/Algebra/RealRing.hs" #-} + (RealRing.genericSplitFraction =~= (NP.splitFraction :: Rational -> (Integer,Rational))) 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,103 +1,157 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Test.MathObj.Gaussian.Bell where - -import qualified MathObj.Gaussian.Bell as G - -import qualified Algebra.Laws as Laws +-- Do not edit! Automatically created with doctest-extract from gaussian/MathObj/Gaussian/Bell.hs +{-# LINE 30 "gaussian/MathObj/Gaussian/Bell.hs" #-} -import qualified Number.Complex as Complex +module Test.MathObj.Gaussian.Bell where -import Test.NumericPrelude.Utility (testUnit) -import Test.QuickCheck (Testable, quickCheck, (==>)) -import qualified Test.HUnit as HUnit +import Test.DocTest.Base +import qualified Test.DocTest.Driver as DocTest -import Data.Function.HT (nest, ) +{-# LINE 31 "gaussian/MathObj/Gaussian/Bell.hs" #-} +import qualified MathObj.Gaussian.Bell as G +import qualified Algebra.ZeroTestable as ZeroTestable +import qualified Algebra.Laws as Laws +import qualified Number.Complex as Complex +import Number.Complex ((+:)) +import NumericPrelude.Base as P +import NumericPrelude.Numeric as NP +import Prelude () +import qualified Test.QuickCheck as QC +import Data.Function.HT (Id, nest) -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP +asRational :: Id (G.T Rational) +asRational = id +withRational :: Id (G.T Rational -> a) +withRational = id -simple :: - (Testable t) => - (G.T Rational -> t) -> IO () -simple = quickCheck +isConstant :: ZeroTestable.C a => G.T a -> Bool +isConstant (G.Cons _amp _a b c) = isZero b && isZero c -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) : - ("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", - 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 by translation", - simple $ \x -> G.fourier x == G.fourierByTranslation x) : - ("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))) : - [] +test :: DocTest.T () +test = do + DocTest.printPrefix "MathObj.Gaussian.Bell:108: " +{-# LINE 108 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 108 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (Laws.identity G.multiply G.constant . asRational) + DocTest.printPrefix "MathObj.Gaussian.Bell:109: " +{-# LINE 109 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 109 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (Laws.commutative G.multiply . asRational) + DocTest.printPrefix "MathObj.Gaussian.Bell:110: " +{-# LINE 110 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 110 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (Laws.associative G.multiply . asRational) + DocTest.printPrefix "MathObj.Gaussian.Bell:152: " +{-# LINE 152 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 152 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (Laws.commutative G.convolve . asRational) + DocTest.printPrefix "MathObj.Gaussian.Bell:153: " +{-# LINE 153 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 153 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (Laws.associative G.convolve . asRational) + DocTest.printPrefix "MathObj.Gaussian.Bell:161: " +{-# LINE 161 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 161 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (isConstant . G.convolve G.constant . asRational) + DocTest.printPrefix "MathObj.Gaussian.Bell:149: " +{-# LINE 149 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.example +{-# LINE 149 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (let x=G.Cons 2 (1+:3) (4+:5) (7::Rational); y=G.Cons 7 (1+:4) (3+:2) (5::Rational) in G.convolve x y) + [ExpectedLine [LineChunk "Cons {amp = 7 % 6, c0 = 13 % 6 +: 55 % 8, c1 = 41 % 12 +: 13 % 4, c2 = 35 % 12}"]] + DocTest.printPrefix "MathObj.Gaussian.Bell:200: " +{-# LINE 200 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 200 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x y -> G.convolve x y == G.convolveByTranslation x y) + DocTest.printPrefix "MathObj.Gaussian.Bell:217: " +{-# LINE 217 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 217 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x y -> G.convolve x y == G.convolveByFourier x y) + DocTest.printPrefix "MathObj.Gaussian.Bell:225: " +{-# LINE 225 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 225 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x y -> G.fourier (G.convolve x y) == G.multiply (G.fourier x) (G.fourier y)) + DocTest.printPrefix "MathObj.Gaussian.Bell:226: " +{-# LINE 226 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 226 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x -> nest 2 G.fourier x == G.reverse x) + DocTest.printPrefix "MathObj.Gaussian.Bell:227: " +{-# LINE 227 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 227 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (G.fourier G.unit == (asRational G.unit)) + DocTest.printPrefix "MathObj.Gaussian.Bell:228: " +{-# LINE 228 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 228 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x a -> G.fourier (G.translate a x) == G.modulate a (G.fourier x)) + DocTest.printPrefix "MathObj.Gaussian.Bell:229: " +{-# LINE 229 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 229 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x (QC.Positive a) -> G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x))) + DocTest.printPrefix "MathObj.Gaussian.Bell:244: " +{-# LINE 244 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 244 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x -> G.fourier x == G.fourierByTranslation x) + DocTest.printPrefix "MathObj.Gaussian.Bell:312: " +{-# LINE 312 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 312 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x a b -> G.translate a (G.translate b x) == G.translate (a+b) x) + DocTest.printPrefix "MathObj.Gaussian.Bell:326: " +{-# LINE 326 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 326 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x a b -> G.translateComplex a (G.translateComplex b x) == G.translateComplex (a+b) x) + DocTest.printPrefix "MathObj.Gaussian.Bell:327: " +{-# LINE 327 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 327 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x a -> G.translateComplex (Complex.fromReal a) x == G.translate a x) + DocTest.printPrefix "MathObj.Gaussian.Bell:341: " +{-# LINE 341 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 341 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x a b -> G.modulate a (G.modulate b x) == G.modulate (a+b) x) + DocTest.printPrefix "MathObj.Gaussian.Bell:342: " +{-# LINE 342 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 342 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x a b -> G.modulate b (G.translate a x) == G.turn (a*b) (G.translate a (G.modulate b x))) + DocTest.printPrefix "MathObj.Gaussian.Bell:361: " +{-# LINE 361 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 361 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x -> nest 2 G.reverse x == x) + DocTest.printPrefix "MathObj.Gaussian.Bell:369: " +{-# LINE 369 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 369 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x (QC.Positive a) (QC.Positive b) -> G.dilate a (G.dilate b x) == G.dilate (a*b) x) + DocTest.printPrefix "MathObj.Gaussian.Bell:370: " +{-# LINE 370 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 370 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x (QC.Positive a) -> G.shrink a x == G.dilate (recip a) x) + DocTest.printPrefix "MathObj.Gaussian.Bell:381: " +{-# LINE 381 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 381 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x (QC.Positive a) -> G.dilate a (G.shrink a x) == x) + DocTest.printPrefix "MathObj.Gaussian.Bell:382: " +{-# LINE 382 "gaussian/MathObj/Gaussian/Bell.hs" #-} + DocTest.property +{-# LINE 382 "gaussian/MathObj/Gaussian/Bell.hs" #-} + (withRational $ \x (QC.Positive a) -> G.shrink a (G.dilate a x) == x) diff --git a/test/Test/MathObj/Gaussian/ExponentTuple.hs b/test/Test/MathObj/Gaussian/ExponentTuple.hs new file mode 100644 --- /dev/null +++ b/test/Test/MathObj/Gaussian/ExponentTuple.hs @@ -0,0 +1,26 @@ +-- Do not edit! Automatically created with doctest-extract from gaussian/MathObj/Gaussian/ExponentTuple.hs +{-# LINE 14 "gaussian/MathObj/Gaussian/ExponentTuple.hs" #-} + +module Test.MathObj.Gaussian.ExponentTuple where + +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 15 "gaussian/MathObj/Gaussian/ExponentTuple.hs" #-} +import MathObj.Gaussian.ExponentTuple (HoelderConjugates(HoelderConjugates)) +import MathObj.Gaussian.ExponentTuple (YoungConjugates(YoungConjugates)) +import NumericPrelude.Base as P +import NumericPrelude.Numeric as NP +import Prelude () + +test :: DocTest.T () +test = do + DocTest.printPrefix "MathObj.Gaussian.ExponentTuple:26: " +{-# LINE 26 "gaussian/MathObj/Gaussian/ExponentTuple.hs" #-} + DocTest.property +{-# LINE 26 "gaussian/MathObj/Gaussian/ExponentTuple.hs" #-} + (\(HoelderConjugates p q) -> p>=1 && q>=1 && 1/p + 1/q == 1) + DocTest.printPrefix "MathObj.Gaussian.ExponentTuple:53: " +{-# LINE 53 "gaussian/MathObj/Gaussian/ExponentTuple.hs" #-} + DocTest.property +{-# LINE 53 "gaussian/MathObj/Gaussian/ExponentTuple.hs" #-} + (\(YoungConjugates p q r) -> p>=1 && q>=1 && r>=1 && 1/p + 1/q == 1/r + 1) 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,165 +1,215 @@ -{-# 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 +-- Do not edit! Automatically created with doctest-extract from gaussian/MathObj/Gaussian/Polynomial.hs +{-# LINE 60 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} -import qualified Number.NonNegative as NonNeg -import Data.Function.HT (nest, ) -import Data.Tuple.HT (mapSnd, ) +{-# OPTIONS_GHC -XRebindableSyntax #-} --- import Debug.Trace (trace, ) +module Test.MathObj.Gaussian.Polynomial where -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP +import Test.DocTest.Base +import qualified Test.DocTest.Driver as DocTest +{-# LINE 63 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} +import qualified MathObj.Gaussian.Polynomial as G +import qualified MathObj.Gaussian.Bell as Bell +import qualified MathObj.Polynomial as Poly +import qualified Algebra.Laws as Laws +import qualified Number.Complex as Complex +import Number.Complex ((+:)) +import NumericPrelude.Base as P +import NumericPrelude.Numeric as NP +import qualified Test.QuickCheck as QC +import Data.Function.HT (Id, nest) +import Data.Tuple.HT (mapSnd) -simple :: - (Testable t) => - (G.T Rational -> t) -> IO () -simple f = - quickCheck (\x -> f (x :: G.T Rational)) +asRational :: Id (G.T Rational) +asRational = id -tests :: HUnit.Test -tests = - HUnit.TestLabel "polynomial" $ - HUnit.TestList $ - map testUnit $ - testList +withRational :: Id (G.T Rational -> a) +withRational = id -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) : - [] +mulLinear2i :: Id (G.T Rational) +mulLinear2i x = + x{G.polynomial = Poly.fromCoeffs [0, 0+:2] * G.polynomial x} -{- -inequalities: +rotateQuarter :: Int -> Id (G.T Rational) +rotateQuarter n = + G.scaleComplex (negate Complex.imaginaryUnit ^ fromIntegral n) -Heisenberg's uncertainty relation - needs integrals and thus needs product of exponential numbers and roots --} +test :: DocTest.T () +test = do + DocTest.printPrefix "MathObj.Gaussian.Polynomial:185: " +{-# LINE 185 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 185 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (QC.forAll (QC.choose (0,3)) $ \n -> G.eigenfunctionDifferential n == asRational (G.eigenfunctionIterative n)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:193: " +{-# LINE 193 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 193 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (G.eigenfunction0 == asRational (G.eigenfunctionDifferential 0)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:198: " +{-# LINE 198 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 198 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (G.eigenfunction1 == asRational (G.eigenfunctionDifferential 1)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:203: " +{-# LINE 203 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 203 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (G.eigenfunction2 == asRational (G.eigenfunctionDifferential 2)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:208: " +{-# LINE 208 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 208 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (G.eigenfunction3 == asRational (G.eigenfunctionDifferential 3)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:215: " +{-# LINE 215 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 215 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (QC.forAll (QC.choose (0,15)) $ \n -> let x = G.eigenfunctionDifferential n in G.fourier x == rotateQuarter n x) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:224: " +{-# LINE 224 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 224 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (QC.forAll (QC.choose (0,15)) $ \n -> let x = G.eigenfunctionIterative n in G.fourier x == rotateQuarter n x) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:246: " +{-# LINE 246 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 246 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ Laws.identity G.multiply G.constant) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:247: " +{-# LINE 247 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 247 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ Laws.commutative G.multiply) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:248: " +{-# LINE 248 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 248 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ Laws.associative G.multiply) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:258: " +{-# LINE 258 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 258 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ Laws.commutative G.convolve) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:259: " +{-# LINE 259 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 259 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ Laws.associative G.convolve) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:301: " +{-# LINE 301 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 301 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x y -> G.fourier (G.convolve x y) == G.multiply (G.fourier x) (G.fourier y)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:302: " +{-# LINE 302 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 302 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x -> nest 2 G.fourier x == G.reverse x) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:303: " +{-# LINE 303 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 303 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x a -> G.fourier (G.translate a x) == G.modulate a (G.fourier x)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:304: " +{-# LINE 304 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 304 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x (QC.Positive a) -> G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x))) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:305: " +{-# LINE 305 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 305 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x -> G.fourier (G.differentiate x) == mulLinear2i (G.fourier x)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:323: " +{-# LINE 323 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 323 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x y -> G.convolve (G.differentiate x) y == G.convolve x (G.differentiate y)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:348: " +{-# LINE 348 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 348 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x -> G.integrate (G.differentiate x) == (zero, x)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:349: " +{-# LINE 349 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 349 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x@(G.Cons b p) -> let (xoff,xint) = G.integrate x in G.differentiate xint == G.Cons b (p + Poly.const xoff)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:345: " +{-# LINE 345 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.example +{-# LINE 345 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (snd $ G.integrate $ G.differentiate $ G.Cons Bell.unit (Poly.fromCoeffs [7,7,7,7 :: Complex.T Rational])) + [ExpectedLine [LineChunk "Cons {bell = Cons {amp = 1 % 1, c0 = 0 % 1 +: 0 % 1, c1 = 0 % 1 +: 0 % 1, c2 = 1 % 1}, polynomial = Polynomial.fromCoeffs [7 % 1 +: 0 % 1,7 % 1 +: 0 % 1,7 % 1 +: 0 % 1,7 % 1 +: 0 % 1]}"]] + DocTest.printPrefix "MathObj.Gaussian.Polynomial:409: " +{-# LINE 409 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 409 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x a b -> G.translate a (G.translate b x) == G.translate (a+b) x) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:416: " +{-# LINE 416 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 416 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x a b -> G.translateComplex a (G.translateComplex b x) == G.translateComplex (a+b) x) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:417: " +{-# LINE 417 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 417 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x a -> G.translateComplex (Complex.fromReal a) x == G.translate a x) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:426: " +{-# LINE 426 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 426 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x a b -> G.modulate a (G.modulate b x) == G.modulate (a+b) x) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:427: " +{-# LINE 427 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 427 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x a b -> G.modulate b (G.translate a x) == G.turn (a*b) (G.translate a (G.modulate b x))) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:442: " +{-# LINE 442 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 442 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x -> nest 2 G.reverse x == x) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:451: " +{-# LINE 451 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 451 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x (QC.Positive a) (QC.Positive b) -> G.dilate a (G.dilate b x) == G.dilate (a*b) x) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:452: " +{-# LINE 452 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 452 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x (QC.Positive a) -> G.shrink a x == G.dilate (recip a) x) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:461: " +{-# LINE 461 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 461 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x (QC.Positive a) -> G.dilate a (G.shrink a x) == x) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:462: " +{-# LINE 462 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 462 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x (QC.Positive a) -> G.shrink a (G.dilate a x) == x) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:490: " +{-# LINE 490 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 490 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x (QC.NonZero unit) d -> G.approximateByBells unit (G.translateComplex d x) == map (mapSnd (Bell.translateComplex d)) (G.approximateByBells unit x)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:491: " +{-# LINE 491 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 491 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x (QC.NonZero unit) (QC.NonZero d) -> G.approximateByBells unit (G.dilate d x) == map (mapSnd (Bell.dilate d)) (G.approximateByBells (unit/d) x)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:492: " +{-# LINE 492 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 492 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (withRational $ \x (QC.NonZero unit) (QC.NonZero d) -> G.approximateByBells unit (G.shrink d x) == map (mapSnd (Bell.shrink d)) (G.approximateByBells (unit*d) x)) + DocTest.printPrefix "MathObj.Gaussian.Polynomial:512: " +{-# LINE 512 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + DocTest.property +{-# LINE 512 "gaussian/MathObj/Gaussian/Polynomial.hs" #-} + (\(QC.NonZero unit) d s p0 -> let p = Poly.fromCoeffs $ take 10 p0 in G.approximateByBellsAtOnce unit d s p == G.approximateByBellsByTranslation unit d (s::Rational) p) 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,227 +1,142 @@ -{-# 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 - -{- -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 --} +-- Do not edit! Automatically created with doctest-extract from gaussian/MathObj/Gaussian/Variance.hs +{-# LINE 34 "gaussian/MathObj/Gaussian/Variance.hs" #-} +module Test.MathObj.Gaussian.Variance where -simple :: - (Testable t) => - (G.T Rational -> t) -> IO () -simple f = - quickCheck (\x -> f (x :: G.T Rational)) +import qualified Test.DocTest.Driver as DocTest -tests :: HUnit.Test -tests = - HUnit.TestLabel "variance" $ - HUnit.TestList $ - map testUnit $ - testList +{-# LINE 35 "gaussian/MathObj/Gaussian/Variance.hs" #-} +import qualified MathObj.Gaussian.Variance as G +import MathObj.Gaussian.ExponentTuple (HoelderConjugates(HoelderConjugates)) +import MathObj.Gaussian.ExponentTuple (YoungConjugates(YoungConjugates)) +import qualified Algebra.Laws as Laws +import qualified Number.Root as Root +import NumericPrelude.Base as P +import NumericPrelude.Numeric as NP +import Prelude () +import qualified Test.QuickCheck as QC +import Data.Function.HT (Id, nest) -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. +asRational :: Id (G.T Rational) +asRational = id -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) : +withRational :: Id (G.T Rational -> a) +withRational = id -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) : - [] +test :: DocTest.T () +test = do + DocTest.printPrefix "MathObj.Gaussian.Variance:95: " +{-# LINE 95 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 95 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x y -> G.scalarProductRoot x y <= G.norm2Root x `Root.mul` G.norm2Root y) + DocTest.printPrefix "MathObj.Gaussian.Variance:99: " +{-# LINE 99 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 99 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x y -> G.scalarProductRoot x y <= G.norm1Root x `Root.mul` G.normInfRoot y) + DocTest.printPrefix "MathObj.Gaussian.Variance:100: " +{-# LINE 100 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 100 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x y (HoelderConjugates p q) -> G.scalarProductRoot x y <= G.normPRoot p x `Root.mul` G.normPRoot q y) + DocTest.printPrefix "MathObj.Gaussian.Variance:108: " +{-# LINE 108 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 108 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x -> G.norm1Root x == G.normPRoot 1 x) + DocTest.printPrefix "MathObj.Gaussian.Variance:114: " +{-# LINE 114 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 114 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x -> G.norm2Root x == G.normPRoot 2 x) + DocTest.printPrefix "MathObj.Gaussian.Variance:186: " +{-# LINE 186 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 186 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x (QC.Positive a) -> G.varianceRational (G.dilate a x) == a^2 * G.varianceRational x) + DocTest.printPrefix "MathObj.Gaussian.Variance:187: " +{-# LINE 187 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 187 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x y -> G.varianceRational (G.convolve x y) == G.varianceRational x + G.varianceRational y) + DocTest.printPrefix "MathObj.Gaussian.Variance:193: " +{-# LINE 193 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 193 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (Laws.identity G.multiply G.constant . asRational) + DocTest.printPrefix "MathObj.Gaussian.Variance:194: " +{-# LINE 194 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 194 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (Laws.commutative G.multiply . asRational) + DocTest.printPrefix "MathObj.Gaussian.Variance:195: " +{-# LINE 195 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 195 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (Laws.associative G.multiply . asRational) + DocTest.printPrefix "MathObj.Gaussian.Variance:228: " +{-# LINE 228 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 228 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (Laws.commutative G.convolve . asRational) + DocTest.printPrefix "MathObj.Gaussian.Variance:229: " +{-# LINE 229 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 229 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (Laws.associative G.convolve . asRational) + DocTest.printPrefix "MathObj.Gaussian.Variance:233: " +{-# LINE 233 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 233 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x y -> G.normInfRoot (G.convolve x y) <= G.norm1Root x `Root.mul` G.normInfRoot y) + DocTest.printPrefix "MathObj.Gaussian.Variance:234: " +{-# LINE 234 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 234 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x y (HoelderConjugates p q) -> G.normInfRoot (G.convolve x y) <= G.normPRoot p x `Root.mul` G.normPRoot q y) + DocTest.printPrefix "MathObj.Gaussian.Variance:235: " +{-# LINE 235 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 235 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x y (YoungConjugates p q r) -> G.normPRoot r (G.convolve x y) <= G.normPRoot p x `Root.mul` G.normPRoot q y) + DocTest.printPrefix "MathObj.Gaussian.Variance:251: " +{-# LINE 251 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 251 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x y -> G.fourier (G.convolve x y) == G.multiply (G.fourier x) (G.fourier y)) + DocTest.printPrefix "MathObj.Gaussian.Variance:252: " +{-# LINE 252 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 252 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x -> nest 4 G.fourier x == x) + DocTest.printPrefix "MathObj.Gaussian.Variance:253: " +{-# LINE 253 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 253 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x (QC.Positive a) -> G.fourier (G.dilate a x) == G.amplify a (G.shrink a (G.fourier x))) + DocTest.printPrefix "MathObj.Gaussian.Variance:254: " +{-# LINE 254 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 254 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x y -> G.scalarProductRoot x y == G.scalarProductRoot (G.fourier x) (G.fourier y)) + DocTest.printPrefix "MathObj.Gaussian.Variance:265: " +{-# LINE 265 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 265 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x (QC.Positive a) (QC.Positive b) -> G.dilate a (G.dilate b x) == G.dilate (a*b) x) + DocTest.printPrefix "MathObj.Gaussian.Variance:266: " +{-# LINE 266 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 266 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x (QC.Positive a) -> G.shrink a x == G.dilate (recip a) x) + DocTest.printPrefix "MathObj.Gaussian.Variance:273: " +{-# LINE 273 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 273 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x (QC.Positive a) -> G.dilate a (G.shrink a x) == x) + DocTest.printPrefix "MathObj.Gaussian.Variance:274: " +{-# LINE 274 "gaussian/MathObj/Gaussian/Variance.hs" #-} + DocTest.property +{-# LINE 274 "gaussian/MathObj/Gaussian/Variance.hs" #-} + (withRational $ \x (QC.Positive a) -> G.shrink a (G.dilate a x) == x) 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,107 +1,122 @@ -{-# 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 System.Random as Random +-- Do not edit! Automatically created with doctest-extract from src/MathObj/Matrix.hs +{-# LINE 71 "src/MathObj/Matrix.hs" #-} -import Data.Function.HT (nest, ) +module Test.MathObj.Matrix where -import Test.NumericPrelude.Utility (testUnit, ) -import Test.QuickCheck (Arbitrary(arbitrary), quickCheck, ) -import qualified Test.QuickCheck as QC -import qualified Test.HUnit as HUnit +import qualified Test.DocTest.Driver as DocTest +{-# LINE 72 "src/MathObj/Matrix.hs" #-} +import qualified MathObj.Matrix as Matrix +import qualified Algebra.Ring as Ring +import qualified Algebra.Laws as Laws +import Test.NumericPrelude.Utility ((/\)) +import qualified Test.QuickCheck as QC +import NumericPrelude.Numeric as NP +import NumericPrelude.Base as P +import Prelude () -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP +import Control.Monad (replicateM, join) +import Control.Applicative (liftA2) +import Data.Function.HT (nest) +genDimension :: QC.Gen Int +genDimension = QC.choose (0,20) -type Seed = Int -newtype Dimension = Dimension {unDim :: Int} - deriving (Show) +genMatrixFor :: (QC.Arbitrary a) => Int -> Int -> QC.Gen (Matrix.T a) +genMatrixFor m n = + fmap (Matrix.fromList m n) $ replicateM (m*n) QC.arbitrary -instance Arbitrary Dimension where - arbitrary = fmap Dimension $ QC.choose (0,20) +genMatrix :: (QC.Arbitrary a) => QC.Gen (Matrix.T a) +genMatrix = join $ liftA2 genMatrixFor genDimension genDimension +genIntMatrix :: QC.Gen (Matrix.T Integer) +genIntMatrix = genMatrix -random :: Dimension -> Dimension -> Seed -> Matrix.T Integer -random mn nn seed = - fst $ - Matrix.random (unDim mn) (unDim nn) $ - Random.mkStdGen seed +genFactorMatrix :: (QC.Arbitrary a) => Matrix.T a -> QC.Gen (Matrix.T a) +genFactorMatrix a = genMatrixFor (Matrix.numColumns a) =<< genDimension +genSameMatrix :: (QC.Arbitrary a) => Matrix.T a -> QC.Gen (Matrix.T a) +genSameMatrix = uncurry genMatrixFor . Matrix.dimension -tests :: HUnit.Test -tests = - HUnit.TestLabel "matrix" $ - HUnit.TestList $ - map testUnit $ - ("dimension", - quickCheck (\m n a -> - (unDim m, unDim 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 (unDim m) (unDim n) (Matrix.rows a))) : - ("to and from columns", - quickCheck (\m n a' -> - let a = random m n a' - in a == Matrix.fromColumns (unDim m) (unDim 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 (unDim m) (unDim 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 = unDim 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 (unDim m)) (random m n a))) : - ("multiplication, one right", - quickCheck (\m n a -> - Laws.rightIdentity (*) (Matrix.one (unDim 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 (unDim m)))) : -{- - ("division", quickCheck (\x -> Integral.propInverse (x :: Poly.T Rational))) : --} - [] +test :: DocTest.T () +test = do + DocTest.printPrefix "MathObj.Matrix:118: " +{-# LINE 118 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 118 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> Matrix.rows a == Matrix.columns (Matrix.transpose a)) + DocTest.printPrefix "MathObj.Matrix:119: " +{-# LINE 119 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 119 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> Matrix.columns a == Matrix.rows (Matrix.transpose a)) + DocTest.printPrefix "MathObj.Matrix:120: " +{-# LINE 120 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 120 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> genSameMatrix a /\ \b -> Laws.homomorphism Matrix.transpose (+) (+) a b) + DocTest.printPrefix "MathObj.Matrix:141: " +{-# LINE 141 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 141 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> a == uncurry Matrix.fromRows (Matrix.dimension a) (Matrix.rows a)) + DocTest.printPrefix "MathObj.Matrix:152: " +{-# LINE 152 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 152 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> a == uncurry Matrix.fromColumns (Matrix.dimension a) (Matrix.columns a)) + DocTest.printPrefix "MathObj.Matrix:195: " +{-# LINE 195 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 195 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> genSameMatrix a /\ \b -> Laws.commutative (+) a b) + DocTest.printPrefix "MathObj.Matrix:196: " +{-# LINE 196 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 196 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> genSameMatrix a /\ \b -> genSameMatrix b /\ \c -> Laws.associative (+) a b c) + DocTest.printPrefix "MathObj.Matrix:212: " +{-# LINE 212 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 212 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> Laws.identity (+) (uncurry Matrix.zero $ Matrix.dimension a) a) + DocTest.printPrefix "MathObj.Matrix:228: " +{-# LINE 228 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 228 "src/MathObj/Matrix.hs" #-} + (genDimension /\ \n -> Matrix.one n == Matrix.diagonal (replicate n Ring.one :: [Integer])) + DocTest.printPrefix "MathObj.Matrix:242: " +{-# LINE 242 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 242 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> Laws.leftIdentity (*) (Matrix.one (Matrix.numRows a)) a) + DocTest.printPrefix "MathObj.Matrix:243: " +{-# LINE 243 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 243 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> Laws.rightIdentity (*) (Matrix.one (Matrix.numColumns a)) a) + DocTest.printPrefix "MathObj.Matrix:244: " +{-# LINE 244 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 244 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> genFactorMatrix a /\ \b -> Laws.homomorphism Matrix.transpose (*) (flip (*)) a b) + DocTest.printPrefix "MathObj.Matrix:245: " +{-# LINE 245 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 245 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> genFactorMatrix a /\ \b -> genFactorMatrix b /\ \c -> Laws.associative (*) a b c) + DocTest.printPrefix "MathObj.Matrix:246: " +{-# LINE 246 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 246 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \b -> genSameMatrix b /\ \c -> genFactorMatrix b /\ \a -> Laws.leftDistributive (*) (+) a b c) + DocTest.printPrefix "MathObj.Matrix:247: " +{-# LINE 247 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 247 "src/MathObj/Matrix.hs" #-} + (genIntMatrix /\ \a -> genFactorMatrix a /\ \b -> genSameMatrix b /\ \c -> Laws.rightDistributive (*) (+) a b c) + DocTest.printPrefix "MathObj.Matrix:248: " +{-# LINE 248 "src/MathObj/Matrix.hs" #-} + DocTest.property +{-# LINE 248 "src/MathObj/Matrix.hs" #-} + (QC.choose (0,10) /\ \k -> genDimension /\ \n -> genMatrixFor n n /\ \a -> a^k == nest (fromInteger k) ((a::Matrix.T Integer)*) (Matrix.one n)) 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,206 +1,137 @@ -{-# 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 Test.NumericPrelude.Utility (testUnit) -import Test.QuickCheck (quickCheck) -import qualified Test.HUnit as HUnit - - -import qualified Control.Monad.HT as M - -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) : - [] +-- Do not edit! Automatically created with doctest-extract from src/MathObj/PartialFraction.hs +{-# LINE 45 "src/MathObj/PartialFraction.hs" #-} +module Test.MathObj.PartialFraction where -{- * Properties for Polynomials -} +import qualified Test.DocTest.Driver as DocTest -newtype IrredPoly = IrredPoly {polyFromIrredPoly :: Poly.T Rational} +{-# LINE 46 "src/MathObj/PartialFraction.hs" #-} +import qualified MathObj.PartialFraction as PartialFraction +import qualified MathObj.Polynomial.Core as PolyCore +import qualified MathObj.Polynomial as Poly +import qualified Algebra.PrincipalIdealDomain as PID +import qualified Algebra.Indexable as Indexable +import qualified Algebra.Laws as Laws +import qualified Number.Ratio as Ratio +import Test.NumericPrelude.Utility ((/\)) +import qualified Test.QuickCheck as QC +import NumericPrelude.Numeric as NP +import NumericPrelude.Base as P +import Prelude () -type RatPolynomial = Poly.T Rational -type PolyFraction = ([IrredPoly],RatPolynomial) +import Control.Applicative (liftA2) -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)) +{- | +Generator of 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. +-} -- +genSmallPrime :: QC.Gen Integer +genSmallPrime = + let primes = [2,3,5,7,11,13] + in QC.elements (primes ++ map negate primes) -instance Show IrredPoly where - show = show . polyFromIrredPoly +genPartialFractionInt :: QC.Gen (PartialFraction.T Integer) +genPartialFractionInt = + liftA2 PartialFraction.fromFactoredFraction + (QC.listOf genSmallPrime) QC.arbitrary -fractionConvPoly :: [IrredPoly] -> RatPolynomial -> Bool -fractionConvPoly = - fractionConv . map polyFromIrredPoly - -fractionConvAltPoly :: [IrredPoly] -> RatPolynomial -> Bool -fractionConvAltPoly = - fractionConvAlt . map polyFromIrredPoly +genIrreduciblePolynomial :: QC.Gen (Poly.T Rational) +genIrreduciblePolynomial = do + QC.NonZero unit <- QC.arbitrary + fmap (Poly.fromCoeffs . map (unit*)) $ + QC.elements [[2,3],[2,0,1],[3,0,1],[1,-3,0,1]] -fromIrredPolys :: PolyFraction -> PartialFraction.T RatPolynomial -fromIrredPolys (xs,y) = - PartialFraction.fromFactoredFraction (map polyFromIrredPoly xs) y +genPartialFractionPoly :: QC.Gen (PartialFraction.T (Poly.T Rational)) +genPartialFractionPoly = + liftA2 PartialFraction.fromFactoredFraction + (fmap (take 3) $ QC.listOf genIrreduciblePolynomial) + (fmap (Poly.fromCoeffs . PolyCore.normalize . take 5) QC.arbitrary) -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) - +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 -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) : - [] +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, sub, mul :: + (PID.C a, Indexable.C a) => + PartialFraction.T a -> PartialFraction.T a -> Bool +add = Laws.homomorphism PartialFraction.toFraction (+) (+) +sub = Laws.homomorphism PartialFraction.toFraction (-) (-) +mul = Laws.homomorphism PartialFraction.toFraction (*) (*) -tests :: HUnit.Test -tests = - HUnit.TestLabel "partial fraction" $ - HUnit.TestList $ - intTests : --- polyTests : - [] +test :: DocTest.T () +test = do + DocTest.printPrefix "MathObj.PartialFraction:195: " +{-# LINE 195 "src/MathObj/PartialFraction.hs" #-} + DocTest.property +{-# LINE 195 "src/MathObj/PartialFraction.hs" #-} + (QC.listOf genSmallPrime /\ fractionConv) + DocTest.printPrefix "MathObj.PartialFraction:196: " +{-# LINE 196 "src/MathObj/PartialFraction.hs" #-} + DocTest.property +{-# LINE 196 "src/MathObj/PartialFraction.hs" #-} + (fmap (take 3) (QC.listOf genIrreduciblePolynomial) /\ fractionConv) + DocTest.printPrefix "MathObj.PartialFraction:220: " +{-# LINE 220 "src/MathObj/PartialFraction.hs" #-} + DocTest.property +{-# LINE 220 "src/MathObj/PartialFraction.hs" #-} + (QC.listOf genSmallPrime /\ fractionConvAlt) + DocTest.printPrefix "MathObj.PartialFraction:221: " +{-# LINE 221 "src/MathObj/PartialFraction.hs" #-} + DocTest.property +{-# LINE 221 "src/MathObj/PartialFraction.hs" #-} + (fmap (take 3) (QC.listOf genIrreduciblePolynomial) /\ fractionConvAlt) + DocTest.printPrefix "MathObj.PartialFraction:297: " +{-# LINE 297 "src/MathObj/PartialFraction.hs" #-} + DocTest.property +{-# LINE 297 "src/MathObj/PartialFraction.hs" #-} + (genPartialFractionInt /\ \x -> genPartialFractionInt /\ \y -> add x y) + DocTest.printPrefix "MathObj.PartialFraction:298: " +{-# LINE 298 "src/MathObj/PartialFraction.hs" #-} + DocTest.property +{-# LINE 298 "src/MathObj/PartialFraction.hs" #-} + (genPartialFractionInt /\ \x -> genPartialFractionInt /\ \y -> sub x y) + DocTest.printPrefix "MathObj.PartialFraction:300: " +{-# LINE 300 "src/MathObj/PartialFraction.hs" #-} + DocTest.property +{-# LINE 300 "src/MathObj/PartialFraction.hs" #-} + (genPartialFractionPoly /\ \x -> genPartialFractionPoly /\ \y -> add x y) + DocTest.printPrefix "MathObj.PartialFraction:301: " +{-# LINE 301 "src/MathObj/PartialFraction.hs" #-} + DocTest.property +{-# LINE 301 "src/MathObj/PartialFraction.hs" #-} + (genPartialFractionPoly /\ \x -> genPartialFractionPoly /\ \y -> sub x y) + DocTest.printPrefix "MathObj.PartialFraction:429: " +{-# LINE 429 "src/MathObj/PartialFraction.hs" #-} + DocTest.property +{-# LINE 429 "src/MathObj/PartialFraction.hs" #-} + (genPartialFractionInt /\ \x k -> scaleInt k x) + DocTest.printPrefix "MathObj.PartialFraction:430: " +{-# LINE 430 "src/MathObj/PartialFraction.hs" #-} + DocTest.property +{-# LINE 430 "src/MathObj/PartialFraction.hs" #-} + (genPartialFractionPoly /\ \x k -> scaleInt k x) + DocTest.printPrefix "MathObj.PartialFraction:449: " +{-# LINE 449 "src/MathObj/PartialFraction.hs" #-} + DocTest.property +{-# LINE 449 "src/MathObj/PartialFraction.hs" #-} + (genPartialFractionInt /\ \x -> genPartialFractionInt /\ \y -> mul x y) + DocTest.printPrefix "MathObj.PartialFraction:450: " +{-# LINE 450 "src/MathObj/PartialFraction.hs" #-} + DocTest.property +{-# LINE 450 "src/MathObj/PartialFraction.hs" #-} + (genPartialFractionPoly /\ \x -> genPartialFractionPoly /\ \y -> mul x y) 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,88 +1,63 @@ -{-# 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 Data.Tuple.HT (mapPair, mapSnd, ) - -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) - -divNormal :: [Rational] -> [Rational] -> Property -divNormal x y = - case (PolyCore.normalize x, PolyCore.normalize y) of - (nx, ny) -> - not (null ny) ==> - mapSnd PolyCore.normalize (PolyCore.divMod nx ny) - == - mapPair - (PolyCore.normalize, PolyCore.normalize) - (PolyCore.divMod x y) - -normalizedQuotient :: [Rational] -> [Rational] -> Property -normalizedQuotient x y = - case PolyCore.normalize x of - nx -> - not (isZero y) ==> - let z = fst $ PolyCore.divMod nx y - in PolyCore.normalize z == z +-- Do not edit! Automatically created with doctest-extract from src/MathObj/Polynomial.hs +{-# LINE 84 "src/MathObj/Polynomial.hs" #-} -modulusSize :: [Rational] -> [Rational] -> Property -modulusSize x y = - case PolyCore.normalize y of - ny -> - not (null ny) ==> - List.length (snd $ PolyCore.divMod x y) - < - List.length ny +module Test.MathObj.Polynomial where +import qualified Test.DocTest.Driver as DocTest -test :: Testable a => (Poly.T Integer -> a) -> IO () -test = quickCheck +{-# LINE 85 "src/MathObj/Polynomial.hs" #-} +import qualified MathObj.Polynomial as Poly +import qualified Algebra.IntegralDomain as Integral +import qualified Algebra.Laws as Laws +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () -testRat :: Testable a => (Poly.T Rational -> a) -> IO () -testRat = quickCheck +intPoly :: Poly.T Integer -> Poly.T Integer +intPoly = id +ratioPoly :: Poly.T Rational -> Poly.T Rational +ratioPoly = id -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) : - ("division, normalize", quickCheck divNormal) : - ("normalized quotient", quickCheck normalizedQuotient) : - ("modulus size", quickCheck modulusSize) : - [] +test :: DocTest.T () +test = do + DocTest.printPrefix "MathObj.Polynomial:100: " +{-# LINE 100 "src/MathObj/Polynomial.hs" #-} + DocTest.property +{-# LINE 100 "src/MathObj/Polynomial.hs" #-} + (Laws.identity (+) zero . intPoly) + DocTest.printPrefix "MathObj.Polynomial:101: " +{-# LINE 101 "src/MathObj/Polynomial.hs" #-} + DocTest.property +{-# LINE 101 "src/MathObj/Polynomial.hs" #-} + (Laws.commutative (+) . intPoly) + DocTest.printPrefix "MathObj.Polynomial:102: " +{-# LINE 102 "src/MathObj/Polynomial.hs" #-} + DocTest.property +{-# LINE 102 "src/MathObj/Polynomial.hs" #-} + (Laws.associative (+) . intPoly) + DocTest.printPrefix "MathObj.Polynomial:103: " +{-# LINE 103 "src/MathObj/Polynomial.hs" #-} + DocTest.property +{-# LINE 103 "src/MathObj/Polynomial.hs" #-} + (Laws.identity (*) one . intPoly) + DocTest.printPrefix "MathObj.Polynomial:104: " +{-# LINE 104 "src/MathObj/Polynomial.hs" #-} + DocTest.property +{-# LINE 104 "src/MathObj/Polynomial.hs" #-} + (Laws.commutative (*) . intPoly) + DocTest.printPrefix "MathObj.Polynomial:105: " +{-# LINE 105 "src/MathObj/Polynomial.hs" #-} + DocTest.property +{-# LINE 105 "src/MathObj/Polynomial.hs" #-} + (Laws.associative (*) . intPoly) + DocTest.printPrefix "MathObj.Polynomial:106: " +{-# LINE 106 "src/MathObj/Polynomial.hs" #-} + DocTest.property +{-# LINE 106 "src/MathObj/Polynomial.hs" #-} + (Laws.leftDistributive (*) (+) . intPoly) + DocTest.printPrefix "MathObj.Polynomial:107: " +{-# LINE 107 "src/MathObj/Polynomial.hs" #-} + DocTest.property +{-# LINE 107 "src/MathObj/Polynomial.hs" #-} + (Integral.propInverse . ratioPoly) diff --git a/test/Test/MathObj/Polynomial/Core.hs b/test/Test/MathObj/Polynomial/Core.hs new file mode 100644 --- /dev/null +++ b/test/Test/MathObj/Polynomial/Core.hs @@ -0,0 +1,51 @@ +-- Do not edit! Automatically created with doctest-extract from src/MathObj/Polynomial/Core.hs +{-# LINE 47 "src/MathObj/Polynomial/Core.hs" #-} + +module Test.MathObj.Polynomial.Core where + +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 48 "src/MathObj/Polynomial/Core.hs" #-} +import qualified MathObj.Polynomial.Core as PolyCore +import qualified MathObj.Polynomial as Poly +import qualified Data.List as List +import qualified Test.QuickCheck as QC +import Test.QuickCheck ((==>)) +import Data.Tuple.HT (mapPair, mapSnd) +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () + +intPoly :: [Integer] -> [Integer] +intPoly = id + +ratioPoly :: [Rational] -> [Rational] +ratioPoly = id + +test :: DocTest.T () +test = do + DocTest.printPrefix "MathObj.Polynomial.Core:136: " +{-# LINE 136 "src/MathObj/Polynomial/Core.hs" #-} + DocTest.property +{-# LINE 136 "src/MathObj/Polynomial/Core.hs" #-} + (\(QC.NonEmpty xs) (QC.NonEmpty ys) -> PolyCore.tensorProduct xs ys == List.transpose (PolyCore.tensorProduct ys (intPoly xs))) + DocTest.printPrefix "MathObj.Polynomial.Core:161: " +{-# LINE 161 "src/MathObj/Polynomial/Core.hs" #-} + DocTest.property +{-# LINE 161 "src/MathObj/Polynomial/Core.hs" #-} + (\xs ys -> PolyCore.equal (intPoly $ PolyCore.mul xs ys) (PolyCore.mulShear xs ys)) + DocTest.printPrefix "MathObj.Polynomial.Core:173: " +{-# LINE 173 "src/MathObj/Polynomial/Core.hs" #-} + DocTest.property +{-# LINE 173 "src/MathObj/Polynomial/Core.hs" #-} + (\x y -> case (PolyCore.normalize x, PolyCore.normalize y) of (nx, ny) -> not (null (ratioPoly ny)) ==> mapSnd PolyCore.normalize (PolyCore.divMod nx ny) == mapPair (PolyCore.normalize, PolyCore.normalize) (PolyCore.divMod x y)) + DocTest.printPrefix "MathObj.Polynomial.Core:174: " +{-# LINE 174 "src/MathObj/Polynomial/Core.hs" #-} + DocTest.property +{-# LINE 174 "src/MathObj/Polynomial/Core.hs" #-} + (\x y -> not (isZero (ratioPoly y)) ==> let z = fst $ PolyCore.divMod (Poly.coeffs x) y in PolyCore.normalize z == z) + DocTest.printPrefix "MathObj.Polynomial.Core:175: " +{-# LINE 175 "src/MathObj/Polynomial/Core.hs" #-} + DocTest.property +{-# LINE 175 "src/MathObj/Polynomial/Core.hs" #-} + (\x y -> case PolyCore.normalize $ ratioPoly y of ny -> not (null ny) ==> List.length (snd $ PolyCore.divMod x y) < List.length ny) 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,165 +1,23 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Test.MathObj.PowerSeries where - -import qualified MathObj.PowerSeries as PST -import qualified MathObj.PowerSeries.Core as PS -import qualified MathObj.PowerSeries.Example as PSE - -import qualified Test.QuickCheck.Modifiers as Mod -import Test.NumericPrelude.Utility (equalInfLists, testUnit) -import Test.QuickCheck (quickCheck) --- 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])) : - [] - -identitiesHoles :: [(String, Int, [Rational] -> [Rational], Rational)] -identitiesHoles = - ("exp", 30, PS.exp (\0 -> 1), 0) : - ("log", 30, PS.log (\1 -> 0), 1) : - ("tan", 20, PS.tan (\0 -> (0,1)), 0) : - ("atan", 20, PS.atan (\0 -> 0), 0) : - ("sin", 20, PS.sin (\0 -> (0,1)), 0) : - ("cos", 20, PS.cos (\0 -> (0,1)), 0) : - ("asin", 30, PS.asin (\1 -> 1) (\0 -> 0), 0) : - ("sqrt", 50, PS.sqrt (\1 -> 1), 1) : - ("pow13", 30, PS.pow (\1 -> 1) (1/3), 1) : - ("pow25", 30, PS.pow (\1 -> 1) (2/5), 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])) - - -holesMultiplicative :: Int -> Int -> Int -> [Rational] -> Bool -holesMultiplicative trunc expon0 expon1 xs = - let n0 = 1 + mod expon0 10 - n1 = 1 + mod expon1 10 - in equalInfLists trunc - [PS.insertHoles n0 $ PS.insertHoles n1 xs, - PS.insertHoles n1 $ PS.insertHoles n0 xs, - PS.insertHoles (n0*n1) xs] - -testHolesIdentity :: - (String, Int, [Rational] -> [Rational], Rational) -> HUnit.Test -testHolesIdentity (label, len, f, x0) = - HUnit.test $ testUnit $ (,) ("holes in " ++ label) $ - quickCheck $ \expon0 xs -> checkHoles len expon0 f x0 xs - - -checkHoles :: - Int -> Int -> ([Rational] -> [Rational]) -> - Rational -> [Rational] -> Bool -checkHoles trunc expon0 f x xs = - let expon = 1 + mod expon0 10 - in equalInfLists trunc - [(f $ PS.insertHoles expon (x:xs)) ++ repeat zero, - (PS.insertHoles expon $ f $ x:xs) ++ repeat zero] - - -powerMultSeries :: Int -> Integer -> Mod.Positive Rational -> [Rational] -> Bool -powerMultSeries trunc expon0 xp xs = - let expon = 1 + mod expon0 10 - x = Mod.getPositive xp - xt = x:xs - in equalInfLists trunc - [PS.pow - (const x) (1 % expon) - (PST.coeffs (PST.fromCoeffs xt ^ expon)) - ++ repeat zero, - xt ++ repeat zero] - -powerMult :: Int -> Rational -> Rational -> Bool -powerMult trunc exp0 exp1 = - equalInfLists trunc - [PS.mul (PSE.pow exp0) (PSE.pow exp1), PSE.pow (exp0+exp1)] +-- Do not edit! Automatically created with doctest-extract from src/MathObj/PowerSeries.hs +{-# LINE 30 "src/MathObj/PowerSeries.hs" #-} -powerExplODE :: Int -> Rational -> Bool -powerExplODE trunc expon = - equalInfLists trunc [PSE.powODE expon, PSE.powExpl expon] +module Test.MathObj.PowerSeries where -invDiff :: Int -> Rational -> Mod.NonZero Rational -> [Rational] -> Bool -invDiff trunc x0 x1 xs_ = - let xs = x0 : Mod.getNonZero x1 : xs_ - (y,ys) = PS.inv xs - (z,zs) = PS.invDiff xs - in y==z && equalInfLists trunc [ys, zs] +import qualified Test.DocTest.Driver as DocTest +{-# LINE 31 "src/MathObj/PowerSeries.hs" #-} +import qualified MathObj.PowerSeries.Core as PS +import qualified MathObj.PowerSeries as PST +import qualified Test.QuickCheck as QC +import Test.NumericPrelude.Utility (equalTrunc, (/\)) +import NumericPrelude.Numeric as NP +import NumericPrelude.Base as P +import Prelude () -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 testHolesIdentity identitiesHoles - ++ - (map testUnit $ - ("multiplicative holes", quickCheck (holesMultiplicative 100)) : - ("powers of series", quickCheck (powerMultSeries 15)) : - ("products of powers", quickCheck (powerMult 30)) : - ("power explicit vs. ODE", quickCheck (powerExplODE 50)) : - ("inv vs. invDiff", quickCheck (invDiff 15)) : - []) - ] +test :: DocTest.T () +test = do + DocTest.printPrefix "MathObj.PowerSeries:141: " +{-# LINE 141 "src/MathObj/PowerSeries.hs" #-} + DocTest.property +{-# LINE 141 "src/MathObj/PowerSeries.hs" #-} + (QC.choose (1,10) /\ \expon (QC.Positive x) xs -> let xt = x:xs in equalTrunc 15 (PS.pow (const x) (1 % expon) (PST.coeffs (PST.fromCoeffs xt ^ expon)) ++ repeat zero) (xt ++ repeat zero)) diff --git a/test/Test/MathObj/PowerSeries/Core.hs b/test/Test/MathObj/PowerSeries/Core.hs new file mode 100644 --- /dev/null +++ b/test/Test/MathObj/PowerSeries/Core.hs @@ -0,0 +1,178 @@ +-- Do not edit! Automatically created with doctest-extract from src/MathObj/PowerSeries/Core.hs +{-# LINE 23 "src/MathObj/PowerSeries/Core.hs" #-} + +module Test.MathObj.PowerSeries.Core where + +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 24 "src/MathObj/PowerSeries/Core.hs" #-} +import qualified MathObj.PowerSeries.Core as PS +import qualified MathObj.PowerSeries.Example as PSE +import Test.NumericPrelude.Utility (equalTrunc, (/\)) +import qualified Test.QuickCheck as QC +import NumericPrelude.Numeric as NP +import NumericPrelude.Base as P +import Prelude () +import Control.Applicative (liftA3) + +checkHoles :: + Int -> ([Rational] -> [Rational]) -> + Rational -> [Rational] -> QC.Property +checkHoles trunc f x xs = + QC.choose (1,10) /\ \expon -> + equalTrunc trunc + (f (PS.insertHoles expon (x:xs)) ++ repeat zero) + (PS.insertHoles expon (f (x:xs)) ++ repeat zero) + +genInvertible :: QC.Gen [Rational] +genInvertible = + liftA3 (\x0 x1 xs -> x0:x1:xs) + QC.arbitrary (fmap QC.getNonZero QC.arbitrary) QC.arbitrary + +test :: DocTest.T () +test = do + DocTest.printPrefix "MathObj.PowerSeries.Core:108: " +{-# LINE 108 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 108 "src/MathObj/PowerSeries/Core.hs" #-} + (QC.choose (1,10) /\ \m -> QC.choose (1,10) /\ \n xs -> equalTrunc 100 (PS.insertHoles m $ PS.insertHoles n xs) (PS.insertHoles (m*n) xs)) + DocTest.printPrefix "MathObj.PowerSeries.Core:190: " +{-# LINE 190 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 190 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 50 PSE.sqrtExpl (PS.sqrt (\1 -> 1) [1,1])) + DocTest.printPrefix "MathObj.PowerSeries.Core:191: " +{-# LINE 191 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 191 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 500 (1:1:repeat 0) (PS.sqrt (\1 -> 1) (PS.mul [1,1] [1,1]))) + DocTest.printPrefix "MathObj.PowerSeries.Core:192: " +{-# LINE 192 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 192 "src/MathObj/PowerSeries/Core.hs" #-} + (checkHoles 50 (PS.sqrt (\1 -> 1)) 1) + DocTest.printPrefix "MathObj.PowerSeries.Core:217: " +{-# LINE 217 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 217 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 100 (PSE.powExpl (-1/3)) (PS.pow (\1 -> 1) (-1/3) [1,1])) + DocTest.printPrefix "MathObj.PowerSeries.Core:218: " +{-# LINE 218 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 218 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 50 (PSE.powExpl (-1/3)) (PS.exp (\0 -> 1) (PS.scale (-1/3) PSE.log))) + DocTest.printPrefix "MathObj.PowerSeries.Core:219: " +{-# LINE 219 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 219 "src/MathObj/PowerSeries/Core.hs" #-} + (checkHoles 30 (PS.pow (\1 -> 1) (1/3)) 1) + DocTest.printPrefix "MathObj.PowerSeries.Core:220: " +{-# LINE 220 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 220 "src/MathObj/PowerSeries/Core.hs" #-} + (checkHoles 30 (PS.pow (\1 -> 1) (2/5)) 1) + DocTest.printPrefix "MathObj.PowerSeries.Core:237: " +{-# LINE 237 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 237 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 500 PSE.expExpl (PS.exp (\0 -> 1) [0,1])) + DocTest.printPrefix "MathObj.PowerSeries.Core:238: " +{-# LINE 238 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 238 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 100 (1:1:repeat 0) (PS.exp (\0 -> 1) PSE.log)) + DocTest.printPrefix "MathObj.PowerSeries.Core:239: " +{-# LINE 239 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 239 "src/MathObj/PowerSeries/Core.hs" #-} + (checkHoles 30 (PS.exp (\0 -> 1)) 0) + DocTest.printPrefix "MathObj.PowerSeries.Core:259: " +{-# LINE 259 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 259 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 500 PSE.sinExpl (PS.sin (\0 -> (0,1)) [0,1])) + DocTest.printPrefix "MathObj.PowerSeries.Core:260: " +{-# LINE 260 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 260 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 50 (0:1:repeat 0) (PS.sin (\0 -> (0,1)) PSE.asin)) + DocTest.printPrefix "MathObj.PowerSeries.Core:261: " +{-# LINE 261 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 261 "src/MathObj/PowerSeries/Core.hs" #-} + (checkHoles 20 (PS.sin (\0 -> (0,1))) 0) + DocTest.printPrefix "MathObj.PowerSeries.Core:266: " +{-# LINE 266 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 266 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 500 PSE.cosExpl (PS.cos (\0 -> (0,1)) [0,1])) + DocTest.printPrefix "MathObj.PowerSeries.Core:267: " +{-# LINE 267 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 267 "src/MathObj/PowerSeries/Core.hs" #-} + (checkHoles 20 (PS.cos (\0 -> (0,1))) 0) + DocTest.printPrefix "MathObj.PowerSeries.Core:273: " +{-# LINE 273 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 273 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 50 PSE.tanExpl (PS.tan (\0 -> (0,1)) [0,1])) + DocTest.printPrefix "MathObj.PowerSeries.Core:274: " +{-# LINE 274 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 274 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 50 (0:1:repeat 0) (PS.tan (\0 -> (0,1)) PSE.atan)) + DocTest.printPrefix "MathObj.PowerSeries.Core:275: " +{-# LINE 275 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 275 "src/MathObj/PowerSeries/Core.hs" #-} + (checkHoles 20 (PS.tan (\0 -> (0,1))) 0) + DocTest.printPrefix "MathObj.PowerSeries.Core:289: " +{-# LINE 289 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 289 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 500 PSE.logExpl (PS.log (\1 -> 0) [1,1])) + DocTest.printPrefix "MathObj.PowerSeries.Core:290: " +{-# LINE 290 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 290 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 100 (0:1:repeat 0) (PS.log (\1 -> 0) PSE.exp)) + DocTest.printPrefix "MathObj.PowerSeries.Core:291: " +{-# LINE 291 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 291 "src/MathObj/PowerSeries/Core.hs" #-} + (checkHoles 30 (PS.log (\1 -> 0)) 1) + DocTest.printPrefix "MathObj.PowerSeries.Core:303: " +{-# LINE 303 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 303 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 500 PSE.atan (PS.atan (\0 -> 0) [0,1])) + DocTest.printPrefix "MathObj.PowerSeries.Core:304: " +{-# LINE 304 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 304 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 50 (0:1:repeat 0) (PS.atan (\0 -> 0) PSE.tan)) + DocTest.printPrefix "MathObj.PowerSeries.Core:305: " +{-# LINE 305 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 305 "src/MathObj/PowerSeries/Core.hs" #-} + (checkHoles 20 (PS.atan (\0 -> 0)) 0) + DocTest.printPrefix "MathObj.PowerSeries.Core:313: " +{-# LINE 313 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 313 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 100 (0:1:repeat 0) (PS.asin (\1 -> 1) (\0 -> 0) PSE.sin)) + DocTest.printPrefix "MathObj.PowerSeries.Core:314: " +{-# LINE 314 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 314 "src/MathObj/PowerSeries/Core.hs" #-} + (equalTrunc 50 PSE.asin (PS.asin (\1 -> 1) (\0 -> 0) [0,1])) + DocTest.printPrefix "MathObj.PowerSeries.Core:315: " +{-# LINE 315 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 315 "src/MathObj/PowerSeries/Core.hs" #-} + (checkHoles 30 (PS.asin (\1 -> 1) (\0 -> 0)) 0) + DocTest.printPrefix "MathObj.PowerSeries.Core:383: " +{-# LINE 383 "src/MathObj/PowerSeries/Core.hs" #-} + DocTest.property +{-# LINE 383 "src/MathObj/PowerSeries/Core.hs" #-} + (genInvertible /\ \xs -> let (y,ys) = PS.inv xs; (z,zs) = PS.invDiff xs in y==z && equalTrunc 15 ys zs) diff --git a/test/Test/MathObj/PowerSeries/Example.hs b/test/Test/MathObj/PowerSeries/Example.hs new file mode 100644 --- /dev/null +++ b/test/Test/MathObj/PowerSeries/Example.hs @@ -0,0 +1,92 @@ +-- Do not edit! Automatically created with doctest-extract from src/MathObj/PowerSeries/Example.hs +{-# LINE 21 "src/MathObj/PowerSeries/Example.hs" #-} + +module Test.MathObj.PowerSeries.Example where + +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 22 "src/MathObj/PowerSeries/Example.hs" #-} +import qualified MathObj.PowerSeries.Core as PS +import qualified MathObj.PowerSeries.Example as PSE +import Test.NumericPrelude.Utility (equalTrunc) +import NumericPrelude.Numeric as NP +import NumericPrelude.Base as P +import Prelude () + +test :: DocTest.T () +test = do + DocTest.printPrefix "MathObj.PowerSeries.Example:55: " +{-# LINE 55 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 55 "src/MathObj/PowerSeries/Example.hs" #-} + (\m n -> equalTrunc 30 (PS.mul (PSE.pow m) (PSE.pow n)) (PSE.pow (m+n))) + DocTest.printPrefix "MathObj.PowerSeries.Example:66: " +{-# LINE 66 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 66 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 500 PSE.expExpl PSE.expODE) + DocTest.printPrefix "MathObj.PowerSeries.Example:69: " +{-# LINE 69 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 69 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 500 PSE.sinExpl PSE.sinODE) + DocTest.printPrefix "MathObj.PowerSeries.Example:72: " +{-# LINE 72 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 72 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 500 PSE.cosExpl PSE.cosODE) + DocTest.printPrefix "MathObj.PowerSeries.Example:76: " +{-# LINE 76 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 76 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 50 PSE.tanExpl PSE.tanODE) + DocTest.printPrefix "MathObj.PowerSeries.Example:80: " +{-# LINE 80 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 80 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 50 PSE.tanExpl PSE.tanExplSieve) + DocTest.printPrefix "MathObj.PowerSeries.Example:87: " +{-# LINE 87 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 87 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 500 PSE.logExpl PSE.logODE) + DocTest.printPrefix "MathObj.PowerSeries.Example:90: " +{-# LINE 90 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 90 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 500 PSE.atanExpl PSE.atanODE) + DocTest.printPrefix "MathObj.PowerSeries.Example:94: " +{-# LINE 94 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 94 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 500 PSE.sinhExpl PSE.sinhODE) + DocTest.printPrefix "MathObj.PowerSeries.Example:97: " +{-# LINE 97 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 97 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 500 PSE.coshExpl PSE.coshODE) + DocTest.printPrefix "MathObj.PowerSeries.Example:100: " +{-# LINE 100 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 100 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 500 PSE.atanhExpl PSE.atanhODE) + DocTest.printPrefix "MathObj.PowerSeries.Example:106: " +{-# LINE 106 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 106 "src/MathObj/PowerSeries/Example.hs" #-} + (\expon -> equalTrunc 50 (PSE.powODE expon) (PSE.powExpl expon)) + DocTest.printPrefix "MathObj.PowerSeries.Example:112: " +{-# LINE 112 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 112 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 100 PSE.sqrtExpl PSE.sqrtODE) + DocTest.printPrefix "MathObj.PowerSeries.Example:149: " +{-# LINE 149 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 149 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 50 PSE.tanODE PSE.tanODESieve) + DocTest.printPrefix "MathObj.PowerSeries.Example:165: " +{-# LINE 165 "src/MathObj/PowerSeries/Example.hs" #-} + DocTest.property +{-# LINE 165 "src/MathObj/PowerSeries/Example.hs" #-} + (equalTrunc 50 PSE.asinODE (snd $ PS.inv PSE.sinODE)) 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,78 +1,72 @@ -{-# 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 - - +-- Do not edit! Automatically created with doctest-extract from src/MathObj/RefinementMask2.hs +{-# LINE 32 "src/MathObj/RefinementMask2.hs" #-} -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 +module Test.MathObj.RefinementMask2 where -inverse0 :: (RealField.C a, ZeroTestable.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 +import Test.DocTest.Base +import qualified Test.DocTest.Driver as DocTest -truncatePolynomial :: (ZeroTestable.C a) => Int -> Poly.T a -> Poly.T a -truncatePolynomial n = - Poly.fromCoeffs . PolyCore.normalize . take n . Poly.coeffs +{-# LINE 33 "src/MathObj/RefinementMask2.hs" #-} +import qualified MathObj.RefinementMask2 as Mask +import qualified MathObj.Polynomial as Poly +import qualified MathObj.Polynomial.Core as PolyCore -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 +import qualified Algebra.Differential as D +import qualified Algebra.Ring as Ring +import Test.NumericPrelude.Utility ((/\)) +import qualified Test.QuickCheck as QC +import NumericPrelude.Numeric as NP +import NumericPrelude.Base as P +import Prelude () -refining :: (RealField.C a, ZeroTestable.C a) => Poly.T a -> Bool -refining poly = - poly == Mask.refinePolynomial (Mask.fromPolynomial poly) poly +import Data.Function.HT (nest) +import Data.Maybe (fromMaybe) +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 -test :: Testable a => (Poly.T Integer -> a) -> IO () -test = quickCheck +genAdmissibleMask :: QC.Gen (Mask.T Rational, Poly.T Rational) +genAdmissibleMask = + QC.suchThatMap QC.arbitrary $ + \mask -> fmap ((,) mask) $ Mask.toPolynomial mask -testRat :: Testable a => (Poly.T Rational -> a) -> IO () -testRat = quickCheck +polyFromMask :: Mask.T a -> Poly.T a +polyFromMask = Poly.fromCoeffs . Mask.coeffs +genShortPolynomial :: Int -> QC.Gen (Poly.T Rational) +genShortPolynomial n = + fmap (Poly.fromCoeffs . PolyCore.normalize . take n) $ QC.arbitrary -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)) : - [] +test :: DocTest.T () +test = do + DocTest.printPrefix "MathObj.RefinementMask2:127: " +{-# LINE 127 "src/MathObj/RefinementMask2.hs" #-} + DocTest.property +{-# LINE 127 "src/MathObj/RefinementMask2.hs" #-} + (genAdmissibleMask /\ \(mask,poly) -> hasMultipleZero (fromMaybe 0 $ Poly.degree poly) 1 (polyFromMask (Mask.fromPolynomial poly) - polyFromMask mask)) + DocTest.printPrefix "MathObj.RefinementMask2:129: " +{-# LINE 129 "src/MathObj/RefinementMask2.hs" #-} + DocTest.property +{-# LINE 129 "src/MathObj/RefinementMask2.hs" #-} + (genShortPolynomial 5 /\ \poly -> maybe False (Poly.collinear poly) $ Mask.toPolynomial $ Mask.fromPolynomial poly) + DocTest.printPrefix "MathObj.RefinementMask2:161: " +{-# LINE 161 "src/MathObj/RefinementMask2.hs" #-} + DocTest.example +{-# LINE 161 "src/MathObj/RefinementMask2.hs" #-} + (fmap ((6::Rational) *>) $ Mask.toPolynomial (Mask.fromCoeffs [0.1, 0.02, 0.005::Rational])) + [ExpectedLine [LineChunk "Just (Polynomial.fromCoeffs [-12732 % 109375,272 % 625,-18 % 25,1 % 1])"]] + DocTest.printPrefix "MathObj.RefinementMask2:207: " +{-# LINE 207 "src/MathObj/RefinementMask2.hs" #-} + DocTest.property +{-# LINE 207 "src/MathObj/RefinementMask2.hs" #-} + (genShortPolynomial 5 /\ \poly -> poly == Mask.refinePolynomial (Mask.fromPolynomial poly) poly) + DocTest.printPrefix "MathObj.RefinementMask2:209: " +{-# LINE 209 "src/MathObj/RefinementMask2.hs" #-} + DocTest.example +{-# LINE 209 "src/MathObj/RefinementMask2.hs" #-} + (fmap (round :: Double -> Integer) $ fmap (1000000*) $ nest 50 (Mask.refinePolynomial (Mask.fromCoeffs [0.1, 0.02, 0.005])) (Poly.fromCoeffs [0,0,0,1])) + [ExpectedLine [LineChunk "Polynomial.fromCoeffs [-116407,435200,-720000,1000000]"]] 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,50 +1,56 @@ -{-# 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 +-- Do not edit! Automatically created with doctest-extract from playground/Number/ComplexSquareRoot.hs +{-# LINE 21 "playground/Number/ComplexSquareRoot.hs" #-} -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP +module Test.Number.ComplexSquareRoot where +import qualified Test.DocTest.Driver as DocTest -simple :: - (Testable t) => - (S.T Rational -> t) -> IO () -simple = quickCheck +{-# LINE 22 "playground/Number/ComplexSquareRoot.hs" #-} +import qualified Number.ComplexSquareRoot as SR +import qualified Number.Complex as Complex +import qualified Algebra.Laws as Laws +import Test.QuickCheck ((==>)) +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () -tests :: HUnit.Test -tests = - HUnit.TestLabel "complex square root" $ - HUnit.TestList $ - map testUnit $ - testList +sr :: SR.T Rational -> SR.T Rational +sr = id -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) : - [] +test :: DocTest.T () +test = do + DocTest.printPrefix "Number.ComplexSquareRoot:42: " +{-# LINE 42 "playground/Number/ComplexSquareRoot.hs" #-} + DocTest.property +{-# LINE 42 "playground/Number/ComplexSquareRoot.hs" #-} + (Laws.identity SR.mul SR.one . sr) + DocTest.printPrefix "Number.ComplexSquareRoot:43: " +{-# LINE 43 "playground/Number/ComplexSquareRoot.hs" #-} + DocTest.property +{-# LINE 43 "playground/Number/ComplexSquareRoot.hs" #-} + (Laws.commutative SR.mul . sr) + DocTest.printPrefix "Number.ComplexSquareRoot:44: " +{-# LINE 44 "playground/Number/ComplexSquareRoot.hs" #-} + DocTest.property +{-# LINE 44 "playground/Number/ComplexSquareRoot.hs" #-} + (Laws.associative SR.mul . sr) + DocTest.printPrefix "Number.ComplexSquareRoot:45: " +{-# LINE 45 "playground/Number/ComplexSquareRoot.hs" #-} + DocTest.property +{-# LINE 45 "playground/Number/ComplexSquareRoot.hs" #-} + (Laws.homomorphism SR.fromNumber (\x y -> x * (y :: Complex.T Rational)) SR.mul) + DocTest.printPrefix "Number.ComplexSquareRoot:46: " +{-# LINE 46 "playground/Number/ComplexSquareRoot.hs" #-} + DocTest.property +{-# LINE 46 "playground/Number/ComplexSquareRoot.hs" #-} + (Laws.rightIdentity SR.div SR.one . sr) + DocTest.printPrefix "Number.ComplexSquareRoot:47: " +{-# LINE 47 "playground/Number/ComplexSquareRoot.hs" #-} + DocTest.property +{-# LINE 47 "playground/Number/ComplexSquareRoot.hs" #-} + (\x -> not (isZero x) ==> SR.recip (SR.recip x) == sr x) + DocTest.printPrefix "Number.ComplexSquareRoot:48: " +{-# LINE 48 "playground/Number/ComplexSquareRoot.hs" #-} + DocTest.property +{-# LINE 48 "playground/Number/ComplexSquareRoot.hs" #-} + (\x -> not (isZero x) ==> Laws.inverse SR.mul SR.recip SR.one (sr x)) 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,37 +1,70 @@ -{-# 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 - +-- Do not edit! Automatically created with doctest-extract from src/Number/GaloisField2p32m5.hs +{-# LINE 33 "src/Number/GaloisField2p32m5.hs" #-} -import NumericPrelude.Base as P -import NumericPrelude.Numeric as NP +module Test.Number.GaloisField2p32m5 where +import qualified Test.DocTest.Driver as DocTest -test :: Testable a => (GF.T -> a) -> IO () -test = quickCheck +{-# LINE 34 "src/Number/GaloisField2p32m5.hs" #-} +import qualified Number.GaloisField2p32m5 as GF +import qualified Algebra.Laws as Laws +import Test.QuickCheck ((==>)) +import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () +gf :: GF.T -> GF.T +gf = id -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 (*) (+))) : - [] +test :: DocTest.T () +test = do + DocTest.printPrefix "Number.GaloisField2p32m5:46: " +{-# LINE 46 "src/Number/GaloisField2p32m5.hs" #-} + DocTest.property +{-# LINE 46 "src/Number/GaloisField2p32m5.hs" #-} + (Laws.identity (+) zero . gf) + DocTest.printPrefix "Number.GaloisField2p32m5:47: " +{-# LINE 47 "src/Number/GaloisField2p32m5.hs" #-} + DocTest.property +{-# LINE 47 "src/Number/GaloisField2p32m5.hs" #-} + (Laws.commutative (+) . gf) + DocTest.printPrefix "Number.GaloisField2p32m5:48: " +{-# LINE 48 "src/Number/GaloisField2p32m5.hs" #-} + DocTest.property +{-# LINE 48 "src/Number/GaloisField2p32m5.hs" #-} + (Laws.associative (+) . gf) + DocTest.printPrefix "Number.GaloisField2p32m5:49: " +{-# LINE 49 "src/Number/GaloisField2p32m5.hs" #-} + DocTest.property +{-# LINE 49 "src/Number/GaloisField2p32m5.hs" #-} + (Laws.inverse (+) negate zero . gf) + DocTest.printPrefix "Number.GaloisField2p32m5:50: " +{-# LINE 50 "src/Number/GaloisField2p32m5.hs" #-} + DocTest.property +{-# LINE 50 "src/Number/GaloisField2p32m5.hs" #-} + (\x -> Laws.inverse (+) (x-) (gf x)) + DocTest.printPrefix "Number.GaloisField2p32m5:51: " +{-# LINE 51 "src/Number/GaloisField2p32m5.hs" #-} + DocTest.property +{-# LINE 51 "src/Number/GaloisField2p32m5.hs" #-} + (Laws.identity (*) one . gf) + DocTest.printPrefix "Number.GaloisField2p32m5:52: " +{-# LINE 52 "src/Number/GaloisField2p32m5.hs" #-} + DocTest.property +{-# LINE 52 "src/Number/GaloisField2p32m5.hs" #-} + (Laws.commutative (*) . gf) + DocTest.printPrefix "Number.GaloisField2p32m5:53: " +{-# LINE 53 "src/Number/GaloisField2p32m5.hs" #-} + DocTest.property +{-# LINE 53 "src/Number/GaloisField2p32m5.hs" #-} + (Laws.associative (*) . gf) + DocTest.printPrefix "Number.GaloisField2p32m5:54: " +{-# LINE 54 "src/Number/GaloisField2p32m5.hs" #-} + DocTest.property +{-# LINE 54 "src/Number/GaloisField2p32m5.hs" #-} + (\y -> gf y /= zero ==> Laws.inverse (*) recip one y) + DocTest.printPrefix "Number.GaloisField2p32m5:55: " +{-# LINE 55 "src/Number/GaloisField2p32m5.hs" #-} + DocTest.property +{-# LINE 55 "src/Number/GaloisField2p32m5.hs" #-} + (\y x -> gf y /= zero ==> Laws.inverse (*) (x/) x y) diff --git a/test/Test/NumericPrelude/Utility.hs b/test/Test/NumericPrelude/Utility.hs --- a/test/Test/NumericPrelude/Utility.hs +++ b/test/Test/NumericPrelude/Utility.hs @@ -1,21 +1,17 @@ --- 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 +import qualified Test.QuickCheck as QC +import qualified NumericPrelude.Numeric as NP -testUnit :: (String, IO ()) -> HUnit.Test -testUnit (label, check) = - HUnit.TestLabel label (HUnit.TestCase check) +import Data.Eq.HT (equating) --- 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) +equalTrunc :: Int -> [NP.Rational] -> [NP.Rational] -> Bool +equalTrunc n = equating (take n) + + +infixr 0 /\ + +(/\) :: (Show a, QC.Testable test) => QC.Gen a -> (a -> test) -> QC.Property +(/\) = QC.forAll diff --git a/test/Test/Run.hs b/test/Test/Run.hs --- a/test/Test/Run.hs +++ b/test/Test/Run.hs @@ -1,36 +1,44 @@ +-- Do not edit! Automatically created with doctest-extract. 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.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 -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 +import qualified Test.Algebra.Additive +import qualified Test.Algebra.IntegralDomain +import qualified Test.Algebra.PrincipalIdealDomain +import qualified Test.Algebra.RealRing +import qualified Test.MathObj.Gaussian.Bell +import qualified Test.MathObj.Gaussian.Polynomial +import qualified Test.MathObj.Gaussian.ExponentTuple +import qualified Test.MathObj.Gaussian.Variance +import qualified Test.MathObj.Matrix +import qualified Test.MathObj.PartialFraction +import qualified Test.MathObj.Polynomial +import qualified Test.MathObj.Polynomial.Core +import qualified Test.MathObj.PowerSeries +import qualified Test.MathObj.PowerSeries.Core +import qualified Test.MathObj.PowerSeries.Example +import qualified Test.MathObj.RefinementMask2 +import qualified Test.Number.ComplexSquareRoot +import qualified Test.Number.GaloisField2p32m5 +import qualified Test.DocTest.Driver as DocTest + main :: IO () -main = - print =<< - HUnitText.runTestTT (HUnit.TestList $ - RefinementMask2.tests : - RealRing.tests : - Integral.tests : - Additive.tests : - GaussVariance.tests : - GaussBell.tests : - GaussPoly.tests : - PartialFraction.tests : - Matrix.tests : - Polynomial.tests : - PowerSeries.tests : - CSqRt.tests : - GF.tests : - []) +main = DocTest.run $ do + Test.Algebra.Additive.test + Test.Algebra.IntegralDomain.test + Test.Algebra.PrincipalIdealDomain.test + Test.Algebra.RealRing.test + Test.MathObj.Gaussian.Bell.test + Test.MathObj.Gaussian.Polynomial.test + Test.MathObj.Gaussian.ExponentTuple.test + Test.MathObj.Gaussian.Variance.test + Test.MathObj.Matrix.test + Test.MathObj.PartialFraction.test + Test.MathObj.Polynomial.test + Test.MathObj.Polynomial.Core.test + Test.MathObj.PowerSeries.test + Test.MathObj.PowerSeries.Core.test + Test.MathObj.PowerSeries.Example.test + Test.MathObj.RefinementMask2.test + Test.Number.ComplexSquareRoot.test + Test.Number.GaloisField2p32m5.test