3 files changed, 0 insertions, 554 deletions
diff --git a/lib/Numeric/LinearAlgebra/Tests/Instances.hs b/lib/Numeric/LinearAlgebra/Tests/Instances.hs
deleted file mode 100644
index 6dd9cfe..0000000
--- a/lib/Numeric/LinearAlgebra/Tests/Instances.hs
+++ /dev/null
@@ -1,249 +0,0 @@
-{-# LANGUAGE FlexibleContexts, UndecidableInstances, CPP, FlexibleInstances #-}
-{-# OPTIONS_GHC -fno-warn-unused-imports #-}
-----------------------------------------------------------------------------
-{- |
-Module      :  Numeric.LinearAlgebra.Tests.Instances
-Copyright   :  (c) Alberto Ruiz 2008
-License     :  GPL-style
-Maintainer  :  Alberto Ruiz (aruiz at um dot es)
-Stability   :  provisional
-Portability :  portable
-Arbitrary instances for vectors, matrices.
-}
-module Numeric.LinearAlgebra.Tests.Instances(
-    Sq(..),     rSq,cSq,
-    Rot(..),    rRot,cRot,
-    Her(..),    rHer,cHer,
-    WC(..),     rWC,cWC,
-    SqWC(..),   rSqWC, cSqWC,
-    PosDef(..), rPosDef, cPosDef,
-    Consistent(..), rConsist, cConsist,
-    RM,CM, rM,cM,
-    FM,ZM, fM,zM
-) where
-import System.Random
-import Numeric.LinearAlgebra
-import Control.Monad(replicateM)
-#include "quickCheckCompat.h"
-#if MIN_VERSION_QuickCheck(2,0,0)
-shrinkListElementwise :: (Arbitrary a) => [a] -> [[a]]
-shrinkListElementwise []     = []
-shrinkListElementwise (x:xs) = [ y:xs | y  <- shrink x                 ]
-                            ++ [ x:ys | ys <- shrinkListElementwise xs ]
-shrinkPair :: (Arbitrary a, Arbitrary b) => (a,b) -> [(a,b)]
-shrinkPair (a,b) = [ (a,x) | x <- shrink b ] ++ [ (x,b) | x <- shrink a ]
-#endif
-#if MIN_VERSION_QuickCheck(2,1,1)
-#else
-instance (Arbitrary a, RealFloat a) => Arbitrary (Complex a) where
-    arbitrary = do
-        re <- arbitrary
-        im <- arbitrary
-        return (re :+ im)
-#if MIN_VERSION_QuickCheck(2,0,0)
-    shrink (re :+ im) = 
-        [ u :+ v | (u,v) <- shrinkPair (re,im) ]
-#else
-    -- this has been moved to the 'Coarbitrary' class in QuickCheck 2
-    coarbitrary = undefined 
-#endif
-#endif
-chooseDim = sized $ \m -> choose (1,max 1 m)
-instance (Field a, Arbitrary a) => Arbitrary (Vector a) where 
-    arbitrary = do m <- chooseDim
-                   l <- vector m
-                   return $ fromList l
-#if MIN_VERSION_QuickCheck(2,0,0)
-    -- shrink any one of the components
-    shrink = map fromList . shrinkListElementwise . toList
-#else
-    coarbitrary = undefined
-#endif
-instance (Element a, Arbitrary a) => Arbitrary (Matrix a) where 
-    arbitrary = do
-        m <- chooseDim
-        n <- chooseDim
-        l <- vector (m*n)
-        return $ (m><n) l
-#if MIN_VERSION_QuickCheck(2,0,0)
-    -- shrink any one of the components
-    shrink a = map (rows a >< cols a)
-               . shrinkListElementwise
-               . concat . toLists 
-                     $ a
-#else
-    coarbitrary = undefined
-#endif
-- a square matrix
-newtype (Sq a) = Sq (Matrix a) deriving Show
-instance (Element a, Arbitrary a) => Arbitrary (Sq a) where
-    arbitrary = do
-        n <- chooseDim
-        l <- vector (n*n)
-        return $ Sq $ (n><n) l
-#if MIN_VERSION_QuickCheck(2,0,0)
-    shrink (Sq a) = [ Sq b | b <- shrink a ]
-#else
-    coarbitrary = undefined
-#endif
-- a unitary matrix
-newtype (Rot a) = Rot (Matrix a) deriving Show
-instance (Field a, Arbitrary a) => Arbitrary (Rot a) where
-    arbitrary = do
-        Sq m <- arbitrary
-        let (q,_) = qr m
-        return (Rot q)
-#if MIN_VERSION_QuickCheck(2,0,0)
-#else
-    coarbitrary = undefined
-#endif
-- a complex hermitian or real symmetric matrix
-newtype (Her a) = Her (Matrix a) deriving Show
-instance (Field a, Arbitrary a, Num (Vector a)) => Arbitrary (Her a) where
-    arbitrary = do
-        Sq m <- arbitrary
-        let m' = m/2
-        return $ Her (m' + ctrans m')
-#if MIN_VERSION_QuickCheck(2,0,0)
-#else
-    coarbitrary = undefined
-#endif
-class (Field a, Arbitrary a, Element (RealOf a), Random (RealOf a)) => ArbitraryField a
-instance ArbitraryField Double
-instance ArbitraryField (Complex Double)
-- a well-conditioned general matrix (the singular values are between 1 and 100)
-newtype (WC a) = WC (Matrix a) deriving Show
-instance (ArbitraryField a) => Arbitrary (WC a) where
-    arbitrary = do
-        m <- arbitrary
-        let (u,_,v) = svd m
-            r = rows m
-            c = cols m
-            n = min r c
-        sv' <- replicateM n (choose (1,100))
-        let s = diagRect 0 (fromList sv') r c
-        return $ WC (u <> real s <> trans v)
-#if MIN_VERSION_QuickCheck(2,0,0)
-#else
-    coarbitrary = undefined
-#endif
-- a well-conditioned square matrix (the singular values are between 1 and 100)
-newtype (SqWC a) = SqWC (Matrix a) deriving Show
-instance (ArbitraryField a) => Arbitrary (SqWC a) where
-    arbitrary = do
-        Sq m <- arbitrary
-        let (u,_,v) = svd m
-            n = rows m
-        sv' <- replicateM n (choose (1,100))
-        let s = diag (fromList sv')
-        return $ SqWC (u <> real s <> trans v)
-#if MIN_VERSION_QuickCheck(2,0,0)
-#else
-    coarbitrary = undefined
-#endif
-- a positive definite square matrix (the eigenvalues are between 0 and 100)
-newtype (PosDef a) = PosDef (Matrix a) deriving Show
-instance (ArbitraryField a, Num (Vector a)) 
-    => Arbitrary (PosDef a) where
-    arbitrary = do
-        Her m <- arbitrary
-        let (_,v) = eigSH m
-            n = rows m
-        l <- replicateM n (choose (0,100))
-        let s = diag (fromList l)
-            p = v <> real s <> ctrans v
-        return $ PosDef (0.5 * p + 0.5 * ctrans p)
-#if MIN_VERSION_QuickCheck(2,0,0)
-#else
-    coarbitrary = undefined
-#endif
-- a pair of matrices that can be multiplied
-newtype (Consistent a) = Consistent (Matrix a, Matrix a) deriving Show
-instance (Field a, Arbitrary a) => Arbitrary (Consistent a) where
-    arbitrary = do
-        n <- chooseDim
-        k <- chooseDim
-        m <- chooseDim
-        la <- vector (n*k)
-        lb <- vector (k*m)
-        return $ Consistent ((n><k) la, (k><m) lb)
-#if MIN_VERSION_QuickCheck(2,0,0)
-    shrink (Consistent (x,y)) = [ Consistent (u,v) | (u,v) <- shrinkPair (x,y) ]
-#else
-    coarbitrary = undefined
-#endif
-type RM = Matrix Double
-type CM = Matrix (Complex Double)
-type FM = Matrix Float
-type ZM = Matrix (Complex Float)
-rM m = m :: RM
-cM m = m :: CM
-fM m = m :: FM
-zM m = m :: ZM
-rHer (Her m) = m :: RM
-cHer (Her m) = m :: CM
-rRot (Rot m) = m :: RM
-cRot (Rot m) = m :: CM
-rSq  (Sq m)  = m :: RM
-cSq  (Sq m)  = m :: CM
-rWC (WC m) = m :: RM
-cWC (WC m) = m :: CM
-rSqWC (SqWC m) = m :: RM
-cSqWC (SqWC m) = m :: CM
-rPosDef (PosDef m) = m :: RM
-cPosDef (PosDef m) = m :: CM
-rConsist (Consistent (a,b)) = (a,b::RM)
-cConsist (Consistent (a,b)) = (a,b::CM)
diff --git a/lib/Numeric/LinearAlgebra/Tests/Properties.hs b/lib/Numeric/LinearAlgebra/Tests/Properties.hs
deleted file mode 100644
index fe13544..0000000
--- a/lib/Numeric/LinearAlgebra/Tests/Properties.hs
+++ /dev/null
@@ -1,272 +0,0 @@
-{-# LANGUAGE CPP, FlexibleContexts #-}
-{-# OPTIONS_GHC -fno-warn-unused-imports #-}
-----------------------------------------------------------------------------
-{- |
-Module      :  Numeric.LinearAlgebra.Tests.Properties
-Copyright   :  (c) Alberto Ruiz 2008
-License     :  GPL-style
-Maintainer  :  Alberto Ruiz (aruiz at um dot es)
-Stability   :  provisional
-Portability :  portable
-Testing properties.
-}
-module Numeric.LinearAlgebra.Tests.Properties (
-    dist, (|~|), (~:), Aprox((:~)),
-    zeros, ones,
-    square,
-    unitary,
-    hermitian,
-    wellCond,
-    positiveDefinite,
-    upperTriang,
-    upperHessenberg,
-    luProp,
-    invProp,
-    pinvProp,
-    detProp,
-    nullspaceProp,
-    bugProp,
-    svdProp1, svdProp1a, svdProp1b, svdProp2, svdProp3, svdProp4,
-    svdProp5a, svdProp5b, svdProp6a, svdProp6b, svdProp7,
-    eigProp, eigSHProp, eigProp2, eigSHProp2,
-    qrProp, rqProp, rqProp1, rqProp2, rqProp3,
-    hessProp,
-    schurProp1, schurProp2,
-    cholProp, exactProp,
-    expmDiagProp,
-    multProp1, multProp2,
-    subProp,
-    linearSolveProp, linearSolveProp2
-) where
-import Numeric.LinearAlgebra --hiding (real,complex)
-import Numeric.LinearAlgebra.LAPACK
-import Debug.Trace
-#include "quickCheckCompat.h"
--real x = real'' x
--complex x = complex'' x
-debug x = trace (show x) x
-- relative error
-dist :: (Normed c t, Num (c t)) => c t -> c t -> Double
-dist a b = realToFrac r
-    where norm = pnorm Infinity
-          na = norm a
-          nb = norm b
-          nab = norm (a-b)
-          mx = max na nb
-          mn = min na nb
-          r = if mn < peps
-                then mx
-                else nab/mx
-infixl 4 |~|
-a |~| b = a :~10~: b
--a |~| b = dist a b < 10^^(-10)
-data Aprox a = (:~) a Int
-- (~:) :: (Normed a, Num a) => Aprox a -> a -> Bool
-a :~n~: b = dist a b < 10^^(-n)
------------------------------------------------------
-square m = rows m == cols m
-- orthonormal columns
-orthonormal m = ctrans m <> m |~| ident (cols m)
-unitary m = square m && orthonormal m
-hermitian m = square m && m |~| ctrans m
-wellCond m = rcond m > 1/100
-positiveDefinite m = minimum (toList e) > 0
-    where (e,_v) = eigSH m
-upperTriang m = rows m == 1 || down == z
-    where down = fromList $ concat $ zipWith drop [1..] (toLists (ctrans m))
-          z = constant 0 (dim down)
-upperHessenberg m = rows m < 3 || down == z
-    where down = fromList $ concat $ zipWith drop [2..] (toLists (ctrans m))
-          z = constant 0 (dim down)
-zeros (r,c) = reshape c (constant 0 (r*c))
-ones (r,c) = zeros (r,c) + 1
-----------------------------------------------------
-luProp m = m |~| p <> l <> u && f (det p) |~| f s
-    where (l,u,p,s) = lu m
-          f x = fromList [x]
-invProp m = m <> inv m |~| ident (rows m)
-pinvProp m =  m <> p <> m |~| m
-           && p <> m <> p |~| p
-           && hermitian (m<>p)
-           && hermitian (p<>m)
-    where p = pinv m
-detProp m = s d1 |~| s d2
-    where d1 = det m
-          d2 = det' * det q
-          det' = product $ toList $ takeDiag r
-          (q,r) = qr m
-          s x = fromList [x]
-nullspaceProp m = null nl `trivial` (null nl || m <> n |~| zeros (r,c)
-                                     && orthonormal (fromColumns nl))
-    where nl = nullspacePrec 1 m
-          n = fromColumns nl
-          r = rows m
-          c = cols m - rank m
------------------------------------------------------------------
-- testcase for nonempty fpu stack
-- uncommenting unitary' signature eliminates the problem
-bugProp m = m |~| u <> real d <> trans v && unitary' u && unitary' v
-    where (u,d,v) = fullSVD m
-          -- unitary' :: (Num (Vector t), Field t) => Matrix t -> Bool
-          unitary' a = unitary a
------------------------------------------------------------------
-- fullSVD
-svdProp1 m = m |~| u <> real d <> trans v && unitary u && unitary v
-    where (u,d,v) = fullSVD m
-svdProp1a svdfun m = m |~| u <> real d <> trans v && unitary u && unitary v where
-    (u,s,v) = svdfun m
-    d = diagRect 0 s (rows m) (cols m)
-svdProp1b svdfun m = unitary u && unitary v where
-    (u,_,v) = svdfun m
-- thinSVD
-svdProp2 thinSVDfun m = m |~| u <> diag (real s) <> trans v && orthonormal u && orthonormal v && dim s == min (rows m) (cols m)
-    where (u,s,v) = thinSVDfun m
-- compactSVD
-svdProp3 m = (m |~| u <> real (diag s) <> trans v
-             && orthonormal u && orthonormal v)
-    where (u,s,v) = compactSVD m
-svdProp4 m' = m |~| u <> real (diag s) <> trans v
-           && orthonormal u && orthonormal v
-           && (dim s == r || r == 0 && dim s == 1)
-    where (u,s,v) = compactSVD m
-          m = fromBlocks [[m'],[m']]
-          r = rank m'
-svdProp5a m = all (s1|~|) [s2,s3,s4,s5,s6] where
-    s1       = svR  m
-    s2       = svRd m
-    (_,s3,_) = svdR m
-    (_,s4,_) = svdRd m
-    (_,s5,_) = thinSVDR m
-    (_,s6,_) = thinSVDRd m
-svdProp5b m = all (s1|~|) [s2,s3,s4,s5,s6] where
-    s1       = svC  m
-    s2       = svCd m
-    (_,s3,_) = svdC m
-    (_,s4,_) = svdCd m
-    (_,s5,_) = thinSVDC m
-    (_,s6,_) = thinSVDCd m
-svdProp6a m = s |~| s' && v |~| v' && s |~| s'' && u |~| u'
-    where (u,s,v) = svdR m
-          (s',v') = rightSVR m
-          (u',s'') = leftSVR m
-svdProp6b m = s |~| s' && v |~| v' && s |~| s'' && u |~| u'
-    where (u,s,v) = svdC m
-          (s',v') = rightSVC m
-          (u',s'') = leftSVC m
-svdProp7 m = s |~| s' && u |~| u' && v |~| v' && s |~| s'''
-    where (u,s,v) = svd m
-          (s',v') = rightSV m
-          (u',_s'') = leftSV m
-          s''' = singularValues m
------------------------------------------------------------------
-eigProp m = complex m <> v |~| v <> diag s
-    where (s, v) = eig m
-eigSHProp m = m <> v |~| v <> real (diag s)
-              && unitary v
-              && m |~| v <> real (diag s) <> ctrans v
-    where (s, v) = eigSH m
-eigProp2 m = fst (eig m) |~| eigenvalues m
-eigSHProp2 m = fst (eigSH m) |~| eigenvaluesSH m
------------------------------------------------------------------
-qrProp m = q <> r |~| m && unitary q && upperTriang r
-    where (q,r) = qr m
-rqProp m = r <> q |~| m && unitary q && upperTriang' r
-    where (r,q) = rq m
-rqProp1 m = r <> q |~| m
-    where (r,q) = rq m
-rqProp2 m = unitary q
-    where (r,q) = rq m
-rqProp3 m = upperTriang' r
-    where (r,q) = rq m
-upperTriang' r = upptr (rows r) (cols r) * r |~| r
-    where upptr f c = buildMatrix f c $ \(r',c') -> if r'-t > c' then 0 else 1
-              where t = f-c
-hessProp m = m |~| p <> h <> ctrans p && unitary p && upperHessenberg h
-    where (p,h) = hess m
-schurProp1 m = m |~| u <> s <> ctrans u && unitary u && upperTriang s
-    where (u,s) = schur m
-schurProp2 m = m |~| u <> s <> ctrans u && unitary u && upperHessenberg s -- fixme
-    where (u,s) = schur m
-cholProp m = m |~| ctrans c <> c && upperTriang c
-    where c = chol m
-exactProp m = chol m == chol (m+0)
-expmDiagProp m = expm (logm m) :~ 7 ~: complex m
-    where logm = matFunc log
-- reference multiply
-mulH a b = fromLists [[ doth ai bj | bj <- toColumns b] | ai <- toRows a ]
-    where doth u v = sum $ zipWith (*) (toList u) (toList v)
-multProp1 p (a,b) = (a <> b) :~p~: (mulH a b)
-multProp2 p (a,b) = (ctrans (a <> b)) :~p~: (ctrans b <> ctrans a)
-linearSolveProp f m = f m m |~| ident (rows m)
-linearSolveProp2 f (a,x) = not wc `trivial` (not wc || a <> f a b |~| b)
-    where q = min (rows a) (cols a)
-          b = a <> x
-          wc = rank a == q
-subProp m = m == (trans . fromColumns . toRows) m
diff --git a/lib/Numeric/LinearAlgebra/Tests/quickCheckCompat.h b/lib/Numeric/LinearAlgebra/Tests/quickCheckCompat.h
deleted file mode 100644
index 714587b..0000000
--- a/lib/Numeric/LinearAlgebra/Tests/quickCheckCompat.h
+++ /dev/null
@@ -1,33 +0,0 @@
-#ifndef MIN_VERSION_QuickCheck
-#define MIN_VERSION_QuickCheck(A,B,C) 1
-#endif
-#if MIN_VERSION_QuickCheck(2,0,0)
-import Test.QuickCheck(Arbitrary,arbitrary,coarbitrary,choose,vector
-                      ,sized,classify,Testable,Property
-                      ,quickCheckWith,maxSize,stdArgs,shrink)
-#else
-import Test.QuickCheck(Arbitrary,arbitrary,coarbitrary,choose,vector
-                      ,sized,classify,Testable,Property
-                      ,check,configSize,defaultConfig,trivial)
-#endif
-#if MIN_VERSION_QuickCheck(2,0,0)
-trivial :: Testable a => Bool -> a -> Property
-trivial = (`classify` "trivial")
-#else
-#endif
-- define qCheck, which used to be in Tests.hs
-#if MIN_VERSION_QuickCheck(2,0,0)
-qCheck n = quickCheckWith stdArgs {maxSize = n}
-#else
-qCheck n = check defaultConfig {configSize = const n}
-#endif

diff --git a/lib/Numeric/LinearAlgebra/Tests/Instances.hs b/lib/Numeric/LinearAlgebra/Tests/Instances.hs deleted file mode 100644 index 6dd9cfe..0000000 --- a/lib/Numeric/LinearAlgebra/Tests/Instances.hs +++ /dev/null
@@ -1,249 +0,0 @@
1	{-# LANGUAGE FlexibleContexts, UndecidableInstances, CPP, FlexibleInstances #-}
2	{-# OPTIONS_GHC -fno-warn-unused-imports #-}
3	-----------------------------------------------------------------------------
4	{- \|
5	Module : Numeric.LinearAlgebra.Tests.Instances
6	Copyright : (c) Alberto Ruiz 2008
7	License : GPL-style
8
9	Maintainer : Alberto Ruiz (aruiz at um dot es)
10	Stability : provisional
11	Portability : portable
12
13	Arbitrary instances for vectors, matrices.
14
15	-}
16
17	module Numeric.LinearAlgebra.Tests.Instances(
18	Sq(..), rSq,cSq,
19	Rot(..), rRot,cRot,
20	Her(..), rHer,cHer,
21	WC(..), rWC,cWC,
22	SqWC(..), rSqWC, cSqWC,
23	PosDef(..), rPosDef, cPosDef,
24	Consistent(..), rConsist, cConsist,
25	RM,CM, rM,cM,
26	FM,ZM, fM,zM
27	) where
28
29	import System.Random
30
31	import Numeric.LinearAlgebra
32	import Control.Monad(replicateM)
33	#include "quickCheckCompat.h"
34
35	#if MIN_VERSION_QuickCheck(2,0,0)
36	shrinkListElementwise :: (Arbitrary a) => [a] -> [[a]]
37	shrinkListElementwise [] = []
38	shrinkListElementwise (x:xs) = [ y:xs \| y <- shrink x ]
39	++ [ x:ys \| ys <- shrinkListElementwise xs ]
40
41	shrinkPair :: (Arbitrary a, Arbitrary b) => (a,b) -> [(a,b)]
42	shrinkPair (a,b) = [ (a,x) \| x <- shrink b ] ++ [ (x,b) \| x <- shrink a ]
43	#endif
44
45	#if MIN_VERSION_QuickCheck(2,1,1)
46	#else
47	instance (Arbitrary a, RealFloat a) => Arbitrary (Complex a) where
48	arbitrary = do
49	re <- arbitrary
50	im <- arbitrary
51	return (re :+ im)
52
53	#if MIN_VERSION_QuickCheck(2,0,0)
54	shrink (re :+ im) =
55	[ u :+ v \| (u,v) <- shrinkPair (re,im) ]
56	#else
57	-- this has been moved to the 'Coarbitrary' class in QuickCheck 2
58	coarbitrary = undefined
59	#endif
60
61	#endif
62
63	chooseDim = sized $ \m -> choose (1,max 1 m)
64
65	instance (Field a, Arbitrary a) => Arbitrary (Vector a) where
66	arbitrary = do m <- chooseDim
67	l <- vector m
68	return $ fromList l
69
70	#if MIN_VERSION_QuickCheck(2,0,0)
71	-- shrink any one of the components
72	shrink = map fromList . shrinkListElementwise . toList
73
74	#else
75	coarbitrary = undefined
76	#endif
77
78	instance (Element a, Arbitrary a) => Arbitrary (Matrix a) where
79	arbitrary = do
80	m <- chooseDim
81	n <- chooseDim
82	l <- vector (m*n)
83	return $ (m><n) l
84
85	#if MIN_VERSION_QuickCheck(2,0,0)
86	-- shrink any one of the components
87	shrink a = map (rows a >< cols a)
88	. shrinkListElementwise
89	. concat . toLists
90	$ a
91	#else
92	coarbitrary = undefined
93	#endif
94
95
96	-- a square matrix
97	newtype (Sq a) = Sq (Matrix a) deriving Show
98	instance (Element a, Arbitrary a) => Arbitrary (Sq a) where
99	arbitrary = do
100	n <- chooseDim
101	l <- vector (n*n)
102	return $ Sq $ (n><n) l
103
104	#if MIN_VERSION_QuickCheck(2,0,0)
105	shrink (Sq a) = [ Sq b \| b <- shrink a ]
106	#else
107	coarbitrary = undefined
108	#endif
109
110
111	-- a unitary matrix
112	newtype (Rot a) = Rot (Matrix a) deriving Show
113	instance (Field a, Arbitrary a) => Arbitrary (Rot a) where
114	arbitrary = do
115	Sq m <- arbitrary
116	let (q,_) = qr m
117	return (Rot q)
118
119	#if MIN_VERSION_QuickCheck(2,0,0)
120	#else
121	coarbitrary = undefined
122	#endif
123
124
125	-- a complex hermitian or real symmetric matrix
126	newtype (Her a) = Her (Matrix a) deriving Show
127	instance (Field a, Arbitrary a, Num (Vector a)) => Arbitrary (Her a) where
128	arbitrary = do
129	Sq m <- arbitrary
130	let m' = m/2
131	return $ Her (m' + ctrans m')
132
133	#if MIN_VERSION_QuickCheck(2,0,0)
134	#else
135	coarbitrary = undefined
136	#endif
137
138	class (Field a, Arbitrary a, Element (RealOf a), Random (RealOf a)) => ArbitraryField a
139	instance ArbitraryField Double
140	instance ArbitraryField (Complex Double)
141
142
143	-- a well-conditioned general matrix (the singular values are between 1 and 100)
144	newtype (WC a) = WC (Matrix a) deriving Show
145	instance (ArbitraryField a) => Arbitrary (WC a) where
146	arbitrary = do
147	m <- arbitrary
148	let (u,_,v) = svd m
149	r = rows m
150	c = cols m
151	n = min r c
152	sv' <- replicateM n (choose (1,100))
153	let s = diagRect 0 (fromList sv') r c
154	return $ WC (u <> real s <> trans v)
155
156	#if MIN_VERSION_QuickCheck(2,0,0)
157	#else
158	coarbitrary = undefined
159	#endif
160
161
162	-- a well-conditioned square matrix (the singular values are between 1 and 100)
163	newtype (SqWC a) = SqWC (Matrix a) deriving Show
164	instance (ArbitraryField a) => Arbitrary (SqWC a) where
165	arbitrary = do
166	Sq m <- arbitrary
167	let (u,_,v) = svd m
168	n = rows m
169	sv' <- replicateM n (choose (1,100))
170	let s = diag (fromList sv')
171	return $ SqWC (u <> real s <> trans v)
172
173	#if MIN_VERSION_QuickCheck(2,0,0)
174	#else
175	coarbitrary = undefined
176	#endif
177
178
179	-- a positive definite square matrix (the eigenvalues are between 0 and 100)
180	newtype (PosDef a) = PosDef (Matrix a) deriving Show
181	instance (ArbitraryField a, Num (Vector a))
182	=> Arbitrary (PosDef a) where
183	arbitrary = do
184	Her m <- arbitrary
185	let (_,v) = eigSH m
186	n = rows m
187	l <- replicateM n (choose (0,100))
188	let s = diag (fromList l)
189	p = v <> real s <> ctrans v
190	return $ PosDef (0.5 * p + 0.5 * ctrans p)
191
192	#if MIN_VERSION_QuickCheck(2,0,0)
193	#else
194	coarbitrary = undefined
195	#endif
196
197
198	-- a pair of matrices that can be multiplied
199	newtype (Consistent a) = Consistent (Matrix a, Matrix a) deriving Show
200	instance (Field a, Arbitrary a) => Arbitrary (Consistent a) where
201	arbitrary = do
202	n <- chooseDim
203	k <- chooseDim
204	m <- chooseDim
205	la <- vector (n*k)
206	lb <- vector (k*m)
207	return $ Consistent ((n><k) la, (k><m) lb)
208
209	#if MIN_VERSION_QuickCheck(2,0,0)
210	shrink (Consistent (x,y)) = [ Consistent (u,v) \| (u,v) <- shrinkPair (x,y) ]
211	#else
212	coarbitrary = undefined
213	#endif
214
215
216
217	type RM = Matrix Double
218	type CM = Matrix (Complex Double)
219	type FM = Matrix Float
220	type ZM = Matrix (Complex Float)
221
222
223	rM m = m :: RM
224	cM m = m :: CM
225	fM m = m :: FM
226	zM m = m :: ZM
227
228
229	rHer (Her m) = m :: RM
230	cHer (Her m) = m :: CM
231
232	rRot (Rot m) = m :: RM
233	cRot (Rot m) = m :: CM
234
235	rSq (Sq m) = m :: RM
236	cSq (Sq m) = m :: CM
237
238	rWC (WC m) = m :: RM
239	cWC (WC m) = m :: CM
240
241	rSqWC (SqWC m) = m :: RM
242	cSqWC (SqWC m) = m :: CM
243
244	rPosDef (PosDef m) = m :: RM
245	cPosDef (PosDef m) = m :: CM
246
247	rConsist (Consistent (a,b)) = (a,b::RM)
248	cConsist (Consistent (a,b)) = (a,b::CM)
249


diff --git a/lib/Numeric/LinearAlgebra/Tests/Properties.hs b/lib/Numeric/LinearAlgebra/Tests/Properties.hs deleted file mode 100644 index fe13544..0000000 --- a/lib/Numeric/LinearAlgebra/Tests/Properties.hs +++ /dev/null
@@ -1,272 +0,0 @@
1	{-# LANGUAGE CPP, FlexibleContexts #-}
2	{-# OPTIONS_GHC -fno-warn-unused-imports #-}
3	-----------------------------------------------------------------------------
4	{- \|
5	Module : Numeric.LinearAlgebra.Tests.Properties
6	Copyright : (c) Alberto Ruiz 2008
7	License : GPL-style
8
9	Maintainer : Alberto Ruiz (aruiz at um dot es)
10	Stability : provisional
11	Portability : portable
12
13	Testing properties.
14
15	-}
16
17	module Numeric.LinearAlgebra.Tests.Properties (
18	dist, (\|~\|), (~:), Aprox((:~)),
19	zeros, ones,
20	square,
21	unitary,
22	hermitian,
23	wellCond,
24	positiveDefinite,
25	upperTriang,
26	upperHessenberg,
27	luProp,
28	invProp,
29	pinvProp,
30	detProp,
31	nullspaceProp,
32	bugProp,
33	svdProp1, svdProp1a, svdProp1b, svdProp2, svdProp3, svdProp4,
34	svdProp5a, svdProp5b, svdProp6a, svdProp6b, svdProp7,
35	eigProp, eigSHProp, eigProp2, eigSHProp2,
36	qrProp, rqProp, rqProp1, rqProp2, rqProp3,
37	hessProp,
38	schurProp1, schurProp2,
39	cholProp, exactProp,
40	expmDiagProp,
41	multProp1, multProp2,
42	subProp,
43	linearSolveProp, linearSolveProp2
44	) where
45
46	import Numeric.LinearAlgebra --hiding (real,complex)
47	import Numeric.LinearAlgebra.LAPACK
48	import Debug.Trace
49	#include "quickCheckCompat.h"
50
51
52	--real x = real'' x
53	--complex x = complex'' x
54
55	debug x = trace (show x) x
56
57	-- relative error
58	dist :: (Normed c t, Num (c t)) => c t -> c t -> Double
59	dist a b = realToFrac r
60	where norm = pnorm Infinity
61	na = norm a
62	nb = norm b
63	nab = norm (a-b)
64	mx = max na nb
65	mn = min na nb
66	r = if mn < peps
67	then mx
68	else nab/mx
69
70	infixl 4 \|~\|
71	a \|~\| b = a :~10~: b
72	--a \|~\| b = dist a b < 10^^(-10)
73
74	data Aprox a = (:~) a Int
75	-- (~:) :: (Normed a, Num a) => Aprox a -> a -> Bool
76	a :~n~: b = dist a b < 10^^(-n)
77
78	------------------------------------------------------
79
80	square m = rows m == cols m
81
82	-- orthonormal columns
83	orthonormal m = ctrans m <> m \|~\| ident (cols m)
84
85	unitary m = square m && orthonormal m
86
87	hermitian m = square m && m \|~\| ctrans m
88
89	wellCond m = rcond m > 1/100
90
91	positiveDefinite m = minimum (toList e) > 0
92	where (e,_v) = eigSH m
93
94	upperTriang m = rows m == 1 \|\| down == z
95	where down = fromList $ concat $ zipWith drop [1..] (toLists (ctrans m))
96	z = constant 0 (dim down)
97
98	upperHessenberg m = rows m < 3 \|\| down == z
99	where down = fromList $ concat $ zipWith drop [2..] (toLists (ctrans m))
100	z = constant 0 (dim down)
101
102	zeros (r,c) = reshape c (constant 0 (r*c))
103
104	ones (r,c) = zeros (r,c) + 1
105
106	-----------------------------------------------------
107
108	luProp m = m \|~\| p <> l <> u && f (det p) \|~\| f s
109	where (l,u,p,s) = lu m
110	f x = fromList [x]
111
112	invProp m = m <> inv m \|~\| ident (rows m)
113
114	pinvProp m = m <> p <> m \|~\| m
115	&& p <> m <> p \|~\| p
116	&& hermitian (m<>p)
117	&& hermitian (p<>m)
118	where p = pinv m
119
120	detProp m = s d1 \|~\| s d2
121	where d1 = det m
122	d2 = det' * det q
123	det' = product $ toList $ takeDiag r
124	(q,r) = qr m
125	s x = fromList [x]
126
127	nullspaceProp m = null nl `trivial` (null nl \|\| m <> n \|~\| zeros (r,c)
128	&& orthonormal (fromColumns nl))
129	where nl = nullspacePrec 1 m
130	n = fromColumns nl
131	r = rows m
132	c = cols m - rank m
133
134	------------------------------------------------------------------
135
136	-- testcase for nonempty fpu stack
137	-- uncommenting unitary' signature eliminates the problem
138	bugProp m = m \|~\| u <> real d <> trans v && unitary' u && unitary' v
139	where (u,d,v) = fullSVD m
140	-- unitary' :: (Num (Vector t), Field t) => Matrix t -> Bool
141	unitary' a = unitary a
142
143	------------------------------------------------------------------
144
145	-- fullSVD
146	svdProp1 m = m \|~\| u <> real d <> trans v && unitary u && unitary v
147	where (u,d,v) = fullSVD m
148
149	svdProp1a svdfun m = m \|~\| u <> real d <> trans v && unitary u && unitary v where
150	(u,s,v) = svdfun m
151	d = diagRect 0 s (rows m) (cols m)
152
153	svdProp1b svdfun m = unitary u && unitary v where
154	(u,_,v) = svdfun m
155
156	-- thinSVD
157	svdProp2 thinSVDfun m = m \|~\| u <> diag (real s) <> trans v && orthonormal u && orthonormal v && dim s == min (rows m) (cols m)
158	where (u,s,v) = thinSVDfun m
159
160	-- compactSVD
161	svdProp3 m = (m \|~\| u <> real (diag s) <> trans v
162	&& orthonormal u && orthonormal v)
163	where (u,s,v) = compactSVD m
164
165	svdProp4 m' = m \|~\| u <> real (diag s) <> trans v
166	&& orthonormal u && orthonormal v
167	&& (dim s == r \|\| r == 0 && dim s == 1)
168	where (u,s,v) = compactSVD m
169	m = fromBlocks [[m'],[m']]
170	r = rank m'
171
172	svdProp5a m = all (s1\|~\|) [s2,s3,s4,s5,s6] where
173	s1 = svR m
174	s2 = svRd m
175	(_,s3,_) = svdR m
176	(_,s4,_) = svdRd m
177	(_,s5,_) = thinSVDR m
178	(_,s6,_) = thinSVDRd m
179
180	svdProp5b m = all (s1\|~\|) [s2,s3,s4,s5,s6] where
181	s1 = svC m
182	s2 = svCd m
183	(_,s3,_) = svdC m
184	(_,s4,_) = svdCd m
185	(_,s5,_) = thinSVDC m
186	(_,s6,_) = thinSVDCd m
187
188	svdProp6a m = s \|~\| s' && v \|~\| v' && s \|~\| s'' && u \|~\| u'
189	where (u,s,v) = svdR m
190	(s',v') = rightSVR m
191	(u',s'') = leftSVR m
192
193	svdProp6b m = s \|~\| s' && v \|~\| v' && s \|~\| s'' && u \|~\| u'
194	where (u,s,v) = svdC m
195	(s',v') = rightSVC m
196	(u',s'') = leftSVC m
197
198	svdProp7 m = s \|~\| s' && u \|~\| u' && v \|~\| v' && s \|~\| s'''
199	where (u,s,v) = svd m
200	(s',v') = rightSV m
201	(u',_s'') = leftSV m
202	s''' = singularValues m
203
204	------------------------------------------------------------------
205
206	eigProp m = complex m <> v \|~\| v <> diag s
207	where (s, v) = eig m
208
209	eigSHProp m = m <> v \|~\| v <> real (diag s)
210	&& unitary v
211	&& m \|~\| v <> real (diag s) <> ctrans v
212	where (s, v) = eigSH m
213
214	eigProp2 m = fst (eig m) \|~\| eigenvalues m
215
216	eigSHProp2 m = fst (eigSH m) \|~\| eigenvaluesSH m
217
218	------------------------------------------------------------------
219
220	qrProp m = q <> r \|~\| m && unitary q && upperTriang r
221	where (q,r) = qr m
222
223	rqProp m = r <> q \|~\| m && unitary q && upperTriang' r
224	where (r,q) = rq m
225
226	rqProp1 m = r <> q \|~\| m
227	where (r,q) = rq m
228
229	rqProp2 m = unitary q
230	where (r,q) = rq m
231
232	rqProp3 m = upperTriang' r
233	where (r,q) = rq m
234
235	upperTriang' r = upptr (rows r) (cols r) * r \|~\| r
236	where upptr f c = buildMatrix f c $ \(r',c') -> if r'-t > c' then 0 else 1
237	where t = f-c
238
239	hessProp m = m \|~\| p <> h <> ctrans p && unitary p && upperHessenberg h
240	where (p,h) = hess m
241
242	schurProp1 m = m \|~\| u <> s <> ctrans u && unitary u && upperTriang s
243	where (u,s) = schur m
244
245	schurProp2 m = m \|~\| u <> s <> ctrans u && unitary u && upperHessenberg s -- fixme
246	where (u,s) = schur m
247
248	cholProp m = m \|~\| ctrans c <> c && upperTriang c
249	where c = chol m
250
251	exactProp m = chol m == chol (m+0)
252
253	expmDiagProp m = expm (logm m) :~ 7 ~: complex m
254	where logm = matFunc log
255
256	-- reference multiply
257	mulH a b = fromLists [[ doth ai bj \| bj <- toColumns b] \| ai <- toRows a ]
258	where doth u v = sum $ zipWith (*) (toList u) (toList v)
259
260	multProp1 p (a,b) = (a <> b) :~p~: (mulH a b)
261
262	multProp2 p (a,b) = (ctrans (a <> b)) :~p~: (ctrans b <> ctrans a)
263
264	linearSolveProp f m = f m m \|~\| ident (rows m)
265
266	linearSolveProp2 f (a,x) = not wc `trivial` (not wc \|\| a <> f a b \|~\| b)
267	where q = min (rows a) (cols a)
268	b = a <> x
269	wc = rank a == q
270
271	subProp m = m == (trans . fromColumns . toRows) m
272


diff --git a/lib/Numeric/LinearAlgebra/Tests/quickCheckCompat.h b/lib/Numeric/LinearAlgebra/Tests/quickCheckCompat.h deleted file mode 100644 index 714587b..0000000 --- a/lib/Numeric/LinearAlgebra/Tests/quickCheckCompat.h +++ /dev/null
@@ -1,33 +0,0 @@
1	#ifndef MIN_VERSION_QuickCheck
2	#define MIN_VERSION_QuickCheck(A,B,C) 1
3	#endif
4
5	#if MIN_VERSION_QuickCheck(2,0,0)
6	import Test.QuickCheck(Arbitrary,arbitrary,coarbitrary,choose,vector
7	,sized,classify,Testable,Property
8
9	,quickCheckWith,maxSize,stdArgs,shrink)
10
11	#else
12	import Test.QuickCheck(Arbitrary,arbitrary,coarbitrary,choose,vector
13	,sized,classify,Testable,Property
14
15	,check,configSize,defaultConfig,trivial)
16	#endif
17
18
19
20	#if MIN_VERSION_QuickCheck(2,0,0)
21	trivial :: Testable a => Bool -> a -> Property
22	trivial = (`classify` "trivial")
23	#else
24	#endif
25
26
27	-- define qCheck, which used to be in Tests.hs
28	#if MIN_VERSION_QuickCheck(2,0,0)
29	qCheck n = quickCheckWith stdArgs {maxSize = n}
30	#else
31	qCheck n = check defaultConfig {configSize = const n}
32	#endif
33