lapack 0.2.3 → 0.2.3.1
raw patch · 6 files changed
+155/−26 lines, 6 files
Files
- lapack.cabal +2/−2
- src/Numeric/LAPACK/Permutation/Private.hs +6/−5
- test/Main.hs +1/−0
- test/Test/Generator.hs +4/−5
- test/Test/Permutation.hs +141/−13
- test/Test/Utility.hs +1/−1
lapack.cabal view
@@ -1,5 +1,5 @@ Name: lapack-Version: 0.2.3+Version: 0.2.3.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -45,7 +45,7 @@ default: False Source-Repository this- Tag: 0.2.3+ Tag: 0.2.3.1 Type: darcs Location: http://hub.darcs.net/thielema/lapack/
src/Numeric/LAPACK/Permutation/Private.hs view
@@ -30,7 +30,7 @@ import Control.Monad.Trans.Cont (ContT(ContT), evalContT) import Control.Monad.IO.Class (liftIO)-import Control.Monad (forM_)+import Control.Monad (when, forM_) import Control.Applicative ((<$>)) import Data.Bool.HT (if')@@ -184,10 +184,11 @@ fwdPtr <- Call.bool $ not inverted mPtr <- Call.cint m nPtr <- Call.cint n- kPtr <- copyToTemp n perm+ kPtr <- copyToTemp m perm aPtr <- ContT $ withForeignPtr a liftIO $ do copyBlock blockSize aPtr bPtr- case order of- RowMajor -> LapackGen.lapmt fwdPtr nPtr mPtr bPtr mPtr kPtr- ColumnMajor -> LapackGen.lapmr fwdPtr mPtr nPtr bPtr nPtr kPtr+ when (m>0 && n>0) $+ case order of+ RowMajor -> LapackGen.lapmt fwdPtr nPtr mPtr bPtr nPtr kPtr+ ColumnMajor -> LapackGen.lapmr fwdPtr mPtr nPtr bPtr mPtr kPtr
test/Main.hs view
@@ -40,6 +40,7 @@ prefix "Hermitian" Hermitian.testsVar ++ prefix "Banded" Banded.testsVar ++ prefix "BandedHermitian" BandedHermitian.testsVar +++ prefix "Permutation" Permutation.testsVar ++ prefix "Orthogonal" Orthogonal.testsVar ++ prefix "Singular" Singular.testsVar ++ []
test/Test/Generator.hs view
@@ -149,7 +149,7 @@ type Vector tag size = T tag (Variable size) -vectorDim :: (Class.Floating a) => Vector a Int ZeroInt+vectorDim :: Vector a Int ZeroInt vectorDim = Cons $ do dim <- newVariable@@ -187,8 +187,7 @@ type Matrix tag height width = T tag (Variable height, Variable width) -matrixDims ::- (Class.Floating a) => Matrix a Int Int (ZeroInt, ZeroInt)+matrixDims :: Matrix a Int Int (ZeroInt, ZeroInt) matrixDims = Cons $ do dims <- liftA2 (,) newVariable newVariable@@ -202,7 +201,7 @@ Util.genArray maxElem $ uncurry (MatrixShape.general order) dims -squareDim :: (Class.Floating a) => Matrix a Int Int ZeroInt+squareDim :: Matrix a Int Int ZeroInt squareDim = Cons $ do dim <- newVariable@@ -289,7 +288,7 @@ (GenTriangularDiag $ Util.genArray maxElem) -tallDims :: (Class.Floating a) => Matrix a Int Int (ZeroInt, ZeroInt)+tallDims :: Matrix a Int Int (ZeroInt, ZeroInt) tallDims = Cons $ do height <- newVariable
test/Test/Permutation.hs view
@@ -1,40 +1,168 @@ module Test.Permutation where +import qualified Test.Generator as Gen+import qualified Test.Utility as Util+import Test.Generator ((<|*|>))+import Test.Utility (equalArray, Tagged(Tagged))+ import qualified Numeric.LAPACK.Permutation as Perm+import qualified Numeric.LAPACK.Matrix.Square as Square+import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector-import Numeric.LAPACK.Permutation (Inversion(Inverted, NonInverted))-import Numeric.LAPACK.Matrix (ZeroInt, zeroInt)+import Numeric.LAPACK.Permutation+ (Permutation, Inversion(Inverted, NonInverted))+import Numeric.LAPACK.Matrix.Square (Square)+import Numeric.LAPACK.Matrix (ZeroInt, zeroInt, (<#>)) import Numeric.LAPACK.Vector (Vector) +import qualified Numeric.Netlib.Class as Class+ import qualified Data.Array.Comfort.Storable as Array-import Data.Array.Comfort.Storable (Array)+import qualified Data.Array.Comfort.Shape as Shape import Foreign.C.Types (CInt) import Control.Monad (forM)+import Control.Applicative (liftA2, (<$>)) import qualified Test.QuickCheck as QC -genPivots :: QC.Gen (Vector ZeroInt CInt)-genPivots = do- nat <- QC.arbitrary+genPivots :: [()] -> QC.Gen (Vector ZeroInt CInt)+genPivots nat = do let n = length nat let nc = fromIntegral n fmap (Vector.fromList (zeroInt n)) $ forM (zip [1..] nat) $ \(i,()) -> QC.choose (i,nc) +genPerm :: [()] -> QC.Gen (Permutation ZeroInt)+genPerm = fmap (\p -> Perm.fromPivots NonInverted (Array.shape p) p) . genPivots -permutationPivots :: Bool -> Array ZeroInt CInt -> Bool-permutationPivots dir xs =- let inv = if dir then Inverted else NonInverted- in Array.toList (Perm.toPivots inv (Perm.fromPivots inv (Array.shape xs) xs))- ==- Array.toList xs +permutationPivots :: Inversion -> Vector ZeroInt CInt -> Bool+permutationPivots inv xs =+ Array.toList (Perm.toPivots inv (Perm.fromPivots inv (Array.shape xs) xs))+ ==+ Array.toList xs +transposeMultiply :: (Permutation ZeroInt, Permutation ZeroInt) -> Bool+transposeMultiply (p0,p1) =+ (Array.toList $ Perm.toPivots NonInverted $+ Perm.transpose (Perm.multiply p0 p1))+ ==+ (Array.toList $ Perm.toPivots NonInverted $+ Perm.multiply (Perm.transpose p1) (Perm.transpose p0))+++genPermutation :: Gen.Matrix a Int Int (Permutation ZeroInt)+genPermutation =+ flip Gen.mapGen Gen.squareDim $ \_ sh@(Shape.ZeroBased n) ->+ let nc = fromIntegral n+ in fmap (Perm.fromPivots NonInverted sh . Vector.fromList sh) $+ forM [1..] $ \i -> QC.choose (i,nc)+++permApply ::+ (Shape.C height, Eq height, Shape.C width, Class.Floating a) =>+ Inversion -> Permutation height ->+ Matrix.General height width a ->+ Matrix.General height width a+permApply inv = Perm.apply (inv==Inverted)++permToMatrix ::+ (Shape.C sh, Class.Floating a) =>+ Inversion -> Permutation sh -> Square sh a+permToMatrix inv =+ case inv of+ NonInverted -> Perm.toMatrix+ Inverted -> Matrix.transpose . Perm.toMatrix++applyToMatrix ::+ (Class.Floating a) =>+ Inversion -> (Permutation ZeroInt, Matrix.General ZeroInt ZeroInt a) -> Bool+applyToMatrix inv (p,m) =+ equalArray+ (permApply inv p m)+ (permToMatrix inv p <#> m)++applyMultiply ::+ (Class.Floating a) =>+ Inversion ->+ (Permutation ZeroInt, Permutation ZeroInt,+ Matrix.General ZeroInt ZeroInt a) -> Bool+applyMultiply inv (p0,p1,m) =+ equalArray+ (case inv of+ NonInverted -> permApply inv p0 $ permApply inv p1 m+ Inverted -> permApply inv p1 $ permApply inv p0 m)+ (permApply inv (Perm.multiply p0 p1) m)++applyTranspose ::+ (Class.Floating a) =>+ Inversion -> (Permutation ZeroInt, Matrix.General ZeroInt ZeroInt a) -> Bool+applyTranspose inv (p,m) =+ equalArray+ (permApply inv (Perm.transpose p) m)+ (Matrix.transpose (permToMatrix inv p) <#> m)+++addTag :: Gen.T a dim array -> Gen.T a dim (Tagged a array)+addTag = fmap Tagged++taggedToMatrix ::+ (Class.Floating a) => Tagged a (Permutation ZeroInt) -> Square ZeroInt a+taggedToMatrix (Tagged p) = Perm.toMatrix p++determinantNumber ::+ (Class.Floating a, Eq a) => Tagged a (Permutation ZeroInt) -> Bool+determinantNumber tp@(Tagged p) =+ Perm.numberFromSign (Perm.determinant p)+ ==+ Square.determinant (taggedToMatrix tp)++ tests :: [(String, QC.Property)] tests = ("permutationPivots",- QC.property $ QC.forAll genPivots . permutationPivots) :+ QC.property $+ QC.forAll QC.arbitraryBoundedEnum $ \inv ->+ QC.forAll (QC.arbitrary >>= genPivots) $ \pivot ->+ permutationPivots inv pivot) :+ ("transposeMultiply",+ QC.property $+ QC.forAll+ (do nat <- QC.arbitrary+ liftA2 (,) (genPerm nat) (genPerm nat))+ transposeMultiply) :+ []++++checkForAll ::+ (Show a, QC.Testable test) =>+ Gen.T tag dim a -> (a -> test) -> Tagged tag QC.Property+checkForAll gen = Util.checkForAll (Gen.run gen 10 5)++checkForAllExtra ::+ (Show a, Show b, QC.Testable test) =>+ QC.Gen a -> Gen.T tag dim b ->+ (a -> b -> test) -> Tagged tag QC.Property+checkForAllExtra = Gen.withExtra checkForAll++testsVar ::+ (Show a, Class.Floating a, Eq a) =>+ [(String, Tagged a QC.Property)]+testsVar =+ ("applyToMatrix",+ checkForAllExtra QC.arbitraryBoundedEnum+ ((,) <$> genPermutation <|*|> Gen.matrix) applyToMatrix) :+ ("applyMultiply",+ checkForAllExtra QC.arbitraryBoundedEnum+ ((,,) <$> genPermutation <|*|> genPermutation <|*|> Gen.matrix)+ applyMultiply) :+ ("applyTranspose",+ checkForAllExtra QC.arbitraryBoundedEnum+ ((,) <$> genPermutation <|*|> Gen.matrix) applyTranspose) :+ ("determinantNumber",+ checkForAll (addTag genPermutation) determinantNumber) : []
test/Test/Utility.hs view
@@ -188,7 +188,7 @@ -newtype Tagged tag a = Tagged a+newtype Tagged tag a = Tagged a deriving (Show) type TaggedGen tag a = Tagged tag (QC.Gen a) instance Functor (Tagged tag) where