From 6adcc50c3043352738cd7b2c2e741b7735608b4e Mon Sep 17 00:00:00 2001 From: octopuscabbage Date: Thu, 24 Sep 2015 22:19:53 -0500 Subject: [PATCH 1/6] tests are now run in parallel --- matrix.cabal | 3 +++ test/Main.hs | 52 ++++++++++++++++++++++++++-------------------------- 2 files changed, 29 insertions(+), 26 deletions(-) diff --git a/matrix.cabal b/matrix.cabal index 284b14d..ccc117b 100644 --- a/matrix.cabal +++ b/matrix.cabal @@ -50,11 +50,14 @@ Test-Suite matrix-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base == 4.* , matrix , tasty , QuickCheck , tasty-quickcheck + , hspec + Test-Suite matrix-examples type: exitcode-stdio-1.0 diff --git a/test/Main.hs b/test/Main.hs index b2b2487..a90a35e 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -7,6 +7,7 @@ import Data.Monoid (mconcat) import Test.Tasty import qualified Test.Tasty.QuickCheck as QC import Test.QuickCheck +import Test.Hspec {- matrix package test set @@ -54,75 +55,74 @@ instance Arbitrary Sq where Sq <$> genMatrix n n main :: IO () -main = defaultMain $ testGroup "matrix tests" [ - QC.testProperty "zero n m = matrix n m (const 0)" +main = hspec $ parallel $ describe "matrix tests" $do + it "zero n m = matrix n m (const 0)"$ property $ \(I n) (I m) -> zero n m == matrix n m (const 0) - , QC.testProperty "identity * m = m * identity = m" + it "identity * m = m * identity = m" $ property $ \(Sq m) -> let n = nrows m in identity n * m == m && m * identity n == m - , QC.testProperty "a * (b * c) = (a * b) * c" + it "a * (b * c) = (a * b) * c" $ property $ \(I a) (I b) (I c) (I d) -> forAll (genMatrix a b) $ \m1 -> forAll (genMatrix b c) $ \m2 -> forAll (genMatrix c d) $ \m3 -> m1 * (m2 * m3) == (m1 * m2) * m3 - , QC.testProperty "multStd a b = multStd2 a b" + it "multStd a b = multStd2 a b" $ property $ \(I a) (I b) (I c) -> forAll (genMatrix a b) $ \m1 -> forAll (genMatrix b c) $ \m2 -> multStd m1 m2 == multStd2 m1 m2 - , QC.testProperty "getMatrixAsVector m = mconcat [ getRow i m | i <- [1 .. nrows m]]" + it "getMatrixAsVector m = mconcat [ getRow i m | i <- [1 .. nrows m]]" $ property $ \m -> getMatrixAsVector (m :: Matrix R) == mconcat [ getRow i m | i <- [1 .. nrows m] ] - , QC.testProperty "fmap id = id" + it "fmap id = id" $ property $ \m -> fmap id m == (m :: Matrix R) - , QC.testProperty "permMatrix n i j * permMatrix n i j = identity n" + it "permMatrix n i j * permMatrix n i j = identity n" $ property $ \(I n) -> forAll (choose (1,n)) $ \i -> forAll (choose (1,n)) $ \j -> permMatrix n i j * permMatrix n i j == identity n - , QC.testProperty "setElem (getElem i j m) (i,j) m = m" + it "setElem (getElem i j m) (i,j) m = m" $ property $ \m -> forAll (choose (1,nrows m)) $ \i -> forAll (choose (1,ncols m)) $ \j -> setElem (getElem i j m) (i,j) m == (m :: Matrix R) - , QC.testProperty "transpose (transpose m) = m" + it "transpose (transpose m) = m" $ property $ \m -> transpose (transpose m) == (m :: Matrix R) - , QC.testProperty "if m' = setSize e r c m then (nrows m' = r) && (ncols m' = c)" + it "if m' = setSize e r c m then (nrows m' = r) && (ncols m' = c)" $ property $ \e (I r) (I c) m -> let m' :: Matrix R ; m' = setSize e r c m in nrows m' == r && ncols m' == c - , QC.testProperty "if (nrows m = r) && (nrcols m = c) then setSize _ r c m = m" + it "if (nrows m = r) && (nrcols m = c) then setSize _ r c m = m" $ property $ \m -> let r = nrows m c = ncols m in setSize undefined r c m == (m :: Matrix R) - , QC.testProperty "getRow i m = getCol i (transpose m)" + it "getRow i m = getCol i (transpose m)" $ property $ \m -> forAll (choose (1,nrows m)) $ \i -> getRow i (m :: Matrix R) == getCol i (transpose m) - , QC.testProperty "joinBlocks (splitBlocks i j m) = m" + it "joinBlocks (splitBlocks i j m) = m" $ property $ \m -> forAll (choose (1,nrows m)) $ \i -> forAll (choose (1,ncols m)) $ \j -> joinBlocks (splitBlocks i j m) == (m :: Matrix R) - , QC.testProperty "scaleMatrix k m = fmap (*k) m" + it "scaleMatrix k m = fmap (*k) m" $ property $ \k m -> scaleMatrix k m == fmap (*k) (m :: Matrix R) - , QC.testProperty "(+) = elementwise (+)" + it "(+) = elementwise (+)" $ property $ \m1 -> forAll (genMatrix (nrows m1) (ncols m1)) $ \m2 -> m1 + m2 == elementwise (+) m1 m2 - , QC.testProperty "switchCols i j = transpose . switchRows i j . transpose" + it"switchCols i j = transpose . switchRows i j . transpose" $ property $ \m -> forAll (choose (1,ncols m)) $ \i -> forAll (choose (1,ncols m)) $ \j -> switchCols i j (m :: Matrix R) == (transpose $ switchRows i j $ transpose m) - , QC.testProperty "detLaplace (fromList 3 3 $ repeat 1) = 0" + it"detLaplace (fromList 3 3 $ repeat 1) = 0"$ property $ detLaplace (fromList 3 3 $ repeat 1) == 0 - , QC.testProperty "if (u,l,p,d) = luDecomp m then (p*m = l*u) && (detLaplace p = d)" + it "if (u,l,p,d) = luDecomp m then (p*m = l*u) && (detLaplace p = d)" $ property $ \(Sq m) -> (detLaplace m /= 0) ==> (let (u,l,p,d) = luDecompUnsafe m in p*m == l*u && detLaplace p == d) - , QC.testProperty "detLaplace m = detLU m" + it "detLaplace m = detLU m" $ property $ \(Sq m) -> detLaplace m == detLU m - , QC.testProperty "if (u,l,p,q,d,e) = luDecomp' m then (p*m*q = l*u) && (detLU p = d) && (detLU q = e)" + it "if (u,l,p,q,d,e) = luDecomp' m then (p*m*q = l*u) && (detLU p = d) && (detLU q = e)" $ property $ \(Sq m) -> (detLU m /= 0) ==> (let (u,l,p,q,d,e) = luDecompUnsafe' m in p*m*q == l*u && detLU p == d && detLU q == e) - , QC.testProperty "detLU (scaleRow k i m) = k * detLU m" + it "detLU (scaleRow k i m) = k * detLU m" $ property $ \(Sq m) k -> forAll (choose (1,nrows m)) $ \i -> detLU (scaleRow k i m) == k * detLU m - , QC.testProperty "let n = nrows m in detLU (switchRows i j m) = detLU (permMatrix n i j) * detLU m" + it "let n = nrows m in detLU (switchRows i j m) = detLU (permMatrix n i j) * detLU m" $ property $ \(Sq m) -> let n = nrows m in forAll (choose (1,n)) $ \i -> forAll (choose (1,n)) $ \j -> detLU (switchRows i j m) == detLU (permMatrix n i j) * detLU m - , QC.testProperty "fromList n m . toList = id" + it "fromList n m . toList = id" $ property $ \m -> fromList (nrows m) (ncols m) (toList m) == (m :: Matrix R) - , QC.testProperty "fromLists . toLists = id" + it "fromLists . toLists = id" $ property $ \m -> fromLists (toLists m) == (m :: Matrix R) - ] From 5fbd6b3bbf56e06932141456fb3bff7dde59bb40 Mon Sep 17 00:00:00 2001 From: octopuscabbage Date: Wed, 20 Jan 2016 22:15:34 -0600 Subject: [PATCH 2/6] Wrote Monoid and Applicative instance Also added utility flatten function --- Data/Matrix.hs | 44 +++++++++++++++++++++++++++++++++++++++++++- test/Main.hs | 25 +++++++++++++++++++++++-- 2 files changed, 66 insertions(+), 3 deletions(-) diff --git a/Data/Matrix.hs b/Data/Matrix.hs index 05b1a41..e777c3d 100644 --- a/Data/Matrix.hs +++ b/Data/Matrix.hs @@ -71,13 +71,14 @@ import Control.Monad (forM_) import Control.Loop (numLoop,numLoopFold) import Data.Foldable (Foldable, foldMap) import Data.Monoid -import Data.Traversable +import Data.Traversable() -- Data import Control.Monad.Primitive (PrimMonad, PrimState) import Data.List (maximumBy,foldl1') import Data.Ord (comparing) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV +import Data.Maybe ------------------------------------------------------- ------------------------------------------------------- @@ -152,6 +153,47 @@ instance Functor Matrix where ------------------------------------------------------- ------------------------------------------------------- +------------------------------------------------------- +------------------------------------------------------- +---- MONOID INSTANCE + +instance Monoid a => Monoid (Matrix a) where + mempty = fromList 1 1 [mempty] + mappend m m' = matrix (max (nrows m) (nrows m')) (max (ncols m) (ncols m')) $ uncurry zipTogether + where zipTogether row column + | (isJust melem && isJust m'elem) = (fromJust melem) <> (fromJust m'elem) + | (isJust melem) = (fromJust melem) + | (isJust m'elem) = fromJust m'elem + | otherwise = mempty + where melem = safeGet row column m + m'elem = safeGet row column m' + + +------------------------------------------------------- +------------------------------------------------------- +------------------------------------------------------- +------------------------------------------------------- + +------------------------------------------------------- +------------------------------------------------------- +---- APPLICATIVE INSTANCE +---- Works like tensor product but applies a function + +instance Applicative Matrix where + pure x = fromList 1 1 [x] + m <*> m' = flatten $ ((\f -> f <$> m') <$> m) + + +------------------------------------------------------- +------------------------------------------------------- + + + +-- | Flatten a matrix of matrices. All sub matrices must have same dimensions +-- This criteria is not checked. +flatten:: (Matrix (Matrix a)) -> Matrix a +flatten m = foldl1 (<->) $ map (foldl1 (<|>)) $ map (\i -> getRow i m) [1..(nrows m)] + -- | /O(rows*cols)/. Map a function over a row. -- Example: -- diff --git a/test/Main.hs b/test/Main.hs index a90a35e..3d708eb 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -2,11 +2,12 @@ import Data.Matrix import Data.Ratio import Control.Applicative -import Data.Monoid (mconcat) +import Data.Monoid import Test.Tasty import qualified Test.Tasty.QuickCheck as QC import Test.QuickCheck +import Test.QuickCheck.Function import Test.Hspec {- matrix package test set @@ -37,6 +38,9 @@ instance Arbitrary a => Arbitrary (Matrix a) where I m <- arbitrary genMatrix' n m +instance Arbitrary a => Arbitrary (Sum a) where + arbitrary = Sum <$> arbitrary + genMatrix' :: Arbitrary a => Int -> Int -> Gen (Matrix a) genMatrix' n m = fromList n m <$> vector (n*m) @@ -125,4 +129,21 @@ main = hspec $ parallel $ describe "matrix tests" $do it "fromList n m . toList = id" $ property $ \m -> fromList (nrows m) (ncols m) (toList m) == (m :: Matrix R) it "fromLists . toLists = id" $ property - $ \m -> fromLists (toLists m) == (m :: Matrix R) + $ \m -> fromLists (toLists m) == (m :: Matrix (Sum Int)) + it "monoid law: mappend mempty x = x" $ property + $ \x -> mappend mempty (x :: Matrix (Sum Int)) == x + it "monoid law: mappend x mempty = x" $ property + $ \x -> mappend (x :: Matrix (Sum Int)) mempty == x + it "monoid law: mappend x (mappend y z) = mappend (mappend x y) z " $ property + $ \x y z -> mappend (x :: Matrix (Sum Int)) (mappend (y::Matrix (Sum Int)) (z::Matrix (Sum Int))) == mappend (mappend x y) z + it "applicative law - identity: pure id <*> v = v" $ property + $ \x -> (pure id <*> (x :: (Matrix Int))) == x + {-- I couldn't get this one towork + it "applicative law - composition: pure (.) <*> u <*> v <*> w = u <*> (v <*> w)" $ property + $ \u v w -> (pure (.) <*> (u :: Matrix (Int->Int)) <*> (v::Matrix(Int->Int)) <*> (w::Matrix(Int->Int))) == (u <*> (v <*> w)) + it "applicative law - homomorphism: pure f <*> pure x = pure (f x)" $ property + $ \(Fun _ f) x -> (pure f <*> pure (x :: Int)) == pure (f x) + it "applicative law - interchange: u <*> pure y = pure ($ y) <*> u" $ property + $ \(Fun _ u) y -> (u <*> pure (y :: Int)) == (pure ($ y ) <*> u) + --} + From 70f1e737be614eb51e668e841ce6ba2145d7ef07 Mon Sep 17 00:00:00 2001 From: octopuscabbage Date: Tue, 26 Jan 2016 11:31:48 -0600 Subject: [PATCH 3/6] monoid instance now uses monoid instance of maybe --- Data/Matrix.hs | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/Data/Matrix.hs b/Data/Matrix.hs index e777c3d..f8c832b 100644 --- a/Data/Matrix.hs +++ b/Data/Matrix.hs @@ -160,13 +160,7 @@ instance Functor Matrix where instance Monoid a => Monoid (Matrix a) where mempty = fromList 1 1 [mempty] mappend m m' = matrix (max (nrows m) (nrows m')) (max (ncols m) (ncols m')) $ uncurry zipTogether - where zipTogether row column - | (isJust melem && isJust m'elem) = (fromJust melem) <> (fromJust m'elem) - | (isJust melem) = (fromJust melem) - | (isJust m'elem) = fromJust m'elem - | otherwise = mempty - where melem = safeGet row column m - m'elem = safeGet row column m' + where zipTogether row column = fromMaybe mempty $ safeGet row column m <> safeGet row column m' ------------------------------------------------------- @@ -1275,4 +1269,3 @@ detLU :: (Ord a, Fractional a) => Matrix a -> a detLU m = case luDecomp m of Just (u,_,_,d) -> d * diagProd u Nothing -> 0 - From 3b09ac5183f754265aaf2e0351371e3ed188ed8b Mon Sep 17 00:00:00 2001 From: octopuscabbage Date: Tue, 26 Jan 2016 11:37:27 -0600 Subject: [PATCH 4/6] flatten now uses functor laws to be more efficient --- Data/Matrix.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Data/Matrix.hs b/Data/Matrix.hs index f8c832b..6e87d70 100644 --- a/Data/Matrix.hs +++ b/Data/Matrix.hs @@ -63,6 +63,7 @@ module Data.Matrix ( -- ** Determinants , detLaplace , detLU + , flatten ) where -- Classes @@ -186,7 +187,7 @@ instance Applicative Matrix where -- | Flatten a matrix of matrices. All sub matrices must have same dimensions -- This criteria is not checked. flatten:: (Matrix (Matrix a)) -> Matrix a -flatten m = foldl1 (<->) $ map (foldl1 (<|>)) $ map (\i -> getRow i m) [1..(nrows m)] +flatten m = foldl1 (<->) $ map (foldl1 (<|>) . (\i -> getRow i m)) [1..(nrows m)] -- | /O(rows*cols)/. Map a function over a row. -- Example: From 5c4d95c2e2a62f4702371a189c060f7d5ad72adf Mon Sep 17 00:00:00 2001 From: octopuscabbage Date: Tue, 26 Jan 2016 21:13:07 -0600 Subject: [PATCH 5/6] applicative laws now work --- test/Main.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index 3d708eb..493801f 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -58,6 +58,9 @@ instance Arbitrary Sq where I n <- arbitrary Sq <$> genMatrix n n +matrixPure:: a -> Matrix a --Only useful as a type constraint +matrixPure = pure + main :: IO () main = hspec $ parallel $ describe "matrix tests" $do it "zero n m = matrix n m (const 0)"$ property @@ -138,12 +141,10 @@ main = hspec $ parallel $ describe "matrix tests" $do $ \x y z -> mappend (x :: Matrix (Sum Int)) (mappend (y::Matrix (Sum Int)) (z::Matrix (Sum Int))) == mappend (mappend x y) z it "applicative law - identity: pure id <*> v = v" $ property $ \x -> (pure id <*> (x :: (Matrix Int))) == x - {-- I couldn't get this one towork it "applicative law - composition: pure (.) <*> u <*> v <*> w = u <*> (v <*> w)" $ property - $ \u v w -> (pure (.) <*> (u :: Matrix (Int->Int)) <*> (v::Matrix(Int->Int)) <*> (w::Matrix(Int->Int))) == (u <*> (v <*> w)) + $ \(Fun _ u) (Fun _ v) w -> (matrixPure (.) <*> matrixPure (u :: Int->Int) <*> matrixPure (v:: Int->Int) <*> matrixPure (w :: Int)) == (matrixPure u <*> (matrixPure v <*> matrixPure w)) it "applicative law - homomorphism: pure f <*> pure x = pure (f x)" $ property - $ \(Fun _ f) x -> (pure f <*> pure (x :: Int)) == pure (f x) + $ \(Fun _ f) x -> (matrixPure (f :: Int -> Int) <*> pure (x :: Int)) == pure (f x) it "applicative law - interchange: u <*> pure y = pure ($ y) <*> u" $ property - $ \(Fun _ u) y -> (u <*> pure (y :: Int)) == (pure ($ y ) <*> u) - --} + $ \(Fun _ u) y -> ((matrixPure (u :: Int -> Int)) <*> pure (y :: Int)) == (pure ($ y ) <*> (pure u)) From 892e803e17c10b094420a2d95ba07ff08980d7e9 Mon Sep 17 00:00:00 2001 From: octopuscabbage Date: Tue, 26 Jan 2016 22:20:39 -0600 Subject: [PATCH 6/6] applicative instances now use larger matrices --- test/Main.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index 493801f..5ec91fd 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE FlexibleInstances #-} import Data.Matrix import Data.Ratio import Control.Applicative @@ -32,6 +32,11 @@ instance Show I where instance Arbitrary I where arbitrary = I <$> choose (1,9) +instance CoArbitrary a => CoArbitrary (Matrix a) where + coarbitrary = coarbitrary . toList +instance Show (Int -> Int) where + show _ = "" + instance Arbitrary a => Arbitrary (Matrix a) where arbitrary = do I n <- arbitrary @@ -58,9 +63,6 @@ instance Arbitrary Sq where I n <- arbitrary Sq <$> genMatrix n n -matrixPure:: a -> Matrix a --Only useful as a type constraint -matrixPure = pure - main :: IO () main = hspec $ parallel $ describe "matrix tests" $do it "zero n m = matrix n m (const 0)"$ property @@ -142,9 +144,8 @@ main = hspec $ parallel $ describe "matrix tests" $do it "applicative law - identity: pure id <*> v = v" $ property $ \x -> (pure id <*> (x :: (Matrix Int))) == x it "applicative law - composition: pure (.) <*> u <*> v <*> w = u <*> (v <*> w)" $ property - $ \(Fun _ u) (Fun _ v) w -> (matrixPure (.) <*> matrixPure (u :: Int->Int) <*> matrixPure (v:: Int->Int) <*> matrixPure (w :: Int)) == (matrixPure u <*> (matrixPure v <*> matrixPure w)) + $ \u v w -> (pure (.) <*> (u :: Matrix (Int->Int)) <*> (v :: Matrix (Int->Int)) <*> (w :: Matrix Int)) == (u <*> (v <*> w)) it "applicative law - homomorphism: pure f <*> pure x = pure (f x)" $ property - $ \(Fun _ f) x -> (matrixPure (f :: Int -> Int) <*> pure (x :: Int)) == pure (f x) + $ \f x -> ((pure (f :: Int -> Int) <*> pure (x :: Int))::Matrix Int) == pure (f x) it "applicative law - interchange: u <*> pure y = pure ($ y) <*> u" $ property - $ \(Fun _ u) y -> ((matrixPure (u :: Int -> Int)) <*> pure (y :: Int)) == (pure ($ y ) <*> (pure u)) - + $ \u y -> ((u :: Matrix (Int -> Int)) <*> pure (y :: Int)) == (pure ($ y ) <*> u)