10a6003 · grenade · git.iko.soy

git.iko.soy/grenade

on master help sign in

Add Deconvolution layer and update the GAN example to use it

10a6003Huw Campbell10 years ago

README.md+42−3

compare with master

unifiedsplit

@@ -12,7 +12,7 @@ Five is right out.

13💣 Machine learning which might blow up in your face 💣

15−Grenade is a dependently typed, practical, and fast recurrent neural network library

15+Grenade is a composable, dependently typed, practical, and fast recurrent neural network library

16for concise and precise specifications of complex networks in Haskell.

18As an example, a network which can achieve ~1.5% error on MNIST can be

@@ -100,9 +100,48 @@ easy in downstream code. If the shapes of a network are not specified correctly

100and a layer can not sensibly perform the operation between two shapes, then

101it will result in a compile time error.

102

103+Composition

104+-----------

105+

106+Networks and Layers in Grenade are easily composed at the type level. As a `Network`

107+is an instance of `Layer`, one can use a trained Network as a small component in a

108+larger network easily. Furthermore, we provide 2 layers which are designed to run

109+layers in parallel and merge their output (either by concatenating them across one

110+dimension or summing by pointwise adding their activations). This allows one to

111+write any Network which can be expressed as a

112+[series parallel graph](https://en.wikipedia.org/wiki/Series-parallel_graph).

113+

114+A residual network layer specification for instance could be written as

115+```haskell

116+type Residual net = Merge Trivial net

117+```

118+If the type `net` is an instance of `Layer`, then `Residual net` will be too. It will

119+run the network, while retaining its input by passing it through the `Trivial` layer,

120+and merge the original image with the output.

121+

122+See the [MNIST](https://github.com/HuwCampbell/grenade/blob/master/examples/main/mnist.hs)

123+example, which has been overengineered to contain both residual style learning as well

124+as inception style convolutions.

125+

126+Generative Adversarial Networks

127+-------------------------------

128+

129+As Grenade is purely functional, one can compose its training functions in flexible

130+ways. [GAN-MNIST](https://github.com/HuwCampbell/grenade/blob/master/examples/main/gan-mnist.hs)

131+example displays an interesting, type safe way of writing a generative adversarial

132+training function in 10 lines of code.

133+

134+Layer Zoo

135+---------

136+

137+Grenade layers are normal haskell data types which are an instance of `Layer`, so

138+it's easy to build one's own downstream code. We do however provide a decent set

139+of layers, including convolution, deconvolution, pooling, pad, crop, logit, relu,

140+elu, tanh, and fully connected.

141+

103Build Instructions

142Build Instructions

104------------------

143------------------

105−Grenade currently only builds with the [mafia](https://github.com/ambiata/mafia)

144+Grenade is most easily built with the [mafia](https://github.com/ambiata/mafia)

106script that is located in the repository. You will also need the `lapack` and

145script that is located in the repository. You will also need the `lapack` and

107`blas` libraries and development tools. Once you have all that, Grenade can be

146`blas` libraries and development tools. Once you have all that, Grenade can be

108build using:

147build using:

@@ -117,7 +156,7 @@ and the tests run using:

117./mafia test

156./mafia test

118```

157```

119

158

120−Grenade is currently known to build with ghc 7.10 and 8.0.

159+Grenade builds with ghc 7.10 and 8.0.

121

160

122Thanks

161Thanks

123------

162------

examples/main/gan-mnist.hs+22−8

@@ -10,8 +10,8 @@

10-- This is a simple generative adversarial network to make pictures

11-- of numbers similar to those in MNIST.

12--

13−-- It demonstrates a different usage of the library. Within about an

13+-- It demonstrates a different usage of the library. Within about 15

14−-- hour it was producing examples like this:

14+-- minutes hour it was producing examples like this:

15--

16-- --.

17-- .=-.--..#=###

@@ -57,11 +57,25 @@ import Options.Applicative

57import Grenade

58import Grenade.Utils.OneHot

60+type Discriminator =

61+ Network

62+ '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Relu

63+ , Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Relu

60−type Discriminator = Network '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Relu, Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Reshape, Relu, FullyConnected 256 80, Logit, FullyConnected 80 1, Logit]

64+ , Reshape, FullyConnected 256 80, Logit, FullyConnected 80 1, Logit]

65+ '[ 'D2 28 28

61− '[ 'D2 28 28, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10, 'D3 8 8 16, 'D3 4 4 16, 'D1 256, 'D1 256, 'D1 80, 'D1 80, 'D1 1, 'D1 1]

66+ , 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10

62−

67+ , 'D3 8 8 16, 'D3 4 4 16, 'D3 4 4 16

63−type Generator = Network '[ FullyConnected 100 10240, Relu, Reshape, Convolution 10 10 5 5 1 1, Relu, Convolution 10 1 1 1 1 1, Logit, Reshape]

68+ , 'D1 256, 'D1 80, 'D1 80, 'D1 1, 'D1 1]

64− '[ 'D1 100, 'D1 10240, 'D1 10240, 'D3 32 32 10, 'D3 28 28 10, 'D3 28 28 10, 'D3 28 28 1, 'D3 28 28 1, 'D2 28 28 ]

69+

70+type Generator =

71+ Network

72+ '[ FullyConnected 80 256, Relu, Reshape

73+ , Deconvolution 16 10 5 5 2 2, Relu

74+ , Deconvolution 10 1 8 8 2 2, Logit]

75+ '[ 'D1 80

76+ , 'D1 256, 'D1 256, 'D3 4 4 16

77+ , 'D3 11 11 10, 'D3 11 11 10

78+ , 'D2 28 28, 'D2 28 28 ]

