blob: 1bfed6d508d7f58e24a9ea07b12b418be170c68e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Packed.Internal.Common
-- Copyright : (c) Alberto Ruiz 2007
-- License : GPL-style
--
-- Maintainer : Alberto Ruiz <aruiz@um.es>
-- Stability : provisional
-- Portability : portable (uses FFI)
--
-- Common tools
--
-----------------------------------------------------------------------------
module Data.Packed.Internal.Common where
import Foreign
import Complex
import Control.Monad(when)
import Debug.Trace
import Data.List(transpose,intersperse)
import Data.Typeable
import Data.Maybe(fromJust)
debug x = trace (show x) x
data Vector t = V { dim :: Int
, fptr :: ForeignPtr t
, ptr :: Ptr t
} deriving Typeable
----------------------------------------------------------------------
instance (Storable a, RealFloat a) => Storable (Complex a) where --
alignment x = alignment (realPart x) --
sizeOf x = 2 * sizeOf (realPart x) --
peek p = do --
[re,im] <- peekArray 2 (castPtr p) --
return (re :+ im) --
poke p (a :+ b) = pokeArray (castPtr p) [a,b] --
----------------------------------------------------------------------
on :: (a -> a -> b) -> (t -> a) -> t -> t -> b
on f g = \x y -> f (g x) (g y)
partit :: Int -> [a] -> [[a]]
partit _ [] = []
partit n l = take n l : partit n (drop n l)
-- | obtains the common value of a property of a list
common :: (Eq a) => (b->a) -> [b] -> Maybe a
common f = commonval . map f where
commonval :: (Eq a) => [a] -> Maybe a
commonval [] = Nothing
commonval [a] = Just a
commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing
xor :: Bool -> Bool -> Bool
xor a b = a && not b || b && not a
(//) :: x -> (x -> y) -> y
infixl 0 //
(//) = flip ($)
errorCode :: Int -> String
errorCode 1000 = "bad size"
errorCode 1001 = "bad function code"
errorCode 1002 = "memory problem"
errorCode 1003 = "bad file"
errorCode 1004 = "singular"
errorCode 1005 = "didn't converge"
errorCode n = "code "++show n
check :: String -> [Vector a] -> IO Int -> IO ()
check msg ls f = do
err <- f
when (err/=0) (error (msg++": "++errorCode err))
mapM_ (touchForeignPtr . fptr) ls
return ()
class (Storable a, Typeable a) => Field a
instance (Storable a, Typeable a) => Field a
isReal :: (Data.Typeable.Typeable a) => (t -> a) -> t -> Bool
isReal w x = typeOf (undefined :: Double) == typeOf (w x)
isComp :: (Data.Typeable.Typeable a) => (t -> a) -> t -> Bool
isComp w x = typeOf (undefined :: Complex Double) == typeOf (w x)
scast :: forall a . forall b . (Typeable a, Typeable b) => a -> b
scast = fromJust . cast
{- | 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))
---------------------------------------------------
-- ugly, but my haddock version doesn't understand
-- yet infix type constructors
---------------------------------------------------
---------- signatures of the C functions -------
------------------------------------------------
type PD = Ptr Double --
type PC = Ptr (Complex Double) --
type TV = Int -> PD -> IO Int --
type TVV = Int -> PD -> TV --
type TVVV = Int -> PD -> TVV --
type TM = Int -> Int -> PD -> IO Int --
type TMM = Int -> Int -> PD -> TM --
type TMMM = Int -> Int -> PD -> TMM --
type TVM = Int -> PD -> TM --
type TVVM = Int -> PD -> TVM --
type TMV = Int -> Int -> PD -> TV --
type TMVM = Int -> Int -> PD -> TVM --
type TMMVM = Int -> Int -> PD -> TMVM --
type TCM = Int -> Int -> PC -> IO Int --
type TCVCM = Int -> PC -> TCM --
type TCMCVCM = Int -> Int -> PC -> TCVCM --
type TMCMCVCM = Int -> Int -> PD -> TCMCVCM --
type TCMCMCVCM = Int -> Int -> PC -> TCMCVCM --
type TCMCM = Int -> Int -> PC -> TCM --
type TVCM = Int -> PD -> TCM --
type TCMVCM = Int -> Int -> PC -> TVCM --
type TCMCMVCM = Int -> Int -> PC -> TCMVCM --
type TCMCMCM = Int -> Int -> PC -> TCMCM --
type TCV = Int -> PC -> IO Int --
type TCVCV = Int -> PC -> TCV --
type TCVCVCV = Int -> PC -> TCVCV --
type TCMCV = Int -> Int -> PC -> TCV --
type TVCV = Int -> PD -> TCV --
type TCVM = Int -> PC -> TM --
type TMCVM = Int -> Int -> PD -> TCVM --
type TMMCVM = Int -> Int -> PD -> TMCVM --
------------------------------------------------
|
