blob: bdd7f3427ae690ea8c17aff277502ba7fc12b9c8 (
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
|
{-# 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 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 a b = a && not b || b && not a
(//) :: x -> (x -> y) -> y
infixl 0 //
(//) = flip ($)
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 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 w x = typeOf (undefined :: Double) == typeOf (w x)
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 --
------------------------------------------------
|
