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
135
136
137
138
139
140
141
142
143
144
145
146
147
|
{-# OPTIONS_GHC -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- 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)
--
-- Development utilities.
--
-----------------------------------------------------------------------------
-- #hide
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)
import Foreign.C.String(peekCString)
import Foreign.C.Types
----------------------------------------------------------------------
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] --
----------------------------------------------------------------------
-- | @debug x = trace (show x) x@
debug :: (Show a) => a -> a
debug x = trace (show x) x
-- | useful for expressions like @sortBy (compare \`on\` length)@
on :: (a -> a -> b) -> (t -> a) -> t -> t -> b
on f g = \x y -> f (g x) (g y)
-- | @partit 3 [1..9] == [[1,2,3],[4,5,6],[7,8,9]]@
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
-- | postfix function application (@flip ($)@)
(//) :: x -> (x -> y) -> y
infixl 0 //
(//) = flip ($)
-- hmm..
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
errorCode 2000 = "bad size"
errorCode 2001 = "bad function code"
errorCode 2002 = "memory problem"
errorCode 2003 = "bad file"
errorCode 2004 = "singular"
errorCode 2005 = "didn't converge"
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))
---------------------------------------------------
-- 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 --
------------------------------------------------
|
