From 01a14ad32e0fd8586498ead61a426f20b724652b Mon Sep 17 00:00:00 2001 From: Alberto Ruiz Date: Thu, 22 Nov 2007 17:03:41 +0000 Subject: app1, app2, ... --- lib/Data/Packed/Internal/Common.hs | 25 +++++++++++++++++++++++++ lib/Data/Packed/Internal/Matrix.hs | 19 +++++++------------ lib/Data/Packed/Internal/Vector.hs | 30 ++++-------------------------- 3 files changed, 36 insertions(+), 38 deletions(-) (limited to 'lib/Data') diff --git a/lib/Data/Packed/Internal/Common.hs b/lib/Data/Packed/Internal/Common.hs index c3a733c..dc1c2b4 100644 --- a/lib/Data/Packed/Internal/Common.hs +++ b/lib/Data/Packed/Internal/Common.hs @@ -23,6 +23,8 @@ import Debug.Trace import Data.List(transpose,intersperse) import Data.Typeable import Data.Maybe(fromJust) +import Foreign.C.String(peekCString) +import Foreign.C.Types ---------------------------------------------------------------------- instance (Storable a, RealFloat a) => Storable (Complex a) where -- @@ -65,6 +67,13 @@ ww2 w1 o1 w2 o2 f = w1 o1 $ \a1 -> w2 o2 $ \a2 -> f a1 a2 ww3 w1 o1 w2 o2 w3 o3 f = w1 o1 $ \a1 -> ww2 w2 o2 w3 o3 (f a1) ww4 w1 o1 w2 o2 w3 o3 w4 o4 f = w1 o1 $ \a1 -> ww3 w2 o2 w3 o3 w4 o4 (f a1) +app1 f w1 o1 s = w1 o1 $ \a1 -> f // a1 // check s +app2 f w1 o1 w2 o2 s = ww2 w1 o1 w2 o2 $ \a1 a2 -> f // a1 // a2 // check s +app3 f w1 o1 w2 o2 w3 o3 s = ww3 w1 o1 w2 o2 w3 o3 $ + \a1 a2 a3 -> f // a1 // a2 // a3 // check s +app4 f w1 o1 w2 o2 w3 o3 w4 o4 s = ww4 w1 o1 w2 o2 w3 o3 w4 o4 $ + \a1 a2 a3 a4 -> f // a1 // a2 // a3 // a4 // check s + -- GSL error codes are <= 1024 -- | error codes for the auxiliary functions required by the wrappers errorCode :: Int -> String @@ -78,6 +87,22 @@ errorCode 2006 = "the input matrix is not positive definite" errorCode 2007 = "not yet supported in this OS" errorCode n = "code "++show n +-- | check the error code +check :: String -> IO Int -> IO () +check msg f = do + err <- f + when (err/=0) $ if err > 1024 + then (error (msg++": "++errorCode err)) -- our errors + else do -- GSL errors + ps <- gsl_strerror err + s <- peekCString ps + error (msg++": "++s) + return () + +-- | description of GSL error codes +foreign import ccall "auxi.h gsl_strerror" gsl_strerror :: Int -> IO (Ptr CChar) + + {- | conversion of Haskell functions into function pointers that can be used in the C side -} foreign import ccall "wrapper" mkfun:: (Double -> Ptr() -> Double) -> IO( FunPtr (Double -> Ptr() -> Double)) diff --git a/lib/Data/Packed/Internal/Matrix.hs b/lib/Data/Packed/Internal/Matrix.hs index 90a96b5..0519603 100644 --- a/lib/Data/Packed/Internal/Matrix.hs +++ b/lib/Data/Packed/Internal/Matrix.hs @@ -79,8 +79,7 @@ cmat MF {rows = r, cols = c, fdat = d } = MC {rows = r, cols = c, cdat = transda fmat m@MF{} = m fmat MC {rows = r, cols = c, cdat = d } = MF {rows = r, cols = c, fdat = transdata c d r} ---matc m f = f (rows m) (cols m) (ptr (cdat m)) ---matf m f = f (rows m) (cols m) (ptr (fdat m)) +mat = withMatrix withMatrix MC {rows = r, cols = c, cdat = d } f = withForeignPtr (fptr d) $ \p -> do @@ -308,8 +307,7 @@ subMatrixR :: (Int,Int) -> (Int,Int) -> Matrix Double -> Matrix Double subMatrixR (r0,c0) (rt,ct) x' = unsafePerformIO $ do r <- createMatrix RowMajor rt ct let x = cmat x' - ww2 withMatrix x withMatrix r $ \x r -> - c_submatrixR r0 (r0+rt-1) c0 (c0+ct-1) // x // r // check "subMatrixR" + app2 (c_submatrixR r0 (r0+rt-1) c0 (c0+ct-1)) mat x mat r "subMatrixR" return r foreign import ccall "auxi.h submatrixR" c_submatrixR :: Int -> Int -> Int -> Int -> TMM @@ -333,8 +331,7 @@ subMatrix = subMatrixD diagAux fun msg (v@V {dim = n}) = unsafePerformIO $ do m <- createMatrix RowMajor n n - ww2 withVector v withMatrix m $ \v m -> - fun // v // m // check msg + app2 fun vec v mat m msg return m -- | diagonal matrix from a real vector @@ -356,19 +353,18 @@ diag = diagD constantAux fun x n = unsafePerformIO $ do v <- createVector n px <- newArray [x] - withVector v $ \v -> - fun px // v // check "constantAux" + app1 (fun px) vec v "constantAux" free px return v constantR :: Double -> Int -> Vector Double constantR = constantAux cconstantR -foreign import ccall safe "auxi.h constantR" +foreign import ccall "auxi.h constantR" cconstantR :: Ptr Double -> TV -- Double :> IO Int constantC :: Complex Double -> Int -> Vector (Complex Double) constantC = constantAux cconstantC -foreign import ccall safe "auxi.h constantC" +foreign import ccall "auxi.h constantC" cconstantC :: Ptr (Complex Double) -> TCV -- Complex Double :> IO Int {- | creates a vector with a given number of equal components: @@ -403,8 +399,7 @@ fromFile :: FilePath -> (Int,Int) -> IO (Matrix Double) fromFile filename (r,c) = do charname <- newCString filename res <- createMatrix RowMajor r c - withMatrix res $ \res -> - c_gslReadMatrix charname // res // check "gslReadMatrix" + app1 (c_gslReadMatrix charname) mat res "gslReadMatrix" --free charname -- TO DO: free the auxiliary CString return res foreign import ccall "auxi.h matrix_fscanf" c_gslReadMatrix:: Ptr CChar -> TM diff --git a/lib/Data/Packed/Internal/Vector.hs b/lib/Data/Packed/Internal/Vector.hs index 386ebb5..7eee5fe 100644 --- a/lib/Data/Packed/Internal/Vector.hs +++ b/lib/Data/Packed/Internal/Vector.hs @@ -21,10 +21,6 @@ import Foreign import Complex import Control.Monad(when) import Data.List(transpose) -import Debug.Trace(trace) -import Foreign.C.String(peekCString) -import Foreign.C.Types -import Data.Monoid -- | A one-dimensional array of objects stored in a contiguous memory block. data Vector t = V { dim :: Int -- ^ number of elements @@ -33,30 +29,14 @@ data Vector t = V { dim :: Int -- ^ number of elements --ptr (V _ fptr) = unsafeForeignPtrToPtr fptr --- | check the error code -check :: String -> IO Int -> IO () -check msg f = do - err <- f - when (err/=0) $ if err > 1024 - then (error (msg++": "++errorCode err)) -- our errors - else do -- GSL errors - ps <- gsl_strerror err - s <- peekCString ps - error (msg++": "++s) - return () - --- | description of GSL error codes -foreign import ccall "auxi.h gsl_strerror" gsl_strerror :: Int -> IO (Ptr CChar) - -- | signature of foreign functions admitting C-style vectors type Vc t s = Int -> Ptr t -> s -- not yet admitted by my haddock version -- infixr 5 :> -- type t :> s = Vc t s ---- | adaptation of our vectors to be admitted by foreign functions: @f \/\/ vec v@ ---vec :: Vector t -> (Vc t s) -> s ---vec v f = f (dim v) (ptr v) + +vec = withVector withVector (V n fp) f = withForeignPtr fp $ \p -> do let v f = do @@ -80,8 +60,7 @@ fromList :: Storable a => [a] -> Vector a fromList l = unsafePerformIO $ do v <- createVector (length l) let f _ p = pokeArray p l >> return 0 - withVector v $ \v -> - f // v // check "fromList" + app1 f vec v "fromList" return v safeRead v = unsafePerformIO . withForeignPtr (fptr v) @@ -124,8 +103,7 @@ subVector k l (v@V {dim=n}) | otherwise = unsafePerformIO $ do r <- createVector l let f _ s _ d = copyArray d (advancePtr s k) l >> return 0 - ww2 withVector v withVector r $ \v r -> - f // v // r // check "subVector" + app2 f vec v vec r "subVector" return r {- | Reads a vector position: -- cgit v1.2.3