module Data.Packed.Internal.Vector (
Vector, dim,
fromList, toList, (|>),
join, (@>), safe, at, at', subVector, takesV,
mapVector, zipVector,
foldVector, foldVectorG, foldLoop,
createVector, vec,
asComplex, asReal,
fwriteVector, freadVector, fprintfVector, fscanfVector,
cloneVector,
unsafeToForeignPtr,
unsafeFromForeignPtr,
unsafeWith
) where
import Data.Packed.Internal.Common
import Data.Packed.Internal.Signatures
import Foreign
import Foreign.C.String
import Foreign.C.Types(CInt,CChar)
import Data.Complex
import Control.Monad(when)
#if __GLASGOW_HASKELL__ >= 605
import GHC.ForeignPtr (mallocPlainForeignPtrBytes)
#else
import Foreign.ForeignPtr (mallocForeignPtrBytes)
#endif
import GHC.Base
#if __GLASGOW_HASKELL__ < 612
import GHC.IOBase
#endif
#ifdef VECTOR
import qualified Data.Vector.Storable as Vector
import Data.Vector.Storable(Vector,
unsafeToForeignPtr,
unsafeFromForeignPtr,
unsafeWith)
#endif
#ifdef VECTOR
dim :: (Storable t) => Vector t -> Int
dim = Vector.length
#else
data Vector t =
V { ioff :: !Int
, idim :: !Int
, fptr :: !(ForeignPtr t)
}
unsafeToForeignPtr :: Vector a -> (ForeignPtr a, Int, Int)
unsafeToForeignPtr v = (fptr v, ioff v, idim v)
unsafeFromForeignPtr :: ForeignPtr a -> Int -> Int -> Vector a
unsafeFromForeignPtr fp i n | n > 0 = V {ioff = i, idim = n, fptr = fp}
| otherwise = error "unsafeFromForeignPtr with dim < 1"
unsafeWith (V i _ fp) m = withForeignPtr fp $ \p -> m (p `advancePtr` i)
dim :: (Storable t) => Vector t -> Int
dim = idim
#endif
vec :: (Storable t) => Vector t -> (((CInt -> Ptr t -> t1) -> t1) -> IO b) -> IO b
vec x f = unsafeWith x $ \p -> do
let v g = do
g (fi $ dim x) p
f v
createVector :: Storable a => Int -> IO (Vector a)
createVector n = do
when (n <= 0) $ error ("trying to createVector of dim "++show n)
fp <- doMalloc undefined
return $ unsafeFromForeignPtr fp 0 n
where
doMalloc :: Storable b => b -> IO (ForeignPtr b)
doMalloc dummy = do
#if __GLASGOW_HASKELL__ >= 605
mallocPlainForeignPtrBytes (n * sizeOf dummy)
#else
mallocForeignPtrBytes (n * sizeOf dummy)
#endif
fromList :: Storable a => [a] -> Vector a
fromList l = unsafePerformIO $ do
v <- createVector (length l)
unsafeWith v $ \ p -> pokeArray p l
return v
safeRead v = inlinePerformIO . unsafeWith v
inlinePerformIO :: IO a -> a
inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
toList :: Storable a => Vector a -> [a]
toList v = safeRead v $ peekArray (dim v)
(|>) :: (Storable a) => Int -> [a] -> Vector a
infixl 9 |>
n |> l = if length l' == n
then fromList l'
else error "list too short for |>"
where l' = take n l
at' :: Storable a => Vector a -> Int -> a
at' v n = safeRead v $ flip peekElemOff n
#if defined(UNSAFE)
safe :: Bool
safe = False
#else
safe = True
#endif
at :: Storable a => Vector a -> Int -> a
at v n
| safe = if n >= 0 && n < dim v
then at' v n
else error "vector index out of range"
| otherwise = at' v n
subVector :: Storable t => Int
-> Int
-> Vector t
-> Vector t
#ifdef VECTOR
subVector = Vector.slice
#else
subVector k l v@V{idim = n, ioff = i}
| k<0 || k >= n || k+l > n || l < 0 = error "subVector out of range"
| otherwise = v {idim = l, ioff = i+k}
subVectorCopy k l (v@V {idim=n})
| k<0 || k >= n || k+l > n || l < 0 = error "subVector out of range"
| otherwise = unsafePerformIO $ do
r <- createVector l
let f _ s _ d = copyArray d (advancePtr s k) l >> return 0
app2 f vec v vec r "subVector"
return r
#endif
(@>) :: Storable t => Vector t -> Int -> t
infixl 9 @>
(@>) = at
join :: Storable t => [Vector t] -> Vector t
join [] = error "joining zero vectors"
join [v] = v
join as = unsafePerformIO $ do
let tot = sum (map dim as)
r <- createVector tot
unsafeWith r $ \ptr ->
joiner as tot ptr
return r
where joiner [] _ _ = return ()
joiner (v:cs) _ p = do
let n = dim v
unsafeWith v $ \pb -> copyArray p pb n
joiner cs 0 (advancePtr p n)
takesV :: Storable t => [Int] -> Vector t -> [Vector t]
takesV ms w | sum ms > dim w = error $ "takesV " ++ show ms ++ " on dim = " ++ (show $ dim w)
| otherwise = go ms w
where go [] _ = []
go (n:ns) v = subVector 0 n v
: go ns (subVector n (dim v n) v)
asReal :: Vector (Complex Double) -> Vector Double
asReal v = unsafeFromForeignPtr (castForeignPtr fp) (2*i) (2*n)
where (fp,i,n) = unsafeToForeignPtr v
asComplex :: Vector Double -> Vector (Complex Double)
asComplex v = unsafeFromForeignPtr (castForeignPtr fp) (i `div` 2) (n `div` 2)
where (fp,i,n) = unsafeToForeignPtr v
cloneVector :: Storable t => Vector t -> IO (Vector t)
cloneVector v = do
let n = dim v
r <- createVector n
let f _ s _ d = copyArray d s n >> return 0
app2 f vec v vec r "cloneVector"
return r
mapVector :: (Storable a, Storable b) => (a-> b) -> Vector a -> Vector b
mapVector f v = unsafePerformIO $ do
w <- createVector (dim v)
unsafeWith v $ \p ->
unsafeWith w $ \q -> do
let go (1) = return ()
go !k = do x <- peekElemOff p k
pokeElemOff q k (f x)
go (k1)
go (dim v 1)
return w
zipVector :: (Storable a, Storable b, Storable c) => (a-> b -> c) -> Vector a -> Vector b -> Vector c
zipVector f u v = unsafePerformIO $ do
let n = min (dim u) (dim v)
w <- createVector n
unsafeWith u $ \pu ->
unsafeWith v $ \pv ->
unsafeWith w $ \pw -> do
let go (1) = return ()
go !k = do x <- peekElemOff pu k
y <- peekElemOff pv k
pokeElemOff pw k (f x y)
go (k1)
go (n 1)
return w
foldVector f x v = unsafePerformIO $
unsafeWith (v::Vector Double) $ \p -> do
let go (1) s = return s
go !k !s = do y <- peekElemOff p k
go (k1::Int) (f y s)
go (dim v 1) x
foldLoop f s0 d = go (d 1) s0
where
go 0 s = f (0::Int) s
go !j !s = go (j 1) (f j s)
foldVectorG f s0 v = foldLoop g s0 (dim v)
where g !k !s = f k (at' v) s
fscanfVector :: FilePath -> Int -> IO (Vector Double)
fscanfVector filename n = do
charname <- newCString filename
res <- createVector n
app1 (gsl_vector_fscanf charname) vec res "gsl_vector_fscanf"
free charname
return res
foreign import ccall "vector_fscanf" gsl_vector_fscanf:: Ptr CChar -> TV
fprintfVector :: FilePath -> String -> Vector Double -> IO ()
fprintfVector filename fmt v = do
charname <- newCString filename
charfmt <- newCString fmt
app1 (gsl_vector_fprintf charname charfmt) vec v "gsl_vector_fprintf"
free charname
free charfmt
foreign import ccall "vector_fprintf" gsl_vector_fprintf :: Ptr CChar -> Ptr CChar -> TV
freadVector :: FilePath -> Int -> IO (Vector Double)
freadVector filename n = do
charname <- newCString filename
res <- createVector n
app1 (gsl_vector_fread charname) vec res "gsl_vector_fread"
free charname
return res
foreign import ccall "vector_fread" gsl_vector_fread:: Ptr CChar -> TV
fwriteVector :: FilePath -> Vector Double -> IO ()
fwriteVector filename v = do
charname <- newCString filename
app1 (gsl_vector_fwrite charname) vec v "gsl_vector_fwrite"
free charname
foreign import ccall "vector_fwrite" gsl_vector_fwrite :: Ptr CChar -> TV