git.iko.soy/grenade
on master help sign in
Fix silent conversion bug in pooling layer
424d791Huw Campbell
cbits/im2col.c+25−20
compare with master
unifiedsplit
@@ -48,7 +48,7 @@ void col2im_cpu(const double* data_col, int dataOffset, const int channels,
48 }
48 }
49}
49}
50
50
51−inline int max ( int a, int b ) { return a > b ? a : b; }
51+inline double max ( double a, double b ) { return a > b ? a : b; }
52
52
53void pool_forwards_cpu(const double* data_im, int dataOffset, const int channels,
53void pool_forwards_cpu(const double* data_im, int dataOffset, const int channels,
54 const int height, const int width, const int kernel_h, const int kernel_w,
54 const int height, const int width, const int kernel_h, const int kernel_w,
@@ -63,19 +63,24 @@ void pool_forwards_cpu(const double* data_im, int dataOffset, const int channels
63 for (int fitting_height = 0; fitting_height <= (height - kernel_h); fitting_height += stride_h) {
63 for (int fitting_height = 0; fitting_height <= (height - kernel_h); fitting_height += stride_h) {
64 for (int fitting_width = 0; fitting_width <= (width - kernel_w); fitting_width += stride_w) {
64 for (int fitting_width = 0; fitting_width <= (width - kernel_w); fitting_width += stride_w) {
65 // Start with the value in 0,0
65 // Start with the value in 0,0
66− int max_value = data_im[fitting_height * width + fitting_width + channel_size * channel];
66+ int max_index = fitting_height * width + fitting_width + channel_size * channel;
67+ double max_value = data_im[max_index];
67 // Initial row, skipping the corner we've done
68 // Initial row, skipping the corner we've done
68 for (int kernel_col = 1; kernel_col < kernel_w; kernel_col++) {
69 for (int kernel_col = 1; kernel_col < kernel_w; kernel_col++) {
69− int input_row = fitting_height;
70+ int input_row = fitting_height;
70− int input_col = fitting_width + kernel_col;
71+ int input_col = fitting_width + kernel_col;
71− max_value = max ( max_value, data_im[input_row * width + input_col + channel_size * channel] );
72+ int data_index = input_row * width + input_col + channel_size * channel;
73+ double data_value = data_im[data_index];
74+ max_value = max ( max_value, data_value );
72 }
75 }
73 // The remaining rows
76 // The remaining rows
74 for (int kernel_row = 1; kernel_row < kernel_h; kernel_row++) {
77 for (int kernel_row = 1; kernel_row < kernel_h; kernel_row++) {
75 for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {
78 for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {
76− int input_row = fitting_height + kernel_row;
79+ int input_row = fitting_height + kernel_row;
77− int input_col = fitting_width + kernel_col;
80+ int input_col = fitting_width + kernel_col;
78− max_value = max ( max_value, data_im[input_row * width + input_col + channel_size * channel] );
81+ int data_index = input_row * width + input_col + channel_size * channel;
82+ double data_value = data_im[data_index];
83+ max_value = max ( max_value, data_value );
79 }
84 }
80 }
85 }
81 *(data_pooled++) = max_value;
86 *(data_pooled++) = max_value;
@@ -99,27 +104,27 @@ void pool_backwards_cpu(const double* data_im, int data_im_offset,
99 for (int channel = 0; channel < channels; channel++) {
104 for (int channel = 0; channel < channels; channel++) {
100 for (int fitting_height = 0; fitting_height <= (height - kernel_h); fitting_height += stride_h) {
105 for (int fitting_height = 0; fitting_height <= (height - kernel_h); fitting_height += stride_h) {
101 for (int fitting_width = 0; fitting_width <= (width - kernel_w); fitting_width += stride_w) {
106 for (int fitting_width = 0; fitting_width <= (width - kernel_w); fitting_width += stride_w) {
102− int max_index = fitting_height * width + fitting_width + channel_size * channel;
107+ int max_index = fitting_height * width + fitting_width + channel_size * channel;
103− int max_value = data_im[max_index];
108+ double max_value = data_im[max_index];
104 for (int kernel_col = 1; kernel_col < kernel_w; kernel_col++) {
109 for (int kernel_col = 1; kernel_col < kernel_w; kernel_col++) {
105− int input_row = fitting_height;
110+ int input_row = fitting_height;
106− int input_col = fitting_width + kernel_col;
111+ int input_col = fitting_width + kernel_col;
107− int data_index = input_row * width + input_col + channel_size * channel;
112+ int data_index = input_row * width + input_col + channel_size * channel;
108− int data_value = data_im[data_index];
113+ double data_value = data_im[data_index];
109 if ( data_value > max_value ) {
114 if ( data_value > max_value ) {
110− max_value = data_value;
111 max_index = data_index;
115 max_index = data_index;
116+ max_value = data_value;
112 }
117 }
113 }
118 }
114 for (int kernel_row = 1; kernel_row < kernel_h; kernel_row++) {
119 for (int kernel_row = 1; kernel_row < kernel_h; kernel_row++) {
115 for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {
120 for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {
116− int input_row = fitting_height + kernel_row;
121+ int input_row = fitting_height + kernel_row;
117− int input_col = fitting_width + kernel_col;
122+ int input_col = fitting_width + kernel_col;
118− int data_index = input_row * width + input_col + channel_size * channel;
123+ int data_index = input_row * width + input_col + channel_size * channel;
119− int data_value = data_im[data_index];
124+ double data_value = data_im[data_index];
120 if ( data_value > max_value ) {
125 if ( data_value > max_value ) {
121− max_value = data_value;
122 max_index = data_index;
126 max_index = data_index;
127+ max_value = data_value;
123 }
128 }
124 }
129 }
125 }
130 }
grenade.cabal+6
@@ -106,11 +106,17 @@ test-suite test
106 base >= 4.8 && < 5
106 base >= 4.8 && < 5
107 , grenade
107 , grenade
108 , ambiata-disorder-core
108 , ambiata-disorder-core
109+ , ambiata-disorder-jack
109 , hmatrix
110 , hmatrix
110 , mtl
111 , mtl
112+ , singletons
111 , text == 1.2.*
113 , text == 1.2.*
114+ , typelits-witnesses
115+ , constraints
112 , QuickCheck >= 2.7 && < 2.9
116 , QuickCheck >= 2.7 && < 2.9
113 , quickcheck-instances == 0.3.*
117 , quickcheck-instances == 0.3.*
118+ , MonadRandom
119+ , random
114
120
115
121
116benchmark bench
122benchmark bench
lib/disorder.hs+1−1

Submodule changed.

src/Grenade/Layers/Internal/Pooling.hs+2−2
@@ -34,8 +34,8 @@ foreign import ccall unsafe
34 :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()
34 :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()
35
35
36poolBackward :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double
36poolBackward :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double
37−poolBackward channels height width kernelRows kernelColumns strideRows strideColumns dataCol dataGrad =
37+poolBackward channels height width kernelRows kernelColumns strideRows strideColumns dataIm dataGrad =
38− let vecIm = flatten dataCol
38+ let vecIm = flatten dataIm
39 vecGrad = flatten dataGrad
39 vecGrad = flatten dataGrad
40 in unsafePerformIO $ do
40 in unsafePerformIO $ do
41 outPtr <- mallocForeignPtrArray0 (height * width * channels)
41 outPtr <- mallocForeignPtrArray0 (height * width * channels)
test/Test/Grenade/Layers/Convolution.hs+80−219
@@ -1,234 +1,95 @@
1{-# LANGUAGE TemplateHaskell #-}
1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE ConstraintKinds #-}
7+{-# LANGUAGE TypeOperators #-}
8+
4{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
9{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
5module Test.Grenade.Layers.Convolution where
10module Test.Grenade.Layers.Convolution where
6
11
12+import Unsafe.Coerce
13+import Data.Constraint
14+import Data.Proxy
15+import Data.Singletons ()
16+import GHC.TypeLits
17+import GHC.TypeLits.Witnesses
18+
7import Grenade.Core.Shape
19import Grenade.Core.Shape
8import Grenade.Core.Network
20import Grenade.Core.Network
9import Grenade.Layers.Convolution
21import Grenade.Layers.Convolution
10−import Grenade.Layers.Internal.Convolution
11
22
12−import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
13import qualified Numeric.LinearAlgebra.Static as HStatic
23import qualified Numeric.LinearAlgebra.Static as HStatic
14
24
15−import Test.QuickCheck hiding ((><))
25+import Disorder.Jack
16−
26+
17−prop_im2col_no_stride = once $
27+import Test.Jack.Hmatrix
18− let input = (3><4)
28+
19− [ 1.0, 2.0, 3.0, 4.0
29+data OpaqueConvolution :: * where
20− , 5.0, 6.0, 7.0, 8.0
30+ OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution
21− , 9.0, 10.0, 11.0, 12.0 ]
31+
22− expected = (6><4)
32+instance Show OpaqueConvolution where
23− [ 1.0, 2.0, 5.0, 6.0
33+ show (OpaqueConvolution n) = show n
24− , 2.0, 3.0, 6.0, 7.0
34+
25− , 3.0, 4.0, 7.0, 8.0
35+genOpaqueOpaqueConvolution :: Jack OpaqueConvolution
26− , 5.0, 6.0, 9.0, 10.0
36+genOpaqueOpaqueConvolution = do
27− , 6.0, 7.0, 10.0, 11.0
37+ Just channels <- someNatVal <$> choose (1, 10)
28− , 7.0, 8.0, 11.0, 12.0 ]
38+ Just filters <- someNatVal <$> choose (1, 10)
29− out = im2col 2 2 1 1 input
39+ Just kernel_h <- someNatVal <$> choose (2, 20)
30− in expected === out
40+ Just kernel_w <- someNatVal <$> choose (2, 20)
31−
41+ Just stride_h <- someNatVal <$> choose (1, 10)
32−prop_im2col_stride = once $
42+ Just stride_w <- someNatVal <$> choose (1, 10)
33− let input = (3><4)
43+ case (channels, filters, kernel_h, kernel_w, stride_h, stride_w) of
34− [ 1.0, 2.0, 3.0, 4.0
44+ ( SomeNat (pch :: Proxy ch), SomeNat (_ :: Proxy fl),
35− , 5.0, 6.0, 7.0, 8.0
45+ SomeNat (pkr :: Proxy kr), SomeNat (pkc :: Proxy kc),
36− , 9.0, 10.0, 11.0, 12.0 ]
46+ SomeNat (_ :: Proxy sr), SomeNat (_ :: Proxy sc)) ->
37− expected = (4><4)
47+ let p1 = natDict pkr
38− [ 1.0, 2.0, 5.0, 6.0
48+ p2 = natDict pkc
39− , 3.0, 4.0, 7.0, 8.0
49+ p3 = natDict pch
40− , 5.0, 6.0, 9.0, 10.0
50+ in case p1 %* p2 %* p3 of
41− , 7.0, 8.0, 11.0, 12.0 ]
51+ Dict -> OpaqueConvolution <$> (Convolution <$> uniformSample <*> uniformSample :: Jack (Convolution ch fl kr kc sr sc))
42− out = im2col 2 2 1 2 input
52+
43− in expected === out
53+prop_conv_net_witness =
44−
54+ gamble genOpaqueOpaqueConvolution $ \onet ->
45−prop_im2col_other = once $
55+ (case onet of
46− let input = (3><4)
56+ (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> True
47− [ 1.0, 2.0, 3.0, 4.0
57+ ) :: Bool
48− , 5.0, 6.0, 7.0, 8.0
58+
49− , 9.0, 10.0, 11.0, 12.0 ]
59+prop_conv_net =
50− expected = (2><6)
60+ gamble genOpaqueOpaqueConvolution $ \onet ->
51− [ 1.0, 2.0, 5.0, 6.0 , 9.0, 10.0
61+ (case onet of
52− , 3.0, 4.0, 7.0, 8.0 , 11.0 ,12.0 ]
62+ (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->
53− out = im2col 3 2 1 2 input
63+ let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]
54− in expected === out
64+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)
55−
65+ kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
56−-- If there's no overlap (stride is the same size as the kernel)
66+ kc = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
57−-- then col2im . im2col should be symmetric.
67+ sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)
58−prop_im2col_sym_on_same_stride = once $
68+ sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)
59− let input = (3><4)
69+
60− [ 1.0, 2.0, 3.0, 4.0
70+ in gamble (elements (ok sr kr)) $ \er ->
61− , 5.0, 6.0, 7.0, 8.0
71+ gamble (elements (ok sc kc)) $ \ec ->
62− , 9.0, 10.0, 11.0, 12.0 ]
72+ let i = fromIntegral (er * ec * ch)
63− out = col2im 3 2 3 2 3 4 . im2col 3 2 3 2 $ input
73+ rr = ((er - kr) `div` sr) + 1
64− in input === out
74+ rc = ((ec - kc) `div` sc) + 1
65−
75+ er' = someNatVal er
66−-- If there is an overlap, then the gradient passed back should be
76+ ec' = someNatVal ec
67−-- the sum of the gradients across the filters.
77+ rr' = someNatVal rr
68−prop_im2col_col2im_additive = once $
78+ rc' = someNatVal rc
69− let input = (3><4)
79+ in gamble (vectorOf i sizedRealFrac) $ \(input :: [Double]) ->
70− [ 1.0, 1.0, 1.0, 1.0
80+ case (er', ec', rr', rc') of
71− , 1.0, 1.0, 1.0, 1.0
81+ (Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)), Just (SomeNat (pour :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols))) ->
72− , 1.0, 1.0, 1.0, 1.0 ]
82+ let p1 = natDict pinr
73− expected = (3><4)
83+ p2 = natDict pour
74− [ 1.0, 2.0, 2.0, 1.0
84+ in case ( p1 %* natDict (Proxy :: Proxy channels)
75− , 2.0, 4.0, 4.0, 2.0
85+ , p2 %* natDict (Proxy :: Proxy filters)
76− , 1.0, 2.0, 2.0, 1.0 ]
86+ -- Fake it till you make it.
77− out = col2im 2 2 1 1 3 4 . im2col 2 2 1 1 $ input
87+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
78− in expected === out
88+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
79−
89+ (Dict, Dict, Dict, Dict) -> let x :: S' ('D3 outRows outCols filters) = runForwards convLayer ((S3D' (HStatic.matrix input)) :: S' ('D3 inRows inCols channels))
80−prop_simple_conv_forwards = once $
90+ in x `seq` True
81− -- Create a convolution kernel with 4 filters.
91+ _ -> False
82− -- [ 1, 0 [ 0, 1 [ 0, 1 [ 0, 0
92+ ) :: Property
83− -- , 0,-1 ] ,-1, 0 ] , 1, 0 ] ,-1,-1 ]
84− let myKernel = HStatic.matrix
85− [ 1.0, 0.0, 0.0, 0.0
86− , 0.0, 1.0, 1.0, 0.0
87− , 0.0, -1.0, 1.0, -1.0
88− ,-1.0, 0.0, 0.0, -1.0 ] :: HStatic.L 4 4
89− zeroKernel = HStatic.matrix
90− [ 0.0, 0.0, 0.0, 0.0
91− , 0.0, 0.0, 0.0, 0.0
92− , 0.0, 0.0, 0.0, 0.0
93− , 0.0, 0.0, 0.0, 0.0 ] :: HStatic.L 4 4
94−
95− expectedGradient = HStatic.matrix
96− [ 1.0, 0.0, 0.0, 2.0
97− , 2.0, 0.0, 0.0, 5.0
98− , 3.0, 0.0, 0.0, 4.0
99− , 4.0, 0.0, 0.0, 6.0 ] :: HStatic.L 4 4
100−
101− convLayer = Convolution myKernel zeroKernel :: Convolution 1 4 2 2 1 1
102−
103− input = S2D' (HStatic.matrix
104− [ 1.0, 2.0, 5.0
105− , 3.0, 4.0, 6.0] :: HStatic.L 2 3)
106−
107− expect = HStatic.matrix
108− [ -3.0 , -4.0
109− , -1.0 , 1.0
110− , 5.0 , 9.0
111− , -7.0 , -10.0 ] :: HStatic.L 4 2
112− out = runForwards convLayer input :: S' ('D3 1 2 4)
113−
114− grad = S3D' ( HStatic.matrix
115− [ 1 , 0
116− , 0 , 0
117− , 0 , 0
118− , 0 , 1 ] :: HStatic.L 4 2 ) :: S' ('D3 1 2 4)
119−
120− expectBack = (HStatic.matrix
121− [ 1.0, 0.0, 0.0
122− , 0.0, -2.0,-1.0] :: HStatic.L 2 3)
123− (nc, inX) = runBackwards convLayer input grad
124−
125− in case (out, inX, nc) of
126− (S3D' out' , S2D' inX', Convolution' backGrad)
127− -> (HStatic.extract expect === HStatic.extract out')
128− .&&. (HStatic.extract expectBack === HStatic.extract inX')
129− .&&. (HStatic.extract expectedGradient === HStatic.extract backGrad)
130−
131−prop_vid2col_no_stride = once $
132− let input = (6><4)
133− [ 1.0, 2.0, 3.0, 4.0
134− , 5.0, 6.0, 7.0, 8.0
135− , 9.0, 10.0, 11.0, 12.0
136− -- -- --
137− , 21.0, 22.0, 23.0, 24.0
138− , 25.0, 26.0, 27.0, 28.0
139− , 29.0, 30.0, 31.0, 32.0 ]
140− expected = (6><8)
141− [ 1.0, 2.0, 5.0, 6.0 , 21.0, 22.0, 25.0, 26.0
142− , 2.0, 3.0, 6.0, 7.0 , 22.0, 23.0, 26.0, 27.0
143− , 3.0, 4.0, 7.0, 8.0 , 23.0, 24.0, 27.0, 28.0
144− , 5.0, 6.0, 9.0, 10.0 , 25.0, 26.0, 29.0, 30.0
145− , 6.0, 7.0, 10.0, 11.0 , 26.0, 27.0, 30.0, 31.0
146− , 7.0, 8.0, 11.0, 12.0 , 27.0, 28.0, 31.0, 32.0 ]
147− out_c = vid2col 2 2 1 1 3 4 input
148− in expected === out_c
149−
150−prop_vid2col_stride = once $
151− let input = (6><4)
152− [ 1.0, 2.0, 3.0, 4.0
153− , 5.0, 6.0, 7.0, 8.0
154− , 9.0, 10.0, 11.0, 12.0
155− -- -- -- -- --
156− , 21.0, 22.0, 23.0, 24.0
157− , 25.0, 26.0, 27.0, 28.0
158− , 29.0, 30.0, 31.0, 32.0 ]
159− expected = (4><8)
160− [ 1.0, 2.0, 5.0, 6.0 , 21.0, 22.0, 25.0, 26.0
161− , 3.0, 4.0, 7.0, 8.0 , 23.0, 24.0, 27.0, 28.0
162− , 5.0, 6.0, 9.0, 10.0 , 25.0, 26.0, 29.0, 30.0
163− , 7.0, 8.0, 11.0, 12.0 , 27.0, 28.0, 31.0, 32.0 ]
164− out_c = vid2col 2 2 1 2 3 4 input
165− in expected === out_c
166−
167−prop_vid2col_invert = once $
168− let input = (6><4)
169− [ 1.0, 2.0, 3.0, 4.0
170− , 5.0, 6.0, 7.0, 8.0
171− , 9.0, 10.0, 11.0, 12.0
172− -- -- -- -- --
173− , 21.0, 22.0, 23.0, 24.0
174− , 25.0, 26.0, 27.0, 28.0
175− , 29.0, 30.0, 31.0, 32.0 ]
176− out = col2vid 3 2 3 2 3 4 . vid2col 3 2 3 2 3 4 $ input
177− in input === out
178−
179−
180−-- This test show that 2D convs act the same
181−-- 3D convs with one layer
182−prop_single_conv_forwards = once $
183− -- Create a convolution kernel with 4 filters.
184− -- [ 1, 0 [ 0, 1 [ 0, 1 [ 0, 0
185− -- , 0,-1 ] ,-1, 0 ] , 1, 0 ] ,-1,-1 ]
186− let myKernel = (HStatic.matrix
187− [ 1.0, 0.0, 0.0, 0.0
188− , 0.0, 1.0, 1.0, 0.0
189− , 0.0, -1.0, 1.0, -1.0
190− ,-1.0, 0.0, 0.0, -1.0 ] :: HStatic.L 4 4)
191− zeroKernel = (HStatic.matrix
192− [ 0.0, 0.0, 0.0, 0.0
193− , 0.0, 0.0, 0.0, 0.0
194− , 0.0, 0.0, 0.0, 0.0
195− , 0.0, 0.0, 0.0, 0.0 ] :: HStatic.L 4 4)
196−
197− expectedGradient = (HStatic.matrix
198− [ 1.0, 0.0, 0.0, 2.0
199− , 2.0, 0.0, 0.0, 5.0
200− , 3.0, 0.0, 0.0, 4.0
201− , 4.0, 0.0, 0.0, 6.0 ] :: HStatic.L 4 4)
202−
203− convLayer = Convolution myKernel zeroKernel :: Convolution 1 4 2 2 1 1
204−
205− input = S3D' ( HStatic.matrix
206− [ 1.0, 2.0, 5.0
207− , 3.0, 4.0, 6.0] :: HStatic.L 2 3 ) :: S' ('D3 2 3 1)
208−
209− expect = HStatic.matrix
210− [ -3.0 , -4.0
211− , -1.0 , 1.0
212− , 5.0 , 9.0
213− , -7.0 , -10.0 ] :: HStatic.L 4 2
214− out = runForwards convLayer input :: S' ('D3 1 2 4)
215−
216− grad = S3D' (HStatic.matrix
217− [ 1 , 0
218− , 0 , 0
219− , 0 , 0
220− , 0 , 1 ] :: HStatic.L 4 2 ) :: S' ('D3 1 2 4)
221−
222− expectBack = (HStatic.matrix
223− [ 1.0, 0.0, 0.0
224− , 0.0, -2.0,-1.0] :: HStatic.L 2 3)
225− (nc, inX) = runBackwards convLayer input grad
226−
227− in case (out, inX, nc) of
228− (S3D' out' , S3D' inX', Convolution' backGrad)
229− -> (HStatic.extract expect === HStatic.extract out')
230− .&&. (HStatic.extract expectBack === HStatic.extract inX')
231− .&&. (HStatic.extract expectedGradient === HStatic.extract backGrad)
232
93
233return []
94return []
234tests :: IO Bool
95tests :: IO Bool
test/Test/Grenade/Layers/FullyConnected.hsnew file+57
@@ -0,0 +1,57 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE TemplateHaskell #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
8+module Test.Grenade.Layers.FullyConnected where
9+
10+import Data.Proxy
11+import Data.Singletons ()
12+
13+import GHC.TypeLits
14+
15+import Grenade.Core.Shape
16+import Grenade.Core.Network
17+import Grenade.Layers.FullyConnected
18+
19+import qualified Numeric.LinearAlgebra.Static as HStatic
20+
21+import Disorder.Jack
22+
23+import Test.Jack.Hmatrix
24+
25+
26+data OpaqueFullyConnected :: * where
27+ OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected
28+
29+instance Show OpaqueFullyConnected where
30+ show (OpaqueFullyConnected n) = show n
31+
32+genOpaqueFullyConnected :: Jack OpaqueFullyConnected
33+genOpaqueFullyConnected = do
34+ input :: Integer <- choose (2, 100)
35+ output :: Integer <- choose (2, 100)
36+ let Just input' = someNatVal input
37+ let Just output' = someNatVal output
38+ case (input', output') of
39+ (SomeNat (Proxy :: Proxy i'), SomeNat (Proxy :: Proxy o')) -> do
40+ wB <- randomVector
41+ bM <- randomVector
42+ wN <- uniformSample
43+ kM <- uniformSample
44+ return . OpaqueFullyConnected $ (FullyConnected wB bM wN kM :: FullyConnected i' o')
45+
46+prop_fully_connected_forwards :: Property
47+prop_fully_connected_forwards =
48+ gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->
49+ let i = fromIntegral $ natVal (Proxy :: Proxy i)
50+ in gamble (vectorOf i sizedRealFrac) $ \input ->
51+ let x :: S' ('D1 o) = runForwards fclayer (S1D' (HStatic.vector input :: HStatic.R i))
52+ in x `seq` True
53+
54+
55+return []
56+tests :: IO Bool
57+tests = $quickCheckAll
test/Test/Grenade/Layers/Internal/Convolution.hsnew file+54
@@ -0,0 +1,54 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE ConstraintKinds #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
9+module Test.Grenade.Layers.Internal.Convolution where
10+
11+-- import Control.Monad.Random
12+
13+import Grenade.Layers.Internal.Convolution
14+
15+import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
16+
17+import Disorder.Jack
18+
19+import qualified Test.Grenade.Layers.Internal.Reference as Reference
20+
21+prop_im2col_col2im_symmetrical_with_kernel_stride =
22+ let factors n = [x | x <- [1..n], n `mod` x == 0]
23+ in gamble (choose (2, 100)) $ \height ->
24+ gamble (choose (2, 100)) $ \width ->
25+ gamble ((height `div`) <$> elements (factors height)) $ \kernel_h ->
26+ gamble ((width `div`) <$> elements (factors width)) $ \kernel_w ->
27+ gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
28+ let input' = (height >< width) input
29+ stride_h = kernel_h
30+ stride_w = kernel_w
31+ out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input'
32+ in input' === out
33+
34+prop_im2col_col2im_behaves_as_reference =
35+ let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
36+ in gamble (choose (2, 100)) $ \height ->
37+ gamble (choose (2, 100)) $ \width ->
38+ gamble (choose (2, height - 1)) $ \kernel_h ->
39+ gamble (choose (2, width - 1)) $ \kernel_w ->
40+ gamble (elements (ok height kernel_h)) $ \stride_h ->
41+ gamble (elements (ok width kernel_w)) $ \stride_w ->
42+ gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
43+ let input' = (height >< width) input
44+ outFast = im2col kernel_h kernel_w stride_h stride_w input'
45+ retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast
46+
47+ outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input'
48+ retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference
49+ in outFast === outReference .&&. retFast === retReference
50+
51+
52+return []
53+tests :: IO Bool
54+tests = $quickCheckAll
test/Test/Grenade/Layers/Internal/Pooling.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE ConstraintKinds #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
9+module Test.Grenade.Layers.Internal.Pooling where
10+
11+import Grenade.Layers.Internal.Pooling
12+
13+import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
14+
15+import Disorder.Jack
16+
17+import qualified Test.Grenade.Layers.Internal.Reference as Reference
18+
19+prop_poolForwards_poolBackwards_behaves_as_reference =
20+ let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
21+ output extent kernel stride = (extent - kernel) `div` stride + 1
22+ in gamble (choose (2, 100)) $ \height ->
23+ gamble (choose (2, 100)) $ \width ->
24+ gamble (choose (2, height - 1)) $ \kernel_h ->
25+ gamble (choose (2, width - 1)) $ \kernel_w ->
26+ gamble (elements (ok height kernel_h)) $ \stride_h ->
27+ gamble (elements (ok width kernel_w)) $ \stride_w ->
28+ gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
29+ let input' = (height >< width) input
30+ outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'
31+ -- retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast
32+
33+ outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'
34+ -- retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference
35+ in outFast === outReference -- .&&. retFast === retReference
36+
37+
38+prop_poolForwards_poolBackwards_symmetry =
39+ let factors n = [x | x <- [1..n], n `mod` x == 0]
40+ output extent kernel stride = (extent - kernel) `div` stride + 1
41+ in gamble (choose (2, 100)) $ \height ->
42+ gamble (choose (2, 100)) $ \width ->
43+ gamble ((height `div`) <$> elements (factors height)) $ \kernel_h ->
44+ gamble ((width `div`) <$> elements (factors width)) $ \kernel_w ->
45+ gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
46+ let input' = (height >< width) input
47+ stride_h = kernel_h
48+ stride_w = kernel_w
49+ outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'
50+ retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast
51+
52+ outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'
53+ retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference
54+ in outFast === outReference .&&. retFast === retReference
55+
56+
57+return []
58+tests :: IO Bool
59+tests = $quickCheckAll
test/Test/Grenade/Layers/Internal/Reference.hsnew file+129
@@ -0,0 +1,129 @@
1+module Test.Grenade.Layers.Internal.Reference where
2+
3+
4+import Control.Monad.ST ( ST )
5+
6+import Data.Foldable ( forM_ )
7+import Data.Function ( on )
8+import Data.List ( maximumBy )
9+
10+import Numeric.LinearAlgebra
11+import qualified Numeric.LinearAlgebra.Devel as U
12+
13+im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
14+im2col nrows ncols srows scols m =
15+ let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols
16+ in im2colFit starts nrows ncols m
17+
18+vid2col :: Int -> Int -> Int -> Int -> Int -> Int -> [Matrix Double] -> Matrix Double
19+vid2col nrows ncols srows scols inputrows inputcols ms =
20+ let starts = fittingStarts inputrows nrows srows inputcols ncols scols
21+ subs = fmap (im2colFit starts nrows ncols) ms
22+ in foldl1 (|||) subs
23+
24+im2colFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double
25+im2colFit starts nrows ncols m =
26+ let imRows = fmap (\start -> flatten $ subMatrix start (nrows, ncols) m) starts
27+ in fromRows imRows
28+
29+col2vid :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> [Matrix Double]
30+col2vid nrows ncols srows scols drows dcols m =
31+ let starts = fittingStart (cols m) (nrows * ncols) (nrows * ncols)
32+ r = rows m
33+ mats = fmap (\s -> subMatrix (0,s) (r, nrows * ncols) m) starts
34+ colSts = fittingStarts drows nrows srows dcols ncols scols
35+ in fmap (col2imfit colSts nrows ncols drows dcols) mats
36+
37+col2im :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
38+col2im krows kcols srows scols drows dcols m =
39+ let starts = fittingStarts drows krows srows dcols kcols scols
40+ in col2imfit starts krows kcols drows dcols m
41+
42+col2imfit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
43+col2imfit starts krows kcols drows dcols m =
44+ let indicies = (\[a,b] -> (a,b)) <$> sequence [[0..(krows-1)], [0..(kcols-1)]]
45+ convs = fmap (zip indicies . toList) . toRows $ m
46+ pairs = zip convs starts
47+ accums = concatMap (\(conv',(stx',sty')) -> fmap (\((ix,iy), val) -> ((ix + stx', iy + sty'), val)) conv') pairs
48+ in accum (konst 0 (drows, dcols)) (+) accums
49+
50+
51+poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
52+poolForward nrows ncols srows scols outputRows outputCols m =
53+ let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols
54+ in poolForwardFit starts nrows ncols outputRows outputCols m
55+
56+poolForwardList :: Functor f => Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> f (Matrix Double) -> f (Matrix Double)
57+poolForwardList nrows ncols srows scols inRows inCols outputRows outputCols ms =
58+ let starts = fittingStarts inRows nrows srows inCols ncols scols
59+ in poolForwardFit starts nrows ncols outputRows outputCols <$> ms
60+
61+poolForwardFit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
62+poolForwardFit starts nrows ncols _ outputCols m =
63+ let els = fmap (\start -> unsafeMaxElementSubmatrix start (nrows, ncols) m) starts
64+ in matrix outputCols els
65+
66+poolBackward :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double
67+poolBackward krows kcols srows scols inputMatrix gradientMatrix =
68+ let inRows = rows inputMatrix
69+ inCols = cols inputMatrix
70+ starts = fittingStarts inRows krows srows inCols kcols scols
71+ in poolBackwardFit starts krows kcols inputMatrix gradientMatrix
72+
73+poolBackwardList :: Functor f => Int -> Int -> Int -> Int -> Int -> Int -> f (Matrix Double, Matrix Double) -> f (Matrix Double)
74+poolBackwardList krows kcols srows scols inRows inCols inputMatrices =
75+ let starts = fittingStarts inRows krows srows inCols kcols scols
76+ in uncurry (poolBackwardFit starts krows kcols) <$> inputMatrices
77+
78+poolBackwardFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double
79+poolBackwardFit starts krows kcols inputMatrix gradientMatrix = U.runSTMatrix $ do
80+ let inRows = rows inputMatrix
81+ inCols = cols inputMatrix
82+ gradCol = cols gradientMatrix
83+ extent = (krows, kcols)
84+
85+ retM <- U.newMatrix 0 inRows inCols
86+
87+ forM_ (zip [0..] starts) $ \(ix, start) -> do
88+ let loc = unsafeMaxIndexSubMatrix start extent inputMatrix
89+ uncurry (unsafeModifyMatrix retM) loc ((+) $ uncurry (U.atM' gradientMatrix) $ divMod ix gradCol)
90+
91+ return retM
92+
93+unsafeMaxElementSubmatrix :: (Int,Int) -> (Int,Int) -> Matrix Double -> Double
94+unsafeMaxElementSubmatrix starts extent m = uncurry (U.atM' m) $ unsafeMaxIndexSubMatrix starts extent m
95+
96+unsafeMaxIndexSubMatrix :: (Int,Int) -> (Int,Int) -> Matrix Double -> (Int, Int)
97+unsafeMaxIndexSubMatrix (startRow, startCol) (extentRow, extentCold) m =
98+ let mrows = [startRow .. startRow + extentRow - 1]
99+ mcols = [startCol .. startCol + extentCold - 1]
100+ pairs = concatMap ( \r -> fmap (\c -> (r , c)) mcols ) mrows
101+ in maximumBy (compare `on` uncurry (U.atM' m)) pairs
102+
103+
104+unsafeModifyMatrix :: U.STMatrix s Double -> Int -> Int -> (Double -> Double) -> ST s ()
105+unsafeModifyMatrix x r c f = U.unsafeReadMatrix x r c >>= U.unsafeWriteMatrix x r c . f
106+
107+
108+-- | These functions are not even remotely safe, but it's only called from the statically typed
109+-- commands, so we should be good ?!?!?
110+-- Returns the starting sub matrix locations which fit inside the larger matrix for the
111+-- convolution. Takes into account the stride and kernel size.
112+fittingStarts :: Int -> Int -> Int -> Int -> Int -> Int -> [(Int,Int)]
113+fittingStarts nrows kernelrows steprows ncols kernelcols stepcolsh =
114+ let rs = fittingStart nrows kernelrows steprows
115+ cs = fittingStart ncols kernelcols stepcolsh
116+ ls = sequence [rs, cs]
117+ in fmap (\[a,b] -> (a,b)) ls
118+
119+-- | Returns the starting sub vector which fit inside the larger vector for the
120+-- convolution. Takes into account the stride and kernel size.
121+fittingStart :: Int -> Int -> Int -> [Int]
122+fittingStart width kernel steps =
123+ let go left | left + kernel < width
124+ = left : go (left + steps)
125+ | left + kernel == width
126+ = [left]
127+ | otherwise
128+ = []
129+ in go 0
test/Test/Grenade/Layers/Pooling.hs+29−68
@@ -1,82 +1,43 @@
1{-# LANGUAGE TemplateHaskell #-}
1{-# LANGUAGE TemplateHaskell #-}
2−{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE KindSignatures #-}
3−{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
4{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
6{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
5module Test.Grenade.Layers.Pooling where
7module Test.Grenade.Layers.Pooling where
6
8
7−import Grenade.Layers.Internal.Pooling
9+import Data.Proxy
10+import Data.Singletons ()
8
11
9−import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
12+import GHC.TypeLits
13+import Grenade.Layers.Pooling
10
14
11−import Test.QuickCheck hiding ((><))
15+import Disorder.Jack
12
16
13−prop_pool = once $
14− let input = (3><4)
15− [ 1.0, 14.0, 3.0, 4.0
16− , 5.0, 6.0, 7.0, 8.0
17− , 9.0, 10.0, 11.0, 12.0 ]
18− expected = (2><3)
19− [ 14.0, 14.0, 8.0
20− , 10.0, 11.0, 12.0 ]
21− out = poolForward 1 3 4 2 2 1 1 input
22− in expected === out
23
17
24−prop_pool_rectangular = once $
18+data OpaquePooling :: * where
25− let input = (3><4)
19+ OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling
26− [ 1.0, 14.0, 3.0, 4.0
27− , 5.0, 6.0, 7.0, 8.0
28− , 9.0, 10.0, 11.0, 12.0 ]
29− expected = (2><2)
30− [ 14.0, 14.0
31− , 11.0, 12.0 ]
32− out = poolForward 1 3 4 2 3 1 1 input
33− in expected === out
34
20
35−prop_pool_channels = once $
21+instance Show OpaquePooling where
36− let input = (6><4)
22+ show (OpaquePooling n) = show n
37− [ 1.0, 14.0, 3.0, 4.0
38− , 5.0, 6.0, 7.0, 8.0
39− , 9.0, 10.0, 11.0, 12.0
40− , 1.0, 2.0, 3.0, 4.0
41− , 5.0, 6.0, 7.0, 8.0
42− , 9.0, 10.0, 11.0, 12.0 ]
43− expected = (4><2)
44− [ 14.0, 14.0
45− , 11.0, 12.0
46− , 7.0, 8.0
47− , 11.0, 12.0 ]
48− out = poolForward 2 3 4 2 3 1 1 input
49− in expected === out
50
23
51−prop_pool_backwards = once $
24+genOpaquePooling :: Jack OpaquePooling
52− let input = (3><4)
25+genOpaquePooling = do
53− [ 1.0, 2.0, 3.0, 4.0
26+ Just kernelHeight <- someNatVal <$> choose (2, 15)
54− , 5.0, 6.0, 7.0, 8.0
27+ Just kernelWidth <- someNatVal <$> choose (2, 15)
55− , 9.0, 10.0, 11.0, 12.0 ]
28+ Just strideHeight <- someNatVal <$> choose (2, 15)
56− grads = (2><3)
29+ Just strideWidth <- someNatVal <$> choose (2, 15)
57− [ -6.0, -7.0, -8.0
30+
58− , -10.0, -11.0, -12.0 ]
31+ case (kernelHeight, kernelWidth, strideHeight, strideWidth) of
59− expected = (3><4)
32+ (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->
60− [ 0.0, 0.0, 0.0, 0.0
33+ return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)
61− , 0.0, -6.0, -7.0, -8.0
34+
62− , 0.0,-10.0,-11.0,-12.0 ]
35+prop_pool_layer_witness =
63− out = poolBackward 1 3 4 2 2 1 1 input grads
36+ gamble genOpaquePooling $ \onet ->
64− in expected === out
37+ (case onet of
38+ (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) -> True
39+ ) :: Bool
65
40
66−prop_pool_backwards_additive = once $
67− let input = (3><4)
68− [ 4.0, 2.0, 3.0, 4.0
69− , 0.0, 0.0, 7.0, 8.0
70− , 9.0, 0.0, 0.0, 0.0 ]
71− grads = (2><3)
72− [ -6.0, -7.0, -8.0
73− , -10.0, -11.0, -12.0 ]
74− expected = (3><4)
75− [-6.0, 0.0, 0.0, 0.0
76− , 0.0, 0.0,-18.0,-20.0
77− ,-10.0, 0.0, 0.0, 0.0 ]
78− out = poolBackward 1 3 4 2 2 1 1 input grads
79− in expected === out
80
41
81return []
42return []
82tests :: IO Bool
43tests :: IO Bool
test/Test/Jack/Hmatrix.hsnew file+20
@@ -0,0 +1,20 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+module Test.Jack.Hmatrix where
6+
7+import Data.Proxy
8+import Disorder.Jack
9+
10+import GHC.TypeLits
11+
12+import qualified Numeric.LinearAlgebra.Static as HStatic
13+
14+randomVector :: forall n. KnownNat n => Jack (HStatic.R n)
15+randomVector = HStatic.fromList <$> vectorOf (fromInteger (natVal (Proxy :: Proxy n))) sizedRealFrac
16+
17+uniformSample :: forall m n. (KnownNat m, KnownNat n) => Jack (HStatic.L m n)
18+uniformSample = HStatic.fromList
19+ <$> vectorOf (fromInteger (natVal (Proxy :: Proxy m)) * fromInteger (natVal (Proxy :: Proxy n)))
20+ sizedRealFrac
test/test.hs+11−2
@@ -1,11 +1,20 @@
1import Disorder.Core.Main
1import Disorder.Core.Main
2
2
3−import qualified Test.Grenade.Layers.Pooling as Test.Grenade.Layers.Pooling
3+import qualified Test.Grenade.Layers.Pooling as Test.Grenade.Layers.Pooling
4−import qualified Test.Grenade.Layers.Convolution as Test.Grenade.Layers.Convolution
4+import qualified Test.Grenade.Layers.Convolution as Test.Grenade.Layers.Convolution
5+import qualified Test.Grenade.Layers.FullyConnected as Test.Grenade.Layers.FullyConnected
6+
7+import qualified Test.Grenade.Layers.Internal.Convolution as Test.Grenade.Layers.Internal.Convolution
8+import qualified Test.Grenade.Layers.Internal.Pooling as Test.Grenade.Layers.Internal.Pooling
9+
5
10
6main :: IO ()
11main :: IO ()
7main =
12main =
8 disorderMain [
13 disorderMain [
9 Test.Grenade.Layers.Pooling.tests
14 Test.Grenade.Layers.Pooling.tests
10 , Test.Grenade.Layers.Convolution.tests
15 , Test.Grenade.Layers.Convolution.tests
16+ , Test.Grenade.Layers.FullyConnected.tests
17+
18+ , Test.Grenade.Layers.Internal.Convolution.tests
19+ , Test.Grenade.Layers.Internal.Pooling.tests
11 ]
20 ]