git.iko.soy/grenade
on master help sign in
swap
afb9f9b149 ahead, 0 behind
.gitignore+3−1
since splitsnapshots
unifiedsplit
@@ -1,4 +1,6 @@
1+cabal.project.local
1.cabal-sandbox/
2.cabal-sandbox/
2cabal.sandbox.config
3cabal.sandbox.config
3dist/
4dist/
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 @@
1−Copyright (c) 2016, Huw Campbell
1+Copyright (c) 2016-2017, Huw Campbell
2All rights reserved.
2All rights reserved.
3
3
4Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
4Redistribution 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 @@
1Grenade
1Grenade
2=======
2=======
3
3
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+
4```
9```
5First shalt thou take out the Holy Pin, then shalt thou count to three, no more, no less.
10First shalt thou take out the Holy Pin, then shalt thou count to three, no more, no less.
6Three shall be the number thou shalt count, and the number of the counting shall be three.
11Three shall be the number thou shalt count, and the number of the counting shall be three.
@@ -10,34 +15,139 @@ Five is right out.
10
15
11💣 Machine learning which might blow up in your face 💣
16💣 Machine learning which might blow up in your face 💣
12
17
13−Grenade is a dependently typed, practical, and pretty quick neural network library for concise and precise
18+Grenade is a composable, dependently typed, practical, and fast recurrent neural network library
14−specifications of complex networks in Haskell.
19+for concise and precise specifications of complex networks in Haskell.
15
20
16−As an example, a network which can achieve less than 1.5% error on MNIST can be specified and
21+As an example, a network which can achieve ~1.5% error on MNIST can be
17−initialised with random weights in a few lines of code with
22+specified and initialised with random weights in a few lines of code with
18```haskell
23```haskell
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+
19−randomMnist :: MonadRandom m
33+randomMnist :: MonadRandom m => m MNIST
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])
22randomMnist = randomNetwork
34randomMnist = randomNetwork
23```
35```
24
36
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+
25−The network can be thought of as a heterogeneous list of layers, and its type signature includes a type
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
26−level list of the shapes of the data passed between the layers of the network.
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.
27
94
28−In the above example, the input layer can be seen to be a two dimensional (`D2`) image with 28 by 28 pixels.
95+The gradients however can always be applied, yielding a new (hopefully better)
29−The last item in the list is one dimensional (`D1`) with 10 values, representing the categories of the mnist data.
96+layer with
97+```haskell
98+applyUpdate :: LearningParameters -> Network ls ss -> Gradients ls -> Network ls ss
99+```
30
100
31−Layers in Grenade are represented as Haskell classes, so creating one's own is easy in downstream code. If the shapes
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
32−of a network are not specified correctly and a layer can not sensibly perform the operation between two shapes, then
103+and a layer can not sensibly perform the operation between two shapes, then
33it will result in a compile time error.
104it will result in a compile time error.
34
105
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.
35
144
36Build Instructions
145Build Instructions
37------------------
146------------------
38−Grenade currently only builds with the [mafia](https://github.com/ambiata/mafia) scipt that is located in the
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
39−repository. You will also need the `lapack` and `blas` libraries and development tools. Once you have all
149+`blas` libraries and development tools. Once you have all that, Grenade can be
40−that, Grenade can be build using:
150+build using:
41
151
42```
152```
43./mafia build
153./mafia build
@@ -49,25 +159,34 @@ and the tests run using:
49./mafia test
159./mafia test
50```
160```
51
161
52−Grenade is currently known to build with ghc 7.10 and 8.0.
162+Grenade builds with ghc 7.10, 8.0, 8.2 and 8.4.
53−
54
163
55Thanks
164Thanks
56------
165------
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
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
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
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
59needed, and was a great starting point for writing this library.
170needed, and was a great starting point for writing this library.
60
171
61Performance
172Performance
62-----------
173-----------
63−Grenade is backed by hmatrix and blas, and uses a pretty clever convolution trick popularised by Caffe, which
174+Grenade is backed by hmatrix, BLAS, and LAPACK, with critical functions optimised
64−is surprisingly effective and fast. So for many small scale problems it should be sufficient.
175+in C. Using the im2col trick popularised by Caffe, it should be sufficient for
176+many problems.
65
177
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
178+Being purely functional, it should also be easy to run batches in parallel, which
67−sitting there begging.
179+would be appropriate for larger networks, my current examples however are single
180+threaded.
68
181
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.
70
184
71Contributing
185Contributing
72------------
186------------
73Contributions are welcome.
187Contributions 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 @@
1+Copyright (c) 2016-2017, Huw Campbell
2+All rights reserved.
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>
7+copyright: (c) 2016-2017 Huw Campbell.
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 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
@@ -9,19 +10,34 @@
9import Control.Applicative
10import Control.Applicative
10import Control.Monad
11import Control.Monad
11import Control.Monad.Random
12import Control.Monad.Random
12−import Control.Monad.Trans.Class
13import Control.Monad.Trans.Except
13import Control.Monad.Trans.Except
14
14
15import qualified Data.Attoparsec.Text as A
15import 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+
16import qualified Data.Text as T
21import qualified Data.Text as T
17import qualified Data.Text.IO as T
22import qualified Data.Text.IO as T
23+import qualified Data.Vector.Storable as V
18
24
19−import Numeric.LinearAlgebra (maxIndex)
25+import Numeric.LinearAlgebra ( maxIndex )
20import qualified Numeric.LinearAlgebra.Static as SA
26import qualified Numeric.LinearAlgebra.Static as SA
21
27
22import Options.Applicative
28import Options.Applicative
23
29
24import Grenade
30import 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 ]
25
41
26-- The definition of our convolutional neural network.
42-- The definition of our convolutional neural network.
27-- In the type signature, we have a type level list of shapes which are passed between the layers.
43-- In the type signature, we have a type level list of shapes which are passed between the layers.
@@ -32,9 +48,23 @@ import Grenade
32
48
33-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,
49-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,
34-- this network should get down to about a 1.3% error rate.
50-- this network should get down to about a 1.3% error rate.
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+
35−randomMnist :: MonadRandom m
67+randomMnist :: MonadRandom m => m MNIST
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])
38randomMnist = randomNetwork
68randomMnist = randomNetwork
39
69
40convTest :: Int -> FilePath -> FilePath -> LearningParameters -> ExceptT String IO ()
70convTest :: Int -> FilePath -> FilePath -> LearningParameters -> ExceptT String IO ()
@@ -48,9 +78,9 @@ convTest iterations trainFile validateFile rate = do
48 trainEach rate' !network (i, o) = train rate' network i o
78 trainEach rate' !network (i, o) = train rate' network i o
49
79
50 runIteration trainRows validateRows net i = do
80 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
52 let res = fmap (\(rowP,rowL) -> (rowL,) $ runNet trained' rowP) validateRows
82 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
54 print trained'
84 print trained'
55 putStrLn $ "Iteration " ++ show i ++ ": " ++ show (length (filter ((==) <$> fst <*> snd) res')) ++ " of " ++ show (length res')
85 putStrLn $ "Iteration " ++ show i ++ ": " ++ show (length (filter ((==) <$> fst <*> snd) res')) ++ " of " ++ show (length res')
56 return trained'
86 return trained'
@@ -60,7 +90,7 @@ data MnistOpts = MnistOpts FilePath FilePath Int LearningParameters
60mnist' :: Parser MnistOpts
90mnist' :: Parser MnistOpts
61mnist' = MnistOpts <$> argument str (metavar "TRAIN")
91mnist' = MnistOpts <$> argument str (metavar "TRAIN")
62 <*> argument str (metavar "VALIDATE")
92 <*> argument str (metavar "VALIDATE")
63− <*> option auto (long "iterations" <> short 'i' <> value 10)
93+ <*> option auto (long "iterations" <> short 'i' <> value 15)
64 <*> (LearningParameters
94 <*> (LearningParameters
65 <$> option auto (long "train_rate" <> short 'r' <> value 0.01)
95 <$> option auto (long "train_rate" <> short 'r' <> value 0.01)
66 <*> option auto (long "momentum" <> value 0.9)
96 <*> option auto (long "momentum" <> value 0.9)
@@ -77,14 +107,14 @@ main = do
77 Right () -> pure ()
107 Right () -> pure ()
78 Left err -> putStrLn err
108 Left err -> putStrLn err
79
109
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))]
81readMNIST mnist = ExceptT $ do
111readMNIST mnist = ExceptT $ do
82 mnistdata <- T.readFile mnist
112 mnistdata <- T.readFile mnist
83 return $ traverse (A.parseOnly parseMNIST) (T.lines mnistdata)
113 return $ traverse (A.parseOnly parseMNIST) (T.lines mnistdata)
84
114
85−parseMNIST :: A.Parser (S' ('D2 28 28), S' ('D1 10))
115+parseMNIST :: A.Parser (S ('D2 28 28), S ('D1 10))
86parseMNIST = do
116parseMNIST = do
87− lab <- A.decimal
117+ Just lab <- oneHot <$> A.decimal
88− pixels <- many (A.char ',' >> A.double)
118+ pixels <- many (A.char ',' >> A.double)
89− let lab' = replicate lab 0 ++ [1] ++ replicate (9 - lab) 0
119+ image <- maybe (fail "Parsed row was of an incorrect size") pure (fromStorable . V.fromList $ pixels)
90− return (S2D' $ SA.fromList pixels, S1D' $ SA.fromList lab')
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 @@
1name: grenade
1name: grenade
2−version: 0.0.1
2+version: 0.1.0
3license: BSD2
3license: BSD2
4+license-file: LICENSE
4author: Huw Campbell <huw.campbell@gmail.com>
5author: Huw Campbell <huw.campbell@gmail.com>
5maintainer: Huw Campbell <huw.campbell@gmail.com>
6maintainer: Huw Campbell <huw.campbell@gmail.com>
6−copyright: (c) 2015 Huw Campbell.
7+copyright: (c) 2016-2017 Huw Campbell.
7−synopsis: grenade
8+synopsis: Practical Deep Learning in Haskell
8−category: System
9+category: AI, Machine Learning
9−cabal-version: >= 1.8
10+cabal-version: >= 1.10
10build-type: Simple
11build-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
12
37
13library
38library
14 build-depends:
39 build-depends:
15 base >= 4.8 && < 5
40 base >= 4.8 && < 5
16− , bytestring == 0.10.*
41+ , bytestring >= 0.10.0
17− , async
42+ , containers >= 0.5 && < 0.7
18− , either == 4.4.*
43+ , cereal >= 0.5 && < 0.6
19− , exceptions == 0.8.*
44+ , deepseq >= 1.4 && < 1.5
20− , hmatrix
45+ , hmatrix >= 0.18 && < 0.21
21− , MonadRandom
46+ , MonadRandom >= 0.4 && < 0.6
22− , mtl >= 2.2.1 && < 2.3
23− , parallel == 3.2.*
24− , primitive
47+ , primitive >= 0.6 && < 0.8
25− , text == 1.2.*
48+ -- Versions of singletons are *tightly* coupled with the
26− , transformers
49+ -- GHC version so its fine to drop version bounds.
27 , singletons
50 , singletons
51+ , singletons-base
52+ , vector >= 0.11 && < 0.13
28
53
29 ghc-options:
54 ghc-options:
30 -Wall
55 -Wall
31 hs-source-dirs:
56 hs-source-dirs:
32 src
57 src
33
58
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
34
67
35 exposed-modules:
68 exposed-modules:
36 Grenade
69 Grenade
70+ Grenade.Core
71+ Grenade.Core.Layer
72+ Grenade.Core.LearningParameters
37 Grenade.Core.Network
73 Grenade.Core.Network
38− Grenade.Core.Vector
39 Grenade.Core.Runner
74 Grenade.Core.Runner
40 Grenade.Core.Shape
75 Grenade.Core.Shape
76+
77+ Grenade.Layers
41− Grenade.Layers.Crop
78+ Grenade.Layers.Concat
42 Grenade.Layers.Convolution
79 Grenade.Layers.Convolution
80+ Grenade.Layers.Crop
81+ Grenade.Layers.Deconvolution
43 Grenade.Layers.Dropout
82 Grenade.Layers.Dropout
83+ Grenade.Layers.Elu
44 Grenade.Layers.FullyConnected
84 Grenade.Layers.FullyConnected
45− Grenade.Layers.Flatten
85+ Grenade.Layers.Inception
46− Grenade.Layers.Fuse
47 Grenade.Layers.Logit
86 Grenade.Layers.Logit
48− Grenade.Layers.Relu
87+ Grenade.Layers.Merge
49− Grenade.Layers.Tanh
50 Grenade.Layers.Pad
88 Grenade.Layers.Pad
51 Grenade.Layers.Pooling
89 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
52
96
53 Grenade.Layers.Internal.Convolution
97 Grenade.Layers.Internal.Convolution
98+ Grenade.Layers.Internal.Pad
54 Grenade.Layers.Internal.Pooling
99 Grenade.Layers.Internal.Pooling
100+ Grenade.Layers.Internal.Update
55
101
102+ Grenade.Recurrent
56
103
57−executable feedforward
104+ Grenade.Recurrent.Core
58− ghc-options: -Wall -threaded -O2
105+ Grenade.Recurrent.Core.Layer
59− main-is: main/feedforward.hs
106+ Grenade.Recurrent.Core.Network
60− build-depends: base
107+ Grenade.Recurrent.Core.Runner
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
71
108
72−executable mnist
109+ Grenade.Recurrent.Layers
73− ghc-options: -Wall -threaded -O2
110+ Grenade.Recurrent.Layers.BasicRecurrent
74− main-is: main/mnist.hs
111+ Grenade.Recurrent.Layers.ConcatRecurrent
75− build-depends: base
112+ Grenade.Recurrent.Layers.LSTM
76− , grenade
113+
77− , attoparsec
114+ Grenade.Utils.OneHot
78− , either
115+
79− , optparse-applicative == 0.12.*
116+ includes: cbits/im2col.h
80− , text == 1.2.*
117+ cbits/gradient_descent.h
81− , mtl >= 2.2.1 && < 2.3
118+ cbits/pad.h
82− , hmatrix >= 0.18 && < 0.19
119+ c-sources: cbits/im2col.c
83− , transformers
120+ cbits/gradient_descent.c
84− , singletons
121+ cbits/pad.c
85− , MonadRandom
86
122
123+ cc-options: -std=c99 -O3 -msse4.2 -Wall -Werror -DCABAL=1
87
124
88test-suite test
125test-suite test
89 type: exitcode-stdio-1.0
126 type: exitcode-stdio-1.0
@@ -95,12 +132,84 @@ test-suite test
95 hs-source-dirs:
132 hs-source-dirs:
96 test
133 test
97
134
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+
98 build-depends:
161 build-depends:
99− base >= 4.8 && < 5
162+ base
100 , grenade
163 , grenade
101− , ambiata-disorder-core
164+ , hedgehog >= 1.0 && < 1.1
102 , hmatrix
165 , hmatrix
103 , mtl
166 , mtl
167+ , singletons
104 , text == 1.2.*
168 , text == 1.2.*
105− , QuickCheck >= 2.7 && < 2.9
169+ , typelits-witnesses < 0.4
106− , quickcheck-instances == 0.3.*
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 @@
1module Grenade (
1module Grenade (
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.
2− module X
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+
3 ) where
20 ) where
4
21
5−import Grenade.Core.Vector as X
22+import Grenade.Core
6−import Grenade.Core.Network as X
23+import Grenade.Layers
7−import Grenade.Core.Runner as X
24+
8−import Grenade.Core.Shape as X
25+{- $library
9−import Grenade.Layers.Crop as X
26+Grenade is a purely functional deep learning library.
10−import Grenade.Layers.Dropout as X
27+
11−import Grenade.Layers.Pad as X
28+It provides an expressive type level API for the construction
12−import Grenade.Layers.Pooling as X
29+of complex neural network architectures. Backing this API is and
13−import Grenade.Layers.Flatten as X
30+implementation written using BLAS and LAPACK, mostly provided by
14−import Grenade.Layers.Fuse as X
31+the hmatrix library.
15−import Grenade.Layers.FullyConnected as X
32+
16−import Grenade.Layers.Logit as X
33+-}
17−import Grenade.Layers.Convolution as X
34+
18−import Grenade.Layers.Relu as X
35+{- $example
19−import Grenade.Layers.Tanh as X
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 #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE FlexibleContexts #-}
10{-# LANGUAGE FlexibleInstances #-}
10{-# 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+-}
12
21
13module Grenade.Core.Network (
22module Grenade.Core.Network (
14− Layer (..)
15− , Network (..)
23+ Network (..)
16− , UpdateLayer (..)
17− , LearningParameters (..)
18 , Gradients (..)
24 , Gradients (..)
19− , CreatableNetwork (..)
25+ , Tapes (..)
26+
27+ , runNetwork
28+ , runGradient
29+ , applyUpdate
30+
31+ , randomNetwork
20 ) where
32 ) where
21
33
22−import Control.Monad.Random (MonadRandom)
34+import Control.Monad.Random ( MonadRandom )
23
35
36+import Data.Singletons
37+import Data.Serialize
24
38
25−import Grenade.Core.Shape
39+#if MIN_VERSION_base(4,9,0)
40+import Data.Kind (Type)
41+#endif
26
42
27−data LearningParameters = LearningParameters {
43+import Grenade.Core.Layer
28− learningRate :: Double
44+import Grenade.Core.LearningParameters
29− , learningMomentum :: Double
45+import Grenade.Core.Shape
30− , learningRegulariser :: Double
46+import Prelude.Singletons
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)
55
47
56-- | Type of a network.
48-- | Type of a network.
49+--
57−-- The [*] type specifies the types of the layers. This is needed for parallel
50+-- The @[*]@ type specifies the types of the layers.
58−-- running and being all the gradients beck together.
51+--
59−-- The [Shape] type specifies the shapes of data passed between the layers.
52+-- The @[Shape]@ type specifies the shapes of data passed between the layers.
53+--
60−-- Could be considered to be a heterogeneous list of layers which are able to
54+-- Can be considered to be a heterogeneous list of layers which are able to
61-- transform the data shapes of the network.
55-- transform the data shapes of the network.
62−data Network :: [*] -> [Shape] -> * where
56+data Network :: [Type] -> [Shape] -> Type where
57+ NNil :: SingI i
63− O :: Layer x i o => !x -> Network '[x] '[i, o]
58+ => Network '[] '[i]
59+
60+ (:~>) :: (SingI i, SingI h, Layer x i h)
61+ => !x
62+ -> !(Network xs (h ': hs))
64− (:~>) :: Layer x i h => !x -> !(Network xs (h ': hs)) -> Network (x ': xs) (i ': h ': hs)
63+ -> Network (x ': xs) (i ': h ': hs)
65infixr 5 :~>
64infixr 5 :~>
66
65
67−instance Show (Network l h) where
66+instance Show (Network '[] '[i]) where
68− show (O a) = "O " ++ show a
67+ show NNil = "NNil"
68+instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) where
69− show (i :~> o) = show i ++ "\n:~>\n" ++ show o
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+
70
94
71−-- | Gradients of a network.
95+-- | Running a network forwards with some input data.
72−-- Parameterised on the layers of a Network.
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
73−data Gradients :: [*] -> * where
105+ where
74− OG :: UpdateLayer x => Gradient x -> Gradients '[x]
106+ go :: forall js ss. (Last js ~ Last shapes)
75− (:/>) :: UpdateLayer x => Gradient x -> Gradients xs -> Gradients (x ': xs)
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)
76
114
115+ go NNil !x
116+ = (TNil, x)
77
117
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+
78−-- | A network can easily be created by hand with (:~>), but an easy way to initialise a random
158+-- | A network can easily be created by hand with (:~>), but an easy way to
79−-- network is with the randomNetwork.
159+-- initialise a random network is with the randomNetwork.
80−class CreatableNetwork (xs :: [*]) (ss :: [Shape]) where
160+class CreatableNetwork (xs :: [Type]) (ss :: [Shape]) where
81− -- | Create a network of the types requested
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.
82 randomNetwork :: MonadRandom m => m (Network xs ss)
165 randomNetwork :: MonadRandom m => m (Network xs ss)
83
166
84−instance Layer x i o => CreatableNetwork (x ': '[]) (i ': o ': '[]) where
167+instance SingI i => CreatableNetwork '[] '[i] where
85− randomNetwork = O <$> createRandom
168+ randomNetwork = return NNil
86
169
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
88 randomNetwork = (:~>) <$> createRandom <*> randomNetwork
171 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 #-}
3{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE TypeOperators #-}
3+{-|
6−{-# LANGUAGE TypeFamilies #-}
4+Module : Grenade.Core.Runner
7−
5+Description : Functions to perform training and backpropagation
6+Copyright : (c) Huw Campbell, 2016-2017
7+License : BSD2
8+Stability : experimental
9+-}
8module Grenade.Core.Runner (
10module Grenade.Core.Runner (
9 train
11 train
10 , backPropagate
12 , backPropagate
11 , runNet
13 , runNet
12− , applyUpdate
13 ) where
14 ) where
14
15
15−import Data.Singletons.Prelude
16+
17+import Grenade.Core.LearningParameters
16import Grenade.Core.Network
18import Grenade.Core.Network
17import Grenade.Core.Shape
19import Grenade.Core.Shape
18−
20+import Data.Singletons
19−-- | Drive and network and collect its back propogated gradients.
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+--
20−backPropagate :: forall input output shapes layers. (Head shapes ~ input, Last shapes ~ output)
33+backPropagate :: SingI (Last shapes)
21− => Network layers shapes -> S' input -> S' output -> Gradients layers
34+ => Network layers shapes
35+ -> S (Head shapes)
36+ -> S (Last shapes)
37+ -> Gradients layers
22backPropagate network input target =
38backPropagate network input target =
23− fst $ go input network
39+ let (tapes, output) = runNetwork network input
24− where
40+ (grads, _) = runGradient network tapes (output - target)
25− go :: forall j js sublayers. (Head js ~ j, Last js ~ output)
41+ in grads
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'
36
42
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)
46
43
47-- | Update a network with new weights after training with an instance.
44-- | Update a network with new weights after training with an instance.
48−train :: forall input output shapes layers. (Head shapes ~ input, Last shapes ~ output)
45+train :: SingI (Last shapes)
49− => LearningParameters -- ^ learning rate
46+ => LearningParameters
50− -> Network layers shapes -- ^ network to train
47+ -> Network layers shapes
51− -> S' input -> S' output -- ^ target vector
48+ -> S (Head shapes)
49+ -> S (Last shapes)
52 -> Network layers shapes
50 -> Network layers shapes
53train rate network input output =
51train rate network input output =
54 let grads = backPropagate network input output
52 let grads = backPropagate network input output
55 in applyUpdate rate network grads
53 in applyUpdate rate network grads
56
54
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"
64
55
65−-- | Just forwards propagation with no training.
56+-- | Run the network with input and return the given output.
66−runNet :: Network layers hs
57+runNet :: Network layers shapes -> S (Head shapes) -> S (Last shapes)
67− -> S' (Head hs) -- ^ input vector
58+runNet net = snd . runNetwork net
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
src/Grenade/Core/Shape.hs+199−52
@@ -1,70 +1,217 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE KindSignatures #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE TypeOperators #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE FlexibleContexts #-}
8{-# 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
11
18
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 #-}
15
19
20+-}
16module Grenade.Core.Shape (
21module Grenade.Core.Shape (
17− Shape (..)
18− , S' (..)
22+ S (..)
23+ , Shape (..)
24+ , SShape (..)
25+ , randomOfShape
26+ , fromStorable
19 ) where
27 ) where
20
28
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
21−import Data.Singletons.TypeLits
34+import Data.Singletons
22−
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
23import Numeric.LinearAlgebra.Static
39import Numeric.LinearAlgebra.Static
24−
40+import qualified Numeric.LinearAlgebra as NLA
25−import Grenade.Core.Vector
26
41
27-- | The current shapes we accept.
42-- | The current shapes we accept.
28-- at the moment this is just one, two, and three dimensional
43-- at the moment this is just one, two, and three dimensional
29-- Vectors/Matricies.
44-- Vectors/Matricies.
45+--
46+-- These are only used with DataKinds, as Kind `Shape`, with Types 'D1, 'D2, 'D3.
30−data Shape =
47+data Shape
31− D1 Nat
48+ = D1 Nat
49+ -- ^ One dimensional vector
32 | D2 Nat Nat
50 | D2 Nat Nat
51+ -- ^ Two dimensional matrix. Row, Column.
33 | D3 Nat Nat Nat
52 | 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)
34
215
35−instance Num (S' x) where
216+ D3Sing ->
36− (+) (S1D' x) (S1D' y) = S1D' (x + y)
217+ S3D (konst x)
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
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 #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE StandaloneDeriving #-}
5−{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
7{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
8{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FlexibleInstances #-}
11{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE FlexibleContexts #-}
12−{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE UndecidableInstances #-}
13−{-# LANGUAGE PatternGuards #-}
11+{-|
12+Module : Grenade.Layers.Convolution
13+Description : Convolution layer
14+Copyright : (c) Huw Campbell, 2016-2017
15+License : BSD2
16+Stability : experimental
14
17
18+This module provides the Convolution layer, which is critical in many computer vision tasks.
19+
20+-}
15module Grenade.Layers.Convolution (
21module Grenade.Layers.Convolution (
16 Convolution (..)
22 Convolution (..)
17 , Convolution' (..)
23 , Convolution' (..)
@@ -21,17 +27,18 @@ module Grenade.Layers.Convolution (
21import Control.Monad.Random hiding ( fromList )
27import Control.Monad.Random hiding ( fromList )
22import Data.Maybe
28import Data.Maybe
23import Data.Proxy
29import Data.Proxy
24−import Data.Singletons.TypeLits
30+import Data.Serialize
31+
25import GHC.TypeLits
32import GHC.TypeLits
33+import Data.Kind (Type)
26
34
27import Numeric.LinearAlgebra hiding ( uniformSample, konst )
35import Numeric.LinearAlgebra hiding ( uniformSample, konst )
28import qualified Numeric.LinearAlgebra as LA
36import qualified Numeric.LinearAlgebra as LA
29import Numeric.LinearAlgebra.Static hiding ((|||), build, toRows)
37import Numeric.LinearAlgebra.Static hiding ((|||), build, toRows)
30
38
31−import Grenade.Core.Network
39+import Grenade.Core
32−import Grenade.Core.Shape
33−import Grenade.Core.Vector
34import Grenade.Layers.Internal.Convolution
40import Grenade.Layers.Internal.Convolution
41+import Grenade.Layers.Internal.Update
35
42
36-- | A convolution layer for a neural network.
43-- | A convolution layer for a neural network.
37-- This uses the im2col convolution trick popularised by Caffe, which essentially turns the
44-- This uses the im2col convolution trick popularised by Caffe, which essentially turns the
@@ -44,13 +51,13 @@ import Grenade.Layers.Internal.Convolution
44-- `out = (in - kernel) / stride + 1` for both dimensions.
51-- `out = (in - kernel) / stride + 1` for both dimensions.
45--
52--
46-- One probably shouldn't build their own layer, but rather use the randomConvolution function.
53-- 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.
54+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.
55+ -> Nat -- Number of filters, this is the number of channels output by the layer.
49− -> Nat -- ^ The number of rows in the kernel filter
56+ -> Nat -- The number of rows in the kernel filter
50− -> Nat -- ^ The number of column in the kernel filter
57+ -> Nat -- The number of column in the kernel filter
51− -> Nat -- ^ The row stride of the convolution filter
58+ -> Nat -- The row stride of the convolution filter
52− -> Nat -- ^ The columns stride of the convolution filter
59+ -> Nat -- The columns stride of the convolution filter
53− -> * where
60+ -> Type where
54 Convolution :: ( KnownNat channels
61 Convolution :: ( KnownNat channels
55 , KnownNat filters
62 , KnownNat filters
56 , KnownNat kernelRows
63 , KnownNat kernelRows
@@ -59,17 +66,17 @@ data Convolution :: Nat -- ^ Number of channels, for the first layer this could
59 , KnownNat strideColumns
66 , KnownNat strideColumns
60 , KnownNat kernelFlattened
67 , KnownNat kernelFlattened
61 , kernelFlattened ~ (kernelRows * kernelColumns * channels))
68 , kernelFlattened ~ (kernelRows * kernelColumns * channels))
62− => !(L kernelFlattened filters) -- ^ The kernel filter weights
69+ => !(L kernelFlattened filters) -- The kernel filter weights
63− -> !(L kernelFlattened filters) -- ^ The last kernel update (or momentum)
70+ -> !(L kernelFlattened filters) -- The last kernel update (or momentum)
64 -> Convolution channels filters kernelRows kernelColumns strideRows strideColumns
71 -> Convolution channels filters kernelRows kernelColumns strideRows strideColumns
65
72
66−data Convolution' :: Nat -- ^ Number of channels, for the first layer this could be RGB for instance.
73+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.
74+ -> Nat -- Number of filters, this is the number of channels output by the layer.
68− -> Nat -- ^ The number of rows in the kernel filter
75+ -> Nat -- The number of rows in the kernel filter
69− -> Nat -- ^ The number of column in the kernel filter
76+ -> Nat -- The number of column in the kernel filter
70− -> Nat -- ^ The row stride of the convolution filter
77+ -> Nat -- The row stride of the convolution filter
71− -> Nat -- ^ The columns stride of the convolution filter
78+ -> Nat -- The columns stride of the convolution filter
72− -> * where
79+ -> Type where
73 Convolution' :: ( KnownNat channels
80 Convolution' :: ( KnownNat channels
74 , KnownNat filters
81 , KnownNat filters
75 , KnownNat kernelRows
82 , KnownNat kernelRows
@@ -78,7 +85,7 @@ data Convolution' :: Nat -- ^ Number of channels, for the first layer this could
78 , KnownNat strideColumns
85 , KnownNat strideColumns
79 , KnownNat kernelFlattened
86 , KnownNat kernelFlattened
80 , kernelFlattened ~ (kernelRows * kernelColumns * channels))
87 , kernelFlattened ~ (kernelRows * kernelColumns * channels))
81− => !(L kernelFlattened filters) -- ^ The kernel filter gradient
88+ => !(L kernelFlattened filters) -- The kernel filter gradient
82 -> Convolution' channels filters kernelRows kernelColumns strideRows strideColumns
89 -> Convolution' channels filters kernelRows kernelColumns strideRows strideColumns
83
90
84instance Show (Convolution c f k k' s s') where
91instance Show (Convolution c f k k' s s') where
@@ -110,7 +117,7 @@ randomConvolution :: ( MonadRandom m
110 , kernelFlattened ~ (kernelRows * kernelColumns * channels))
117 , kernelFlattened ~ (kernelRows * kernelColumns * channels))
111 => m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)
118 => m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)
112randomConvolution = do
119randomConvolution = do
113− s :: Int <- getRandom
120+ s <- getRandom
114 let wN = uniformSample s (-1) 1
121 let wN = uniformSample s (-1) 1
115 mm = konst 0
122 mm = konst 0
116 return $ Convolution wN mm
123 return $ Convolution wN mm
@@ -123,16 +130,30 @@ instance ( KnownNat channels
123 , KnownNat strideColumns
130 , KnownNat strideColumns
124 , KnownNat (kernelRows * kernelColumns * channels)
131 , KnownNat (kernelRows * kernelColumns * channels)
125 ) => UpdateLayer (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where
132 ) => 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)
133+ type Gradient (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Convolution' channels filters kernelRows kernelColumns strideRows strideColumns)
127− runUpdate LearningParameters {..} (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =
134+ runUpdate lp (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =
128− let newMomentum = konst learningMomentum * oldMomentum - konst learningRate * kernelGradient
135+ let (newKernel, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldKernel kernelGradient oldMomentum
129− regulariser = konst (learningRegulariser * learningRate) * oldKernel
130− newKernel = oldKernel + newMomentum - regulariser
131 in Convolution newKernel newMomentum
136 in Convolution newKernel newMomentum
132
137
133 createRandom = randomConvolution
138 createRandom = randomConvolution
134
139
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.
136instance ( KnownNat kernelRows
157instance ( KnownNat kernelRows
137 , KnownNat kernelCols
158 , KnownNat kernelCols
138 , KnownNat filters
159 , KnownNat filters
@@ -142,26 +163,33 @@ instance ( KnownNat kernelRows
142 , KnownNat inputCols
163 , KnownNat inputCols
143 , KnownNat outputRows
164 , KnownNat outputRows
144 , KnownNat outputCols
165 , KnownNat outputCols
166+ , KnownNat channels
145 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
167 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
146 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
168 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
147− , KnownNat (kernelRows * kernelCols * 1)
169+ , KnownNat (kernelRows * kernelCols * channels)
170+ , KnownNat (outputRows * filters)
148− ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where
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+
149− runForwards (Convolution kernel _) (S2D' input) =
175+ runForwards (Convolution kernel _) (S3D input) =
150 let ex = extract input
176 let ex = extract input
151 ek = extract kernel
177 ek = extract kernel
178+ ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
179+ iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
152 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
180 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
153 ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
181 ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
154 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
182 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
155 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
183 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
156 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
184 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
157 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
185 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
163
186
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)
164− runBackwards (Convolution kernel _) (S2D' input) (S3D' dEdy) =
192+ runBackwards (Convolution kernel _) (S3D input) (S3D dEdy) =
165 let ex = extract input
193 let ex = extract input
166 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
194 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
167 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
195 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
@@ -172,22 +200,22 @@ instance ( KnownNat kernelRows
172 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
200 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
173 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
201 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
174
202
175− c = im2colUnsafe kx ky sx sy ex
203+ c = vid2col kx ky sx sy ix iy ex
176
204
177− eo = vecToList $ fmap extract dEdy
205+ eo = extract dEdy
178 ek = extract kernel
206 ek = extract kernel
179
207
180− vs = vid2colUnsafe 1 1 1 1 ox oy eo
208+ vs = vid2col 1 1 1 1 ox oy eo
181
209
182 kN = fromJust . create $ tr c LA.<> vs
210 kN = fromJust . create $ tr c LA.<> vs
211+
183 dW = vs LA.<> tr ek
212 dW = vs LA.<> tr ek
184
213
185− xW = col2imUnsafe kx ky sx sy ix iy dW
214+ xW = col2vid kx ky sx sy ix iy dW
186− in (Convolution' kN, S2D' . fromJust . create $ xW)
215+ in (Convolution' kN, S3D . fromJust . create $ xW)
187
216
188
217
189−-- | A three dimensional image (or 2d with many channels) can have
218+-- | A two dimentional image may have a convolution filter applied to it
190−-- an appropriately sized convolution filter run across it.
191instance ( KnownNat kernelRows
219instance ( KnownNat kernelRows
192 , KnownNat kernelCols
220 , KnownNat kernelCols
193 , KnownNat filters
221 , KnownNat filters
@@ -197,49 +225,63 @@ instance ( KnownNat kernelRows
197 , KnownNat inputCols
225 , KnownNat inputCols
198 , KnownNat outputRows
226 , KnownNat outputRows
199 , KnownNat outputCols
227 , KnownNat outputCols
200− , KnownNat channels
201 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
228 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
202 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
229 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
203− , KnownNat (kernelRows * kernelCols * channels)
230+ , KnownNat (kernelRows * kernelCols * 1)
231+ , KnownNat (outputRows * filters)
204− ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where
232+ ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where
205− runForwards (Convolution kernel _) (S3D' input) =
233+ type Tape (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols 1)
206− let ex = vecToList $ fmap extract input
234+ runForwards c (S2D input) =
207− ek = extract kernel
235+ runForwards c (S3D input :: S ('D3 inputRows inputCols 1))
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)
232
236
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)
234
240
235− eo = vecToList $ fmap extract dEdy
236− ek = extract kernel
237
241
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)
239
261
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)
241
265
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)
243
285
244− xW = col2vidUnsafe kx ky sx sy ix iy dW
286+ runBackwards c tape (S2D grads) =
245− in (Convolution' kN, S3D' . mkVector . fmap (fromJust . create) $ xW)
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 #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleContexts #-}
9−{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
10−
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+-}
11module Grenade.Layers.Crop (
17module Grenade.Layers.Crop (
12 Crop (..)
18 Crop (..)
13 ) where
19 ) where
14
20
15import Data.Maybe
21import Data.Maybe
16import Data.Proxy
22import Data.Proxy
17−import Data.Singletons.TypeLits
23+import Data.Serialize
24+
18import GHC.TypeLits
25import GHC.TypeLits
26+import Data.Kind (Type)
19
27
20−import Grenade.Core.Network
28+import Grenade.Core
21−import Grenade.Core.Shape
29+import Grenade.Layers.Internal.Pad
22
30
23import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)
31import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)
24import Numeric.LinearAlgebra.Static (extract, create)
32import Numeric.LinearAlgebra.Static (extract, create)
@@ -27,7 +35,7 @@ import Numeric.LinearAlgebra.Static (extract, create)
27data Crop :: Nat
35data Crop :: Nat
28 -> Nat
36 -> Nat
29 -> Nat
37 -> Nat
30− -> Nat -> * where
38+ -> Nat -> Type where
31 Crop :: Crop cropLeft cropTop cropRight cropBottom
39 Crop :: Crop cropLeft cropTop cropRight cropBottom
32
40
33instance Show (Crop cropLeft cropTop cropRight cropBottom) where
41instance Show (Crop cropLeft cropTop cropRight cropBottom) where
@@ -38,6 +46,10 @@ instance UpdateLayer (Crop l t r b) where
38 runUpdate _ x _ = x
46 runUpdate _ x _ = x
39 createRandom = return Crop
47 createRandom = return Crop
40
48
49+instance Serialize (Crop l t r b) where
50+ put _ = return ()
51+ get = return Crop
52+
41-- | A two dimentional image can be cropped.
53-- | A two dimentional image can be cropped.
42instance ( KnownNat cropLeft
54instance ( KnownNat cropLeft
43 , KnownNat cropTop
55 , KnownNat cropTop
@@ -47,22 +59,68 @@ instance ( KnownNat cropLeft
47 , KnownNat inputColumns
59 , KnownNat inputColumns
48 , KnownNat outputRows
60 , KnownNat outputRows
49 , KnownNat outputColumns
61 , KnownNat outputColumns
50− , (inputRows - cropTop - cropBottom) ~ outputRows
62+ , (outputRows + cropTop + cropBottom) ~ inputRows
51− , (inputColumns - cropLeft - cropRight) ~ outputColumns
63+ , (outputColumns + cropLeft + cropRight) ~ inputColumns
52 ) => Layer (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where
64 ) => Layer (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where
65+ type Tape (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = ()
53− runForwards Crop (S2D' input) =
66+ runForwards Crop (S2D input) =
54 let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)
67 let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)
55 cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)
68 cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)
56 nrows = fromIntegral $ natVal (Proxy :: Proxy outputRows)
69 nrows = fromIntegral $ natVal (Proxy :: Proxy outputRows)
57 ncols = fromIntegral $ natVal (Proxy :: Proxy outputColumns)
70 ncols = fromIntegral $ natVal (Proxy :: Proxy outputColumns)
58 m = extract input
71 m = extract input
59 r = subMatrix (cropt, cropl) (nrows, ncols) m
72 r = subMatrix (cropt, cropl) (nrows, ncols) m
60− in S2D' . fromJust . create $ r
73+ in ((), S2D . fromJust . create $ r)
61− runBackwards _ _ (S2D' dEdy) =
74+ runBackwards _ _ (S2D dEdy) =
62 let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)
75 let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)
63 cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)
76 cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)
64 cropr = fromIntegral $ natVal (Proxy :: Proxy cropRight)
77 cropr = fromIntegral $ natVal (Proxy :: Proxy cropRight)
65 cropb = fromIntegral $ natVal (Proxy :: Proxy cropBottom)
78 cropb = fromIntegral $ natVal (Proxy :: Proxy cropBottom)
66 eo = extract dEdy
79 eo = extract dEdy
67 vs = diagBlock [konst 0 (cropt,cropl), eo, konst 0 (cropb,cropr)]
80 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 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE TypeOperators #-}
2{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE FlexibleContexts #-}
7−{-# LANGUAGE FlexibleInstances #-}
8−{-# LANGUAGE LambdaCase #-}
9−
10module Grenade.Layers.Dropout (
5module Grenade.Layers.Dropout (
11 Dropout (..)
6 Dropout (..)
12 , randomDropout
7 , randomDropout
@@ -15,37 +10,28 @@ module Grenade.Layers.Dropout (
15import Control.Monad.Random hiding (fromList)
10import Control.Monad.Random hiding (fromList)
16
11
17import GHC.TypeLits
12import GHC.TypeLits
18−import Grenade.Core.Shape
13+import Grenade.Core
19−import Grenade.Core.Network
20−
21−import Numeric.LinearAlgebra.Static
22−
23
14
24-- Dropout layer help to reduce overfitting.
15-- Dropout layer help to reduce overfitting.
25-- Idea here is that the vector is a shape of 1s and 0s, which we multiply the input by.
16-- Idea here is that the vector is a shape of 1s and 0s, which we multiply the input by.
26-- After backpropogation, we return a new matrix/vector, with different bits dropped out.
17-- After backpropogation, we return a new matrix/vector, with different bits dropped out.
27-- Double is the proportion to drop in each training iteration (like 1% or 5% would be
18-- Double is the proportion to drop in each training iteration (like 1% or 5% would be
28-- reasonable).
19-- reasonable).
29−data Dropout o =
20+data Dropout = Dropout {
30− Dropout (R o)
31− | Pass Double
21+ dropoutRate :: Double
22+ , dropoutSeed :: Int
32− deriving Show
23+ } deriving Show
33
24
34−instance (KnownNat i) => UpdateLayer (Dropout i) where
25+instance UpdateLayer Dropout where
35− type Gradient (Dropout i) = ()
26+ type Gradient Dropout = ()
36 runUpdate _ x _ = x
27 runUpdate _ x _ = x
37 createRandom = randomDropout 0.95
28 createRandom = randomDropout 0.95
38
29
39−randomDropout :: (MonadRandom m, KnownNat i)
30+randomDropout :: MonadRandom m
40− => Double -> m (Dropout i)
31+ => Double -> m Dropout
41−randomDropout rate = do
32+randomDropout rate = Dropout rate <$> getRandom
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
46
33
47−instance (KnownNat i) => Layer (Dropout i) ('D1 i) ('D1 i) where
34+instance (KnownNat i) => Layer Dropout ('D1 i) ('D1 i) where
48− runForwards (Dropout drops) (S1D' x) = S1D' $ x * drops
35+ type Tape Dropout ('D1 i) ('D1 i) = ()
49− runForwards (Pass rate) (S1D' x)= S1D' $ dvmap (* (1 - rate)) x
50− runBackwards (Dropout drops) _ (S1D' x) = ((), S1D' $ x * drops)
36+ runForwards (Dropout _ _) (S1D x) = ((), S1D x)
51− runBackwards (Pass rate) _ (S1D' x) = ((), S1D' $ dvmap (* (1 - rate)) 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 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE TypeOperators #-}
2{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
8−
9module Grenade.Layers.FullyConnected (
6module Grenade.Layers.FullyConnected (
10 FullyConnected (..)
7 FullyConnected (..)
8+ , FullyConnected' (..)
11 , randomFullyConnected
9 , randomFullyConnected
12 ) where
10 ) where
13
11
14import Control.Monad.Random hiding (fromList)
12import Control.Monad.Random hiding (fromList)
15
13
16−import Data.Singletons.TypeLits
14+import Data.Proxy
15+import Data.Serialize
17
16
17+import qualified Numeric.LinearAlgebra as LA
18import Numeric.LinearAlgebra.Static
18import Numeric.LinearAlgebra.Static
19
19
20−import Grenade.Core.Network
20+import Grenade.Core
21+
21−import Grenade.Core.Shape
22+import Grenade.Layers.Internal.Update
23+import GHC.TypeLits
22
24
23-- | A basic fully connected (or inner product) neural network layer.
25-- | A basic fully connected (or inner product) neural network layer.
24data FullyConnected i o = FullyConnected
26data FullyConnected i o = FullyConnected
25− !(R o) -- Bias neuron weights
27+ !(FullyConnected' i o) -- Neuron weights
26− !(R o) -- Bias neuron momentum
28+ !(FullyConnected' i o) -- Neuron momentum
27− !(L o i) -- Activation weights
28− !(L o i) -- Momentum
29
29
30data FullyConnected' i o = FullyConnected'
30data FullyConnected' i o = FullyConnected'
31− !(R o) -- Bias neuron gradient
31+ !(R o) -- Bias
32− !(L o i) -- Activation gradient
32+ !(L o i) -- Activations
33
33
34instance Show (FullyConnected i o) where
34instance Show (FullyConnected i o) where
35 show FullyConnected {} = "FullyConnected"
35 show FullyConnected {} = "FullyConnected"
@@ -37,35 +37,46 @@ instance Show (FullyConnected i o) where
37instance (KnownNat i, KnownNat o) => UpdateLayer (FullyConnected i o) where
37instance (KnownNat i, KnownNat o) => UpdateLayer (FullyConnected i o) where
38 type Gradient (FullyConnected i o) = (FullyConnected' i o)
38 type Gradient (FullyConnected i o) = (FullyConnected' i o)
39
39
40− runUpdate LearningParameters {..} (FullyConnected oldBias oldBiasMomentum oldActivations oldMomentum) (FullyConnected' biasGradient activationGradient) =
40+ runUpdate lp (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =
41− let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient
41+ let (newBias, newBiasMomentum) = descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldBias biasGradient oldBiasMomentum
42− newBias = oldBias + newBiasMomentum
42+ (newActivations, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldActivations activationGradient oldMomentum
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
43+ in FullyConnected (FullyConnected' newBias newActivations) (FullyConnected' newBiasMomentum newMomentum)
47
44
48 createRandom = randomFullyConnected
45 createRandom = randomFullyConnected
49
46
50instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o) where
47instance (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
51 -- Do a matrix vector multiplication and return the result.
49 -- 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))
53
51
54 -- Run a backpropogation step for a full connected layer.
52 -- 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) =
56 let wB' = dEdy
54 let wB' = dEdy
57 mm' = dEdy `outer` x
55 mm' = dEdy `outer` x
58 -- calcluate derivatives for next step
56 -- calcluate derivatives for next step
59 dWs = tr wN #> dEdy
57 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)
61
72
62randomFullyConnected :: (MonadRandom m, KnownNat i, KnownNat o)
73randomFullyConnected :: (MonadRandom m, KnownNat i, KnownNat o)
63 => m (FullyConnected i o)
74 => m (FullyConnected i o)
64randomFullyConnected = do
75randomFullyConnected = do
65− s1 :: Int <- getRandom
76+ s1 <- getRandom
66− s2 :: Int <- getRandom
77+ s2 <- getRandom
67 let wB = randomVector s1 Uniform * 2 - 1
78 let wB = randomVector s1 Uniform * 2 - 1
68 wN = uniformSample s2 (-1) 1
79 wN = uniformSample s2 (-1) 1
69 bm = konst 0
80 bm = konst 0
70 mm = konst 0
81 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−184
@@ -1,195 +1,80 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
1module Grenade.Layers.Internal.Convolution (
2module Grenade.Layers.Internal.Convolution (
2− col2vidUnsafe
3+ im2col
3− , col2imUnsafe
4+ , col2im
4− , vid2colUnsafe
5+ , col2vid
5− , im2colUnsafe
6+ , vid2col
6− , fittingStarts
7− , unsafeModifyMatrix
8 ) where
7 ) where
9
8
10−import Control.Monad.ST ( ST, runST )
9+import qualified Data.Vector.Storable as U ( unsafeToForeignPtr0, unsafeFromForeignPtr0 )
11
10
12−import Data.STRef ( newSTRef, modifySTRef', writeSTRef, readSTRef )
11+import Foreign ( mallocForeignPtrArray, withForeignPtr )
13−import Data.Foldable ( forM_ )
12+import Foreign.Ptr ( Ptr )
14−import Data.Traversable ( forM )
15
13
16−import Foreign.Storable( Storable )
17−
18−import Numeric.LinearAlgebra hiding ( uniformSample, konst )
14+import Numeric.LinearAlgebra ( Matrix, flatten, rows, cols )
19import qualified Numeric.LinearAlgebra.Devel as U
15import qualified Numeric.LinearAlgebra.Devel as U
20
16
21−-- This module provides provides im2col function and friends, ala caffe.
17+import System.IO.Unsafe ( unsafePerformIO )
22−--
18+
23−-- /* From Caffe */
19+col2vid :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
24−-- @
20+col2vid kernelRows kernelColumns strideRows strideColumns height width dataCol =
25−-- void col2im_cpu(const Dtype* data_col, const int channels,
21+ let channels = cols dataCol `div` (kernelRows * kernelColumns)
26−-- const int height, const int width, const int kernel_h, const int kernel_w,
22+ in col2im_c channels height width kernelRows kernelColumns strideRows strideColumns dataCol
27−-- const int pad_h, const int pad_w,
23+
28−-- const int stride_h, const int stride_w,
29−-- const int dilation_h, const int dilation_w,
30−-- Dtype* data_im) {
31−-- caffe_set(height * width * channels, Dtype(0), data_im);
32−-- const int output_h = (height + 2 * pad_h -
33−-- (dilation_h * (kernel_h - 1) + 1)) / stride_h + 1;
34−-- const int output_w = (width + 2 * pad_w -
35−-- (dilation_w * (kernel_w - 1) + 1)) / stride_w + 1;
36−-- const int channel_size = height * width;
37−-- for (int channel = channels; channel--; data_im += channel_size) {
38−-- for (int kernel_row = 0; kernel_row < kernel_h; kernel_row++) {
39−-- for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {
40−-- int input_row = -pad_h + kernel_row * dilation_h;
41−-- for (int output_rows = output_h; output_rows; output_rows--) {
42−-- if (!is_a_ge_zero_and_a_lt_b(input_row, height)) {
43−-- data_col += output_w;
44−-- } else {
45−-- int input_col = -pad_w + kernel_col * dilation_w;
46−-- for (int output_col = output_w; output_col; output_col--) {
47−-- if (is_a_ge_zero_and_a_lt_b(input_col, width)) {
48−-- data_im[input_row * width + input_col] += *data_col;
49−-- }
50−-- data_col++;
51−-- input_col += stride_w;
52−-- }
53−-- }
54−-- input_row += stride_h;
55−-- }
56−-- }
57−-- }
58−-- }
59−-- }
60−-- @
61−--
62−
63−-- | col2im function.
64−--
65−-- Takes a column patch, and reconstitutes it into a normal image.
66−-- Does not do any bounds checking on the matrix, so should only
67−-- be called once the sizes are ensured correct.
68−col2imUnsafe :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
24+col2im :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
69−col2imUnsafe kernelRows kernelColumns strideRows strideColumns destinationRows destinationCols columnMatrix = U.runSTMatrix $ do
25+col2im kernelRows kernelColumns strideRows strideColumns height width dataCol =
70− let columnMatrixRows = rows columnMatrix
26+ let channels = 1
71−
27+ in col2im_c channels height width kernelRows kernelColumns strideRows strideColumns dataCol
72− dataIm <- U.newMatrix 0 destinationRows destinationCols
28+
73− offsetR <- newSTRef 0
29+col2im_c :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
74− offsetC <- newSTRef 0
30+col2im_c channels height width kernelRows kernelColumns strideRows strideColumns dataCol =
75−
31+ let vec = flatten dataCol
76− forM_ [0 .. columnMatrixRows - 1] $ \inputRow -> do
32+ in unsafePerformIO $ do
77− inputColumnRef <- newSTRef 0
33+ outPtr <- mallocForeignPtrArray (height * width * channels)
78− offsetR' <- readSTRef offsetR
34+ let (inPtr, _) = U.unsafeToForeignPtr0 vec
79− offsetC' <- readSTRef offsetC
35+
80− forM_ [offsetR' .. offsetR' + kernelRows -1] $ \kr ->
36+ withForeignPtr inPtr $ \inPtr' ->
81− forM_ [offsetC' .. offsetC' + kernelColumns -1] $ \kc -> do
37+ withForeignPtr outPtr $ \outPtr' ->
82− inputColumn <- readSTRef inputColumnRef
38+ col2im_cpu inPtr' channels height width kernelRows kernelColumns strideRows strideColumns outPtr'
83− unsafeModifyMatrix dataIm kr kc (+ U.atM' columnMatrix inputRow inputColumn)
39+
84− modifySTRef' inputColumnRef (+1)
40+ let matVec = U.unsafeFromForeignPtr0 outPtr (height * width * channels)
85−
41+ return $ U.matrixFromVector U.RowMajor (height * channels) width matVec
86− if offsetC' + kernelColumns < destinationCols
42+
87− then modifySTRef' offsetC (+ strideColumns)
43+foreign import ccall unsafe
88− else writeSTRef offsetC 0 >> modifySTRef' offsetR (+ strideRows)
44+ col2im_cpu
89−
45+ :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()
90− return dataIm
46+
91−
92−-- | col2vid function.
93−--
94−-- Takes a column patch image, and reconstitutes it into a normal image with multiple channels.
95−-- Does not do any bounds checking on the matrix, so should only
96−-- be called once the sizes are ensured correct.
97−col2vidUnsafe :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> [Matrix Double]
47+vid2col :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
98−col2vidUnsafe kernelRows kernelColumns strideRows strideColumns destinationRows destinationCols columnMatrix = runST $ do
48+vid2col kernelRows kernelColumns strideRows strideColumns height width dataVid =
99− let columnMatrixRows = rows columnMatrix
49+ let channels = rows dataVid `div` height
100− let filters = cols columnMatrix `div` (kernelRows * kernelColumns)
50+ in im2col_c channels height width kernelRows kernelColumns strideRows strideColumns dataVid
101−
51+
102− forM [0 .. filters - 1] $ \iter -> do
52+
53+im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
103− let offsetM = iter * (kernelRows * kernelColumns)
54+im2col kernelRows kernelColumns strideRows strideColumns dataIm =
104− dataIm <- U.newMatrix 0 destinationRows destinationCols
55+ let channels = 1
105− offsetR <- newSTRef 0
56+ height = rows dataIm
106− offsetC <- newSTRef 0
57+ width = cols dataIm
107− forM_ [0 .. columnMatrixRows - 1] $ \ir -> do
58+ in im2col_c channels height width kernelRows kernelColumns strideRows strideColumns dataIm
108− inputColumn <- newSTRef 0
59+
109− offsetR' <- readSTRef offsetR
110− offsetC' <- readSTRef offsetC
111− forM_ [offsetR' .. offsetR' + kernelRows -1] $ \kr ->
112− forM_ [offsetC' .. offsetC' + kernelColumns -1] $ \kc -> do
113− ic <- readSTRef inputColumn
114− unsafeModifyMatrix dataIm kr kc (+ U.atM' columnMatrix ir (ic + offsetM))
115− modifySTRef' inputColumn (+1)
116−
117− if offsetC' + kernelColumns < destinationCols
118− then modifySTRef' offsetC (+ strideColumns)
119− else writeSTRef offsetC 0 >> modifySTRef' offsetR (+ strideRows)
120−
121− U.unsafeFreezeMatrix dataIm
122−
123−vid2colUnsafe :: Int -> Int -> Int -> Int -> Int -> Int -> [Matrix Double] -> Matrix Double
60+im2col_c :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
124−vid2colUnsafe kernelRows kernelColumns striderows stridecols vidrows vidcols dataVid = U.runSTMatrix $ do
61+im2col_c channels height width kernelRows kernelColumns strideRows strideColumns dataIm =
125− let starts = fittingStarts vidrows kernelRows striderows vidcols kernelColumns stridecols
62+ let vec = flatten dataIm
63+ rowOut = (height - kernelRows) `div` strideRows + 1
64+ colOut = (width - kernelColumns) `div` strideColumns + 1
126 kernelSize = kernelRows * kernelColumns
65 kernelSize = kernelRows * kernelColumns
127− numberOfPatches = length starts
66+ numberOfPatches = rowOut * colOut
128− channels = length dataVid
67+ in unsafePerformIO $ do
129−
68+ outPtr <- mallocForeignPtrArray (numberOfPatches * kernelSize * channels)
130− dataCol <- U.newMatrix 0 numberOfPatches (channels * kernelSize)
69+ let (inPtr, _) = U.unsafeToForeignPtr0 vec
131−
132− offsetC <- newSTRef 0
133
70
134− forM_ dataVid $ \dataIm -> do
71+ withForeignPtr inPtr $ \inPtr' ->
135− inputRowRef <- newSTRef 0
72+ withForeignPtr outPtr $ \outPtr' ->
136− offsetC' <- readSTRef offsetC
73+ im2col_cpu inPtr' channels height width kernelRows kernelColumns strideRows strideColumns outPtr'
137− forM_ starts $ \(startRow, startCol) -> do
138− inputColumnRef <- newSTRef 0
139− inputRow <- readSTRef inputRowRef
140− forM_ [startRow .. startRow + kernelRows -1] $ \kr ->
141− forM_ [startCol .. startCol + kernelColumns -1] $ \kc -> do
142− inputColumn <- readSTRef inputColumnRef
143− unsafeModifyMatrix dataCol inputRow (inputColumn + offsetC') (+ U.atM' dataIm kr kc)
144− modifySTRef' inputColumnRef (+1)
145− modifySTRef' inputRowRef (+1)
146
74
147− modifySTRef' offsetC (+ kernelSize)
75+ let matVec = U.unsafeFromForeignPtr0 outPtr (numberOfPatches * kernelSize * channels)
76+ return $ U.matrixFromVector U.RowMajor numberOfPatches (kernelSize * channels) matVec
148
77
149− return dataCol
78+foreign import ccall unsafe
150−
79+ im2col_cpu
151−im2colUnsafe :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
80+ :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()
152−im2colUnsafe kernelRows kernelColumns striderows stridecols dataIm = U.runSTMatrix $ do
153− let starts = fittingStarts (rows dataIm) kernelRows striderows (cols dataIm) kernelColumns stridecols
154− kernelSize = kernelRows * kernelColumns
155− numberOfPatches = length starts
156−
157− dataCol <- U.newMatrix 0 numberOfPatches kernelSize
158−
159− inputRowRef <- newSTRef 0
160− forM_ starts $ \(startRow, startCol) -> do
161− inputColumnRef <- newSTRef 0
162− inputRow <- readSTRef inputRowRef
163− forM_ [startRow .. startRow + kernelRows -1] $ \kr ->
164− forM_ [startCol .. startCol + kernelColumns -1] $ \kc -> do
165− inputColumn <- readSTRef inputColumnRef
166− unsafeModifyMatrix dataCol inputRow inputColumn (+ U.atM' dataIm kr kc)
167− modifySTRef' inputColumnRef (+1)
168− modifySTRef' inputRowRef (+1)
169−
170− return dataCol
171−
172−unsafeModifyMatrix :: (Storable t) => U.STMatrix s t -> Int -> Int -> (t -> t) -> ST s ()
173−unsafeModifyMatrix x r c f = U.unsafeReadMatrix x r c >>= U.unsafeWriteMatrix x r c . f
174−{-# INLINE unsafeModifyMatrix #-}
175−
176−
177−-- | Returns the starting sub matrix locations which fit inside the larger matrix for the
178−-- convolution. Takes into account the stride and kernel size.
179−fittingStarts :: Int -> Int -> Int -> Int -> Int -> Int -> [(Int,Int)]
180−fittingStarts nrows kernelrows steprows ncols kernelcols stepcolsh =
181− let rs = fittingStart nrows kernelrows steprows
182− cs = fittingStart ncols kernelcols stepcolsh
183− in concatMap ( \r -> fmap (\c -> (r , c)) cs ) rs
184−
185−-- | Returns the starting sub vector which fit inside the larger vector for the
186−-- convolution. Takes into account the stride and kernel size.
187−fittingStart :: Int -> Int -> Int -> [Int]
188−fittingStart width kernel steps =
189− let go left | left + kernel < width
190− = left : go (left + steps)
191− | left + kernel == width
192− = [left]
193− | otherwise
194− = []
195− in go 0
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−61
@@ -1,69 +1,57 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
1module Grenade.Layers.Internal.Pooling (
2module Grenade.Layers.Internal.Pooling (
2 poolForward
3 poolForward
3 , poolBackward
4 , poolBackward
4− , poolForwardList
5− , poolBackwardList
6 ) where
5 ) where
7
6
8−import Data.Foldable ( forM_ )
7+import qualified Data.Vector.Storable as U ( unsafeToForeignPtr0, unsafeFromForeignPtr0 )
9−import Data.Function ( on )
10−import Data.List ( maximumBy )
11
8
12−import Numeric.LinearAlgebra hiding ( uniformSample, konst )
9+import Foreign ( mallocForeignPtrArray, withForeignPtr )
13−import qualified Numeric.LinearAlgebra as LA
10+import Foreign.Ptr ( Ptr )
14−import qualified Numeric.LinearAlgebra.Devel as U
15−
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 -> unsafeMaxElementSubmatrix 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
11
45−poolBackwardFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double
12+import Numeric.LinearAlgebra ( Matrix , flatten )
46−poolBackwardFit starts krows kcols inputMatrix gradientMatrix = U.runSTMatrix $ do
13+import qualified Numeric.LinearAlgebra.Devel as U
47− let inRows = rows inputMatrix
48− inCols = cols inputMatrix
49− gradCol = cols gradientMatrix
50− extent = (krows, kcols)
51−
52− retM <- U.newMatrix 0 inRows inCols
53−
54− forM_ (zip [0..] starts) $ \(ix, start) -> do
55− let loc = unsafeMaxIndexSubMatrix start extent inputMatrix
56− uncurry (unsafeModifyMatrix retM) loc ((+) $ uncurry (U.atM' gradientMatrix) $ divMod ix gradCol)
57−
58− return retM
59−
60−unsafeMaxElementSubmatrix :: (Int,Int) -> (Int,Int) -> Matrix Double -> Double
61−unsafeMaxElementSubmatrix starts extent m = uncurry (U.atM' m) $ unsafeMaxIndexSubMatrix starts extent m
62−
63−unsafeMaxIndexSubMatrix :: (Int,Int) -> (Int,Int) -> Matrix Double -> (Int, Int)
64−unsafeMaxIndexSubMatrix (startRow, startCol) (extentRow, extentCold) m =
65− let mrows = [startRow .. startRow + extentRow - 1]
66− mcols = [startCol .. startCol + extentCold - 1]
67− pairs = concatMap ( \r -> fmap (\c -> (r , c)) mcols ) mrows
68− in maximumBy (compare `on` uncurry (U.atM' m)) pairs
69
14
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 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE TypeOperators #-}
2{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE FlexibleInstances #-}
4{-# 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+-}
8module Grenade.Layers.Logit (
13module Grenade.Layers.Logit (
9 Logit (..)
14 Logit (..)
10 ) where
15 ) where
11
16
12
17
13−import Data.Singletons.TypeLits
18+import Data.Serialize
14−import Grenade.Core.Network
19+import Data.Singletons
20+
15−import Grenade.Core.Vector
21+import Grenade.Core
16−import Grenade.Core.Shape
17
22
18-- | A Logit layer.
23-- | A Logit layer.
24+--
19-- A layer which can act between any shape of the same dimension, perfoming an sigmoid function.
25-- A layer which can act between any shape of the same dimension, perfoming an sigmoid function.
20-- This layer should be used as the output layer of a network for logistic regression (classification)
26-- This layer should be used as the output layer of a network for logistic regression (classification)
21-- problems.
27-- problems.
@@ -27,23 +33,25 @@ instance UpdateLayer Logit where
27 runUpdate _ _ _ = Logit
33 runUpdate _ _ _ = Logit
28 createRandom = return Logit
34 createRandom = return Logit
29
35
30−instance (KnownNat i) => Layer Logit ('D1 i) ('D1 i) where
36+instance (a ~ b, SingI a) => Layer Logit a b where
31− runForwards _ (S1D' y) = S1D' (logistic y)
37+ -- Wengert tape optimisation:
32− runBackwards _ (S1D' y) (S1D' dEdy) = ((), S1D' (logistic' y * dEdy))
38+ --
33−
39+ -- Derivative of the sigmoid function is
34−instance (KnownNat i, KnownNat j) => Layer Logit ('D2 i j) ('D2 i j) where
40+ -- d σ(x) / dx = σ(x) • (1 - σ(x))
35− runForwards _ (S2D' y) = S2D' (logistic y)
41+ -- but we have already calculated σ(x) in
36− runBackwards _ (S2D' y) (S2D' dEdy) = ((), S2D' (logistic' y * dEdy))
42+ -- the forward pass, so just store that
37−
43+ -- and use it in the backwards pass.
38−instance (KnownNat i, KnownNat j, KnownNat k) => Layer Logit ('D3 i j k) ('D3 i j k) where
44+ type Tape Logit a b = S a
39− runForwards _ (S3D' y) = S3D' (fmap logistic y)
45+ runForwards _ a =
40− runBackwards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> logistic' y' * dEdy') y dEdy))
46+ let l = sigmoid a
41−
47+ in (l, l)
42−
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+
43−logistic :: Floating a => a -> a
56+sigmoid :: Floating a => a -> a
44−logistic x = 1 / (1 + exp (-x))
57+sigmoid x = 1 / (1 + exp (-x))
45−
46−logistic' :: Floating a => a -> a
47−logistic' x = logix * (1 - logix)
48− where
49− logix = logistic 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 #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleContexts #-}
9−{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE UndecidableInstances #-}
10−
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+-}
11module Grenade.Layers.Pad (
17module Grenade.Layers.Pad (
12 Pad (..)
18 Pad (..)
13 ) where
19 ) where
14
20
15import Data.Maybe
21import Data.Maybe
16import Data.Proxy
22import Data.Proxy
17−import Data.Singletons.TypeLits
23+import Data.Serialize
24+
18import GHC.TypeLits
25import GHC.TypeLits
26+import Data.Kind (Type)
19
27
20−import Grenade.Core.Network
28+import Grenade.Core
21−import Grenade.Core.Shape
29+import Grenade.Layers.Internal.Pad
22
30
23import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)
31import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)
24import Numeric.LinearAlgebra.Static (extract, create)
32import Numeric.LinearAlgebra.Static (extract, create)
25
33
26-- | A padding layer for a neural network.
34-- | A padding layer for a neural network.
35+--
36+-- Pads on the X and Y dimension of an image.
27data Pad :: Nat
37data Pad :: Nat
28 -> Nat
38 -> Nat
29 -> Nat
39 -> Nat
30− -> Nat -> * where
40+ -> Nat -> Type where
31 Pad :: Pad padLeft padTop padRight padBottom
41 Pad :: Pad padLeft padTop padRight padBottom
32
42
33instance Show (Pad padLeft padTop padRight padBottom) where
43instance Show (Pad padLeft padTop padRight padBottom) where
@@ -38,7 +48,11 @@ instance UpdateLayer (Pad l t r b) where
38 runUpdate _ x _ = x
48 runUpdate _ x _ = x
39 createRandom = return Pad
49 createRandom = return Pad
40
50
51+instance Serialize (Pad l t r b) where
52+ put _ = return ()
53+ get = return Pad
54+
41−-- | A two dimentional image can be padped.
55+-- | A two dimentional image can be padded.
42instance ( KnownNat padLeft
56instance ( KnownNat padLeft
43 , KnownNat padTop
57 , KnownNat padTop
44 , KnownNat padRight
58 , KnownNat padRight
@@ -50,19 +64,64 @@ instance ( KnownNat padLeft
50 , (inputRows + padTop + padBottom) ~ outputRows
64 , (inputRows + padTop + padBottom) ~ outputRows
51 , (inputColumns + padLeft + padRight) ~ outputColumns
65 , (inputColumns + padLeft + padRight) ~ outputColumns
52 ) => Layer (Pad padLeft padTop padRight padBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where
66 ) => Layer (Pad padLeft padTop padRight padBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where
67+ type Tape (Pad padLeft padTop padRight padBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = ()
53− runForwards Pad (S2D' input) =
68+ runForwards Pad (S2D input) =
54 let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)
69 let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)
55 padt = fromIntegral $ natVal (Proxy :: Proxy padTop)
70 padt = fromIntegral $ natVal (Proxy :: Proxy padTop)
56 padr = fromIntegral $ natVal (Proxy :: Proxy padRight)
71 padr = fromIntegral $ natVal (Proxy :: Proxy padRight)
57 padb = fromIntegral $ natVal (Proxy :: Proxy padBottom)
72 padb = fromIntegral $ natVal (Proxy :: Proxy padBottom)
58 m = extract input
73 m = extract input
59 r = diagBlock [konst 0 (padt,padl), m, konst 0 (padb,padr)]
74 r = diagBlock [konst 0 (padt,padl), m, konst 0 (padb,padr)]
60− in S2D' . fromJust . create $ r
75+ in ((), S2D . fromJust . create $ r)
61− runBackwards Pad _ (S2D' dEdy) =
76+ runBackwards Pad _ (S2D dEdy) =
62 let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)
77 let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)
63 padt = fromIntegral $ natVal (Proxy :: Proxy padTop)
78 padt = fromIntegral $ natVal (Proxy :: Proxy padTop)
64 nrows = fromIntegral $ natVal (Proxy :: Proxy inputRows)
79 nrows = fromIntegral $ natVal (Proxy :: Proxy inputRows)
65 ncols = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
80 ncols = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
66 m = extract dEdy
81 m = extract dEdy
67 vs = subMatrix (padt, padl) (nrows, ncols) m
82 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 #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE StandaloneDeriving #-}
4{-# LANGUAGE StandaloneDeriving #-}
@@ -6,44 +6,54 @@
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE FlexibleInstances #-}
10{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE FlexibleContexts #-}
11−{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE UndecidableInstances #-}
12−
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+-}
13module Grenade.Layers.Pooling (
18module Grenade.Layers.Pooling (
14 Pooling (..)
19 Pooling (..)
15 ) where
20 ) where
16
21
17import Data.Maybe
22import Data.Maybe
18import Data.Proxy
23import Data.Proxy
19−import Data.Singletons.TypeLits
24+import Data.Serialize
25+
20import GHC.TypeLits
26import GHC.TypeLits
27+import Data.Kind (Type)
21
28
22−import Grenade.Core.Network
29+import Grenade.Core
23−import Grenade.Core.Shape
24−import Grenade.Core.Vector
25import Grenade.Layers.Internal.Pooling
30import Grenade.Layers.Internal.Pooling
26
31
27import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)
32import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)
28
33
29-- | A pooling layer for a neural network.
34-- | A pooling layer for a neural network.
35+--
30-- Does a max pooling, looking over a kernel similarly to the convolution network, but returning
36-- Does a max pooling, looking over a kernel similarly to the convolution network, but returning
31-- maxarg only. This layer is often used to provide minor amounts of translational invariance.
37-- maxarg only. This layer is often used to provide minor amounts of translational invariance.
32--
38--
33-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:
39-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:
34-- `out = (in - kernel) / stride + 1` for both dimensions.
40-- `out = (in - kernel) / stride + 1` for both dimensions.
35--
41--
36−data Pooling :: Nat -> Nat -> Nat -> Nat -> * where
42+data Pooling :: Nat -> Nat -> Nat -> Nat -> Type where
37 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns
43 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns
38
44
39instance Show (Pooling k k' s s') where
45instance Show (Pooling k k' s s') where
40 show Pooling = "Pooling"
46 show Pooling = "Pooling"
41
47
42instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where
48instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where
43− type Gradient (Pooling kr kc sr sc) = ()
49+ type Gradient (Pooling kernelRows kernelColumns strideRows strideColumns) = ()
44 runUpdate _ Pooling _ = Pooling
50 runUpdate _ Pooling _ = Pooling
45 createRandom = return Pooling
51 createRandom = return Pooling
46
52
53+instance Serialize (Pooling kernelRows kernelColumns strideRows strideColumns) where
54+ put _ = return ()
55+ get = return Pooling
56+
47-- | A two dimentional image can be pooled.
57-- | A two dimentional image can be pooled.
48instance ( KnownNat kernelRows
58instance ( KnownNat kernelRows
49 , KnownNat kernelColumns
59 , KnownNat kernelColumns
@@ -56,26 +66,29 @@ instance ( KnownNat kernelRows
56 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
66 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
57 , ((outputColumns - 1) * strideColumns) ~ (inputColumns - kernelColumns)
67 , ((outputColumns - 1) * strideColumns) ~ (inputColumns - kernelColumns)
58 ) => Layer (Pooling kernelRows kernelColumns strideRows strideColumns) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where
68 ) => Layer (Pooling kernelRows kernelColumns strideRows strideColumns) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where
69+ type Tape (Pooling kernelRows kernelColumns strideRows strideColumns) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = S ('D2 inputRows inputColumns)
59− runForwards Pooling (S2D' input) =
70+ runForwards Pooling (S2D input) =
71+ let height = fromIntegral $ natVal (Proxy :: Proxy inputRows)
72+ width = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
60− let kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
73+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
61 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)
74 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)
62 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
75 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
63 sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)
76 sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)
64− ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
65− oy = fromIntegral $ natVal (Proxy :: Proxy outputColumns)
66 ex = extract input
77 ex = extract input
67− r = poolForward kx ky sx sy ox oy $ ex
78+ r = poolForward 1 height width kx ky sx sy ex
68 rs = fromJust . create $ r
79 rs = fromJust . create $ r
69− in S2D' $ rs
80+ in (S2D input, S2D rs)
70− runBackwards Pooling (S2D' input) (S2D' dEdy) =
81+ runBackwards Pooling (S2D input) (S2D dEdy) =
82+ let height = fromIntegral $ natVal (Proxy :: Proxy inputRows)
83+ width = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
71− let kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
84+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
72 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)
85 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)
73 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
86 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
74 sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)
87 sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)
75 ex = extract input
88 ex = extract input
76 eo = extract dEdy
89 eo = extract dEdy
77− vs = poolBackward kx ky sx sy ex eo
90+ vs = poolBackward 1 height width kx ky sx sy ex eo
78− in ((), S2D' . fromJust . create $ vs)
91+ in ((), S2D . fromJust . create $ vs)
79
92
80
93
81-- | A three dimensional image can be pooled on each layer.
94-- | A three dimensional image can be pooled on each layer.
@@ -87,31 +100,33 @@ instance ( KnownNat kernelRows
87 , KnownNat inputColumns
100 , KnownNat inputColumns
88 , KnownNat outputRows
101 , KnownNat outputRows
89 , KnownNat outputColumns
102 , KnownNat outputColumns
103+ , KnownNat channels
104+ , KnownNat (outputRows * channels)
90 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
105 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
91 , ((outputColumns - 1) * strideColumns) ~ (inputColumns - kernelColumns)
106 , ((outputColumns - 1) * strideColumns) ~ (inputColumns - kernelColumns)
92 ) => Layer (Pooling kernelRows kernelColumns strideRows strideColumns) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where
107 ) => Layer (Pooling kernelRows kernelColumns strideRows strideColumns) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where
108+ type Tape (Pooling kernelRows kernelColumns strideRows strideColumns) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) = S ('D3 inputRows inputColumns channels)
93− runForwards Pooling (S3D' input) =
109+ runForwards Pooling (S3D input) =
94 let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
110 let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
95 iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
111 iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
96 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
112 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
97 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)
113 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)
98 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
114 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
99 sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)
115 sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)
100− ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
101− oy = fromIntegral $ natVal (Proxy :: Proxy outputColumns)
116+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)
102− ex = fmap extract input
117+ ex = extract input
103− r = poolForwardList kx ky sx sy ix iy ox oy ex
118+ r = poolForward ch ix iy kx ky sx sy ex
104− rs = fmap (fromJust . create) r
119+ rs = fromJust . create $ r
105− in S3D' rs
120+ in (S3D input, S3D rs)
106− runBackwards Pooling (S3D' input) (S3D' dEdy) =
121+ runBackwards Pooling (S3D input) (S3D dEdy) =
107 let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
122 let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
108 iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
123 iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
109 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
124 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
110 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)
125 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)
111 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
126 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
112 sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)
127 sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)
128+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)
113− ex = fmap extract input
129+ ex = extract input
114− eo = fmap extract dEdy
130+ eo = extract dEdy
115− ez = vectorZip (,) ex eo
131+ vs = poolBackward ch ix iy kx ky sx sy ex eo
116− vs = poolBackwardList kx ky sx sy ix iy ez
117− in ((), S3D' . fmap (fromJust . create) $ vs)
132+ in ((), S3D . fromJust . create $ vs)
src/Grenade/Layers/Relu.hs+27−12
@@ -1,18 +1,22 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE TypeOperators #-}
2{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE FlexibleInstances #-}
5+{-|
7−
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+-}
8module Grenade.Layers.Relu (
12module Grenade.Layers.Relu (
9 Relu (..)
13 Relu (..)
10 ) where
14 ) where
11
15
16+import Data.Serialize
17+
12import GHC.TypeLits
18import GHC.TypeLits
13−import Grenade.Core.Vector
19+import Grenade.Core
14−import Grenade.Core.Network
15−import Grenade.Core.Shape
16
20
17import qualified Numeric.LinearAlgebra.Static as LAS
21import qualified Numeric.LinearAlgebra.Static as LAS
18
22
@@ -27,26 +31,37 @@ instance UpdateLayer Relu where
27 runUpdate _ _ _ = Relu
31 runUpdate _ _ _ = Relu
28 createRandom = return Relu
32 createRandom = return Relu
29
33
34+instance Serialize Relu where
35+ put _ = return ()
36+ get = return Relu
37+
30instance ( KnownNat i) => Layer Relu ('D1 i) ('D1 i) where
38instance ( KnownNat i) => Layer Relu ('D1 i) ('D1 i) where
39+ type Tape Relu ('D1 i) ('D1 i) = S ('D1 i)
40+
31− runForwards _ (S1D' y) = S1D' (relu y)
41+ runForwards _ (S1D y) = (S1D y, S1D (relu y))
32 where
42 where
33 relu = LAS.dvmap (\a -> if a <= 0 then 0 else a)
43 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))
35 where
45 where
36 relu' = LAS.dvmap (\a -> if a <= 0 then 0 else 1)
46 relu' = LAS.dvmap (\a -> if a <= 0 then 0 else 1)
37
47
38instance (KnownNat i, KnownNat j) => Layer Relu ('D2 i j) ('D2 i j) where
48instance (KnownNat i, KnownNat j) => Layer Relu ('D2 i j) ('D2 i j) where
49+ type Tape Relu ('D2 i j) ('D2 i j) = S ('D2 i j)
50+
39− runForwards _ (S2D' y) = S2D' (relu y)
51+ runForwards _ (S2D y) = (S2D y, S2D (relu y))
40 where
52 where
41 relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)
53 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))
43 where
55 where
44 relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)
56 relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)
45
57
46instance (KnownNat i, KnownNat j, KnownNat k) => Layer Relu ('D3 i j k) ('D3 i j k) where
58instance (KnownNat i, KnownNat j, KnownNat k) => Layer Relu ('D3 i j k) ('D3 i j k) where
59+
60+ type Tape Relu ('D3 i j k) ('D3 i j k) = S ('D3 i j k)
61+
47− runForwards _ (S3D' y) = S3D' (fmap relu y)
62+ runForwards _ (S3D y) = (S3D y, S3D (relu y))
48 where
63 where
49 relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)
64 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))
51 where
66 where
52 relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)
67 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 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE TypeOperators #-}
4−{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE FlexibleInstances #-}
2{-# 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+-}
8module Grenade.Layers.Tanh (
13module Grenade.Layers.Tanh (
9 Tanh (..)
14 Tanh (..)
10 ) where
15 ) where
11
16
12−import GHC.TypeLits
17+import Data.Serialize
13−import Grenade.Core.Vector
18+import Data.Singletons
14−import Grenade.Core.Network
19+
15−import Grenade.Core.Shape
20+import Grenade.Core
16
21
17-- | A Tanh layer.
22-- | 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.
19data Tanh = Tanh
24data Tanh = Tanh
20 deriving Show
25 deriving Show
21
26
@@ -24,17 +29,14 @@ instance UpdateLayer Tanh where
24 runUpdate _ _ _ = Tanh
29 runUpdate _ _ _ = Tanh
25 createRandom = return Tanh
30 createRandom = return Tanh
26
31
27−instance KnownNat i => Layer Tanh ('D1 i) ('D1 i) where
32+instance Serialize Tanh where
28− runForwards _ (S1D' y) = S1D' (tanh y)
33+ put _ = return ()
29− runBackwards _ (S1D' y) (S1D' dEdy) = ((), S1D' (tanh' y * dEdy))
34+ get = return Tanh
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))
34
35
35−instance (KnownNat i, KnownNat j, KnownNat k) => Layer Tanh ('D3 i j k) ('D3 i j k) where
36+instance (a ~ b, SingI a) => Layer Tanh a b where
37+ type Tape Tanh a b = S a
36− runForwards _ (S3D' y) = S3D' (fmap tanh y)
38+ runForwards _ a = (a, tanh a)
37− runBackwards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> tanh' y' * dEdy') y dEdy))
39+ runBackwards _ a g = ((), tanh' a * g)
38
40
39tanh' :: (Floating a) => a -> a
41tanh' :: (Floating a) => a -> a
40tanh' t = 1 - s ^ (2 :: Int) where s = tanh t
42tanh' 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 CPP #-}
1−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE ConstraintKinds #-}
8+{-# LANGUAGE TypeOperators #-}
4{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
9{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
5module Test.Grenade.Layers.Convolution where
10module Test.Grenade.Layers.Convolution where
6
11
7−import Grenade.Core.Shape
12+import Unsafe.Coerce
8−import Grenade.Core.Vector as Grenade
13+import Data.Constraint
9−import Grenade.Core.Network
14+import Data.Proxy
10−import Grenade.Layers.Convolution
15+import Data.Singletons ()
11−import Grenade.Layers.Internal.Convolution
16+import GHC.TypeLits
12−
17+import GHC.TypeLits.Witnesses
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)
118
18
119− expect = [ HStatic.matrix
19+#if MIN_VERSION_base(4,9,0)
120− [ -3.0 , -4.0 ] :: HStatic.L 1 2
20+import Data.Kind (Type)
121− , HStatic.matrix
21+#endif
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)
128
22
129− grad = S3D' ( mkVector
23+import Grenade.Core
130− [ HStatic.matrix
24+import Grenade.Layers.Convolution
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)
247
25
248− expectBack = (HStatic.matrix
26+import Hedgehog
249− [ 1.0, 0.0, 0.0
27+import qualified Hedgehog.Gen as Gen
250− , 0.0, -2.0,-1.0] :: HStatic.L 2 3)
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))
251− (nc, inX) = runBackwards convLayer input grad
103+ = runBackwards convLayer tape output
104+ in backed `seq` success
252
105
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)
258
106
259−return []
260tests :: IO Bool
107tests :: 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 CPP #-}
1−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TemplateHaskell #-}
2−{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE KindSignatures #-}
3−{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
4{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
7{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
5module Test.Grenade.Layers.Pooling where
8module Test.Grenade.Layers.Pooling where
6
9
7−import Grenade.Layers.Internal.Pooling
10+import Data.Proxy
11+import Data.Singletons ()
8
12
9−import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
13+#if MIN_VERSION_base(4,9,0)
14+import Data.Kind (Type)
15+#endif
10
16
11−import Test.QuickCheck hiding ((><))
17+import GHC.TypeLits
18+import Grenade.Layers.Pooling
12
19
13−prop_pool = once $
20+import Hedgehog
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
23
21
24−prop_pool_rectangular = once $
22+import Test.Hedgehog.Compat
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
34
23
35−prop_pool_backwards = once $
24+data OpaquePooling :: Type where
36− let input = (3><4)
25+ OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling
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
49
26
50−prop_pool_backwards_additive = once $
27+instance Show OpaquePooling where
51− let input = (3><4)
28+ show (OpaquePooling n) = show n
52− [ 4.0, 2.0, 3.0, 4.0
29+
53− , 0.0, 0.0, 7.0, 8.0
30+genOpaquePooling :: Gen OpaquePooling
54− , 9.0, 0.0, 0.0, 0.0 ]
31+genOpaquePooling = do
55− grads = (2><3)
32+ ~(Just kernelHeight) <- someNatVal <$> choose 2 15
56− [ -6.0, -7.0, -8.0
33+ ~(Just kernelWidth ) <- someNatVal <$> choose 2 15
57− , -10.0, -11.0, -12.0 ]
34+ ~(Just strideHeight) <- someNatVal <$> choose 2 15
58− expected = (3><4)
35+ ~(Just strideWidth ) <- someNatVal <$> choose 2 15
59− [-6.0, 0.0, 0.0, 0.0
36+
60− , 0.0, 0.0,-18.0,-20.0
37+ case (kernelHeight, kernelWidth, strideHeight, strideWidth) of
61− ,-10.0, 0.0, 0.0, 0.0 ]
38+ (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->
62− out = poolBackward 2 2 1 1 input grads
39+ return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)
63− in expected === out
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
64
47
65−return []
66tests :: IO Bool
48tests :: 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
2
2
3−import qualified Test.Grenade.Layers.Pooling as Test.Grenade.Layers.Pooling
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+
4−import qualified Test.Grenade.Layers.Convolution as Test.Grenade.Layers.Convolution
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
5
18
6main :: IO ()
19main :: IO ()
7main =
20main =
8 disorderMain [
21 disorderMain [
22+ Test.Grenade.Network.tests
23+
9− Test.Grenade.Layers.Pooling.tests
24+ , Test.Grenade.Layers.Pooling.tests
10 , Test.Grenade.Layers.Convolution.tests
25 , 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+
11 ]
35 ]
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