summaryrefslogtreecommitdiff
path: root/lib/Data/Packed
diff options
context:
space:
mode:
authorAlberto Ruiz <aruiz@um.es>2007-11-22 17:03:41 +0000
committerAlberto Ruiz <aruiz@um.es>2007-11-22 17:03:41 +0000
commit01a14ad32e0fd8586498ead61a426f20b724652b (patch)
treeb894c4d09700c2cf1f6abf2c89e6df81eebddb71 /lib/Data/Packed
parent2f45fdd97f80c0ffd0e10cce68d1cd24a43696c0 (diff)
app1, app2, ...
Diffstat (limited to 'lib/Data/Packed')
-rw-r--r--lib/Data/Packed/Internal/Common.hs25
-rw-r--r--lib/Data/Packed/Internal/Matrix.hs19
-rw-r--r--lib/Data/Packed/Internal/Vector.hs30
3 files changed, 36 insertions, 38 deletions
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
23import Data.List(transpose,intersperse) 23import Data.List(transpose,intersperse)
24import Data.Typeable 24import Data.Typeable
25import Data.Maybe(fromJust) 25import Data.Maybe(fromJust)
26import Foreign.C.String(peekCString)
27import Foreign.C.Types
26 28
27---------------------------------------------------------------------- 29----------------------------------------------------------------------
28instance (Storable a, RealFloat a) => Storable (Complex a) where -- 30instance (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
65ww3 w1 o1 w2 o2 w3 o3 f = w1 o1 $ \a1 -> ww2 w2 o2 w3 o3 (f a1) 67ww3 w1 o1 w2 o2 w3 o3 f = w1 o1 $ \a1 -> ww2 w2 o2 w3 o3 (f a1)
66ww4 w1 o1 w2 o2 w3 o3 w4 o4 f = w1 o1 $ \a1 -> ww3 w2 o2 w3 o3 w4 o4 (f a1) 68ww4 w1 o1 w2 o2 w3 o3 w4 o4 f = w1 o1 $ \a1 -> ww3 w2 o2 w3 o3 w4 o4 (f a1)
67 69
70app1 f w1 o1 s = w1 o1 $ \a1 -> f // a1 // check s
71app2 f w1 o1 w2 o2 s = ww2 w1 o1 w2 o2 $ \a1 a2 -> f // a1 // a2 // check s
72app3 f w1 o1 w2 o2 w3 o3 s = ww3 w1 o1 w2 o2 w3 o3 $
73 \a1 a2 a3 -> f // a1 // a2 // a3 // check s
74app4 f w1 o1 w2 o2 w3 o3 w4 o4 s = ww4 w1 o1 w2 o2 w3 o3 w4 o4 $
75 \a1 a2 a3 a4 -> f // a1 // a2 // a3 // a4 // check s
76
68-- GSL error codes are <= 1024 77-- GSL error codes are <= 1024
69-- | error codes for the auxiliary functions required by the wrappers 78-- | error codes for the auxiliary functions required by the wrappers
70errorCode :: Int -> String 79errorCode :: Int -> String
@@ -78,6 +87,22 @@ errorCode 2006 = "the input matrix is not positive definite"
78errorCode 2007 = "not yet supported in this OS" 87errorCode 2007 = "not yet supported in this OS"
79errorCode n = "code "++show n 88errorCode n = "code "++show n
80 89
90-- | check the error code
91check :: String -> IO Int -> IO ()
92check msg f = do
93 err <- f
94 when (err/=0) $ if err > 1024
95 then (error (msg++": "++errorCode err)) -- our errors
96 else do -- GSL errors
97 ps <- gsl_strerror err
98 s <- peekCString ps
99 error (msg++": "++s)
100 return ()
101
102-- | description of GSL error codes
103foreign import ccall "auxi.h gsl_strerror" gsl_strerror :: Int -> IO (Ptr CChar)
104
105
81{- | conversion of Haskell functions into function pointers that can be used in the C side 106{- | conversion of Haskell functions into function pointers that can be used in the C side
82-} 107-}
83foreign import ccall "wrapper" mkfun:: (Double -> Ptr() -> Double) -> IO( FunPtr (Double -> Ptr() -> Double)) 108foreign 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
79fmat m@MF{} = m 79fmat m@MF{} = m
80fmat MC {rows = r, cols = c, cdat = d } = MF {rows = r, cols = c, fdat = transdata c d r} 80fmat MC {rows = r, cols = c, cdat = d } = MF {rows = r, cols = c, fdat = transdata c d r}
81 81
82--matc m f = f (rows m) (cols m) (ptr (cdat m)) 82mat = withMatrix
83--matf m f = f (rows m) (cols m) (ptr (fdat m))
84 83
85withMatrix MC {rows = r, cols = c, cdat = d } f = 84withMatrix MC {rows = r, cols = c, cdat = d } f =
86 withForeignPtr (fptr d) $ \p -> do 85 withForeignPtr (fptr d) $ \p -> do
@@ -308,8 +307,7 @@ subMatrixR :: (Int,Int) -> (Int,Int) -> Matrix Double -> Matrix Double
308subMatrixR (r0,c0) (rt,ct) x' = unsafePerformIO $ do 307subMatrixR (r0,c0) (rt,ct) x' = unsafePerformIO $ do
309 r <- createMatrix RowMajor rt ct 308 r <- createMatrix RowMajor rt ct
310 let x = cmat x' 309 let x = cmat x'
311 ww2 withMatrix x withMatrix r $ \x r -> 310 app2 (c_submatrixR r0 (r0+rt-1) c0 (c0+ct-1)) mat x mat r "subMatrixR"
312 c_submatrixR r0 (r0+rt-1) c0 (c0+ct-1) // x // r // check "subMatrixR"
313 return r 311 return r
314foreign import ccall "auxi.h submatrixR" c_submatrixR :: Int -> Int -> Int -> Int -> TMM 312foreign import ccall "auxi.h submatrixR" c_submatrixR :: Int -> Int -> Int -> Int -> TMM
315 313
@@ -333,8 +331,7 @@ subMatrix = subMatrixD
333 331
334diagAux fun msg (v@V {dim = n}) = unsafePerformIO $ do 332diagAux fun msg (v@V {dim = n}) = unsafePerformIO $ do
335 m <- createMatrix RowMajor n n 333 m <- createMatrix RowMajor n n
336 ww2 withVector v withMatrix m $ \v m -> 334 app2 fun vec v mat m msg
337 fun // v // m // check msg
338 return m 335 return m
339 336
340-- | diagonal matrix from a real vector 337-- | diagonal matrix from a real vector
@@ -356,19 +353,18 @@ diag = diagD
356constantAux fun x n = unsafePerformIO $ do 353constantAux fun x n = unsafePerformIO $ do
357 v <- createVector n 354 v <- createVector n
358 px <- newArray [x] 355 px <- newArray [x]
359 withVector v $ \v -> 356 app1 (fun px) vec v "constantAux"
360 fun px // v // check "constantAux"
361 free px 357 free px
362 return v 358 return v
363 359
364constantR :: Double -> Int -> Vector Double 360constantR :: Double -> Int -> Vector Double
365constantR = constantAux cconstantR 361constantR = constantAux cconstantR
366foreign import ccall safe "auxi.h constantR" 362foreign import ccall "auxi.h constantR"
367 cconstantR :: Ptr Double -> TV -- Double :> IO Int 363 cconstantR :: Ptr Double -> TV -- Double :> IO Int
368 364
369constantC :: Complex Double -> Int -> Vector (Complex Double) 365constantC :: Complex Double -> Int -> Vector (Complex Double)
370constantC = constantAux cconstantC 366constantC = constantAux cconstantC
371foreign import ccall safe "auxi.h constantC" 367foreign import ccall "auxi.h constantC"
372 cconstantC :: Ptr (Complex Double) -> TCV -- Complex Double :> IO Int 368 cconstantC :: Ptr (Complex Double) -> TCV -- Complex Double :> IO Int
373 369
374{- | creates a vector with a given number of equal components: 370{- | creates a vector with a given number of equal components:
@@ -403,8 +399,7 @@ fromFile :: FilePath -> (Int,Int) -> IO (Matrix Double)
403fromFile filename (r,c) = do 399fromFile filename (r,c) = do
404 charname <- newCString filename 400 charname <- newCString filename
405 res <- createMatrix RowMajor r c 401 res <- createMatrix RowMajor r c
406 withMatrix res $ \res -> 402 app1 (c_gslReadMatrix charname) mat res "gslReadMatrix"
407 c_gslReadMatrix charname // res // check "gslReadMatrix"
408 --free charname -- TO DO: free the auxiliary CString 403 --free charname -- TO DO: free the auxiliary CString
409 return res 404 return res
410foreign import ccall "auxi.h matrix_fscanf" c_gslReadMatrix:: Ptr CChar -> TM 405foreign 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
21import Complex 21import Complex
22import Control.Monad(when) 22import Control.Monad(when)
23import Data.List(transpose) 23import Data.List(transpose)
24import Debug.Trace(trace)
25import Foreign.C.String(peekCString)
26import Foreign.C.Types
27import Data.Monoid
28 24
29-- | A one-dimensional array of objects stored in a contiguous memory block. 25-- | A one-dimensional array of objects stored in a contiguous memory block.
30data Vector t = V { dim :: Int -- ^ number of elements 26data Vector t = V { dim :: Int -- ^ number of elements
@@ -33,30 +29,14 @@ data Vector t = V { dim :: Int -- ^ number of elements
33 29
34--ptr (V _ fptr) = unsafeForeignPtrToPtr fptr 30--ptr (V _ fptr) = unsafeForeignPtrToPtr fptr
35 31
36-- | check the error code
37check :: String -> IO Int -> IO ()
38check msg f = do
39 err <- f
40 when (err/=0) $ if err > 1024
41 then (error (msg++": "++errorCode err)) -- our errors
42 else do -- GSL errors
43 ps <- gsl_strerror err
44 s <- peekCString ps
45 error (msg++": "++s)
46 return ()
47
48-- | description of GSL error codes
49foreign import ccall "auxi.h gsl_strerror" gsl_strerror :: Int -> IO (Ptr CChar)
50
51-- | signature of foreign functions admitting C-style vectors 32-- | signature of foreign functions admitting C-style vectors
52type Vc t s = Int -> Ptr t -> s 33type Vc t s = Int -> Ptr t -> s
53-- not yet admitted by my haddock version 34-- not yet admitted by my haddock version
54-- infixr 5 :> 35-- infixr 5 :>
55-- type t :> s = Vc t s 36-- type t :> s = Vc t s
56 37
57--- | adaptation of our vectors to be admitted by foreign functions: @f \/\/ vec v@ 38
58--vec :: Vector t -> (Vc t s) -> s 39vec = withVector
59--vec v f = f (dim v) (ptr v)
60 40
61withVector (V n fp) f = withForeignPtr fp $ \p -> do 41withVector (V n fp) f = withForeignPtr fp $ \p -> do
62 let v f = do 42 let v f = do
@@ -80,8 +60,7 @@ fromList :: Storable a => [a] -> Vector a
80fromList l = unsafePerformIO $ do 60fromList l = unsafePerformIO $ do
81 v <- createVector (length l) 61 v <- createVector (length l)
82 let f _ p = pokeArray p l >> return 0 62 let f _ p = pokeArray p l >> return 0
83 withVector v $ \v -> 63 app1 f vec v "fromList"
84 f // v // check "fromList"
85 return v 64 return v
86 65
87safeRead v = unsafePerformIO . withForeignPtr (fptr v) 66safeRead v = unsafePerformIO . withForeignPtr (fptr v)
@@ -124,8 +103,7 @@ subVector k l (v@V {dim=n})
124 | otherwise = unsafePerformIO $ do 103 | otherwise = unsafePerformIO $ do
125 r <- createVector l 104 r <- createVector l
126 let f _ s _ d = copyArray d (advancePtr s k) l >> return 0 105 let f _ s _ d = copyArray d (advancePtr s k) l >> return 0
127 ww2 withVector v withVector r $ \v r -> 106 app2 f vec v vec r "subVector"
128 f // v // r // check "subVector"
129 return r 107 return r
130 108
131{- | Reads a vector position: 109{- | Reads a vector position: