diff options
author | Alberto Ruiz <aruiz@um.es> | 2015-06-05 16:38:09 +0200 |
---|---|---|
committer | Alberto Ruiz <aruiz@um.es> | 2015-06-05 16:38:09 +0200 |
commit | 8b093ecca2b4e200ff191b84cb0b56a12312867b (patch) | |
tree | 222527525810a76b7b67eba5b309ae2c633e90aa /packages/base/src/Numeric | |
parent | 2dae75e9d2b08a23945e936dcd5244b7f0c46107 (diff) |
move convolution
Diffstat (limited to 'packages/base/src/Numeric')
-rw-r--r-- | packages/base/src/Numeric/LinearAlgebra/Util/Convolution.hs | 150 |
1 files changed, 0 insertions, 150 deletions
diff --git a/packages/base/src/Numeric/LinearAlgebra/Util/Convolution.hs b/packages/base/src/Numeric/LinearAlgebra/Util/Convolution.hs deleted file mode 100644 index c9e75de..0000000 --- a/packages/base/src/Numeric/LinearAlgebra/Util/Convolution.hs +++ /dev/null | |||
@@ -1,150 +0,0 @@ | |||
1 | {-# LANGUAGE FlexibleContexts #-} | ||
2 | ----------------------------------------------------------------------------- | ||
3 | {- | | ||
4 | Module : Numeric.LinearAlgebra.Util.Convolution | ||
5 | Copyright : (c) Alberto Ruiz 2012 | ||
6 | License : BSD3 | ||
7 | Maintainer : Alberto Ruiz | ||
8 | Stability : provisional | ||
9 | |||
10 | -} | ||
11 | ----------------------------------------------------------------------------- | ||
12 | {-# OPTIONS_HADDOCK hide #-} | ||
13 | |||
14 | module Numeric.LinearAlgebra.Util.Convolution( | ||
15 | corr, conv, corrMin, | ||
16 | corr2, conv2, separable | ||
17 | ) where | ||
18 | |||
19 | import qualified Data.Vector.Storable as SV | ||
20 | import Data.Packed.Numeric | ||
21 | |||
22 | |||
23 | vectSS :: Element t => Int -> Vector t -> Matrix t | ||
24 | vectSS n v = fromRows [ subVector k n v | k <- [0 .. dim v - n] ] | ||
25 | |||
26 | |||
27 | corr | ||
28 | :: (Container Vector t, Product t) | ||
29 | => Vector t -- ^ kernel | ||
30 | -> Vector t -- ^ source | ||
31 | -> Vector t | ||
32 | {- ^ correlation | ||
33 | |||
34 | >>> corr (fromList[1,2,3]) (fromList [1..10]) | ||
35 | fromList [14.0,20.0,26.0,32.0,38.0,44.0,50.0,56.0] | ||
36 | |||
37 | -} | ||
38 | corr ker v | ||
39 | | dim ker == 0 = konst 0 (dim v) | ||
40 | | dim ker <= dim v = vectSS (dim ker) v <> ker | ||
41 | | otherwise = error $ "corr: dim kernel ("++show (dim ker)++") > dim vector ("++show (dim v)++")" | ||
42 | |||
43 | |||
44 | conv :: (Container Vector t, Product t, Num t) => Vector t -> Vector t -> Vector t | ||
45 | {- ^ convolution ('corr' with reversed kernel and padded input, equivalent to polynomial product) | ||
46 | |||
47 | >>> conv (fromList[1,1]) (fromList [-1,1]) | ||
48 | fromList [-1.0,0.0,1.0] | ||
49 | |||
50 | -} | ||
51 | conv ker v | ||
52 | | dim ker == 0 = konst 0 (dim v) | ||
53 | | otherwise = corr ker' v' | ||
54 | where | ||
55 | ker' = SV.reverse ker | ||
56 | v' = vjoin [z,v,z] | ||
57 | z = konst 0 (dim ker -1) | ||
58 | |||
59 | corrMin :: (Container Vector t, RealElement t, Product t) | ||
60 | => Vector t | ||
61 | -> Vector t | ||
62 | -> Vector t | ||
63 | -- ^ similar to 'corr', using 'min' instead of (*) | ||
64 | corrMin ker v | ||
65 | | dim ker == 0 = error "corrMin: empty kernel" | ||
66 | | otherwise = minEvery ss (asRow ker) <> ones | ||
67 | where | ||
68 | minEvery a b = cond a b a a b | ||
69 | ss = vectSS (dim ker) v | ||
70 | ones = konst 1 (dim ker) | ||
71 | |||
72 | |||
73 | |||
74 | matSS :: Element t => Int -> Matrix t -> [Matrix t] | ||
75 | matSS dr m = map (reshape c) [ subVector (k*c) n v | k <- [0 .. r - dr] ] | ||
76 | where | ||
77 | v = flatten m | ||
78 | c = cols m | ||
79 | r = rows m | ||
80 | n = dr*c | ||
81 | |||
82 | |||
83 | {- | 2D correlation (without padding) | ||
84 | |||
85 | >>> disp 5 $ corr2 (konst 1 (3,3)) (ident 10 :: Matrix Double) | ||
86 | 8x8 | ||
87 | 3 2 1 0 0 0 0 0 | ||
88 | 2 3 2 1 0 0 0 0 | ||
89 | 1 2 3 2 1 0 0 0 | ||
90 | 0 1 2 3 2 1 0 0 | ||
91 | 0 0 1 2 3 2 1 0 | ||
92 | 0 0 0 1 2 3 2 1 | ||
93 | 0 0 0 0 1 2 3 2 | ||
94 | 0 0 0 0 0 1 2 3 | ||
95 | |||
96 | -} | ||
97 | corr2 :: Product a => Matrix a -> Matrix a -> Matrix a | ||
98 | corr2 ker mat = dims | ||
99 | . concatMap (map (udot ker' . flatten) . matSS c . trans) | ||
100 | . matSS r $ mat | ||
101 | where | ||
102 | r = rows ker | ||
103 | c = cols ker | ||
104 | ker' = flatten (trans ker) | ||
105 | rr = rows mat - r + 1 | ||
106 | rc = cols mat - c + 1 | ||
107 | dims | rr > 0 && rc > 0 = (rr >< rc) | ||
108 | | otherwise = error $ "corr2: dim kernel ("++sz ker++") > dim matrix ("++sz mat++")" | ||
109 | sz m = show (rows m)++"x"++show (cols m) | ||
110 | -- TODO check empty kernel | ||
111 | |||
112 | {- | 2D convolution | ||
113 | |||
114 | >>> disp 5 $ conv2 (konst 1 (3,3)) (ident 10 :: Matrix Double) | ||
115 | 12x12 | ||
116 | 1 1 1 0 0 0 0 0 0 0 0 0 | ||
117 | 1 2 2 1 0 0 0 0 0 0 0 0 | ||
118 | 1 2 3 2 1 0 0 0 0 0 0 0 | ||
119 | 0 1 2 3 2 1 0 0 0 0 0 0 | ||
120 | 0 0 1 2 3 2 1 0 0 0 0 0 | ||
121 | 0 0 0 1 2 3 2 1 0 0 0 0 | ||
122 | 0 0 0 0 1 2 3 2 1 0 0 0 | ||
123 | 0 0 0 0 0 1 2 3 2 1 0 0 | ||
124 | 0 0 0 0 0 0 1 2 3 2 1 0 | ||
125 | 0 0 0 0 0 0 0 1 2 3 2 1 | ||
126 | 0 0 0 0 0 0 0 0 1 2 2 1 | ||
127 | 0 0 0 0 0 0 0 0 0 1 1 1 | ||
128 | |||
129 | -} | ||
130 | conv2 | ||
131 | :: (Num (Matrix a), Product a, Container Vector a) | ||
132 | => Matrix a -- ^ kernel | ||
133 | -> Matrix a -> Matrix a | ||
134 | conv2 k m | ||
135 | | empty = konst 0 (rows m + r -1, cols m + c -1) | ||
136 | | otherwise = corr2 (fliprl . flipud $ k) padded | ||
137 | where | ||
138 | padded = fromBlocks [[z,0,0] | ||
139 | ,[0,m,0] | ||
140 | ,[0,0,z]] | ||
141 | r = rows k | ||
142 | c = cols k | ||
143 | z = konst 0 (r-1,c-1) | ||
144 | empty = r == 0 || c == 0 | ||
145 | |||
146 | |||
147 | separable :: Element t => (Vector t -> Vector t) -> Matrix t -> Matrix t | ||
148 | -- ^ matrix computation implemented as separated vector operations by rows and columns. | ||
149 | separable f = fromColumns . map f . toColumns . fromRows . map f . toRows | ||
150 | |||