66randomDiscriminator :: MonadRandom m => m Discriminator

80randomDiscriminator :: MonadRandom m => m Discriminator

67randomDiscriminator = randomNetwork

81randomDiscriminator = randomNetwork

@@ -69,7 +83,7 @@ randomDiscriminator = randomNetwork

69randomGenerator :: MonadRandom m => m Generator

83randomGenerator :: MonadRandom m => m Generator

70randomGenerator = randomNetwork

84randomGenerator = randomNetwork

72−trainExample :: LearningParameters -> Discriminator -> Generator -> S ('D2 28 28) -> S ('D1 100) -> ( Discriminator, Generator )

86+trainExample :: LearningParameters -> Discriminator -> Generator -> S ('D2 28 28) -> S ('D1 80) -> ( Discriminator, Generator )

73trainExample rate discriminator generator realExample noiseSource

87trainExample rate discriminator generator realExample noiseSource

74 = let (generatorTape, fakeExample) = runNetwork generator noiseSource

88 = let (generatorTape, fakeExample) = runNetwork generator noiseSource

examples/main/mnist.hs+19−12

@@ -5,6 +5,7 @@

5{-# LANGUAGE TupleSections #-}

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE FlexibleContexts #-}

8import Control.Applicative

9import Control.Applicative

9import Control.Monad

10import Control.Monad

10import Control.Monad.Random

11import Control.Monad.Random

@@ -25,6 +26,15 @@ import Options.Applicative

25import Grenade

26import Grenade

26import Grenade.Utils.OneHot

27import Grenade.Utils.OneHot

29+-- It's logistic regression!

30+--

31+-- This network is used to show how we can embed a Network as a layer in the larger MNIST

32+-- type.

33+type FL i o =

34+ Network

35+ '[ FullyConnected i o, Logit ]

36+ '[ 'D1 i, 'D1 o, 'D1 o ]

37+

28-- The definition of our convolutional neural network.

38-- The definition of our convolutional neural network.

29-- In the type signature, we have a type level list of shapes which are passed between the layers.

39-- In the type signature, we have a type level list of shapes which are passed between the layers.

30-- One can see that the images we are inputing are two dimensional with 28 * 28 pixels.

40-- One can see that the images we are inputing are two dimensional with 28 * 28 pixels.

@@ -40,18 +50,15 @@ import Grenade.Utils.OneHot

40--

50--

41type MNIST =

51type MNIST =

42 Network

52 Network

43− '[ Reshape

53+ '[ Reshape,

54+ Concat ('D3 28 28 1) Trivial ('D3 28 28 14) (InceptionMini 28 28 1 5 9),

44− , Inception 28 28 1 5 5 5, Pooling 2 2 2 2, Relu

