eb179d0...master · grenade

.gitignore+3−1

@@ -1,4 +1,6 @@

1+cabal.project.local

12.cabal-sandbox/

23cabal.sandbox.config

34dist/

4−

5+dist-newstyle/

6+.stack-work/

.gitmodulesdeleted−15

@@ -1,15 +0,0 @@

1−[submodule "lib/disorder"]

2− path = lib/disorder

3− url = https://github.com/ambiata/disorder.hs

4−[submodule "lib/x"]

5− path = lib/x

6− url = https://github.com/ambiata/x.git

7−[submodule "lib/p"]

8− path = lib/p

9− url = https://github.com/ambiata/p

10−[submodule "lib/disorder.hs"]

11− path = lib/disorder.hs

12− url = https://github.com/ambiata/disorder.hs.git

13−[submodule "lib/hmatrix"]

14− path = lib/hmatrix

15− url = https://github.com/albertoruiz/hmatrix.git

.travis.ymlnew file+31

@@ -0,0 +1,31 @@

1+# NB: don't set `language: haskell` here

2+

3+# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.

4+env:

5+ - GHCVER=8.0.2

6+ - GHCVER=8.2.2

7+ - GHCVER=8.4.4

8+ - GHCVER=8.6.5

9+ - GHCVER=8.8.3

10+ - GHCVER=8.10.1

11+

12+# Note: the distinction between `before_install` and `install` is not important.

13+before_install:

14+ - travis_retry sudo add-apt-repository -y ppa:hvr/ghc

15+ - travis_retry sudo apt-get update

16+ - travis_retry sudo apt-get install cabal-install-3.2 ghc-$GHCVER libblas-dev liblapack-dev

17+ - export PATH=/opt/cabal/bin:/opt/ghc/$GHCVER/bin:$PATH

18+

19+install:

20+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"

21+ - travis_retry cabal-3.2 update

22+

23+notifications:

24+ email: false

25+

26+# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.

27+script:

28+ - cabal-3.2 configure --enable-tests

29+ - cabal-3.2 build all

30+ - cabal-3.2 test --test-show-details=direct -j1

31+

LICENSE+1−1

@@ -1,4 +1,4 @@

22All rights reserved.

33

44Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

README.md+144−25

@@ -1,6 +1,11 @@

11Grenade

22=======

33

4+[![Build Status](https://api.travis-ci.org/HuwCampbell/grenade.svg?branch=master)](https://travis-ci.org/HuwCampbell/grenade)

5+[![Hackage page (downloads and API reference)][hackage-png]][hackage]

6+[![Hackage-Deps][hackage-deps-png]][hackage-deps]

7+

8+

49```

510First shalt thou take out the Holy Pin, then shalt thou count to three, no more, no less.

611Three shall be the number thou shalt count, and the number of the counting shall be three.

@@ -10,34 +15,139 @@ Five is right out.

1015

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

1217

13−Grenade is a dependently typed, practical, and pretty quick neural network library for concise and precise

14−specifications of complex networks in Haskell.

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

19+for concise and precise specifications of complex networks in Haskell.

1520

16−As an example, a network which can achieve less than 1.5% error on MNIST can be specified and

17−initialised with random weights in a few lines of code with

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

22+specified and initialised with random weights in a few lines of code with

1823```haskell

19−randomMnist :: MonadRandom m

20− => m (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, FlattenLayer, Relu, FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]

21− '[ '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 10, 'D1 10])

24+type MNIST

25+ = Network

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

27+ , Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Reshape, Relu

28+ , FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]

29+ '[ 'D2 28 28, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10

30+ , 'D3 8 8 16, 'D3 4 4 16, 'D1 256, 'D1 256

31+ , 'D1 80, 'D1 80, 'D1 10, 'D1 10]

32+

33+randomMnist :: MonadRandom m => m MNIST

2234randomMnist = randomNetwork

2335```

2436

25−The network can be thought of as a heterogeneous list of layers, and its type signature includes a type

26−level list of the shapes of the data passed between the layers of the network.

37+And that's it. Because the types are so rich, there's no specific term level code

38+required to construct this network; although it is of course possible and

39+easy to construct and deconstruct the networks and layers explicitly oneself.

40+

41+If recurrent neural networks are more your style, you can try defining something

42+["unreasonably effective"](http://karpathy.github.io/2015/05/21/rnn-effectiveness/)

43+with

44+```haskell

45+type Shakespeare

46+ = RecurrentNetwork

47+ '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyConnected 40 40), F Logit]

48+ '[ 'D1 40, 'D1 80, 'D1 40, 'D1 40, 'D1 40 ]

49+```

50+

51+Design

52+------

53+

54+Networks in Grenade can be thought of as a heterogeneous lists of layers, where

55+their type includes not only the layers of the network, but also the shapes of

56+data that are passed between the layers.

57+

58+The definition of a network is surprisingly simple:

59+```haskell

60+data Network :: [*] -> [Shape] -> * where

61+ NNil :: SingI i

62+ => Network '[] '[i]

63+

64+ (:~>) :: (SingI i, SingI h, Layer x i h)

65+ => !x

66+ -> !(Network xs (h ': hs))

67+ -> Network (x ': xs) (i ': h ': hs)

68+```

69+

70+The `Layer x i o` constraint ensures that the layer `x` can sensibly perform a

71+transformation between the input and output shapes `i` and `o`.

72+

73+The lifted data kind `Shape` defines our 1, 2, and 3 dimension types, used to

74+declare what shape of data is passed between the layers.

75+

76+In the MNIST example above, the input layer can be seen to be a two dimensional

77+(`D2`), image with 28 by 28 pixels. When the first *Convolution* layer runs, it

78+outputs a three dimensional (`D3`) 24x24x10 image. The last item in the list is

79+one dimensional (`D1`) with 10 values, representing the categories of the MNIST

80+data.

81+

82+Usage

83+-----

84+

85+To perform back propagation, one can call the eponymous function

86+```haskell

87+backPropagate :: forall shapes layers.

88+ Network layers shapes -> S (Head shapes) -> S (Last shapes) -> Gradients layers

89+```

90+which takes a network, appropriate input and target data, and returns the

91+back propagated gradients for the network. The shapes of the gradients are

92+appropriate for each layer, and may be trivial for layers like `Relu` which

93+have no learnable parameters.

2794

28−In the above example, the input layer can be seen to be a two dimensional (`D2`) image with 28 by 28 pixels.

29−The last item in the list is one dimensional (`D1`) with 10 values, representing the categories of the mnist data.

95+The gradients however can always be applied, yielding a new (hopefully better)

96+layer with

97+```haskell

98+applyUpdate :: LearningParameters -> Network ls ss -> Gradients ls -> Network ls ss

99+```

30100

31−Layers in Grenade are represented as Haskell classes, so creating one's own is easy in downstream code. If the shapes

32−of a network are not specified correctly and a layer can not sensibly perform the operation between two shapes, then

101+Layers in Grenade are represented as Haskell classes, so creating one's own is

102+easy in downstream code. If the shapes of a network are not specified correctly

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

33104it will result in a compile time error.

34105

106+Composition

107+-----------

108+

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

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

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

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

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

114+write any Network which can be expressed as a

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

116+

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

118+```haskell

119+type Residual net = Merge Trivial net

120+```

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

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

123+and merge the original image with the output.

124+

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

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

127+as inception style convolutions.

128+

129+Generative Adversarial Networks

130+-------------------------------

131+

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

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

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

135+training function in 10 lines of code.

136+

137+Layer Zoo

138+---------

139+

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

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

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

143+elu, tanh, and fully connected.

35144

36145Build Instructions

37146------------------

38−Grenade currently only builds with the [mafia](https://github.com/ambiata/mafia) scipt that is located in the

39−repository. You will also need the `lapack` and `blas` libraries and development tools. Once you have all

40−that, Grenade can be build using:

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

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

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

150+build using:

41151

42152```

43153./mafia build

@@ -49,25 +159,34 @@ and the tests run using:

49159./mafia test

50160```

51161

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

53−

162+Grenade builds with ghc 7.10, 8.0, 8.2 and 8.4.

54163

55164Thanks

56165------

57−Writing a library like this has been on my mind for a while now, but a big shout out must go to [Justin Le](https://github.com/mstksg), whose

58−[dependently typed fully connected network](https://blog.jle.im/entry/practical-dependent-types-in-haskell-1.html) inspired me to get cracking, gave many ideas for the type level tools I

166+Writing a library like this has been on my mind for a while now, but a big shout

167+out must go to [Justin Le](https://github.com/mstksg), whose

168+[dependently typed fully connected network](https://blog.jle.im/entry/practical-dependent-types-in-haskell-1.html)

169+inspired me to get cracking, gave many ideas for the type level tools I

59170needed, and was a great starting point for writing this library.

60171

61172Performance

62173-----------

63−Grenade is backed by hmatrix and blas, and uses a pretty clever convolution trick popularised by Caffe, which

64−is surprisingly effective and fast. So for many small scale problems it should be sufficient.

174+Grenade is backed by hmatrix, BLAS, and LAPACK, with critical functions optimised

175+in C. Using the im2col trick popularised by Caffe, it should be sufficient for

176+many problems.

65177

66−That said, it's currently stuck on a single core and doesn't hit up the GPU, so there's a fair bit of performance

67−sitting there begging.

178+Being purely functional, it should also be easy to run batches in parallel, which

179+would be appropriate for larger networks, my current examples however are single

180+threaded.

68181

69−Training 15 generations over Kaggle's mnist training data took a few hours.

182+Training 15 generations over Kaggle's 41000 sample MNIST training set on a single

183+core took around 12 minutes, achieving 1.5% error rate on a 1000 sample holdout set.

70184

71185Contributing

72186------------

73187Contributions are welcome.

188+

189+ [hackage]: http://hackage.haskell.org/package/grenade

190+ [hackage-png]: http://img.shields.io/hackage/v/grenade.svg

191+ [hackage-deps]: http://packdeps.haskellers.com/reverse/grenade

192+ [hackage-deps-png]: https://img.shields.io/hackage-deps/v/grenade.svg

_config.ymlnew file+1

@@ -0,0 +1 @@

1+theme: jekyll-theme-minimal

bench/bench-lstm.hsnew file+30

@@ -0,0 +1,30 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+import Criterion.Main

5+

6+import Grenade

7+import Grenade.Recurrent

8+

9+main :: IO ()

10+main = do

11+ input40 :: S ('D1 40) <- randomOfShape

12+ lstm :: RecNet <- randomRecurrent

13+

14+ defaultMain [

15+ bgroup "train" [ bench "one-time-step" $ whnf (nfT2 . trainRecurrent lp lstm 0) [(input40, Just input40)]

16+ , bench "ten-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm 0) $ replicate 10 (input40, Just input40)

17+ , bench "fifty-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm 0) $ replicate 50 (input40, Just input40)

18+ ]

19+ ]

20+

21+nfT2 :: (a, b) -> (a, b)

22+nfT2 (!a, !b) = (a, b)

23+

24+

25+type R = Recurrent

26+type RecNet = RecurrentNetwork '[ R (LSTM 40 512), R (LSTM 512 40) ]

27+ '[ 'D1 40, 'D1 512, 'D1 40 ]

28+

29+lp :: LearningParameters

30+lp = LearningParameters 0.1 0 0

bench/bench.hsnew file+55

@@ -0,0 +1,55 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+import Criterion.Main

4+

5+import Grenade

6+

7+import Grenade.Layers.Internal.Convolution

8+import Grenade.Layers.Internal.Pooling

9+

10+import Numeric.LinearAlgebra

11+

12+main :: IO ()

13+main = do

14+ x :: S ('D2 60 60 ) <- randomOfShape

15+ y :: S ('D3 60 60 1) <- randomOfShape

16+

17+ defaultMain [

18+ bgroup "im2col" [ bench "im2col 3x4" $ whnf (im2col 2 2 1 1) ((3><4) [1..])

19+ , bench "im2col 28x28" $ whnf (im2col 5 5 1 1) ((28><28) [1..])

20+ , bench "im2col 100x100" $ whnf (im2col 10 10 1 1) ((100><100) [1..])

21+ ]

22+ , bgroup "col2im" [ bench "col2im 3x4" $ whnf (col2im 2 2 1 1 3 4) ((6><4) [1..])

23+ , bench "col2im 28x28" $ whnf (col2im 5 5 1 1 28 28) ((576><25) [1..])

24+ , bench "col2im 100x100" $ whnf (col2im 10 10 1 1 100 100) ((8281><100) [1..])

25+ ]

26+ , bgroup "poolfw" [ bench "poolforwards 3x4" $ whnf (poolForward 1 3 4 2 2 1 1) ((3><4) [1..])

27+ , bench "poolforwards 28x28" $ whnf (poolForward 1 28 28 5 5 1 1) ((28><28) [1..])

28+ , bench "poolforwards 100x100" $ whnf (poolForward 1 100 100 10 10 1 1) ((100><100) [1..])

29+ ]

30+ , bgroup "poolbw" [ bench "poolbackwards 3x4" $ whnf (poolBackward 1 3 4 2 2 1 1 ((3><4) [1..])) ((2><3) [1..])

31+ , bench "poolbackwards 28x28" $ whnf (poolBackward 1 28 28 5 5 1 1 ((28><28) [1..])) ((24><24) [1..])

32+ , bench "poolbackwards 100x100" $ whnf (poolBackward 1 100 100 10 10 1 1 ((100><100) [1..])) ((91><91) [1..])

33+ ]

34+ , bgroup "padcrop" [ bench "pad 2D 60x60" $ whnf (testRun2D Pad) x

35+ , bench "pad 3D 60x60" $ whnf (testRun3D Pad) y

36+ , bench "crop 2D 60x60" $ whnf (testRun2D' Crop) x

37+ , bench "crop 3D 60x60" $ whnf (testRun3D' Crop) y

38+ ]

39+ ]

40+

41+

42+testRun2D :: Pad 1 1 1 1 -> S ('D2 60 60) -> S ('D2 62 62)

43+testRun2D = snd ... runForwards

44+

45+testRun3D :: Pad 1 1 1 1 -> S ('D3 60 60 1) -> S ('D3 62 62 1)

46+testRun3D = snd ... runForwards

47+

48+testRun2D' :: Crop 1 1 1 1 -> S ('D2 60 60) -> S ('D2 58 58)

49+testRun2D' = snd ... runForwards

50+

51+testRun3D' :: Crop 1 1 1 1 -> S ('D3 60 60 1) -> S ('D3 58 58 1)

52+testRun3D' = snd ... runForwards

53+

54+(...) :: (a -> b) -> (c -> d -> a) -> c -> d -> b

55+(...) = (.) . (.)

cbits/gradient_descent.cnew file+13

@@ -0,0 +1,13 @@

1+#include "gradient_descent.h"

2+

3+void descend_cpu(int len, double rate, double momentum, double regulariser,

4+ const double* weights,

5+ const double* gradient,

6+ const double* last,

7+ double* outputWeights, double* outputMomentum) {

8+

9+ for (int i = 0; i < len; i++) {

10+ outputMomentum[i] = momentum * last[i] - rate * gradient[i];

11+ outputWeights[i] = weights[i] + outputMomentum[i] - (rate * regulariser) * weights[i];

12+ }

13+}

cbits/gradient_descent.hnew file+9

@@ -0,0 +1,9 @@

1+#include <stdio.h>

2+#include <stdint.h>

3+

4+void descend_cpu(int len, double rate, double momentum, double regulariser,

5+ const double* weights,

6+ const double* gradient,

7+ const double* last,

8+ double* outputWeights, double* outputMomentum);

9+

cbits/im2col.cnew file+128

@@ -0,0 +1,128 @@

1+#include "im2col.h"

2+

3+void im2col_cpu(const double* data_im, const int channels,

4+ const int height, const int width, const int kernel_h, const int kernel_w,

5+ const int stride_h, const int stride_w,

6+ double* data_col) {

7+

8+ const int channel_size = height * width;

9+

10+ for (int fitting_height = 0; fitting_height <= (height - kernel_h); fitting_height += stride_h) {

11+ for (int fitting_width = 0; fitting_width <= (width - kernel_w); fitting_width += stride_w) {

12+ for (int channel = 0; channel < channels; channel++) {

13+ for (int kernel_row = 0; kernel_row < kernel_h; kernel_row++) {

14+ for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {

15+ int input_row = fitting_height + kernel_row;

16+ int input_col = fitting_width + kernel_col;

17+ *(data_col++) = data_im[input_row * width + input_col + channel_size * channel];

18+ }

19+ }

20+ }

21+ }

22+ }

23+}

24+

25+void col2im_cpu(const double* data_col, const int channels,

26+ const int height, const int width, const int kernel_h, const int kernel_w,

27+ const int stride_h, const int stride_w,

28+ double* data_im) {

29+

30+ memset(data_im, 0, height * width * channels * sizeof(double));

31+

32+ const int channel_size = height * width;

33+

34+ for (int fitting_height = 0; fitting_height <= (height - kernel_h); fitting_height += stride_h) {

35+ for (int fitting_width = 0; fitting_width <= (width - kernel_w); fitting_width += stride_w) {

36+ for (int channel = 0; channel < channels; channel++) {

37+ for (int kernel_row = 0; kernel_row < kernel_h; kernel_row++) {

38+ for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {

39+ int input_row = fitting_height + kernel_row;

40+ int input_col = fitting_width + kernel_col;

41+ data_im[input_row * width + input_col + channel_size * channel] += *(data_col++);

42+ }

43+ }

44+ }

45+ }

46+ }

47+}

48+

49+inline double max ( double a, double b ) { return a > b ? a : b; }

50+

51+void pool_forwards_cpu(const double* data_im, const int channels,

52+ const int height, const int width, const int kernel_h, const int kernel_w,

53+ const int stride_h, const int stride_w,

54+ double* data_pooled) {

55+

56+ const int channel_size = height * width;

57+

58+ for (int channel = 0; channel < channels; channel++) {

59+ for (int fitting_height = 0; fitting_height <= (height - kernel_h); fitting_height += stride_h) {

60+ for (int fitting_width = 0; fitting_width <= (width - kernel_w); fitting_width += stride_w) {

61+ // Start with the value in 0,0

62+ int max_index = fitting_height * width + fitting_width + channel_size * channel;

63+ double max_value = data_im[max_index];

64+ // Initial row, skipping the corner we've done

65+ for (int kernel_col = 1; kernel_col < kernel_w; kernel_col++) {

66+ int input_row = fitting_height;

67+ int input_col = fitting_width + kernel_col;

68+ int data_index = input_row * width + input_col + channel_size * channel;

69+ double data_value = data_im[data_index];

70+ max_value = max ( max_value, data_value );

71+ }

72+ // The remaining rows

73+ for (int kernel_row = 1; kernel_row < kernel_h; kernel_row++) {

74+ for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {

75+ int input_row = fitting_height + kernel_row;

76+ int input_col = fitting_width + kernel_col;

77+ int data_index = input_row * width + input_col + channel_size * channel;

78+ double data_value = data_im[data_index];

79+ max_value = max ( max_value, data_value );

80+ }

81+ }

82+ *(data_pooled++) = max_value;

83+ }

84+ }

85+ }

86+}

87+

88+void pool_backwards_cpu(const double* data_im, const double* data_pooled,

89+ const int channels, const int height, const int width, const int kernel_h,

90+ const int kernel_w, const int stride_h, const int stride_w,

91+ double* data_backgrad ) {

92+

93+ memset(data_backgrad, 0, height * width * channels * sizeof(double));

94+

95+ const int channel_size = height * width;

96+

97+ for (int channel = 0; channel < channels; channel++) {

98+ for (int fitting_height = 0; fitting_height <= (height - kernel_h); fitting_height += stride_h) {

99+ for (int fitting_width = 0; fitting_width <= (width - kernel_w); fitting_width += stride_w) {

100+ int max_index = fitting_height * width + fitting_width + channel_size * channel;

101+ double max_value = data_im[max_index];

102+ for (int kernel_col = 1; kernel_col < kernel_w; kernel_col++) {

103+ int input_row = fitting_height;

104+ int input_col = fitting_width + kernel_col;

105+ int data_index = input_row * width + input_col + channel_size * channel;

106+ double data_value = data_im[data_index];

107+ if ( data_value > max_value ) {

108+ max_index = data_index;

109+ max_value = data_value;

110+ }

111+ }

112+ for (int kernel_row = 1; kernel_row < kernel_h; kernel_row++) {

113+ for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {

114+ int input_row = fitting_height + kernel_row;

115+ int input_col = fitting_width + kernel_col;

116+ int data_index = input_row * width + input_col + channel_size * channel;

117+ double data_value = data_im[data_index];

118+ if ( data_value > max_value ) {

119+ max_index = data_index;

120+ max_value = data_value;

121+ }

122+ }

123+ }

124+ data_backgrad[max_index] += *(data_pooled++);

125+ }

126+ }

127+ }

128+}

cbits/im2col.hnew file+23

@@ -0,0 +1,23 @@

1+#include <stdio.h>

2+#include <stdint.h>

3+#include <string.h>

4+

5+void im2col_cpu(const double* data_im, const int channels,

6+ const int height, const int width, const int kernel_h, const int kernel_w,

7+ const int stride_h, const int stride_w,

8+ double* data_col);

9+

10+void col2im_cpu(const double* data_col, const int channels,

11+ const int height, const int width, const int kernel_h, const int kernel_w,

12+ const int stride_h, const int stride_w,

13+ double* data_im);

14+

15+void pool_forwards_cpu(const double* data_im, const int channels,

16+ const int height, const int width, const int kernel_h, const int kernel_w,

17+ const int stride_h, const int stride_w,

18+ double* data_pooled);

19+

20+void pool_backwards_cpu(const double* data_im, const double* data_pooled,

21+ const int channels, const int height, const int width, const int kernel_h,

22+ const int kernel_w, const int stride_h, const int stride_w,

23+ double* data_backgrad );

cbits/pad.cnew file+39

@@ -0,0 +1,39 @@

1+#include "pad.h"

2+

3+void pad_cpu(double* data, const int channels,

4+ const int height, const int width, const int pad_left, const int pad_top,

5+ const int pad_right, const int pad_bottom,

6+ double* data_padded) {

7+

8+ const int pad_width = width + pad_left + pad_right;

9+ const int pad_height = height + pad_top + pad_bottom;

10+

11+ memset(data_padded, 0, pad_height * pad_width * channels * sizeof(double));

12+

13+ for (int channel = 0; channel < channels; channel++) {

14+ double* px = data_padded + (pad_width * pad_top + pad_left) + channel * (pad_width * pad_height);

15+ for (int y = 0; y < height; y++) {

16+ memcpy(px, data, sizeof(double) * width);

17+ px += pad_width;

18+ data += width;

19+ }

20+ }

21+}

22+

23+void crop_cpu(double* data, const int channels,

24+ const int height, const int width, const int crop_left, const int crop_top,

25+ const int crop_right, const int crop_bottom,

26+ double* data_cropped) {

27+

28+ const int crop_width = width + crop_left + crop_right;

29+ const int crop_height = height + crop_top + crop_bottom;

30+

31+ for (int channel = 0; channel < channels; channel++) {

32+ double* px = data + (crop_width * crop_top + crop_left) + channel * (crop_width * crop_height);

33+ for (int y = 0; y < height; y++) {

34+ memcpy(data_cropped, px, sizeof(double) * width);

35+ px += crop_width;

36+ data_cropped += width;

37+ }

38+ }

39+}

cbits/pad.hnew file+13

@@ -0,0 +1,13 @@

1+#include <stdio.h>

2+#include <stdint.h>

3+#include <string.h>

4+

5+void pad_cpu(double* data_im, const int channels,

6+ const int height, const int width, const int pad_left, const int pad_top,

7+ const int pad_right, const int pad_bottom,

8+ double* data_col);

9+

10+void crop_cpu(double* data_im, const int channels,

11+ const int height, const int width, const int crop_left, const int crop_top,

12+ const int crop_right, const int crop_bottom,

13+ double* data_col);

examples/LICENSEnew file+10

@@ -0,0 +1,10 @@

3+

4+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

5+

6+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.

7+

8+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.

9+

10+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

examples/grenade-examples.cabalnew file+109

@@ -0,0 +1,109 @@

1+name: grenade-examples

2+version: 0.0.1

3+license: BSD2

4+license-file: LICENSE

5+author: Huw Campbell <huw.campbell@gmail.com>

6+maintainer: Huw Campbell <huw.campbell@gmail.com>

8+synopsis: grenade-examples

9+category: System

10+cabal-version: >= 1.8

11+build-type: Simple

12+description: grenade-examples

13+

14+source-repository head

15+ type: git

16+ location: https://github.com/HuwCampbell/grenade.git

17+

18+library

19+

20+executable feedforward

21+ ghc-options: -Wall -threaded -O2

22+ main-is: main/feedforward.hs

23+ build-depends: base

24+ , grenade

25+ , attoparsec

26+ , bytestring

27+ , cereal

28+ , either

29+ , optparse-applicative >= 0.13 && < 0.18

30+ , text == 1.2.*

31+ , mtl >= 2.2.1 && < 2.3

32+ , hmatrix

33+ , transformers

34+ , singletons

35+ , semigroups

36+ , MonadRandom

37+

38+executable mnist

39+ ghc-options: -Wall -threaded -O2

40+ main-is: main/mnist.hs

41+ build-depends: base

42+ , grenade

43+ , attoparsec

44+ , either

45+ , optparse-applicative >= 0.13 && < 0.18

46+ , text == 1.2.*

47+ , mtl >= 2.2.1 && < 2.3

48+ , hmatrix >= 0.18 && < 0.21

49+ , transformers

50+ , semigroups

51+ , singletons

52+ , MonadRandom

53+ , vector

54+

55+executable gan-mnist

56+ ghc-options: -Wall -threaded -O2

57+ main-is: main/gan-mnist.hs

58+ build-depends: base

59+ , grenade

60+ , attoparsec

61+ , bytestring

62+ , cereal

63+ , either

64+ , optparse-applicative >= 0.13 && < 0.18

65+ , text == 1.2.*

66+ , mtl >= 2.2.1 && < 2.3

67+ , hmatrix >= 0.18 && < 0.21

68+ , transformers

69+ , semigroups

70+ , singletons

71+ , MonadRandom

72+ , vector

73+

74+executable recurrent

75+ ghc-options: -Wall -threaded -O2

76+ main-is: main/recurrent.hs

77+ build-depends: base

78+ , grenade

79+ , attoparsec

80+ , either

81+ , optparse-applicative >= 0.13 && < 0.18

82+ , text == 1.2.*

83+ , mtl >= 2.2.1 && < 2.3

84+ , hmatrix >= 0.18 && < 0.21

85+ , transformers

86+ , semigroups

87+ , singletons

88+ , MonadRandom

89+

90+executable shakespeare

91+ ghc-options: -Wall -threaded -O2

92+ main-is: main/shakespeare.hs

93+ build-depends: base

94+ , grenade

95+ , attoparsec

96+ , bytestring

97+ , cereal

98+ , either

99+ , optparse-applicative >= 0.13 && < 0.18

100+ , text == 1.2.*

101+ , mtl >= 2.2.1 && < 2.3

102+ , hmatrix >= 0.18 && < 0.21

103+ , transformers

104+ , semigroups

105+ , singletons

106+ , singletons-base

107+ , vector

108+ , MonadRandom

109+ , containers

examples/mafianew file+62

@@ -0,0 +1,62 @@

1+#!/bin/sh -eu

2+

3+: ${MAFIA_HOME:=$HOME/.mafia}

4+: ${MAFIA_VERSIONS:=$MAFIA_HOME/versions}

5+

6+latest_version () {

7+ git ls-remote https://github.com/haskell-mafia/mafia | grep refs/heads/master | cut -f 1

8+}

9+

10+build_version() {

11+ MAFIA_VERSION="$1"

12+ MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia')

13+ MAFIA_FILE=mafia-$MAFIA_VERSION

14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE

15+ mkdir -p $MAFIA_VERSIONS

16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

17+ git clone https://github.com/haskell-mafia/mafia $MAFIA_TEMP

18+ git --git-dir="$MAFIA_TEMP/.git" --work-tree="$MAFIA_TEMP" reset --hard $MAFIA_VERSION || {

19+ echo "mafia version ($MAFIA_VERSION) could not be found." >&2

20+ exit 1

21+ }

22+ (cd "$MAFIA_TEMP" && ./bin/bootstrap) || {

23+ got=$?

24+ echo "mafia version ($MAFIA_VERSION) could not be built." >&2

25+ exit "$got"

26+ }

27+ chmod +x "$MAFIA_TEMP/.cabal-sandbox/bin/mafia"

28+ # Ensure executable is on same file-system so final mv is atomic.

29+ mv -f "$MAFIA_TEMP/.cabal-sandbox/bin/mafia" "$MAFIA_PATH.$$"

30+ mv "$MAFIA_PATH.$$" "$MAFIA_PATH" || {

31+ rm -f "$MAFIA_PATH.$$"

32+ echo "INFO: mafia version ($MAFIA_VERSION) already exists not overiding," >&2

33+ echo "INFO: this is expected if parallel builds of the same version of" >&2

34+ echo "INFO: mafia occur, we are playing by first in, wins." >&2

35+ exit 0

36+ }

37+}

38+

39+enable_version() {

40+ if [ $# -eq 0 ]; then

41+ MAFIA_VERSION="$(latest_version)"

42+ echo "INFO: No explicit mafia version requested installing latest ($MAFIA_VERSION)." >&2

43+ else

44+ MAFIA_VERSION="$1"

45+ fi

46+ [ -x "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" ] || build_version "$MAFIA_VERSION"

47+ ln -sf "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" "$MAFIA_HOME/versions/mafia"

48+}

49+

50+exec_mafia () {

51+ [ -x "$MAFIA_HOME/versions/mafia" ] || enable_version

52+ "$MAFIA_HOME/versions/mafia" "$@"

53+}

54+

55+#

56+# The actual start of the script.....

57+#

58+

59+case "${1:-}" in

60+upgrade) shift; enable_version "$@" ;;

61+*) exec_mafia "$@"

62+esac

examples/main/feedforward.hsnew file+103

@@ -0,0 +1,103 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TupleSections #-}

7+{-# LANGUAGE TypeFamilies #-}

8+import Control.Monad

9+import Control.Monad.Random

10+import Data.List ( foldl' )

11+

12+import qualified Data.ByteString as B

13+import Data.Serialize

14+#if ! MIN_VERSION_base(4,13,0)

15+import Data.Semigroup ( (<>) )

16+#endif

17+import GHC.TypeLits

18+

19+import qualified Numeric.LinearAlgebra.Static as SA

20+

21+import Options.Applicative

22+

23+import Grenade

24+

25+

26+-- The defininition for our simple feed forward network.

27+-- The type level lists represents the layers and the shapes passed through the layers.

28+-- One can see that for this demonstration we are using relu, tanh and logit non-linear

29+-- units, which can be easily subsituted for each other in and out.

30+--

31+-- With around 100000 examples, this should show two clear circles which have been learned by the network.

32+type FFNet = Network '[ FullyConnected 2 40, Tanh, FullyConnected 40 10, Relu, FullyConnected 10 1, Logit ]

33+ '[ 'D1 2, 'D1 40, 'D1 40, 'D1 10, 'D1 10, 'D1 1, 'D1 1]

34+

35+randomNet :: MonadRandom m => m FFNet

36+randomNet = randomNetwork

37+

38+netTrain :: FFNet -> LearningParameters -> Int -> IO FFNet

39+netTrain net0 rate n = do

40+ inps <- replicateM n $ do

41+ s <- getRandom

42+ return $ S1D $ SA.randomVector s SA.Uniform * 2 - 1

43+ let outs = flip map inps $ \(S1D v) ->

44+ if v `inCircle` (fromRational 0.33, 0.33) || v `inCircle` (fromRational (-0.33), 0.33)

45+ then S1D $ fromRational 1

46+ else S1D $ fromRational 0

47+

48+ let trained = foldl' trainEach net0 (zip inps outs)

49+ return trained

50+

51+ where

52+ inCircle :: KnownNat n => SA.R n -> (SA.R n, Double) -> Bool

53+ v `inCircle` (o, r) = SA.norm_2 (v - o) <= r

54+ trainEach !network (i,o) = train rate network i o

55+

56+netLoad :: FilePath -> IO FFNet

57+netLoad modelPath = do

58+ modelData <- B.readFile modelPath

59+ either fail return $ runGet (get :: Get FFNet) modelData

60+

61+netScore :: FFNet -> IO ()

62+netScore network = do

63+ let testIns = [ [ (x,y) | x <- [0..50] ]

64+ | y <- [0..20] ]

65+ outMat = fmap (fmap (\(x,y) -> (render . normx) $ runNet network (S1D $ SA.vector [x / 25 - 1,y / 10 - 1]))) testIns

66+ putStrLn $ unlines outMat

67+

68+ where

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

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

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

72+ | n' <= 0.8 = '='

73+ | otherwise = '#'

74+

75+ normx :: S ('D1 1) -> Double

76+ normx (S1D r) = SA.mean r

77+

78+data FeedForwardOpts = FeedForwardOpts Int LearningParameters (Maybe FilePath) (Maybe FilePath)

79+

80+feedForward' :: Parser FeedForwardOpts

81+feedForward' =

82+ FeedForwardOpts <$> option auto (long "examples" <> short 'e' <> value 100000)

83+ <*> (LearningParameters

84+ <$> option auto (long "train_rate" <> short 'r' <> value 0.01)

85+ <*> option auto (long "momentum" <> value 0.9)

86+ <*> option auto (long "l2" <> value 0.0005)

87+ )

88+ <*> optional (strOption (long "load"))

89+ <*> optional (strOption (long "save"))

90+

91+main :: IO ()

92+main = do

93+ FeedForwardOpts examples rate load save <- execParser (info (feedForward' <**> helper) idm)

94+ net0 <- case load of

95+ Just loadFile -> netLoad loadFile

96+ Nothing -> randomNet

97+

98+ net <- netTrain net0 rate examples

99+ netScore net

100+

101+ case save of

102+ Just saveFile -> B.writeFile saveFile $ runPut (put net)

103+ Nothing -> return ()

examples/main/gan-mnist.hsnew file+185

@@ -0,0 +1,185 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE TupleSections #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE FlexibleContexts #-}

10+

11+-- This is a simple generative adversarial network to make pictures

12+-- of numbers similar to those in MNIST.

13+--

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

15+-- minutes it was producing examples like this:

16+--

17+-- --.

18+-- .=-.--..#=###

19+-- -##==#########.

20+-- #############-

21+-- -###-.=..-.-==

22+-- ###-

23+-- .###-

24+-- .####...==-.

25+-- -####=--.=##=

26+-- -##=- -##

27+-- =##

28+-- -##=

29+-- -###-

30+-- .####.

31+-- .#####.

32+-- ...---=#####-

33+-- .=#########. .

34+-- .#######=. .

35+-- . =-.

36+--

37+-- It's a 5!

38+--

39+import Control.Applicative

40+import Control.Monad

41+import Control.Monad.Random

42+import Control.Monad.Trans.Except

43+

44+import qualified Data.Attoparsec.Text as A

45+import qualified Data.ByteString as B

46+import Data.List ( foldl' )

47+#if ! MIN_VERSION_base(4,13,0)

48+import Data.Semigroup ( (<>) )

49+#endif

50+import Data.Serialize

51+import qualified Data.Text as T

52+import qualified Data.Text.IO as T

53+import qualified Data.Vector.Storable as V

54+

55+import qualified Numeric.LinearAlgebra.Static as SA

56+import Numeric.LinearAlgebra.Data ( toLists )

57+

58+import Options.Applicative

59+

60+import Grenade

61+import Grenade.Utils.OneHot

62+

63+type Discriminator =

64+ Network

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

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

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

68+ '[ 'D2 28 28

69+ , 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10

70+ , 'D3 8 8 16, 'D3 4 4 16, 'D3 4 4 16

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

72+

73+type Generator =

74+ Network

75+ '[ FullyConnected 80 256, Relu, Reshape

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

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

78+ '[ 'D1 80

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

80+ , 'D3 11 11 10, 'D3 11 11 10

81+ , 'D2 28 28, 'D2 28 28 ]

82+

83+randomDiscriminator :: MonadRandom m => m Discriminator

84+randomDiscriminator = randomNetwork

85+

86+randomGenerator :: MonadRandom m => m Generator

87+randomGenerator = randomNetwork

88+

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

90+trainExample rate discriminator generator realExample noiseSource

91+ = let (generatorTape, fakeExample) = runNetwork generator noiseSource

92+

93+ (discriminatorTapeReal, guessReal) = runNetwork discriminator realExample

94+ (discriminatorTapeFake, guessFake) = runNetwork discriminator fakeExample

95+

96+ (discriminator'real, _) = runGradient discriminator discriminatorTapeReal ( guessReal - 1 )

97+ (discriminator'fake, _) = runGradient discriminator discriminatorTapeFake guessFake

98+ (_, push) = runGradient discriminator discriminatorTapeFake ( guessFake - 1)

99+

100+ (generator', _) = runGradient generator generatorTape push

101+

102+ newDiscriminator = foldl' (applyUpdate rate { learningRegulariser = learningRegulariser rate * 10}) discriminator [ discriminator'real, discriminator'fake ]

103+ newGenerator = applyUpdate rate generator generator'

104+ in ( newDiscriminator, newGenerator )

105+

106+

107+ganTest :: (Discriminator, Generator) -> Int -> FilePath -> LearningParameters -> ExceptT String IO (Discriminator, Generator)

108+ganTest (discriminator0, generator0) iterations trainFile rate = do

109+ trainData <- fmap fst <$> readMNIST trainFile

110+

111+ lift $ foldM (runIteration trainData) ( discriminator0, generator0 ) [1..iterations]

112+

113+ where

114+

115+ showShape' :: S ('D2 a b) -> IO ()

116+ showShape' (S2D mm) = putStrLn $

117+ let m = SA.extract mm

118+ ms = toLists m

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

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

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

122+ | n' <= 0.8 = '='

123+ | otherwise = '#'

124+

125+ px = (fmap . fmap) render ms

126+ in unlines px

127+

128+ runIteration :: [S ('D2 28 28)] -> (Discriminator, Generator) -> Int -> IO (Discriminator, Generator)

129+ runIteration trainData ( !discriminator, !generator ) _ = do

130+ trained' <- foldM ( \(!discriminatorX, !generatorX ) realExample -> do

131+ fakeExample <- randomOfShape

132+ return $ trainExample rate discriminatorX generatorX realExample fakeExample

133+ ) ( discriminator, generator ) trainData

134+

135+

136+ showShape' . snd . runNetwork (snd trained') =<< randomOfShape

137+

138+ return trained'

139+

140+data GanOpts = GanOpts FilePath Int LearningParameters (Maybe FilePath) (Maybe FilePath)

141+

142+mnist' :: Parser GanOpts

143+mnist' = GanOpts <$> argument str (metavar "TRAIN")

144+ <*> option auto (long "iterations" <> short 'i' <> value 15)

145+ <*> (LearningParameters

146+ <$> option auto (long "train_rate" <> short 'r' <> value 0.01)

147+ <*> option auto (long "momentum" <> value 0.9)

148+ <*> option auto (long "l2" <> value 0.0005)

149+ )

150+ <*> optional (strOption (long "load"))

151+ <*> optional (strOption (long "save"))

152+

153+

154+main :: IO ()

155+main = do

156+ GanOpts mnist iter rate load save <- execParser (info (mnist' <**> helper) idm)

157+ putStrLn "Training stupidly simply GAN"

158+ nets0 <- case load of

159+ Just loadFile -> netLoad loadFile

160+ Nothing -> (,) <$> randomDiscriminator <*> randomGenerator

161+

162+ res <- runExceptT $ ganTest nets0 iter mnist rate

163+ case res of

164+ Right nets1 -> case save of

165+ Just saveFile -> B.writeFile saveFile $ runPut (put nets1)

166+ Nothing -> return ()

167+

168+ Left err -> putStrLn err

169+

170+readMNIST :: FilePath -> ExceptT String IO [(S ('D2 28 28), S ('D1 10))]

171+readMNIST mnist = ExceptT $ do

172+ mnistdata <- T.readFile mnist

173+ return $ traverse (A.parseOnly parseMNIST) (T.lines mnistdata)

174+

175+parseMNIST :: A.Parser (S ('D2 28 28), S ('D1 10))

176+parseMNIST = do

177+ Just lab <- oneHot <$> A.decimal

178+ pixels <- many (A.char ',' >> A.double)

179+ image <- maybe (fail "Parsed row was of an incorrect size") pure (fromStorable . V.fromList $ pixels)

180+ return (image, lab)

181+

182+netLoad :: FilePath -> IO (Discriminator, Generator)

183+netLoad modelPath = do

184+ modelData <- B.readFile modelPath

185+ either fail return $ runGet (get :: Get (Discriminator, Generator)) modelData

main/mnist.hs → examples/main/mnist.hsrenamed+44−14

@@ -1,4 +1,5 @@

11{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE ScopedTypeVariables #-}

45{-# LANGUAGE TypeOperators #-}

@@ -9,19 +10,34 @@

910import Control.Applicative

1011import Control.Monad

1112import Control.Monad.Random

12−import Control.Monad.Trans.Class

1313import Control.Monad.Trans.Except

1414

1515import qualified Data.Attoparsec.Text as A

16+import Data.List ( foldl' )

17+#if ! MIN_VERSION_base(4,13,0)

18+import Data.Semigroup ( (<>) )

19+#endif

20+

1621import qualified Data.Text as T

1722import qualified Data.Text.IO as T

23+import qualified Data.Vector.Storable as V

1824

19−import Numeric.LinearAlgebra (maxIndex)

25+import Numeric.LinearAlgebra ( maxIndex )

2026import qualified Numeric.LinearAlgebra.Static as SA

2127

2228import Options.Applicative

2329

2430import Grenade

31+import Grenade.Utils.OneHot

32+

33+-- It's logistic regression!

34+--

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

36+-- type.

37+type FL i o =

38+ Network

39+ '[ FullyConnected i o, Logit ]

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

2541

2642-- The definition of our convolutional neural network.

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

@@ -32,9 +48,23 @@ import Grenade

3248

3349-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,

3450-- this network should get down to about a 1.3% error rate.

35−randomMnist :: MonadRandom m

36− => m (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, FlattenLayer, Relu, FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]

37− '[ '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 10, 'D1 10])

51+--

52+-- /NOTE:/ This model is actually too complex for MNIST, and one should use the type given in the readme instead.

53+-- This one is just here to demonstrate Inception layers in use.

54+--

55+type MNIST =

56+ Network

57+ '[ Reshape,

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

59+ Pooling 2 2 2 2, Relu,

60+ 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,

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

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

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

64+ 'D3 12 12 18, 'D3 4 4 18, 'D3 4 4 18,

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

66+

67+randomMnist :: MonadRandom m => m MNIST

3868randomMnist = randomNetwork

3969

4070convTest :: Int -> FilePath -> FilePath -> LearningParameters -> ExceptT String IO ()

@@ -48,9 +78,9 @@ convTest iterations trainFile validateFile rate = do

4878 trainEach rate' !network (i, o) = train rate' network i o

4979

5080 runIteration trainRows validateRows net i = do

51− let trained' = foldl (trainEach ( rate { learningRate = learningRate rate * 0.9 ^ i} )) net trainRows

81+ let trained' = foldl' (trainEach ( rate { learningRate = learningRate rate * 0.9 ^ i} )) net trainRows

5282 let res = fmap (\(rowP,rowL) -> (rowL,) $ runNet trained' rowP) validateRows

53− let res' = fmap (\(S1D' label, S1D' prediction) -> (maxIndex (SA.extract label), maxIndex (SA.extract prediction))) res

83+ let res' = fmap (\(S1D label, S1D prediction) -> (maxIndex (SA.extract label), maxIndex (SA.extract prediction))) res

5484 print trained'

5585 putStrLn $ "Iteration " ++ show i ++ ": " ++ show (length (filter ((==) <$> fst <*> snd) res')) ++ " of " ++ show (length res')

5686 return trained'

@@ -60,7 +90,7 @@ data MnistOpts = MnistOpts FilePath FilePath Int LearningParameters

6090mnist' :: Parser MnistOpts

6191mnist' = MnistOpts <$> argument str (metavar "TRAIN")

6292 <*> argument str (metavar "VALIDATE")

63− <*> option auto (long "iterations" <> short 'i' <> value 10)

93+ <*> option auto (long "iterations" <> short 'i' <> value 15)

6494 <*> (LearningParameters

6595 <$> option auto (long "train_rate" <> short 'r' <> value 0.01)

6696 <*> option auto (long "momentum" <> value 0.9)

@@ -77,14 +107,14 @@ main = do

77107 Right () -> pure ()

78108 Left err -> putStrLn err

79109

80−readMNIST :: FilePath -> ExceptT String IO [(S' ('D2 28 28), S' ('D1 10))]

110+readMNIST :: FilePath -> ExceptT String IO [(S ('D2 28 28), S ('D1 10))]

81111readMNIST mnist = ExceptT $ do

82112 mnistdata <- T.readFile mnist

83113 return $ traverse (A.parseOnly parseMNIST) (T.lines mnistdata)

84114

85−parseMNIST :: A.Parser (S' ('D2 28 28), S' ('D1 10))

115+parseMNIST :: A.Parser (S ('D2 28 28), S ('D1 10))

86116parseMNIST = do

87− lab <- A.decimal

88− pixels <- many (A.char ',' >> A.double)

89− let lab' = replicate lab 0 ++ [1] ++ replicate (9 - lab) 0

90− return (S2D' $ SA.fromList pixels, S1D' $ SA.fromList lab')

117+ Just lab <- oneHot <$> A.decimal

118+ pixels <- many (A.char ',' >> A.double)

119+ image <- maybe (fail "Parsed row was of an incorrect size") pure (fromStorable . V.fromList $ pixels)

120+ return (image, lab)

examples/main/recurrent.hsnew file+93

@@ -0,0 +1,93 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TupleSections #-}

7+{-# LANGUAGE TypeFamilies #-}

8+

9+import Control.Monad ( foldM )

10+import Control.Monad.Random ( MonadRandom, getRandomR )

11+

12+#if MIN_VERSION_base(4,13,0)

13+import Data.List ( unfoldr )

14+#else

15+import Data.List ( cycle, unfoldr )

16+import Data.Semigroup ( (<>) )

17+#endif

18+

19+import qualified Numeric.LinearAlgebra.Static as SA

20+

21+import Options.Applicative

22+

23+import Grenade

24+import Grenade.Recurrent

25+

26+-- The defininition for our simple recurrent network.

27+-- This file just trains a network to generate a repeating sequence

28+-- of 0 0 1.

29+--

30+-- The F and R types are Tagging types to ensure that the runner and

31+-- creation function know how to treat the layers.

32+type R = Recurrent

33+

34+type RecNet = RecurrentNetwork '[ R (LSTM 1 1)]

35+ '[ 'D1 1, 'D1 1]

36+

37+type RecInput = RecurrentInputs '[ R (LSTM 1 1)]

38+

39+randomNet :: MonadRandom m => m RecNet

40+randomNet = randomRecurrent

41+

42+netTest :: MonadRandom m => RecNet -> RecInput -> LearningParameters -> Int -> m (RecNet, RecInput)

43+netTest net0 i0 rate iterations =

44+ foldM trainIteration (net0,i0) [1..iterations]

45+ where

46+ trainingCycle = cycle [c 0, c 0, c 1]

47+

48+ trainIteration (net, io) _ = do

49+ dropping <- getRandomR (0, 2)

50+ count <- getRandomR (5, 30)

51+ let t = drop dropping trainingCycle

52+ let example = ((,Nothing) <$> take count t) ++ [(t !! count, Just $ t !! (count + 1))]

53+ return $ trainEach net io example

54+

55+ trainEach !nt !io !ex = trainRecurrent rate nt io ex

56+

57+data FeedForwardOpts = FeedForwardOpts Int LearningParameters

58+

59+feedForward' :: Parser FeedForwardOpts

60+feedForward' = FeedForwardOpts <$> option auto (long "examples" <> short 'e' <> value 40000)

61+ <*> (LearningParameters

62+ <$> option auto (long "train_rate" <> short 'r' <> value 0.01)

63+ <*> option auto (long "momentum" <> value 0.9)

64+ <*> option auto (long "l2" <> value 0.0005)

65+ )

66+

67+generateRecurrent :: RecNet -> RecInput -> S ('D1 1) -> [Int]

68+generateRecurrent n s i =

69+ unfoldr go (s, i)

70+ where

71+ go (x, y) =

72+ do let (_, ns, o) = runRecurrent n x y

73+ o' = heat o

74+ Just (o', (ns, fromIntegral o'))

75+

76+ heat :: S ('D1 1) -> Int

77+ heat x = case x of

78+ (S1D v) -> round (SA.mean v)

79+

80+main :: IO ()

81+main = do

82+ FeedForwardOpts examples rate <- execParser (info (feedForward' <**> helper) idm)

83+ putStrLn "Training network..."

84+

85+ net0 <- randomNet

86+ (trained, bestInput) <- netTest net0 0 rate examples

87+

88+ let results = generateRecurrent trained bestInput (c 1)

89+

90+ print . take 50 . drop 100 $ results

91+

92+c :: Double -> S ('D1 1)

93+c = S1D . SA.konst

examples/main/shakespeare.hsnew file+187

@@ -0,0 +1,187 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TupleSections #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE LambdaCase #-}

9+

10+import Control.Monad.Random

11+import Control.Monad.Trans.Except

12+

13+import Data.Char ( isUpper, toUpper, toLower )

14+import Data.List ( foldl' )

15+import Data.Maybe ( fromMaybe )

16+

17+

18+import qualified Data.Vector as V

19+import Data.Vector ( Vector )

20+

21+import qualified Data.Map as M

22+

23+import qualified Data.ByteString as B

24+import Data.Serialize

25+

26+import GHC.TypeLits

27+

28+import Numeric.LinearAlgebra.Static ( konst )

29+

30+import Options.Applicative

31+

32+import Grenade

33+import Grenade.Recurrent

34+import Grenade.Utils.OneHot

35+

36+import System.IO.Unsafe ( unsafeInterleaveIO )

37+import Data.Proxy

38+import Prelude.Singletons

39+

40+-- The defininition for our natural language recurrent network.

41+-- This network is able to learn and generate simple words in

42+-- about an hour.

43+--

44+-- Grab the input from

45+-- https://raw.githubusercontent.com/karpathy/char-rnn/master/data/tinyshakespeare/input.txt

46+--

47+-- This is a first class recurrent net.

48+--

49+-- The F and R types are tagging types to ensure that the runner and

50+-- creation function know how to treat the layers.

51+--

52+-- As an example, here's a short sequence generated.

53+--

54+-- > KING RICHARD III:

55+-- > And as the heaven her his words, we the son, I show sand stape but the lament to shall were the sons with a strend

56+

57+type F = FeedForward

58+type R = Recurrent

59+

60+-- The definition of our network

61+type Shakespeare = RecurrentNetwork '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyConnected 40 40), F Logit]

62+ '[ 'D1 40, 'D1 80, 'D1 40, 'D1 40, 'D1 40 ]

63+

64+-- The definition of the "sideways" input, which the network is fed recurrently.

65+type Shakespearian = RecurrentInputs '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyConnected 40 40), F Logit]

66+

67+randomNet :: MonadRandom m => m Shakespeare

68+randomNet = randomRecurrent

69+

70+-- | Load the data files and prepare a map of characters to a compressed int representation.

71+loadShakespeare :: FilePath -> ExceptT String IO (Vector Int, M.Map Char Int, Vector Char)

72+loadShakespeare path = do

73+ contents <- lift $ readFile path

74+ let annotated = annotateCapitals contents

75+ (m,cs) <- ExceptT . return $ hotMap (Proxy :: Proxy 40) annotated

76+ hot <- ExceptT . return . note "Couldn't generate hot values" $ traverse (`M.lookup` m) annotated

77+ return (V.fromList hot, m, cs)

78+

79+trainSlice :: LearningParameters -> Shakespeare -> Shakespearian -> Vector Int -> Int -> Int -> (Shakespeare, Shakespearian)

80+trainSlice !lrate !net !recIns input offset size =

81+ let e = fmap (x . oneHot) . V.toList $ V.slice offset size input

82+ in case reverse e of

83+ (o : l : xs) ->

84+ let examples = reverse $ (l, Just o) : ((,Nothing) <$> xs)

85+ in trainRecurrent lrate net recIns examples

86+ _ -> error "Not enough input"

87+ where

88+ x = fromMaybe (error "Hot variable didn't fit.")

89+

90+runShakespeare :: ShakespeareOpts -> ExceptT String IO ()

91+runShakespeare opts = do

92+ (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare $ trainingFile opts

93+ (net0, i0) <- lift $

94+ case loadPath opts of

95+ Just loadFile -> netLoad loadFile

96+ Nothing -> (,0) <$> randomNet

97+

98+ (trained, bestInput) <- lift $ foldM (\(!net, !io) size -> do

99+ xs <- take (iterations opts `div` 10) <$> getRandomRs (0, length shakespeare - size - 1)

100+ let (!trained, !bestInput) = foldl' (\(!n, !i) offset -> trainSlice (rate opts) n i shakespeare offset size) (net, io) xs

101+ results <- take 1000 <$> generateParagraph trained bestInput (temperature opts) oneHotMap oneHotDictionary ( S1D $ konst 0)

102+ putStrLn ("TRAINING STEP WITH SIZE: " ++ show size)

103+ putStrLn (unAnnotateCapitals results)

104+ return (trained, bestInput)

105+ ) (net0, i0) $ replicate 10 (sequenceSize opts)

106+

107+ case savePath opts of

108+ Just saveFile -> lift . B.writeFile saveFile $ runPut (put trained >> put bestInput)

109+ Nothing -> return ()

110+

111+generateParagraph :: forall layers shapes n a. (Last shapes ~ 'D1 n, Head shapes ~ 'D1 n, KnownNat n, Ord a)

112+ => RecurrentNetwork layers shapes

113+ -> RecurrentInputs layers

114+ -> Double

115+ -> M.Map a Int

116+ -> Vector a

117+ -> S ('D1 n)

118+ -> IO [a]

119+generateParagraph n s temp hotmap hotdict =

120+ go s

121+ where

122+ go x y =

123+ do let (_, ns, o) = runRecurrent n x y

124+ un <- sample temp hotdict o

125+ Just re <- return $ makeHot hotmap un

126+ rest <- unsafeInterleaveIO $ go ns re

127+ return (un : rest)

128+

129+data ShakespeareOpts = ShakespeareOpts {

130+ trainingFile :: FilePath

131+ , iterations :: Int

132+ , rate :: LearningParameters

133+ , sequenceSize :: Int

134+ , temperature :: Double

135+ , loadPath :: Maybe FilePath

136+ , savePath :: Maybe FilePath

137+ }

138+

139+shakespeare' :: Parser ShakespeareOpts

140+shakespeare' = ShakespeareOpts <$> argument str (metavar "TRAIN")

141+ <*> option auto (long "examples" <> short 'e' <> value 1000000)

142+ <*> (LearningParameters

143+ <$> option auto (long "train_rate" <> short 'r' <> value 0.01)

144+ <*> option auto (long "momentum" <> value 0.95)

145+ <*> option auto (long "l2" <> value 0.000001)

146+ )

147+ <*> option auto (long "sequence-length" <> short 's' <> value 50)

148+ <*> option auto (long "temperature" <> short 't' <> value 0.4)

149+ <*> optional (strOption (long "load"))

150+ <*> optional (strOption (long "save"))

151+

152+main :: IO ()

153+main = do

154+ shopts <- execParser (info (shakespeare' <**> helper) idm)

155+ res <- runExceptT $ runShakespeare shopts

156+ case res of

157+ Right () -> pure ()

158+ Left err -> putStrLn err

159+

160+

161+netLoad :: FilePath -> IO (Shakespeare, Shakespearian)

162+netLoad modelPath = do

163+ modelData <- B.readFile modelPath

164+ either fail return $ runGet get modelData

165+

166+-- Replace capitals with an annotation and the lower case letter

167+-- http://fastml.com/one-weird-trick-for-training-char-rnns/

168+annotateCapitals :: String -> String

169+annotateCapitals (x : rest)

170+ | isUpper x

171+ = '^' : toLower x : annotateCapitals rest

172+ | otherwise

173+ = x : annotateCapitals rest

174+annotateCapitals []

175+ = []

176+

177+unAnnotateCapitals :: String -> String

178+unAnnotateCapitals ('^' : x : rest)

179+ = toUpper x : unAnnotateCapitals rest

180+unAnnotateCapitals (x : rest)

181+ = x : unAnnotateCapitals rest

182+unAnnotateCapitals []

183+ = []

184+

185+-- | Tag the 'Nothing' value of a 'Maybe'

186+note :: a -> Maybe b -> Either a b

187+note a = maybe (Left a) Right

framework/mafianew file+62

@@ -0,0 +1,62 @@

1+#!/bin/sh -eu

2+

3+: ${MAFIA_HOME:=$HOME/.mafia}

4+: ${MAFIA_VERSIONS:=$MAFIA_HOME/versions}

5+

6+latest_version () {

7+ git ls-remote https://github.com/haskell-mafia/mafia | grep refs/heads/master | cut -f 1

8+}

9+

10+build_version() {

11+ MAFIA_VERSION="$1"

12+ MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia')

13+ MAFIA_FILE=mafia-$MAFIA_VERSION

14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE

15+ mkdir -p $MAFIA_VERSIONS

16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

17+ git clone https://github.com/haskell-mafia/mafia $MAFIA_TEMP

18+ git --git-dir="$MAFIA_TEMP/.git" --work-tree="$MAFIA_TEMP" reset --hard $MAFIA_VERSION || {

19+ echo "mafia version ($MAFIA_VERSION) could not be found." >&2

20+ exit 1

21+ }

22+ (cd "$MAFIA_TEMP" && ./bin/bootstrap) || {

23+ got=$?

24+ echo "mafia version ($MAFIA_VERSION) could not be built." >&2

25+ exit "$got"

26+ }

27+ chmod +x "$MAFIA_TEMP/.cabal-sandbox/bin/mafia"

28+ # Ensure executable is on same file-system so final mv is atomic.

29+ mv -f "$MAFIA_TEMP/.cabal-sandbox/bin/mafia" "$MAFIA_PATH.$$"

30+ mv "$MAFIA_PATH.$$" "$MAFIA_PATH" || {

31+ rm -f "$MAFIA_PATH.$$"

32+ echo "INFO: mafia version ($MAFIA_VERSION) already exists not overiding," >&2

33+ echo "INFO: this is expected if parallel builds of the same version of" >&2

34+ echo "INFO: mafia occur, we are playing by first in, wins." >&2

35+ exit 0

36+ }

37+}

38+

39+enable_version() {

40+ if [ $# -eq 0 ]; then

41+ MAFIA_VERSION="$(latest_version)"

42+ echo "INFO: No explicit mafia version requested installing latest ($MAFIA_VERSION)." >&2

43+ else

44+ MAFIA_VERSION="$1"

45+ fi

46+ [ -x "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" ] || build_version "$MAFIA_VERSION"

47+ ln -sf "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" "$MAFIA_HOME/versions/mafia"

48+}

49+

50+exec_mafia () {

51+ [ -x "$MAFIA_HOME/versions/mafia" ] || enable_version

52+ "$MAFIA_HOME/versions/mafia" "$@"

53+}

54+

55+#

56+# The actual start of the script.....

57+#

58+

59+case "${1:-}" in

60+upgrade) shift; enable_version "$@" ;;

61+*) exec_mafia "$@"

62+esac

grenade.cabal+164−55

@@ -1,89 +1,126 @@

11name: grenade

2−version: 0.0.1

2+version: 0.1.0

33license: BSD2

4+license-file: LICENSE

45author: Huw Campbell <huw.campbell@gmail.com>

56maintainer: Huw Campbell <huw.campbell@gmail.com>

7−synopsis: grenade

8−category: System

9−cabal-version: >= 1.8

8+synopsis: Practical Deep Learning in Haskell

9+category: AI, Machine Learning

10+cabal-version: >= 1.10

1011build-type: Simple

11−description: grenade.

12+description:

13+ Grenade is a composable, dependently typed, practical, and fast

14+ recurrent neural network library for precise specifications and

15+ complex deep neural networks in Haskell.

16+ .

17+ Grenade provides an API for composing layers of a neural network

18+ into a sequence parallel graph in a type safe manner; running

19+ networks with reverse automatic differentiation to calculate their

20+ gradients; and applying gradient descent for learning.

21+ .

22+ Documentation and examples are available on github

23+ <https://github.com/HuwCampbell/grenade>.

24+

25+extra-source-files:

26+ README.md

27+ cbits/im2col.h

28+ cbits/im2col.c

29+ cbits/gradient_descent.h

30+ cbits/gradient_descent.c

31+ cbits/pad.h

32+ cbits/pad.c

33+

34+source-repository head

35+ type: git

36+ location: https://github.com/HuwCampbell/grenade.git

1237

1338library

1439 build-depends:

1540 base >= 4.8 && < 5

16− , bytestring == 0.10.*

17− , async

18− , either == 4.4.*

19− , exceptions == 0.8.*

20− , hmatrix

21− , MonadRandom

22− , mtl >= 2.2.1 && < 2.3

23− , parallel == 3.2.*

24− , primitive

25− , text == 1.2.*

26− , transformers

41+ , bytestring >= 0.10.0

42+ , containers >= 0.5 && < 0.7

43+ , cereal >= 0.5 && < 0.6

44+ , deepseq >= 1.4 && < 1.5

45+ , hmatrix >= 0.18 && < 0.21

46+ , MonadRandom >= 0.4 && < 0.6

47+ , primitive >= 0.6 && < 0.8

48+ -- Versions of singletons are *tightly* coupled with the

49+ -- GHC version so its fine to drop version bounds.

2750 , singletons

51+ , singletons-base

52+ , vector >= 0.11 && < 0.13

2853

2954 ghc-options:

3055 -Wall

3156 hs-source-dirs:

3257 src

3358

59+ default-language: Haskell2010

60+

61+ if impl(ghc < 8.0)

62+ ghc-options: -fno-warn-incomplete-patterns

63+ cpp-options: -DType=*

64+

65+ if impl(ghc >= 8.6)

66+ default-extensions: NoStarIsType

3467

3568 exposed-modules:

3669 Grenade

70+ Grenade.Core

71+ Grenade.Core.Layer

72+ Grenade.Core.LearningParameters

3773 Grenade.Core.Network

38− Grenade.Core.Vector

3974 Grenade.Core.Runner

4075 Grenade.Core.Shape

41− Grenade.Layers.Crop

76+

77+ Grenade.Layers

78+ Grenade.Layers.Concat

4279 Grenade.Layers.Convolution

80+ Grenade.Layers.Crop

81+ Grenade.Layers.Deconvolution

4382 Grenade.Layers.Dropout

83+ Grenade.Layers.Elu

4484 Grenade.Layers.FullyConnected

45− Grenade.Layers.Flatten

46− Grenade.Layers.Fuse

85+ Grenade.Layers.Inception

4786 Grenade.Layers.Logit

48− Grenade.Layers.Relu

49− Grenade.Layers.Tanh

87+ Grenade.Layers.Merge

5088 Grenade.Layers.Pad

5189 Grenade.Layers.Pooling

90+ Grenade.Layers.Relu

91+ Grenade.Layers.Reshape

92+ Grenade.Layers.Sinusoid

93+ Grenade.Layers.Softmax

94+ Grenade.Layers.Tanh

95+ Grenade.Layers.Trivial

5296

5397 Grenade.Layers.Internal.Convolution

98+ Grenade.Layers.Internal.Pad

5499 Grenade.Layers.Internal.Pooling

100+ Grenade.Layers.Internal.Update

55101

102+ Grenade.Recurrent

56103

57−executable feedforward

58− ghc-options: -Wall -threaded -O2

59− main-is: main/feedforward.hs

60− build-depends: base

61− , grenade

62− , attoparsec

63− , either

64− , optparse-applicative == 0.12.*

65− , text == 1.2.*

66− , mtl >= 2.2.1 && < 2.3

67− , hmatrix

68− , transformers

69− , singletons

70− , MonadRandom

104+ Grenade.Recurrent.Core

105+ Grenade.Recurrent.Core.Layer

106+ Grenade.Recurrent.Core.Network

107+ Grenade.Recurrent.Core.Runner

71108

72−executable mnist

73− ghc-options: -Wall -threaded -O2

74− main-is: main/mnist.hs

75− build-depends: base

76− , grenade

77− , attoparsec

78− , either

79− , optparse-applicative == 0.12.*

80− , text == 1.2.*

81− , mtl >= 2.2.1 && < 2.3

82− , hmatrix >= 0.18 && < 0.19

83− , transformers

84− , singletons

85− , MonadRandom

109+ Grenade.Recurrent.Layers

110+ Grenade.Recurrent.Layers.BasicRecurrent

111+ Grenade.Recurrent.Layers.ConcatRecurrent

112+ Grenade.Recurrent.Layers.LSTM

113+

114+ Grenade.Utils.OneHot

115+

116+ includes: cbits/im2col.h

117+ cbits/gradient_descent.h

118+ cbits/pad.h

119+ c-sources: cbits/im2col.c

120+ cbits/gradient_descent.c

121+ cbits/pad.c

86122

123+ cc-options: -std=c99 -O3 -msse4.2 -Wall -Werror -DCABAL=1

87124

88125test-suite test

89126 type: exitcode-stdio-1.0

@@ -95,12 +132,84 @@ test-suite test

95132 hs-source-dirs:

96133 test

97134

135+ default-language: Haskell2010

136+

137+ other-modules: Test.Hedgehog.Compat

138+ Test.Hedgehog.Hmatrix

139+ Test.Hedgehog.TypeLits

140+

141+ Test.Grenade.Network

142+ Test.Grenade.Layers.Convolution

143+ Test.Grenade.Layers.FullyConnected

144+ Test.Grenade.Layers.Nonlinear

145+ Test.Grenade.Layers.PadCrop

146+ Test.Grenade.Layers.Pooling

147+ Test.Grenade.Layers.Internal.Convolution

148+ Test.Grenade.Layers.Internal.Pooling

149+ Test.Grenade.Layers.Internal.Reference

150+

151+ Test.Grenade.Recurrent.Layers.LSTM

152+ Test.Grenade.Recurrent.Layers.LSTM.Reference

153+

154+ if impl(ghc < 8.0)

155+ ghc-options: -fno-warn-incomplete-patterns

156+ cpp-options: -DType=*

157+

158+ if impl(ghc >= 8.6)

159+ default-extensions: NoStarIsType

160+

98161 build-depends:

99− base >= 4.8 && < 5

162+ base

100163 , grenade

101− , ambiata-disorder-core

164+ , hedgehog >= 1.0 && < 1.1

102165 , hmatrix

103166 , mtl

167+ , singletons

104168 , text == 1.2.*

105− , QuickCheck >= 2.7 && < 2.9

106− , quickcheck-instances == 0.3.*

169+ , typelits-witnesses < 0.4

170+ , transformers

171+ , constraints

172+ , MonadRandom

173+ , random

174+ , ad

175+ , reflection

176+ , vector

177+

178+

179+benchmark bench

180+ type: exitcode-stdio-1.0

181+

182+ main-is: bench.hs

183+

184+ ghc-options: -Wall -threaded -O2

185+

186+ hs-source-dirs:

187+ bench

188+

189+ default-language: Haskell2010

190+

191+ build-depends:

192+ base

193+ , bytestring

194+ , criterion >= 1.1 && < 1.6

195+ , grenade

196+ , hmatrix

197+

198+benchmark bench-lstm

199+ type: exitcode-stdio-1.0

200+

201+ main-is: bench-lstm.hs

202+

203+ ghc-options: -Wall -threaded -O2

204+

205+ hs-source-dirs:

206+ bench

207+

208+ default-language: Haskell2010

209+

210+ build-depends:

211+ base

212+ , bytestring

213+ , criterion

214+ , grenade

215+ , hmatrix

lib/disorder.hsdeleted−1

Submodule changed.

lib/pdeleted−1

Submodule changed.

mafiamode 100755 → 120000+1−121

@@ -1,121 +0,0 @@

1−#!/bin/sh -eu

2−

3−fetch_latest () {

4− if [ -z ${MAFIA_TEST_MODE+x} ]; then

5− TZ=$(date +"%T")

6− curl --silent "https://raw.githubusercontent.com/ambiata/mafia/master/script/mafia?$TZ"

7− else

8− cat ../script/mafia

9− fi

10−}

11−

12−latest_version () {

13− git ls-remote https://github.com/ambiata/mafia | grep refs/heads/master | cut -f 1

14−}

15−

16−local_version () {

17− awk '/^# Version: / { print $3; exit 0; }' $0

18−}

19−

20−run_upgrade () {

21− MAFIA_TEMP=$(mktemp 2>/dev/null || mktemp -t 'upgrade_mafia')

22−

23− clean_up () {

24− rm -f "$MAFIA_TEMP"

25− }

26−

27− trap clean_up EXIT

28−

29− MAFIA_CUR="$0"

30−

31− if [ -L "$MAFIA_CUR" ]; then

32− echo 'Refusing to overwrite a symlink; run `upgrade` from the canonical path.' >&2

33− exit 1

34− fi

35−

36− echo "Checking for a new version of mafia ..."

37− fetch_latest > $MAFIA_TEMP

38−

39− LATEST_VERSION=$(latest_version)

40− echo "# Version: $LATEST_VERSION" >> $MAFIA_TEMP

41−

42− if ! cmp $MAFIA_CUR $MAFIA_TEMP >/dev/null 2>&1; then

43− mv $MAFIA_TEMP $MAFIA_CUR

44− chmod +x $MAFIA_CUR

45− echo "New version found and upgraded. You can now commit it to your git repo."

46− else

47− echo "You have latest mafia."

48− fi

49−}

50−

51−exec_mafia () {

52− MAFIA_VERSION=$(local_version)

53−

54− if [ "x$MAFIA_VERSION" = "x" ]; then

55− # If we can't find the mafia version, then we need to upgrade the script.

56− run_upgrade

57− else

58− MAFIA_BIN=$HOME/.ambiata/mafia/bin

59− MAFIA_FILE=mafia-$MAFIA_VERSION

60− MAFIA_PATH=$MAFIA_BIN/$MAFIA_FILE

61−

62− [ -f "$MAFIA_PATH" ] || {

63− # Create a temporary directory which will be deleted when the script

64− # terminates. Unfortunately `mktemp` doesn't behave the same on

65− # Linux and OS/X so we need to try two different approaches.

66− MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia')

67−

68− # Create a temporary file in MAFIA_BIN so we can do an atomic copy/move dance.

69− mkdir -p $MAFIA_BIN

70−

71− clean_up () {

72− rm -rf "$MAFIA_TEMP"

73− }

74−

75− trap clean_up EXIT

76−

77− echo "Building $MAFIA_FILE in $MAFIA_TEMP"

78−

79− ( cd "$MAFIA_TEMP"

80−

81− git clone https://github.com/ambiata/mafia

82− cd mafia

83−

84− git reset --hard $MAFIA_VERSION

85−

86− bin/bootstrap ) || exit $?

87−

88− MAFIA_PATH_TEMP=$(mktemp --tmpdir=$MAFIA_BIN $MAFIA_FILE-XXXXXX 2>/dev/null || TMPDIR=$MAFIA_BIN mktemp -t $MAFIA_FILE)

89−

90− clean_up_temp () {

91− clean_up

92− rm -f "$MAFIA_PATH_TEMP"

93− }

94− trap clean_up_temp EXIT

95−

96− cp "$MAFIA_TEMP/mafia/.cabal-sandbox/bin/mafia" "$MAFIA_PATH_TEMP"

97− chmod 755 "$MAFIA_PATH_TEMP"

98− mv "$MAFIA_PATH_TEMP" "$MAFIA_PATH"

99−

100− clean_up_temp

101− }

102−

103− exec $MAFIA_PATH "$@"

104− fi

105−}

106−

107−#

108−# The actual start of the script.....

109−#

110−

111−if [ $# -gt 0 ]; then

112− MODE="$1"

113−else

114− MODE=""

115−fi

116−

117−case "$MODE" in

118−upgrade) shift; run_upgrade "$@" ;;

119−*) exec_mafia "$@"

120−esac

121−# Version: a1b39ee8ac1969ed2e891b9062d079be75863e99

@@ -0,0 +1 @@

1+framework/mafia

main/feedforward.hsdeleted−79

@@ -1,79 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE TypeOperators #-}

5−{-# LANGUAGE TupleSections #-}

6−{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE FlexibleContexts #-}

8−

9−import Control.Monad

10−import Control.Monad.Random

11−import GHC.TypeLits

12−

13−import qualified Numeric.LinearAlgebra.Static as SA

14−

15−import Options.Applicative

16−

17−import Grenade

18−

19−-- The defininition for our simple feed forward network.

20−-- The type level list represents the shapes passed through the layers. One can see that for this demonstration

21−-- we are using relu, tanh and logit non-linear units, which can be easily subsituted for each other in and out.

22−

23−-- It's important to keep the type signatures, as there's many layers which can "squeeze" into the gaps

24−-- between the shapes, so inference can't do it all for us.

25−

26−-- With around 100000 examples, this should show two clear circles which have been learned by the network.

27−randomNet :: MonadRandom m

28− => m (Network '[ FullyConnected 2 40, Tanh, FullyConnected 40 10, Relu, FullyConnected 10 1, Logit ]

29− '[ 'D1 2, 'D1 40, 'D1 40, 'D1 10, 'D1 10, 'D1 1, 'D1 1])

30−randomNet = randomNetwork

31−

32−netTest :: MonadRandom m => LearningParameters -> Int -> m String

33−netTest rate n = do

34− inps <- replicateM n $ do

35− s <- getRandom

36− return $ S1D' $ SA.randomVector s SA.Uniform * 2 - 1

37− let outs = flip map inps $ \(S1D' v) ->

38− if v `inCircle` (fromRational 0.33, 0.33) || v `inCircle` (fromRational (-0.33), 0.33)

39− then S1D' $ fromRational 1

40− else S1D' $ fromRational 0

41− net0 <- randomNet

42−

43− let trained = foldl trainEach net0 (zip inps outs)

44− let testIns = [ [ (x,y) | x <- [0..50] ]

45− | y <- [0..20] ]

46−

47− let outMat = fmap (fmap (\(x,y) -> (render . normx) $ runNet trained (S1D' $ SA.vector [x / 25 - 1,y / 10 - 1]))) testIns

48− return $ unlines outMat

49−

50− where

51− inCircle :: KnownNat n => SA.R n -> (SA.R n, Double) -> Bool

52− v `inCircle` (o, r) = SA.norm_2 (v - o) <= r

53− trainEach !network (i,o) = train rate network i o

54−

55− render n' | n' <= 0.2 = ' '

56− | n' <= 0.4 = '.'

57− | n' <= 0.6 = '-'

58− | n' <= 0.8 = '='

59− | otherwise = '#'

60−

61− normx :: S' ('D1 1) -> Double

62− normx (S1D' r) = SA.mean r

63−

64−data FeedForwardOpts = FeedForwardOpts Int LearningParameters

65−

66−feedForward' :: Parser FeedForwardOpts

67−feedForward' =

68− FeedForwardOpts <$> option auto (long "examples" <> short 'e' <> value 100000)

69− <*> (LearningParameters

70− <$> option auto (long "train_rate" <> short 'r' <> value 0.01)

71− <*> option auto (long "momentum" <> value 0.9)

72− <*> option auto (long "l2" <> value 0.0005)

73− )

74−

75−main :: IO ()

76−main = do

77− FeedForwardOpts examples rate <- execParser (info (feedForward' <**> helper) idm)

78− putStrLn "Training network..."

79− putStrLn =<< evalRandIO (netTest rate examples)

src/Grenade.hs+50−16

@@ -1,19 +1,53 @@

11module Grenade (

2− module X

2+ -- | This is an empty module which simply re-exports public definitions

3+ -- for machine learning with Grenade.

4+

5+ -- * Exported modules

6+ --

7+ -- | The core types and runners for Grenade.

8+ module Grenade.Core

9+

10+ -- | The neural network layer zoo

11+ , module Grenade.Layers

12+

13+

14+ -- * Overview of the library

15+ -- $library

16+

17+ -- * Example usage

18+ -- $example

19+

320 ) where

421

5−import Grenade.Core.Vector as X

6−import Grenade.Core.Network as X

7−import Grenade.Core.Runner as X

8−import Grenade.Core.Shape as X

9−import Grenade.Layers.Crop as X

10−import Grenade.Layers.Dropout as X

11−import Grenade.Layers.Pad as X

12−import Grenade.Layers.Pooling as X

13−import Grenade.Layers.Flatten as X

14−import Grenade.Layers.Fuse as X

15−import Grenade.Layers.FullyConnected as X

16−import Grenade.Layers.Logit as X

17−import Grenade.Layers.Convolution as X

18−import Grenade.Layers.Relu as X

19−import Grenade.Layers.Tanh as X

22+import Grenade.Core

23+import Grenade.Layers

24+

25+{- $library

26+Grenade is a purely functional deep learning library.

27+

28+It provides an expressive type level API for the construction

29+of complex neural network architectures. Backing this API is and

30+implementation written using BLAS and LAPACK, mostly provided by

31+the hmatrix library.

32+

33+-}

34+

35+{- $example

36+A few examples are provided at https://github.com/HuwCampbell/grenade

37+under the examples folder.

38+

39+The starting place is to write your neural network type and a

40+function to create a random layer of that type. The following

41+is a simple example which runs a logistic regression.

42+

43+> type MyNet = Network '[ FullyConnected 10 1, Logit ] '[ 'D1 10, 'D1 1, 'D1 1 ]

44+>

45+> randomMyNet :: MonadRandom MyNet

46+> randomMyNet = randomNetwork

47+

48+The function `randomMyNet` witnesses the `CreatableNetwork`

49+constraint of the neural network, and in doing so, ensures the network

50+can be built, and hence, that the architecture is sound.

51+-}

52+

53+

src/Grenade/Core.hsnew file+13

@@ -0,0 +1,13 @@

1+module Grenade.Core (

2+ module Grenade.Core.Layer

3+ , module Grenade.Core.LearningParameters

4+ , module Grenade.Core.Network

5+ , module Grenade.Core.Runner

6+ , module Grenade.Core.Shape

7+ ) where

8+

9+import Grenade.Core.Layer

10+import Grenade.Core.LearningParameters

11+import Grenade.Core.Network

12+import Grenade.Core.Runner

13+import Grenade.Core.Shape

src/Grenade/Core/Layer.hsnew file+92

@@ -0,0 +1,92 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE FlexibleInstances #-}

10+{-|

11+Module : Grenade.Core.Layer

12+Description : Defines the Layer Classes

13+Copyright : (c) Huw Campbell, 2016-2017

14+License : BSD2

15+Stability : experimental

16+

17+This module defines what a Layer is in a Grenade

18+neural network.

19+

20+There are two classes of interest: `UpdateLayer` and `Layer`.

21+

22+`UpdateLayer` is required for all types which are used as a layer

23+in a network. Having no shape information, this class is agnostic

24+to the input and output data of the layer.

25+

26+An instance of `Layer` on the other hand is required for usage in

27+a neural network, but also specifies the shapes of data that the

28+network can transform. Multiple instance of `Layer` are permitted

29+for a single type, to transform different shapes. The `Reshape` layer

30+for example can act as a flattening layer, and its inverse, projecting

31+a 1D shape up to 2 or 3 dimensions.

32+

33+Instances of `Layer` should be as strict as possible, and not emit

34+runtime errors.

35+-}

36+module Grenade.Core.Layer (

37+ Layer (..)

38+ , UpdateLayer (..)

39+ ) where

40+

41+import Control.Monad.Random ( MonadRandom )

42+

43+import Data.List ( foldl' )

44+

45+#if MIN_VERSION_base(4,9,0)

46+import Data.Kind (Type)

47+#endif

48+

49+import Grenade.Core.Shape

50+import Grenade.Core.LearningParameters

51+

52+-- | Class for updating a layer. All layers implement this, as it

53+-- describes how to create and update the layer.

54+--

55+class UpdateLayer x where

56+ -- | The type for the gradient for this layer.

57+ -- Unit if there isn't a gradient to pass back.

58+ type Gradient x :: Type

59+

60+ -- | Update a layer with its gradient and learning parameters

61+ runUpdate :: LearningParameters -> x -> Gradient x -> x

62+

63+ -- | Create a random layer, many layers will use pure

64+ createRandom :: MonadRandom m => m x

65+

66+ -- | Update a layer with many Gradients

67+ runUpdates :: LearningParameters -> x -> [Gradient x] -> x

68+ runUpdates rate = foldl' (runUpdate rate)

69+

70+ {-# MINIMAL runUpdate, createRandom #-}

71+

72+-- | Class for a layer. All layers implement this, however, they don't

73+-- need to implement it for all shapes, only ones which are

74+-- appropriate.

75+--

76+class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where

77+ -- | The Wengert tape for this layer. Includes all that is required

78+ -- to generate the back propagated gradients efficiently. As a

79+ -- default, `S i` is fine.

80+ type Tape x i o :: Type

81+

82+ -- | Used in training and scoring. Take the input from the previous

83+ -- layer, and give the output from this layer.

84+ runForwards :: x -> S i -> (Tape x i o, S o)

85+

86+ -- | Back propagate a step. Takes the current layer, the input that

87+ -- the layer gave from the input and the back propagated derivatives

88+ -- from the layer above.

89+ --

90+ -- Returns the gradient layer and the derivatives to push back

91+ -- further.

92+ runBackwards :: x -> Tape x i o -> S o -> (Gradient x, S i)

src/Grenade/Core/LearningParameters.hsnew file+21

@@ -0,0 +1,21 @@

1+{-|

2+Module : Grenade.Core.LearningParameters

3+Description : Stochastic gradient descent learning parameters

4+Copyright : (c) Huw Campbell, 2016-2017

5+License : BSD2

6+Stability : experimental

7+-}

8+module Grenade.Core.LearningParameters (

9+ -- | This module contains learning algorithm specific

10+ -- code. Currently, this module should be considered

11+ -- unstable, due to issue #26.

12+

13+ LearningParameters (..)

14+ ) where

15+

16+-- | Learning parameters for stochastic gradient descent.

17+data LearningParameters = LearningParameters {

18+ learningRate :: Double

19+ , learningMomentum :: Double

20+ , learningRegulariser :: Double

21+ } deriving (Eq, Show)

src/Grenade/Core/Network.hs+169−60

@@ -1,88 +1,197 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE BangPatterns #-}

24{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE KindSignatures #-}

45{-# LANGUAGE ScopedTypeVariables #-}

56{-# LANGUAGE TypeOperators #-}

67{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE PolyKinds #-}

88{-# LANGUAGE MultiParamTypeClasses #-}

99{-# LANGUAGE FlexibleContexts #-}

1010{-# LANGUAGE FlexibleInstances #-}

11−{-# LANGUAGE LambdaCase #-}

11+{-|

12+Module : Grenade.Core.Network

13+Description : Core definition of a Neural Network

14+Copyright : (c) Huw Campbell, 2016-2017

15+License : BSD2

16+Stability : experimental

17+

18+This module defines the core data types and functions

19+for non-recurrent neural networks.

20+-}

1221

1322module Grenade.Core.Network (

14− Layer (..)

15− , Network (..)

16− , UpdateLayer (..)

17− , LearningParameters (..)

23+ Network (..)

1824 , Gradients (..)

19− , CreatableNetwork (..)

25+ , Tapes (..)

26+

27+ , runNetwork

28+ , runGradient

29+ , applyUpdate

30+

31+ , randomNetwork

2032 ) where

2133

22−import Control.Monad.Random (MonadRandom)

34+import Control.Monad.Random ( MonadRandom )

2335

36+import Data.Singletons

37+import Data.Serialize

2438

25−import Grenade.Core.Shape

39+#if MIN_VERSION_base(4,9,0)

40+import Data.Kind (Type)

41+#endif

2642

27−data LearningParameters = LearningParameters {

28− learningRate :: Double

29− , learningMomentum :: Double

30− , learningRegulariser :: Double

31− } deriving (Eq, Show)

32−

33−-- | Class for updating a layer. All layers implement this, and it is

34−-- shape independent.

35−class Show x => UpdateLayer x where

36− -- | The type for the gradient for this layer.

37− -- Unit if there isn't a gradient to pass back.

38− type Gradient x :: *

39− -- | Update a layer with its gradient and learning parameters

40− runUpdate :: LearningParameters -> x -> Gradient x -> x

41− -- | Create a random layer, many layers will use pure

42− createRandom :: MonadRandom m => m x

43−

44−-- | Class for a layer. All layers implement this, however, they don't

45−-- need to implement it for all shapes, only ones which are appropriate.

46−class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where

47− -- | Used in training and scoring. Take the input from the previous

48− -- layer, and give the output from this layer.

49− runForwards :: x -> S' i -> S' o

50− -- | Back propagate a step. Takes the current layer, the input that the

51− -- layer gave from the input and the back propagated derivatives from

52− -- the layer above.

53− -- Returns the gradient layer and the derivatives to push back further.

54− runBackwards :: x -> S' i -> S' o -> (Gradient x, S' i)

43+import Grenade.Core.Layer

44+import Grenade.Core.LearningParameters

45+import Grenade.Core.Shape

46+import Prelude.Singletons

5547

5648-- | Type of a network.

57−-- The [*] type specifies the types of the layers. This is needed for parallel

58−-- running and being all the gradients beck together.

59−-- The [Shape] type specifies the shapes of data passed between the layers.

60−-- Could be considered to be a heterogeneous list of layers which are able to

49+--

50+-- The @[*]@ type specifies the types of the layers.

51+--

52+-- The @[Shape]@ type specifies the shapes of data passed between the layers.

53+--

54+-- Can be considered to be a heterogeneous list of layers which are able to

6155-- transform the data shapes of the network.

62−data Network :: [*] -> [Shape] -> * where

63− O :: Layer x i o => !x -> Network '[x] '[i, o]

64− (:~>) :: Layer x i h => !x -> !(Network xs (h ': hs)) -> Network (x ': xs) (i ': h ': hs)

56+data Network :: [Type] -> [Shape] -> Type where

57+ NNil :: SingI i

58+ => Network '[] '[i]

59+

60+ (:~>) :: (SingI i, SingI h, Layer x i h)

61+ => !x

62+ -> !(Network xs (h ': hs))

63+ -> Network (x ': xs) (i ': h ': hs)

6564infixr 5 :~>

6665

67−instance Show (Network l h) where

68− show (O a) = "O " ++ show a

69− show (i :~> o) = show i ++ "\n:~>\n" ++ show o

66+instance Show (Network '[] '[i]) where

67+ show NNil = "NNil"

68+instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) where

69+ show (x :~> xs) = show x ++ "\n~>\n" ++ show xs

70+

71+-- | Gradient of a network.

72+--

73+-- Parameterised on the layers of the network.

74+data Gradients :: [Type] -> Type where

75+ GNil :: Gradients '[]

76+

77+ (:/>) :: UpdateLayer x

78+ => Gradient x

79+ -> Gradients xs

80+ -> Gradients (x ': xs)

81+

82+-- | Wegnert Tape of a network.

83+--

84+-- Parameterised on the layers and shapes of the network.

85+data Tapes :: [Type] -> [Shape] -> Type where

86+ TNil :: SingI i

87+ => Tapes '[] '[i]

88+

89+ (:\>) :: (SingI i, SingI h, Layer x i h)

90+ => !(Tape x i h)

91+ -> !(Tapes xs (h ': hs))

92+ -> Tapes (x ': xs) (i ': h ': hs)

93+

7094

71−-- | Gradients of a network.

72−-- Parameterised on the layers of a Network.

73−data Gradients :: [*] -> * where

74− OG :: UpdateLayer x => Gradient x -> Gradients '[x]

75− (:/>) :: UpdateLayer x => Gradient x -> Gradients xs -> Gradients (x ': xs)

95+-- | Running a network forwards with some input data.

96+--

97+-- This gives the output, and the Wengert tape required for back

98+-- propagation.

99+runNetwork :: forall layers shapes.

100+ Network layers shapes

101+ -> S (Head shapes)

102+ -> (Tapes layers shapes, S (Last shapes))

103+runNetwork =

104+ go

105+ where

106+ go :: forall js ss. (Last js ~ Last shapes)

107+ => Network ss js

108+ -> S (Head js)

109+ -> (Tapes ss js, S (Last js))

110+ go (layer :~> n) !x =

111+ let (tape, forward) = runForwards layer x

112+ (tapes, answer) = go n forward

113+ in (tape :\> tapes, answer)

76114

115+ go NNil !x

116+ = (TNil, x)

77117

78−-- | A network can easily be created by hand with (:~>), but an easy way to initialise a random

79−-- network is with the randomNetwork.

80−class CreatableNetwork (xs :: [*]) (ss :: [Shape]) where

81− -- | Create a network of the types requested

118+

119+-- | Running a loss gradient back through the network.

120+--

121+-- This requires a Wengert tape, generated with the appropriate input

122+-- for the loss.

123+--

124+-- Gives the gradients for the layer, and the gradient across the

125+-- input (which may not be required).

126+runGradient :: forall layers shapes.

127+ Network layers shapes

128+ -> Tapes layers shapes

129+ -> S (Last shapes)

130+ -> (Gradients layers, S (Head shapes))

131+runGradient net tapes o =

132+ go net tapes

133+ where

134+ go :: forall js ss. (Last js ~ Last shapes)

135+ => Network ss js

136+ -> Tapes ss js

137+ -> (Gradients ss, S (Head js))

138+ go (layer :~> n) (tape :\> nt) =

139+ let (gradients, feed) = go n nt

140+ (layer', backGrad) = runBackwards layer tape feed

141+ in (layer' :/> gradients, backGrad)

142+

143+ go NNil TNil

144+ = (GNil, o)

145+

146+

147+-- | Apply one step of stochastic gradient descent across the network.

148+applyUpdate :: LearningParameters

149+ -> Network layers shapes

150+ -> Gradients layers

151+ -> Network layers shapes

152+applyUpdate rate (layer :~> rest) (gradient :/> grest)

153+ = runUpdate rate layer gradient :~> applyUpdate rate rest grest

154+

155+applyUpdate _ NNil GNil

156+ = NNil

157+

158+-- | A network can easily be created by hand with (:~>), but an easy way to

159+-- initialise a random network is with the randomNetwork.

160+class CreatableNetwork (xs :: [Type]) (ss :: [Shape]) where

161+ -- | Create a network with randomly initialised weights.

162+ --

163+ -- Calls to this function will not compile if the type of the neural

164+ -- network is not sound.

82165 randomNetwork :: MonadRandom m => m (Network xs ss)

83166

84−instance Layer x i o => CreatableNetwork (x ': '[]) (i ': o ': '[]) where

85− randomNetwork = O <$> createRandom

167+instance SingI i => CreatableNetwork '[] '[i] where

168+ randomNetwork = return NNil

86169

87−instance (Layer x i o, CreatableNetwork xs (o ': r ': rs)) => CreatableNetwork (x ': xs) (i ': o ': r ': rs) where

170+instance (SingI i, SingI o, Layer x i o, CreatableNetwork xs (o ': rs)) => CreatableNetwork (x ': xs) (i ': o ': rs) where

88171 randomNetwork = (:~>) <$> createRandom <*> randomNetwork

172+

173+-- | Add very simple serialisation to the network

174+instance SingI i => Serialize (Network '[] '[i]) where

175+ put NNil = pure ()

176+ get = return NNil

177+

178+instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o ': rs))) => Serialize (Network (x ': xs) (i ': o ': rs)) where

179+ put (x :~> r) = put x >> put r

180+ get = (:~>) <$> get <*> get

181+

182+

183+-- | Ultimate composition.

184+--

185+-- This allows a complete network to be treated as a layer in a larger network.

186+instance CreatableNetwork sublayers subshapes => UpdateLayer (Network sublayers subshapes) where

187+ type Gradient (Network sublayers subshapes) = Gradients sublayers

188+ runUpdate = applyUpdate

189+ createRandom = randomNetwork

190+

191+-- | Ultimate composition.

192+--

193+-- This allows a complete network to be treated as a layer in a larger network.

194+instance (CreatableNetwork sublayers subshapes, i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (Network sublayers subshapes) i o where

195+ type Tape (Network sublayers subshapes) i o = Tapes sublayers subshapes

196+ runForwards = runNetwork

197+ runBackwards = runGradient

src/Grenade/Core/Runner.hs+39−51

@@ -1,70 +1,58 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE GADTs #-}

31{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE TypeOperators #-}

6−{-# LANGUAGE TypeFamilies #-}

7−

2+{-# LANGUAGE FlexibleContexts #-}

3+{-|

4+Module : Grenade.Core.Runner

5+Description : Functions to perform training and backpropagation

6+Copyright : (c) Huw Campbell, 2016-2017

7+License : BSD2

8+Stability : experimental

9+-}

810module Grenade.Core.Runner (

911 train

1012 , backPropagate

1113 , runNet

12− , applyUpdate

1314 ) where

1415

15−import Data.Singletons.Prelude

16+

17+import Grenade.Core.LearningParameters

1618import Grenade.Core.Network

1719import Grenade.Core.Shape

18−

19−-- | Drive and network and collect its back propogated gradients.

20−backPropagate :: forall input output shapes layers. (Head shapes ~ input, Last shapes ~ output)

21− => Network layers shapes -> S' input -> S' output -> Gradients layers

20+import Data.Singletons

21+import Prelude.Singletons

22+

23+-- | Perform reverse automatic differentiation on the network

24+-- for the current input and expected output.

25+--

26+-- /Note:/ The loss function pushed backwards is appropriate

27+-- for both regression and classification as a squared loss

28+-- or log-loss respectively.

29+--

30+-- For other loss functions, use runNetwork and runGradient

31+-- with the back propagated gradient of your loss.

32+--

33+backPropagate :: SingI (Last shapes)

34+ => Network layers shapes

35+ -> S (Head shapes)

36+ -> S (Last shapes)

37+ -> Gradients layers

2238backPropagate network input target =

23− fst $ go input network

24− where

25− go :: forall j js sublayers. (Head js ~ j, Last js ~ output)

26− => S' j -- ^ input vector

27− -> Network sublayers js -- ^ network to train

28− -> (Gradients sublayers, S' j)

29− -- handle input from the beginning, feeding upwards.

30− go !x (layer :~> n)

31− = let y = runForwards layer x

32− -- recursively run the rest of the network, and get the gradients from above.

33− (n', dWs') = go y n

34− -- calculate the gradient for this layer to pass down,

35− (layer', dWs) = runBackwards layer x dWs'

39+ let (tapes, output) = runNetwork network input

40+ (grads, _) = runGradient network tapes (output - target)

41+ in grads

3642

37− in (layer' :/> n', dWs)

38−

39− -- handle the output layer, bouncing the derivatives back down.

40− go !x (O layer)

41− = let y = runForwards layer x

42− -- the gradient (how much y affects the error)

43− (layer', dWs) = runBackwards layer x (y - target)

44−

45− in (OG layer', dWs)

4643

4744-- | Update a network with new weights after training with an instance.

48−train :: forall input output shapes layers. (Head shapes ~ input, Last shapes ~ output)

49− => LearningParameters -- ^ learning rate

50− -> Network layers shapes -- ^ network to train

51− -> S' input -> S' output -- ^ target vector

45+train :: SingI (Last shapes)

46+ => LearningParameters

47+ -> Network layers shapes

48+ -> S (Head shapes)

49+ -> S (Last shapes)

5250 -> Network layers shapes

5351train rate network input output =

5452 let grads = backPropagate network input output

5553 in applyUpdate rate network grads

5654

57−applyUpdate :: LearningParameters -> Network ls ss -> Gradients ls -> Network ls ss

58−applyUpdate rate (O layer) (OG gradient)

59− = O (runUpdate rate layer gradient)

60−applyUpdate rate (layer :~> rest) (gradient :/> grest)

61− = runUpdate rate layer gradient :~> applyUpdate rate rest grest

62−applyUpdate _ _ _

63− = error "Impossible for the gradients of a network to have a different length to the network"

6455

65−-- | Just forwards propagation with no training.

66−runNet :: Network layers hs

67− -> S' (Head hs) -- ^ input vector

68− -> S' (Last hs) -- ^ target vector

69−runNet (layer :~> n) !x = let y = runForwards layer x in runNet n y

70−runNet (O layer) !x = runForwards layer x

56+-- | Run the network with input and return the given output.

57+runNet :: Network layers shapes -> S (Head shapes) -> S (Last shapes)

58+runNet net = snd . runNetwork net

src/Grenade/Core/Shape.hs+199−52

@@ -1,70 +1,217 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE KindSignatures #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE TypeOperators #-}

65{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE StandaloneDeriving #-}

98{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE FlexibleInstances #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+{-|

13+Module : Grenade.Core.Shape

14+Description : Dependently typed shapes of data which are passed between layers of a network

15+Copyright : (c) Huw Campbell, 2016-2017

16+License : BSD2

17+Stability : experimental

1118

12−-- Ghc 8.0 gives a warning on `(+) _ _ = error ...` but ghc 7.10 fails to

13−-- compile without this default pattern.

14−{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

1519

20+-}

1621module Grenade.Core.Shape (

17− Shape (..)

18− , S' (..)

22+ S (..)

23+ , Shape (..)

24+ , SShape (..)

25+ , randomOfShape

26+ , fromStorable

1927 ) where

2028

21−import Data.Singletons.TypeLits

22−

29+import Control.DeepSeq (NFData (..))

30+import Control.Monad.Random ( MonadRandom, getRandom )

31+import Data.Kind (Type)

32+import Data.Proxy

33+import Data.Serialize

34+import Data.Singletons

35+import Data.Vector.Storable ( Vector )

36+import qualified Data.Vector.Storable as V

37+import GHC.TypeLits

38+import qualified Numeric.LinearAlgebra.Static as H

2339import Numeric.LinearAlgebra.Static

24−

25−import Grenade.Core.Vector

40+import qualified Numeric.LinearAlgebra as NLA

2641

2742-- | The current shapes we accept.

2843-- at the moment this is just one, two, and three dimensional

2944-- Vectors/Matricies.

30−data Shape =

31− D1 Nat

45+--

46+-- These are only used with DataKinds, as Kind `Shape`, with Types 'D1, 'D2, 'D3.

47+data Shape

48+ = D1 Nat

49+ -- ^ One dimensional vector

3250 | D2 Nat Nat

51+ -- ^ Two dimensional matrix. Row, Column.

3352 | D3 Nat Nat Nat

53+ -- ^ Three dimensional matrix. Row, Column, Channels.

54+

55+-- | Concrete data structures for a Shape.

56+--

57+-- All shapes are held in contiguous memory.

58+-- 3D is held in a matrix (usually row oriented) which has height depth * rows.

59+data S (n :: Shape) where

60+ S1D :: ( KnownNat len )

61+ => R len

62+ -> S ('D1 len)

63+

64+ S2D :: ( KnownNat rows, KnownNat columns )

65+ => L rows columns

66+ -> S ('D2 rows columns)

67+

68+ S3D :: ( KnownNat rows

69+ , KnownNat columns

70+ , KnownNat depth

71+ , KnownNat (rows * depth))

72+ => L (rows * depth) columns

73+ -> S ('D3 rows columns depth)

74+

75+deriving instance Show (S n)

76+

77+-- Singleton instances.

78+--

79+-- These could probably be derived with template haskell, but this seems

80+-- clear and makes adding the KnownNat constraints simple.

81+-- We can also keep our code TH free, which is great.

82+#if MIN_VERSION_singletons(2,6,0)

83+-- In singletons 2.6 Sing switched from a data family to a type family.

84+type instance Sing = SShape

85+

86+data SShape :: Shape -> Type where

87+ D1Sing :: KnownNat a => SShape ('D1 a)

88+ D2Sing :: (KnownNat a, KnownNat b) => SShape ('D2 a b)

89+ D3Sing :: (KnownNat (a * c), KnownNat a, KnownNat b, KnownNat c) => SShape ('D3 a b c)

90+#else

91+data instance Sing (n :: Shape) where

92+ D1Sing :: Sing a -> Sing ('D1 a)

93+ D2Sing :: Sing a -> Sing b -> Sing ('D2 a b)

94+ D3Sing :: KnownNat (a * c) => Sing a -> Sing b -> Sing c -> Sing ('D3 a b c)

95+#endif

96+

97+instance KnownNat a => SingI ('D1 a) where

98+ sing = D1Sing

99+instance (KnownNat a, KnownNat b) => SingI ('D2 a b) where

100+ sing = D2Sing

101+instance (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => SingI ('D3 a b c) where

102+ sing = D3Sing

103+

104+instance SingI x => Num (S x) where

105+ (+) = n2 (+)

106+ (-) = n2 (-)

107+ (*) = n2 (*)

108+ abs = n1 abs

109+ signum = n1 signum

110+ fromInteger x = nk (fromInteger x)

111+

112+instance SingI x => Fractional (S x) where

113+ (/) = n2 (/)

114+ recip = n1 recip

115+ fromRational x = nk (fromRational x)

116+

117+instance SingI x => Floating (S x) where

118+ pi = nk pi

119+ exp = n1 exp

120+ log = n1 log

121+ sqrt = n1 sqrt

122+ (**) = n2 (**)

123+ logBase = n2 logBase

124+ sin = n1 sin

125+ cos = n1 cos

126+ tan = n1 tan

127+ asin = n1 asin

128+ acos = n1 acos

129+ atan = n1 atan

130+ sinh = n1 sinh

131+ cosh = n1 cosh

132+ tanh = n1 tanh

133+ asinh = n1 asinh

134+ acosh = n1 acosh

135+ atanh = n1 atanh

136+

137+--

138+-- I haven't made shapes strict, as sometimes they're not needed

139+-- (the last input gradient back for instance)

140+--

141+instance NFData (S x) where

142+ rnf (S1D x) = rnf x

143+ rnf (S2D x) = rnf x

144+ rnf (S3D x) = rnf x

145+

146+-- | Generate random data of the desired shape

147+randomOfShape :: forall x m. ( MonadRandom m, SingI x ) => m (S x)

148+randomOfShape = do

149+ seed :: Int <- getRandom

150+ return $ case (sing :: Sing x) of

151+ D1Sing ->

152+ S1D (randomVector seed Uniform * 2 - 1)

153+

154+ D2Sing ->

155+ S2D (uniformSample seed (-1) 1)

156+

157+ D3Sing ->

158+ S3D (uniformSample seed (-1) 1)

159+

160+-- | Generate a shape from a Storable Vector.

161+--

162+-- Returns Nothing if the vector is of the wrong size.

163+fromStorable :: forall x. SingI x => Vector Double -> Maybe (S x)

164+fromStorable xs = case sing :: Sing x of

165+ D1Sing ->

166+ S1D <$> H.create xs

167+

168+ D2Sing ->

169+ S2D <$> mkL xs

170+

171+ D3Sing ->

172+ S3D <$> mkL xs

173+ where

174+ mkL :: forall rows columns. (KnownNat rows, KnownNat columns)

175+ => Vector Double -> Maybe (L rows columns)

176+ mkL v =

177+ let rows = fromIntegral $ natVal (Proxy :: Proxy rows)

178+ columns = fromIntegral $ natVal (Proxy :: Proxy columns)

179+ in if rows * columns == V.length v

180+ then H.create $ NLA.reshape columns v

181+ else Nothing

182+

183+

184+instance SingI x => Serialize (S x) where

185+ put i = (case i of

186+ (S1D x) -> putListOf put . NLA.toList . H.extract $ x

187+ (S2D x) -> putListOf put . NLA.toList . NLA.flatten . H.extract $ x

188+ (S3D x) -> putListOf put . NLA.toList . NLA.flatten . H.extract $ x

189+ ) :: PutM ()

190+

191+ get = do

192+ Just i <- fromStorable . V.fromList <$> getListOf get

193+ return i

194+

195+-- Helper function for creating the number instances

196+n1 :: ( forall a. Floating a => a -> a ) -> S x -> S x

197+n1 f (S1D x) = S1D (f x)

198+n1 f (S2D x) = S2D (f x)

199+n1 f (S3D x) = S3D (f x)

200+

201+-- Helper function for creating the number instances

202+n2 :: ( forall a. Floating a => a -> a -> a ) -> S x -> S x -> S x

203+n2 f (S1D x) (S1D y) = S1D (f x y)

204+n2 f (S2D x) (S2D y) = S2D (f x y)

205+n2 f (S3D x) (S3D y) = S3D (f x y)

206+

207+-- Helper function for creating the number instances

208+nk :: forall x. (SingI x) => Double -> S x

209+nk x = case (sing :: Sing x) of

210+ D1Sing ->

211+ S1D (konst x)

212+

213+ D2Sing ->

214+ S2D (konst x)

34215

35−instance Num (S' x) where

36− (+) (S1D' x) (S1D' y) = S1D' (x + y)

37− (+) (S2D' x) (S2D' y) = S2D' (x + y)

38− (+) (S3D' x) (S3D' y) = S3D' (vectorZip (+) x y)

39− (+) _ _ = error "Impossible to have different constructors for the same shaped network"

40−

41− (-) (S1D' x) (S1D' y) = S1D' (x - y)

42− (-) (S2D' x) (S2D' y) = S2D' (x - y)

43− (-) (S3D' x) (S3D' y) = S3D' (vectorZip (-) x y)

44− (-) _ _ = error "Impossible to have different constructors for the same shaped network"

45−

46− (*) (S1D' x) (S1D' y) = S1D' (x * y)

47− (*) (S2D' x) (S2D' y) = S2D' (x * y)

48− (*) (S3D' x) (S3D' y) = S3D' (vectorZip (*) x y)

49− (*) _ _ = error "Impossible to have different constructors for the same shaped network"

50−

51− abs (S1D' x) = S1D' (abs x)

52− abs (S2D' x) = S2D' (abs x)

53− abs (S3D' x) = S3D' (fmap abs x)

54−

55− signum (S1D' x) = S1D' (signum x)

56− signum (S2D' x) = S2D' (signum x)

57− signum (S3D' x) = S3D' (fmap signum x)

58−

59− fromInteger _ = error "Unimplemented: fromInteger on Shape"

60−

61−-- | Given a Shape n, these are the possible data structures with that shape.

62−data S' (n :: Shape) where

63− S1D' :: (KnownNat o) => R o -> S' ('D1 o)

64− S2D' :: (KnownNat rows, KnownNat columns) => L rows columns -> S' ('D2 rows columns)

65− S3D' :: (KnownNat rows, KnownNat columns, KnownNat depth) => Vector depth (L rows columns) -> S' ('D3 rows columns depth)

66−

67−instance Show (S' n) where

68− show (S1D' a) = "S1D' " ++ show a

69− show (S2D' a) = "S2D' " ++ show a

70− show (S3D' a) = "S3D' " ++ show a

216+ D3Sing ->

217+ S3D (konst x)

src/Grenade/Core/Vector.hsdeleted−53

@@ -1,53 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE StandaloneDeriving #-}

7−{-# LANGUAGE TypeOperators #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE PolyKinds #-}

10−

11−module Grenade.Core.Vector (

12− Vector

13− , vectorZip

14− , vecToList

15− , mkVector

16− ) where

17−

18−import Data.Proxy

19−import GHC.TypeLits

20−

21−-- | A more specific Tagged type, ensuring that a list

22−-- is equal to the Nat value.

23−newtype Vector (n :: Nat) a = Vector [a]

24−

25−instance Foldable (Vector n) where

26− foldr f b (Vector as) = foldr f b as

27−

28−instance KnownNat n => Traversable (Vector n) where

29− traverse f (Vector as) = mkVector <$> traverse f as

30−

31−instance Functor (Vector n) where

32− fmap f (Vector as) = Vector (fmap f as)

33−

34−instance Show a => Show (Vector n a) where

35− showsPrec d = showsPrec d . vecToList

36−

37−instance Eq a => Eq (Vector n a) where

38− (Vector as) == (Vector bs) = as == bs

39−

40−mkVector :: forall n a. KnownNat n => [a] -> Vector n a

41−mkVector as

42− = let du = fromIntegral . natVal $ (undefined :: Proxy n)

43− la = length as

44− in if du == la

45− then Vector as

46− else error $ "Error creating staticly sized Vector of length: " ++

47− show du ++ " list is of length:" ++ show la

48−

49−vecToList :: Vector n a -> [a]

50−vecToList (Vector as) = as

51−

52−vectorZip :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c

53−vectorZip f (Vector as) (Vector bs) = Vector (zipWith f as bs)

src/Grenade/Layers.hsnew file+35

@@ -0,0 +1,35 @@

1+module Grenade.Layers (

2+ module Grenade.Layers.Concat

3+ , module Grenade.Layers.Convolution

4+ , module Grenade.Layers.Crop

5+ , module Grenade.Layers.Deconvolution

6+ , module Grenade.Layers.Elu

7+ , module Grenade.Layers.FullyConnected

8+ , module Grenade.Layers.Inception

9+ , module Grenade.Layers.Logit

10+ , module Grenade.Layers.Merge

11+ , module Grenade.Layers.Pad

12+ , module Grenade.Layers.Pooling

13+ , module Grenade.Layers.Reshape

14+ , module Grenade.Layers.Relu

15+ , module Grenade.Layers.Softmax

16+ , module Grenade.Layers.Tanh

17+ , module Grenade.Layers.Trivial

18+ ) where

19+

20+import Grenade.Layers.Concat

21+import Grenade.Layers.Convolution

22+import Grenade.Layers.Crop

23+import Grenade.Layers.Deconvolution

24+import Grenade.Layers.Elu

25+import Grenade.Layers.Pad

26+import Grenade.Layers.FullyConnected

27+import Grenade.Layers.Inception

28+import Grenade.Layers.Logit

29+import Grenade.Layers.Merge

30+import Grenade.Layers.Pooling

31+import Grenade.Layers.Reshape

32+import Grenade.Layers.Relu

33+import Grenade.Layers.Softmax

34+import Grenade.Layers.Tanh

35+import Grenade.Layers.Trivial

src/Grenade/Layers/Concat.hsnew file+139

@@ -0,0 +1,139 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE FlexibleInstances #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+{-|

14+Module : Grenade.Layers.Concat

15+Description : Concatenation layer

16+Copyright : (c) Huw Campbell, 2016-2017

17+License : BSD2

18+Stability : experimental

19+

20+This module provides the concatenation layer, which runs two chilld layers in parallel and combines their outputs.

21+-}

22+module Grenade.Layers.Concat (

23+ Concat (..)

24+ ) where

25+

26+import Data.Serialize

27+

28+import Data.Singletons

29+import GHC.TypeLits

30+

31+#if MIN_VERSION_base(4,9,0)

32+import Data.Kind (Type)

33+#endif

34+

35+import Grenade.Core

36+

37+import Numeric.LinearAlgebra.Static ( row, (===), splitRows, unrow, (#), split, R )

38+

39+-- | A Concatentating Layer.

40+--

41+-- This layer shares it's input state between two sublayers, and concatenates their output.

42+--

43+-- With Networks able to be Layers, this allows for very expressive composition of complex Networks.

44+--

45+-- The Concat layer has a few instances, which allow one to flexibly "bash" together the outputs.

46+--

47+-- Two 1D vectors, can go to a 2D shape with 2 rows if their lengths are identical.

48+-- Any 2 1D vectors can also become a longer 1D Vector.

49+--

50+-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad

51+-- and Crop layers to ensure this is the case.

52+data Concat :: Shape -> Type -> Shape -> Type -> Type where

53+ Concat :: x -> y -> Concat m x n y

54+

55+instance (Show x, Show y) => Show (Concat m x n y) where

56+ show (Concat x y) = "Concat\n" ++ show x ++ "\n" ++ show y

57+

58+-- | Run two layers in parallel, combining their outputs.

59+instance (UpdateLayer x, UpdateLayer y) => UpdateLayer (Concat m x n y) where

60+ type Gradient (Concat m x n y) = (Gradient x, Gradient y)

61+ runUpdate lr (Concat x y) (x', y') = Concat (runUpdate lr x x') (runUpdate lr y y')

62+ createRandom = Concat <$> createRandom <*> createRandom

63+

64+instance ( SingI i

65+ , Layer x i ('D1 o)

66+ , Layer y i ('D1 o)

67+ ) => Layer (Concat ('D1 o) x ('D1 o) y) i ('D2 2 o) where

68+ type Tape (Concat ('D1 o) x ('D1 o) y) i ('D2 2 o) = (Tape x i ('D1 o), Tape y i ('D1 o))

69+

70+ runForwards (Concat x y) input =

71+ let (xT, xOut :: S ('D1 o)) = runForwards x input

72+ (yT, yOut :: S ('D1 o)) = runForwards y input

73+ in case (xOut, yOut) of

74+ (S1D xOut', S1D yOut') ->

75+ ((xT, yT), S2D (row xOut' === row yOut'))

76+

77+ runBackwards (Concat x y) (xTape, yTape) (S2D o) =

78+ let (ox, oy) = splitRows o

79+ (x', xB :: S i) = runBackwards x xTape (S1D $ unrow ox)

80+ (y', yB :: S i) = runBackwards y yTape (S1D $ unrow oy)

81+ in ((x', y'), xB + yB)

82+

83+instance ( SingI i

84+ , Layer x i ('D1 m)

85+ , Layer y i ('D1 n)

86+ , KnownNat o

87+ , KnownNat m

88+ , KnownNat n

89+ , o ~ (m + n)

90+ , n ~ (o - m)

91+ , (m <=? o) ~ 'True

92+ ) => Layer (Concat ('D1 m) x ('D1 n) y) i ('D1 o) where

93+ type Tape (Concat ('D1 m) x ('D1 n) y) i ('D1 o) = (Tape x i ('D1 m), Tape y i ('D1 n))

94+

95+ runForwards (Concat x y) input =

96+ let (xT, xOut :: S ('D1 m)) = runForwards x input

97+ (yT, yOut :: S ('D1 n)) = runForwards y input

98+ in case (xOut, yOut) of

99+ (S1D xOut', S1D yOut') ->

100+ ((xT, yT), S1D (xOut' # yOut'))

101+

102+ runBackwards (Concat x y) (xTape, yTape) (S1D o) =

103+ let (ox :: R m , oy :: R n) = split o

104+ (x', xB :: S i) = runBackwards x xTape (S1D ox)

105+ (y', yB :: S i) = runBackwards y yTape (S1D oy)

106+ in ((x', y'), xB + yB)

107+

108+-- | Concat 3D shapes, increasing the number of channels.

109+instance ( SingI i

110+ , Layer x i ('D3 rows cols m)

111+ , Layer y i ('D3 rows cols n)

112+ , KnownNat (rows * n)

113+ , KnownNat (rows * m)

114+ , KnownNat (rows * o)

115+ , KnownNat o

116+ , KnownNat m

117+ , KnownNat n

118+ , ((rows * m) + (rows * n)) ~ (rows * o)

119+ , ((rows * o) - (rows * m)) ~ (rows * n)

120+ , ((rows * m) <=? (rows * o)) ~ 'True

121+ ) => Layer (Concat ('D3 rows cols m) x ('D3 rows cols n) y) i ('D3 rows cols o) where

122+ type Tape (Concat ('D3 rows cols m) x ('D3 rows cols n) y) i ('D3 rows cols o) = (Tape x i ('D3 rows cols m), Tape y i ('D3 rows cols n))

123+

124+ runForwards (Concat x y) input =

125+ let (xT, xOut :: S ('D3 rows cols m)) = runForwards x input

126+ (yT, yOut :: S ('D3 rows cols n)) = runForwards y input

127+ in case (xOut, yOut) of

128+ (S3D xOut', S3D yOut') ->

129+ ((xT, yT), S3D (xOut' === yOut'))

130+

131+ runBackwards (Concat x y) (xTape, yTape) (S3D o) =

132+ let (ox, oy) = splitRows o

133+ (x', xB :: S i) = runBackwards x xTape (S3D ox :: S ('D3 rows cols m))

134+ (y', yB :: S i) = runBackwards y yTape (S3D oy :: S ('D3 rows cols n))

135+ in ((x', y'), xB + yB)

136+

137+instance (Serialize a, Serialize b) => Serialize (Concat sa a sb b) where

138+ put (Concat a b) = put a *> put b

139+ get = Concat <$> get <*> get

src/Grenade/Layers/Convolution.hs+129−87

@@ -1,17 +1,23 @@

1−{-# LANGUAGE BangPatterns #-}

1+{-# LANGUAGE CPP #-}

22{-# LANGUAGE DataKinds #-}

33{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE StandaloneDeriving #-}

5−{-# LANGUAGE RecordWildCards #-}

64{-# LANGUAGE GADTs #-}

75{-# LANGUAGE TypeOperators #-}

86{-# LANGUAGE TypeFamilies #-}

97{-# LANGUAGE MultiParamTypeClasses #-}

108{-# LANGUAGE FlexibleInstances #-}

119{-# LANGUAGE FlexibleContexts #-}

12−{-# LANGUAGE PolyKinds #-}

13−{-# LANGUAGE PatternGuards #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+{-|

12+Module : Grenade.Layers.Convolution

13+Description : Convolution layer

14+Copyright : (c) Huw Campbell, 2016-2017

15+License : BSD2

16+Stability : experimental

1417

18+This module provides the Convolution layer, which is critical in many computer vision tasks.

19+

20+-}

1521module Grenade.Layers.Convolution (

1622 Convolution (..)

1723 , Convolution' (..)

@@ -21,17 +27,18 @@ module Grenade.Layers.Convolution (

2127import Control.Monad.Random hiding ( fromList )

2228import Data.Maybe

2329import Data.Proxy

24−import Data.Singletons.TypeLits

30+import Data.Serialize

31+

2532import GHC.TypeLits

33+import Data.Kind (Type)

2634

2735import Numeric.LinearAlgebra hiding ( uniformSample, konst )

2836import qualified Numeric.LinearAlgebra as LA

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

3038

31−import Grenade.Core.Network

32−import Grenade.Core.Shape

33−import Grenade.Core.Vector

39+import Grenade.Core

3440import Grenade.Layers.Internal.Convolution

41+import Grenade.Layers.Internal.Update

3542

3643-- | A convolution layer for a neural network.

3744-- This uses the im2col convolution trick popularised by Caffe, which essentially turns the

@@ -44,13 +51,13 @@ import Grenade.Layers.Internal.Convolution

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

4552--

4653-- One probably shouldn't build their own layer, but rather use the randomConvolution function.

47−data Convolution :: Nat -- ^ Number of channels, for the first layer this could be RGB for instance.

48− -> Nat -- ^ Number of filters, this is the number of channels output by the layer.

49− -> Nat -- ^ The number of rows in the kernel filter

50− -> Nat -- ^ The number of column in the kernel filter

51− -> Nat -- ^ The row stride of the convolution filter

52− -> Nat -- ^ The columns stride of the convolution filter

53− -> * where

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

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

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

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

58+ -> Nat -- The row stride of the convolution filter

59+ -> Nat -- The columns stride of the convolution filter

60+ -> Type where

5461 Convolution :: ( KnownNat channels

5562 , KnownNat filters

5663 , KnownNat kernelRows

@@ -59,17 +66,17 @@ data Convolution :: Nat -- ^ Number of channels, for the first layer this could

5966 , KnownNat strideColumns

6067 , KnownNat kernelFlattened

6168 , kernelFlattened ~ (kernelRows * kernelColumns * channels))

62− => !(L kernelFlattened filters) -- ^ The kernel filter weights

63− -> !(L kernelFlattened filters) -- ^ The last kernel update (or momentum)

69+ => !(L kernelFlattened filters) -- The kernel filter weights

70+ -> !(L kernelFlattened filters) -- The last kernel update (or momentum)

6471 -> Convolution channels filters kernelRows kernelColumns strideRows strideColumns

6572

66−data Convolution' :: Nat -- ^ Number of channels, for the first layer this could be RGB for instance.

67− -> Nat -- ^ Number of filters, this is the number of channels output by the layer.

68− -> Nat -- ^ The number of rows in the kernel filter

69− -> Nat -- ^ The number of column in the kernel filter

70− -> Nat -- ^ The row stride of the convolution filter

71− -> Nat -- ^ The columns stride of the convolution filter

72− -> * where

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

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

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

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

77+ -> Nat -- The row stride of the convolution filter

78+ -> Nat -- The columns stride of the convolution filter

79+ -> Type where

7380 Convolution' :: ( KnownNat channels

7481 , KnownNat filters

7582 , KnownNat kernelRows

@@ -78,7 +85,7 @@ data Convolution' :: Nat -- ^ Number of channels, for the first layer this could

7885 , KnownNat strideColumns

7986 , KnownNat kernelFlattened

8087 , kernelFlattened ~ (kernelRows * kernelColumns * channels))

81− => !(L kernelFlattened filters) -- ^ The kernel filter gradient

88+ => !(L kernelFlattened filters) -- The kernel filter gradient

8289 -> Convolution' channels filters kernelRows kernelColumns strideRows strideColumns

8390

8491instance Show (Convolution c f k k' s s') where

@@ -110,7 +117,7 @@ randomConvolution :: ( MonadRandom m

110117 , kernelFlattened ~ (kernelRows * kernelColumns * channels))

111118 => m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

112119randomConvolution = do

113− s :: Int <- getRandom

120+ s <- getRandom

114121 let wN = uniformSample s (-1) 1

115122 mm = konst 0

116123 return $ Convolution wN mm

@@ -123,16 +130,30 @@ instance ( KnownNat channels

123130 , KnownNat strideColumns

124131 , KnownNat (kernelRows * kernelColumns * channels)

125132 ) => UpdateLayer (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where

126− type Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols) = (Convolution' channels filters kernelRows kernelCols strideRows strideCols)

127− runUpdate LearningParameters {..} (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =

128− let newMomentum = konst learningMomentum * oldMomentum - konst learningRate * kernelGradient

129− regulariser = konst (learningRegulariser * learningRate) * oldKernel

130− newKernel = oldKernel + newMomentum - regulariser

133+ type Gradient (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Convolution' channels filters kernelRows kernelColumns strideRows strideColumns)

134+ runUpdate lp (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =

135+ let (newKernel, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldKernel kernelGradient oldMomentum

131136 in Convolution newKernel newMomentum

132137

133138 createRandom = randomConvolution

134139

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

140+instance ( KnownNat channels

141+ , KnownNat filters

142+ , KnownNat kernelRows

143+ , KnownNat kernelColumns

144+ , KnownNat strideRows

145+ , KnownNat strideColumns

146+ , KnownNat (kernelRows * kernelColumns * channels)

147+ ) => Serialize (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where

148+ put (Convolution w _) = putListOf put . toList . flatten . extract $ w

149+ get = do

150+ let f = fromIntegral $ natVal (Proxy :: Proxy filters)

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

152+ let mm = konst 0

153+ return $ Convolution wN mm

154+

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

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

136157instance ( KnownNat kernelRows

137158 , KnownNat kernelCols

138159 , KnownNat filters

@@ -142,26 +163,33 @@ instance ( KnownNat kernelRows

142163 , KnownNat inputCols

143164 , KnownNat outputRows

144165 , KnownNat outputCols

166+ , KnownNat channels

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

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

147− , KnownNat (kernelRows * kernelCols * 1)

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

149− runForwards (Convolution kernel _) (S2D' input) =

169+ , KnownNat (kernelRows * kernelCols * channels)

170+ , KnownNat (outputRows * filters)

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

172+

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

174+

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

150176 let ex = extract input

151177 ek = extract kernel

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

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

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

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

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

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

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

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

158− c = im2colUnsafe kx ky sx sy ex

159− mt = c LA.<> ek

160− r = col2vidUnsafe 1 1 1 1 ox oy mt

161− rs = fmap (fromJust . create) r

162− in S3D' $ mkVector rs

163186

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

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

188+ mt = c LA.<> ek

189+ r = col2vid 1 1 1 1 ox oy mt

190+ rs = fromJust . create $ r

191+ in (S3D input, S3D rs)

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

165193 let ex = extract input

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

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

@@ -172,22 +200,22 @@ instance ( KnownNat kernelRows

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

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

174202

175− c = im2colUnsafe kx ky sx sy ex

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

176204

177− eo = vecToList $ fmap extract dEdy

205+ eo = extract dEdy

178206 ek = extract kernel

179207

180− vs = vid2colUnsafe 1 1 1 1 ox oy eo

208+ vs = vid2col 1 1 1 1 ox oy eo

181209

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

211+

183212 dW = vs LA.<> tr ek

184213

185− xW = col2imUnsafe kx ky sx sy ix iy dW

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

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

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

187216

188217

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

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

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

191219instance ( KnownNat kernelRows

192220 , KnownNat kernelCols

193221 , KnownNat filters

@@ -197,49 +225,63 @@ instance ( KnownNat kernelRows

197225 , KnownNat inputCols

198226 , KnownNat outputRows

199227 , KnownNat outputCols

200− , KnownNat channels

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

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

203− , KnownNat (kernelRows * kernelCols * channels)

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

205− runForwards (Convolution kernel _) (S3D' input) =

206− let ex = vecToList $ fmap extract input

207− ek = extract kernel

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

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

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

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

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

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

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

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

216−

217− c = vid2colUnsafe kx ky sx sy ix iy ex

218− mt = c LA.<> ek

219− r = col2vidUnsafe 1 1 1 1 ox oy mt

220− rs = fmap (fromJust . create) r

221− in S3D' $ mkVector rs

222− runBackwards (Convolution kernel _) (S3D' input) (S3D' dEdy) =

223− let ex = vecToList $ fmap extract input

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

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

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

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

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

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

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

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

230+ , KnownNat (kernelRows * kernelCols * 1)

231+ , KnownNat (outputRows * filters)

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

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

234+ runForwards c (S2D input) =

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

232236

233− c = vid2colUnsafe kx ky sx sy ix iy ex

237+ runBackwards c tape grads =

238+ case runBackwards c tape grads of

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

234240

235− eo = vecToList $ fmap extract dEdy

236− ek = extract kernel

237241

238− vs = vid2colUnsafe 1 1 1 1 ox oy eo

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

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

244+instance ( KnownNat kernelRows

245+ , KnownNat kernelCols

246+ , KnownNat strideRows

247+ , KnownNat strideCols

248+ , KnownNat inputRows

249+ , KnownNat inputCols

250+ , KnownNat outputRows

251+ , KnownNat outputCols

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

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

254+ , KnownNat (kernelRows * kernelCols * 1)

255+ , KnownNat (outputRows * 1)

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

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

258+ runForwards c (S2D input) =

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

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

239261

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

262+ runBackwards c tape (S2D grads) =

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

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

241265

242− dW = vs LA.<> tr ek

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

267+instance ( KnownNat kernelRows

268+ , KnownNat kernelCols

269+ , KnownNat strideRows

270+ , KnownNat strideCols

271+ , KnownNat inputRows

272+ , KnownNat inputCols

273+ , KnownNat outputRows

274+ , KnownNat outputCols

275+ , KnownNat channels

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

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

278+ , KnownNat (kernelRows * kernelCols * channels)

279+ , KnownNat (outputRows * 1)

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

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

282+ runForwards c input =

283+ case runForwards c input of

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

243285

244− xW = col2vidUnsafe kx ky sx sy ix iy dW

245− in (Convolution' kN, S3D' . mkVector . fmap (fromJust . create) $ xW)

286+ runBackwards c tape (S2D grads) =

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

src/Grenade/Layers/Crop.hs+72−14

@@ -1,24 +1,32 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE GADTs #-}

45{-# LANGUAGE TypeOperators #-}

56{-# LANGUAGE TypeFamilies #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE FlexibleInstances #-}

87{-# LANGUAGE FlexibleContexts #-}

9−{-# LANGUAGE PolyKinds #-}

10−

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+{-|

11+Module : Grenade.Layers.Crop

12+Description : Cropping layer

13+Copyright : (c) Huw Campbell, 2016-2017

14+License : BSD2

15+Stability : experimental

16+-}

1117module Grenade.Layers.Crop (

1218 Crop (..)

1319 ) where

1420

1521import Data.Maybe

1622import Data.Proxy

17−import Data.Singletons.TypeLits

23+import Data.Serialize

24+

1825import GHC.TypeLits

26+import Data.Kind (Type)

1927

20−import Grenade.Core.Network

21−import Grenade.Core.Shape

28+import Grenade.Core

29+import Grenade.Layers.Internal.Pad

2230

2331import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)

2432import Numeric.LinearAlgebra.Static (extract, create)

@@ -27,7 +35,7 @@ import Numeric.LinearAlgebra.Static (extract, create)

2735data Crop :: Nat

2836 -> Nat

2937 -> Nat

30− -> Nat -> * where

38+ -> Nat -> Type where

3139 Crop :: Crop cropLeft cropTop cropRight cropBottom

3240

3341instance Show (Crop cropLeft cropTop cropRight cropBottom) where

@@ -38,6 +46,10 @@ instance UpdateLayer (Crop l t r b) where

3846 runUpdate _ x _ = x

3947 createRandom = return Crop

4048

49+instance Serialize (Crop l t r b) where

50+ put _ = return ()

51+ get = return Crop

52+

4153-- | A two dimentional image can be cropped.

4254instance ( KnownNat cropLeft

4355 , KnownNat cropTop

@@ -47,22 +59,68 @@ instance ( KnownNat cropLeft

4759 , KnownNat inputColumns

4860 , KnownNat outputRows

4961 , KnownNat outputColumns

50− , (inputRows - cropTop - cropBottom) ~ outputRows

51− , (inputColumns - cropLeft - cropRight) ~ outputColumns

62+ , (outputRows + cropTop + cropBottom) ~ inputRows

63+ , (outputColumns + cropLeft + cropRight) ~ inputColumns

5264 ) => Layer (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where

53− runForwards Crop (S2D' input) =

65+ type Tape (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = ()

66+ runForwards Crop (S2D input) =

5467 let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)

5568 cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)

5669 nrows = fromIntegral $ natVal (Proxy :: Proxy outputRows)

5770 ncols = fromIntegral $ natVal (Proxy :: Proxy outputColumns)

5871 m = extract input

5972 r = subMatrix (cropt, cropl) (nrows, ncols) m

60− in S2D' . fromJust . create $ r

61− runBackwards _ _ (S2D' dEdy) =

73+ in ((), S2D . fromJust . create $ r)

74+ runBackwards _ _ (S2D dEdy) =

6275 let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)

6376 cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)

6477 cropr = fromIntegral $ natVal (Proxy :: Proxy cropRight)

6578 cropb = fromIntegral $ natVal (Proxy :: Proxy cropBottom)

6679 eo = extract dEdy

6780 vs = diagBlock [konst 0 (cropt,cropl), eo, konst 0 (cropb,cropr)]

68− in ((), S2D' . fromJust . create $ vs)

81+ in ((), S2D . fromJust . create $ vs)

82+

83+

84+-- | A two dimentional image can be cropped.

85+instance ( KnownNat cropLeft

86+ , KnownNat cropTop

87+ , KnownNat cropRight

88+ , KnownNat cropBottom

89+ , KnownNat inputRows

90+ , KnownNat inputColumns

91+ , KnownNat outputRows

92+ , KnownNat outputColumns

93+ , KnownNat channels

94+ , KnownNat (inputRows * channels)

95+ , KnownNat (outputRows * channels)

96+ , (outputRows + cropTop + cropBottom) ~ inputRows

97+ , (outputColumns + cropLeft + cropRight) ~ inputColumns

98+ ) => Layer (Crop cropLeft cropTop cropRight cropBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where

99+ type Tape (Crop cropLeft cropTop cropRight cropBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) = ()

100+ runForwards Crop (S3D input) =

101+ let padl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)

102+ padt = fromIntegral $ natVal (Proxy :: Proxy cropTop)

103+ padr = fromIntegral $ natVal (Proxy :: Proxy cropRight)

104+ padb = fromIntegral $ natVal (Proxy :: Proxy cropBottom)

105+ inr = fromIntegral $ natVal (Proxy :: Proxy inputRows)

106+ inc = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

107+ outr = fromIntegral $ natVal (Proxy :: Proxy outputRows)

108+ outc = fromIntegral $ natVal (Proxy :: Proxy outputColumns)

109+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)

110+ m = extract input

111+ cropped = crop ch padl padt padr padb outr outc inr inc m

112+ in ((), S3D . fromJust . create $ cropped)

113+

114+ runBackwards Crop () (S3D gradient) =

115+ let padl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)

116+ padt = fromIntegral $ natVal (Proxy :: Proxy cropTop)

117+ padr = fromIntegral $ natVal (Proxy :: Proxy cropRight)

118+ padb = fromIntegral $ natVal (Proxy :: Proxy cropBottom)

119+ inr = fromIntegral $ natVal (Proxy :: Proxy inputRows)

120+ inc = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

121+ outr = fromIntegral $ natVal (Proxy :: Proxy outputRows)

122+ outc = fromIntegral $ natVal (Proxy :: Proxy outputColumns)

123+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)

124+ m = extract gradient

125+ padded = pad ch padl padt padr padb outr outc inr inc m

126+ in ((), S3D . fromJust . create $ padded)

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

@@ -0,0 +1,285 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+{-|

12+Module : Grenade.Layers.Deconvolution

13+Description : Deconvolution layer

14+Copyright : (c) Huw Campbell, 2016-2017

15+License : BSD2

16+Stability : experimental

17+

18+A deconvolution layer is in many ways a convolution layer in reverse.

19+It learns a kernel to apply to each pixel location, spreading it out

20+into a larger layer.

21+

22+This layer is important for image generation tasks, such as GANs on

23+images.

24+-}

25+module Grenade.Layers.Deconvolution (

26+ Deconvolution (..)

27+ , Deconvolution' (..)

28+ , randomDeconvolution

29+ ) where

30+

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

32+import Data.Maybe

33+import Data.Proxy

34+import Data.Serialize

35+

36+import GHC.TypeLits

37+import Data.Kind (Type)

38+

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

40+import qualified Numeric.LinearAlgebra as LA

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

42+

43+import Grenade.Core

44+import Grenade.Layers.Internal.Convolution

45+import Grenade.Layers.Internal.Update

46+

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

48+-- This uses the im2col Convolution trick popularised by Caffe.

49+--

50+-- The Deconvolution layer is a way of spreading out a single response

51+-- into a larger image, and is useful in generating images.

52+--

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

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

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

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

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

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

59+ -> Type where

60+ Deconvolution :: ( KnownNat channels

61+ , KnownNat filters

62+ , KnownNat kernelRows

63+ , KnownNat kernelColumns

64+ , KnownNat strideRows

65+ , KnownNat strideColumns

66+ , KnownNat kernelFlattened

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

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

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

70+ -> Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns

71+

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

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

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

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

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

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

78+ -> Type where

79+ Deconvolution' :: ( KnownNat channels

80+ , KnownNat filters

81+ , KnownNat kernelRows

82+ , KnownNat kernelColumns

83+ , KnownNat strideRows

84+ , KnownNat strideColumns

85+ , KnownNat kernelFlattened

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

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

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

89+

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

91+ show (Deconvolution a _) = renderConv a

92+ where

93+ renderConv mm =

94+ let m = extract mm

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

96+ rs = LA.toColumns m

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

98+

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

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

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

102+ | n' <= 0.8 = '='

103+ | otherwise = '#'

104+

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

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

107+

108+randomDeconvolution :: ( MonadRandom m

109+ , KnownNat channels

110+ , KnownNat filters

111+ , KnownNat kernelRows

112+ , KnownNat kernelColumns

113+ , KnownNat strideRows

114+ , KnownNat strideColumns

115+ , KnownNat kernelFlattened

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

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

118+randomDeconvolution = do

119+ s <- getRandom

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

121+ mm = konst 0

122+ return $ Deconvolution wN mm

123+

124+instance ( KnownNat channels

125+ , KnownNat filters

126+ , KnownNat kernelRows

127+ , KnownNat kernelColumns

128+ , KnownNat strideRows

129+ , KnownNat strideColumns

130+ , KnownNat (kernelRows * kernelColumns * filters)

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

132+ type Gradient (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns)

133+ runUpdate lp (Deconvolution oldKernel oldMomentum) (Deconvolution' kernelGradient) =

134+ let (newKernel, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldKernel kernelGradient oldMomentum

135+ in Deconvolution newKernel newMomentum

136+

137+ createRandom = randomDeconvolution

138+

139+instance ( KnownNat channels

140+ , KnownNat filters

141+ , KnownNat kernelRows

142+ , KnownNat kernelColumns

143+ , KnownNat strideRows

144+ , KnownNat strideColumns

145+ , KnownNat (kernelRows * kernelColumns * filters)

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

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

148+ get = do

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

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

151+ let mm = konst 0

152+ return $ Deconvolution wN mm

153+

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

155+instance ( KnownNat kernelRows

156+ , KnownNat kernelCols

157+ , KnownNat filters

158+ , KnownNat strideRows

159+ , KnownNat strideCols

160+ , KnownNat inputRows

161+ , KnownNat inputCols

162+ , KnownNat outputRows

163+ , KnownNat outputCols

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

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

166+ , KnownNat (kernelRows * kernelCols * filters)

167+ , KnownNat (outputRows * filters)

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

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

170+ runForwards c (S2D input) =

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

172+

173+ runBackwards c tape grads =

174+ case runBackwards c tape grads of

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

176+

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

178+instance ( KnownNat kernelRows

179+ , KnownNat kernelCols

180+ , KnownNat strideRows

181+ , KnownNat strideCols

182+ , KnownNat inputRows

183+ , KnownNat inputCols

184+ , KnownNat outputRows

185+ , KnownNat outputCols

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

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

188+ , KnownNat (kernelRows * kernelCols * 1)

189+ , KnownNat (outputRows * 1)

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

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

192+ runForwards c (S2D input) =

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

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

195+

196+ runBackwards c tape (S2D grads) =

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

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

199+

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

201+instance ( KnownNat kernelRows

202+ , KnownNat kernelCols

203+ , KnownNat strideRows

204+ , KnownNat strideCols

205+ , KnownNat inputRows

206+ , KnownNat inputCols

207+ , KnownNat outputRows

208+ , KnownNat outputCols

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

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

211+ , KnownNat (kernelRows * kernelCols * 1)

212+ , KnownNat (outputRows * 1)

213+ , KnownNat channels

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

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

216+ runForwards c input =

217+ case runForwards c input of

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

219+

220+ runBackwards c tape (S2D grads) =

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

222+

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

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

225+instance ( KnownNat kernelRows

226+ , KnownNat kernelCols

227+ , KnownNat filters

228+ , KnownNat strideRows

229+ , KnownNat strideCols

230+ , KnownNat inputRows

231+ , KnownNat inputCols

232+ , KnownNat outputRows

233+ , KnownNat outputCols

234+ , KnownNat channels

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

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

237+ , KnownNat (kernelRows * kernelCols * filters)

238+ , KnownNat (outputRows * filters)

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

240+

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

242+

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

244+ let ex = extract input

245+ ek = extract kernel

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

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

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

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

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

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

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

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

254+

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

256+

257+ mt = c LA.<> tr ek

258+

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

260+ rs = fromJust . create $ r

261+ in (S3D input, S3D rs)

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

263+ let ex = extract input

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

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

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

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

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

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

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

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

272+

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

274+

275+ eo = extract dEdy

276+ ek = extract kernel

277+

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

279+

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

281+

282+ dW = vs LA.<> ek

283+

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

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

src/Grenade/Layers/Dropout.hs+14−28

@@ -1,12 +1,7 @@

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

32{-# LANGUAGE TypeOperators #-}

43{-# LANGUAGE TypeFamilies #-}

54{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE FlexibleContexts #-}

7−{-# LANGUAGE FlexibleInstances #-}

8−{-# LANGUAGE LambdaCase #-}

9−

105module Grenade.Layers.Dropout (

116 Dropout (..)

127 , randomDropout

@@ -15,37 +10,28 @@ module Grenade.Layers.Dropout (

1510import Control.Monad.Random hiding (fromList)

1611

1712import GHC.TypeLits

18−import Grenade.Core.Shape

19−import Grenade.Core.Network

20−

21−import Numeric.LinearAlgebra.Static

22−

13+import Grenade.Core

2314

2415-- Dropout layer help to reduce overfitting.

2516-- Idea here is that the vector is a shape of 1s and 0s, which we multiply the input by.

2617-- After backpropogation, we return a new matrix/vector, with different bits dropped out.

2718-- Double is the proportion to drop in each training iteration (like 1% or 5% would be

2819-- reasonable).

29−data Dropout o =

30− Dropout (R o)

31− | Pass Double

32− deriving Show

20+data Dropout = Dropout {

21+ dropoutRate :: Double

22+ , dropoutSeed :: Int

23+ } deriving Show

3324

34−instance (KnownNat i) => UpdateLayer (Dropout i) where

35− type Gradient (Dropout i) = ()

25+instance UpdateLayer Dropout where

26+ type Gradient Dropout = ()

3627 runUpdate _ x _ = x

3728 createRandom = randomDropout 0.95

3829

39−randomDropout :: (MonadRandom m, KnownNat i)

40− => Double -> m (Dropout i)

41−randomDropout rate = do

42− seed <- getRandom

43− let wN = randomVector seed Uniform

44− xs = dvmap (\a -> if a <= rate then 0 else 1) wN

45− return $ Dropout xs

30+randomDropout :: MonadRandom m

31+ => Double -> m Dropout

32+randomDropout rate = Dropout rate <$> getRandom

4633

47−instance (KnownNat i) => Layer (Dropout i) ('D1 i) ('D1 i) where

48− runForwards (Dropout drops) (S1D' x) = S1D' $ x * drops

49− runForwards (Pass rate) (S1D' x)= S1D' $ dvmap (* (1 - rate)) x

50− runBackwards (Dropout drops) _ (S1D' x) = ((), S1D' $ x * drops)

51− runBackwards (Pass rate) _ (S1D' x) = ((), S1D' $ dvmap (* (1 - rate)) x)

34+instance (KnownNat i) => Layer Dropout ('D1 i) ('D1 i) where

35+ type Tape Dropout ('D1 i) ('D1 i) = ()

36+ runForwards (Dropout _ _) (S1D x) = ((), S1D x)

37+ runBackwards (Dropout _ _) _ (S1D x) = ((), S1D x)

src/Grenade/Layers/Elu.hsnew file+67

@@ -0,0 +1,67 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-|

6+Module : Grenade.Layers.Logit

7+Description : Exponential linear unit layer

8+Copyright : (c) Huw Campbell, 2016-2017

9+License : BSD2

10+Stability : experimental

11+-}

12+module Grenade.Layers.Elu (

13+ Elu (..)

14+ ) where

15+

16+import Data.Serialize

17+

18+import GHC.TypeLits

19+import Grenade.Core

20+

21+import qualified Numeric.LinearAlgebra.Static as LAS

22+

23+-- | An exponential linear unit.

24+-- A layer which can act between any shape of the same dimension, acting as a

25+-- diode on every neuron individually.

26+data Elu = Elu

27+ deriving Show

28+

29+instance UpdateLayer Elu where

30+ type Gradient Elu = ()

31+ runUpdate _ _ _ = Elu

32+ createRandom = return Elu

33+

34+instance Serialize Elu where

35+ put _ = return ()

36+ get = return Elu

37+

38+instance ( KnownNat i) => Layer Elu ('D1 i) ('D1 i) where

39+ type Tape Elu ('D1 i) ('D1 i) = LAS.R i

40+

41+ runForwards _ (S1D y) = (y, S1D (elu y))

42+ where

43+ elu = LAS.dvmap (\a -> if a <= 0 then exp a - 1 else a)

44+ runBackwards _ y (S1D dEdy) = ((), S1D (elu' y * dEdy))

45+ where

46+ elu' = LAS.dvmap (\a -> if a <= 0 then exp a else 1)

47+

48+instance (KnownNat i, KnownNat j) => Layer Elu ('D2 i j) ('D2 i j) where

49+ type Tape Elu ('D2 i j) ('D2 i j) = S ('D2 i j)

50+

51+ runForwards _ (S2D y) = (S2D y, S2D (elu y))

52+ where

53+ elu = LAS.dmmap (\a -> if a <= 0 then exp a - 1 else a)

54+ runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (elu' y * dEdy))

55+ where

56+ elu' = LAS.dmmap (\a -> if a <= 0 then exp a else 1)

57+

58+instance (KnownNat i, KnownNat j, KnownNat k) => Layer Elu ('D3 i j k) ('D3 i j k) where

59+

60+ type Tape Elu ('D3 i j k) ('D3 i j k) = S ('D3 i j k)

61+

62+ runForwards _ (S3D y) = (S3D y, S3D (elu y))

63+ where

64+ elu = LAS.dmmap (\a -> if a <= 0 then exp a - 1 else a)

65+ runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (elu' y * dEdy))

66+ where

67+ elu' = LAS.dmmap (\a -> if a <= 0 then exp a else 1)

src/Grenade/Layers/Flatten.hsdeleted−51

@@ -1,51 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE StandaloneDeriving #-}

5−{-# LANGUAGE TypeOperators #-}

6−{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE FlexibleInstances #-}

9−

10−module Grenade.Layers.Flatten (

11− FlattenLayer (..)

12− ) where

13−

14−import Data.Proxy

15−import Data.Singletons.TypeLits

16−import GHC.TypeLits

17−

18−import Numeric.LinearAlgebra.Static

19−import Numeric.LinearAlgebra.Data as LA (flatten, toList, takesV, reshape, vjoin)

20−

21−import Grenade.Core.Vector

22−import Grenade.Core.Shape

23−import Grenade.Core.Network

24−

25−data FlattenLayer = FlattenLayer

26− deriving Show

27−

28−instance UpdateLayer FlattenLayer where

29− type Gradient FlattenLayer = ()

30− runUpdate _ _ _ = FlattenLayer

31− createRandom = return FlattenLayer

32−

33−

34−instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer FlattenLayer ('D2 x y) ('D1 a) where

35− runForwards _ (S2D' y) = S1D' . fromList . toList . flatten . extract $ y

36− runBackwards _ _ (S1D' y) = ((), S2D' . fromList . toList . unwrap $ y)

37−

38−instance (KnownNat a, KnownNat x, KnownNat y, KnownNat z, a ~ (x * y * z)) => Layer FlattenLayer ('D3 x y z) ('D1 a) where

39− runForwards _ (S3D' y) = S1D' . raiseShapeError . create . vjoin . vecToList . fmap (flatten . extract) $ y

40− runBackwards _ _ (S1D' o) =

41− let x' = fromIntegral $ natVal (Proxy :: Proxy x)

42− y' = fromIntegral $ natVal (Proxy :: Proxy y)

43− z' = fromIntegral $ natVal (Proxy :: Proxy z)

44− vecs = takesV (replicate z' (x' * y')) (extract o)

45− ls = fmap (raiseShapeError . create . reshape y') vecs

46− ls' = mkVector ls :: Vector z (L x y)

47− in ((), S3D' ls')

48−

49−raiseShapeError :: Maybe a -> a

50−raiseShapeError (Just x) = x

51−raiseShapeError Nothing = error "Static shape creation from Flatten layer produced the wrong result"

src/Grenade/Layers/FullyConnected.hs+37−26

@@ -1,35 +1,35 @@

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE RecordWildCards #-}

42{-# LANGUAGE TypeOperators #-}

53{-# LANGUAGE TypeFamilies #-}

64{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE FlexibleInstances #-}

8−

5+{-# LANGUAGE ScopedTypeVariables #-}

96module Grenade.Layers.FullyConnected (

107 FullyConnected (..)

8+ , FullyConnected' (..)

119 , randomFullyConnected

1210 ) where

1311

1412import Control.Monad.Random hiding (fromList)

1513

16−import Data.Singletons.TypeLits

14+import Data.Proxy

15+import Data.Serialize

1716

17+import qualified Numeric.LinearAlgebra as LA

1818import Numeric.LinearAlgebra.Static

1919

20−import Grenade.Core.Network

21−import Grenade.Core.Shape

20+import Grenade.Core

21+

22+import Grenade.Layers.Internal.Update

23+import GHC.TypeLits

2224

2325-- | A basic fully connected (or inner product) neural network layer.

2426data FullyConnected i o = FullyConnected

25− !(R o) -- Bias neuron weights

26− !(R o) -- Bias neuron momentum

27− !(L o i) -- Activation weights

28− !(L o i) -- Momentum

27+ !(FullyConnected' i o) -- Neuron weights

28+ !(FullyConnected' i o) -- Neuron momentum

2929

3030data FullyConnected' i o = FullyConnected'

31− !(R o) -- Bias neuron gradient

32− !(L o i) -- Activation gradient

31+ !(R o) -- Bias

32+ !(L o i) -- Activations

3333

3434instance Show (FullyConnected i o) where

3535 show FullyConnected {} = "FullyConnected"

@@ -37,35 +37,46 @@ instance Show (FullyConnected i o) where

3737instance (KnownNat i, KnownNat o) => UpdateLayer (FullyConnected i o) where

3838 type Gradient (FullyConnected i o) = (FullyConnected' i o)

3939

40− runUpdate LearningParameters {..} (FullyConnected oldBias oldBiasMomentum oldActivations oldMomentum) (FullyConnected' biasGradient activationGradient) =

41− let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient

42− newBias = oldBias + newBiasMomentum

43− newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient

44− regulariser = konst (learningRegulariser * learningRate) * oldActivations

45− newActivations = oldActivations + newMomentum - regulariser

46− in FullyConnected newBias newBiasMomentum newActivations newMomentum

40+ runUpdate lp (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =

41+ let (newBias, newBiasMomentum) = descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldBias biasGradient oldBiasMomentum

42+ (newActivations, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldActivations activationGradient oldMomentum

43+ in FullyConnected (FullyConnected' newBias newActivations) (FullyConnected' newBiasMomentum newMomentum)

4744

4845 createRandom = randomFullyConnected

4946

5047instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o) where

48+ type Tape (FullyConnected i o) ('D1 i) ('D1 o) = R i

5149 -- Do a matrix vector multiplication and return the result.

52− runForwards (FullyConnected wB _ wN _) (S1D' v) = S1D' (wB + wN #> v)

50+ runForwards (FullyConnected (FullyConnected' wB wN) _) (S1D v) = (v, S1D (wB + wN #> v))

5351

5452 -- Run a backpropogation step for a full connected layer.

55− runBackwards (FullyConnected _ _ wN _) (S1D' x) (S1D' dEdy) =

53+ runBackwards (FullyConnected (FullyConnected' _ wN) _) x (S1D dEdy) =

5654 let wB' = dEdy

5755 mm' = dEdy `outer` x

5856 -- calcluate derivatives for next step

5957 dWs = tr wN #> dEdy

60− in (FullyConnected' wB' mm', S1D' dWs)

58+ in (FullyConnected' wB' mm', S1D dWs)

59+

60+instance (KnownNat i, KnownNat o) => Serialize (FullyConnected i o) where

61+ put (FullyConnected (FullyConnected' b w) _) = do

62+ putListOf put . LA.toList . extract $ b

63+ putListOf put . LA.toList . LA.flatten . extract $ w

64+

65+ get = do

66+ let f = fromIntegral $ natVal (Proxy :: Proxy i)

67+ b <- maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

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

69+ let bm = konst 0

70+ let mm = konst 0

71+ return $ FullyConnected (FullyConnected' b k) (FullyConnected' bm mm)

6172

6273randomFullyConnected :: (MonadRandom m, KnownNat i, KnownNat o)

6374 => m (FullyConnected i o)

6475randomFullyConnected = do

65− s1 :: Int <- getRandom

66− s2 :: Int <- getRandom

76+ s1 <- getRandom

77+ s2 <- getRandom

6778 let wB = randomVector s1 Uniform * 2 - 1

6879 wN = uniformSample s2 (-1) 1

6980 bm = konst 0

7081 mm = konst 0

71− return $ FullyConnected wB bm wN mm

82+ return $ FullyConnected (FullyConnected' wB wN) (FullyConnected' bm mm)

src/Grenade/Layers/Fuse.hsdeleted−52

@@ -1,52 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeOperators #-}

7−{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE FlexibleContexts #-}

11−{-# LANGUAGE FlexibleInstances #-}

12−

13−

14−module Grenade.Layers.Fuse (

15− Fuse (..)

16− ) where

17−

18−import Grenade.Core.Network

19−import Grenade.Core.Shape

20−

21−-- | Fuse two layers into one layer.

22−-- This can be used to simplify a network if a complicated repeated structure is used.

23−-- This does however have a trade off, internal incremental states in the Wengert tape are

24−-- not retained during reverse accumulation. So less RAM is used, but more compute is required.

25−data Fuse :: * -> * -> Shape -> Shape -> Shape -> * where

26− (:$$) :: (Layer x i h, Layer y h o)

27− => !x

28− -> !y

29− -> Fuse x y i h o

30−infixr 5 :$$

31−

32−instance (Show x, Show y) => Show (Fuse x y i h o) where

33− show (x :$$ y) = "(" ++ show x ++ " :$$ " ++ show y ++ ")"

34−

35−instance (Layer x i h, Layer y h o) => UpdateLayer (Fuse x y i h o) where

36− type Gradient (Fuse x y i h o) = (Gradient x, Gradient y)

37− runUpdate lr (x :$$ y) (x', y') =

38− let newX = runUpdate lr x x'

39− newY = runUpdate lr y y'

40− in (newX :$$ newY)

41− createRandom = (:$$) <$> createRandom <*> createRandom

42−

43−instance (Layer x i h, Layer y h o) => Layer (Fuse x y i h o) i o where

44− runForwards (x :$$ y) input =

45− let yInput :: S' h = runForwards x input

46− in runForwards y yInput

47−

48− runBackwards (x :$$ y) input backGradient =

49− let yInput :: S' h = runForwards x input

50− (y', yGrad) = runBackwards y yInput backGradient

51− (x', xGrad) = runBackwards x input yGrad

52− in ((x', y'), xGrad)

src/Grenade/Layers/Inception.hsnew file+67

@@ -0,0 +1,67 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE TypeOperators #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE FlexibleContexts #-}

7+{-# LANGUAGE RankNTypes #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-|

11+Module : Grenade.Core.Network

12+Description : Inception style parallel convolutional network composition.

13+Copyright : (c) Huw Campbell, 2016-2017

14+License : BSD2

15+Stability : experimental

16+

17+Export an Inception style type, which can be used to build up

18+complex multiconvolution size networks.

19+-}

20+module Grenade.Layers.Inception (

21+ Inception

22+ , InceptionMini

23+ , Resnet

24+ ) where

25+

26+import GHC.TypeLits

27+

28+import Grenade.Core

29+import Grenade.Layers.Convolution

30+import Grenade.Layers.Pad

31+import Grenade.Layers.Concat

32+import Grenade.Layers.Merge

33+import Grenade.Layers.Trivial

34+

35+-- | Type of an inception layer.

36+--

37+-- It looks like a bit of a handful, but is actually pretty easy to use.

38+--

39+-- The first three type parameters are the size of the (3D) data the

40+-- inception layer will take. It will emit 3D data with the number of

41+-- channels being the sum of @chx@, @chy@, @chz@, which are the number

42+-- of convolution filters in the 3x3, 5x5, and 7x7 convolutions Layers

43+-- respectively.

44+--

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

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

47+type Inception rows cols channels chx chy chz

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

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

50+

51+type InceptionMini rows cols channels chx chy

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

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

54+

55+type Inception3x3 rows cols channels chx

56+ = Network '[ Pad 1 1 1 1, Convolution channels chx 3 3 1 1 ]

57+ '[ 'D3 rows cols channels, 'D3 (rows + 2) (cols + 2) channels, 'D3 rows cols chx ]

58+

59+type Inception5x5 rows cols channels chx

60+ = Network '[ Pad 2 2 2 2, Convolution channels chx 5 5 1 1 ]

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

62+

63+type Inception7x7 rows cols channels chx

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

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

66+

67+type Resnet branch = Merge Trivial branch

src/Grenade/Layers/Internal/Convolution.hs+69−180

@@ -1,191 +1,80 @@

1+{-# LANGUAGE ForeignFunctionInterface #-}

12module Grenade.Layers.Internal.Convolution (

2− col2vidUnsafe

3− , col2imUnsafe

4− , vid2colUnsafe

5− , im2colUnsafe

6− , fittingStarts

3+ im2col

4+ , col2im

5+ , col2vid

6+ , vid2col

77 ) where

88

9−import Control.Monad.ST ( runST )

9+import qualified Data.Vector.Storable as U ( unsafeToForeignPtr0, unsafeFromForeignPtr0 )

1010

11−import Data.STRef ( newSTRef, modifySTRef, writeSTRef, readSTRef )

12−import Data.Foldable ( forM_ )

13−import Data.Traversable ( forM )

11+import Foreign ( mallocForeignPtrArray, withForeignPtr )

12+import Foreign.Ptr ( Ptr )

1413

15−import Numeric.LinearAlgebra hiding ( uniformSample, konst )

14+import Numeric.LinearAlgebra ( Matrix, flatten, rows, cols )

1615import qualified Numeric.LinearAlgebra.Devel as U

1716

18−-- This module provides provides im2col function and friends, ala caffe.

19−--

20−-- /* From Caffe */

21−-- @

22−-- void col2im_cpu(const Dtype* data_col, const int channels,

23−-- const int height, const int width, const int kernel_h, const int kernel_w,

24−-- const int pad_h, const int pad_w,

25−-- const int stride_h, const int stride_w,

26−-- const int dilation_h, const int dilation_w,

27−-- Dtype* data_im) {

28−-- caffe_set(height * width * channels, Dtype(0), data_im);

29−-- const int output_h = (height + 2 * pad_h -

30−-- (dilation_h * (kernel_h - 1) + 1)) / stride_h + 1;

31−-- const int output_w = (width + 2 * pad_w -

32−-- (dilation_w * (kernel_w - 1) + 1)) / stride_w + 1;

33−-- const int channel_size = height * width;

34−-- for (int channel = channels; channel--; data_im += channel_size) {

35−-- for (int kernel_row = 0; kernel_row < kernel_h; kernel_row++) {

36−-- for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {

37−-- int input_row = -pad_h + kernel_row * dilation_h;

38−-- for (int output_rows = output_h; output_rows; output_rows--) {

39−-- if (!is_a_ge_zero_and_a_lt_b(input_row, height)) {

40−-- data_col += output_w;

41−-- } else {

42−-- int input_col = -pad_w + kernel_col * dilation_w;

43−-- for (int output_col = output_w; output_col; output_col--) {

44−-- if (is_a_ge_zero_and_a_lt_b(input_col, width)) {

45−-- data_im[input_row * width + input_col] += *data_col;

46−-- }

47−-- data_col++;

48−-- input_col += stride_w;

49−-- }

50−-- }

51−-- input_row += stride_h;

52−-- }

53−-- }

54−-- }

55−-- }

56−-- }

57−-- @

58−--

59−

60−-- | col2im function.

61−--

62−-- Takes a column patch, and reconstitutes it into a normal image.

63−-- Does not do any bounds checking on the matrix, so should only

64−-- be called once the sizes are ensured correct.

65−col2imUnsafe :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

66−col2imUnsafe kernelRows kernelColumns strideRows strideColumns destinationRows destinationCols columnMatrix = U.runSTMatrix $ do

67− let columnMatrixRows = rows columnMatrix

68−

69− dataIm <- U.newMatrix 0 destinationRows destinationCols

70− offsetR <- newSTRef 0

71− offsetC <- newSTRef 0

72−

73− forM_ [0 .. columnMatrixRows - 1] $ \inputRow -> do

74− inputColumnRef <- newSTRef 0

75− forM_ [0 .. kernelRows -1] $ \kr ->

76− forM_ [0 .. kernelColumns -1] $ \kc -> do

77− inputColumn <- readSTRef inputColumnRef

78− offsetR' <- readSTRef offsetR

79− offsetC' <- readSTRef offsetC

80− U.modifyMatrix dataIm (kr + offsetR') (kc + offsetC') (+ U.atM' columnMatrix inputRow inputColumn)

81− modifySTRef inputColumnRef (+1)

82−

83− offsetC' <- readSTRef offsetC

84− if offsetC' + kernelColumns < destinationCols

85− then modifySTRef offsetC (+ strideColumns)

86− else writeSTRef offsetC 0 >> modifySTRef offsetR (+ strideRows)

87−

88− return dataIm

89−

90−-- | col2vid function.

91−--

92−-- Takes a column patch image, and reconstitutes it into a normal image with multiple channels.

93−-- Does not do any bounds checking on the matrix, so should only

94−-- be called once the sizes are ensured correct.

95−col2vidUnsafe :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> [Matrix Double]

96−col2vidUnsafe kernelRows kernelColumns strideRows strideColumns destinationRows destinationCols columnMatrix = runST $ do

97− let columnMatrixRows = rows columnMatrix

98− let filters = cols columnMatrix `div` (kernelRows * kernelColumns)

99−

100− forM [0 .. filters - 1] $ \iter -> do

101− let offsetM = iter * (kernelRows * kernelColumns)

102− dataIm <- U.newMatrix 0 destinationRows destinationCols

103− offsetR <- newSTRef 0

104− offsetC <- newSTRef 0

105− forM_ [0 .. columnMatrixRows - 1] $ \ir -> do

106− inputColumn <- newSTRef 0

107− forM_ [0 .. kernelRows -1] $ \kr ->

108− forM_ [0 .. kernelColumns -1] $ \kc -> do

109− ic <- readSTRef inputColumn

110− offsetR' <- readSTRef offsetR

111− offsetC' <- readSTRef offsetC

112− U.modifyMatrix dataIm (kr + offsetR') (kc + offsetC') (+ U.atM' columnMatrix ir (ic + offsetM))

113− modifySTRef inputColumn (+1)

114−

115− offsetC' <- readSTRef offsetC

116− if offsetC' + kernelColumns < destinationCols

117− then modifySTRef offsetC (+ strideColumns)

118− else writeSTRef offsetC 0 >> modifySTRef offsetR (+ strideRows)

119−

120− U.unsafeFreezeMatrix dataIm

121−

122−vid2colUnsafe :: Int -> Int -> Int -> Int -> Int -> Int -> [Matrix Double] -> Matrix Double

123−vid2colUnsafe kernelRows kernelColumns striderows stridecols vidrows vidcols dataVid = U.runSTMatrix $ do

124− let starts = fittingStarts vidrows kernelRows striderows vidcols kernelColumns stridecols

17+import System.IO.Unsafe ( unsafePerformIO )

18+

19+col2vid :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

20+col2vid kernelRows kernelColumns strideRows strideColumns height width dataCol =

21+ let channels = cols dataCol `div` (kernelRows * kernelColumns)

22+ in col2im_c channels height width kernelRows kernelColumns strideRows strideColumns dataCol

23+

24+col2im :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

25+col2im kernelRows kernelColumns strideRows strideColumns height width dataCol =

26+ let channels = 1

27+ in col2im_c channels height width kernelRows kernelColumns strideRows strideColumns dataCol

28+

29+col2im_c :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

30+col2im_c channels height width kernelRows kernelColumns strideRows strideColumns dataCol =

31+ let vec = flatten dataCol

32+ in unsafePerformIO $ do

33+ outPtr <- mallocForeignPtrArray (height * width * channels)

34+ let (inPtr, _) = U.unsafeToForeignPtr0 vec

35+

36+ withForeignPtr inPtr $ \inPtr' ->

37+ withForeignPtr outPtr $ \outPtr' ->

38+ col2im_cpu inPtr' channels height width kernelRows kernelColumns strideRows strideColumns outPtr'

39+

40+ let matVec = U.unsafeFromForeignPtr0 outPtr (height * width * channels)

41+ return $ U.matrixFromVector U.RowMajor (height * channels) width matVec

42+

43+foreign import ccall unsafe

44+ col2im_cpu

45+ :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()

46+

47+vid2col :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

48+vid2col kernelRows kernelColumns strideRows strideColumns height width dataVid =

49+ let channels = rows dataVid `div` height

50+ in im2col_c channels height width kernelRows kernelColumns strideRows strideColumns dataVid

51+

52+

53+im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

54+im2col kernelRows kernelColumns strideRows strideColumns dataIm =

55+ let channels = 1

56+ height = rows dataIm

57+ width = cols dataIm

58+ in im2col_c channels height width kernelRows kernelColumns strideRows strideColumns dataIm

59+

60+im2col_c :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

61+im2col_c channels height width kernelRows kernelColumns strideRows strideColumns dataIm =

62+ let vec = flatten dataIm

63+ rowOut = (height - kernelRows) `div` strideRows + 1

64+ colOut = (width - kernelColumns) `div` strideColumns + 1

12565 kernelSize = kernelRows * kernelColumns

126− numberOfPatches = length starts

127− channels = length dataVid

66+ numberOfPatches = rowOut * colOut

67+ in unsafePerformIO $ do

68+ outPtr <- mallocForeignPtrArray (numberOfPatches * kernelSize * channels)

69+ let (inPtr, _) = U.unsafeToForeignPtr0 vec

12870

129− dataCol <- U.newMatrix 0 numberOfPatches (channels * kernelSize)

71+ withForeignPtr inPtr $ \inPtr' ->

72+ withForeignPtr outPtr $ \outPtr' ->

73+ im2col_cpu inPtr' channels height width kernelRows kernelColumns strideRows strideColumns outPtr'

13074

131− offsetC <- newSTRef 0

75+ let matVec = U.unsafeFromForeignPtr0 outPtr (numberOfPatches * kernelSize * channels)

76+ return $ U.matrixFromVector U.RowMajor numberOfPatches (kernelSize * channels) matVec

13277

133− forM_ dataVid $ \dataIm -> do

134− inputRowRef <- newSTRef 0

135− offsetC' <- readSTRef offsetC

136− forM_ starts $ \(startRow, startCol) -> do

137− inputColumnRef <- newSTRef 0

138− inputRow <- readSTRef inputRowRef

139− forM_ [0 .. kernelRows -1] $ \kr ->

140− forM_ [0 .. kernelColumns -1] $ \kc -> do

141− inputColumn <- readSTRef inputColumnRef

142− U.modifyMatrix dataCol inputRow (inputColumn + offsetC') (+ U.atM' dataIm (kr + startRow) (kc + startCol))

143− modifySTRef inputColumnRef (+1)

144− modifySTRef inputRowRef (+1)

145−

146− modifySTRef offsetC (+ kernelSize)

147−

148− return dataCol

149−

150−im2colUnsafe :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

151−im2colUnsafe kernelRows kernelColumns striderows stridecols dataIm = U.runSTMatrix $ do

152− let starts = fittingStarts (rows dataIm) kernelRows striderows (cols dataIm) kernelColumns stridecols

153− kernelSize = kernelRows * kernelColumns

154− numberOfPatches = length starts

155−

156− dataCol <- U.newMatrix 0 numberOfPatches kernelSize

157−

158− inputRowRef <- newSTRef 0

159− forM_ starts $ \(startRow, startCol) -> do

160− inputColumnRef <- newSTRef 0

161− inputRow <- readSTRef inputRowRef

162− forM_ [0 .. kernelRows -1] $ \kr ->

163− forM_ [0 .. kernelColumns -1] $ \kc -> do

164− inputColumn <- readSTRef inputColumnRef

165− U.modifyMatrix dataCol inputRow inputColumn (+ U.atM' dataIm (kr + startRow) (kc + startCol))

166− modifySTRef inputColumnRef (+1)

167− modifySTRef inputRowRef (+1)

168−

169− return dataCol

170−

171−

172−-- | Returns the starting sub matrix locations which fit inside the larger matrix for the

173−-- convolution. Takes into account the stride and kernel size.

174−fittingStarts :: Int -> Int -> Int -> Int -> Int -> Int -> [(Int,Int)]

175−fittingStarts nrows kernelrows steprows ncols kernelcols stepcolsh =

176− let rs = fittingStart nrows kernelrows steprows

177− cs = fittingStart ncols kernelcols stepcolsh

178− ls = sequence [rs, cs]

179− in fmap (\[a,b] -> (a,b)) ls

180−

181−-- | Returns the starting sub vector which fit inside the larger vector for the

182−-- convolution. Takes into account the stride and kernel size.

183−fittingStart :: Int -> Int -> Int -> [Int]

184−fittingStart width kernel steps =

185− let go left | left + kernel < width

186− = left : go (left + steps)

187− | left + kernel == width

188− = [left]

189− | otherwise

190− = []

191− in go 0

78+foreign import ccall unsafe

79+ im2col_cpu

80+ :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()

src/Grenade/Layers/Internal/Pad.hsnew file+54

@@ -0,0 +1,54 @@

1+{-# LANGUAGE ForeignFunctionInterface #-}

2+module Grenade.Layers.Internal.Pad (

3+ pad

4+ , crop

5+ ) where

6+

7+import qualified Data.Vector.Storable as U ( unsafeToForeignPtr0, unsafeFromForeignPtr0 )

8+

9+import Foreign ( mallocForeignPtrArray, withForeignPtr )

10+import Foreign.Ptr ( Ptr )

11+

12+import Numeric.LinearAlgebra ( flatten, Matrix )

13+import qualified Numeric.LinearAlgebra.Devel as U

14+

15+import System.IO.Unsafe ( unsafePerformIO )

16+

17+pad :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

18+pad channels padLeft padTop padRight padBottom rows cols rows' cols' m

19+ = let outMatSize = rows' * cols' * channels

20+ vec = flatten m

21+ in unsafePerformIO $ do

22+ outPtr <- mallocForeignPtrArray outMatSize

23+ let (inPtr, _) = U.unsafeToForeignPtr0 vec

24+

25+ withForeignPtr inPtr $ \inPtr' ->

26+ withForeignPtr outPtr $ \outPtr' ->

27+ pad_cpu inPtr' channels rows cols padLeft padTop padRight padBottom outPtr'

28+

29+ let matVec = U.unsafeFromForeignPtr0 outPtr outMatSize

30+ return (U.matrixFromVector U.RowMajor (rows' * channels) cols' matVec)

31+{-# INLINE pad #-}

32+

33+foreign import ccall unsafe

34+ pad_cpu

35+ :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()

36+

37+crop :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

38+crop channels padLeft padTop padRight padBottom rows cols _ _ m

39+ = let outMatSize = rows * cols * channels

40+ vec = flatten m

41+ in unsafePerformIO $ do

42+ outPtr <- mallocForeignPtrArray outMatSize

43+ let (inPtr, _) = U.unsafeToForeignPtr0 vec

44+

45+ withForeignPtr inPtr $ \inPtr' ->

46+ withForeignPtr outPtr $ \outPtr' ->

47+ crop_cpu inPtr' channels rows cols padLeft padTop padRight padBottom outPtr'

48+

49+ let matVec = U.unsafeFromForeignPtr0 outPtr outMatSize

50+ return (U.matrixFromVector U.RowMajor (rows * channels) cols matVec)

51+

52+foreign import ccall unsafe

53+ crop_cpu

54+ :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()

src/Grenade/Layers/Internal/Pooling.hs+49−55

@@ -1,63 +1,57 @@

1+{-# LANGUAGE ForeignFunctionInterface #-}

12module Grenade.Layers.Internal.Pooling (

23 poolForward

34 , poolBackward

4− , poolForwardList

5− , poolBackwardList

65 ) where

76

8−import Data.Function ( on )

9−import Data.List ( maximumBy )

7+import qualified Data.Vector.Storable as U ( unsafeToForeignPtr0, unsafeFromForeignPtr0 )

108

11−import Numeric.LinearAlgebra hiding ( uniformSample, konst )

12−import qualified Numeric.LinearAlgebra as LA

13−import qualified Numeric.LinearAlgebra.Devel as U

9+import Foreign ( mallocForeignPtrArray, withForeignPtr )

10+import Foreign.Ptr ( Ptr )

1411

12+import Numeric.LinearAlgebra ( Matrix , flatten )

13+import qualified Numeric.LinearAlgebra.Devel as U

1514

16−import Grenade.Layers.Internal.Convolution

17−

18−poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

19−poolForward nrows ncols srows scols outputRows outputCols m =

20− let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols

21− in poolForwardFit starts nrows ncols outputRows outputCols m

22−

23−poolForwardList :: Functor f => Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> f (Matrix Double) -> f (Matrix Double)

24−poolForwardList nrows ncols srows scols inRows inCols outputRows outputCols ms =

25− let starts = fittingStarts inRows nrows srows inCols ncols scols

26− in poolForwardFit starts nrows ncols outputRows outputCols <$> ms

27−

28−poolForwardFit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

29−poolForwardFit starts nrows ncols _ outputCols m =

30− let els = fmap (\start -> unsafeMaxElement $ subMatrix start (nrows, ncols) m) starts

31− in LA.matrix outputCols els

32−

33−poolBackward :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double

34−poolBackward krows kcols srows scols inputMatrix gradientMatrix =

35− let inRows = rows inputMatrix

36− inCols = cols inputMatrix

37− starts = fittingStarts inRows krows srows inCols kcols scols

38− in poolBackwardFit starts krows kcols inputMatrix gradientMatrix

39−

40−poolBackwardList :: Functor f => Int -> Int -> Int -> Int -> Int -> Int -> f (Matrix Double, Matrix Double) -> f (Matrix Double)

41−poolBackwardList krows kcols srows scols inRows inCols inputMatrices =

42− let starts = fittingStarts inRows krows srows inCols kcols scols

43− in uncurry (poolBackwardFit starts krows kcols) <$> inputMatrices

44−

45−poolBackwardFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double

46−poolBackwardFit starts krows kcols inputMatrix gradientMatrix =

47− let inRows = rows inputMatrix

48− inCols = cols inputMatrix

49− inds = fmap (\start -> unsafeMaxIndex $ subMatrix start (krows, kcols) inputMatrix) starts

50− grads = toList $ flatten gradientMatrix

51− grads' = zip3 starts grads inds

52− accums = fmap (\((stx',sty'),grad,(inx, iny)) -> ((stx' + inx, sty' + iny), grad)) grads'

53− in accum (LA.konst 0 (inRows, inCols)) (+) accums

54−

55−unsafeMaxElement :: Matrix Double -> Double

56−unsafeMaxElement m = uncurry (U.atM' m) $ unsafeMaxIndex m

57−

58−unsafeMaxIndex :: Matrix Double -> (Int, Int)

59−unsafeMaxIndex m =

60− let mrows = [0 .. rows m - 1]

61− mcols = [0 .. cols m - 1]

62− pairs = concatMap ( \r -> fmap (\c -> (r , c)) mcols ) mrows

63− in maximumBy (compare `on` uncurry (U.atM' m)) pairs

15+import System.IO.Unsafe ( unsafePerformIO )

16+

17+poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

18+poolForward channels height width kernelRows kernelColumns strideRows strideColumns dataIm =

19+ let vec = flatten dataIm

20+ rowOut = (height - kernelRows) `div` strideRows + 1

21+ colOut = (width - kernelColumns) `div` strideColumns + 1

22+ numberOfPatches = rowOut * colOut

23+ in unsafePerformIO $ do

24+ outPtr <- mallocForeignPtrArray (numberOfPatches * channels)

25+ let (inPtr, _) = U.unsafeToForeignPtr0 vec

26+

27+ withForeignPtr inPtr $ \inPtr' ->

28+ withForeignPtr outPtr $ \outPtr' ->

29+ pool_forwards_cpu inPtr' channels height width kernelRows kernelColumns strideRows strideColumns outPtr'

30+

31+ let matVec = U.unsafeFromForeignPtr0 outPtr (numberOfPatches * channels)

32+ return $ U.matrixFromVector U.RowMajor (rowOut * channels) colOut matVec

33+

34+foreign import ccall unsafe

35+ pool_forwards_cpu

36+ :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()

37+

38+poolBackward :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double

39+poolBackward channels height width kernelRows kernelColumns strideRows strideColumns dataIm dataGrad =

40+ let vecIm = flatten dataIm

41+ vecGrad = flatten dataGrad

42+ in unsafePerformIO $ do

43+ outPtr <- mallocForeignPtrArray (height * width * channels)

44+ let (imPtr, _) = U.unsafeToForeignPtr0 vecIm

45+ let (gradPtr, _) = U.unsafeToForeignPtr0 vecGrad

46+

47+ withForeignPtr imPtr $ \imPtr' ->

48+ withForeignPtr gradPtr $ \gradPtr' ->

49+ withForeignPtr outPtr $ \outPtr' ->

50+ pool_backwards_cpu imPtr' gradPtr' channels height width kernelRows kernelColumns strideRows strideColumns outPtr'

51+

52+ let matVec = U.unsafeFromForeignPtr0 outPtr (height * width * channels)

53+ return $ U.matrixFromVector U.RowMajor (height * channels) width matVec

54+

55+foreign import ccall unsafe

56+ pool_backwards_cpu

57+ :: Ptr Double -> Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()

src/Grenade/Layers/Internal/Update.hsnew file+70

@@ -0,0 +1,70 @@

1+{-# LANGUAGE ForeignFunctionInterface #-}

2+module Grenade.Layers.Internal.Update (

3+ descendMatrix

4+ , descendVector

5+ ) where

6+

7+import Data.Maybe ( fromJust )

8+import qualified Data.Vector.Storable as U ( unsafeToForeignPtr0, unsafeFromForeignPtr0 )

9+

10+import Foreign ( mallocForeignPtrArray, withForeignPtr )

11+import Foreign.Ptr ( Ptr )

12+import GHC.TypeLits

13+

14+import Numeric.LinearAlgebra ( Vector, flatten )

15+import Numeric.LinearAlgebra.Static

16+import qualified Numeric.LinearAlgebra.Devel as U

17+

18+import System.IO.Unsafe ( unsafePerformIO )

19+

20+descendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)

21+descendMatrix rate momentum regulariser weights gradient lastUpdate =

22+ let (rows, cols) = size weights

23+ len = rows * cols

24+ -- Most gradients come in in ColumnMajor,

25+ -- so we'll transpose here before flattening them

26+ -- into a vector to prevent a copy.

27+ --

28+ -- This gives ~15% speed improvement for LSTMs.

29+ weights' = flatten . tr . extract $ weights

30+ gradient' = flatten . tr . extract $ gradient

31+ lastUpdate' = flatten . tr . extract $ lastUpdate

32+ (vw, vm) = descendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'

33+

34+ -- Note that it's ColumnMajor, as we did a transpose before

35+ -- using the internal vectors.

36+ mw = U.matrixFromVector U.ColumnMajor rows cols vw

37+ mm = U.matrixFromVector U.ColumnMajor rows cols vm

38+ in (fromJust . create $ mw, fromJust . create $ mm)

39+

40+descendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)

41+descendVector rate momentum regulariser weights gradient lastUpdate =

42+ let len = size weights

43+ weights' = extract weights

44+ gradient' = extract gradient

45+ lastUpdate' = extract lastUpdate

46+ (vw, vm) = descendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'

47+ in (fromJust $ create vw, fromJust $ create vm)

48+

49+descendUnsafe :: Int -> Double -> Double -> Double -> Vector Double -> Vector Double -> Vector Double -> (Vector Double, Vector Double)

50+descendUnsafe len rate momentum regulariser weights gradient lastUpdate =

51+ unsafePerformIO $ do

52+ outWPtr <- mallocForeignPtrArray len

53+ outMPtr <- mallocForeignPtrArray len

54+ let (wPtr, _) = U.unsafeToForeignPtr0 weights

55+ let (gPtr, _) = U.unsafeToForeignPtr0 gradient

56+ let (lPtr, _) = U.unsafeToForeignPtr0 lastUpdate

57+

58+ withForeignPtr wPtr $ \wPtr' ->

59+ withForeignPtr gPtr $ \gPtr' ->

60+ withForeignPtr lPtr $ \lPtr' ->

61+ withForeignPtr outWPtr $ \outWPtr' ->

62+ withForeignPtr outMPtr $ \outMPtr' ->

63+ descend_cpu len rate momentum regulariser wPtr' gPtr' lPtr' outWPtr' outMPtr'

64+

65+ return (U.unsafeFromForeignPtr0 outWPtr len, U.unsafeFromForeignPtr0 outMPtr len)

66+

67+foreign import ccall unsafe

68+ descend_cpu

69+ :: Int -> Double -> Double -> Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()

70+

src/Grenade/Layers/Logit.hs+35−27

@@ -1,21 +1,27 @@

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

32{-# LANGUAGE TypeOperators #-}

43{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

64{-# LANGUAGE FlexibleInstances #-}

7−

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-|

7+Module : Grenade.Layers.Logit

8+Description : Sigmoid nonlinear layer

9+Copyright : (c) Huw Campbell, 2016-2017

10+License : BSD2

11+Stability : experimental

12+-}

813module Grenade.Layers.Logit (

914 Logit (..)

1015 ) where

1116

1217

13−import Data.Singletons.TypeLits

14−import Grenade.Core.Network

15−import Grenade.Core.Vector

16−import Grenade.Core.Shape

18+import Data.Serialize

19+import Data.Singletons

20+

21+import Grenade.Core

1722

1823-- | A Logit layer.

24+--

1925-- A layer which can act between any shape of the same dimension, perfoming an sigmoid function.

2026-- This layer should be used as the output layer of a network for logistic regression (classification)

2127-- problems.

@@ -27,23 +33,25 @@ instance UpdateLayer Logit where

2733 runUpdate _ _ _ = Logit

2834 createRandom = return Logit

2935

30−instance (KnownNat i) => Layer Logit ('D1 i) ('D1 i) where

31− runForwards _ (S1D' y) = S1D' (logistic y)

32− runBackwards _ (S1D' y) (S1D' dEdy) = ((), S1D' (logistic' y * dEdy))

33−

34−instance (KnownNat i, KnownNat j) => Layer Logit ('D2 i j) ('D2 i j) where

35− runForwards _ (S2D' y) = S2D' (logistic y)

36− runBackwards _ (S2D' y) (S2D' dEdy) = ((), S2D' (logistic' y * dEdy))

37−

38−instance (KnownNat i, KnownNat j, KnownNat k) => Layer Logit ('D3 i j k) ('D3 i j k) where

39− runForwards _ (S3D' y) = S3D' (fmap logistic y)

40− runBackwards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> logistic' y' * dEdy') y dEdy))

41−

42−

43−logistic :: Floating a => a -> a

44−logistic x = 1 / (1 + exp (-x))

45−

46−logistic' :: Floating a => a -> a

47−logistic' x = logix * (1 - logix)

48− where

49− logix = logistic x

36+instance (a ~ b, SingI a) => Layer Logit a b where

37+ -- Wengert tape optimisation:

38+ --

39+ -- Derivative of the sigmoid function is

40+ -- d σ(x) / dx = σ(x) • (1 - σ(x))

41+ -- but we have already calculated σ(x) in

42+ -- the forward pass, so just store that

43+ -- and use it in the backwards pass.

44+ type Tape Logit a b = S a

45+ runForwards _ a =

46+ let l = sigmoid a

47+ in (l, l)

48+ runBackwards _ l g =

49+ let sigmoid' = l * (1 - l)

50+ in ((), sigmoid' * g)

51+

52+instance Serialize Logit where

53+ put _ = return ()

54+ get = return Logit

55+

56+sigmoid :: Floating a => a -> a

57+sigmoid x = 1 / (1 + exp (-x))

src/Grenade/Layers/Merge.hsnew file+66

@@ -0,0 +1,66 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE FlexibleInstances #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE StandaloneDeriving #-}

12+{-|

13+Module : Grenade.Core.Network

14+Description : Merging layer for parallel network composition

15+Copyright : (c) Huw Campbell, 2016-2017

16+License : BSD2

17+Stability : experimental

18+-}

19+module Grenade.Layers.Merge (

20+ Merge (..)

21+ ) where

22+

23+import Data.Serialize

24+

25+import Data.Singletons

26+

27+#if MIN_VERSION_base(4,9,0)

28+import Data.Kind (Type)

29+#endif

30+

31+import Grenade.Core

32+

33+-- | A Merging layer.

34+--

35+-- Similar to Concat layer, except sums the activations instead of creating a larger

36+-- shape.

37+data Merge :: Type -> Type -> Type where

38+ Merge :: x -> y -> Merge x y

39+

40+instance (Show x, Show y) => Show (Merge x y) where

41+ show (Merge x y) = "Merge\n" ++ show x ++ "\n" ++ show y

42+

43+-- | Run two layers in parallel, combining their outputs.

44+-- This just kind of "smooshes" the weights together.

45+instance (UpdateLayer x, UpdateLayer y) => UpdateLayer (Merge x y) where

46+ type Gradient (Merge x y) = (Gradient x, Gradient y)

47+ runUpdate lr (Merge x y) (x', y') = Merge (runUpdate lr x x') (runUpdate lr y y')

48+ createRandom = Merge <$> createRandom <*> createRandom

49+

50+-- | Combine the outputs and the inputs, summing the output shape

51+instance (SingI i, SingI o, Layer x i o, Layer y i o) => Layer (Merge x y) i o where

52+ type Tape (Merge x y) i o = (Tape x i o, Tape y i o)

53+

54+ runForwards (Merge x y) input =

55+ let (xT, xOut) = runForwards x input

56+ (yT, yOut) = runForwards y input

57+ in ((xT, yT), xOut + yOut)

58+

59+ runBackwards (Merge x y) (xTape, yTape) o =

60+ let (x', xB) = runBackwards x xTape o

61+ (y', yB) = runBackwards y yTape o

62+ in ((x', y'), xB + yB)

63+

64+instance (Serialize a, Serialize b) => Serialize (Merge a b) where

65+ put (Merge a b) = put a *> put b

66+ get = Merge <$> get <*> get

src/Grenade/Layers/Pad.hs+71−12

@@ -1,33 +1,43 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE GADTs #-}

45{-# LANGUAGE TypeOperators #-}

56{-# LANGUAGE TypeFamilies #-}

67{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE FlexibleInstances #-}

88{-# LANGUAGE FlexibleContexts #-}

9−{-# LANGUAGE PolyKinds #-}

10−

9+{-# LANGUAGE UndecidableInstances #-}

10+{-|

11+Module : Grenade.Core.Pad

12+Description : Padding layer for 2D and 3D images

13+Copyright : (c) Huw Campbell, 2016-2017

14+License : BSD2

15+Stability : experimental

16+-}

1117module Grenade.Layers.Pad (

1218 Pad (..)

1319 ) where

1420

1521import Data.Maybe

1622import Data.Proxy

17−import Data.Singletons.TypeLits

23+import Data.Serialize

24+

1825import GHC.TypeLits

26+import Data.Kind (Type)

1927

20−import Grenade.Core.Network

21−import Grenade.Core.Shape

28+import Grenade.Core

29+import Grenade.Layers.Internal.Pad

2230

2331import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)

2432import Numeric.LinearAlgebra.Static (extract, create)

2533

2634-- | A padding layer for a neural network.

35+--

36+-- Pads on the X and Y dimension of an image.

2737data Pad :: Nat

2838 -> Nat

2939 -> Nat

30− -> Nat -> * where

40+ -> Nat -> Type where

3141 Pad :: Pad padLeft padTop padRight padBottom

3242

3343instance Show (Pad padLeft padTop padRight padBottom) where

@@ -38,7 +48,11 @@ instance UpdateLayer (Pad l t r b) where

3848 runUpdate _ x _ = x

3949 createRandom = return Pad

4050

41−-- | A two dimentional image can be padped.

51+instance Serialize (Pad l t r b) where

52+ put _ = return ()

53+ get = return Pad

54+

55+-- | A two dimentional image can be padded.

4256instance ( KnownNat padLeft

4357 , KnownNat padTop

4458 , KnownNat padRight

@@ -50,19 +64,64 @@ instance ( KnownNat padLeft

5064 , (inputRows + padTop + padBottom) ~ outputRows

5165 , (inputColumns + padLeft + padRight) ~ outputColumns

5266 ) => Layer (Pad padLeft padTop padRight padBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where

53− runForwards Pad (S2D' input) =

67+ type Tape (Pad padLeft padTop padRight padBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = ()

68+ runForwards Pad (S2D input) =

5469 let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)

5570 padt = fromIntegral $ natVal (Proxy :: Proxy padTop)

5671 padr = fromIntegral $ natVal (Proxy :: Proxy padRight)

5772 padb = fromIntegral $ natVal (Proxy :: Proxy padBottom)

5873 m = extract input

5974 r = diagBlock [konst 0 (padt,padl), m, konst 0 (padb,padr)]

60− in S2D' . fromJust . create $ r

61− runBackwards Pad _ (S2D' dEdy) =

75+ in ((), S2D . fromJust . create $ r)

76+ runBackwards Pad _ (S2D dEdy) =

6277 let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)

6378 padt = fromIntegral $ natVal (Proxy :: Proxy padTop)

6479 nrows = fromIntegral $ natVal (Proxy :: Proxy inputRows)

6580 ncols = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

6681 m = extract dEdy

6782 vs = subMatrix (padt, padl) (nrows, ncols) m

68− in ((), S2D' . fromJust . create $ vs)

83+ in ((), S2D . fromJust . create $ vs)

84+

85+-- | A two dimentional image can be padded.

86+instance ( KnownNat padLeft

87+ , KnownNat padTop

88+ , KnownNat padRight

89+ , KnownNat padBottom

90+ , KnownNat inputRows

91+ , KnownNat inputColumns

92+ , KnownNat outputRows

93+ , KnownNat outputColumns

94+ , KnownNat channels

95+ , KnownNat (inputRows * channels)

96+ , KnownNat (outputRows * channels)

97+ , (inputRows + padTop + padBottom) ~ outputRows

98+ , (inputColumns + padLeft + padRight) ~ outputColumns

99+ ) => Layer (Pad padLeft padTop padRight padBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where

100+ type Tape (Pad padLeft padTop padRight padBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) = ()

101+ runForwards Pad (S3D input) =

102+ let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)

103+ padt = fromIntegral $ natVal (Proxy :: Proxy padTop)

104+ padr = fromIntegral $ natVal (Proxy :: Proxy padRight)

105+ padb = fromIntegral $ natVal (Proxy :: Proxy padBottom)

106+ outr = fromIntegral $ natVal (Proxy :: Proxy outputRows)

107+ outc = fromIntegral $ natVal (Proxy :: Proxy outputColumns)

108+ inr = fromIntegral $ natVal (Proxy :: Proxy inputRows)

109+ inc = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

110+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)

111+ m = extract input

112+ padded = pad ch padl padt padr padb inr inc outr outc m

113+ in ((), S3D . fromJust . create $ padded)

114+

115+ runBackwards Pad () (S3D gradient) =

116+ let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)

117+ padt = fromIntegral $ natVal (Proxy :: Proxy padTop)

118+ padr = fromIntegral $ natVal (Proxy :: Proxy padRight)

119+ padb = fromIntegral $ natVal (Proxy :: Proxy padBottom)

120+ outr = fromIntegral $ natVal (Proxy :: Proxy outputRows)

121+ outc = fromIntegral $ natVal (Proxy :: Proxy outputColumns)

122+ inr = fromIntegral $ natVal (Proxy :: Proxy inputRows)

123+ inc = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

124+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)

125+ m = extract gradient

126+ cropped = crop ch padl padt padr padb inr inc outr outc m

127+ in ((), S3D . fromJust . create $ cropped)

src/Grenade/Layers/Pooling.hs+48−33

@@ -1,4 +1,4 @@

1−{-# LANGUAGE BangPatterns #-}

1+{-# LANGUAGE CPP #-}

22{-# LANGUAGE DataKinds #-}

33{-# LANGUAGE ScopedTypeVariables #-}

44{-# LANGUAGE StandaloneDeriving #-}

@@ -6,44 +6,54 @@

66{-# LANGUAGE TypeOperators #-}

77{-# LANGUAGE TypeFamilies #-}

88{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE FlexibleInstances #-}

109{-# LANGUAGE FlexibleContexts #-}

11−{-# LANGUAGE PolyKinds #-}

12−

10+{-# LANGUAGE UndecidableInstances #-}

11+{-|

12+Module : Grenade.Core.Pooling

13+Description : Max Pooling layer for 2D and 3D images

14+Copyright : (c) Huw Campbell, 2016-2017

15+License : BSD2

16+Stability : experimental

17+-}

1318module Grenade.Layers.Pooling (

1419 Pooling (..)

1520 ) where

1621

1722import Data.Maybe

1823import Data.Proxy

19−import Data.Singletons.TypeLits

24+import Data.Serialize

25+

2026import GHC.TypeLits

27+import Data.Kind (Type)

2128

22−import Grenade.Core.Network

23−import Grenade.Core.Shape

24−import Grenade.Core.Vector

29+import Grenade.Core

2530import Grenade.Layers.Internal.Pooling

2631

2732import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)

2833

2934-- | A pooling layer for a neural network.

35+--

3036-- Does a max pooling, looking over a kernel similarly to the convolution network, but returning

3137-- maxarg only. This layer is often used to provide minor amounts of translational invariance.

3238--

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

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

3541--

36−data Pooling :: Nat -> Nat -> Nat -> Nat -> * where

42+data Pooling :: Nat -> Nat -> Nat -> Nat -> Type where

3743 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

3844

3945instance Show (Pooling k k' s s') where

4046 show Pooling = "Pooling"

4147

4248instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

43− type Gradient (Pooling kr kc sr sc) = ()

49+ type Gradient (Pooling kernelRows kernelColumns strideRows strideColumns) = ()

4450 runUpdate _ Pooling _ = Pooling

4551 createRandom = return Pooling

4652

53+instance Serialize (Pooling kernelRows kernelColumns strideRows strideColumns) where

54+ put _ = return ()

55+ get = return Pooling

56+

4757-- | A two dimentional image can be pooled.

4858instance ( KnownNat kernelRows

4959 , KnownNat kernelColumns

@@ -56,26 +66,29 @@ instance ( KnownNat kernelRows

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

5767 , ((outputColumns - 1) * strideColumns) ~ (inputColumns - kernelColumns)

5868 ) => Layer (Pooling kernelRows kernelColumns strideRows strideColumns) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where

59− runForwards Pooling (S2D' input) =

60− let kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

69+ type Tape (Pooling kernelRows kernelColumns strideRows strideColumns) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = S ('D2 inputRows inputColumns)

70+ runForwards Pooling (S2D input) =

71+ let height = fromIntegral $ natVal (Proxy :: Proxy inputRows)

72+ width = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

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

6174 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)

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

6376 sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)

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

65− oy = fromIntegral $ natVal (Proxy :: Proxy outputColumns)

6677 ex = extract input

67− r = poolForward kx ky sx sy ox oy $ ex

78+ r = poolForward 1 height width kx ky sx sy ex

6879 rs = fromJust . create $ r

69− in S2D' $ rs

70− runBackwards Pooling (S2D' input) (S2D' dEdy) =

71− let kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

80+ in (S2D input, S2D rs)

81+ runBackwards Pooling (S2D input) (S2D dEdy) =

82+ let height = fromIntegral $ natVal (Proxy :: Proxy inputRows)

83+ width = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

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

7285 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)

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

7487 sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)

7588 ex = extract input

7689 eo = extract dEdy

77− vs = poolBackward kx ky sx sy ex eo

78− in ((), S2D' . fromJust . create $ vs)

90+ vs = poolBackward 1 height width kx ky sx sy ex eo

91+ in ((), S2D . fromJust . create $ vs)

7992

8093

8194-- | A three dimensional image can be pooled on each layer.

@@ -87,31 +100,33 @@ instance ( KnownNat kernelRows

87100 , KnownNat inputColumns

88101 , KnownNat outputRows

89102 , KnownNat outputColumns

103+ , KnownNat channels

104+ , KnownNat (outputRows * channels)

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

91106 , ((outputColumns - 1) * strideColumns) ~ (inputColumns - kernelColumns)

92107 ) => Layer (Pooling kernelRows kernelColumns strideRows strideColumns) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where

93− runForwards Pooling (S3D' input) =

108+ type Tape (Pooling kernelRows kernelColumns strideRows strideColumns) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) = S ('D3 inputRows inputColumns channels)

109+ runForwards Pooling (S3D input) =

94110 let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

95111 iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

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

97113 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)

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

99115 sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)

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

101− oy = fromIntegral $ natVal (Proxy :: Proxy outputColumns)

102− ex = fmap extract input

103− r = poolForwardList kx ky sx sy ix iy ox oy ex

104− rs = fmap (fromJust . create) r

105− in S3D' rs

106− runBackwards Pooling (S3D' input) (S3D' dEdy) =

116+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)

117+ ex = extract input

118+ r = poolForward ch ix iy kx ky sx sy ex

119+ rs = fromJust . create $ r

120+ in (S3D input, S3D rs)

121+ runBackwards Pooling (S3D input) (S3D dEdy) =

107122 let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

108123 iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

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

110125 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)

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

112127 sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)

113− ex = fmap extract input

114− eo = fmap extract dEdy

115− ez = vectorZip (,) ex eo

116− vs = poolBackwardList kx ky sx sy ix iy ez

117− in ((), S3D' . fmap (fromJust . create) $ vs)

128+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)

129+ ex = extract input

130+ eo = extract dEdy

131+ vs = poolBackward ch ix iy kx ky sx sy ex eo

132+ in ((), S3D . fromJust . create $ vs)

src/Grenade/Layers/Relu.hs+27−12

@@ -1,18 +1,22 @@

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

32{-# LANGUAGE TypeOperators #-}

43{-# LANGUAGE TypeFamilies #-}

54{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE FlexibleInstances #-}

7−

5+{-|

6+Module : Grenade.Layers.Relu

7+Description : Rectifying linear unit layer

8+Copyright : (c) Huw Campbell, 2016-2017

9+License : BSD2

10+Stability : experimental

11+-}

812module Grenade.Layers.Relu (

913 Relu (..)

1014 ) where

1115

16+import Data.Serialize

17+

1218import GHC.TypeLits

13−import Grenade.Core.Vector

14−import Grenade.Core.Network

15−import Grenade.Core.Shape

19+import Grenade.Core

1620

1721import qualified Numeric.LinearAlgebra.Static as LAS

1822

@@ -27,26 +31,37 @@ instance UpdateLayer Relu where

2731 runUpdate _ _ _ = Relu

2832 createRandom = return Relu

2933

34+instance Serialize Relu where

35+ put _ = return ()

36+ get = return Relu

37+

3038instance ( KnownNat i) => Layer Relu ('D1 i) ('D1 i) where

31− runForwards _ (S1D' y) = S1D' (relu y)

39+ type Tape Relu ('D1 i) ('D1 i) = S ('D1 i)

40+

41+ runForwards _ (S1D y) = (S1D y, S1D (relu y))

3242 where

3343 relu = LAS.dvmap (\a -> if a <= 0 then 0 else a)

34− runBackwards _ (S1D' y) (S1D' dEdy) = ((), S1D' (relu' y * dEdy))

44+ runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (relu' y * dEdy))

3545 where

3646 relu' = LAS.dvmap (\a -> if a <= 0 then 0 else 1)

3747

3848instance (KnownNat i, KnownNat j) => Layer Relu ('D2 i j) ('D2 i j) where

39− runForwards _ (S2D' y) = S2D' (relu y)

49+ type Tape Relu ('D2 i j) ('D2 i j) = S ('D2 i j)

50+

51+ runForwards _ (S2D y) = (S2D y, S2D (relu y))

4052 where

4153 relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)

42− runBackwards _ (S2D' y) (S2D' dEdy) = ((), S2D' (relu' y * dEdy))

54+ runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (relu' y * dEdy))

4355 where

4456 relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)

4557

4658instance (KnownNat i, KnownNat j, KnownNat k) => Layer Relu ('D3 i j k) ('D3 i j k) where

47− runForwards _ (S3D' y) = S3D' (fmap relu y)

59+

60+ type Tape Relu ('D3 i j k) ('D3 i j k) = S ('D3 i j k)

61+

62+ runForwards _ (S3D y) = (S3D y, S3D (relu y))

4863 where

4964 relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)

50− runBackwards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> relu' y' * dEdy') y dEdy))

65+ runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (relu' y * dEdy))

5166 where

5267 relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)

src/Grenade/Layers/Reshape.hsnew file+80

@@ -0,0 +1,80 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE UndecidableInstances #-}

7+{-|

8+Module : Grenade.Layers.Reshape

9+Description : Multipurpose reshaping layer

10+Copyright : (c) Huw Campbell, 2016-2017

11+License : BSD2

12+Stability : experimental

13+-}

14+module Grenade.Layers.Reshape (

15+ Reshape (..)

16+ ) where

17+

18+import Data.Serialize

19+

20+import GHC.TypeLits

21+

22+import Numeric.LinearAlgebra.Static

23+import Numeric.LinearAlgebra.Data as LA ( flatten )

24+

25+import Grenade.Core

26+

27+-- | Reshape Layer

28+--

29+-- The Reshape layer can flatten any 2D or 3D image to 1D vector with the

30+-- same number of activations, as well as cast up from 1D to a 2D or 3D

31+-- shape.

32+--

33+-- Can also be used to turn a 3D image with only one channel into a 2D image

34+-- or vice versa.

35+data Reshape = Reshape

36+ deriving Show

37+

38+instance UpdateLayer Reshape where

39+ type Gradient Reshape = ()

40+ runUpdate _ _ _ = Reshape

41+ createRandom = return Reshape

42+

43+instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer Reshape ('D2 x y) ('D1 a) where

44+ type Tape Reshape ('D2 x y) ('D1 a) = ()

45+ runForwards _ (S2D y) = ((), fromJust' . fromStorable . flatten . extract $ y)

46+ runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)

47+

48+instance (KnownNat a, KnownNat x, KnownNat y, KnownNat (x * z), KnownNat z, a ~ (x * y * z)) => Layer Reshape ('D3 x y z) ('D1 a) where

49+ type Tape Reshape ('D3 x y z) ('D1 a) = ()

50+ runForwards _ (S3D y) = ((), fromJust' . fromStorable . flatten . extract $ y)

51+ runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)

52+

53+instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer Reshape ('D3 x y z) ('D2 x y) where

54+ type Tape Reshape ('D3 x y z) ('D2 x y) = ()

55+ runForwards _ (S3D y) = ((), S2D y)

56+ runBackwards _ _ (S2D y) = ((), S3D y)

57+

58+instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer Reshape ('D2 x y) ('D3 x y z) where

59+ type Tape Reshape ('D2 x y) ('D3 x y z) = ()

60+ runForwards _ (S2D y) = ((), S3D y)

61+ runBackwards _ _ (S3D y) = ((), S2D y)

62+

63+instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer Reshape ('D1 a) ('D2 x y) where

64+ type Tape Reshape ('D1 a) ('D2 x y) = ()

65+ runForwards _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)

66+ runBackwards _ _ (S2D y) = ((), fromJust' . fromStorable . flatten . extract $ y)

67+

68+instance (KnownNat a, KnownNat x, KnownNat y, KnownNat (x * z), KnownNat z, a ~ (x * y * z)) => Layer Reshape ('D1 a) ('D3 x y z) where

69+ type Tape Reshape ('D1 a) ('D3 x y z) = ()

70+ runForwards _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)

71+ runBackwards _ _ (S3D y) = ((), fromJust' . fromStorable . flatten . extract $ y)

72+

73+instance Serialize Reshape where

74+ put _ = return ()

75+ get = return Reshape

76+

77+

78+fromJust' :: Maybe x -> x

79+fromJust' (Just x) = x

80+fromJust' Nothing = error $ "Reshape error: data shape couldn't be converted."

src/Grenade/Layers/Sinusoid.hsnew file+39

@@ -0,0 +1,39 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-|

7+Module : Grenade.Layers.Sinusoid

8+Description : Sinusoid nonlinear layer

9+Copyright : (c) Manuel Schneckenreither, 2018

10+License : BSD2

11+Stability : experimental

12+-}

13+module Grenade.Layers.Sinusoid (

14+ Sinusoid (..)

15+ ) where

16+

17+import Data.Serialize

18+import Data.Singletons

19+

20+import Grenade.Core

21+

22+-- | A Sinusoid layer.

23+-- A layer which can act between any shape of the same dimension, performing a sin function.

24+data Sinusoid = Sinusoid

25+ deriving Show

26+

27+instance UpdateLayer Sinusoid where

28+ type Gradient Sinusoid = ()

29+ runUpdate _ _ _ = Sinusoid

30+ createRandom = return Sinusoid

31+

32+instance Serialize Sinusoid where

33+ put _ = return ()

34+ get = return Sinusoid

35+

36+instance (a ~ b, SingI a) => Layer Sinusoid a b where

37+ type Tape Sinusoid a b = S a

38+ runForwards _ a = (a, sin a)

39+ runBackwards _ a g = ((), cos a * g)

src/Grenade/Layers/Softmax.hsnew file+64

@@ -0,0 +1,64 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-|

7+Module : Grenade.Core.Softmax

8+Description : Softmax loss layer

9+Copyright : (c) Huw Campbell, 2016-2017

10+License : BSD2

11+Stability : experimental

12+-}

13+module Grenade.Layers.Softmax (

14+ Softmax (..)

15+ , softmax

16+ , softmax'

17+ ) where

18+

19+import Data.Serialize

20+

21+import GHC.TypeLits

22+import Grenade.Core

23+

24+import Numeric.LinearAlgebra.Static as LAS

25+

26+-- | A Softmax layer

27+--

28+-- This layer is like a logit layer, but normalises

29+-- a set of matricies to be probabilities.

30+--

31+-- One can use this layer as the last layer in a network

32+-- if they need normalised probabilities.

33+data Softmax = Softmax

34+ deriving Show

35+

36+instance UpdateLayer Softmax where

37+ type Gradient Softmax = ()

38+ runUpdate _ _ _ = Softmax

39+ createRandom = return Softmax

40+

41+instance ( KnownNat i ) => Layer Softmax ('D1 i) ('D1 i) where

42+ type Tape Softmax ('D1 i) ('D1 i) = S ('D1 i)

43+

44+ runForwards _ (S1D y) = (S1D y, S1D (softmax y))

45+ runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (softmax' y dEdy))

46+

47+instance Serialize Softmax where

48+ put _ = return ()

49+ get = return Softmax

50+

51+softmax :: KnownNat i => LAS.R i -> LAS.R i

52+softmax xs =

53+ let xs' = LAS.dvmap exp xs

54+ s = LAS.dot xs' 1

55+ in LAS.dvmap (/ s) xs'

56+

57+softmax' :: KnownNat i => LAS.R i -> LAS.R i -> LAS.R i

58+softmax' x grad =

59+ let yTy = outer sm sm

60+ d = diag sm

61+ g = d - yTy

62+ in g #> grad

63+ where

64+ sm = softmax x

src/Grenade/Layers/Tanh.hs+22−20

@@ -1,21 +1,26 @@

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE TypeOperators #-}

4−{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

62{-# LANGUAGE FlexibleInstances #-}

7−

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-|

7+Module : Grenade.Layers.Tanh

8+Description : Hyperbolic tangent nonlinear layer

9+Copyright : (c) Huw Campbell, 2016-2017

10+License : BSD2

11+Stability : experimental

12+-}

813module Grenade.Layers.Tanh (

914 Tanh (..)

1015 ) where

1116

12−import GHC.TypeLits

13−import Grenade.Core.Vector

14−import Grenade.Core.Network

15−import Grenade.Core.Shape

17+import Data.Serialize

18+import Data.Singletons

19+

20+import Grenade.Core

1621

1722-- | A Tanh layer.

18−-- A layer which can act between any shape of the same dimension, perfoming a tanh function.

23+-- A layer which can act between any shape of the same dimension, performing a tanh function.

1924data Tanh = Tanh

2025 deriving Show

2126

@@ -24,17 +29,14 @@ instance UpdateLayer Tanh where

2429 runUpdate _ _ _ = Tanh

2530 createRandom = return Tanh

2631

27−instance KnownNat i => Layer Tanh ('D1 i) ('D1 i) where

28− runForwards _ (S1D' y) = S1D' (tanh y)

29− runBackwards _ (S1D' y) (S1D' dEdy) = ((), S1D' (tanh' y * dEdy))

30−

31−instance (KnownNat i, KnownNat j) => Layer Tanh ('D2 i j) ('D2 i j) where

32− runForwards _ (S2D' y) = S2D' (tanh y)

33− runBackwards _ (S2D' y) (S2D' dEdy) = ((), S2D' (tanh' y * dEdy))

32+instance Serialize Tanh where

33+ put _ = return ()

34+ get = return Tanh

3435

35−instance (KnownNat i, KnownNat j, KnownNat k) => Layer Tanh ('D3 i j k) ('D3 i j k) where

36− runForwards _ (S3D' y) = S3D' (fmap tanh y)

37− runBackwards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> tanh' y' * dEdy') y dEdy))

36+instance (a ~ b, SingI a) => Layer Tanh a b where

37+ type Tape Tanh a b = S a

38+ runForwards _ a = (a, tanh a)

39+ runBackwards _ a g = ((), tanh' a * g)

3840

3941tanh' :: (Floating a) => a -> a

4042tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

src/Grenade/Layers/Trivial.hsnew file+40

@@ -0,0 +1,40 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-|

7+Module : Grenade.Core.Trivial

8+Description : Trivial layer which perfoms no operations on the data

9+Copyright : (c) Huw Campbell, 2016-2017

10+License : BSD2

11+Stability : experimental

12+-}

13+module Grenade.Layers.Trivial (

14+ Trivial (..)

15+ ) where

16+

17+import Data.Serialize

18+

19+import Grenade.Core

20+

21+-- | A Trivial layer.

22+--

23+-- This can be used to pass an unchanged value up one side of a

24+-- graph, for a Residual network for example.

25+data Trivial = Trivial

26+ deriving Show

27+

28+instance Serialize Trivial where

29+ put _ = return ()

30+ get = return Trivial

31+

32+instance UpdateLayer Trivial where

33+ type Gradient Trivial = ()

34+ runUpdate _ _ _ = Trivial

35+ createRandom = return Trivial

36+

37+instance (a ~ b) => Layer Trivial a b where

38+ type Tape Trivial a b = ()

39+ runForwards _ a = ((), a)

40+ runBackwards _ _ y = ((), y)

src/Grenade/Recurrent.hsnew file+29

@@ -0,0 +1,29 @@

1+module Grenade.Recurrent (

2+ -- | This is an empty module which simply re-exports public definitions

3+ -- for recurrent networks in Grenade.

4+

5+ -- * Exported modules

6+ --

7+ -- | The core types and runners for Recurrent Networks.

8+ module Grenade.Recurrent.Core

9+

10+ -- | The recurrent neural network layer zoo

11+ , module Grenade.Recurrent.Layers

12+

13+ -- * Overview of recurrent Networks

14+ -- $recurrent

15+

16+ ) where

17+

18+import Grenade.Recurrent.Core

19+import Grenade.Recurrent.Layers

20+

21+{- $recurrent

22+There are two ways in which deep learning libraries choose to represent

23+recurrent Neural Networks, as an unrolled graph, or at a first class

24+level. Grenade chooses the latter representation, and provides a network

25+type which is specifically suited for recurrent neural networks.

26+

27+Currently grenade supports two layers, a basic recurrent layer, and an

28+LSTM layer.

29+-}

src/Grenade/Recurrent/Core.hsnew file+9

@@ -0,0 +1,9 @@

1+module Grenade.Recurrent.Core (

2+ module Grenade.Recurrent.Core.Layer

3+ , module Grenade.Recurrent.Core.Network

4+ , module Grenade.Recurrent.Core.Runner

5+ ) where

6+

7+import Grenade.Recurrent.Core.Layer

8+import Grenade.Recurrent.Core.Network

9+import Grenade.Recurrent.Core.Runner

src/Grenade/Recurrent/Core/Layer.hsnew file+35

@@ -0,0 +1,35 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+module Grenade.Recurrent.Core.Layer (

8+ RecurrentLayer (..)

9+ , RecurrentUpdateLayer (..)

10+ ) where

11+

12+#if MIN_VERSION_base(4,9,0)

13+import Data.Kind (Type)

14+#endif

15+

16+import Grenade.Core

17+

18+-- | Class for a recurrent layer.

19+-- It's quite similar to a normal layer but for the input and output

20+-- of an extra recurrent data shape.

21+class UpdateLayer x => RecurrentUpdateLayer x where

22+ -- | Shape of data that is passed between each subsequent run of the layer

23+ type RecurrentShape x :: Type

24+

25+class (RecurrentUpdateLayer x, Num (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where

26+ -- | Wengert Tape

27+ type RecTape x i o :: Type

28+ -- | Used in training and scoring. Take the input from the previous

29+ -- layer, and give the output from this layer.

30+ runRecurrentForwards :: x -> RecurrentShape x -> S i -> (RecTape x i o, RecurrentShape x, S o)

31+ -- | Back propagate a step. Takes the current layer, the input that the

32+ -- layer gave from the input and the back propagated derivatives from

33+ -- the layer above.

34+ -- Returns the gradient layer and the derivatives to push back further.

35+ runRecurrentBackwards :: x -> RecTape x i o -> RecurrentShape x -> S o -> (Gradient x, RecurrentShape x, S i)

src/Grenade/Recurrent/Core/Network.hsnew file+328

@@ -0,0 +1,328 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+{-# LANGUAGE EmptyDataDecls #-}

10+{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE BangPatterns #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE UndecidableInstances #-}

14+

15+module Grenade.Recurrent.Core.Network (

16+ Recurrent

17+ , FeedForward

18+

19+ , RecurrentNetwork (..)

20+ , RecurrentInputs (..)

21+ , RecurrentTape (..)

22+ , RecurrentGradient (..)

23+

24+ , randomRecurrent

25+ , runRecurrent

26+ , runRecurrent'

27+ , applyRecurrentUpdate

28+ ) where

29+

30+

31+import Control.Monad.Random ( MonadRandom )

32+import Data.Serialize

33+

34+import Data.Kind (Type)

35+

36+import Grenade.Core

37+import Grenade.Recurrent.Core.Layer

38+import Prelude.Singletons

39+

40+-- | Witness type to say indicate we're building up with a normal feed

41+-- forward layer.

42+data FeedForward :: Type -> Type

43+-- | Witness type to say indicate we're building up with a recurrent layer.

44+data Recurrent :: Type -> Type

45+

46+-- | Type of a recurrent neural network.

47+--

48+-- The [Type] type specifies the types of the layers.

49+--

50+-- The [Shape] type specifies the shapes of data passed between the layers.

51+--

52+-- The definition is similar to a Network, but every layer in the

53+-- type is tagged by whether it's a FeedForward Layer of a Recurrent layer.

54+--

55+-- Often, to make the definitions more concise, one will use a type alias

56+-- for these empty data types.

57+data RecurrentNetwork :: [Type] -> [Shape] -> Type where

58+ RNil :: SingI i

59+ => RecurrentNetwork '[] '[i]

60+

61+ (:~~>) :: (SingI i, Layer x i h)

62+ => !x

63+ -> !(RecurrentNetwork xs (h ': hs))

64+ -> RecurrentNetwork (FeedForward x ': xs) (i ': h ': hs)

65+

66+ (:~@>) :: (SingI i, RecurrentLayer x i h)

67+ => !x

68+ -> !(RecurrentNetwork xs (h ': hs))

69+ -> RecurrentNetwork (Recurrent x ': xs) (i ': h ': hs)

70+infixr 5 :~~>

71+infixr 5 :~@>

72+

73+-- | Gradient of a network.

74+--

75+-- Parameterised on the layers of the network.

76+data RecurrentGradient :: [Type] -> Type where

77+ RGNil :: RecurrentGradient '[]

78+

79+ (://>) :: UpdateLayer x

80+ => Gradient x

81+ -> RecurrentGradient xs

82+ -> RecurrentGradient (phantom x ': xs)

83+

84+-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)

85+-- Parameterised on the layers of a Network.

86+data RecurrentInputs :: [Type] -> Type where

87+ RINil :: RecurrentInputs '[]

88+

89+ (:~~+>) :: (UpdateLayer x, Fractional (RecurrentInputs xs))

90+ => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)

91+

92+ (:~@+>) :: (Fractional (RecurrentShape x), Fractional (RecurrentInputs xs), RecurrentUpdateLayer x)

93+ => !(RecurrentShape x) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)

94+

95+-- | All the information required to backpropogate

96+-- through time safely.

97+--

98+-- We index on the time step length as well, to ensure

99+-- that that all Tape lengths are the same.

100+data RecurrentTape :: [Type] -> [Shape] -> Type where

101+ TRNil :: SingI i

102+ => RecurrentTape '[] '[i]

103+

104+ (:\~>) :: Tape x i h

105+ -> !(RecurrentTape xs (h ': hs))

106+ -> RecurrentTape (FeedForward x ': xs) (i ': h ': hs)

107+

108+ (:\@>) :: RecTape x i h

109+ -> !(RecurrentTape xs (h ': hs))

110+ -> RecurrentTape (Recurrent x ': xs) (i ': h ': hs)

111+

112+

113+runRecurrent :: forall shapes layers.

114+ RecurrentNetwork layers shapes

115+ -> RecurrentInputs layers

116+ -> S (Head shapes)

117+ -> (RecurrentTape layers shapes, RecurrentInputs layers, S (Last shapes))

118+runRecurrent =

119+ go

120+ where

121+ go :: forall js sublayers. (Last js ~ Last shapes)

122+ => RecurrentNetwork sublayers js

123+ -> RecurrentInputs sublayers

124+ -> S (Head js)

125+ -> (RecurrentTape sublayers js, RecurrentInputs sublayers, S (Last js))

126+ go (!layer :~~> n) (() :~~+> nIn) !x

127+ = let (!tape, !forwards) = runForwards layer x

128+

129+ -- recursively run the rest of the network, and get the gradients from above.

130+ (!newFN, !ig, !answer) = go n nIn forwards

131+ in (tape :\~> newFN, () :~~+> ig, answer)

132+

133+ -- This is a recurrent layer, so we need to do a scan, first input to last, providing

134+ -- the recurrent shape output to the next layer.

135+ go (layer :~@> n) (recIn :~@+> nIn) !x

136+ = let (tape, shape, forwards) = runRecurrentForwards layer recIn x

137+ (newFN, ig, answer) = go n nIn forwards

138+ in (tape :\@> newFN, shape :~@+> ig, answer)

139+

140+ -- Handle the output layer, bouncing the derivatives back down.

141+ -- We may not have a target for each example, so when we don't use 0 gradient.

142+ go RNil RINil !x

143+ = (TRNil, RINil, x)

144+

145+runRecurrent' :: forall layers shapes.

146+ RecurrentNetwork layers shapes

147+ -> RecurrentTape layers shapes

148+ -> RecurrentInputs layers

149+ -> S (Last shapes)

150+ -> (RecurrentGradient layers, RecurrentInputs layers, S (Head shapes))

151+runRecurrent' net tapes r o =

152+ go net tapes r

153+ where

154+ -- We have to be careful regarding the direction of the lists

155+ -- Inputs come in forwards, but our return value is backwards

156+ -- through time.

157+ go :: forall js ss. (Last js ~ Last shapes)

158+ => RecurrentNetwork ss js

159+ -> RecurrentTape ss js

160+ -> RecurrentInputs ss

161+ -> (RecurrentGradient ss, RecurrentInputs ss, S (Head js))

162+ -- This is a simple non-recurrent layer

163+ -- Run the rest of the network, update with the tapes and gradients

164+ go (!layer :~~> n) (!tape :\~> nTapes) (() :~~+> nRecs) =

165+ let (!gradients, !rins, !feed) = go n nTapes nRecs

166+ (!grad, !back) = runBackwards layer tape feed

167+ in (grad ://> gradients, () :~~+> rins, back)

168+

169+ -- This is a recurrent layer

170+ -- Run the rest of the network, scan over the tapes in reverse

171+ go (!layer :~@> n) (!tape :\@> nTapes) (!recGrad :~@+> nRecs) =

172+ let (!gradients, !rins, !feed) = go n nTapes nRecs

173+ (!grad, !sidegrad, !back) = runRecurrentBackwards layer tape recGrad feed

174+ in (grad ://> gradients, sidegrad :~@+> rins, back)

175+

176+ -- End of the road, so we reflect the given gradients backwards.

177+ -- Crucially, we reverse the list, so it's backwards in time as

178+ -- well.

179+ go !RNil !TRNil !RINil

180+ = (RGNil, RINil, o)

181+

182+-- | Apply a batch of gradients to the network

183+-- Uses runUpdates which can be specialised for

184+-- a layer.

185+applyRecurrentUpdate :: LearningParameters

186+ -> RecurrentNetwork layers shapes

187+ -> RecurrentGradient layers

188+ -> RecurrentNetwork layers shapes

189+applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)

190+ = runUpdate rate layer gradient :~~> applyRecurrentUpdate rate rest grest

191+

192+applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)

193+ = runUpdate rate layer gradient :~@> applyRecurrentUpdate rate rest grest

194+

195+applyRecurrentUpdate _ RNil RGNil

196+ = RNil

197+

198+

199+instance Show (RecurrentNetwork '[] '[i]) where

200+ show RNil = "NNil"

201+instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (FeedForward x ': xs) (i ': rs)) where

202+ show (x :~~> xs) = show x ++ "\n~~>\n" ++ show xs

203+instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recurrent x ': xs) (i ': rs)) where

204+ show (x :~@> xs) = show x ++ "\n~~>\n" ++ show xs

205+

206+

207+-- | A network can easily be created by hand with (:~~>) and (:~@>), but an easy way to initialise a random

208+-- recurrent network and a set of random inputs for it is with the randomRecurrent.

209+class CreatableRecurrent (xs :: [Type]) (ss :: [Shape]) where

210+ -- | Create a network of the types requested

211+ randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss)

212+

213+instance SingI i => CreatableRecurrent '[] '[i] where

214+ randomRecurrent =

215+ return RNil

216+

217+instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where

218+ randomRecurrent = do

219+ thisLayer <- createRandom

220+ rest <- randomRecurrent

221+ return (thisLayer :~~> rest)

222+

223+instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where

224+ randomRecurrent = do

225+ thisLayer <- createRandom

226+ rest <- randomRecurrent

227+ return (thisLayer :~@> rest)

228+

229+-- | Add very simple serialisation to the recurrent network

230+instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where

231+ put RNil = pure ()

232+ get = pure RNil

233+

234+instance (SingI i, Layer x i o, Serialize x, Serialize (RecurrentNetwork xs (o ': rs))) => Serialize (RecurrentNetwork (FeedForward x ': xs) (i ': o ': rs)) where

235+ put (x :~~> r) = put x >> put r

236+ get = (:~~>) <$> get <*> get

237+

238+instance (SingI i, RecurrentLayer x i o, Serialize x, Serialize (RecurrentNetwork xs (o ': rs))) => Serialize (RecurrentNetwork (Recurrent x ': xs) (i ': o ': rs)) where

239+ put (x :~@> r) = put x >> put r

240+ get = (:~@>) <$> get <*> get

241+

242+instance (Serialize (RecurrentInputs '[])) where

243+ put _ = return ()

244+ get = return RINil

245+

246+instance (UpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

247+ put ( () :~~+> rest) = put rest

248+ get = ( () :~~+> ) <$> get

249+

250+instance (Serialize (RecurrentShape x), Fractional (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

251+ put ( i :~@+> rest ) = put i >> put rest

252+ get = (:~@+>) <$> get <*> get

253+

254+

255+-- Num instance for `RecurrentInputs layers`

256+-- Not sure if this is really needed, as I only need a `fromInteger 0` at

257+-- the moment for training, to create a null gradient on the recurrent

258+-- edge.

259+--

260+-- It does raise an interesting question though? Is a 0 gradient actually

261+-- the best?

262+--

263+-- I could imaging that weakly push back towards the optimum input could

264+-- help make a more stable generator.

265+instance (Num (RecurrentInputs '[])) where

266+ (+) _ _ = RINil

267+ (-) _ _ = RINil

268+ (*) _ _ = RINil

269+ abs _ = RINil

270+ signum _ = RINil

271+ fromInteger _ = RINil

272+

273+instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where

274+ (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)

275+ (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)

276+ (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)

277+ abs (() :~~+> x) = () :~~+> abs x

278+ signum (() :~~+> x) = () :~~+> signum x

279+ fromInteger x = () :~~+> fromInteger x

280+

281+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where

282+ (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')

283+ (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')

284+ (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')

285+ abs (x :~@+> x') = abs x :~@+> abs x'

286+ signum (x :~@+> x') = signum x :~@+> signum x'

287+ fromInteger x = fromInteger x :~@+> fromInteger x

288+

289+instance (Fractional (RecurrentInputs '[])) where

290+ (/) _ _ = RINil

291+ recip _ = RINil

292+ fromRational _ = RINil

293+

294+instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (FeedForward x ': ys))) where

295+ (/) (() :~~+> x) (() :~~+> y) = () :~~+> (x / y)

296+ recip (() :~~+> x) = () :~~+> recip x

297+ fromRational x = () :~~+> fromRational x

298+

299+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (Recurrent x ': ys))) where

300+ (/) (x :~@+> x') (y :~@+> y') = (x / y) :~@+> (x' / y')

301+ recip (x :~@+> x') = recip x :~@+> recip x'

302+ fromRational x = fromRational x :~@+> fromRational x

303+

304+

305+-- | Ultimate composition.

306+--

307+-- This allows a complete network to be treated as a layer in a larger network.

308+instance CreatableRecurrent sublayers subshapes => UpdateLayer (RecurrentNetwork sublayers subshapes) where

309+ type Gradient (RecurrentNetwork sublayers subshapes) = RecurrentGradient sublayers

310+ runUpdate = applyRecurrentUpdate

311+ createRandom = randomRecurrent

312+

313+-- | Ultimate composition.

314+--

315+-- This allows a complete network to be treated as a layer in a larger network.

316+instance CreatableRecurrent sublayers subshapes => RecurrentUpdateLayer (RecurrentNetwork sublayers subshapes) where

317+ type RecurrentShape (RecurrentNetwork sublayers subshapes) = RecurrentInputs sublayers

318+

319+-- | Ultimate composition.

320+--

321+-- This allows a complete network to be treated as a layer in a larger network.

322+instance ( CreatableRecurrent sublayers subshapes

323+ , i ~ (Head subshapes), o ~ (Last subshapes)

324+ , Num (RecurrentShape (RecurrentNetwork sublayers subshapes))

325+ ) => RecurrentLayer (RecurrentNetwork sublayers subshapes) i o where

326+ type RecTape (RecurrentNetwork sublayers subshapes) i o = RecurrentTape sublayers subshapes

327+ runRecurrentForwards = runRecurrent

328+ runRecurrentBackwards = runRecurrent'

src/Grenade/Recurrent/Core/Runner.hsnew file+110

@@ -0,0 +1,110 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE RankNTypes #-}

9+

10+module Grenade.Recurrent.Core.Runner (

11+ runRecurrentExamples

12+ , runRecurrentBackprop

13+ , backPropagateRecurrent

14+ , trainRecurrent

15+

16+ , RecurrentGradients

17+ ) where

18+

19+import Data.List ( foldl' )

20+import Grenade.Core

21+

22+import Grenade.Recurrent.Core.Network

23+import Prelude.Singletons

24+

25+type RecurrentGradients layers = [RecurrentGradient layers]

26+

27+runRecurrentExamples :: forall shapes layers.

28+ RecurrentNetwork layers shapes

29+ -> RecurrentInputs layers

30+ -> [S (Head shapes)]

31+ -> ([(RecurrentTape layers shapes, S (Last shapes))], RecurrentInputs layers)

32+runRecurrentExamples net =

33+ go

34+ where

35+ go !side [] = ([], side)

36+ go !side (!x : xs) =

37+ let (!tape, !side', !o) = runRecurrent net side x

38+ (!res, !finalSide) = go side' xs

39+ in (( tape, o ) : res, finalSide)

40+

41+runRecurrentBackprop :: forall layers shapes.

42+ RecurrentNetwork layers shapes

43+ -> RecurrentInputs layers

44+ -> [(RecurrentTape layers shapes, S (Last shapes))]

45+ -> ([(RecurrentGradient layers, S (Head shapes))], RecurrentInputs layers)

46+runRecurrentBackprop net =

47+ go

48+ where

49+ go !side [] = ([], side)

50+ go !side ((!tape,!x):xs) =

51+ let (res, !side') = go side xs

52+ (!grad, !finalSide, !o) = runRecurrent' net tape side' x

53+ in (( grad, o ) : res, finalSide)

54+

55+

56+-- | Drive and network and collect its back propogated gradients.

57+backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

58+ => RecurrentNetwork layers shapes

59+ -> RecurrentInputs layers

60+ -> [(S (Head shapes), Maybe (S (Last shapes)))]

61+ -> (RecurrentGradients layers, RecurrentInputs layers)

62+backPropagateRecurrent network recinputs examples =

63+ let (outForwards, _) = runRecurrentExamples network recinputs inputs

64+

65+ backPropagations = zipWith makeError outForwards targets

66+

67+ (outBackwards, input') = runRecurrentBackprop network 0 backPropagations

68+

69+ gradients = fmap fst outBackwards

70+ in (gradients, input')

71+

72+ where

73+

74+ inputs = fst <$> examples

75+ targets = snd <$> examples

76+

77+ makeError :: (x, S (Last shapes)) -> Maybe (S (Last shapes)) -> (x, S (Last shapes))

78+ makeError (x, _) Nothing = (x, 0)

79+ makeError (x, y) (Just t) = (x, y - t)

80+

81+

82+trainRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

83+ => LearningParameters

84+ -> RecurrentNetwork layers shapes

85+ -> RecurrentInputs layers

86+ -> [(S (Head shapes), Maybe (S (Last shapes)))]

87+ -> (RecurrentNetwork layers shapes, RecurrentInputs layers)

88+trainRecurrent rate network recinputs examples =

89+ let (gradients, recinputs') = backPropagateRecurrent network recinputs examples

90+

91+ newInputs = updateRecInputs rate recinputs recinputs'

92+

93+ newNetwork = foldl' (applyRecurrentUpdate rate) network gradients

94+

95+ in (newNetwork, newInputs)

96+

97+updateRecInputs :: Fractional (RecurrentInputs sublayers)

98+ => LearningParameters

99+ -> RecurrentInputs sublayers

100+ -> RecurrentInputs sublayers

101+ -> RecurrentInputs sublayers

102+

103+updateRecInputs lp (() :~~+> xs) (() :~~+> ys)

104+ = () :~~+> updateRecInputs lp xs ys

105+

106+updateRecInputs lp (x :~@+> xs) (y :~@+> ys)

107+ = (realToFrac (1 - learningRate lp * learningRegulariser lp) * x - realToFrac (learningRate lp) * y) :~@+> updateRecInputs lp xs ys

108+

109+updateRecInputs _ RINil RINil

110+ = RINil

src/Grenade/Recurrent/Layers.hsnew file+9

@@ -0,0 +1,9 @@

1+module Grenade.Recurrent.Layers (

2+ module Grenade.Recurrent.Layers.BasicRecurrent

3+ , module Grenade.Recurrent.Layers.ConcatRecurrent

4+ , module Grenade.Recurrent.Layers.LSTM

5+ ) where

6+

7+import Grenade.Recurrent.Layers.BasicRecurrent

8+import Grenade.Recurrent.Layers.ConcatRecurrent

9+import Grenade.Recurrent.Layers.LSTM

src/Grenade/Recurrent/Layers/BasicRecurrent.hsnew file+97

@@ -0,0 +1,97 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE UndecidableInstances #-}

9+

10+module Grenade.Recurrent.Layers.BasicRecurrent (

11+ BasicRecurrent (..)

12+ , randomBasicRecurrent

13+ ) where

14+

15+

16+

17+import Control.Monad.Random ( MonadRandom, getRandom )

18+

19+

20+import Data.Kind (Type)

21+

22+import Numeric.LinearAlgebra.Static

23+

24+import GHC.TypeLits

25+

26+import Grenade.Core

27+import Grenade.Recurrent.Core

28+

29+data BasicRecurrent :: Nat -- Input layer size

30+ -> Nat -- Output layer size

31+ -> Type where

32+ BasicRecurrent :: ( KnownNat input

33+ , KnownNat output

34+ , KnownNat matrixCols

35+ , matrixCols ~ (input + output))

36+ => !(R output) -- Bias neuron weights

37+ -> !(R output) -- Bias neuron momentum

38+ -> !(L output matrixCols) -- Activation

39+ -> !(L output matrixCols) -- Momentum

40+ -> BasicRecurrent input output

41+

42+data BasicRecurrent' :: Nat -- Input layer size

43+ -> Nat -- Output layer size

44+ -> Type where

45+ BasicRecurrent' :: ( KnownNat input

46+ , KnownNat output

47+ , KnownNat matrixCols

48+ , matrixCols ~ (input + output))

49+ => !(R output) -- Bias neuron gradients

50+ -> !(L output matrixCols)

51+ -> BasicRecurrent' input output

52+

53+instance Show (BasicRecurrent i o) where

54+ show BasicRecurrent {} = "BasicRecurrent"

55+

56+instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

57+ type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

58+

59+ runUpdate lp (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

60+ let newBiasMomentum = konst (learningMomentum lp) * oldBiasMomentum - konst (learningRate lp) * biasGradient

61+ newBias = oldBias + newBiasMomentum

62+ newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient

63+ regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations

64+ newActivations = oldActivations + newMomentum - regulariser

65+ in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

66+

67+ createRandom = randomBasicRecurrent

68+

69+instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where

70+ type RecurrentShape (BasicRecurrent i o) = S ('D1 o)

71+

72+instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

73+

74+ type RecTape (BasicRecurrent i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))

75+ -- Do a matrix vector multiplication and return the result.

76+ runRecurrentForwards (BasicRecurrent wB _ wN _) (S1D lastOutput) (S1D thisInput) =

77+ let thisOutput = S1D $ wB + wN #> (thisInput # lastOutput)

78+ in ((S1D lastOutput, S1D thisInput), thisOutput, thisOutput)

79+

80+ -- Run a backpropogation step for a full connected layer.

81+ runRecurrentBackwards (BasicRecurrent _ _ wN _) (S1D lastOutput, S1D thisInput) (S1D dRec) (S1D dEdy) =

82+ let biasGradient = (dRec + dEdy)

83+ layerGrad = (dRec + dEdy) `outer` (thisInput # lastOutput)

84+ -- calcluate derivatives for next step

85+ (backGrad, recGrad) = split $ tr wN #> (dRec + dEdy)

86+ in (BasicRecurrent' biasGradient layerGrad, S1D recGrad, S1D backGrad)

87+

88+randomBasicRecurrent :: (MonadRandom m, KnownNat i, KnownNat o, KnownNat x, x ~ (i + o))

89+ => m (BasicRecurrent i o)

90+randomBasicRecurrent = do

91+ seed1 <- getRandom

92+ seed2 <- getRandom

93+ let wB = randomVector seed1 Uniform * 2 - 1

94+ wN = uniformSample seed2 (-1) 1

95+ bm = konst 0

96+ mm = konst 0

97+ return $ BasicRecurrent wB bm wN mm

src/Grenade/Recurrent/Layers/ConcatRecurrent.hsnew file+180

@@ -0,0 +1,180 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE FlexibleInstances #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+{-|

14+Module : Grenade.Layers.Concat

15+Description : Concatenation layer

16+Copyright : (c) Huw Campbell, 2016-2017

17+License : BSD2

18+Stability : experimental

19+

20+This module provides the concatenation layer, which runs two chilld layers in parallel and combines their outputs.

21+-}

22+module Grenade.Recurrent.Layers.ConcatRecurrent (

23+ ConcatRecurrent (..)

24+ ) where

25+

26+import Data.Serialize

27+

28+import Data.Singletons

29+import GHC.TypeLits

30+

31+#if MIN_VERSION_base(4,9,0)

32+import Data.Kind (Type)

33+#endif

34+

35+import Grenade.Core

36+import Grenade.Recurrent.Core

37+

38+import Numeric.LinearAlgebra.Static ( (#), split, R )

39+

40+-- | A Concatentating Layer.

41+--

42+-- This layer shares it's input state between two sublayers, and concatenates their output.

43+--

44+-- With Networks able to be Layers, this allows for very expressive composition of complex Networks.

45+--

46+-- The Concat layer has a few instances, which allow one to flexibly "bash" together the outputs.

47+--

48+-- Two 1D vectors, can go to a 2D shape with 2 rows if their lengths are identical.

49+-- Any 2 1D vectors can also become a longer 1D Vector.

50+--

51+-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad

52+-- and Crop layers to ensure this is the case.

53+data ConcatRecurrent :: Shape -> Type -> Shape -> Type -> Type where

54+ ConcatRecLeft :: x -> y -> ConcatRecurrent m (Recurrent x) n (FeedForward y)

55+ ConcatRecRight :: x -> y -> ConcatRecurrent m (FeedForward x) n (Recurrent y)

56+ ConcatRecBoth :: x -> y -> ConcatRecurrent m (Recurrent x) n (Recurrent y)

57+

58+instance (Show x, Show y) => Show (ConcatRecurrent m (p x) n (q y)) where

59+ show (ConcatRecLeft x y) = "ConcatRecLeft\n" ++ show x ++ "\n" ++ show y

60+ show (ConcatRecRight x y) = "ConcatRecRight\n" ++ show x ++ "\n" ++ show y

61+ show (ConcatRecBoth x y) = "ConcatRecBoth\n" ++ show x ++ "\n" ++ show y

62+

63+instance (RecurrentUpdateLayer x, UpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where

64+ type Gradient (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = (Gradient x, Gradient y)

65+ runUpdate lr (ConcatRecLeft x y) (x', y')

66+ = ConcatRecLeft (runUpdate lr x x') (runUpdate lr y y')

67+ createRandom

68+ = ConcatRecLeft <$> createRandom <*> createRandom

69+

70+instance (UpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where

71+ type Gradient (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = (Gradient x, Gradient y)

72+ runUpdate lr (ConcatRecRight x y) (x', y')

73+ = ConcatRecRight (runUpdate lr x x') (runUpdate lr y y')

74+ createRandom

75+ = ConcatRecRight <$> createRandom <*> createRandom

76+

77+instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where

78+ type Gradient (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = (Gradient x, Gradient y)

79+ runUpdate lr (ConcatRecBoth x y) (x', y')

80+ = ConcatRecBoth (runUpdate lr x x') (runUpdate lr y y')

81+ createRandom

82+ = ConcatRecBoth <$> createRandom <*> createRandom

83+

84+instance (RecurrentUpdateLayer x, UpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where

85+ type RecurrentShape (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = RecurrentShape x

86+

87+instance (UpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where

88+ type RecurrentShape (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = RecurrentShape y

89+

90+instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where

91+ type RecurrentShape (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = RecurrentInputs '[ Recurrent x, Recurrent y ]

92+

93+instance ( SingI i

94+ , Layer x i ('D1 m)

95+ , RecurrentLayer y i ('D1 n)

96+ , KnownNat o

97+ , KnownNat m

98+ , KnownNat n

99+ , o ~ (m + n)

100+ , n ~ (o - m)

101+ , (m <=? o) ~ 'True

102+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) where

103+ type RecTape (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) = (Tape x i ('D1 m), RecTape y i ('D1 n))

104+

105+ runRecurrentForwards (ConcatRecRight x y) s input =

106+ let (xT, xOut :: S ('D1 m)) = runForwards x input

107+ (yT, side, yOut :: S ('D1 n)) = runRecurrentForwards y s input

108+ in case (xOut, yOut) of

109+ (S1D xOut', S1D yOut') ->

110+ ((xT, yT), side, S1D (xOut' # yOut'))

111+

112+ runRecurrentBackwards (ConcatRecRight x y) (xTape, yTape) s (S1D o) =

113+ let (ox :: R m , oy :: R n) = split o

114+ (x', xB :: S i) = runBackwards x xTape (S1D ox)

115+ (y', side, yB :: S i) = runRecurrentBackwards y yTape s (S1D oy)

116+ in ((x', y'), side, xB + yB)

117+

118+instance ( SingI i

119+ , RecurrentLayer x i ('D1 m)

120+ , Layer y i ('D1 n)

121+ , KnownNat o

122+ , KnownNat m

123+ , KnownNat n

124+ , o ~ (m + n)

125+ , n ~ (o - m)

126+ , (m <=? o) ~ 'True

127+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) where

128+ type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) = (RecTape x i ('D1 m), Tape y i ('D1 n))

129+

130+ runRecurrentForwards (ConcatRecLeft x y) s input =

131+ let (xT, side, xOut :: S ('D1 m)) = runRecurrentForwards x s input

132+ (yT, yOut :: S ('D1 n)) = runForwards y input

133+ in case (xOut, yOut) of

134+ (S1D xOut', S1D yOut') ->

135+ ((xT, yT), side, S1D (xOut' # yOut'))

136+

137+ runRecurrentBackwards (ConcatRecLeft x y) (xTape, yTape) s (S1D o) =

138+ let (ox :: R m , oy :: R n) = split o

139+ (x', side, xB :: S i) = runRecurrentBackwards x xTape s (S1D ox)

140+ (y', yB :: S i) = runBackwards y yTape (S1D oy)

141+ in ((x', y'), side, xB + yB)

142+

143+instance ( SingI i

144+ , RecurrentLayer x i ('D1 m)

145+ , RecurrentLayer y i ('D1 n)

146+ , Fractional (RecurrentShape x)

147+ , Fractional (RecurrentShape y)

148+ , KnownNat o

149+ , KnownNat m

150+ , KnownNat n

151+ , o ~ (m + n)

152+ , n ~ (o - m)

153+ , (m <=? o) ~ 'True

154+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) where

155+ type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) = (RecTape x i ('D1 m), RecTape y i ('D1 n))

156+

157+ runRecurrentForwards (ConcatRecBoth x y) (sx :~@+> (sy :~@+> RINil)) input =

158+ let (xT, s'x, xOut :: S ('D1 m)) = runRecurrentForwards x sx input

159+ (yT, s'y, yOut :: S ('D1 n)) = runRecurrentForwards y sy input

160+ in case (xOut, yOut) of

161+ (S1D xOut', S1D yOut') ->

162+ ((xT, yT), (s'x :~@+> (s'y :~@+> RINil)), S1D (xOut' # yOut'))

163+

164+ runRecurrentBackwards (ConcatRecBoth x y) (xTape, yTape) (sx :~@+> (sy :~@+> RINil)) (S1D o) =

165+ let (ox :: R m , oy :: R n) = split o

166+ (x', s'x, xB :: S i) = runRecurrentBackwards x xTape sx (S1D ox)

167+ (y', s'y, yB :: S i) = runRecurrentBackwards y yTape sy (S1D oy)

168+ in ((x', y'), (s'x :~@+> (s'y :~@+> RINil)), xB + yB)

169+

170+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (FeedForward a) sb (Recurrent b)) where

171+ put (ConcatRecRight a b) = put a *> put b

172+ get = ConcatRecRight <$> get <*> get

173+

174+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (Recurrent b)) where

175+ put (ConcatRecBoth a b) = put a *> put b

176+ get = ConcatRecBoth <$> get <*> get

177+

178+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (FeedForward b)) where

179+ put (ConcatRecLeft a b) = put a *> put b

180+ get = ConcatRecLeft <$> get <*> get

src/Grenade/Recurrent/Layers/LSTM.hsnew file+268

@@ -0,0 +1,268 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE ViewPatterns #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+

13+module Grenade.Recurrent.Layers.LSTM (

14+ LSTM (..)

15+ , LSTMWeights (..)

16+ , randomLSTM

17+ ) where

18+

19+import Control.Monad.Random ( MonadRandom, getRandom )

20+

21+-- import Data.List ( foldl1' )

22+import Data.Proxy

23+import Data.Serialize

24+import Data.Kind (Type)

25+

26+import qualified Numeric.LinearAlgebra as LA

27+import Numeric.LinearAlgebra.Static

28+

29+import Grenade.Core

30+import Grenade.Recurrent.Core

31+import Grenade.Layers.Internal.Update

32+import GHC.TypeLits

33+

34+

35+-- | Long Short Term Memory Recurrent unit

36+--

37+-- This is a Peephole formulation, so the recurrent shape is

38+-- just the cell state, the previous output is not held or used

39+-- at all.

40+data LSTM :: Nat -> Nat -> Type where

41+ LSTM :: ( KnownNat input

42+ , KnownNat output

43+ ) => !(LSTMWeights input output) -- Weights

44+ -> !(LSTMWeights input output) -- Momentums

45+ -> LSTM input output

46+

47+data LSTMWeights :: Nat -> Nat -> Type where

48+ LSTMWeights :: ( KnownNat input

49+ , KnownNat output

50+ ) => {

51+ lstmWf :: !(L output input) -- Weight Forget (W_f)

52+ , lstmUf :: !(L output output) -- Cell State Forget (U_f)

53+ , lstmBf :: !(R output) -- Bias Forget (b_f)

54+ , lstmWi :: !(L output input) -- Weight Input (W_i)

55+ , lstmUi :: !(L output output) -- Cell State Input (U_i)

56+ , lstmBi :: !(R output) -- Bias Input (b_i)

57+ , lstmWo :: !(L output input) -- Weight Output (W_o)

58+ , lstmUo :: !(L output output) -- Cell State Output (U_o)

59+ , lstmBo :: !(R output) -- Bias Output (b_o)

60+ , lstmWc :: !(L output input) -- Weight Cell (W_c)

61+ , lstmBc :: !(R output) -- Bias Cell (b_c)

62+ } -> LSTMWeights input output

63+

64+instance Show (LSTM i o) where

65+ show LSTM {} = "LSTM"

66+

67+instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

68+ -- The gradients are the same shape as the weights and momentum

69+ -- This seems to be a general pattern, maybe it should be enforced.

70+ type Gradient (LSTM i o) = (LSTMWeights i o)

71+

72+ -- Run the update function for each group matrix/vector of weights, momentums and gradients.

73+ -- Hmm, maybe the function should be used instead of passing in the learning parameters.

74+ runUpdate lp (LSTM w m) g =

75+ let (wf, wf') = u lstmWf w m g

76+ (uf, uf') = u lstmUf w m g

77+ (bf, bf') = v lstmBf w m g

78+ (wi, wi') = u lstmWi w m g

79+ (ui, ui') = u lstmUi w m g

80+ (bi, bi') = v lstmBi w m g

81+ (wo, wo') = u lstmWo w m g

82+ (uo, uo') = u lstmUo w m g

83+ (bo, bo') = v lstmBo w m g

84+ (wc, wc') = u lstmWc w m g

85+ (bc, bc') = v lstmBc w m g

86+ in LSTM (LSTMWeights wf uf bf wi ui bi wo uo bo wc bc) (LSTMWeights wf' uf' bf' wi' ui' bi' wo' uo' bo' wc' bc')

87+ where

88+ -- Utility function for updating with the momentum, gradients, and weights.

89+ u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

90+ u e (e -> weights) (e -> momentum) (e -> gradient) =

91+ descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

92+

93+ v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

94+ v e (e -> weights) (e -> momentum) (e -> gradient) =

95+ descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

96+

97+ -- There's a lot of updates here, so to try and minimise the number of data copies

98+ -- we'll create a mutable bucket for each.

99+ -- runUpdates rate lstm gs =

100+ -- let combinedGradient = foldl1' uu gs

101+ -- in runUpdate rate lstm combinedGradient

102+ -- where

103+ -- uu :: (KnownNat i, KnownNat o) => LSTMWeights i o -> LSTMWeights i o -> LSTMWeights i o

104+ -- uu a b =

105+ -- let wf = u lstmWf a b

106+ -- uf = u lstmUf a b

107+ -- bf = v lstmBf a b

108+ -- wi = u lstmWi a b

109+ -- ui = u lstmUi a b

110+ -- bi = v lstmBi a b

111+ -- wo = u lstmWo a b

112+ -- uo = u lstmUo a b

113+ -- bo = v lstmBo a b

114+ -- wc = u lstmWc a b

115+ -- bc = v lstmBc a b

116+ -- in LSTMWeights wf uf bf wi ui bi wo uo bo wc bc

117+ -- u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> L out ix

118+ -- u e (e -> a) (e -> b) = tr $ tr a + tr b

119+

120+ -- v :: forall x ix. (x -> (R ix)) -> x -> x -> R ix

121+ -- v e (e -> a) (e -> b) = a + b

122+ createRandom = randomLSTM

123+

124+instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

125+ -- The recurrent shape is the same size as the output.

126+ -- It's actually the cell state however, as this is a peephole variety LSTM.

127+ type RecurrentShape (LSTM i o) = S ('D1 o)

128+

129+instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

130+

131+ -- The tape stores essentially every variable we calculate,

132+ -- so we don't have to run any forwards component again.

133+ type RecTape (LSTM i o) ('D1 i) ('D1 o) = (R o, R i, R o, R o, R o, R o, R o, R o, R o, R o, R o)

134+ -- Forward propagation for the LSTM layer.

135+ -- The size of the cell state is also the size of the output.

136+ runRecurrentForwards (LSTM lw _) (S1D cell) (S1D input) =

137+ let -- Forget state vector

138+ f_s = lstmBf lw + lstmWf lw #> input + lstmUf lw #> cell

139+ f_t = sigmoid f_s

140+ -- Input state vector

141+ i_s = lstmBi lw + lstmWi lw #> input + lstmUi lw #> cell

142+ i_t = sigmoid i_s

143+ -- Output state vector

144+ o_s = lstmBo lw + lstmWo lw #> input + lstmUo lw #> cell

145+ o_t = sigmoid o_s

146+ -- Cell input state vector

147+ c_s = lstmBc lw + lstmWc lw #> input

148+ c_x = tanh c_s

149+ -- Cell state

150+ c_t = f_t * cell + i_t * c_x

151+ -- Output (it's sometimes recommended to use tanh c_t)

152+ h_t = o_t * c_t

153+ in ((cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t), S1D c_t, S1D h_t)

154+

155+ -- Run a backpropogation step for an LSTM layer.

156+ -- We're doing all the derivatives by hand here, so one should

157+ -- be extra careful when changing this.

158+ --

159+ -- There's a test version using the AD library without hmatrix in the test

160+ -- suite. These should match always.

161+ runRecurrentBackwards (LSTM lw _) (cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t) (S1D cellGrad) (S1D h_t') =

162+ let -- Reverse Mode AD Derivitives

163+ c_t' = h_t' * o_t + cellGrad

164+

165+ f_t' = c_t' * cell

166+ f_s' = sigmoid' f_s * f_t'

167+

168+ o_t' = h_t' * c_t

169+ o_s' = sigmoid' o_s * o_t'

170+

171+ i_t' = c_t' * c_x

172+ i_s' = sigmoid' i_s * i_t'

173+

174+ c_x' = c_t' * i_t

175+ c_s' = tanh' c_s * c_x'

176+

177+ -- The derivatives to pass sideways (recurrent) and downwards

178+ cell' = tr (lstmUf lw) #> f_s' + tr (lstmUo lw) #> o_s' + tr (lstmUi lw) #> i_s' + c_t' * f_t

179+ input' = tr (lstmWf lw) #> f_s' + tr (lstmWo lw) #> o_s' + tr (lstmWi lw) #> i_s' + tr (lstmWc lw) #> c_s'

180+

181+ -- Calculate the gradient Matricies for the input

182+ lstmWf' = f_s' `outer` input

183+ lstmWi' = i_s' `outer` input

184+ lstmWo' = o_s' `outer` input

185+ lstmWc' = c_s' `outer` input

186+

187+ -- Calculate the gradient Matricies for the cell

188+ lstmUf' = f_s' `outer` cell

189+ lstmUi' = i_s' `outer` cell

190+ lstmUo' = o_s' `outer` cell

191+

192+ -- The biases just get the values, but we'll write it so it's obvious

193+ lstmBf' = f_s'

194+ lstmBi' = i_s'

195+ lstmBo' = o_s'

196+ lstmBc' = c_s'

197+

198+ gradients = LSTMWeights lstmWf' lstmUf' lstmBf' lstmWi' lstmUi' lstmBi' lstmWo' lstmUo' lstmBo' lstmWc' lstmBc'

199+ in (gradients, S1D cell', S1D input')

200+

201+-- | Generate an LSTM layer with random Weights

202+-- one can also just call createRandom from UpdateLayer

203+--

204+-- Has forget gate biases set to 1 to encourage early learning.

205+--

206+-- https://github.com/karpathy/char-rnn/commit/0dfeaa454e687dd0278f036552ea1e48a0a408c9

207+--

208+randomLSTM :: forall m i o. (MonadRandom m, KnownNat i, KnownNat o)

209+ => m (LSTM i o)

210+randomLSTM = do

211+ let w = (\s -> uniformSample s (-1) 1 ) <$> getRandom

212+ u = (\s -> uniformSample s (-1) 1 ) <$> getRandom

213+ v = (\s -> randomVector s Uniform * 2 - 1) <$> getRandom

214+

215+ w0 = konst 0

216+ u0 = konst 0

217+ v0 = konst 0

218+

219+ LSTM <$> (LSTMWeights <$> w <*> u <*> pure (konst 1) <*> w <*> u <*> v <*> w <*> u <*> v <*> w <*> v)

220+ <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

221+

222+-- | Maths

223+--

224+-- TODO: Move to not here

225+-- Optimise backwards derivative

226+sigmoid :: Floating a => a -> a

227+sigmoid x = 1 / (1 + exp (-x))

228+

229+sigmoid' :: Floating a => a -> a

230+sigmoid' x = logix * (1 - logix)

231+ where

232+ logix = sigmoid x

233+

234+tanh' :: (Floating a) => a -> a

235+tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

236+

237+instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

238+ put (LSTM lw _) = do

239+ u (lstmWf lw)

240+ u (lstmUf lw)

241+ v (lstmBf lw)

242+ u (lstmWi lw)

243+ u (lstmUi lw)

244+ v (lstmBi lw)

245+ u (lstmWo lw)

246+ u (lstmUo lw)

247+ v (lstmBo lw)

248+ u (lstmWc lw)

249+ v (lstmBc lw)

250+ where

251+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

252+ u = putListOf put . LA.toList . LA.flatten . extract

253+ v :: forall a. (KnownNat a) => Putter (R a)

254+ v = putListOf put . LA.toList . extract

255+

256+ get = do

257+ w <- LSTMWeights <$> u <*> u <*> v <*> u <*> u <*> v <*> u <*> u <*> v <*> u <*> v

258+ return $ LSTM w (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

259+ where

260+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

261+ u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

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

263+ v :: forall a. (KnownNat a) => Get (R a)

264+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

265+

266+ w0 = konst 0

267+ u0 = konst 0

268+ v0 = konst 0

src/Grenade/Utils/OneHot.hsnew file+94

@@ -0,0 +1,94 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE RankNTypes #-}

8+

9+module Grenade.Utils.OneHot (

10+ oneHot

11+ , hotMap

12+ , makeHot

13+ , unHot

14+ , sample

15+ ) where

16+

17+import qualified Control.Monad.Random as MR

18+

19+import Data.List ( group, sort )

20+

21+import Data.Map ( Map )

22+import qualified Data.Map as M

23+

24+import Data.Proxy

25+

26+import Data.Vector ( Vector )

27+import qualified Data.Vector as V

28+import qualified Data.Vector.Storable as VS

29+

30+import Numeric.LinearAlgebra ( maxIndex )

31+import Numeric.LinearAlgebra.Devel

32+import Numeric.LinearAlgebra.Static

33+import GHC.TypeLits

34+

35+import Grenade.Core.Shape

36+

37+-- | From an int which is hot, create a 1D Shape

38+-- with one index hot (1) with the rest 0.

39+-- Rerurns Nothing if the hot number is larger

40+-- than the length of the vector.

41+oneHot :: forall n. (KnownNat n)

42+ => Int -> Maybe (S ('D1 n))

43+oneHot hot =

44+ let len = fromIntegral $ natVal (Proxy :: Proxy n)

45+ in if hot < len

46+ then

47+ fmap S1D . create $ runSTVector $ do

48+ vec <- newVector 0 len

49+ writeVector vec hot 1

50+ return vec

51+ else Nothing

52+

53+-- | Create a one hot map from any enumerable.

54+-- Returns a map, and the ordered list for the reverse transformation

55+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Either String (Map a Int, Vector a)

56+hotMap n as =

57+ let len = fromIntegral $ natVal n

58+ uniq = [ c | (c:_) <- group $ sort as]

59+ hotl = length uniq

60+ in if hotl == len

61+ then

62+ Right (M.fromList $ zip uniq [0..], V.fromList uniq)

63+ else

64+ Left ("Couldn't create hotMap of size " ++ show len ++ " from vector with " ++ show hotl ++ " unique characters")

65+

66+-- | From a map and value, create a 1D Shape

67+-- with one index hot (1) with the rest 0.

68+-- Rerurns Nothing if the hot number is larger

69+-- than the length of the vector or the map

70+-- doesn't contain the value.

71+makeHot :: forall a n. (Ord a, KnownNat n)

72+ => Map a Int -> a -> Maybe (S ('D1 n))

73+makeHot m x = do

74+ hot <- M.lookup x m

75+ let len = fromIntegral $ natVal (Proxy :: Proxy n)

76+ if hot < len

77+ then

78+ fmap S1D . create $ runSTVector $ do

79+ vec <- newVector 0 len

80+ writeVector vec hot 1

81+ return vec

82+ else Nothing

83+

84+unHot :: forall a n. KnownNat n

85+ => Vector a -> S ('D1 n) -> Maybe a

86+unHot v (S1D xs)

87+ = (V.!?) v

88+ $ maxIndex (extract xs)

89+

90+sample :: forall a n m. (KnownNat n, MR.MonadRandom m)

91+ => Double -> Vector a -> S ('D1 n) -> m a

92+sample temperature v (S1D xs) = do

93+ ix <- MR.fromList . zip [0..] . fmap (toRational . exp . (/ temperature) . log) . VS.toList . extract $ xs

94+ return $ v V.! ix

stack.yamlnew file+78

@@ -0,0 +1,78 @@

1+# This file was automatically generated by 'stack init'

2+#

3+# Some commonly used options have been documented as comments in this file.

4+# For advanced use and comprehensive documentation of the format, please see:

5+# https://docs.haskellstack.org/en/stable/yaml_configuration/

6+

7+# A warning or info to be displayed to the user on config load.

8+# user-message: |

9+

10+# Resolver to choose a 'specific' stackage snapshot or a compiler version.

11+# A snapshot resolver dictates the compiler version and the set of packages

12+# to be used for project dependencies. For example:

13+#

14+# resolver: lts-3.5

15+# resolver: nightly-2015-09-21

16+# resolver: ghc-7.10.2

17+#

18+# The location of a snapshot can be provided as a file or url. Stack assumes

19+# a snapshot provided as a file might change, whereas a url resource does not.

20+#

21+# resolver: ./custom-snapshot.yaml

22+# resolver: https://example.com/snapshots/2018-01-01.yaml

23+resolver: lts-20.18

24+

25+# User packages to be built.

26+# Various formats can be used as shown in the example below.

27+#

28+# packages:

29+# - some-directory

30+# - https://example.com/foo/bar/baz-0.0.2.tar.gz

31+# subdirs:

32+# - auto-update

33+# - wai

34+packages:

35+ - .

36+ - examples

37+

38+# Dependency packages to be pulled from upstream that are not in the resolver.

39+# These entries can reference officially published versions as well as

40+# forks / in-progress versions pinned to a git hash. For example:

41+#

42+# extra-deps:

43+# - acme-missiles-0.3

44+# - git: https://github.com/commercialhaskell/stack.git

45+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

46+#

47+extra-deps:

48+ - typelits-witnesses-0.3.0.3

49+

50+# Override default flag values for local packages and extra-deps

51+# flags: {}

52+

53+# Extra package databases containing global packages

54+# extra-package-dbs: []

55+

56+# Control whether we use the GHC we find on the path

57+# system-ghc: true

58+#

59+# Require a specific version of stack, using version ranges

60+# require-stack-version: -any # Default

61+# require-stack-version: ">=2.1"

62+#

63+# Override the architecture used by stack, especially useful on Windows

64+# arch: i386

65+# arch: x86_64

66+#

67+# Extra directories used by stack for building

68+# extra-include-dirs: [/path/to/dir]

69+# extra-lib-dirs: [/path/to/dir]

70+#

71+# Allow a newer minor version of GHC than the snapshot specifies

72+# compiler-check: newer-minor

73+

74+nix:

75+ enable: true

76+ packages:

77+ - blas

78+ - lapack

stack.yaml.locknew file+19

@@ -0,0 +1,19 @@

1+# This file was autogenerated by Stack.

2+# You should not edit this file by hand.

3+# For more information, please see the documentation at:

4+# https://docs.haskellstack.org/en/stable/lock_files

5+

6+packages:

7+- completed:

8+ hackage: typelits-witnesses-0.3.0.3@sha256:2d9df4ac6ff3077bfd2bf659e4b495e157723ac5b45c519762853f55df5c16db,2738

9+ pantry-tree:

10+ sha256: 6a42a462f98e94933b6e9721acd912c6c6b6a4743635efd15cc5871908c816a0

11+ size: 469

12+ original:

13+ hackage: typelits-witnesses-0.3.0.3

14+snapshots:

15+- completed:

16+ sha256: 9fa4bece7acfac1fc7930c5d6e24606004b09e80aa0e52e9f68b148201008db9

17+ size: 649606

18+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/18.yaml

19+ original: lts-20.18

test/Test/Grenade/Layers/Convolution.hs+98−251

@@ -1,261 +1,108 @@

1−{-# LANGUAGE TemplateHaskell #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TemplateHaskell #-}

23{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE ConstraintKinds #-}

8+{-# LANGUAGE TypeOperators #-}

49{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

510module Test.Grenade.Layers.Convolution where

611

7−import Grenade.Core.Shape

8−import Grenade.Core.Vector as Grenade

9−import Grenade.Core.Network

10−import Grenade.Layers.Convolution

11−import Grenade.Layers.Internal.Convolution

12−

13−import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

14−import qualified Numeric.LinearAlgebra.Static as HStatic

15−

16−import Test.QuickCheck hiding ((><))

17−

18−prop_im2col_no_stride = once $

19− let input = (3><4)

20− [ 1.0, 2.0, 3.0, 4.0

21− , 5.0, 6.0, 7.0, 8.0

22− , 9.0, 10.0, 11.0, 12.0 ]

23− expected = (6><4)

24− [ 1.0, 2.0, 5.0, 6.0

25− , 2.0, 3.0, 6.0, 7.0

26− , 3.0, 4.0, 7.0, 8.0

27− , 5.0, 6.0, 9.0, 10.0

28− , 6.0, 7.0, 10.0, 11.0

29− , 7.0, 8.0, 11.0, 12.0 ]

30− out = im2colUnsafe 2 2 1 1 input

31− in expected === out

32−

33−prop_im2col_stride = once $

34− let input = (3><4)

35− [ 1.0, 2.0, 3.0, 4.0

36− , 5.0, 6.0, 7.0, 8.0

37− , 9.0, 10.0, 11.0, 12.0 ]

38− expected = (4><4)

39− [ 1.0, 2.0, 5.0, 6.0

40− , 3.0, 4.0, 7.0, 8.0

41− , 5.0, 6.0, 9.0, 10.0

42− , 7.0, 8.0, 11.0, 12.0 ]

43− out = im2colUnsafe 2 2 1 2 input

44− in expected === out

45−

46−prop_im2col_other = once $

47− let input = (3><4)

48− [ 1.0, 2.0, 3.0, 4.0

49− , 5.0, 6.0, 7.0, 8.0

50− , 9.0, 10.0, 11.0, 12.0 ]

51− expected = (2><6)

52− [ 1.0, 2.0, 5.0, 6.0 , 9.0, 10.0

53− , 3.0, 4.0, 7.0, 8.0 , 11.0 ,12.0 ]

54− out = im2colUnsafe 3 2 1 2 input

55− in expected === out

56−

57−-- If there's no overlap (stride is the same size as the kernel)

58−-- then col2im . im2col should be symmetric.

59−prop_im2col_sym_on_same_stride = once $

60− let input = (3><4)

61− [ 1.0, 2.0, 3.0, 4.0

62− , 5.0, 6.0, 7.0, 8.0

63− , 9.0, 10.0, 11.0, 12.0 ]

64− out = col2imUnsafe 3 2 3 2 3 4 . im2colUnsafe 3 2 3 2 $ input

65− in input === out

66−

67−-- If there's no overlap (stride is the same size as the kernel)

68−-- then col2im . im2col should be symmetric.

69−prop_im2colunsafe_sym_on_same_stride = once $

70− let input = (3><4)

71− [ 1.0, 2.0, 3.0, 4.0

72− , 5.0, 6.0, 7.0, 8.0

73− , 9.0, 10.0, 11.0, 12.0 ]

74− out = col2imUnsafe 3 2 3 2 3 4 . im2colUnsafe 3 2 3 2 $ input

75− in input === out

76−

77−

78−-- If there is an overlap, then the gradient passed back should be

79−-- the sum of the gradients across the filters.

80−prop_im2col_col2im_additive = once $

81− let input = (3><4)

82− [ 1.0, 1.0, 1.0, 1.0

83− , 1.0, 1.0, 1.0, 1.0

84− , 1.0, 1.0, 1.0, 1.0 ]

85− expected = (3><4)

86− [ 1.0, 2.0, 2.0, 1.0

87− , 2.0, 4.0, 4.0, 2.0

88− , 1.0, 2.0, 2.0, 1.0 ]

89− out = col2imUnsafe 2 2 1 1 3 4 . im2colUnsafe 2 2 1 1 $ input

90− in expected === out

91−

92−prop_simple_conv_forwards = once $

93− -- Create a convolution kernel with 4 filters.

94− -- [ 1, 0 [ 0, 1 [ 0, 1 [ 0, 0

95− -- , 0,-1 ] ,-1, 0 ] , 1, 0 ] ,-1,-1 ]

96− let myKernel = HStatic.matrix

97− [ 1.0, 0.0, 0.0, 0.0

98− , 0.0, 1.0, 1.0, 0.0

99− , 0.0, -1.0, 1.0, -1.0

100− ,-1.0, 0.0, 0.0, -1.0 ] :: HStatic.L 4 4

101− zeroKernel = HStatic.matrix

102− [ 0.0, 0.0, 0.0, 0.0

103− , 0.0, 0.0, 0.0, 0.0

104− , 0.0, 0.0, 0.0, 0.0

105− , 0.0, 0.0, 0.0, 0.0 ] :: HStatic.L 4 4

106−

107− expectedGradient = HStatic.matrix

108− [ 1.0, 0.0, 0.0, 2.0

109− , 2.0, 0.0, 0.0, 5.0

110− , 3.0, 0.0, 0.0, 4.0

111− , 4.0, 0.0, 0.0, 6.0 ] :: HStatic.L 4 4

112−

113− convLayer = Convolution myKernel zeroKernel :: Convolution 1 4 2 2 1 1

114−

115− input = S2D' (HStatic.matrix

116− [ 1.0, 2.0, 5.0

117− , 3.0, 4.0, 6.0] :: HStatic.L 2 3)

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

11818

119− expect = [ HStatic.matrix

120− [ -3.0 , -4.0 ] :: HStatic.L 1 2

121− , HStatic.matrix

122− [ -1.0 , 1.0 ] :: HStatic.L 1 2

123− , HStatic.matrix

124− [ 5.0 , 9.0 ] :: HStatic.L 1 2

125− , HStatic.matrix

126− [ -7.0 , -10.0 ] :: HStatic.L 1 2] :: [HStatic.L 1 2]

127− out = runForwards convLayer input :: S' ('D3 1 2 4)

19+#if MIN_VERSION_base(4,9,0)

20+import Data.Kind (Type)

21+#endif

12822

129− grad = S3D' ( mkVector

130− [ HStatic.matrix

131− [ 1 , 0 ] :: HStatic.L 1 2

132− , HStatic.matrix

133− [ 0 , 0 ] :: HStatic.L 1 2

134− , HStatic.matrix

135− [ 0 , 0 ] :: HStatic.L 1 2

136− , HStatic.matrix

137− [ 0 , 1 ] :: HStatic.L 1 2] ) :: S' ('D3 1 2 4)

138−

139− expectBack = (HStatic.matrix

140− [ 1.0, 0.0, 0.0

141− , 0.0, -2.0,-1.0] :: HStatic.L 2 3)

142− (nc, inX) = runBackwards convLayer input grad

143−

144− in case (out, inX, nc) of

145− (S3D' out' , S2D' inX', Convolution' backGrad)

146− -> ((HStatic.extract <$> expect) === (HStatic.extract <$> vecToList out'))

147− .&&. (HStatic.extract expectBack === HStatic.extract inX')

148− .&&. (HStatic.extract expectedGradient === HStatic.extract backGrad)

149−

150−prop_vid2col_no_stride = once $

151− let input = [(3><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− , (3><4)

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 = (6><8)

160− [ 1.0, 2.0, 5.0, 6.0 , 21.0, 22.0, 25.0, 26.0

161− , 2.0, 3.0, 6.0, 7.0 , 22.0, 23.0, 26.0, 27.0

162− , 3.0, 4.0, 7.0, 8.0 , 23.0, 24.0, 27.0, 28.0

163− , 5.0, 6.0, 9.0, 10.0 , 25.0, 26.0, 29.0, 30.0

164− , 6.0, 7.0, 10.0, 11.0 , 26.0, 27.0, 30.0, 31.0

165− , 7.0, 8.0, 11.0, 12.0 , 27.0, 28.0, 31.0, 32.0 ]

166− out = vid2colUnsafe 2 2 1 1 3 4 input

167− in expected === out

168−

169−prop_vid2col_stride = once $

170− let input = [(3><4)

171− [ 1.0, 2.0, 3.0, 4.0

172− , 5.0, 6.0, 7.0, 8.0

173− , 9.0, 10.0, 11.0, 12.0 ]

174− , (3><4)

175− [ 21.0, 22.0, 23.0, 24.0

176− , 25.0, 26.0, 27.0, 28.0

177− , 29.0, 30.0, 31.0, 32.0 ] ]

178− expected = (4><8)

179− [ 1.0, 2.0, 5.0, 6.0 , 21.0, 22.0, 25.0, 26.0

180− , 3.0, 4.0, 7.0, 8.0 , 23.0, 24.0, 27.0, 28.0

181− , 5.0, 6.0, 9.0, 10.0 , 25.0, 26.0, 29.0, 30.0

182− , 7.0, 8.0, 11.0, 12.0 , 27.0, 28.0, 31.0, 32.0 ]

183− out = vid2colUnsafe 2 2 1 2 3 4 input

184− in expected === out

185−

186−prop_vid2col_invert = once $

187− let input = [(3><4)

188− [ 1.0, 2.0, 3.0, 4.0

189− , 5.0, 6.0, 7.0, 8.0

190− , 9.0, 10.0, 11.0, 12.0 ]

191− , (3><4)

192− [ 21.0, 22.0, 23.0, 24.0

193− , 25.0, 26.0, 27.0, 28.0

194− , 29.0, 30.0, 31.0, 32.0 ] ]

195− out = col2vidUnsafe 3 2 3 2 3 4 . vid2colUnsafe 3 2 3 2 3 4 $ input

196− in input === out

197−

198−

199−-- This test show that 2D convs act the same

200−-- 3D convs with one layer

201−prop_single_conv_forwards = once $

202− -- Create a convolution kernel with 4 filters.

203− -- [ 1, 0 [ 0, 1 [ 0, 1 [ 0, 0

204− -- , 0,-1 ] ,-1, 0 ] , 1, 0 ] ,-1,-1 ]

205− let myKernel = (HStatic.matrix

206− [ 1.0, 0.0, 0.0, 0.0

207− , 0.0, 1.0, 1.0, 0.0

208− , 0.0, -1.0, 1.0, -1.0

209− ,-1.0, 0.0, 0.0, -1.0 ] :: HStatic.L 4 4)

210− zeroKernel = (HStatic.matrix

211− [ 0.0, 0.0, 0.0, 0.0

212− , 0.0, 0.0, 0.0, 0.0

213− , 0.0, 0.0, 0.0, 0.0

214− , 0.0, 0.0, 0.0, 0.0 ] :: HStatic.L 4 4)

215−

216− expectedGradient = (HStatic.matrix

217− [ 1.0, 0.0, 0.0, 2.0

218− , 2.0, 0.0, 0.0, 5.0

219− , 3.0, 0.0, 0.0, 4.0

220− , 4.0, 0.0, 0.0, 6.0 ] :: HStatic.L 4 4)

221−

222− convLayer = Convolution myKernel zeroKernel :: Convolution 1 4 2 2 1 1

223−

224− input = S3D' ( mkVector [HStatic.matrix

225− [ 1.0, 2.0, 5.0

226− , 3.0, 4.0, 6.0] :: HStatic.L 2 3] ) :: S' ('D3 2 3 1)

227−

228− expect = [HStatic.matrix

229− [ -3.0 , -4.0 ] :: HStatic.L 1 2

230− ,HStatic.matrix

231− [ -1.0 , 1.0 ] :: HStatic.L 1 2

232− ,HStatic.matrix

233− [ 5.0 , 9.0 ] :: HStatic.L 1 2

234− ,HStatic.matrix

235− [ -7.0 , -10.0 ] :: HStatic.L 1 2] :: [HStatic.L 1 2]

236− out = runForwards convLayer input :: S' ('D3 1 2 4)

237−

238− grad = S3D' ( mkVector

239− [HStatic.matrix

240− [ 1 , 0 ] :: HStatic.L 1 2

241− ,HStatic.matrix

242− [ 0 , 0 ] :: HStatic.L 1 2

243− ,HStatic.matrix

244− [ 0 , 0 ] :: HStatic.L 1 2

245− ,HStatic.matrix

246− [ 0 , 1 ] :: HStatic.L 1 2] ) :: S' ('D3 1 2 4)

23+import Grenade.Core

24+import Grenade.Layers.Convolution

24725

248− expectBack = (HStatic.matrix

249− [ 1.0, 0.0, 0.0

250− , 0.0, -2.0,-1.0] :: HStatic.L 2 3)

251− (nc, inX) = runBackwards convLayer input grad

26+import Hedgehog

27+import qualified Hedgehog.Gen as Gen

28+

29+import Test.Hedgehog.Hmatrix

30+import Test.Hedgehog.TypeLits

31+import Test.Hedgehog.Compat

32+

33+data OpaqueConvolution :: Type where

34+ OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution

35+

36+instance Show OpaqueConvolution where

37+ show (OpaqueConvolution n) = show n

38+

39+genConvolution :: ( KnownNat channels

40+ , KnownNat filters

41+ , KnownNat kernelRows

42+ , KnownNat kernelColumns

43+ , KnownNat strideRows

44+ , KnownNat strideColumns

45+ , KnownNat kernelFlattened

46+ , kernelFlattened ~ (kernelRows * kernelColumns * channels)

47+ ) => Gen (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

48+genConvolution = Convolution <$> uniformSample <*> uniformSample

49+

50+genOpaqueOpaqueConvolution :: Gen OpaqueConvolution

51+genOpaqueOpaqueConvolution = do

52+ channels <- genNat

53+ filters <- genNat

54+ kernel_h <- genNat

55+ kernel_w <- genNat

56+ stride_h <- genNat

57+ stride_w <- genNat

58+ case (channels, filters, kernel_h, kernel_w, stride_h, stride_w) of

59+ ( SomeNat (pch :: Proxy ch), SomeNat (_ :: Proxy fl),

60+ SomeNat (pkr :: Proxy kr), SomeNat (pkc :: Proxy kc),

61+ SomeNat (_ :: Proxy sr), SomeNat (_ :: Proxy sc)) ->

62+ let p1 = natDict pkr

63+ p2 = natDict pkc

64+ p3 = natDict pch

65+ in case p1 %* p2 %* p3 of

66+ Dict -> OpaqueConvolution <$> (genConvolution :: Gen (Convolution ch fl kr kc sr sc))

67+

68+prop_conv_net_witness = property $

69+ blindForAll genOpaqueOpaqueConvolution >>= \onet ->

70+ case onet of

71+ (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> success

72+

73+

74+prop_conv_net = property $

75+ blindForAll genOpaqueOpaqueConvolution >>= \onet ->

76+ case onet of

77+ (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->

78+ let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]

79+ kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

80+ kc = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

81+ sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)

82+ sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)

83+

84+ in forAll (Gen.element (ok sr kr)) >>= \er ->

85+ forAll (Gen.element (ok sc kc)) >>= \ec ->

86+ let rr = ((er - kr) `div` sr) + 1

87+ rc = ((ec - kc) `div` sc) + 1

88+ Just er' = someNatVal er

89+ Just ec' = someNatVal ec

90+ Just rr' = someNatVal rr

91+ Just rc' = someNatVal rc

92+ in case (er', ec', rr', rc') of

93+ ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->

94+ case ( natDict pinr %* natDict (Proxy :: Proxy channels)

95+ , natDict pour %* natDict (Proxy :: Proxy filters)

96+ -- Fake it till you make it.

97+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

98+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

99+ (Dict, Dict, Dict, Dict) ->

100+ blindForAll (S3D <$> uniformSample) >>= \(input :: S ('D3 inRows inCols channels)) ->

101+ let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input

102+ backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))

103+ = runBackwards convLayer tape output

104+ in backed `seq` success

252105

253− in case (out, inX, nc) of

254− (S3D' out' , S3D' inX', Convolution' backGrad)

255− -> ((HStatic.extract <$> expect) === (HStatic.extract <$> vecToList out'))

256− .&&. ([HStatic.extract expectBack] === (HStatic.extract <$> vecToList inX'))

257− .&&. (HStatic.extract expectedGradient === HStatic.extract backGrad)

258106

259−return []

260107tests :: IO Bool

261−tests = $quickCheckAll

108+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/FullyConnected.hsnew file+58

@@ -0,0 +1,58 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE TemplateHaskell #-}

4+{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE KindSignatures #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

9+module Test.Grenade.Layers.FullyConnected where

10+

11+import Data.Proxy

12+import Data.Singletons ()

13+

14+import GHC.TypeLits

15+

16+#if MIN_VERSION_base(4,9,0)

17+import Data.Kind (Type)

18+#endif

19+

20+import Grenade.Core

21+import Grenade.Layers.FullyConnected

22+

23+import Hedgehog

24+

25+import Test.Hedgehog.Compat

26+import Test.Hedgehog.Hmatrix

27+

28+data OpaqueFullyConnected :: Type where

29+ OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected

30+

31+instance Show OpaqueFullyConnected where

32+ show (OpaqueFullyConnected n) = show n

33+

34+genOpaqueFullyConnected :: Gen OpaqueFullyConnected

35+genOpaqueFullyConnected = do

36+ input :: Integer <- choose 2 100

37+ output :: Integer <- choose 1 100

38+ let Just input' = someNatVal input

39+ let Just output' = someNatVal output

40+ case (input', output') of

41+ (SomeNat (Proxy :: Proxy i'), SomeNat (Proxy :: Proxy o')) -> do

42+ wB <- randomVector

43+ bM <- randomVector

44+ wN <- uniformSample

45+ kM <- uniformSample

46+ return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')

47+

48+prop_fully_connected_forwards :: Property

49+prop_fully_connected_forwards = property $ do

50+ OpaqueFullyConnected (fclayer :: FullyConnected i o) <- blindForAll genOpaqueFullyConnected

51+ input :: S ('D1 i) <- blindForAll (S1D <$> randomVector)

52+ let (tape, output :: S ('D1 o)) = runForwards fclayer input

53+ backed :: (Gradient (FullyConnected i o), S ('D1 i))

54+ = runBackwards fclayer tape output

55+ backed `seq` success

56+

57+tests :: IO Bool

58+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Internal/Convolution.hsnew file+57

@@ -0,0 +1,57 @@

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 Grenade.Layers.Internal.Convolution

12+

13+import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

14+

15+import Hedgehog

16+import qualified Hedgehog.Gen as Gen

17+import qualified Hedgehog.Range as Range

18+

19+import qualified Test.Grenade.Layers.Internal.Reference as Reference

20+import Test.Hedgehog.Compat

21+

22+prop_im2col_col2im_symmetrical_with_kernel_stride =

23+ let factors n = [x | x <- [1..n], n `mod` x == 0]

24+ in property $ do

25+ height <- forAll $ choose 2 100

26+ width <- forAll $ choose 2 100

27+ kernel_h <- forAll $ (height `div`) <$> Gen.element (factors height)

28+ kernel_w <- forAll $ (width `div`) <$> Gen.element (factors width)

29+ input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

30+

31+ let stride_h = kernel_h

32+ let stride_w = kernel_w

33+ let out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input

34+ input === out

35+

36+prop_im2col_col2im_behaves_as_reference =

37+ let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

38+ in property $ do

39+ height <- forAll (choose 2 100)

40+ width <- forAll (choose 2 100)

41+ kernel_h <- forAll (choose 2 (height - 1))

42+ kernel_w <- forAll (choose 2 (width - 1))

43+ stride_h <- forAll (Gen.element (ok height kernel_h))

44+ stride_w <- forAll (Gen.element (ok width kernel_w))

45+ input <- forAll ((height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100))

46+

47+ let outFast = im2col kernel_h kernel_w stride_h stride_w input

48+ let retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast

49+

50+ let outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input

51+ let retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference

52+

53+ outFast === outReference

54+ retFast === retReference

55+

56+tests :: IO Bool

57+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Internal/Pooling.hsnew file+45

@@ -0,0 +1,45 @@

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 Hedgehog

16+import qualified Hedgehog.Gen as Gen

17+import qualified Hedgehog.Range as Range

18+

19+import qualified Test.Grenade.Layers.Internal.Reference as Reference

20+import Test.Hedgehog.Compat

21+

22+prop_poolForwards_poolBackwards_behaves_as_reference =

23+ let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

24+ output extent kernel stride = (extent - kernel) `div` stride + 1

25+ in property $ do

26+ height <- forAll $ choose 2 100

27+ width <- forAll $ choose 2 100

28+ kernel_h <- forAll $ choose 1 (height - 1)

29+ kernel_w <- forAll $ choose 1 (width - 1)

30+ stride_h <- forAll $ Gen.element (ok height kernel_h)

31+ stride_w <- forAll $ Gen.element (ok width kernel_w)

32+ input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

33+

34+ let outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input

35+ let retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input outFast

36+

37+ let outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input

38+ let retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input outReference

39+

40+ outFast === outReference

41+ retFast === retReference

42+

43+

44+tests :: IO Bool

45+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Internal/Reference.hsnew file+100

@@ -0,0 +1,100 @@

1+module Test.Grenade.Layers.Internal.Reference where

2+

3+import Numeric.LinearAlgebra

4+

5+im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

6+im2col nrows ncols srows scols m =

7+ let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols

8+ in im2colFit starts nrows ncols m

9+

10+vid2col :: Int -> Int -> Int -> Int -> Int -> Int -> [Matrix Double] -> Matrix Double

11+vid2col nrows ncols srows scols inputrows inputcols ms =

12+ let starts = fittingStarts inputrows nrows srows inputcols ncols scols

13+ subs = fmap (im2colFit starts nrows ncols) ms

14+ in foldl1 (|||) subs

15+

16+im2colFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double

17+im2colFit starts nrows ncols m =

18+ let imRows = fmap (\start -> flatten $ subMatrix start (nrows, ncols) m) starts

19+ in fromRows imRows

20+

21+col2vid :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> [Matrix Double]

22+col2vid nrows ncols srows scols drows dcols m =

23+ let starts = fittingStart (cols m) (nrows * ncols) (nrows * ncols)

24+ r = rows m

25+ mats = fmap (\s -> subMatrix (0,s) (r, nrows * ncols) m) starts

26+ colSts = fittingStarts drows nrows srows dcols ncols scols

27+ in fmap (col2imfit colSts nrows ncols drows dcols) mats

28+

29+col2im :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

30+col2im krows kcols srows scols drows dcols m =

31+ let starts = fittingStarts drows krows srows dcols kcols scols

32+ in col2imfit starts krows kcols drows dcols m

33+

34+col2imfit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

35+col2imfit starts krows kcols drows dcols m =

36+ let indicies = (\[a,b] -> (a,b)) <$> sequence [[0..(krows-1)], [0..(kcols-1)]]

37+ convs = fmap (zip indicies . toList) . toRows $ m

38+ pairs = zip convs starts

39+ accums = concatMap (\(conv',(stx',sty')) -> fmap (\((ix,iy), val) -> ((ix + stx', iy + sty'), val)) conv') pairs

40+ in accum (konst 0 (drows, dcols)) (+) accums

41+

42+poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

43+poolForward nrows ncols srows scols outputRows outputCols m =

44+ let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols

45+ in poolForwardFit starts nrows ncols outputRows outputCols m

46+

47+poolForwardList :: Functor f => Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> f (Matrix Double) -> f (Matrix Double)

48+poolForwardList nrows ncols srows scols inRows inCols outputRows outputCols ms =

49+ let starts = fittingStarts inRows nrows srows inCols ncols scols

50+ in poolForwardFit starts nrows ncols outputRows outputCols <$> ms

51+

52+poolForwardFit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

53+poolForwardFit starts nrows ncols _ outputCols m =

54+ let els = fmap (\start -> maxElement $ subMatrix start (nrows, ncols) m) starts

55+ in matrix outputCols els

56+

57+poolBackward :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double

58+poolBackward krows kcols srows scols inputMatrix gradientMatrix =

59+ let inRows = rows inputMatrix

60+ inCols = cols inputMatrix

61+ starts = fittingStarts inRows krows srows inCols kcols scols

62+ in poolBackwardFit starts krows kcols inputMatrix gradientMatrix

63+

64+poolBackwardList :: Functor f => Int -> Int -> Int -> Int -> Int -> Int -> f (Matrix Double, Matrix Double) -> f (Matrix Double)

65+poolBackwardList krows kcols srows scols inRows inCols inputMatrices =

66+ let starts = fittingStarts inRows krows srows inCols kcols scols

67+ in uncurry (poolBackwardFit starts krows kcols) <$> inputMatrices

68+

69+poolBackwardFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double

70+poolBackwardFit starts krows kcols inputMatrix gradientMatrix =

71+ let inRows = rows inputMatrix

72+ inCols = cols inputMatrix

73+ inds = fmap (\start -> maxIndex $ subMatrix start (krows, kcols) inputMatrix) starts

74+ grads = toList $ flatten gradientMatrix

75+ grads' = zip3 starts grads inds

76+ accums = fmap (\((stx',sty'),grad,(inx, iny)) -> ((stx' + inx, sty' + iny), grad)) grads'

77+ in accum (konst 0 (inRows, inCols)) (+) accums

78+

79+-- | These functions are not even remotely safe, but it's only called from the statically typed

80+-- commands, so we should be good ?!?!?

81+-- Returns the starting sub matrix locations which fit inside the larger matrix for the

82+-- convolution. Takes into account the stride and kernel size.

83+fittingStarts :: Int -> Int -> Int -> Int -> Int -> Int -> [(Int,Int)]

84+fittingStarts nrows kernelrows steprows ncols kernelcols stepcolsh =

85+ let rs = fittingStart nrows kernelrows steprows

86+ cs = fittingStart ncols kernelcols stepcolsh

87+ ls = sequence [rs, cs]

88+ in fmap (\[a,b] -> (a,b)) ls

89+

90+-- | Returns the starting sub vector which fit inside the larger vector for the

91+-- convolution. Takes into account the stride and kernel size.

92+fittingStart :: Int -> Int -> Int -> [Int]

93+fittingStart width kernel steps =

94+ let go left | left + kernel < width

95+ = left : go (left + steps)

96+ | left + kernel == width

97+ = [left]

98+ | otherwise

99+ = []

100+ in go 0

test/Test/Grenade/Layers/Nonlinear.hsnew file+54

@@ -0,0 +1,54 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE TemplateHaskell #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE LambdaCase #-}

8+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

9+module Test.Grenade.Layers.Nonlinear where

10+

11+import Data.Singletons

12+

13+import Grenade

14+

15+import Hedgehog

16+

17+import Test.Hedgehog.Compat

18+import Test.Hedgehog.Hmatrix

19+import Test.Hedgehog.TypeLits

20+

21+import Numeric.LinearAlgebra.Static ( norm_Inf )

22+

23+prop_sigmoid_grad :: Property

24+prop_sigmoid_grad = property $

25+ forAllWith rss genShape >>= \case

26+ (SomeSing (r :: Sing s)) ->

27+ withSingI r $

28+ blindForAll genOfShape >>= \(ds :: S s) ->

29+ let (tape, f :: S s) = runForwards Logit ds

30+ ((), ret :: S s) = runBackwards Logit tape (1 :: S s)

31+ (_, numer :: S s) = runForwards Logit (ds + 0.0001)

32+ numericalGradient = (numer - f) * 10000

33+ in assert ((case numericalGradient - ret of

34+ (S1D x) -> norm_Inf x < 0.0001

35+ (S2D x) -> norm_Inf x < 0.0001

36+ (S3D x) -> norm_Inf x < 0.0001) :: Bool)

37+

38+prop_tanh_grad :: Property

39+prop_tanh_grad = property $

40+ forAllWith rss genShape >>= \case

41+ (SomeSing (r :: Sing s)) ->

42+ withSingI r $

43+ blindForAll genOfShape >>= \(ds :: S s) ->

44+ let (tape, f :: S s) = runForwards Tanh ds

45+ ((), ret :: S s) = runBackwards Tanh tape (1 :: S s)

46+ (_, numer :: S s) = runForwards Tanh (ds + 0.0001)

47+ numericalGradient = (numer - f) * 10000

48+ in assert ((case numericalGradient - ret of

49+ (S1D x) -> norm_Inf x < 0.001

50+ (S2D x) -> norm_Inf x < 0.001

51+ (S3D x) -> norm_Inf x < 0.001) :: Bool)

52+

53+tests :: IO Bool

54+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/PadCrop.hsnew file+49

@@ -0,0 +1,49 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE TemplateHaskell #-}

4+{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE KindSignatures #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

9+

10+module Test.Grenade.Layers.PadCrop where

11+

12+import Grenade

13+

14+import Hedgehog

15+

16+import Numeric.LinearAlgebra.Static ( norm_Inf )

17+

18+import Test.Hedgehog.Hmatrix

19+

20+prop_pad_crop :: Property

21+prop_pad_crop =

22+ let net :: Network '[Pad 2 3 4 6, Crop 2 3 4 6] '[ 'D3 7 9 5, 'D3 16 15 5, 'D3 7 9 5 ]

23+ net = Pad :~> Crop :~> NNil

24+ in property $

25+ forAll genOfShape >>= \(d :: S ('D3 7 9 5)) ->

26+ let (tapes, res) = runForwards net d

27+ (_ , grad) = runBackwards net tapes d

28+ in do assert $ d ~~~ res

29+ assert $ grad ~~~ d

30+

31+prop_pad_crop_2d :: Property

32+prop_pad_crop_2d =

33+ let net :: Network '[Pad 2 3 4 6, Crop 2 3 4 6] '[ 'D2 7 9, 'D2 16 15, 'D2 7 9 ]

34+ net = Pad :~> Crop :~> NNil

35+ in property $

36+ forAll genOfShape >>= \(d :: S ('D2 7 9)) ->

37+ let (tapes, res) = runForwards net d

38+ (_ , grad) = runBackwards net tapes d

39+ in do assert $ d ~~~ res

40+ assert $ grad ~~~ d

41+

42+(~~~) :: S x -> S x -> Bool

43+(S1D x) ~~~ (S1D y) = norm_Inf (x - y) < 0.00001

44+(S2D x) ~~~ (S2D y) = norm_Inf (x - y) < 0.00001

45+(S3D x) ~~~ (S3D y) = norm_Inf (x - y) < 0.00001

46+

47+

48+tests :: IO Bool

49+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Pooling.hs+38−56

@@ -1,67 +1,49 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GADTs #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TemplateHaskell #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

47{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

58module Test.Grenade.Layers.Pooling where

69

7−import Grenade.Layers.Internal.Pooling

10+import Data.Proxy

11+import Data.Singletons ()

812

9−import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

13+#if MIN_VERSION_base(4,9,0)

14+import Data.Kind (Type)

15+#endif

1016

11−import Test.QuickCheck hiding ((><))

17+import GHC.TypeLits

18+import Grenade.Layers.Pooling

1219

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 2 2 1 1 2 3 input

22− in expected === out

20+import Hedgehog

2321

24−prop_pool_rectangular = once $

25− let input = (3><4)

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 2 3 1 1 2 2 input

33− in expected === out

22+import Test.Hedgehog.Compat

3423

35−prop_pool_backwards = once $

36− let input = (3><4)

37− [ 1.0, 2.0, 3.0, 4.0

38− , 5.0, 6.0, 7.0, 8.0

39− , 9.0, 10.0, 11.0, 12.0 ]

40− grads = (2><3)

41− [ -6.0, -7.0, -8.0

42− , -10.0, -11.0, -12.0 ]

43− expected = (3><4)

44− [ 0.0, 0.0, 0.0, 0.0

45− , 0.0, -6.0, -7.0, -8.0

46− , 0.0,-10.0,-11.0,-12.0 ]

47− out = poolBackward 2 2 1 1 input grads

48− in expected === out

24+data OpaquePooling :: Type where

25+ OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

4926

50−prop_pool_backwards_additive = once $

51− let input = (3><4)

52− [ 4.0, 2.0, 3.0, 4.0

53− , 0.0, 0.0, 7.0, 8.0

54− , 9.0, 0.0, 0.0, 0.0 ]

55− grads = (2><3)

56− [ -6.0, -7.0, -8.0

57− , -10.0, -11.0, -12.0 ]

58− expected = (3><4)

59− [-6.0, 0.0, 0.0, 0.0

60− , 0.0, 0.0,-18.0,-20.0

61− ,-10.0, 0.0, 0.0, 0.0 ]

62− out = poolBackward 2 2 1 1 input grads

63− in expected === out

27+instance Show OpaquePooling where

28+ show (OpaquePooling n) = show n

29+

30+genOpaquePooling :: Gen OpaquePooling

31+genOpaquePooling = do

32+ ~(Just kernelHeight) <- someNatVal <$> choose 2 15

33+ ~(Just kernelWidth ) <- someNatVal <$> choose 2 15

34+ ~(Just strideHeight) <- someNatVal <$> choose 2 15

35+ ~(Just strideWidth ) <- someNatVal <$> choose 2 15

36+

37+ case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

38+ (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

39+ return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)

40+

41+prop_pool_layer_witness =

42+ property $ do

43+ onet <- forAll genOpaquePooling

44+ case onet of

45+ (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) ->

46+ assert True

6447

65−return []

6648tests :: IO Bool

67−tests = $quickCheckAll

49+tests = checkParallel $$(discover)

test/Test/Grenade/Network.hsnew file+504

@@ -0,0 +1,504 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE TypeOperators #-}

9+{-# LANGUAGE TemplateHaskell #-}

10+{-# LANGUAGE FlexibleContexts #-}

11+module Test.Grenade.Network where

12+

13+import Control.Monad ( guard )

14+import Control.Monad.ST ( runST )

15+

16+import Data.Constraint

17+import qualified Data.Vector.Storable as VS

18+import qualified Data.Vector.Storable.Mutable as VS ( write )

19+import Data.Singletons

20+import Data.Singletons.Prelude.List

21+import Data.Singletons.TypeLits

22+

23+import Hedgehog

24+import qualified Hedgehog.Gen as Gen

25+import Hedgehog.Internal.Source

26+import Hedgehog.Internal.Property ( failWith )

27+

28+import Grenade

29+

30+#if MIN_VERSION_base(4,11,0)

31+import GHC.TypeLits hiding (natVal)

32+#else

33+import GHC.TypeLits

34+#endif

35+#if MIN_VERSION_base(4,9,0)

36+import Data.Kind (Type)

37+#endif

38+

39+import GHC.TypeLits.Witnesses

40+import Test.Hedgehog.Compat

41+import Test.Hedgehog.TypeLits

42+import Test.Hedgehog.Hmatrix

43+import Test.Grenade.Layers.Convolution

44+

45+import Numeric.LinearAlgebra ( flatten )

46+import Numeric.LinearAlgebra.Static ( extract, norm_Inf )

47+import Unsafe.Coerce

48+

49+data SomeNetwork :: Type where

50+ SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork

51+

52+instance Show SomeNetwork where

53+ show (SomeNetwork net) = show net

54+

55+-- | Generate a random network of a random type

56+--

57+-- This is slightly insane for a few reasons. Everything must be wrapped up

58+-- in a SomeNetwork.

59+genNetwork :: Gen SomeNetwork

60+genNetwork =

61+ Gen.recursive Gen.choice [

62+ do SomeSing ( r :: Sing final ) <- genShape

63+ withSingI r $

64+ pure (SomeNetwork (NNil :: Network '[] '[ final ] ))

65+ ] [

66+ do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork

67+ case ( sing :: Sing shapes ) of

68+ SNil -> Gen.discard -- Can't occur

69+ SCons ( h :: Sing h ) ( _ :: Sing hs ) ->

70+ withSingI h $

71+ case h of

72+ D1Sing l@SNat ->

73+ Gen.choice [

74+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

75+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

76+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

77+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

78+ , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))

79+ , do -- Reshape to two dimensions

80+ let divisors :: Integer -> [Integer]

81+ divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]

82+ let len = fromIntegral $ natVal l

83+ rs <- Gen.element $ divisors len

84+ let cs = len `quot` rs

85+ case ( someNatVal rs, someNatVal cs, someNatVal len ) of

86+ ( Just (SomeNat (rs' :: Proxy inRows)), Just (SomeNat (cs' :: Proxy inCols)), Just (SomeNat (_ :: Proxy outLen ) )) ->

87+ let p1 = natDict rs'

88+ p2 = natDict cs'

89+ in case ( p1 %* p2, unsafeCoerce (Dict :: Dict ()) :: Dict ((inRows * inCols) ~ outLen), unsafeCoerce (Dict :: Dict ()) :: Dict (( 'D1 outLen ) ~ h )) of

90+ ( Dict, Dict, Dict ) ->

91+ pure (SomeNetwork (Reshape :~> rest :: Network ( Reshape ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

92+ _ -> Gen.discard -- Doesn't occur

93+ ]

94+ D2Sing r@SNat c@SNat ->

95+ Gen.choice [

96+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

97+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

98+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

99+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

100+ , do -- Build a convolution layer with one filter output

101+ -- Figure out some kernel sizes which work for this layer

102+ -- There must be a better way than this...

103+ let output_r = fromIntegral $ natVal r

104+ let output_c = fromIntegral $ natVal c

105+

106+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

107+

108+ -- Get some kernels which will fit

109+ kernel_r <- choose 1 output_r

110+ kernel_c <- choose 1 output_c

111+

112+ -- Build up some strides which also fit

113+ stride_r <- Gen.element $ ok output_r kernel_r

114+ stride_c <- Gen.element $ ok output_c kernel_c

115+

116+ -- Determine the input size

117+ let input_r = (output_r - 1) * stride_r + kernel_r

118+ let input_c = (output_c - 1) * stride_c + kernel_c

119+

120+ guard (input_r < 100)

121+ guard (input_c < 100)

122+

123+ -- Remake types for input

124+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

125+ ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

126+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

127+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

128+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

129+ let p1 = natDict pkr

130+ p2 = natDict pkc

131+ in case ( p1 %* p2

132+ -- Fake it till you make it.

133+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))

134+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

135+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

136+ (Dict, Dict, Dict, Dict) -> do

137+ conv <- genConvolution

138+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution 1 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

139+ _ -> Gen.discard -- Can't occur

140+ , do -- Build a convolution layer with one filter output

141+ -- Figure out some kernel sizes which work for this layer

142+ -- There must be a better way than this...

143+ let output_r = fromIntegral $ natVal r

144+ let output_c = fromIntegral $ natVal c

145+

146+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

147+

148+ -- Get some kernels which will fit

149+ kernel_r <- choose 1 output_r

150+ kernel_c <- choose 1 output_c

151+ channels <- choose 1 10

152+

153+ -- Build up some strides which also fit

154+ stride_r <- Gen.element $ ok output_r kernel_r

155+ stride_c <- Gen.element $ ok output_c kernel_c

156+

157+ -- Determine the input size

158+ let input_r = (output_r - 1) * stride_r + kernel_r

159+ let input_c = (output_c - 1) * stride_c + kernel_c

160+

161+ guard (input_r < 100)

162+ guard (input_c < 100)

163+

164+ -- Remake types for input

165+ case ( someNatVal channels, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

166+ ( Just (SomeNat (chan :: Proxy channels)),

167+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

168+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

169+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

170+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

171+ let p1 = natDict pkr

172+ p2 = natDict pkc

173+ p3 = natDict chan

174+ in case ( p1 %* p2 %* p3

175+ , natDict pinr %* natDict chan

176+ -- Fake it till you make it.

177+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))

178+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

179+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

180+ (Dict, Dict, Dict, Dict, Dict) -> do

181+ conv <- genConvolution

182+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

183+ _ -> Gen.discard -- Can't occur

184+ , do -- Build a Pooling layer

185+ let output_r = fromIntegral $ natVal r

186+ let output_c = fromIntegral $ natVal c

187+

188+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

189+

190+ -- Get some kernels which will fit

191+ kernel_r <- choose 1 output_r

192+ kernel_c <- choose 1 output_c

193+

194+ -- Build up some strides which also fit

195+ stride_r <- Gen.element $ ok output_r kernel_r

196+ stride_c <- Gen.element $ ok output_c kernel_c

197+

198+ -- Determine the input size

199+ let input_r = (output_r - 1) * stride_r + kernel_r

200+ let input_c = (output_c - 1) * stride_c + kernel_c

201+

202+ guard (input_r < 100)

203+ guard (input_c < 100)

204+

205+ -- Remake types for input

206+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

207+ ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

208+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

209+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

210+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

211+ let p1 = natDict pkr

212+ p2 = natDict pkc

213+ in case ( p1 %* p2

214+ -- Fake it till you make it.

215+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))

216+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

217+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

218+ (Dict, Dict, Dict, Dict) ->

219+ pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

220+ _ -> Gen.discard -- Can't occur

221+ , do -- Build a Pad layer

222+ let output_r = fromIntegral $ natVal r

223+ let output_c = fromIntegral $ natVal c

224+

225+ pad_left <- choose 0 (output_r - 1)

226+ pad_right <- choose 0 (output_r - 1 - pad_left)

227+ pad_top <- choose 0 (output_c - 1)

228+ pad_bottom <- choose 0 (output_c - 1 - pad_top)

229+

230+ let input_r = output_r - pad_top - pad_bottom

231+ let input_c = output_c - pad_left - pad_right

232+

233+ guard (input_r > 1)

234+ guard (input_c > 1)

235+

236+ -- Remake types for input

237+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal pad_left, someNatVal pad_right, someNatVal pad_top, someNatVal pad_bottom ) of

238+ ( Just (SomeNat (_ :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

239+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

240+ Just (SomeNat (_ :: Proxy padLeft)), Just (SomeNat (_ :: Proxy padRight)),

241+ Just (SomeNat (_ :: Proxy padTop)), Just (SomeNat (_ :: Proxy padBottom))) ->

242+ case ( (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outputRows outputColumns) ~ h ))

243+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputRows + padTop + padBottom) ~ outputRows) )

244+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputColumns + padLeft + padRight) ~ outputColumns ))) of

245+ ( Dict, Dict, Dict ) ->

246+ pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D2 inputRows inputColumns) ': h ': hs )))

247+ _ -> Gen.discard -- Can't occur

248+ , do -- Build a Crop layer

249+ let output_r = fromIntegral $ natVal r

250+ let output_c = fromIntegral $ natVal c

251+

252+ crop_left <- choose 0 10

253+ crop_right <- choose 0 10

254+ crop_top <- choose 0 10

255+ crop_bottom <- choose 0 10

256+

257+ let input_r = output_r + crop_top + crop_bottom

258+ let input_c = output_c + crop_left + crop_right

259+

260+ -- Remake types for input

261+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal crop_left, someNatVal crop_right, someNatVal crop_top, someNatVal crop_bottom ) of

262+ ( Just (SomeNat (_ :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

263+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

264+ Just (SomeNat (_ :: Proxy cropLeft)), Just (SomeNat (_ :: Proxy cropRight)),

265+ Just (SomeNat (_ :: Proxy cropTop)), Just (SomeNat (_ :: Proxy cropBottom))) ->

266+ case ( (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outputRows outputColumns) ~ h ))

267+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputRows + cropTop + cropBottom) ~ inputRows ) )

268+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputColumns + cropLeft + cropRight) ~ inputColumns ))) of

269+ (Dict, Dict, Dict) ->

270+ pure (SomeNetwork (Crop :~> rest :: Network ( Crop cropLeft cropTop cropRight cropBottom ': layers ) ( ('D2 inputRows inputColumns) ': h ': hs )))

271+ _ -> Gen.discard -- Can't occur

272+ ]

273+ D3Sing r@SNat c@SNat f@SNat ->

274+ Gen.choice [

275+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

276+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

277+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

278+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

279+ , do -- Build a convolution layer with one filter output

280+ -- Figure out some kernel sizes which work for this layer

281+ -- There must be a better way than this...

282+ let output_r = fromIntegral $ natVal r

283+ let output_c = fromIntegral $ natVal c

284+ let output_f = fromIntegral $ natVal f

285+

286+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

287+

288+ -- Get some kernels which will fit

289+ kernel_r <- choose 1 output_r

290+ kernel_c <- choose 1 output_c

291+ channels <- choose 1 10

292+

293+ -- Build up some strides which also fit

294+ stride_r <- Gen.element $ ok output_r kernel_r

295+ stride_c <- Gen.element $ ok output_c kernel_c

296+

297+ -- Determine the input size

298+ let input_r = (output_r - 1) * stride_r + kernel_r

299+ let input_c = (output_c - 1) * stride_c + kernel_c

300+

301+ guard (input_r < 100)

302+ guard (input_c < 100)

303+

304+ -- Remake types for input

305+ case ( someNatVal channels, someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

306+ ( Just (SomeNat (chan :: Proxy channels)), Just (SomeNat (_ :: Proxy filters)),

307+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

308+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

309+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

310+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

311+ let p1 = natDict pkr

312+ p2 = natDict pkc

313+ p3 = natDict chan

314+ in case ( p1 %* p2 %* p3

315+ , natDict pinr %* natDict chan

316+ -- Fake it till you make it.

317+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outRows outCols filters) ~ h ))

318+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

319+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

320+ (Dict, Dict, Dict, Dict, Dict) -> do

321+ conv <- genConvolution

322+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels filters kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

323+ _ -> Gen.discard -- Can't occur

324+ , do -- Build a Pooling layer

325+ let output_r = fromIntegral $ natVal r

326+ let output_c = fromIntegral $ natVal c

327+ let output_f = fromIntegral $ natVal f

328+

329+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

330+

331+ -- Get some kernels which will fit

332+ kernel_r <- choose 1 output_r

333+ kernel_c <- choose 1 output_c

334+

335+ -- Build up some strides which also fit

336+ stride_r <- Gen.element $ ok output_r kernel_r

337+ stride_c <- Gen.element $ ok output_c kernel_c

338+

339+ -- Determine the input size

340+ let input_r = (output_r - 1) * stride_r + kernel_r

341+ let input_c = (output_c - 1) * stride_c + kernel_c

342+

343+ guard (input_r < 100)

344+ guard (input_c < 100)

345+

346+ -- Remake types for input

347+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

348+ ( Just (SomeNat (chan :: Proxy filters)),

349+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

350+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

351+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

352+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

353+ let p1 = natDict pkr

354+ p2 = natDict pkc

355+ p3 = natDict chan

356+ in case ( p1 %* p2 %* p3

357+ , natDict pinr %* natDict chan

358+ -- Fake it till you make it.

359+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outRows outCols filters) ~ h ))

360+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

361+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

362+ (Dict, Dict, Dict, Dict, Dict) ->

363+ pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols filters) ': h ': hs )))

364+ _ -> Gen.discard -- Can't occur

365+ , do -- Build a Pad layer

366+ let output_r = fromIntegral $ natVal r

367+ let output_c = fromIntegral $ natVal c

368+ let output_f = fromIntegral $ natVal f

369+

370+ pad_left <- choose 0 (output_r - 1)

371+ pad_right <- choose 0 (output_r - 1 - pad_left)

372+ pad_top <- choose 0 (output_c - 1)

373+ pad_bottom <- choose 0 (output_c - 1 - pad_top)

374+

375+ let input_r = output_r - pad_top - pad_bottom

376+ let input_c = output_c - pad_left - pad_right

377+

378+ guard (input_r > 1)

379+ guard (input_c > 1)

380+

381+ -- Remake types for input

382+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal pad_left, someNatVal pad_right, someNatVal pad_top, someNatVal pad_bottom ) of

383+ ( Just (SomeNat (chan :: Proxy filters)),

384+ Just (SomeNat (pinr :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

385+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

386+ Just (SomeNat (_ :: Proxy padLeft)), Just (SomeNat (_ :: Proxy padRight)),

387+ Just (SomeNat (_ :: Proxy padTop)), Just (SomeNat (_ :: Proxy padBottom))) ->

388+ case ( natDict pinr %* natDict chan

389+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outputRows outputColumns filters) ~ h ))

390+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputRows + padTop + padBottom) ~ outputRows) )

391+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputColumns + padLeft + padRight) ~ outputColumns ))) of

392+ (Dict, Dict, Dict, Dict) ->

393+ pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))

394+ _ -> Gen.discard -- Can't occur

395+ , do -- Build a Crop layer

396+ let output_r = fromIntegral $ natVal r

397+ let output_c = fromIntegral $ natVal c

398+ let output_f = fromIntegral $ natVal f

399+

400+ crop_left <- choose 0 10

401+ crop_right <- choose 0 10

402+ crop_top <- choose 0 10

403+ crop_bottom <- choose 0 10

404+

405+ let input_r = output_r + crop_top + crop_bottom

406+ let input_c = output_c + crop_left + crop_right

407+

408+ -- Remake types for input

409+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal crop_left, someNatVal crop_right, someNatVal crop_top, someNatVal crop_bottom ) of

410+ ( Just (SomeNat (chan :: Proxy filters)),

411+ Just (SomeNat (pinr :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

412+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

413+ Just (SomeNat (_ :: Proxy cropLeft)), Just (SomeNat (_ :: Proxy cropRight)),

414+ Just (SomeNat (_ :: Proxy cropTop)), Just (SomeNat (_ :: Proxy cropBottom))) ->

415+ case ( natDict pinr %* natDict chan

416+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outputRows outputColumns filters) ~ h ))

417+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputRows + cropTop + cropBottom) ~ inputRows ) )

418+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputColumns + cropLeft + cropRight) ~ inputColumns ))) of

419+ (Dict, Dict, Dict, Dict) ->

420+ pure (SomeNetwork (Crop :~> rest :: Network ( Crop cropLeft cropTop cropRight cropBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))

421+ _ -> Gen.discard -- Can't occur

422+ ]

423+ ]

424+

425+-- | Test a partial derivative numerically for a random network and input

426+--

427+-- This is the most important test.

428+prop_auto_diff :: Property

429+prop_auto_diff = withDiscards 1000 . withTests 10000 . property $ do

430+ SomeNetwork (network :: Network layers shapes) <- forAll genNetwork

431+ (input :: S (Head shapes)) <- forAllWith nice genOfShape

432+ (target :: S (Last shapes)) <- forAllWith nice oneUp

433+ (tested :: S (Head shapes)) <- forAllWith nice oneUp

434+

435+ let (!tapes, !output) = runNetwork network input

436+ let (_, !backgrad) = runGradient network tapes target

437+ let inputDiff = input + tested * 0.00001

438+ let expected = maxVal ( backgrad * tested )

439+ let (_, !outputDiff) = runNetwork network inputDiff

440+ let result = maxVal ( outputDiff * target - output * target ) / 0.00001

441+

442+ result ~~~ expected

443+

444+-- Make a shape where all are 0 except for 1 value, which is 1.

445+oneUp :: forall shape. ( SingI shape ) => Gen (S shape)

446+oneUp =

447+ case ( sing :: Sing shape ) of

448+ D1Sing SNat ->

449+ let x = 0 :: S ( shape )

450+ in case x of

451+ ( S1D x' ) -> do

452+ let ex = extract x'

453+ let len = VS.length ex

454+ ix <- choose 0 (len - 1)

455+ let nx = runST $ do ex' <- VS.thaw ex

456+ VS.write ex' ix 1.0

457+ VS.freeze ex'

458+ maybe Gen.discard pure . fromStorable $ nx

459+

460+ D2Sing SNat SNat ->

461+ let x = 0 :: S ( shape )

462+ in case x of

463+ ( S2D x' ) -> do

464+ let ex = flatten ( extract x' )

465+ let len = VS.length ex

466+ ix <- choose 0 (len - 1)

467+ let nx = runST $ do ex' <- VS.thaw ex

468+ VS.write ex' ix 1

469+ VS.freeze ex'

470+ maybe Gen.discard pure . fromStorable $ nx

471+

472+ D3Sing SNat SNat SNat ->

473+ let x = 0 :: S ( shape )

474+ in case x of

475+ ( S3D x' ) -> do

476+ let ex = flatten ( extract x' )

477+ let len = VS.length ex

478+ ix <- choose 0 (len - 1)

479+ let nx = runST $ do ex' <- VS.thaw ex

480+ VS.write ex' ix 1

481+ VS.freeze ex'

482+ maybe Gen.discard pure . fromStorable $ nx

483+

484+maxVal :: S shape -> Double

485+maxVal ( S1D x ) = norm_Inf x

486+maxVal ( S2D x ) = norm_Inf x

487+maxVal ( S3D x ) = norm_Inf x

488+

489+(~~~) :: (Monad m, HasCallStack) => Double -> Double -> PropertyT m ()

490+(~~~) x y =

491+ if abs (x - y) < 2e-5 then

492+ success

493+ else

494+ withFrozenCallStack $

495+ failWith Nothing $ unlines [

496+ "━━━ Not Simliar ━━━"

497+ , show x

498+ , show y

499+ ]

500+infix 4 ~~~

501+

502+

503+tests :: IO Bool

504+tests = checkParallel $$(discover)

test/Test/Grenade/Recurrent/Layers/LSTM.hsnew file+130

@@ -0,0 +1,130 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE ConstraintKinds #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE RankNTypes #-}

9+

10+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

11+module Test.Grenade.Recurrent.Layers.LSTM where

12+

13+import Hedgehog

14+import Hedgehog.Internal.Source

15+import Hedgehog.Internal.Show

16+import Hedgehog.Internal.Property ( failWith, Diff (..) )

17+

18+import Data.Foldable ( toList )

19+import Data.Singletons.TypeLits

20+

21+import Grenade

22+import Grenade.Recurrent

23+

24+import qualified Numeric.LinearAlgebra as H

25+import qualified Numeric.LinearAlgebra.Static as S

26+

27+

28+import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

29+import Test.Hedgehog.Hmatrix

30+

31+genLSTM :: forall i o. (KnownNat i, KnownNat o) => Gen (LSTM i o)

32+genLSTM = do

33+ let w = uniformSample

34+ u = uniformSample

35+ v = randomVector

36+

37+ w0 = S.konst 0

38+ u0 = S.konst 0

39+ v0 = S.konst 0

40+

41+ LSTM <$> (LSTMWeights <$> w <*> u <*> v <*> w <*> u <*> v <*> w <*> u <*> v <*> w <*> v)

42+ <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

43+

44+prop_lstm_reference_forwards =

45+ property $ do

46+ input :: S.R 3 <- forAll randomVector

47+ cell :: S.R 2 <- forAll randomVector

48+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

49+

50+ let actual = runRecurrentForwards net (S1D cell) (S1D input)

51+ case actual of

52+ (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->

53+ let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut

54+ output' = Reference.Vector . H.toList . S.extract $ output

55+ refNet = Reference.lstmToReference lstmWeights

56+ refCell = Reference.Vector . H.toList . S.extract $ cell

57+ refInput = Reference.Vector . H.toList . S.extract $ input

58+ (refCO, refO) = Reference.runLSTM refNet refCell refInput

59+ in do toList refCO ~~~ toList cellOut'

60+ toList refO ~~~ toList output'

61+

62+

63+prop_lstm_reference_backwards =

64+ property $ do

65+ input :: S.R 3 <- forAll randomVector

66+ cell :: S.R 2 <- forAll randomVector

67+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

68+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

69+ = runRecurrentForwards net (S1D cell) (S1D input)

70+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

71+ case actualBacks of

72+ (actualGradients, _, _ :: S ('D1 3)) ->

73+ let refNet = Reference.lstmToReference lstmWeights

74+ refCell = Reference.Vector . H.toList . S.extract $ cell

75+ refInput = Reference.Vector . H.toList . S.extract $ input

76+ refGradients = Reference.runLSTMback refCell refInput refNet

77+ in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)

78+

79+prop_lstm_reference_backwards_input =

80+ property $ do

81+ input :: S.R 3 <- forAll randomVector

82+ cell :: S.R 2 <- forAll randomVector

83+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

84+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

85+ = runRecurrentForwards net (S1D cell) (S1D input)

86+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

87+ case actualBacks of

88+ (_, _, S1D actualGradients :: S ('D1 3)) ->

89+ let refNet = Reference.lstmToReference lstmWeights

90+ refCell = Reference.Vector . H.toList . S.extract $ cell

91+ refInput = Reference.Vector . H.toList . S.extract $ input

92+ refGradients = Reference.runLSTMbackOnInput refCell refNet refInput

93+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

94+

95+prop_lstm_reference_backwards_cell =

96+ property $ do

97+ input :: S.R 3 <- forAll randomVector

98+ cell :: S.R 2 <- forAll randomVector

99+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

100+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

101+ = runRecurrentForwards net (S1D cell) (S1D input)

102+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

103+ case actualBacks of

104+ (_, S1D actualGradients, _ :: S ('D1 3)) ->

105+ let refNet = Reference.lstmToReference lstmWeights

106+ refCell = Reference.Vector . H.toList . S.extract $ cell

107+ refInput = Reference.Vector . H.toList . S.extract $ input

108+ refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

109+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

110+

111+(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> PropertyT m ()

112+(~~~) x y =

113+ if all (< 1e-8) (zipWith (-) x y) then

114+ success

115+ else

116+ case valueDiff <$> mkValue x <*> mkValue y of

117+ Nothing ->

118+ withFrozenCallStack $

119+ failWith Nothing $ unlines [

120+ "━━━ Not Simliar ━━━"

121+ , showPretty x

122+ , showPretty y

123+ ]

124+ Just differ ->

125+ withFrozenCallStack $

126+ failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" differ) ""

127+infix 4 ~~~

128+

129+tests :: IO Bool

130+tests = checkParallel $$(discover)

test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hsnew file+153

@@ -0,0 +1,153 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE ConstraintKinds #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE DeriveFunctor #-}

7+{-# LANGUAGE DeriveFoldable #-}

8+{-# LANGUAGE DeriveTraversable #-}

9+{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE RankNTypes #-}

11+

12+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

13+module Test.Grenade.Recurrent.Layers.LSTM.Reference where

14+

15+import Data.Reflection

16+import Numeric.AD.Mode.Reverse

17+import Numeric.AD.Internal.Reverse (Tape)

18+

19+import GHC.TypeLits (KnownNat)

20+

21+import Grenade.Recurrent.Layers.LSTM (LSTMWeights (..))

22+import qualified Grenade.Recurrent.Layers.LSTM as LSTM

23+

24+import qualified Numeric.LinearAlgebra.Static as S

25+import qualified Numeric.LinearAlgebra as H

26+

27+--

28+-- This module contains a set of list only versions of

29+-- an LSTM layer which can be used with the AD library.

30+--

31+-- Using this, we can check to make sure that our fast

32+-- back propagation implementation is correct.

33+--

34+

35+-- | List only matrix deriving functor

36+data Matrix a = Matrix {

37+ matrixWeights :: [[a]]

38+ } deriving (Functor, Foldable, Traversable, Eq, Show)

39+

40+-- | List only vector deriving functor

41+data Vector a = Vector {

42+ vectorWeights :: [a]

43+ } deriving (Functor, Foldable, Traversable, Eq, Show)

44+

45+-- | List only LSTM weights

46+data RefLSTM a = RefLSTM

47+ { refLstmWf :: Matrix a -- Weight Forget (W_f)

48+ , refLstmUf :: Matrix a -- Cell State Forget (U_f)

49+ , refLstmBf :: Vector a -- Bias Forget (b_f)

50+ , refLstmWi :: Matrix a -- Weight Input (W_i)

51+ , refLstmUi :: Matrix a -- Cell State Input (U_i)

52+ , refLstmBi :: Vector a -- Bias Input (b_i)

53+ , refLstmWo :: Matrix a -- Weight Output (W_o)

54+ , refLstmUo :: Matrix a -- Cell State Output (U_o)

55+ , refLstmBo :: Vector a -- Bias Output (b_o)

56+ , refLstmWc :: Matrix a -- Weight Cell (W_c)

57+ , refLstmBc :: Vector a -- Bias Cell (b_c)

58+ } deriving (Functor, Foldable, Traversable, Eq, Show)

59+

60+lstmToReference :: (KnownNat a, KnownNat b) => LSTM.LSTMWeights a b -> RefLSTM Double

61+lstmToReference lw =

62+ RefLSTM

63+ { refLstmWf = Matrix . H.toLists . S.extract $ lstmWf lw -- Weight Forget (W_f)

64+ , refLstmUf = Matrix . H.toLists . S.extract $ lstmUf lw -- Cell State Forget (U_f)

65+ , refLstmBf = Vector . H.toList . S.extract $ lstmBf lw -- Bias Forget (b_f)

66+ , refLstmWi = Matrix . H.toLists . S.extract $ lstmWi lw -- Weight Input (W_i)

67+ , refLstmUi = Matrix . H.toLists . S.extract $ lstmUi lw -- Cell State Input (U_i)

68+ , refLstmBi = Vector . H.toList . S.extract $ lstmBi lw -- Bias Input (b_i)

69+ , refLstmWo = Matrix . H.toLists . S.extract $ lstmWo lw -- Weight Output (W_o)

70+ , refLstmUo = Matrix . H.toLists . S.extract $ lstmUo lw -- Cell State Output (U_o)

71+ , refLstmBo = Vector . H.toList . S.extract $ lstmBo lw -- Bias Output (b_o)

72+ , refLstmWc = Matrix . H.toLists . S.extract $ lstmWc lw -- Weight Cell (W_c)

73+ , refLstmBc = Vector . H.toList . S.extract $ lstmBc lw -- Bias Cell (b_c)

74+ }

75+

76+runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

77+runLSTM rl cell input =

78+ let -- Forget state vector

79+ f_t = sigmoid $ refLstmBf rl #+ refLstmWf rl #> input #+ refLstmUf rl #> cell

80+ -- Input state vector

81+ i_t = sigmoid $ refLstmBi rl #+ refLstmWi rl #> input #+ refLstmUi rl #> cell

82+ -- Output state vector

83+ o_t = sigmoid $ refLstmBo rl #+ refLstmWo rl #> input #+ refLstmUo rl #> cell

84+ -- Cell input state vector

85+ c_x = fmap tanh $ refLstmBc rl #+ refLstmWc rl #> input

86+ -- Cell state

87+ c_t = f_t #* cell #+ i_t #* c_x

88+ -- Output (it's sometimes recommended to use tanh c_t)

89+ h_t = o_t #* c_t

90+ in (c_t, h_t)

91+

92+runLSTMback :: forall a. Floating a => Vector a -> Vector a -> RefLSTM a -> RefLSTM a

93+runLSTMback cell input =

94+ grad f

95+ where

96+ f :: forall s. Reifies s Tape => RefLSTM (Reverse s a) -> Reverse s a

97+ f net =

98+ let cell' = fmap auto cell

99+ input' = fmap auto input

100+ (cells, forwarded) = runLSTM net cell' input'

101+ in sum forwarded + sum cells

102+

103+runLSTMbackOnInput :: forall a. Floating a => Vector a -> RefLSTM a -> Vector a -> Vector a

104+runLSTMbackOnInput cell net =

105+ grad f

106+ where

107+ f :: forall s. Reifies s Tape => Vector (Reverse s a) -> Reverse s a

108+ f input =

109+ let cell' = fmap auto cell

110+ net' = fmap auto net

111+ (cells, forwarded) = runLSTM net' cell' input

112+ in sum forwarded + sum cells

113+

114+runLSTMbackOnCell :: forall a. Floating a => Vector a -> RefLSTM a -> Vector a -> Vector a

115+runLSTMbackOnCell input net =

116+ grad f

117+ where

118+ f :: forall s. Reifies s Tape => Vector (Reverse s a) -> Reverse s a

119+ f cell =

120+ let input' = fmap auto input

121+ net' = fmap auto net

122+ (cells, forwarded) = runLSTM net' cell input'

123+ in sum forwarded + sum cells

124+

125+-- | Helper to multiply a matrix by a vector

126+matMult :: Num a => Matrix a -> Vector a -> Vector a

127+matMult (Matrix m) (Vector v) = Vector result

128+ where

129+ lrs = map length m

130+ l = length v

131+ result = if all (== l) lrs

132+ then map (\r -> sum $ zipWith (*) r v) m

133+ else error $ "Matrix has rows of length " ++ show lrs ++

134+ " but vector is of length " ++ show l

135+

136+(#>) :: Num a => Matrix a -> Vector a -> Vector a

137+(#>) = matMult

138+infixr 8 #>

139+

140+(#+) :: Num a => Vector a -> Vector a -> Vector a

141+(#+) (Vector as) (Vector bs) = Vector $ zipWith (+) as bs

142+infixl 6 #+

143+

144+(#-) :: Num a => Vector a -> Vector a -> Vector a

145+(#-) (Vector as) (Vector bs) = Vector $ zipWith (-) as bs

146+infixl 6 #-

147+

148+(#*) :: Num a => Vector a -> Vector a -> Vector a

149+(#*) (Vector as) (Vector bs) = Vector $ zipWith (*) as bs

150+infixl 7 #*

151+

152+sigmoid :: (Functor f, Floating a) => f a -> f a

153+sigmoid xs = (\x -> 1 / (1 + exp (-x))) <$> xs

test/Test/Hedgehog/Compat.hsnew file+21

@@ -0,0 +1,21 @@

1+{-# LANGUAGE RankNTypes #-}

2+module Test.Hedgehog.Compat (

3+ (...)

4+ , choose

5+ , blindForAll

6+ )where

7+

8+import Hedgehog (Gen)

9+import qualified Hedgehog.Gen as Gen

10+import qualified Hedgehog.Range as Range

11+import Hedgehog.Internal.Property

12+

13+(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

14+(...) = (.) . (.)

15+{-# INLINE (...) #-}

16+

17+choose :: Integral a => a -> a -> Gen a

18+choose = Gen.integral ... Range.constant

19+

20+blindForAll :: Monad m => Gen a -> PropertyT m a

21+blindForAll = forAllWith (const "blind")

test/Test/Hedgehog/Hmatrix.hsnew file+42

@@ -0,0 +1,42 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+

7+module Test.Hedgehog.Hmatrix where

8+

9+import Grenade

10+import Data.Singletons

11+import Data.Singletons.TypeLits

12+

13+import Hedgehog (Gen)

14+import qualified Hedgehog.Gen as Gen

15+import qualified Hedgehog.Range as Range

16+

17+import qualified Numeric.LinearAlgebra.Static as HStatic

18+

19+randomVector :: forall n. ( KnownNat n ) => Gen (HStatic.R n)

20+randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded

21+

22+uniformSample :: forall m n. ( KnownNat m, KnownNat n ) => Gen (HStatic.L m n)

23+uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded

24+

25+-- | Generate random data of the desired shape

26+genOfShape :: forall x. ( SingI x ) => Gen (S x)

27+genOfShape =

28+ case (sing :: Sing x) of

29+ D1Sing l ->

30+ withKnownNat l $

31+ S1D <$> randomVector

32+ D2Sing r c ->

33+ withKnownNat r $ withKnownNat c $

34+ S2D <$> uniformSample

35+ D3Sing r c d ->

36+ withKnownNat r $ withKnownNat c $ withKnownNat d $

37+ S3D <$> uniformSample

38+

39+nice :: S shape -> String

40+nice (S1D x) = show . HStatic.extract $ x

41+nice (S2D x) = show . HStatic.extract $ x

42+nice (S3D x) = show . HStatic.extract $ x

test/Test/Hedgehog/TypeLits.hsnew file+65

@@ -0,0 +1,65 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE RankNTypes #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE GADTs #-}

8+module Test.Hedgehog.TypeLits where

9+

10+import Data.Constraint (Dict (..))

11+import Data.Singletons (Proxy (..), Sing (..), SomeSing (..), sing)

12+#if MIN_VERSION_singletons(2,6,0)

13+import Data.Singletons.TypeLits (SNat (..))

14+#endif

15+

16+import Hedgehog (Gen)

17+import qualified Hedgehog.Gen as Gen

18+

19+import Grenade

20+

21+import GHC.TypeLits (SomeNat (..), natVal, someNatVal)

22+import GHC.TypeLits.Witnesses ((%*), natDict)

23+import Test.Hedgehog.Compat (choose)

24+

25+genNat :: Gen SomeNat

26+genNat = do

27+ ~(Just n) <- someNatVal <$> choose 1 10

28+ return n

29+

30+genShape :: Gen (SomeSing Shape)

31+genShape

32+ = Gen.choice [

33+ genD1

34+ , genD2

35+ , genD3

36+ ]

37+

38+genD1 :: Gen (SomeSing Shape)

39+genD1 = do

40+ n <- genNat

41+ return $ case n of

42+ SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

43+

44+genD2 :: Gen (SomeSing Shape)

45+genD2 = do

46+ n <- genNat

47+ m <- genNat

48+ return $ case (n, m) of

49+ (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

50+

51+genD3 :: Gen (SomeSing Shape)

52+genD3 = do

53+ n <- genNat

54+ m <- genNat

55+ o <- genNat

56+ return $ case (n, m, o) of

57+ (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->

58+ case natDict px %* natDict pz of

59+ Dict -> SomeSing (sing :: Sing ('D3 x y z))

60+

61+rss :: SomeSing Shape -> String

62+rss (SomeSing (r :: Sing s)) = case r of

63+ (D1Sing a@SNat) -> "D1 " ++ show (natVal a)

64+ (D2Sing a@SNat b@SNat) -> "D2 " ++ show (natVal a) ++ " " ++ show (natVal b)

65+ (D3Sing a@SNat b@SNat c@SNat) -> "D3 " ++ show (natVal a) ++ " " ++ show (natVal b) ++ " " ++ show (natVal c)

test/test.hs+40−4

@@ -1,11 +1,47 @@

1−import Disorder.Core.Main

1+import Control.Monad

22

3−import qualified Test.Grenade.Layers.Pooling as Test.Grenade.Layers.Pooling

4−import qualified Test.Grenade.Layers.Convolution as Test.Grenade.Layers.Convolution

3+import qualified Test.Grenade.Network

4+

5+import qualified Test.Grenade.Layers.Pooling

6+import qualified Test.Grenade.Layers.Convolution

7+import qualified Test.Grenade.Layers.FullyConnected

8+import qualified Test.Grenade.Layers.Nonlinear

9+import qualified Test.Grenade.Layers.PadCrop

10+

11+import qualified Test.Grenade.Layers.Internal.Convolution

12+import qualified Test.Grenade.Layers.Internal.Pooling

13+

14+import qualified Test.Grenade.Recurrent.Layers.LSTM

15+

16+import System.Exit

17+import System.IO

518

619main :: IO ()

720main =

821 disorderMain [

9− Test.Grenade.Layers.Pooling.tests

22+ Test.Grenade.Network.tests

23+

24+ , Test.Grenade.Layers.Pooling.tests

1025 , Test.Grenade.Layers.Convolution.tests

26+ , Test.Grenade.Layers.FullyConnected.tests

27+ , Test.Grenade.Layers.Nonlinear.tests

28+ , Test.Grenade.Layers.PadCrop.tests

29+

30+ , Test.Grenade.Layers.Internal.Convolution.tests

31+ , Test.Grenade.Layers.Internal.Pooling.tests

32+

33+ , Test.Grenade.Recurrent.Layers.LSTM.tests

34+

1135 ]

36+

37+disorderMain :: [IO Bool] -> IO ()

38+disorderMain tests = do

39+ lineBuffer

40+ rs <- sequence tests

41+ unless (and rs) exitFailure

42+

43+

44+lineBuffer :: IO ()

45+lineBuffer = do

46+ hSetBuffering stdout LineBuffering

47+ hSetBuffering stderr LineBuffering