From 8bdb87764762ef43b186bcc04caa404928df22fa Mon Sep 17 00:00:00 2001 From: Sidharth Kapur Date: Mon, 1 Feb 2016 17:40:40 -0600 Subject: some work (will probably undo this commit later) --- packages/base/hmatrix.cabal | 3 +- packages/base/src/Internal/Matrix.hs | 1 + packages/base/src/Internal/Static.hs | 25 ++++++++++-- packages/gsl/hmatrix-gsl.cabal | 3 +- packages/gsl/src/Numeric/GSL/Polynomials.hs | 5 ++- packages/special/hmatrix-special.cabal | 5 +-- packages/special/lib/Numeric/GSL/Special/Airy.hs | 1 + packages/special/lib/Numeric/GSL/Special/Bessel.hs | 1 + .../special/lib/Numeric/GSL/Special/Clausen.hs | 1 + .../special/lib/Numeric/GSL/Special/Coulomb.hs | 1 + .../special/lib/Numeric/GSL/Special/Coupling.hs | 1 + packages/special/lib/Numeric/GSL/Special/Dawson.hs | 1 + packages/special/lib/Numeric/GSL/Special/Debye.hs | 1 + packages/special/lib/Numeric/GSL/Special/Dilog.hs | 1 + .../special/lib/Numeric/GSL/Special/Elementary.hs | 1 + packages/special/lib/Numeric/GSL/Special/Ellint.hs | 1 + packages/special/lib/Numeric/GSL/Special/Erf.hs | 1 + packages/special/lib/Numeric/GSL/Special/Exp.hs | 1 + packages/special/lib/Numeric/GSL/Special/Expint.hs | 1 + .../special/lib/Numeric/GSL/Special/Fermi_dirac.hs | 1 + packages/special/lib/Numeric/GSL/Special/Gamma.hs | 1 + .../special/lib/Numeric/GSL/Special/Gegenbauer.hs | 1 + packages/special/lib/Numeric/GSL/Special/Hyperg.hs | 1 + .../special/lib/Numeric/GSL/Special/Laguerre.hs | 1 + .../special/lib/Numeric/GSL/Special/Lambert.hs | 1 + .../special/lib/Numeric/GSL/Special/Legendre.hs | 1 + packages/special/lib/Numeric/GSL/Special/Log.hs | 1 + .../special/lib/Numeric/GSL/Special/Pow_int.hs | 1 + packages/special/lib/Numeric/GSL/Special/Psi.hs | 1 + .../special/lib/Numeric/GSL/Special/Synchrotron.hs | 1 + .../special/lib/Numeric/GSL/Special/Transport.hs | 1 + packages/special/lib/Numeric/GSL/Special/Trig.hs | 1 + packages/special/lib/Numeric/GSL/Special/Zeta.hs | 1 + packages/tests/hmatrix-tests.cabal | 1 + packages/tests/src/Numeric/LinearAlgebra/Tests.hs | 10 +++++ .../src/Numeric/LinearAlgebra/Tests/Instances.hs | 46 +++++++++++++++++++--- .../src/Numeric/LinearAlgebra/Tests/Properties.hs | 44 ++++++++++++++++++++- 37 files changed, 151 insertions(+), 19 deletions(-) diff --git a/packages/base/hmatrix.cabal b/packages/base/hmatrix.cabal index 9fa3c4e..5524d2b 100644 --- a/packages/base/hmatrix.cabal +++ b/packages/base/hmatrix.cabal @@ -79,8 +79,7 @@ library src/Internal/C/vector-aux.c - extensions: ForeignFunctionInterface, - CPP + extensions: ForeignFunctionInterface ghc-options: -Wall -fno-warn-missing-signatures diff --git a/packages/base/src/Internal/Matrix.hs b/packages/base/src/Internal/Matrix.hs index 3082e8d..f9b02ca 100644 --- a/packages/base/src/Internal/Matrix.hs +++ b/packages/base/src/Internal/Matrix.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveGeneric #-} diff --git a/packages/base/src/Internal/Static.hs b/packages/base/src/Internal/Static.hs index 419ff07..0ad2cad 100644 --- a/packages/base/src/Internal/Static.hs +++ b/packages/base/src/Internal/Static.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DataKinds #-} @@ -12,6 +13,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} {- | Module : Internal.Static @@ -33,6 +35,8 @@ import Control.DeepSeq import Data.Proxy(Proxy) import Foreign.Storable(Storable) import Text.Printf +import Data.Binary +import GHC.Generics (Generic) -------------------------------------------------------------------------------- @@ -40,7 +44,14 @@ type ℝ = Double type ℂ = Complex Double newtype Dim (n :: Nat) t = Dim t - deriving Show + deriving (Show, Generic) + +instance Binary a => Binary (Complex a) + where + put (r :+ i) = put (r, i) + get = (\(r,i) -> r :+ i) <$> get + +instance (Binary a) => Binary (Dim n a) lift1F :: (c t -> c t) @@ -58,15 +69,21 @@ instance NFData t => NFData (Dim n t) where -------------------------------------------------------------------------------- newtype R n = R (Dim n (Vector ℝ)) - deriving (Num,Fractional,Floating) + deriving (Num,Fractional,Floating,Generic) newtype C n = C (Dim n (Vector ℂ)) - deriving (Num,Fractional,Floating) + deriving (Num,Fractional,Floating,Generic) newtype L m n = L (Dim m (Dim n (Matrix ℝ))) + deriving (Generic) -newtype M m n = M (Dim m (Dim n (Matrix ℂ))) +newtype M m n = M (Dim m (Dim n (Matrix ℂ))) + deriving (Generic) +instance (KnownNat n) => Binary (R n) +instance (KnownNat n) => Binary (C n) +instance (KnownNat m, KnownNat n) => Binary (L m n) +instance (KnownNat m, KnownNat n) => Binary (M m n) mkR :: Vector ℝ -> R n mkR = R . Dim diff --git a/packages/gsl/hmatrix-gsl.cabal b/packages/gsl/hmatrix-gsl.cabal index d009994..bfd1abf 100644 --- a/packages/gsl/hmatrix-gsl.cabal +++ b/packages/gsl/hmatrix-gsl.cabal @@ -29,8 +29,7 @@ library process, random - Extensions: ForeignFunctionInterface, - CPP + Extensions: ForeignFunctionInterface hs-source-dirs: src Exposed-modules: Numeric.GSL.Differentiation, diff --git a/packages/gsl/src/Numeric/GSL/Polynomials.hs b/packages/gsl/src/Numeric/GSL/Polynomials.hs index 8890f8f..46a31f3 100644 --- a/packages/gsl/src/Numeric/GSL/Polynomials.hs +++ b/packages/gsl/src/Numeric/GSL/Polynomials.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {- | Module : Numeric.GSL.Polynomials Copyright : (c) Alberto Ruiz 2006 @@ -24,7 +25,7 @@ import System.IO.Unsafe (unsafePerformIO) import Foreign.C.Types (CInt(..)) #endif -{- | Solution of general polynomial equations, using /gsl_poly_complex_solve/. +{- | Solution of general polynomial equations, using /gsl_poly_complex_solve/. For example, the three solutions of x^3 + 8 = 0 @@ -41,7 +42,7 @@ The example in the GSL manual: To find the roots of x^5 -1 = 0: 0.30901699437494756 :+ (-0.9510565162951535), 1.0000000000000002 :+ 0.0] --} +-} polySolve :: [Double] -> [Complex Double] polySolve = toList . polySolve' . fromList diff --git a/packages/special/hmatrix-special.cabal b/packages/special/hmatrix-special.cabal index 3b122c8..368ed2c 100644 --- a/packages/special/hmatrix-special.cabal +++ b/packages/special/hmatrix-special.cabal @@ -29,8 +29,7 @@ flag safe-cheap library Build-Depends: base <5, hmatrix>=0.17, hmatrix-gsl - Extensions: ForeignFunctionInterface, - CPP + Extensions: ForeignFunctionInterface hs-source-dirs: lib @@ -67,7 +66,7 @@ library other-modules: Numeric.GSL.Special.Internal ghc-options: -Wall -fno-warn-unused-binds - + if flag(safe-cheap) cpp-options: -DSAFE_CHEAP=safe else diff --git a/packages/special/lib/Numeric/GSL/Special/Airy.hs b/packages/special/lib/Numeric/GSL/Special/Airy.hs index 737de7c..78f14b8 100644 --- a/packages/special/lib/Numeric/GSL/Special/Airy.hs +++ b/packages/special/lib/Numeric/GSL/Special/Airy.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Airy diff --git a/packages/special/lib/Numeric/GSL/Special/Bessel.hs b/packages/special/lib/Numeric/GSL/Special/Bessel.hs index 4a80c28..70066f8 100644 --- a/packages/special/lib/Numeric/GSL/Special/Bessel.hs +++ b/packages/special/lib/Numeric/GSL/Special/Bessel.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Bessel diff --git a/packages/special/lib/Numeric/GSL/Special/Clausen.hs b/packages/special/lib/Numeric/GSL/Special/Clausen.hs index 80bd45c..c495c99 100644 --- a/packages/special/lib/Numeric/GSL/Special/Clausen.hs +++ b/packages/special/lib/Numeric/GSL/Special/Clausen.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Clausen diff --git a/packages/special/lib/Numeric/GSL/Special/Coulomb.hs b/packages/special/lib/Numeric/GSL/Special/Coulomb.hs index 218213a..6904739 100644 --- a/packages/special/lib/Numeric/GSL/Special/Coulomb.hs +++ b/packages/special/lib/Numeric/GSL/Special/Coulomb.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Coulomb diff --git a/packages/special/lib/Numeric/GSL/Special/Coupling.hs b/packages/special/lib/Numeric/GSL/Special/Coupling.hs index 326f53f..ad120cc 100644 --- a/packages/special/lib/Numeric/GSL/Special/Coupling.hs +++ b/packages/special/lib/Numeric/GSL/Special/Coupling.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Coupling diff --git a/packages/special/lib/Numeric/GSL/Special/Dawson.hs b/packages/special/lib/Numeric/GSL/Special/Dawson.hs index 9f73767..58d92a5 100644 --- a/packages/special/lib/Numeric/GSL/Special/Dawson.hs +++ b/packages/special/lib/Numeric/GSL/Special/Dawson.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Dawson diff --git a/packages/special/lib/Numeric/GSL/Special/Debye.hs b/packages/special/lib/Numeric/GSL/Special/Debye.hs index 7ca17e4..91f9f19 100644 --- a/packages/special/lib/Numeric/GSL/Special/Debye.hs +++ b/packages/special/lib/Numeric/GSL/Special/Debye.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Debye diff --git a/packages/special/lib/Numeric/GSL/Special/Dilog.hs b/packages/special/lib/Numeric/GSL/Special/Dilog.hs index 32cceba..aaebd9f 100644 --- a/packages/special/lib/Numeric/GSL/Special/Dilog.hs +++ b/packages/special/lib/Numeric/GSL/Special/Dilog.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Dilog diff --git a/packages/special/lib/Numeric/GSL/Special/Elementary.hs b/packages/special/lib/Numeric/GSL/Special/Elementary.hs index e58a697..2c092cd 100644 --- a/packages/special/lib/Numeric/GSL/Special/Elementary.hs +++ b/packages/special/lib/Numeric/GSL/Special/Elementary.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Elementary diff --git a/packages/special/lib/Numeric/GSL/Special/Ellint.hs b/packages/special/lib/Numeric/GSL/Special/Ellint.hs index 365c366..678f6db 100644 --- a/packages/special/lib/Numeric/GSL/Special/Ellint.hs +++ b/packages/special/lib/Numeric/GSL/Special/Ellint.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Ellint diff --git a/packages/special/lib/Numeric/GSL/Special/Erf.hs b/packages/special/lib/Numeric/GSL/Special/Erf.hs index 171a3c5..ef96a18 100644 --- a/packages/special/lib/Numeric/GSL/Special/Erf.hs +++ b/packages/special/lib/Numeric/GSL/Special/Erf.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Erf diff --git a/packages/special/lib/Numeric/GSL/Special/Exp.hs b/packages/special/lib/Numeric/GSL/Special/Exp.hs index 3b70078..b6dfeef 100644 --- a/packages/special/lib/Numeric/GSL/Special/Exp.hs +++ b/packages/special/lib/Numeric/GSL/Special/Exp.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Exp diff --git a/packages/special/lib/Numeric/GSL/Special/Expint.hs b/packages/special/lib/Numeric/GSL/Special/Expint.hs index 06f4594..faef752 100644 --- a/packages/special/lib/Numeric/GSL/Special/Expint.hs +++ b/packages/special/lib/Numeric/GSL/Special/Expint.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Expint diff --git a/packages/special/lib/Numeric/GSL/Special/Fermi_dirac.hs b/packages/special/lib/Numeric/GSL/Special/Fermi_dirac.hs index c39c096..fe45d53 100644 --- a/packages/special/lib/Numeric/GSL/Special/Fermi_dirac.hs +++ b/packages/special/lib/Numeric/GSL/Special/Fermi_dirac.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Fermi_dirac diff --git a/packages/special/lib/Numeric/GSL/Special/Gamma.hs b/packages/special/lib/Numeric/GSL/Special/Gamma.hs index 78115f1..41e24f0 100644 --- a/packages/special/lib/Numeric/GSL/Special/Gamma.hs +++ b/packages/special/lib/Numeric/GSL/Special/Gamma.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Gamma diff --git a/packages/special/lib/Numeric/GSL/Special/Gegenbauer.hs b/packages/special/lib/Numeric/GSL/Special/Gegenbauer.hs index a3c998a..fb8bf3f 100644 --- a/packages/special/lib/Numeric/GSL/Special/Gegenbauer.hs +++ b/packages/special/lib/Numeric/GSL/Special/Gegenbauer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Gegenbauer diff --git a/packages/special/lib/Numeric/GSL/Special/Hyperg.hs b/packages/special/lib/Numeric/GSL/Special/Hyperg.hs index ac237a5..3f63b8f 100644 --- a/packages/special/lib/Numeric/GSL/Special/Hyperg.hs +++ b/packages/special/lib/Numeric/GSL/Special/Hyperg.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Hyperg diff --git a/packages/special/lib/Numeric/GSL/Special/Laguerre.hs b/packages/special/lib/Numeric/GSL/Special/Laguerre.hs index 28b3d20..919dc25 100644 --- a/packages/special/lib/Numeric/GSL/Special/Laguerre.hs +++ b/packages/special/lib/Numeric/GSL/Special/Laguerre.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Laguerre diff --git a/packages/special/lib/Numeric/GSL/Special/Lambert.hs b/packages/special/lib/Numeric/GSL/Special/Lambert.hs index 44fbfb1..71ec9c2 100644 --- a/packages/special/lib/Numeric/GSL/Special/Lambert.hs +++ b/packages/special/lib/Numeric/GSL/Special/Lambert.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Lambert diff --git a/packages/special/lib/Numeric/GSL/Special/Legendre.hs b/packages/special/lib/Numeric/GSL/Special/Legendre.hs index cb33e2e..927fa2c 100644 --- a/packages/special/lib/Numeric/GSL/Special/Legendre.hs +++ b/packages/special/lib/Numeric/GSL/Special/Legendre.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Legendre diff --git a/packages/special/lib/Numeric/GSL/Special/Log.hs b/packages/special/lib/Numeric/GSL/Special/Log.hs index 3becf15..6111ed9 100644 --- a/packages/special/lib/Numeric/GSL/Special/Log.hs +++ b/packages/special/lib/Numeric/GSL/Special/Log.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Log diff --git a/packages/special/lib/Numeric/GSL/Special/Pow_int.hs b/packages/special/lib/Numeric/GSL/Special/Pow_int.hs index 08fd497..6f2540c 100644 --- a/packages/special/lib/Numeric/GSL/Special/Pow_int.hs +++ b/packages/special/lib/Numeric/GSL/Special/Pow_int.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Pow_int diff --git a/packages/special/lib/Numeric/GSL/Special/Psi.hs b/packages/special/lib/Numeric/GSL/Special/Psi.hs index da53d1b..9e2e31a 100644 --- a/packages/special/lib/Numeric/GSL/Special/Psi.hs +++ b/packages/special/lib/Numeric/GSL/Special/Psi.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Psi diff --git a/packages/special/lib/Numeric/GSL/Special/Synchrotron.hs b/packages/special/lib/Numeric/GSL/Special/Synchrotron.hs index b3292a6..c518c30 100644 --- a/packages/special/lib/Numeric/GSL/Special/Synchrotron.hs +++ b/packages/special/lib/Numeric/GSL/Special/Synchrotron.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Synchrotron diff --git a/packages/special/lib/Numeric/GSL/Special/Transport.hs b/packages/special/lib/Numeric/GSL/Special/Transport.hs index b92b578..0047104 100644 --- a/packages/special/lib/Numeric/GSL/Special/Transport.hs +++ b/packages/special/lib/Numeric/GSL/Special/Transport.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Transport diff --git a/packages/special/lib/Numeric/GSL/Special/Trig.hs b/packages/special/lib/Numeric/GSL/Special/Trig.hs index 43fdc95..f2c1519 100644 --- a/packages/special/lib/Numeric/GSL/Special/Trig.hs +++ b/packages/special/lib/Numeric/GSL/Special/Trig.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Trig diff --git a/packages/special/lib/Numeric/GSL/Special/Zeta.hs b/packages/special/lib/Numeric/GSL/Special/Zeta.hs index a57a918..53a6314 100644 --- a/packages/special/lib/Numeric/GSL/Special/Zeta.hs +++ b/packages/special/lib/Numeric/GSL/Special/Zeta.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ------------------------------------------------------------ -- | -- Module : Numeric.GSL.Special.Zeta diff --git a/packages/tests/hmatrix-tests.cabal b/packages/tests/hmatrix-tests.cabal index d4c87aa..00f3a38 100644 --- a/packages/tests/hmatrix-tests.cabal +++ b/packages/tests/hmatrix-tests.cabal @@ -29,6 +29,7 @@ library Build-Depends: base >= 4 && < 5, deepseq, QuickCheck >= 2, HUnit, random, hmatrix >= 0.18 + , binary if flag(gsl) Build-Depends: hmatrix-gsl >= 0.18 diff --git a/packages/tests/src/Numeric/LinearAlgebra/Tests.hs b/packages/tests/src/Numeric/LinearAlgebra/Tests.hs index d9cc3b6..043ebf3 100644 --- a/packages/tests/src/Numeric/LinearAlgebra/Tests.hs +++ b/packages/tests/src/Numeric/LinearAlgebra/Tests.hs @@ -26,6 +26,7 @@ module Numeric.LinearAlgebra.Tests( utest, runTests, runBenchmarks + , binaryTests -- , findNaN --, runBigTests ) where @@ -743,6 +744,15 @@ makeUnitary v | realPart n > 1 = v / scalar n | otherwise = v where n = sqrt (v `dot` v) +binaryTests :: IO () +binaryTests = do + let test :: forall t . T.Testable t => t -> IO () + test = qCheck 100 + test vectorBinaryRoundtripProp + test staticVectorBinaryRoundtripProp + qCheck 30 matrixBinaryRoundtripProp + qCheck 30 staticMatrixBinaryRoundtripProp + -- -- | Some additional tests on big matrices. They take a few minutes. -- runBigTests :: IO () -- runBigTests = undefined diff --git a/packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs b/packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs index 3d5441d..23d7e6f 100644 --- a/packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs +++ b/packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, UndecidableInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances, FlexibleInstances, ScopedTypeVariables #-} ----------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra.Tests.Instances @@ -29,6 +29,10 @@ import Numeric.LinearAlgebra.HMatrix hiding (vector) import Control.Monad(replicateM) import Test.QuickCheck(Arbitrary,arbitrary,choose,vector,sized,shrink) +import GHC.TypeLits +import Data.Proxy (Proxy) +import qualified Numeric.LinearAlgebra.Static as Static + shrinkListElementwise :: (Arbitrary a) => [a] -> [[a]] shrinkListElementwise [] = [] @@ -40,14 +44,27 @@ shrinkPair (a,b) = [ (a,x) | x <- shrink b ] ++ [ (x,b) | x <- shrink a ] chooseDim = sized $ \m -> choose (1,max 1 m) -instance (Field a, Arbitrary a) => Arbitrary (Vector a) where +instance (Field a, Arbitrary a) => Arbitrary (Vector a) where arbitrary = do m <- chooseDim l <- vector m return $ fromList l -- shrink any one of the components shrink = map fromList . shrinkListElementwise . toList -instance (Element a, Arbitrary a) => Arbitrary (Matrix a) where +instance KnownNat n => Arbitrary (Static.R n) where + arbitrary = do + l <- vector n + return (Static.fromList l) + + where proxy :: Proxy n + proxy = proxy + + n :: Int + n = fromIntegral (natVal proxy) + + shrink v = [] + +instance (Element a, Arbitrary a) => Arbitrary (Matrix a) where arbitrary = do m <- chooseDim n <- chooseDim @@ -57,9 +74,28 @@ instance (Element a, Arbitrary a) => Arbitrary (Matrix a) where -- shrink any one of the components shrink a = map (rows a >< cols a) . shrinkListElementwise - . concat . toLists + . concat . toLists $ a +instance (KnownNat n, KnownNat m) => Arbitrary (Static.L m n) where + arbitrary = do + l <- vector (m * n) + return (Static.fromList l) + + where proxyM :: Proxy m + proxyM = proxyM + + proxyN :: Proxy n + proxyN = proxyN + + m :: Int + m = fromIntegral (natVal proxyM) + + n :: Int + n = fromIntegral (natVal proxyN) + + shrink mat = [] + -- a square matrix newtype (Sq a) = Sq (Matrix a) deriving Show instance (Element a, Arbitrary a) => Arbitrary (Sq a) where @@ -121,7 +157,7 @@ instance (ArbitraryField a, Numeric a) => Arbitrary (SqWC a) where -- a positive definite square matrix (the eigenvalues are between 0 and 100) newtype (PosDef a) = PosDef (Matrix a) deriving Show -instance (Numeric a, ArbitraryField a, Num (Vector a)) +instance (Numeric a, ArbitraryField a, Num (Vector a)) => Arbitrary (PosDef a) where arbitrary = do m <- arbitrary diff --git a/packages/tests/src/Numeric/LinearAlgebra/Tests/Properties.hs b/packages/tests/src/Numeric/LinearAlgebra/Tests/Properties.hs index 046644f..0de9f37 100644 --- a/packages/tests/src/Numeric/LinearAlgebra/Tests/Properties.hs +++ b/packages/tests/src/Numeric/LinearAlgebra/Tests/Properties.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- {- | @@ -39,12 +40,25 @@ module Numeric.LinearAlgebra.Tests.Properties ( expmDiagProp, multProp1, multProp2, subProp, - linearSolveProp, linearSolvePropH, linearSolveProp2 + linearSolveProp, linearSolvePropH, linearSolveProp2, + + -- Binary properties + vectorBinaryRoundtripProp + , staticVectorBinaryRoundtripProp + , matrixBinaryRoundtripProp + , staticMatrixBinaryRoundtripProp + , staticVectorBinaryFailProp ) where import Numeric.LinearAlgebra.HMatrix hiding (Testable,unitary) +import qualified Numeric.LinearAlgebra.Static as Static import Test.QuickCheck +import Data.Binary +import Data.Binary.Get (runGet) +import Data.Either (isLeft) +import Debug.Trace (traceShowId) + (~=) :: Double -> Double -> Bool a ~= b = abs (a - b) < 1e-10 @@ -275,3 +289,31 @@ linearSolveProp2 f (a,x) = not wc `trivial` (not wc || a <> f a b |~| b) subProp m = m == (conj . tr . fromColumns . toRows) m +------------------------------------------------------------------ + +vectorBinaryRoundtripProp :: Vector Double -> Bool +vectorBinaryRoundtripProp vec = decode (encode vec) == vec + +staticVectorBinaryRoundtripProp :: Static.R 5 -> Bool +staticVectorBinaryRoundtripProp vec = + let + decoded = decode (encode vec) :: Static.R 500 + in + Static.extract decoded == Static.extract vec + +matrixBinaryRoundtripProp :: Matrix Double -> Bool +matrixBinaryRoundtripProp mat = decode (encode mat) == mat + +staticMatrixBinaryRoundtripProp :: Static.L 100 200 -> Bool +staticMatrixBinaryRoundtripProp mat = + let + decoded = decode (encode mat) :: Static.L 100 200 + in + (Static.extract decoded) == (Static.extract mat) + +staticVectorBinaryFailProp :: Static.R 20 -> Bool +staticVectorBinaryFailProp vec = + let + decoded = runGet get (encode vec) :: Either String (Static.R 50) + in + isLeft decoded -- cgit v1.2.3 From 3824df2f2f17c8395832b88b27d61fdc22553f2e Mon Sep 17 00:00:00 2001 From: Sidharth Kapur Date: Sun, 13 Mar 2016 15:30:43 -0500 Subject: Simplify binary instances --- packages/base/src/Internal/Static.hs | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/packages/base/src/Internal/Static.hs b/packages/base/src/Internal/Static.hs index 1e9a5a3..058b9d0 100644 --- a/packages/base/src/Internal/Static.hs +++ b/packages/base/src/Internal/Static.hs @@ -69,21 +69,16 @@ instance NFData t => NFData (Dim n t) where -------------------------------------------------------------------------------- newtype R n = R (Dim n (Vector ℝ)) - deriving (Num,Fractional,Floating,Generic) + deriving (Num,Fractional,Floating,Generic,Binary) newtype C n = C (Dim n (Vector ℂ)) - deriving (Num,Fractional,Floating,Generic) + deriving (Num,Fractional,Floating,Generic,Binary) newtype L m n = L (Dim m (Dim n (Matrix ℝ))) - deriving (Generic) + deriving (Generic, Binary) newtype M m n = M (Dim m (Dim n (Matrix ℂ))) - deriving (Generic) - -instance (KnownNat n) => Binary (R n) -instance (KnownNat n) => Binary (C n) -instance (KnownNat m, KnownNat n) => Binary (L m n) -instance (KnownNat m, KnownNat n) => Binary (M m n) + deriving (Generic, Binary) mkR :: Vector ℝ -> R n mkR = R . Dim -- cgit v1.2.3 From 91e9c879bfa3b509cd737ba31580cbba0c0bf340 Mon Sep 17 00:00:00 2001 From: Sidharth Kapur Date: Sun, 13 Mar 2016 17:25:23 -0500 Subject: Add dimension check in Dim binary instance --- packages/base/src/Internal/Static.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/packages/base/src/Internal/Static.hs b/packages/base/src/Internal/Static.hs index 058b9d0..a0af085 100644 --- a/packages/base/src/Internal/Static.hs +++ b/packages/base/src/Internal/Static.hs @@ -35,8 +35,10 @@ import Control.DeepSeq import Data.Proxy(Proxy) import Foreign.Storable(Storable) import Text.Printf + import Data.Binary import GHC.Generics (Generic) +import Data.Proxy (Proxy(..)) -------------------------------------------------------------------------------- @@ -51,7 +53,17 @@ instance Binary a => Binary (Complex a) put (r :+ i) = put (r, i) get = (\(r,i) -> r :+ i) <$> get -instance (Binary a) => Binary (Dim n a) +instance (KnownNat n, Binary a) => Binary (Dim n a) where + get = do + k <- get + let n = natVal (Proxy :: Proxy n) + if n == k + then Dim <$> get + else fail ("Expected dimension " ++ (show n) ++ ", but found dimension " ++ (show k)) + + put (Dim x) = do + put (natVal (Proxy :: Proxy n)) + put x lift1F :: (c t -> c t) -- cgit v1.2.3 From 7a861a58211a0fb020dca2db2767de24538648b7 Mon Sep 17 00:00:00 2001 From: Sidharth Kapur Date: Sun, 13 Mar 2016 17:28:08 -0500 Subject: Simplify test code --- .../tests/src/Numeric/LinearAlgebra/Tests/Instances.hs | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs b/packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs index 23d7e6f..3211877 100644 --- a/packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs +++ b/packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs @@ -30,7 +30,7 @@ import Control.Monad(replicateM) import Test.QuickCheck(Arbitrary,arbitrary,choose,vector,sized,shrink) import GHC.TypeLits -import Data.Proxy (Proxy) +import Data.Proxy (Proxy(..)) import qualified Numeric.LinearAlgebra.Static as Static @@ -82,17 +82,12 @@ instance (KnownNat n, KnownNat m) => Arbitrary (Static.L m n) where l <- vector (m * n) return (Static.fromList l) - where proxyM :: Proxy m - proxyM = proxyM + where + m :: Int + m = fromIntegral (natVal (Proxy :: Proxy m)) - proxyN :: Proxy n - proxyN = proxyN - - m :: Int - m = fromIntegral (natVal proxyM) - - n :: Int - n = fromIntegral (natVal proxyN) + n :: Int + n = fromIntegral (natVal (Proxy :: Proxy n)) shrink mat = [] -- cgit v1.2.3 From 80e88bbb1fef8b904e5e01d3ca6cc35a97339cda Mon Sep 17 00:00:00 2001 From: Sidharth Kapur Date: Sun, 13 Mar 2016 17:28:58 -0500 Subject: Small change to test code --- packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs b/packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs index 3211877..37f7da2 100644 --- a/packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs +++ b/packages/tests/src/Numeric/LinearAlgebra/Tests/Instances.hs @@ -56,11 +56,9 @@ instance KnownNat n => Arbitrary (Static.R n) where l <- vector n return (Static.fromList l) - where proxy :: Proxy n - proxy = proxy - - n :: Int - n = fromIntegral (natVal proxy) + where + n :: Int + n = fromIntegral (natVal (Proxy :: Proxy n)) shrink v = [] -- cgit v1.2.3