55+ Pooling 2 2 2 2, Relu,

45− , Inception 14 14 15 5 5 5, Pooling 2 2 2 2, Relu

56+ Concat ('D3 14 14 3) (Convolution 15 3 1 1 1 1) ('D3 14 14 15) (InceptionMini 14 14 15 5 10), Crop 1 1 1 1, Pooling 3 3 3 3, Relu,

46− , Reshape

57+ Reshape, FL 288 80, FL 80 10 ]

47− , FullyConnected 735 80, Logit

48− , FullyConnected 80 10, Logit]

49− '[ 'D2 28 28, 'D3 28 28 1

58+ '[ 'D2 28 28, 'D3 28 28 1,

50− , 'D3 28 28 15, 'D3 14 14 15, 'D3 14 14 15

59+ 'D3 28 28 15, 'D3 14 14 15, 'D3 14 14 15, 'D3 14 14 18,

51− , 'D3 14 14 15, 'D3 7 7 15, 'D3 7 7 15

60+ 'D3 12 12 18, 'D3 4 4 18, 'D3 4 4 18,

52− , 'D1 735

53− , 'D1 80, 'D1 80

61+ 'D1 288, 'D1 80, 'D1 10 ]

54− , 'D1 10, 'D1 10]

56randomMnist :: MonadRandom m => m MNIST

63randomMnist :: MonadRandom m => m MNIST

57randomMnist = randomNetwork

64randomMnist = randomNetwork

grenade.cabal+1

@@ -61,6 +61,7 @@ library

61 Grenade.Layers.Concat

62 Grenade.Layers.Convolution

63 Grenade.Layers.Crop

64+ Grenade.Layers.Deconvolution

64 Grenade.Layers.Dropout

65 Grenade.Layers.Dropout

65 Grenade.Layers.Elu

66 Grenade.Layers.Elu

66 Grenade.Layers.FullyConnected

67 Grenade.Layers.FullyConnected

src/Grenade/Layers.hs+2

@@ -2,6 +2,7 @@ module Grenade.Layers (

2 module Grenade.Layers.Concat

3 , module Grenade.Layers.Convolution

4 , module Grenade.Layers.Crop

5+ , module Grenade.Layers.Deconvolution

5 , module Grenade.Layers.Elu

6 , module Grenade.Layers.Elu

6 , module Grenade.Layers.FullyConnected

7 , module Grenade.Layers.FullyConnected

7 , module Grenade.Layers.Inception

8 , module Grenade.Layers.Inception

@@ -19,6 +20,7 @@ module Grenade.Layers (

19import Grenade.Layers.Concat

20import Grenade.Layers.Concat

20import Grenade.Layers.Convolution

21import Grenade.Layers.Convolution

21import Grenade.Layers.Crop

22import Grenade.Layers.Crop

23+import Grenade.Layers.Deconvolution

22import Grenade.Layers.Elu

24import Grenade.Layers.Elu

23import Grenade.Layers.Pad

25import Grenade.Layers.Pad

24import Grenade.Layers.FullyConnected

26import Grenade.Layers.FullyConnected

src/Grenade/Layers/Convolution.hs+71−55

@@ -141,7 +141,8 @@ instance ( KnownNat channels

141 let mm = konst 0

142 return $ Convolution wN mm

143

144−-- | A two dimentional image may have a convolution filter applied to it

144+-- | A three dimensional image (or 2d with many channels) can have

145+-- an appropriately sized convolution filter run across it.

145instance ( KnownNat kernelRows

146instance ( KnownNat kernelRows

146 , KnownNat kernelCols

147 , KnownNat kernelCols

147 , KnownNat filters

148 , KnownNat filters

@@ -151,28 +152,33 @@ instance ( KnownNat kernelRows

151 , KnownNat inputCols

152 , KnownNat inputCols

152 , KnownNat outputRows

153 , KnownNat outputRows

153 , KnownNat outputCols

154 , KnownNat outputCols

155+ , KnownNat channels

154 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)

156 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)

155 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)

157 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)

156− , KnownNat (kernelRows * kernelCols * 1)

158+ , KnownNat (kernelRows * kernelCols * channels)

157 , KnownNat (outputRows * filters)

159 , KnownNat (outputRows * filters)

158− ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where

160+ ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where

161+

159− type Tape (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D2 inputRows inputCols)

162+ type Tape (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)

163+

160− runForwards (Convolution kernel _) (S2D input) =

164+ runForwards (Convolution kernel _) (S3D input) =

161 let ex = extract input

165 let ex = extract input

162 ek = extract kernel

166 ek = extract kernel

167+ ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

168+ iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

163 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

169 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

164 ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

170 ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

165 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

171 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

166 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

172 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

167 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

173 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

168 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

174 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

175+

169− c = im2col kx ky sx sy ex

176+ c = vid2col kx ky sx sy ix iy ex

170 mt = c LA.<> ek

177 mt = c LA.<> ek

171 r = col2vid 1 1 1 1 ox oy mt

178 r = col2vid 1 1 1 1 ox oy mt

172 rs = fromJust . create $ r

179 rs = fromJust . create $ r

173− in (S2D input, S3D rs)

180+ in (S3D input, S3D rs)

174−

175− runBackwards (Convolution kernel _) (S2D input) (S3D dEdy) =

181+ runBackwards (Convolution kernel _) (S3D input) (S3D dEdy) =

176 let ex = extract input

182 let ex = extract input

177 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

183 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

178 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

184 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

@@ -183,7 +189,7 @@ instance ( KnownNat kernelRows

183 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

189 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

184 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

190 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

185

191

186− c = im2col kx ky sx sy ex

192+ c = vid2col kx ky sx sy ix iy ex

187

193

188 eo = extract dEdy

194 eo = extract dEdy

189 ek = extract kernel

195 ek = extract kernel

@@ -191,14 +197,14 @@ instance ( KnownNat kernelRows

191 vs = vid2col 1 1 1 1 ox oy eo

197 vs = vid2col 1 1 1 1 ox oy eo

192

198

193 kN = fromJust . create $ tr c LA.<> vs

199 kN = fromJust . create $ tr c LA.<> vs

200+

194 dW = vs LA.<> tr ek

201 dW = vs LA.<> tr ek

195

202

196− xW = col2im kx ky sx sy ix iy dW

203+ xW = col2vid kx ky sx sy ix iy dW

197− in (Convolution' kN, S2D . fromJust . create $ xW)

204+ in (Convolution' kN, S3D . fromJust . create $ xW)

198

205

199

206

200−-- | A three dimensional image (or 2d with many channels) can have

207+-- | A two dimentional image may have a convolution filter applied to it

201−-- an appropriately sized convolution filter run across it.

202instance ( KnownNat kernelRows

208instance ( KnownNat kernelRows

203 , KnownNat kernelCols

209 , KnownNat kernelCols

204 , KnownNat filters

210 , KnownNat filters

@@ -208,53 +214,63 @@ instance ( KnownNat kernelRows

208 , KnownNat inputCols

214 , KnownNat inputCols

209 , KnownNat outputRows

215 , KnownNat outputRows

210 , KnownNat outputCols

216 , KnownNat outputCols

211− , KnownNat channels

212 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)

217 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)

213 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)

218 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)

214− , KnownNat (kernelRows * kernelCols * channels)

219+ , KnownNat (kernelRows * kernelCols * 1)

215 , KnownNat (outputRows * filters)

220 , KnownNat (outputRows * filters)

216− ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where

221+ ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where

217−

218− type Tape (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)

222+ type Tape (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols 1)

219−

220− runForwards (Convolution kernel _) (S3D input) =

223+ runForwards c (S2D input) =

221− let ex = extract input

224+ runForwards c (S3D input :: S ('D3 inputRows inputCols 1))

222− ek = extract kernel

223− ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

224− iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

225− kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

226− ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

227− sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

228− sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

229− ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

230− oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

231−

232− c = vid2col kx ky sx sy ix iy ex

233− mt = c LA.<> ek

234− r = col2vid 1 1 1 1 ox oy mt

235− rs = fromJust . create $ r

236− in (S3D input, S3D rs)

237− runBackwards (Convolution kernel _) (S3D input) (S3D dEdy) =

238− let ex = extract input

239− ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

240− iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

241− kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

242− ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

243− sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

244− sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

245− ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

246− oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

247

225

248− c = vid2col kx ky sx sy ix iy ex

226+ runBackwards c tape grads =

227+ case runBackwards c tape grads of

228+ (c', S3D back :: S ('D3 inputRows inputCols 1)) -> (c', S2D back)

249

229

250− eo = extract dEdy

251− ek = extract kernel

252

230

253− vs = vid2col 1 1 1 1 ox oy eo

231+-- | A two dimensional image may have a convolution filter applied to it producing

232+-- a two dimensional image if both channels and filters is 1.

233+instance ( KnownNat kernelRows

234+ , KnownNat kernelCols

235+ , KnownNat strideRows

236+ , KnownNat strideCols

237+ , KnownNat inputRows

238+ , KnownNat inputCols

239+ , KnownNat outputRows

240+ , KnownNat outputCols

241+ , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)

242+ , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)

243+ , KnownNat (kernelRows * kernelCols * 1)

244+ , KnownNat (outputRows * 1)

245+ ) => Layer (Convolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) where

246+ type Tape (Convolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols 1)

247+ runForwards c (S2D input) =

248+ case runForwards c (S3D input :: S ('D3 inputRows inputCols 1)) of

249+ (tps, S3D back :: S ('D3 outputRows outputCols 1)) -> (tps, S2D back)

254

250

255− kN = fromJust . create $ tr c LA.<> vs

251+ runBackwards c tape (S2D grads) =

252+ case runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1)) of

253+ (c', S3D back :: S ('D3 inputRows inputCols 1)) -> (c', S2D back)

256

254

257− dW = vs LA.<> tr ek

255+-- | A three dimensional image can produce a 2D image from a convolution with 1 filter

256+instance ( KnownNat kernelRows

257+ , KnownNat kernelCols

258+ , KnownNat strideRows

259+ , KnownNat strideCols

260+ , KnownNat inputRows

261+ , KnownNat inputCols

262+ , KnownNat outputRows

263+ , KnownNat outputCols

264+ , KnownNat channels

265+ , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)

266+ , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)

267+ , KnownNat (kernelRows * kernelCols * channels)

268+ , KnownNat (outputRows * 1)

269+ ) => Layer (Convolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) where

270+ type Tape (Convolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols channels)

271+ runForwards c input =

272+ case runForwards c input of

273+ (tps, S3D back :: S ('D3 outputRows outputCols 1)) -> (tps, S2D back)

258

274

259− xW = col2vid kx ky sx sy ix iy dW

275+ runBackwards c tape (S2D grads) =

260− in (Convolution' kN, S3D . fromJust . create $ xW)

276+ runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1))

src/Grenade/Layers/Deconvolution.hsnew file+275

@@ -0,0 +1,275 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE RecordWildCards #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+{-# LANGUAGE FlexibleContexts #-}

10+module Grenade.Layers.Deconvolution (

11+ Deconvolution (..)

12+ , Deconvolution' (..)

13+ , randomDeconvolution

14+ ) where

15+

16+import Control.Monad.Random hiding ( fromList )

17+import Data.Maybe

18+import Data.Proxy

19+import Data.Serialize

20+import Data.Singletons.TypeLits

21+

22+import GHC.TypeLits

23+

24+import Numeric.LinearAlgebra hiding ( uniformSample, konst )

25+import qualified Numeric.LinearAlgebra as LA

26+import Numeric.LinearAlgebra.Static hiding ((|||), build, toRows)

27+

28+import Grenade.Core

29+import Grenade.Layers.Internal.Convolution

30+import Grenade.Layers.Internal.Update

31+

32+-- | A Deconvolution layer for a neural network.

33+-- This uses the im2col Deconvolution trick popularised by Caffe, which essentially turns the

34+-- many, many, many, many loop Deconvolution into a single matrix multiplication.

35+--

36+-- The Deconvolution layer takes all of the kernels for the Deconvolution, which are flattened

37+-- and then put into columns in the matrix.

38+--

39+-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:

40+-- `out = (in - kernel) / stride + 1` for both dimensions.

41+--

42+-- One probably shouldn't build their own layer, but rather use the randomDeconvolution function.

43+data Deconvolution :: Nat -- Number of channels, for the first layer this could be RGB for instance.

44+ -> Nat -- Number of filters, this is the number of channels output by the layer.

45+ -> Nat -- The number of rows in the kernel filter

46+ -> Nat -- The number of column in the kernel filter

47+ -> Nat -- The row stride of the Deconvolution filter

48+ -> Nat -- The columns stride of the Deconvolution filter

49+ -> * where

50+ Deconvolution :: ( KnownNat channels

51+ , KnownNat filters

52+ , KnownNat kernelRows

53+ , KnownNat kernelColumns

54+ , KnownNat strideRows

55+ , KnownNat strideColumns

56+ , KnownNat kernelFlattened

57+ , kernelFlattened ~ (kernelRows * kernelColumns * filters))

58+ => !(L kernelFlattened channels) -- The kernel filter weights

59+ -> !(L kernelFlattened channels) -- The last kernel update (or momentum)

60+ -> Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns

61+

62+data Deconvolution' :: Nat -- Number of channels, for the first layer this could be RGB for instance.

63+ -> Nat -- Number of filters, this is the number of channels output by the layer.

64+ -> Nat -- The number of rows in the kernel filter

65+ -> Nat -- The number of column in the kernel filter

66+ -> Nat -- The row stride of the Deconvolution filter

67+ -> Nat -- The columns stride of the Deconvolution filter

68+ -> * where

69+ Deconvolution' :: ( KnownNat channels

70+ , KnownNat filters

71+ , KnownNat kernelRows

72+ , KnownNat kernelColumns

73+ , KnownNat strideRows

74+ , KnownNat strideColumns

75+ , KnownNat kernelFlattened

76+ , kernelFlattened ~ (kernelRows * kernelColumns * filters))

77+ => !(L kernelFlattened channels) -- The kernel filter gradient

78+ -> Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns

79+

80+instance Show (Deconvolution c f k k' s s') where

81+ show (Deconvolution a _) = renderConv a

82+ where

83+ renderConv mm =

84+ let m = extract mm

85+ ky = fromIntegral $ natVal (Proxy :: Proxy k)

86+ rs = LA.toColumns m

87+ ms = map (take ky) $ toLists . reshape ky <$> rs

88+

89+ render n' | n' <= 0.2 = ' '

90+ | n' <= 0.4 = '.'

91+ | n' <= 0.6 = '-'

92+ | n' <= 0.8 = '='

93+ | otherwise = '#'

94+

95+ px = (fmap . fmap . fmap) render ms

96+ in unlines $ foldl1 (zipWith (\a' b' -> a' ++ " | " ++ b')) $ px

97+

98+randomDeconvolution :: ( MonadRandom m

99+ , KnownNat channels

100+ , KnownNat filters

101+ , KnownNat kernelRows

102+ , KnownNat kernelColumns

103+ , KnownNat strideRows

104+ , KnownNat strideColumns

105+ , KnownNat kernelFlattened

106+ , kernelFlattened ~ (kernelRows * kernelColumns * filters))

107+ => m (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns)

108+randomDeconvolution = do

109+ s <- getRandom

110+ let wN = uniformSample s (-1) 1

111+ mm = konst 0

112+ return $ Deconvolution wN mm

113+

114+instance ( KnownNat channels

115+ , KnownNat filters

116+ , KnownNat kernelRows

117+ , KnownNat kernelColumns

118+ , KnownNat strideRows

119+ , KnownNat strideColumns

120+ , KnownNat (kernelRows * kernelColumns * filters)

121+ ) => UpdateLayer (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where

122+ type Gradient (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) = (Deconvolution' channels filters kernelRows kernelCols strideRows strideCols)

123+ runUpdate LearningParameters {..} (Deconvolution oldKernel oldMomentum) (Deconvolution' kernelGradient) =

124+ let (newKernel, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldKernel kernelGradient oldMomentum

125+ in Deconvolution newKernel newMomentum

126+

127+ createRandom = randomDeconvolution

128+

129+instance ( KnownNat channels

130+ , KnownNat filters

131+ , KnownNat kernelRows

132+ , KnownNat kernelColumns

133+ , KnownNat strideRows

134+ , KnownNat strideColumns

135+ , KnownNat (kernelRows * kernelColumns * filters)

136+ ) => Serialize (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where

137+ put (Deconvolution w _) = putListOf put . toList . flatten . extract $ w

138+ get = do

139+ let f = fromIntegral $ natVal (Proxy :: Proxy channels)

140+ wN <- maybe (fail "Vector of incorrect size") return . create . reshape f . LA.fromList =<< getListOf get

141+ let mm = konst 0

142+ return $ Deconvolution wN mm

143+

144+-- | A two dimentional image may have a Deconvolution filter applied to it

145+instance ( KnownNat kernelRows

146+ , KnownNat kernelCols

147+ , KnownNat filters

148+ , KnownNat strideRows

149+ , KnownNat strideCols

150+ , KnownNat inputRows

151+ , KnownNat inputCols

152+ , KnownNat outputRows

153+ , KnownNat outputCols

154+ , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)

155+ , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)

156+ , KnownNat (kernelRows * kernelCols * filters)

157+ , KnownNat (outputRows * filters)

158+ ) => Layer (Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where

159+ type Tape (Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols 1)

160+ runForwards c (S2D input) =

161+ runForwards c (S3D input :: S ('D3 inputRows inputCols 1))

162+

163+ runBackwards c tape grads =

164+ case runBackwards c tape grads of

165+ (c', S3D back :: S ('D3 inputRows inputCols 1)) -> (c', S2D back)

166+

167+-- | A two dimentional image may have a Deconvolution filter applied to it

168+instance ( KnownNat kernelRows

169+ , KnownNat kernelCols

170+ , KnownNat strideRows

171+ , KnownNat strideCols

172+ , KnownNat inputRows

173+ , KnownNat inputCols

174+ , KnownNat outputRows

175+ , KnownNat outputCols

176+ , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)

177+ , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)

178+ , KnownNat (kernelRows * kernelCols * 1)

179+ , KnownNat (outputRows * 1)

180+ ) => Layer (Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) where

181+ type Tape (Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols 1)

182+ runForwards c (S2D input) =

183+ case runForwards c (S3D input :: S ('D3 inputRows inputCols 1)) of

184+ (tps, S3D fore :: S ('D3 outputRows outputCols 1)) -> (tps, S2D fore)

185+

186+ runBackwards c tape (S2D grads) =

187+ case runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1)) of

188+ (c', S3D back :: S ('D3 inputRows inputCols 1)) -> (c', S2D back)

189+

190+-- | A two dimentional image may have a Deconvolution filter applied to it

191+instance ( KnownNat kernelRows

192+ , KnownNat kernelCols

193+ , KnownNat strideRows

194+ , KnownNat strideCols

195+ , KnownNat inputRows

196+ , KnownNat inputCols

197+ , KnownNat outputRows

198+ , KnownNat outputCols

199+ , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)

200+ , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)

201+ , KnownNat (kernelRows * kernelCols * 1)

202+ , KnownNat (outputRows * 1)

203+ , KnownNat channels

204+ ) => Layer (Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) where

205+ type Tape (Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols channels)

206+ runForwards c input =

207+ case runForwards c input of

208+ (tps, S3D fore :: S ('D3 outputRows outputCols 1)) -> (tps, S2D fore)

209+

210+ runBackwards c tape (S2D grads) =

211+ runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1))

212+

213+-- | A three dimensional image (or 2d with many channels) can have

214+-- an appropriately sized Deconvolution filter run across it.

215+instance ( KnownNat kernelRows

216+ , KnownNat kernelCols

217+ , KnownNat filters

218+ , KnownNat strideRows

219+ , KnownNat strideCols

220+ , KnownNat inputRows

221+ , KnownNat inputCols

222+ , KnownNat outputRows

223+ , KnownNat outputCols

224+ , KnownNat channels

225+ , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)

226+ , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)

227+ , KnownNat (kernelRows * kernelCols * filters)

228+ , KnownNat (outputRows * filters)

229+ ) => Layer (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where

230+

231+ type Tape (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)

232+

233+ runForwards (Deconvolution kernel _) (S3D input) =

234+ let ex = extract input

235+ ek = extract kernel

236+ ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

237+ iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

238+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

239+ ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

240+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

241+ sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

242+ ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

243+ oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

244+

245+ c = vid2col 1 1 1 1 ix iy ex

246+

247+ mt = c LA.<> tr ek

248+

249+ r = col2vid kx ky sx sy ox oy mt

250+ rs = fromJust . create $ r

251+ in (S3D input, S3D rs)

252+ runBackwards (Deconvolution kernel _) (S3D input) (S3D dEdy) =

253+ let ex = extract input

254+ ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

255+ iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

256+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

257+ ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

258+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

259+ sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

260+ ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

261+ oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

262+

263+ c = vid2col 1 1 1 1 ix iy ex

264+

265+ eo = extract dEdy

266+ ek = extract kernel

267+

268+ vs = vid2col kx ky sx sy ox oy eo

269+

270+ kN = fromJust . create . tr $ tr c LA.<> vs

271+

272+ dW = vs LA.<> ek

273+

274+ xW = col2vid 1 1 1 1 ix iy dW

275+ in (Deconvolution' kN, S3D . fromJust . create $ xW)

src/Grenade/Layers/Inception.hs+7−2

@@ -19,6 +19,8 @@ complex multiconvolution size networks.

19-}

20module Grenade.Layers.Inception (

21 Inception

22+ , InceptionMini

23+ , Resnet

22 ) where

24 ) where

24import GHC.TypeLits

26import GHC.TypeLits

@@ -27,6 +29,8 @@ import Grenade.Core

27import Grenade.Layers.Convolution

29import Grenade.Layers.Convolution

28import Grenade.Layers.Pad

30import Grenade.Layers.Pad

29import Grenade.Layers.Concat

31import Grenade.Layers.Concat

32+import Grenade.Layers.Merge

33+import Grenade.Layers.Trivial

31-- | Type of an inception layer.

35-- | Type of an inception layer.

32--

36--

@@ -41,10 +45,10 @@ import Grenade.Layers.Concat

41-- The network get padded effectively before each convolution filters

45-- The network get padded effectively before each convolution filters

42-- such that the output dimension is the same x and y as the input.

46-- such that the output dimension is the same x and y as the input.

43type Inception rows cols channels chx chy chz

47type Inception rows cols channels chx chy chz

44− = Network '[ Concat ('D3 rows cols (chx + chy)) (InceptionS rows cols channels chx chy) ('D3 rows cols chz) (Inception7x7 rows cols channels chz) ]

48+ = Network '[ Concat ('D3 rows cols (chx + chy)) (InceptionMini rows cols channels chx chy) ('D3 rows cols chz) (Inception7x7 rows cols channels chz) ]

45 '[ 'D3 rows cols channels, 'D3 rows cols (chx + chy + chz) ]

49 '[ 'D3 rows cols channels, 'D3 rows cols (chx + chy + chz) ]

47−type InceptionS rows cols channels chx chy

51+type InceptionMini rows cols channels chx chy

48 = Network '[ Concat ('D3 rows cols chx) (Inception3x3 rows cols channels chx) ('D3 rows cols chy) (Inception5x5 rows cols channels chy) ]

52 = Network '[ Concat ('D3 rows cols chx) (Inception3x3 rows cols channels chx) ('D3 rows cols chy) (Inception5x5 rows cols channels chy) ]

49 '[ 'D3 rows cols channels, 'D3 rows cols (chx + chy) ]

53 '[ 'D3 rows cols channels, 'D3 rows cols (chx + chy) ]

@@ -60,3 +64,4 @@ type Inception7x7 rows cols channels chx

60 = Network '[ Pad 3 3 3 3, Convolution channels chx 7 7 1 1 ]

64 = Network '[ Pad 3 3 3 3, Convolution channels chx 7 7 1 1 ]

61 '[ 'D3 rows cols channels, 'D3 (rows + 6) (cols + 6) channels, 'D3 rows cols chx ]

65 '[ 'D3 rows cols channels, 'D3 (rows + 6) (cols + 6) channels, 'D3 rows cols chx ]

67+type Resnet branch = Merge Trivial branch