diff options
author | Alberto Ruiz <aruiz@um.es> | 2014-05-08 08:48:12 +0200 |
---|---|---|
committer | Alberto Ruiz <aruiz@um.es> | 2014-05-08 08:48:12 +0200 |
commit | 1925c123d7d8184a1d2ddc0a413e0fd2776e1083 (patch) | |
tree | fad79f909d9c3be53d68e6ebd67202650536d387 /lib/Data/Packed/Internal/Common.hs | |
parent | eb3f702d065a4a967bb754977233e6eec408fd1f (diff) |
empty hmatrix-base
Diffstat (limited to 'lib/Data/Packed/Internal/Common.hs')
-rw-r--r-- | lib/Data/Packed/Internal/Common.hs | 171 |
1 files changed, 0 insertions, 171 deletions
diff --git a/lib/Data/Packed/Internal/Common.hs b/lib/Data/Packed/Internal/Common.hs deleted file mode 100644 index edef3c2..0000000 --- a/lib/Data/Packed/Internal/Common.hs +++ /dev/null | |||
@@ -1,171 +0,0 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | ----------------------------------------------------------------------------- | ||
3 | -- | | ||
4 | -- Module : Data.Packed.Internal.Common | ||
5 | -- Copyright : (c) Alberto Ruiz 2007 | ||
6 | -- License : GPL-style | ||
7 | -- | ||
8 | -- Maintainer : Alberto Ruiz <aruiz@um.es> | ||
9 | -- Stability : provisional | ||
10 | -- Portability : portable (uses FFI) | ||
11 | -- | ||
12 | -- Development utilities. | ||
13 | -- | ||
14 | ----------------------------------------------------------------------------- | ||
15 | -- #hide | ||
16 | |||
17 | module Data.Packed.Internal.Common( | ||
18 | Adapt, | ||
19 | app1, app2, app3, app4, | ||
20 | app5, app6, app7, app8, app9, app10, | ||
21 | (//), check, mbCatch, | ||
22 | splitEvery, common, compatdim, | ||
23 | fi, | ||
24 | table | ||
25 | ) where | ||
26 | |||
27 | import Foreign | ||
28 | import Control.Monad(when) | ||
29 | import Foreign.C.String(peekCString) | ||
30 | import Foreign.C.Types | ||
31 | import Foreign.Storable.Complex() | ||
32 | import Data.List(transpose,intersperse) | ||
33 | import Control.Exception as E | ||
34 | |||
35 | -- | @splitEvery 3 [1..9] == [[1,2,3],[4,5,6],[7,8,9]]@ | ||
36 | splitEvery :: Int -> [a] -> [[a]] | ||
37 | splitEvery _ [] = [] | ||
38 | splitEvery k l = take k l : splitEvery k (drop k l) | ||
39 | |||
40 | -- | obtains the common value of a property of a list | ||
41 | common :: (Eq a) => (b->a) -> [b] -> Maybe a | ||
42 | common f = commonval . map f where | ||
43 | commonval :: (Eq a) => [a] -> Maybe a | ||
44 | commonval [] = Nothing | ||
45 | commonval [a] = Just a | ||
46 | commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing | ||
47 | |||
48 | -- | common value with \"adaptable\" 1 | ||
49 | compatdim :: [Int] -> Maybe Int | ||
50 | compatdim [] = Nothing | ||
51 | compatdim [a] = Just a | ||
52 | compatdim (a:b:xs) | ||
53 | | a==b = compatdim (b:xs) | ||
54 | | a==1 = compatdim (b:xs) | ||
55 | | b==1 = compatdim (a:xs) | ||
56 | | otherwise = Nothing | ||
57 | |||
58 | -- | Formatting tool | ||
59 | table :: String -> [[String]] -> String | ||
60 | table sep as = unlines . map unwords' $ transpose mtp where | ||
61 | mt = transpose as | ||
62 | longs = map (maximum . map length) mt | ||
63 | mtp = zipWith (\a b -> map (pad a) b) longs mt | ||
64 | pad n str = replicate (n - length str) ' ' ++ str | ||
65 | unwords' = concat . intersperse sep | ||
66 | |||
67 | -- | postfix function application (@flip ($)@) | ||
68 | (//) :: x -> (x -> y) -> y | ||
69 | infixl 0 // | ||
70 | (//) = flip ($) | ||
71 | |||
72 | -- | specialized fromIntegral | ||
73 | fi :: Int -> CInt | ||
74 | fi = fromIntegral | ||
75 | |||
76 | -- hmm.. | ||
77 | ww2 w1 o1 w2 o2 f = w1 o1 $ w2 o2 . f | ||
78 | ww3 w1 o1 w2 o2 w3 o3 f = w1 o1 $ ww2 w2 o2 w3 o3 . f | ||
79 | ww4 w1 o1 w2 o2 w3 o3 w4 o4 f = w1 o1 $ ww3 w2 o2 w3 o3 w4 o4 . f | ||
80 | ww5 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 f = w1 o1 $ ww4 w2 o2 w3 o3 w4 o4 w5 o5 . f | ||
81 | ww6 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 f = w1 o1 $ ww5 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 . f | ||
82 | ww7 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 f = w1 o1 $ ww6 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 . f | ||
83 | ww8 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 f = w1 o1 $ ww7 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 . f | ||
84 | ww9 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 f = w1 o1 $ ww8 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 . f | ||
85 | ww10 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 f = w1 o1 $ ww9 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 . f | ||
86 | |||
87 | type Adapt f t r = t -> ((f -> r) -> IO()) -> IO() | ||
88 | |||
89 | type Adapt1 f t1 = Adapt f t1 (IO CInt) -> t1 -> String -> IO() | ||
90 | type Adapt2 f t1 r1 t2 = Adapt f t1 r1 -> t1 -> Adapt1 r1 t2 | ||
91 | type Adapt3 f t1 r1 t2 r2 t3 = Adapt f t1 r1 -> t1 -> Adapt2 r1 t2 r2 t3 | ||
92 | type Adapt4 f t1 r1 t2 r2 t3 r3 t4 = Adapt f t1 r1 -> t1 -> Adapt3 r1 t2 r2 t3 r3 t4 | ||
93 | type Adapt5 f t1 r1 t2 r2 t3 r3 t4 r4 t5 = Adapt f t1 r1 -> t1 -> Adapt4 r1 t2 r2 t3 r3 t4 r4 t5 | ||
94 | type Adapt6 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 = Adapt f t1 r1 -> t1 -> Adapt5 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 | ||
95 | type Adapt7 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 = Adapt f t1 r1 -> t1 -> Adapt6 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 | ||
96 | type Adapt8 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 = Adapt f t1 r1 -> t1 -> Adapt7 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 | ||
97 | type Adapt9 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 = Adapt f t1 r1 -> t1 -> Adapt8 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 | ||
98 | type Adapt10 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10 = Adapt f t1 r1 -> t1 -> Adapt9 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10 | ||
99 | |||
100 | app1 :: f -> Adapt1 f t1 | ||
101 | app2 :: f -> Adapt2 f t1 r1 t2 | ||
102 | app3 :: f -> Adapt3 f t1 r1 t2 r2 t3 | ||
103 | app4 :: f -> Adapt4 f t1 r1 t2 r2 t3 r3 t4 | ||
104 | app5 :: f -> Adapt5 f t1 r1 t2 r2 t3 r3 t4 r4 t5 | ||
105 | app6 :: f -> Adapt6 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 | ||
106 | app7 :: f -> Adapt7 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 | ||
107 | app8 :: f -> Adapt8 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 | ||
108 | app9 :: f -> Adapt9 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 | ||
109 | app10 :: f -> Adapt10 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10 | ||
110 | |||
111 | app1 f w1 o1 s = w1 o1 $ \a1 -> f // a1 // check s | ||
112 | app2 f w1 o1 w2 o2 s = ww2 w1 o1 w2 o2 $ \a1 a2 -> f // a1 // a2 // check s | ||
113 | app3 f w1 o1 w2 o2 w3 o3 s = ww3 w1 o1 w2 o2 w3 o3 $ | ||
114 | \a1 a2 a3 -> f // a1 // a2 // a3 // check s | ||
115 | app4 f w1 o1 w2 o2 w3 o3 w4 o4 s = ww4 w1 o1 w2 o2 w3 o3 w4 o4 $ | ||
116 | \a1 a2 a3 a4 -> f // a1 // a2 // a3 // a4 // check s | ||
117 | app5 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 s = ww5 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 $ | ||
118 | \a1 a2 a3 a4 a5 -> f // a1 // a2 // a3 // a4 // a5 // check s | ||
119 | app6 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 s = ww6 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 $ | ||
120 | \a1 a2 a3 a4 a5 a6 -> f // a1 // a2 // a3 // a4 // a5 // a6 // check s | ||
121 | app7 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 s = ww7 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 $ | ||
122 | \a1 a2 a3 a4 a5 a6 a7 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // check s | ||
123 | app8 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 s = ww8 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 $ | ||
124 | \a1 a2 a3 a4 a5 a6 a7 a8 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // check s | ||
125 | app9 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 s = ww9 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 $ | ||
126 | \a1 a2 a3 a4 a5 a6 a7 a8 a9 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // a9 // check s | ||
127 | app10 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 s = ww10 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 $ | ||
128 | \a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // a9 // a10 // check s | ||
129 | |||
130 | |||
131 | |||
132 | -- GSL error codes are <= 1024 | ||
133 | -- | error codes for the auxiliary functions required by the wrappers | ||
134 | errorCode :: CInt -> String | ||
135 | errorCode 2000 = "bad size" | ||
136 | errorCode 2001 = "bad function code" | ||
137 | errorCode 2002 = "memory problem" | ||
138 | errorCode 2003 = "bad file" | ||
139 | errorCode 2004 = "singular" | ||
140 | errorCode 2005 = "didn't converge" | ||
141 | errorCode 2006 = "the input matrix is not positive definite" | ||
142 | errorCode 2007 = "not yet supported in this OS" | ||
143 | errorCode n = "code "++show n | ||
144 | |||
145 | |||
146 | -- | clear the fpu | ||
147 | foreign import ccall unsafe "asm_finit" finit :: IO () | ||
148 | |||
149 | -- | check the error code | ||
150 | check :: String -> IO CInt -> IO () | ||
151 | check msg f = do | ||
152 | #if FINIT | ||
153 | finit | ||
154 | #endif | ||
155 | err <- f | ||
156 | when (err/=0) $ if err > 1024 | ||
157 | then (error (msg++": "++errorCode err)) -- our errors | ||
158 | else do -- GSL errors | ||
159 | ps <- gsl_strerror err | ||
160 | s <- peekCString ps | ||
161 | error (msg++": "++s) | ||
162 | return () | ||
163 | |||
164 | -- | description of GSL error codes | ||
165 | foreign import ccall unsafe "gsl_strerror" gsl_strerror :: CInt -> IO (Ptr CChar) | ||
166 | |||
167 | -- | Error capture and conversion to Maybe | ||
168 | mbCatch :: IO x -> IO (Maybe x) | ||
169 | mbCatch act = E.catch (Just `fmap` act) f | ||
170 | where f :: SomeException -> IO (Maybe x) | ||
171 | f _ = return Nothing | ||