master..32f3e31 · grenade

.gitignore+1−3

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

1−cabal.project.local

21.cabal-sandbox/

32cabal.sandbox.config

43dist/

5−dist-newstyle/

6−.stack-work/

4+

.gitmodulesnew file+15

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

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.ymldeleted−31

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

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

2−

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

4−env:

5− - GHCVER=8.0.2

6− - GHCVER=8.2.2

7− - GHCVER=8.4.4

8− - GHCVER=8.6.5

9− - GHCVER=8.8.3

10− - GHCVER=8.10.1

11−

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

13−before_install:

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

15− - travis_retry sudo apt-get update

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

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

18−

19−install:

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

21− - travis_retry cabal-3.2 update

22−

23−notifications:

24− email: false

25−

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

27−script:

28− - cabal-3.2 configure --enable-tests

29− - cabal-3.2 build all

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

31−

LICENSE+1−1

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

22All rights reserved.

33

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

README.md+10−72

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

11Grenade

22=======

33

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

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

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

7−

8−

94```

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

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

@@ -15,20 +10,14 @@ Five is right out.

1510

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

1712

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

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

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

2015

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

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

2318```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]

19+type MNIST = 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]

20+ '[ '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]

3221

3322randomMnist :: MonadRandom m => m MNIST

3423randomMnist = randomNetwork

@@ -42,10 +31,8 @@ If recurrent neural networks are more your style, you can try defining something

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

4332with

4433```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 ]

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

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

4936```

5037

5138Design

@@ -58,13 +45,8 @@ data that are passed between the layers.

5845The definition of a network is surprisingly simple:

5946```haskell

6047data 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)

48+ O :: (SingI i, SingI o, Layer x i o) => !x -> Network '[x] '[i, o]

49+ (:~>) :: (SingI i, SingI h, Layer x i h) => !x -> !(Network xs (h ': hs)) -> Network (x ': xs) (i ': h ': hs)

6850```

6951

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

@@ -89,7 +71,7 @@ backPropagate :: forall shapes layers.

8971```

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

9173back 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

74+appropriate for each layer, and may be trivial for layers like `Rulu` which

9375have no learnable parameters.

9476

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

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

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

10486it will result in a compile time error.

10587

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.

144−

14588Build Instructions

14689------------------

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

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

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

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

15093build using:

@@ -159,7 +102,7 @@ and the tests run using:

159102./mafia test

160103```

161104

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

105+Grenade is currently known to build with ghc 7.10 and 8.0.

163106

164107Thanks

165108------

@@ -185,8 +128,3 @@ core took around 12 minutes, achieving 1.5% error rate on a 1000 sample holdout

185128Contributing

186129------------

187130Contributions 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.ymldeleted−1

@@ -1 +0,0 @@

1−theme: jekyll-theme-minimal

bench/bench-lstm.hs+48−6

@@ -5,26 +5,68 @@ import Criterion.Main

55

66import Grenade

77import Grenade.Recurrent

8+import Grenade.Layers.Internal.Update

9+

10+import qualified Numeric.LinearAlgebra.Static as H

811

912main :: IO ()

1013main = do

14+ layer60 :: LSTM 40 60 <- createRandom

15+ layer512 :: LSTM 40 512 <- createRandom

1116 input40 :: S ('D1 40) <- randomOfShape

12− lstm :: RecNet <- randomRecurrent

17+ rec60 :: S ('D1 60) <- randomOfShape

18+ rec512 :: S ('D1 512) <- randomOfShape

19+ (lstm, lstm') :: (RecNet, RecInput) <- randomRecurrent

20+

21+ let upIn60 :: H.R 3600 = H.randomVector 1 H.Uniform * 2 - 1

22+ let upIn512 :: H.R 262144 = H.randomVector 1 H.Uniform * 2 - 1

1323

1424 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)

25+ bgroup "lstm" [ bench "forwards-60" $ nf (nfT2 . uncurry (testRun60 layer60)) (rec60, input40)

26+ , bench "forwards-512" $ nf (nfT2 . uncurry (testRun512 layer512)) (rec512, input40)

27+ , bench "backwards-60" $ nf (nfT3 . uncurry4 (testRun60' layer60)) (rec60, input40, rec60, rec60)

28+ , bench "backwards-512" $ nf (nfT3 . uncurry4 (testRun512' layer512)) (rec512, input40, rec512, rec512)

29+ ]

30+ , bgroup "update" [ bench "matrix-60x60" $ nf (uncurry3 (decendVector 1 1 1)) (upIn60, upIn60, upIn60)

31+ , bench "matrix-512x512" $ nf (uncurry3 (decendVector 1 1 1)) (upIn512, upIn512, upIn512)

32+ ]

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

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

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

1836 ]

1937 ]

2038

39+testRun60 :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> (S ('D1 60), S ('D1 60))

40+testRun60 = runRecurrentForwards

41+

42+testRun60' :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> S ('D1 60) -> S ('D1 60) -> (Gradient (LSTM 40 60), S ('D1 60), S ('D1 40))

43+testRun60' = runRecurrentBackwards

44+

45+testRun512 :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> (S ('D1 512), S ('D1 512))

46+testRun512 = runRecurrentForwards

47+

48+testRun512' :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> S ('D1 512) -> S ('D1 512) -> (Gradient (LSTM 40 512), S ('D1 512), S ('D1 40))

49+testRun512' = runRecurrentBackwards

50+

51+uncurry4 :: (t -> t1 -> t2 -> t3 -> t4) -> (t, t1, t2, t3) -> t4

52+uncurry4 f (a,b,c,d) = f a b c d

53+

54+uncurry3 :: (t -> t1 -> t2 -> t3) -> (t, t1, t2) -> t3

55+uncurry3 f (a,b,c) = f a b c

56+

2157nfT2 :: (a, b) -> (a, b)

2258nfT2 (!a, !b) = (a, b)

2359

60+nfT3 :: (a, b, c) -> (b, c)

61+nfT3 (!_, !b, !c) = (b, c)

62+

2463

64+type F = FeedForward

2565type R = Recurrent

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

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

66+type RecNet = RecurrentNetwork '[ R (LSTM 40 512), R (LSTM 512 40), F (FullyConnected 40 40), F Logit]

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

68+

69+type RecInput = RecurrentInputs '[ R (LSTM 40 512), R (LSTM 512 40), F (FullyConnected 40 40), F Logit]

2870

2971lp :: LearningParameters

3072lp = LearningParameters 0.1 0 0

bench/bench.hs+18−47

@@ -1,55 +1,26 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

31import Criterion.Main

42

5−import Grenade

6−

73import Grenade.Layers.Internal.Convolution

84import Grenade.Layers.Internal.Pooling

95

106import Numeric.LinearAlgebra

117

128main :: 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−(...) = (.) . (.)

9+main = defaultMain [

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

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

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

13+ ]

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

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

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

17+ ]

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

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

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

21+ ]

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

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

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

25+ ]

26+ ]

cbits/gradient_descent.c → cbits/gradient_decent.crenamed+3−3

@@ -1,12 +1,12 @@

1−#include "gradient_descent.h"

1+#include "gradient_decent.h"

22

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

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

44 const double* weights,

55 const double* gradient,

66 const double* last,

77 double* outputWeights, double* outputMomentum) {

88

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

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

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

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

1212 }

cbits/gradient_descent.h → cbits/gradient_decent.hrenamed+1−1

@@ -1,7 +1,7 @@

11#include <stdio.h>

22#include <stdint.h>

33

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

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

55 const double* weights,

66 const double* gradient,

77 const double* last,

cbits/pad.cdeleted−39

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

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.hdeleted−13

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

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/LICENSEdeleted−10

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

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.cabaldeleted−109

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

1−name: grenade-examples

2−version: 0.0.1

3−license: BSD2

4−license-file: LICENSE

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

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

8−synopsis: grenade-examples

9−category: System

10−cabal-version: >= 1.8

11−build-type: Simple

12−description: grenade-examples

13−

14−source-repository head

15− type: git

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

17−

18−library

19−

20−executable feedforward

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

22− main-is: main/feedforward.hs

23− build-depends: base

24− , grenade

25− , attoparsec

26− , bytestring

27− , cereal

28− , either

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

30− , text == 1.2.*

31− , mtl >= 2.2.1 && < 2.3

32− , hmatrix

33− , transformers

34− , singletons

35− , semigroups

36− , MonadRandom

37−

38−executable mnist

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

40− main-is: main/mnist.hs

41− build-depends: base

42− , grenade

43− , attoparsec

44− , either

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

46− , text == 1.2.*

47− , mtl >= 2.2.1 && < 2.3

48− , hmatrix >= 0.18 && < 0.21

49− , transformers

50− , semigroups

51− , singletons

52− , MonadRandom

53− , vector

54−

55−executable gan-mnist

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

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

58− build-depends: base

59− , grenade

60− , attoparsec

61− , bytestring

62− , cereal

63− , either

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

65− , text == 1.2.*

66− , mtl >= 2.2.1 && < 2.3

67− , hmatrix >= 0.18 && < 0.21

68− , transformers

69− , semigroups

70− , singletons

71− , MonadRandom

72− , vector

73−

74−executable recurrent

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

76− main-is: main/recurrent.hs

77− build-depends: base

78− , grenade

79− , attoparsec

80− , either

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

82− , text == 1.2.*

83− , mtl >= 2.2.1 && < 2.3

84− , hmatrix >= 0.18 && < 0.21

85− , transformers

86− , semigroups

87− , singletons

88− , MonadRandom

89−

90−executable shakespeare

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

92− main-is: main/shakespeare.hs

93− build-depends: base

94− , grenade

95− , attoparsec

96− , bytestring

97− , cereal

98− , either

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

100− , text == 1.2.*

101− , mtl >= 2.2.1 && < 2.3

102− , hmatrix >= 0.18 && < 0.21

103− , transformers

104− , semigroups

105− , singletons

106− , singletons-base

107− , vector

108− , MonadRandom

109− , containers

examples/mafiadeleted−62

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

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/gan-mnist.hsdeleted−185

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

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

framework/mafiadeleted−62

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

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+117−118

@@ -1,179 +1,182 @@

11name: grenade

2−version: 0.1.0

2+version: 0.0.1

33license: BSD2

4−license-file: LICENSE

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

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

8−synopsis: Practical Deep Learning in Haskell

9−category: AI, Machine Learning

10−cabal-version: >= 1.10

7+synopsis: grenade

8+category: System

9+cabal-version: >= 1.8

1110build-type: Simple

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>.

11+description: grenade.

2412

2513extra-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

14+ cbits/im2col.h

15+ cbits/im2col.c

3716

3817library

3918 build-depends:

4019 base >= 4.8 && < 5

41− , bytestring >= 0.10.0

42− , containers >= 0.5 && < 0.7

43− , cereal >= 0.5 && < 0.6

44− , deepseq >= 1.4 && < 1.5

45− , hmatrix >= 0.18 && < 0.21

46− , MonadRandom >= 0.4 && < 0.6

47− , primitive >= 0.6 && < 0.8

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

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

20+ , bytestring == 0.10.*

21+ , async

22+ , containers

23+ , deepseq

24+ , either == 4.4.*

25+ , cereal

26+ , exceptions == 0.8.*

27+ , hmatrix

28+ , MonadRandom

29+ , mtl >= 2.2.1 && < 2.3

30+ , parallel == 3.2.*

31+ , primitive

32+ , reflection

33+ , text == 1.2.*

34+ , transformers

5035 , singletons

51− , singletons-base

52− , vector >= 0.11 && < 0.13

36+ , vector

5337

5438 ghc-options:

5539 -Wall

5640 hs-source-dirs:

5741 src

5842

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

6743

6844 exposed-modules:

6945 Grenade

70− Grenade.Core

71− Grenade.Core.Layer

72− Grenade.Core.LearningParameters

7346 Grenade.Core.Network

7447 Grenade.Core.Runner

7548 Grenade.Core.Shape

76−

77− Grenade.Layers

78− Grenade.Layers.Concat

79− Grenade.Layers.Convolution

8049 Grenade.Layers.Crop

81− Grenade.Layers.Deconvolution

50+ Grenade.Layers.Convolution

8251 Grenade.Layers.Dropout

83− Grenade.Layers.Elu

8452 Grenade.Layers.FullyConnected

85− Grenade.Layers.Inception

53+ Grenade.Layers.Flatten

54+ Grenade.Layers.Fuse

8655 Grenade.Layers.Logit

87− Grenade.Layers.Merge

88− Grenade.Layers.Pad

89− Grenade.Layers.Pooling

9056 Grenade.Layers.Relu

91− Grenade.Layers.Reshape

92− Grenade.Layers.Sinusoid

93− Grenade.Layers.Softmax

57+ Grenade.Layers.Elu

9458 Grenade.Layers.Tanh

95− Grenade.Layers.Trivial

59+ Grenade.Layers.Pad

60+ Grenade.Layers.Pooling

9661

9762 Grenade.Layers.Internal.Convolution

98− Grenade.Layers.Internal.Pad

9963 Grenade.Layers.Internal.Pooling

10064 Grenade.Layers.Internal.Update

10165

10266 Grenade.Recurrent

10367

104− Grenade.Recurrent.Core

105− Grenade.Recurrent.Core.Layer

10668 Grenade.Recurrent.Core.Network

10769 Grenade.Recurrent.Core.Runner

10870

109− Grenade.Recurrent.Layers

11071 Grenade.Recurrent.Layers.BasicRecurrent

111− Grenade.Recurrent.Layers.ConcatRecurrent

11272 Grenade.Recurrent.Layers.LSTM

73+ Grenade.Recurrent.Layers.Trivial

11374

11475 Grenade.Utils.OneHot

11576

116− includes: cbits/im2col.h

117− cbits/gradient_descent.h

118− cbits/pad.h

119− c-sources: cbits/im2col.c

120− cbits/gradient_descent.c

121− cbits/pad.c

77+ includes: cbits/im2col.h

78+ cbits/gradient_decent.h

79+ c-sources: cbits/im2col.c

80+ cbits/gradient_decent.c

12281

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

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

12483

125−test-suite test

126− type: exitcode-stdio-1.0

84+executable feedforward

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

86+ main-is: main/feedforward.hs

87+ build-depends: base

88+ , grenade

89+ , attoparsec

90+ , bytestring

91+ , cereal

92+ , either

93+ , optparse-applicative == 0.12.*

94+ , text == 1.2.*

95+ , mtl >= 2.2.1 && < 2.3

96+ , hmatrix

97+ , transformers

98+ , singletons

99+ , MonadRandom

127100

128− main-is: test.hs

101+executable mnist

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

103+ main-is: main/mnist.hs

104+ build-depends: base

105+ , grenade

106+ , attoparsec

107+ , either

108+ , optparse-applicative == 0.12.*

109+ , text == 1.2.*

110+ , mtl >= 2.2.1 && < 2.3

111+ , hmatrix >= 0.18 && < 0.19

112+ , transformers

113+ , singletons

114+ , MonadRandom

115+ , vector

129116

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

117+executable recurrent

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

119+ main-is: main/recurrent.hs

120+ build-depends: base

121+ , grenade

122+ , attoparsec

123+ , either

124+ , optparse-applicative == 0.12.*

125+ , text == 1.2.*

126+ , mtl >= 2.2.1 && < 2.3

127+ , hmatrix >= 0.18 && < 0.19

128+ , transformers

129+ , singletons

130+ , MonadRandom

131131

132− hs-source-dirs:

133− test

134132

135− default-language: Haskell2010

133+executable shakespeare

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

135+ main-is: main/shakespeare.hs

136+ build-depends: base

137+ , grenade

138+ , attoparsec

139+ , bytestring

140+ , cereal

141+ , either

142+ , optparse-applicative == 0.12.*

143+ , text == 1.2.*

144+ , mtl >= 2.2.1 && < 2.3

145+ , hmatrix >= 0.18 && < 0.19

146+ , transformers

147+ , singletons

148+ , vector

149+ , MonadRandom

150+ , containers

136151

137− other-modules: Test.Hedgehog.Compat

138− Test.Hedgehog.Hmatrix

139− Test.Hedgehog.TypeLits

140152

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

153+test-suite test

154+ type: exitcode-stdio-1.0

150155

151− Test.Grenade.Recurrent.Layers.LSTM

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

156+ main-is: test.hs

153157

154− if impl(ghc < 8.0)

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

156− cpp-options: -DType=*

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

157159

158− if impl(ghc >= 8.6)

159− default-extensions: NoStarIsType

160+ hs-source-dirs:

161+ test

160162

161163 build-depends:

162− base

164+ base >= 4.8 && < 5

163165 , grenade

164− , hedgehog >= 1.0 && < 1.1

166+ , ambiata-disorder-core

167+ , ambiata-disorder-jack

165168 , hmatrix

166169 , mtl

167170 , singletons

168171 , text == 1.2.*

169− , typelits-witnesses < 0.4

170− , transformers

172+ , typelits-witnesses

171173 , constraints

174+ , QuickCheck >= 2.7 && < 2.9

175+ , quickcheck-instances == 0.3.*

172176 , MonadRandom

173177 , random

174178 , ad

175179 , reflection

176− , vector

177180

178181

179182benchmark bench

@@ -186,12 +189,10 @@ benchmark bench

186189 hs-source-dirs:

187190 bench

188191

189− default-language: Haskell2010

190−

191192 build-depends:

192− base

193− , bytestring

194− , criterion >= 1.1 && < 1.6

193+ base >= 3 && < 5

194+ , bytestring == 0.10.*

195+ , criterion == 1.1.*

195196 , grenade

196197 , hmatrix

197198

@@ -205,11 +206,9 @@ benchmark bench-lstm

205206 hs-source-dirs:

206207 bench

207208

208− default-language: Haskell2010

209−

210209 build-depends:

211− base

212− , bytestring

213− , criterion

210+ base >= 3 && < 5

211+ , bytestring == 0.10.*

212+ , criterion == 1.1.*

214213 , grenade

215214 , hmatrix

lib/disorder.hsnew file+1

Submodule changed.

lib/pnew file+1

Submodule changed.

mafiamode 120000 → 100755+123−1

@@ -1 +0,0 @@

1−framework/mafia

@@ -0,0 +1,123 @@

1+#!/bin/sh -eu

2+

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

4+

5+fetch_latest () {

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

7+ TZ=$(date +"%T")

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

9+ else

10+ cat ../script/mafia

11+ fi

12+}

13+

14+latest_version () {

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

16+}

17+

18+local_version () {

19+ awk '/^# Version: / { print $3; exit 0; }' $0

20+}

21+

22+run_upgrade () {

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

24+

25+ clean_up () {

26+ rm -f "$MAFIA_TEMP"

27+ }

28+

29+ trap clean_up EXIT

30+

31+ MAFIA_CUR="$0"

32+

33+ if [ -L "$MAFIA_CUR" ]; then

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

35+ exit 1

36+ fi

37+

38+ echo "Checking for a new version of mafia ..."

39+ fetch_latest > $MAFIA_TEMP

40+

41+ LATEST_VERSION=$(latest_version)

42+ echo "# Version: $LATEST_VERSION" >> $MAFIA_TEMP

43+

44+ if ! cmp $MAFIA_CUR $MAFIA_TEMP >/dev/null 2>&1; then

45+ mv $MAFIA_TEMP $MAFIA_CUR

46+ chmod +x $MAFIA_CUR

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

48+ else

49+ echo "You have latest mafia."

50+ fi

51+}

52+

53+exec_mafia () {

54+ MAFIA_VERSION=$(local_version)

55+

56+ if [ "x$MAFIA_VERSION" = "x" ]; then

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

58+ run_upgrade

59+ else

60+ MAFIA_BIN=$MAFIA_HOME/bin

61+ MAFIA_FILE=mafia-$MAFIA_VERSION

62+ MAFIA_PATH=$MAFIA_BIN/$MAFIA_FILE

63+

64+ [ -f "$MAFIA_PATH" ] || {

65+ # Create a temporary directory which will be deleted when the script

66+ # terminates. Unfortunately `mktemp` doesn't behave the same on

67+ # Linux and OS/X so we need to try two different approaches.

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

69+

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

71+ mkdir -p $MAFIA_BIN

72+

73+ clean_up () {

74+ rm -rf "$MAFIA_TEMP"

75+ }

76+

77+ trap clean_up EXIT

78+

79+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

80+

81+ ( cd "$MAFIA_TEMP"

82+

83+ git clone https://github.com/ambiata/mafia

84+ cd mafia

85+

86+ git reset --hard $MAFIA_VERSION

87+

88+ bin/bootstrap ) || exit $?

89+

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

91+

92+ clean_up_temp () {

93+ clean_up

94+ rm -f "$MAFIA_PATH_TEMP"

95+ }

96+ trap clean_up_temp EXIT

97+

98+ cp "$MAFIA_TEMP/mafia/.cabal-sandbox/bin/mafia" "$MAFIA_PATH_TEMP"

99+ chmod 755 "$MAFIA_PATH_TEMP"

100+ mv "$MAFIA_PATH_TEMP" "$MAFIA_PATH"

101+

102+ clean_up_temp

103+ }

104+

105+ exec $MAFIA_PATH "$@"

106+ fi

107+}

108+

109+#

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

111+#

112+

113+if [ $# -gt 0 ]; then

114+ MODE="$1"

115+else

116+ MODE=""

117+fi

118+

119+case "$MODE" in

120+upgrade) shift; run_upgrade "$@" ;;

121+*) exec_mafia "$@"

122+esac

123+# Version: 360716306a06db842ec022a7b9f161d2208483f0

examples/main/feedforward.hs → main/feedforward.hsrenamed+1−4

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE ScopedTypeVariables #-}

54{-# LANGUAGE TypeOperators #-}

@@ -11,9 +10,7 @@ import Data.List ( foldl' )

1110

1211import qualified Data.ByteString as B

1312import Data.Serialize

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

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

16−#endif

13+

1714import GHC.TypeLits

1815

1916import qualified Numeric.LinearAlgebra.Static as SA

examples/main/mnist.hs → main/mnist.hsrenamed+2−30

@@ -1,12 +1,10 @@

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE ScopedTypeVariables #-}

54{-# LANGUAGE TypeOperators #-}

65{-# LANGUAGE TupleSections #-}

76{-# LANGUAGE TypeFamilies #-}

87{-# LANGUAGE FlexibleContexts #-}

9−

108import Control.Applicative

119import Control.Monad

1210import Control.Monad.Random

@@ -14,10 +12,6 @@ import Control.Monad.Trans.Except

1412

1513import qualified Data.Attoparsec.Text as A

1614import Data.List ( foldl' )

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

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

19−#endif

20−

2115import qualified Data.Text as T

2216import qualified Data.Text.IO as T

2317import qualified Data.Vector.Storable as V

@@ -30,15 +24,6 @@ import Options.Applicative

3024import Grenade

3125import Grenade.Utils.OneHot

3226

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 ]

41−

4227-- The definition of our convolutional neural network.

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

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

@@ -48,21 +33,8 @@ type FL i o =

4833

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

5035-- 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 ]

36+type MNIST = Network '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Elu, Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Elu, FlattenLayer, 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, 'D3 4 4 16, 'D1 256, 'D1 80, 'D1 80, 'D1 10, 'D1 10]

6638

6739randomMnist :: MonadRandom m => m MNIST

6840randomMnist = randomNetwork

examples/main/recurrent.hs → main/recurrent.hsrenamed+8−15

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE ScopedTypeVariables #-}

54{-# LANGUAGE TypeOperators #-}

@@ -9,13 +8,7 @@

98import Control.Monad ( foldM )

109import Control.Monad.Random ( MonadRandom, getRandomR )

1110

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

13−import Data.List ( unfoldr )

14−#else

1511import Data.List ( cycle, unfoldr )

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

17−#endif

18−

1912import qualified Numeric.LinearAlgebra.Static as SA

2013

2114import Options.Applicative

@@ -31,12 +24,12 @@ import Grenade.Recurrent

3124-- creation function know how to treat the layers.

3225type R = Recurrent

3326

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

35− '[ 'D1 1, 'D1 1]

27+type RecNet = RecurrentNetwork '[ R (LSTM 1 4), R (LSTM 4 1)]

28+ '[ 'D1 1, 'D1 4, 'D1 1 ]

3629

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

30+type RecInput = RecurrentInputs '[ R (LSTM 1 4), R (LSTM 4 1)]

3831

39−randomNet :: MonadRandom m => m RecNet

32+randomNet :: MonadRandom m => m (RecNet, RecInput)

4033randomNet = randomRecurrent

4134

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

@@ -69,8 +62,8 @@ generateRecurrent n s i =

6962 unfoldr go (s, i)

7063 where

7164 go (x, y) =

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

73− o' = heat o

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

66+ o' = heat o

7467 Just (o', (ns, fromIntegral o'))

7568

7669 heat :: S ('D1 1) -> Int

@@ -82,8 +75,8 @@ main = do

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

8376 putStrLn "Training network..."

8477

85− net0 <- randomNet

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

78+ (net0, i0) <- randomNet

79+ (trained, bestInput) <- netTest net0 i0 rate examples

8780

8881 let results = generateRecurrent trained bestInput (c 1)

8982

examples/main/shakespeare.hs → main/shakespeare.hsrenamed+22−26

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

2+{-# LANGUAGE RecordWildCards #-}

33{-# LANGUAGE DataKinds #-}

44{-# LANGUAGE ScopedTypeVariables #-}

55{-# LANGUAGE TypeOperators #-}

@@ -14,15 +14,16 @@ import Data.Char ( isUpper, toUpper, toLower )

1414import Data.List ( foldl' )

1515import Data.Maybe ( fromMaybe )

1616

17−

1817import qualified Data.Vector as V

1918import Data.Vector ( Vector )

2019

2120import qualified Data.Map as M

21+import Data.Proxy ( Proxy (..) )

2222

2323import qualified Data.ByteString as B

2424import Data.Serialize

2525

26+import Data.Singletons.Prelude

2627import GHC.TypeLits

2728

2829import Numeric.LinearAlgebra.Static ( konst )

@@ -34,16 +35,11 @@ import Grenade.Recurrent

3435import Grenade.Utils.OneHot

3536

3637import System.IO.Unsafe ( unsafeInterleaveIO )

37−import Data.Proxy

38−import Prelude.Singletons

3938

4039-- The defininition for our natural language recurrent network.

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

4241-- about an hour.

4342--

44−-- Grab the input from

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

46−--

4743-- This is a first class recurrent net.

4844--

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

@@ -64,7 +60,7 @@ type Shakespeare = RecurrentNetwork '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyC

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

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

6662

67−randomNet :: MonadRandom m => m Shakespeare

63+randomNet :: MonadRandom m => m (Shakespeare, Shakespearian)

6864randomNet = randomRecurrent

6965

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

@@ -72,40 +68,40 @@ loadShakespeare :: FilePath -> ExceptT String IO (Vector Int, M.Map Char Int, Ve

7268loadShakespeare path = do

7369 contents <- lift $ readFile path

7470 let annotated = annotateCapitals contents

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

71+ (m,cs) <- ExceptT . return . note "Couldn't fit data in hotMap" $ hotMap (Proxy :: Proxy 40) annotated

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

7773 return (V.fromList hot, m, cs)

7874

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

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

76+trainSlice !rate !net !recIns input offset size =

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

8278 in case reverse e of

8379 (o : l : xs) ->

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

85− in trainRecurrent lrate net recIns examples

81+ in trainRecurrent rate net recIns examples

8682 _ -> error "Not enough input"

8783 where

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

8985

9086runShakespeare :: ShakespeareOpts -> ExceptT String IO ()

91−runShakespeare opts = do

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

87+runShakespeare ShakespeareOpts {..} = do

88+ (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare trainingFile

9389 (net0, i0) <- lift $

94− case loadPath opts of

90+ case loadPath of

9591 Just loadFile -> netLoad loadFile

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

92+ Nothing -> randomNet

9793

9894 (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)

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

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

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

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

10399 putStrLn (unAnnotateCapitals results)

104100 return (trained, bestInput)

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

101+ ) (net0, i0) $ replicate 10 sequenceSize

106102

107− case savePath opts of

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

103+ case savePath of

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

109105 Nothing -> return ()

110106

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

@@ -116,14 +112,14 @@ generateParagraph :: forall layers shapes n a. (Last shapes ~ 'D1 n, Head shapes

116112 -> Vector a

117113 -> S ('D1 n)

118114 -> IO [a]

119−generateParagraph n s temp hotmap hotdict =

115+generateParagraph n s temperature hotmap hotdict =

120116 go s

121117 where

122118 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

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

120+ un <- sample temperature hotdict o

121+ Just re <- return $ makeHot hotmap un

122+ rest <- unsafeInterleaveIO $ go ns re

127123 return (un : rest)

128124

129125data ShakespeareOpts = ShakespeareOpts {

src/Grenade.hs+17−50

@@ -1,53 +1,20 @@

11module 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.

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−

2+ module X

203 ) where

214

22−import Grenade.Core

23−import Grenade.Layers

24−

25−{- $library

26−Grenade is a purely functional deep learning library.

27−

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

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

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

31−the hmatrix library.

32−

33−-}

34−

35−{- $example

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

37−under the examples folder.

38−

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

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

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

42−

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

44−>

45−> randomMyNet :: MonadRandom MyNet

46−> randomMyNet = randomNetwork

47−

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

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

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

51−-}

52−

53−

5+import Grenade.Core.Network as X

6+import Grenade.Core.Runner as X

7+import Grenade.Core.Shape as X

8+import Grenade.Layers.Crop as X

9+import Grenade.Layers.Dropout as X

10+import Grenade.Layers.Pad as X

11+import Grenade.Layers.Pooling as X

12+import Grenade.Layers.Flatten as X

13+import Grenade.Layers.Fuse as X

14+import Grenade.Layers.FullyConnected as X

15+import Grenade.Layers.Logit as X

16+import Grenade.Layers.Convolution as X

17+import Grenade.Layers.Relu as X

18+import Grenade.Layers.Elu as X

19+import Grenade.Layers.Tanh as X

20+import Grenade.Layers.Softmax as X

src/Grenade/Core.hsdeleted−13

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

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.hsdeleted−92

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

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.hsdeleted−21

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

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+73−143

@@ -1,8 +1,5 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE BangPatterns #-}

42{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

63{-# LANGUAGE TypeOperators #-}

74{-# LANGUAGE TypeFamilies #-}

85{-# LANGUAGE MultiParamTypeClasses #-}

@@ -10,57 +7,84 @@

107{-# LANGUAGE FlexibleInstances #-}

118{-|

129Module : Grenade.Core.Network

13−Description : Core definition of a Neural Network

10+Description : Core definition a simple neural etwork

1411Copyright : (c) Huw Campbell, 2016-2017

1512License : BSD2

1613Stability : experimental

1714

18−This module defines the core data types and functions

19−for non-recurrent neural networks.

20−-}

15+This module defines the core data type for the simplest

16+Neural network we support.

2117

18+-}

2219module Grenade.Core.Network (

23− Network (..)

20+ Layer (..)

21+ , Network (..)

22+ , UpdateLayer (..)

23+ , LearningParameters (..)

2424 , Gradients (..)

2525 , Tapes (..)

26−

27− , runNetwork

28− , runGradient

29− , applyUpdate

30−

31− , randomNetwork

26+ , CreatableNetwork (..)

3227 ) where

3328

34−import Control.Monad.Random ( MonadRandom )

35−

29+import Control.Monad.Random (MonadRandom)

30+import Data.List ( foldl' )

3631import Data.Singletons

37−import Data.Serialize

3832

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

40−import Data.Kind (Type)

41−#endif

33+import Data.Serialize

4234

43−import Grenade.Core.Layer

44−import Grenade.Core.LearningParameters

4535import Grenade.Core.Shape

46−import Prelude.Singletons

36+

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

38+data LearningParameters = LearningParameters {

39+ learningRate :: Double

40+ , learningMomentum :: Double

41+ , learningRegulariser :: Double

42+ } deriving (Eq, Show)

43+

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

45+-- shape independent.

46+class UpdateLayer x where

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

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

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

50+ type Gradient x :: *

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

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

53+

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

55+ createRandom :: MonadRandom m => m x

56+

57+ -- | Update a layer with many Gradients

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

59+ runUpdates rate = foldl' (runUpdate rate)

60+

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

62+-- need to implement it for all shapes, only ones which are appropriate.

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

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

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

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

67+ type Tape x i o :: *

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

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

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

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

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

73+ -- the layer above.

74+ -- Returns the gradient layer and the derivatives to push back further.

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

4776

4877-- | Type of a network.

4978--

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

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

5180--

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

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

5382--

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

5584-- transform the data shapes of the network.

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

57− NNil :: SingI i

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

59−

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

61− => !x

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

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

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

86+ NNil :: SingI i => Network '[] '[i]

87+ (:~>) :: (SingI i, SingI h, Layer x i h) => !x -> !(Network xs (h ': hs)) -> Network (x ': xs) (i ': h ': hs)

6488infixr 5 :~>

6589

6690instance Show (Network '[] '[i]) where

@@ -68,100 +92,22 @@ instance Show (Network '[] '[i]) where

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

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

7094

71−-- | Gradient of a network.

72−--

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

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

95+-- | Gradients of a network.

96+-- Parameterised on the layers of a Network.

97+data Gradients :: [*] -> * where

7598 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−

94−

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

96−--

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

98−-- propagation.

99−runNetwork :: forall layers shapes.

100− Network layers shapes

101− -> S (Head shapes)

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

103−runNetwork =

104− go

105− where

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

107− => Network ss js

108− -> S (Head js)

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

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

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

112− (tapes, answer) = go n forward

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

114−

115− go NNil !x

116− = (TNil, x)

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−

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

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

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

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

162− --

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

164− -- network is not sound.

99+ (:/>) :: UpdateLayer x => Gradient x -> Gradients xs -> Gradients (x ': xs)

100+

101+-- | Gradients of a network.

102+-- Parameterised on the layers of a Network.

103+data Tapes :: [*] -> [Shape] -> * where

104+ TNil :: SingI i => Tapes '[] '[i]

105+ (:\>) :: (SingI i, SingI h, Layer x i h) => !(Tape x i h) -> !(Tapes xs (h ': hs)) -> Tapes (x ': xs) (i ': h ': hs)

106+

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

108+-- network is with the randomNetwork.

109+class CreatableNetwork (xs :: [*]) (ss :: [Shape]) where

110+ -- | Create a network of the types requested

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

166112

167113instance SingI i => CreatableNetwork '[] '[i] where

@@ -170,6 +116,7 @@ instance SingI i => CreatableNetwork '[] '[i] where

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

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

172118

119+

173120-- | Add very simple serialisation to the network

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

175122 put NNil = pure ()

@@ -178,20 +125,3 @@ instance SingI i => Serialize (Network '[] '[i]) where

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

179126 put (x :~> r) = put x >> put r

180127 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+46−28

@@ -1,58 +1,76 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE GADTs #-}

13{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

37{-|

4−Module : Grenade.Core.Runner

5−Description : Functions to perform training and backpropagation

8+Module : Grenade.Core.Shape

9+Description : Core definition of the Shapes of data we understand

610Copyright : (c) Huw Campbell, 2016-2017

711License : BSD2

812Stability : experimental

13+

14+This module defines simple back propagation and training functions

15+for a network.

916-}

17+

18+-- GHC 7.10 doesn't think that go is complete

19+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

1020module Grenade.Core.Runner (

1121 train

1222 , backPropagate

1323 , runNet

24+ , applyUpdate

1425 ) where

1526

16−

17−import Grenade.Core.LearningParameters

27+import Data.Singletons.Prelude

1828import Grenade.Core.Network

1929import Grenade.Core.Shape

20−import Data.Singletons

21−import Prelude.Singletons

2230

2331-- | Perform reverse automatic differentiation on the network

2432-- for the current input and expected output.

2533--

2634-- /Note:/ The loss function pushed backwards is appropriate

2735-- for both regression and classification as a squared loss

28−-- or log-loss respectively.

29−--

30−-- For other loss functions, use runNetwork and runGradient

31−-- with the back propagated gradient of your loss.

32−--

33−backPropagate :: SingI (Last shapes)

34− => Network layers shapes

35− -> S (Head shapes)

36− -> S (Last shapes)

37− -> Gradients layers

36+-- or log-loss respectively. Other loss functions are not yet

37+-- implemented.

38+backPropagate :: forall shapes layers.

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

3840backPropagate network input target =

39− let (tapes, output) = runNetwork network input

40− (grads, _) = runGradient network tapes (output - target)

41− in grads

41+ fst $ go input network

42+ where

43+ go :: forall js sublayers. (Last js ~ Last shapes)

44+ => S (Head js) -- ^ input vector

45+ -> Network sublayers js -- ^ network to train

46+ -> (Gradients sublayers, S (Head js))

47+ -- handle input from the beginning, feeding upwards.

48+ go !x (layer :~> n)

49+ = let (tape, y) = runForwards layer x

50+ -- recursively run the rest of the network, and get the gradients from above.

51+ (n', dWs') = go y n

52+ -- calculate the gradient for this layer to pass down,

53+ (layer', dWs) = runBackwards layer tape dWs'

54+ in (layer' :/> n', dWs)

55+

56+ -- Bouncing the derivatives back down.

57+ go !x NNil

58+ = (GNil, x - target)

4259

60+-- | Apply one step of stochastic gradient decent across the network.

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

62+applyUpdate _ NNil GNil

63+ = NNil

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

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

4366

4467-- | Update a network with new weights after training with an instance.

45−train :: SingI (Last shapes)

46− => LearningParameters

47− -> Network layers shapes

48− -> S (Head shapes)

49− -> S (Last shapes)

50− -> Network layers shapes

68+train :: LearningParameters -> Network layers shapes -> S (Head shapes) -> S (Last shapes) -> Network layers shapes

5169train rate network input output =

5270 let grads = backPropagate network input output

5371 in applyUpdate rate network grads

5472

55−

5673-- | Run the network with input and return the given output.

5774runNet :: Network layers shapes -> S (Head shapes) -> S (Last shapes)

58−runNet net = snd . runNetwork net

75+runNet (layer :~> n) !x = let (_, y) = runForwards layer x in runNet n y

76+runNet NNil !x = x

src/Grenade/Core/Shape.hs+33−77

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE GADTs #-}

43{-# LANGUAGE KindSignatures #-}

@@ -8,33 +7,40 @@

87{-# LANGUAGE FlexibleContexts #-}

98{-# LANGUAGE ScopedTypeVariables #-}

109{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE UndecidableInstances #-}

10+

11+-- Ghc 8.0 gives a warning on `n2 _ _ = error ...` but ghc 7.10 fails to

12+-- compile without this default pattern.

13+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}

14+

1215{-|

1316Module : Grenade.Core.Shape

14−Description : Dependently typed shapes of data which are passed between layers of a network

17+Description : Core definition of the Shapes of data we understand

1518Copyright : (c) Huw Campbell, 2016-2017

1619License : BSD2

1720Stability : experimental

1821

19−

22+This module defines the core data types for the shapes of data that

23+are understood by Grenade.

2024-}

2125module Grenade.Core.Shape (

22− S (..)

23− , Shape (..)

24− , SShape (..)

26+ Shape (..)

27+ , S (..)

28+ , Sing (..)

2529 , randomOfShape

2630 , fromStorable

2731 ) where

2832

2933import Control.DeepSeq (NFData (..))

3034import Control.Monad.Random ( MonadRandom, getRandom )

31−import Data.Kind (Type)

35+

3236import Data.Proxy

33−import Data.Serialize

3437import Data.Singletons

38+import Data.Singletons.TypeLits

3539import Data.Vector.Storable ( Vector )

3640import qualified Data.Vector.Storable as V

41+

3742import GHC.TypeLits

43+

3844import qualified Numeric.LinearAlgebra.Static as H

3945import Numeric.LinearAlgebra.Static

4046import qualified Numeric.LinearAlgebra as NLA

@@ -42,35 +48,21 @@ import qualified Numeric.LinearAlgebra as NLA

4248-- | The current shapes we accept.

4349-- at the moment this is just one, two, and three dimensional

4450-- Vectors/Matricies.

45−--

46−-- These are only used with DataKinds, as Kind `Shape`, with Types 'D1, 'D2, 'D3.

4751data Shape

4852 = D1 Nat

49− -- ^ One dimensional vector

5053 | D2 Nat Nat

51− -- ^ Two dimensional matrix. Row, Column.

5254 | D3 Nat Nat Nat

53− -- ^ Three dimensional matrix. Row, Column, Channels.

5455

55−-- | Concrete data structures for a Shape.

56−--

56+-- | Given a Shape n, these are the possible data structures with that shape.

5757-- All shapes are held in contiguous memory.

5858-- 3D is held in a matrix (usually row oriented) which has height depth * rows.

5959data 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−

60+ S1D :: ( KnownNat o ) => R o -> S ('D1 o)

61+ S2D :: ( KnownNat rows, KnownNat columns ) => L rows columns -> S ('D2 rows columns)

6862 S3D :: ( KnownNat rows

6963 , KnownNat columns

7064 , KnownNat depth

71− , KnownNat (rows * depth))

72− => L (rows * depth) columns

73− -> S ('D3 rows columns depth)

65+ , KnownNat (rows * depth)) => L (rows * depth) columns -> S ('D3 rows columns depth)

7466

7567deriving instance Show (S n)

7668

@@ -79,20 +71,10 @@ deriving instance Show (S n)

7971-- These could probably be derived with template haskell, but this seems

8072-- clear and makes adding the KnownNat constraints simple.

8173-- 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

9174data 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

75+ D1Sing :: KnownNat a => Sing ('D1 a)

76+ D2Sing :: (KnownNat a, KnownNat b) => Sing ('D2 a b)

77+ D3Sing :: (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => Sing ('D3 a b c)

9678

9779instance KnownNat a => SingI ('D1 a) where

9880 sing = D1Sing

@@ -148,28 +130,18 @@ randomOfShape :: forall x m. ( MonadRandom m, SingI x ) => m (S x)

148130randomOfShape = do

149131 seed :: Int <- getRandom

150132 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)

133+ D1Sing -> S1D (randomVector seed Uniform * 2 - 1)

134+ D2Sing -> S2D (uniformSample seed (-1) 1)

135+ D3Sing -> S3D (uniformSample seed (-1) 1)

159136

160137-- | Generate a shape from a Storable Vector.

161138--

162139-- Returns Nothing if the vector is of the wrong size.

163140fromStorable :: forall x. SingI x => Vector Double -> Maybe (S x)

164141fromStorable 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

142+ D1Sing -> S1D <$> H.create xs

143+ D2Sing -> S2D <$> mkL xs

144+ D3Sing -> S3D <$> mkL xs

173145 where

174146 mkL :: forall rows columns. (KnownNat rows, KnownNat columns)

175147 => Vector Double -> Maybe (L rows columns)

@@ -180,18 +152,6 @@ fromStorable xs = case sing :: Sing x of

180152 then H.create $ NLA.reshape columns v

181153 else Nothing

182154

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−

195155-- Helper function for creating the number instances

196156n1 :: ( forall a. Floating a => a -> a ) -> S x -> S x

197157n1 f (S1D x) = S1D (f x)

@@ -203,15 +163,11 @@ n2 :: ( forall a. Floating a => a -> a -> a ) -> S x -> S x -> S x

203163n2 f (S1D x) (S1D y) = S1D (f x y)

204164n2 f (S2D x) (S2D y) = S2D (f x y)

205165n2 f (S3D x) (S3D y) = S3D (f x y)

166+n2 _ _ _ = error "Impossible to have different constructors for the same shaped network"

206167

207168-- Helper function for creating the number instances

208−nk :: forall x. (SingI x) => Double -> S x

169+nk :: forall x. SingI x => Double -> S x

209170nk x = case (sing :: Sing x) of

210− D1Sing ->

211− S1D (konst x)

212−

213− D2Sing ->

214− S2D (konst x)

215−

216− D3Sing ->

217− S3D (konst x)

171+ D1Sing -> S1D (konst x)

172+ D2Sing -> S2D (konst x)

173+ D3Sing -> S3D (konst x)

src/Grenade/Layers.hsdeleted−35

@@ -1,35 +0,0 @@

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.hsdeleted−139

@@ -1,139 +0,0 @@

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+64−90

@@ -1,23 +1,12 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE TypeOperators #-}

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE MultiParamTypeClasses #-}

88{-# LANGUAGE FlexibleInstances #-}

99{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE UndecidableInstances #-}

11−{-|

12−Module : Grenade.Layers.Convolution

13−Description : Convolution layer

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

15−License : BSD2

16−Stability : experimental

17−

18−This module provides the Convolution layer, which is critical in many computer vision tasks.

19−

20−-}

2110module Grenade.Layers.Convolution (

2211 Convolution (..)

2312 , Convolution' (..)

@@ -28,15 +17,16 @@ import Control.Monad.Random hiding ( fromList )

2817import Data.Maybe

2918import Data.Proxy

3019import Data.Serialize

20+import Data.Singletons.TypeLits

3121

3222import GHC.TypeLits

33−import Data.Kind (Type)

3423

3524import Numeric.LinearAlgebra hiding ( uniformSample, konst )

3625import qualified Numeric.LinearAlgebra as LA

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

3827

39−import Grenade.Core

28+import Grenade.Core.Network

29+import Grenade.Core.Shape

4030import Grenade.Layers.Internal.Convolution

4131import Grenade.Layers.Internal.Update

4232

@@ -57,7 +47,7 @@ data Convolution :: Nat -- Number of channels, for the first layer this could be

5747 -> Nat -- The number of column in the kernel filter

5848 -> Nat -- The row stride of the convolution filter

5949 -> Nat -- The columns stride of the convolution filter

60− -> Type where

50+ -> * where

6151 Convolution :: ( KnownNat channels

6252 , KnownNat filters

6353 , KnownNat kernelRows

@@ -76,7 +66,7 @@ data Convolution' :: Nat -- Number of channels, for the first layer this could b

7666 -> Nat -- The number of column in the kernel filter

7767 -> Nat -- The row stride of the convolution filter

7868 -> Nat -- The columns stride of the convolution filter

79− -> Type where

69+ -> * where

8070 Convolution' :: ( KnownNat channels

8171 , KnownNat filters

8272 , KnownNat kernelRows

@@ -130,9 +120,9 @@ instance ( KnownNat channels

130120 , KnownNat strideColumns

131121 , KnownNat (kernelRows * kernelColumns * channels)

132122 ) => UpdateLayer (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where

133− type Gradient (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Convolution' channels filters kernelRows kernelColumns strideRows strideColumns)

134− runUpdate lp (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =

135− let (newKernel, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldKernel kernelGradient oldMomentum

123+ type Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols) = (Convolution' channels filters kernelRows kernelCols strideRows strideCols)

124+ runUpdate LearningParameters {..} (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =

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

136126 in Convolution newKernel newMomentum

137127

138128 createRandom = randomConvolution

@@ -152,8 +142,7 @@ instance ( KnownNat channels

152142 let mm = konst 0

153143 return $ Convolution wN mm

154144

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

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

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

157146instance ( KnownNat kernelRows

158147 , KnownNat kernelCols

159148 , KnownNat filters

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

163152 , KnownNat inputCols

164153 , KnownNat outputRows

165154 , KnownNat outputCols

166− , KnownNat channels

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

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

169− , KnownNat (kernelRows * kernelCols * channels)

157+ , KnownNat (kernelRows * kernelCols * 1)

170158 , KnownNat (outputRows * filters)

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

172−

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

174−

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

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

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

161+ runForwards (Convolution kernel _) (S2D input) =

176162 let ex = extract input

177163 ek = extract kernel

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

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

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

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

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

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

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

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

186−

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

170+ c = im2col kx ky sx sy ex

188171 mt = c LA.<> ek

189172 r = col2vid 1 1 1 1 ox oy mt

190173 rs = fromJust . create $ r

191− in (S3D input, S3D rs)

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

174+ in (S2D input, S3D rs)

175+

176+ runBackwards (Convolution kernel _) (S2D input) (S3D dEdy) =

193177 let ex = extract input

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

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

@@ -200,7 +184,7 @@ instance ( KnownNat kernelRows

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

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

202186

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

187+ c = im2col kx ky sx sy ex

204188

205189 eo = extract dEdy

206190 ek = extract kernel

@@ -208,14 +192,14 @@ instance ( KnownNat kernelRows

208192 vs = vid2col 1 1 1 1 ox oy eo

209193

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

211−

212195 dW = vs LA.<> tr ek

213196

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

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

197+ xW = col2im kx ky sx sy ix iy dW

198+ in (Convolution' kN, S2D . fromJust . create $ xW)

216199

217200

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

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

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

219203instance ( KnownNat kernelRows

220204 , KnownNat kernelCols

221205 , KnownNat filters

@@ -225,63 +209,53 @@ instance ( KnownNat kernelRows

225209 , KnownNat inputCols

226210 , KnownNat outputRows

227211 , KnownNat outputCols

212+ , KnownNat channels

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

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

230− , KnownNat (kernelRows * kernelCols * 1)

215+ , KnownNat (kernelRows * kernelCols * channels)

231216 , KnownNat (outputRows * filters)

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

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

234− runForwards c (S2D input) =

235− runForwards c (S3D input :: S ('D3 inputRows inputCols 1))

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

236218

237− runBackwards c tape grads =

238− case runBackwards c tape grads of

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

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

240220

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

222+ let ex = extract input

223+ ek = extract kernel

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)

241232

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)

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

234+ mt = c LA.<> ek

235+ r = col2vid 1 1 1 1 ox oy mt

236+ rs = fromJust . create $ r

237+ in (S3D input, S3D rs)

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

239+ let ex = extract input

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

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

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

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

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

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

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

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

261248

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)

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

265250

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)

251+ eo = extract dEdy

252+ ek = extract kernel

285253

286− runBackwards c tape (S2D grads) =

287− runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1))

254+ vs = vid2col 1 1 1 1 ox oy eo

255+

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

257+

258+ dW = vs LA.<> tr ek

259+

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

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

src/Grenade/Layers/Crop.hs+6−67

@@ -1,32 +1,20 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE ScopedTypeVariables #-}

43{-# LANGUAGE GADTs #-}

54{-# LANGUAGE TypeOperators #-}

65{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE FlexibleContexts #-}

86{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE UndecidableInstances #-}

10−{-|

11−Module : Grenade.Layers.Crop

12−Description : Cropping layer

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

14−License : BSD2

15−Stability : experimental

16−-}

177module Grenade.Layers.Crop (

188 Crop (..)

199 ) where

2010

2111import Data.Maybe

2212import Data.Proxy

23−import Data.Serialize

24−

13+import Data.Singletons.TypeLits

2514import GHC.TypeLits

26−import Data.Kind (Type)

2715

28−import Grenade.Core

29−import Grenade.Layers.Internal.Pad

16+import Grenade.Core.Network

17+import Grenade.Core.Shape

3018

3119import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)

3220import Numeric.LinearAlgebra.Static (extract, create)

@@ -35,7 +23,7 @@ import Numeric.LinearAlgebra.Static (extract, create)

3523data Crop :: Nat

3624 -> Nat

3725 -> Nat

38− -> Nat -> Type where

26+ -> Nat -> * where

3927 Crop :: Crop cropLeft cropTop cropRight cropBottom

4028

4129instance Show (Crop cropLeft cropTop cropRight cropBottom) where

@@ -46,10 +34,6 @@ instance UpdateLayer (Crop l t r b) where

4634 runUpdate _ x _ = x

4735 createRandom = return Crop

4836

49−instance Serialize (Crop l t r b) where

50− put _ = return ()

51− get = return Crop

52−

5337-- | A two dimentional image can be cropped.

5438instance ( KnownNat cropLeft

5539 , KnownNat cropTop

@@ -59,8 +43,8 @@ instance ( KnownNat cropLeft

5943 , KnownNat inputColumns

6044 , KnownNat outputRows

6145 , KnownNat outputColumns

62− , (outputRows + cropTop + cropBottom) ~ inputRows

63− , (outputColumns + cropLeft + cropRight) ~ inputColumns

46+ , (inputRows - cropTop - cropBottom) ~ outputRows

47+ , (inputColumns - cropLeft - cropRight) ~ outputColumns

6448 ) => Layer (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where

6549 type Tape (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = ()

6650 runForwards Crop (S2D input) =

@@ -79,48 +63,3 @@ instance ( KnownNat cropLeft

7963 eo = extract dEdy

8064 vs = diagBlock [konst 0 (cropt,cropl), eo, konst 0 (cropb,cropr)]

8165 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.hsdeleted−285

@@ -1,285 +0,0 @@

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+2−1

@@ -10,7 +10,8 @@ module Grenade.Layers.Dropout (

1010import Control.Monad.Random hiding (fromList)

1111

1212import GHC.TypeLits

13−import Grenade.Core

13+import Grenade.Core.Shape

14+import Grenade.Core.Network

1415

1516-- Dropout layer help to reduce overfitting.

1617-- Idea here is that the vector is a shape of 1s and 0s, which we multiply the input by.

src/Grenade/Layers/Elu.hsdeleted−67

@@ -1,67 +0,0 @@

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.hsnew file+56

@@ -0,0 +1,56 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+module Grenade.Layers.Flatten (

7+ FlattenLayer (..)

8+ ) where

9+

10+import Data.Serialize

11+

12+import Data.Singletons.TypeLits

13+import GHC.TypeLits

14+

15+import Numeric.LinearAlgebra.Static

16+import Numeric.LinearAlgebra.Data as LA ( flatten )

17+

18+import Grenade.Core.Shape

19+import Grenade.Core.Network

20+

21+-- | Flatten Layer

22+--

23+-- Flattens input down to D1 from either 2D or 3D data.

24+--

25+-- Can also be used to turn a 3D image with only one channel into a 2D image.

26+data FlattenLayer = FlattenLayer

27+ deriving Show

28+

29+instance UpdateLayer FlattenLayer where

30+ type Gradient FlattenLayer = ()

31+ runUpdate _ _ _ = FlattenLayer

32+ createRandom = return FlattenLayer

33+

34+instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer FlattenLayer ('D2 x y) ('D1 a) where

35+ type Tape FlattenLayer ('D2 x y) ('D1 a) = ()

36+ runForwards _ (S2D y) = ((), fromJust' . fromStorable . flatten . extract $ y)

37+ runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)

38+

39+instance (KnownNat a, KnownNat x, KnownNat y, KnownNat (x * z), KnownNat z, a ~ (x * y * z)) => Layer FlattenLayer ('D3 x y z) ('D1 a) where

40+ type Tape FlattenLayer ('D3 x y z) ('D1 a) = ()

41+ runForwards _ (S3D y) = ((), fromJust' . fromStorable . flatten . extract $ y)

42+ runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)

43+

44+instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer FlattenLayer ('D3 x y z) ('D2 x y) where

45+ type Tape FlattenLayer ('D3 x y z) ('D2 x y) = ()

46+ runForwards _ (S3D y) = ((), S2D y)

47+ runBackwards _ _ (S2D y) = ((), S3D y)

48+

49+instance Serialize FlattenLayer where

50+ put _ = return ()

51+ get = return FlattenLayer

52+

53+

54+fromJust' :: Maybe x -> x

55+fromJust' (Just x) = x

56+fromJust' Nothing = error $ "FlattenLayer error: data shape couldn't be converted."

src/Grenade/Layers/FullyConnected.hs+10−8

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

11{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE RecordWildCards #-}

23{-# LANGUAGE TypeOperators #-}

34{-# LANGUAGE TypeFamilies #-}

45{-# LANGUAGE MultiParamTypeClasses #-}

@@ -13,14 +14,15 @@ import Control.Monad.Random hiding (fromList)

1314

1415import Data.Proxy

1516import Data.Serialize

17+import Data.Singletons.TypeLits

1618

1719import qualified Numeric.LinearAlgebra as LA

1820import Numeric.LinearAlgebra.Static

1921

20−import Grenade.Core

22+import Grenade.Core.Network

23+import Grenade.Core.Shape

2124

2225import Grenade.Layers.Internal.Update

23−import GHC.TypeLits

2426

2527-- | A basic fully connected (or inner product) neural network layer.

2628data FullyConnected i o = FullyConnected

@@ -37,20 +39,20 @@ instance Show (FullyConnected i o) where

3739instance (KnownNat i, KnownNat o) => UpdateLayer (FullyConnected i o) where

3840 type Gradient (FullyConnected i o) = (FullyConnected' i o)

3941

40− runUpdate lp (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =

41− let (newBias, newBiasMomentum) = descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldBias biasGradient oldBiasMomentum

42− (newActivations, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldActivations activationGradient oldMomentum

42+ runUpdate LearningParameters {..} (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =

43+ let (newBias, newBiasMomentum) = decendVector learningRate learningMomentum learningRegulariser oldBias biasGradient oldBiasMomentum

44+ (newActivations, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldActivations activationGradient oldMomentum

4345 in FullyConnected (FullyConnected' newBias newActivations) (FullyConnected' newBiasMomentum newMomentum)

4446

4547 createRandom = randomFullyConnected

4648

4749instance (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

50+ type Tape (FullyConnected i o) ('D1 i) ('D1 o) = S ('D1 i)

4951 -- Do a matrix vector multiplication and return the result.

50− runForwards (FullyConnected (FullyConnected' wB wN) _) (S1D v) = (v, S1D (wB + wN #> v))

52+ runForwards (FullyConnected (FullyConnected' wB wN) _) (S1D v) = (S1D v, S1D (wB + wN #> v))

5153

5254 -- Run a backpropogation step for a full connected layer.

53− runBackwards (FullyConnected (FullyConnected' _ wN) _) x (S1D dEdy) =

55+ runBackwards (FullyConnected (FullyConnected' _ wN) _) (S1D x) (S1D dEdy) =

5456 let wB' = dEdy

5557 mm' = dEdy `outer` x

5658 -- calcluate derivatives for next step

src/Grenade/Layers/Fuse.hsnew file+83

@@ -0,0 +1,83 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE FlexibleContexts #-}

9+{-# LANGUAGE FlexibleInstances #-}

10+module Grenade.Layers.Fuse (

11+ SubNetwork (..)

12+ , BranchNetwork (..)

13+ ) where

14+

15+import Data.Singletons.Prelude

16+

17+import Grenade.Core.Network

18+import Grenade.Core.Shape

19+import Grenade.Core.Runner

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+data SubNetwork :: [*] -> [Shape] -> * where

24+ SubNetwork :: Network sublayers subshapes -> SubNetwork sublayers subshapes

25+

26+instance CreatableNetwork sublayers subshapes => UpdateLayer (SubNetwork sublayers subshapes) where

27+ type Gradient (SubNetwork sublayers subshapes) = Gradients sublayers

28+ runUpdate lr (SubNetwork net) = SubNetwork . applyUpdate lr net

29+ createRandom = SubNetwork <$> randomNetwork

30+

31+instance (CreatableNetwork sublayers subshapes, i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (SubNetwork sublayers subshapes) i o where

32+ type Tape (SubNetwork sublayers subshapes) i o = Tapes sublayers subshapes

33+

34+ runForwards (SubNetwork net) i =

35+ go i net

36+ where

37+ go :: forall js ss. (Last js ~ Last subshapes)

38+ => S (Head js) -- ^ input vector

39+ -> Network ss js -- ^ network to train

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

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

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

43+ (tapes, answer) = go forward n

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

45+ go !x NNil

46+ = (TNil, x)

47+

48+ runBackwards (SubNetwork net) tapes o =

49+ go net tapes

50+ where

51+ go :: forall js ss. (Last js ~ Last subshapes)

52+ => Network ss js -- ^ network to train

53+ -> Tapes ss js -- ^ network to train

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

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

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

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

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

59+ go NNil TNil

60+ = (GNil, o)

61+

62+

63+-- | Run two layers in parallel, combining their outputs. The way in which the output is combined is dependent

64+-- on the inut

65+data BranchNetwork :: * -> * -> * where

66+ BranchNetwork :: x -> y -> BranchNetwork x y

67+

68+instance (UpdateLayer x, UpdateLayer y) => UpdateLayer (BranchNetwork x y) where

69+ type Gradient (BranchNetwork x y) = (Gradient x, Gradient y)

70+ runUpdate lr (BranchNetwork x y) (x', y') = BranchNetwork (runUpdate lr x x') (runUpdate lr y y')

71+ createRandom = BranchNetwork <$> createRandom <*> createRandom

72+

73+instance (SingI i, SingI o, Layer x i o, Layer y i o) => Layer (BranchNetwork x y) i o where

74+ type Tape (BranchNetwork x y) i o = (Tape x i o, Tape y i o)

75+ runForwards (BranchNetwork x y) input =

76+ let (xT, xOut) = runForwards x input

77+ (yT, yOut) = runForwards y input

78+ in ((xT, yT), xOut + yOut)

79+

80+ runBackwards (BranchNetwork x y) (xTape, yTape) o =

81+ let (x', xB) = runBackwards x xTape o

82+ (y', yB) = runBackwards y yTape o

83+ in ((x', y'), xB + yB)

src/Grenade/Layers/Inception.hsdeleted−67

@@ -1,67 +0,0 @@

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/Pad.hsdeleted−54

@@ -1,54 +0,0 @@

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/Update.hs+12−12

@@ -1,7 +1,7 @@

11{-# LANGUAGE ForeignFunctionInterface #-}

22module Grenade.Layers.Internal.Update (

3− descendMatrix

4− , descendVector

3+ decendMatrix

4+ , decendVector

55 ) where

66

77import Data.Maybe ( fromJust )

@@ -17,8 +17,8 @@ import qualified Numeric.LinearAlgebra.Devel as U

1717

1818import System.IO.Unsafe ( unsafePerformIO )

1919

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 =

20+decendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)

21+decendMatrix rate momentum regulariser weights gradient lastUpdate =

2222 let (rows, cols) = size weights

2323 len = rows * cols

2424 -- Most gradients come in in ColumnMajor,

@@ -29,7 +29,7 @@ descendMatrix rate momentum regulariser weights gradient lastUpdate =

2929 weights' = flatten . tr . extract $ weights

3030 gradient' = flatten . tr . extract $ gradient

3131 lastUpdate' = flatten . tr . extract $ lastUpdate

32− (vw, vm) = descendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'

32+ (vw, vm) = decendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'

3333

3434 -- Note that it's ColumnMajor, as we did a transpose before

3535 -- using the internal vectors.

@@ -37,17 +37,17 @@ descendMatrix rate momentum regulariser weights gradient lastUpdate =

3737 mm = U.matrixFromVector U.ColumnMajor rows cols vm

3838 in (fromJust . create $ mw, fromJust . create $ mm)

3939

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 =

40+decendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)

41+decendVector rate momentum regulariser weights gradient lastUpdate =

4242 let len = size weights

4343 weights' = extract weights

4444 gradient' = extract gradient

4545 lastUpdate' = extract lastUpdate

46− (vw, vm) = descendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'

46+ (vw, vm) = decendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'

4747 in (fromJust $ create vw, fromJust $ create vm)

4848

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 =

49+decendUnsafe :: Int -> Double -> Double -> Double -> Vector Double -> Vector Double -> Vector Double -> (Vector Double, Vector Double)

50+decendUnsafe len rate momentum regulariser weights gradient lastUpdate =

5151 unsafePerformIO $ do

5252 outWPtr <- mallocForeignPtrArray len

5353 outMPtr <- mallocForeignPtrArray len

@@ -60,11 +60,11 @@ descendUnsafe len rate momentum regulariser weights gradient lastUpdate =

6060 withForeignPtr lPtr $ \lPtr' ->

6161 withForeignPtr outWPtr $ \outWPtr' ->

6262 withForeignPtr outMPtr $ \outMPtr' ->

63− descend_cpu len rate momentum regulariser wPtr' gPtr' lPtr' outWPtr' outMPtr'

63+ decend_cpu len rate momentum regulariser wPtr' gPtr' lPtr' outWPtr' outMPtr'

6464

6565 return (U.unsafeFromForeignPtr0 outWPtr len, U.unsafeFromForeignPtr0 outMPtr len)

6666

6767foreign import ccall unsafe

68− descend_cpu

68+ decend_cpu

6969 :: Int -> Double -> Double -> Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()

7070

src/Grenade/Layers/Logit.hs+11−24

@@ -3,13 +3,6 @@

33{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE FlexibleInstances #-}

55{-# 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−-}

136module Grenade.Layers.Logit (

147 Logit (..)

158 ) where

@@ -18,10 +11,10 @@ module Grenade.Layers.Logit (

1811import Data.Serialize

1912import Data.Singletons

2013

21−import Grenade.Core

14+import Grenade.Core.Network

15+import Grenade.Core.Shape

2216

2317-- | A Logit layer.

24−--

2518-- A layer which can act between any shape of the same dimension, perfoming an sigmoid function.

2619-- This layer should be used as the output layer of a network for logistic regression (classification)

2720-- problems.

@@ -34,24 +27,18 @@ instance UpdateLayer Logit where

3427 createRandom = return Logit

3528

3629instance (a ~ b, SingI a) => Layer Logit a b where

37− -- Wengert tape optimisation:

38− --

39− -- Derivative of the sigmoid function is

40− -- d σ(x) / dx = σ(x) • (1 - σ(x))

41− -- but we have already calculated σ(x) in

42− -- the forward pass, so just store that

43− -- and use it in the backwards pass.

4430 type Tape Logit a b = S a

45− runForwards _ a =

46− let l = sigmoid a

47− in (l, l)

48− runBackwards _ l g =

49− let sigmoid' = l * (1 - l)

50− in ((), sigmoid' * g)

31+ runForwards _ a = (a, logistic a)

32+ runBackwards _ a g = ((), logistic' a * g)

5133

5234instance Serialize Logit where

5335 put _ = return ()

5436 get = return Logit

5537

56−sigmoid :: Floating a => a -> a

57−sigmoid x = 1 / (1 + exp (-x))

38+logistic :: Floating a => a -> a

39+logistic x = 1 / (1 + exp (-x))

40+

41+logistic' :: Floating a => a -> a

42+logistic' x = logix * (1 - logix)

43+ where

44+ logix = logistic x

src/Grenade/Layers/Merge.hsdeleted−66

@@ -1,66 +0,0 @@

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+5−62

@@ -1,19 +1,9 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE ScopedTypeVariables #-}

43{-# LANGUAGE GADTs #-}

54{-# LANGUAGE TypeOperators #-}

65{-# LANGUAGE TypeFamilies #-}

76{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE FlexibleContexts #-}

9−{-# LANGUAGE UndecidableInstances #-}

10−{-|

11−Module : Grenade.Core.Pad

12−Description : Padding layer for 2D and 3D images

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

14−License : BSD2

15−Stability : experimental

16−-}

177module Grenade.Layers.Pad (

188 Pad (..)

199 ) where

@@ -21,23 +11,20 @@ module Grenade.Layers.Pad (

2111import Data.Maybe

2212import Data.Proxy

2313import Data.Serialize

24−

14+import Data.Singletons.TypeLits

2515import GHC.TypeLits

26−import Data.Kind (Type)

2716

28−import Grenade.Core

29−import Grenade.Layers.Internal.Pad

17+import Grenade.Core.Network

18+import Grenade.Core.Shape

3019

3120import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)

3221import Numeric.LinearAlgebra.Static (extract, create)

3322

3423-- | A padding layer for a neural network.

35−--

36−-- Pads on the X and Y dimension of an image.

3724data Pad :: Nat

3825 -> Nat

3926 -> Nat

40− -> Nat -> Type where

27+ -> Nat -> * where

4128 Pad :: Pad padLeft padTop padRight padBottom

4229

4330instance Show (Pad padLeft padTop padRight padBottom) where

@@ -52,7 +39,7 @@ instance Serialize (Pad l t r b) where

5239 put _ = return ()

5340 get = return Pad

5441

55−-- | A two dimentional image can be padded.

42+-- | A two dimentional image can be padped.

5643instance ( KnownNat padLeft

5744 , KnownNat padTop

5845 , KnownNat padRight

@@ -81,47 +68,3 @@ instance ( KnownNat padLeft

8168 m = extract dEdy

8269 vs = subMatrix (padt, padl) (nrows, ncols) m

8370 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+5−15

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE ScopedTypeVariables #-}

43{-# LANGUAGE StandaloneDeriving #-}

@@ -7,14 +6,6 @@

76{-# LANGUAGE TypeFamilies #-}

87{-# LANGUAGE MultiParamTypeClasses #-}

98{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE UndecidableInstances #-}

11−{-|

12−Module : Grenade.Core.Pooling

13−Description : Max Pooling layer for 2D and 3D images

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

15−License : BSD2

16−Stability : experimental

17−-}

189module Grenade.Layers.Pooling (

1910 Pooling (..)

2011 ) where

@@ -22,31 +13,30 @@ module Grenade.Layers.Pooling (

2213import Data.Maybe

2314import Data.Proxy

2415import Data.Serialize

25−

16+import Data.Singletons.TypeLits

2617import GHC.TypeLits

27−import Data.Kind (Type)

2818

29−import Grenade.Core

19+import Grenade.Core.Network

20+import Grenade.Core.Shape

3021import Grenade.Layers.Internal.Pooling

3122

3223import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)

3324

3425-- | A pooling layer for a neural network.

35−--

3626-- Does a max pooling, looking over a kernel similarly to the convolution network, but returning

3727-- maxarg only. This layer is often used to provide minor amounts of translational invariance.

3828--

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

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

4131--

42−data Pooling :: Nat -> Nat -> Nat -> Nat -> Type where

32+data Pooling :: Nat -> Nat -> Nat -> Nat -> * where

4333 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

4434

4535instance Show (Pooling k k' s s') where

4636 show Pooling = "Pooling"

4737

4838instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

49− type Gradient (Pooling kernelRows kernelColumns strideRows strideColumns) = ()

39+ type Gradient (Pooling kr kc sr sc) = ()

5040 runUpdate _ Pooling _ = Pooling

5141 createRandom = return Pooling

5242

src/Grenade/Layers/Relu.hs+2−8

@@ -2,13 +2,6 @@

22{-# LANGUAGE TypeOperators #-}

33{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

5−{-|

6−Module : Grenade.Layers.Relu

7−Description : Rectifying linear unit layer

8−Copyright : (c) Huw Campbell, 2016-2017

9−License : BSD2

10−Stability : experimental

11−-}

125module Grenade.Layers.Relu (

136 Relu (..)

147 ) where

@@ -16,7 +9,8 @@ module Grenade.Layers.Relu (

169import Data.Serialize

1710

1811import GHC.TypeLits

19−import Grenade.Core

12+import Grenade.Core.Network

13+import Grenade.Core.Shape

2014

2115import qualified Numeric.LinearAlgebra.Static as LAS

2216

src/Grenade/Layers/Reshape.hsdeleted−80

@@ -1,80 +0,0 @@

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.hsdeleted−39

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

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.hsdeleted−64

@@ -1,64 +0,0 @@

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+5−11

@@ -1,15 +1,8 @@

11{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE TypeFamilies #-}

24{-# LANGUAGE FlexibleInstances #-}

35{-# 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−-}

136module Grenade.Layers.Tanh (

147 Tanh (..)

158 ) where

@@ -17,10 +10,11 @@ module Grenade.Layers.Tanh (

1710import Data.Serialize

1811import Data.Singletons

1912

20−import Grenade.Core

13+import Grenade.Core.Network

14+import Grenade.Core.Shape

2115

2216-- | A Tanh layer.

23−-- A layer which can act between any shape of the same dimension, performing a tanh function.

17+-- A layer which can act between any shape of the same dimension, perfoming a tanh function.

2418data Tanh = Tanh

2519 deriving Show

2620

src/Grenade/Recurrent.hs+6−26

@@ -1,29 +1,9 @@

11module 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−

2+ module X

163 ) where

174

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−-}

5+import Grenade.Recurrent.Core.Network as X

6+import Grenade.Recurrent.Core.Runner as X

7+import Grenade.Recurrent.Layers.BasicRecurrent as X

8+import Grenade.Recurrent.Layers.LSTM as X

9+import Grenade.Recurrent.Layers.Trivial as X

src/Grenade/Recurrent/Core.hsdeleted−9

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

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.hsdeleted−35

@@ -1,35 +0,0 @@

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.hs+68−258

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE GADTs #-}

43{-# LANGUAGE TypeOperators #-}

@@ -7,195 +6,61 @@

76{-# LANGUAGE FlexibleContexts #-}

87{-# LANGUAGE FlexibleInstances #-}

98{-# LANGUAGE EmptyDataDecls #-}

10−{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE BangPatterns #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−

159module Grenade.Recurrent.Core.Network (

1610 Recurrent

1711 , FeedForward

18−

12+ , RecurrentLayer (..)

13+ , RecurrentUpdateLayer (..)

1914 , RecurrentNetwork (..)

2015 , RecurrentInputs (..)

21− , RecurrentTape (..)

22− , RecurrentGradient (..)

23−

24− , randomRecurrent

25− , runRecurrent

26− , runRecurrent'

27− , applyRecurrentUpdate

16+ , CreatableRecurrent (..)

2817 ) where

2918

3019

3120import Control.Monad.Random ( MonadRandom )

21+import Data.Singletons ( SingI )

3222import Data.Serialize

23+import qualified Data.Vector.Storable as V

3324

34−import Data.Kind (Type)

25+import Grenade.Core.Shape

26+import Grenade.Core.Network

27+

28+import qualified Numeric.LinearAlgebra as LA

29+import qualified Numeric.LinearAlgebra.Static as LAS

3530

36−import Grenade.Core

37−import Grenade.Recurrent.Core.Layer

38−import Prelude.Singletons

3931

4032-- | Witness type to say indicate we're building up with a normal feed

4133-- forward layer.

42−data FeedForward :: Type -> Type

34+data FeedForward :: * -> *

4335-- | 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)

36+data Recurrent :: * -> *

37+

38+-- | Class for a recurrent layer.

39+-- It's quite similar to a normal layer but for the input and output

40+-- of an extra recurrent data shape.

41+class UpdateLayer x => RecurrentUpdateLayer x where

42+ -- | Shape of data that is passed between each subsequent run of the layer

43+ type RecurrentShape x :: Shape

44+

45+class (RecurrentUpdateLayer x, SingI (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where

46+ -- | Wengert Tape

47+ type RecTape x i o :: *

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

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

50+ runRecurrentForwards :: x -> S (RecurrentShape x) -> S i -> (RecTape x i o, S (RecurrentShape x), S o)

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

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

53+ -- the layer above.

54+ -- Returns the gradient layer and the derivatives to push back further.

55+ runRecurrentBackwards :: x -> RecTape x i o -> S (RecurrentShape x) -> S o -> (Gradient x, S (RecurrentShape x), S i)

56+

57+data RecurrentNetwork :: [*] -> [Shape] -> * where

58+ RNil :: SingI i => RecurrentNetwork '[] '[i]

59+ (:~~>) :: (SingI i, Layer x i h) => !x -> !(RecurrentNetwork xs (h ': hs)) -> RecurrentNetwork (FeedForward x ': xs) (i ': h ': hs)

60+ (:~@>) :: (SingI i, RecurrentLayer x i h) => !x -> !(RecurrentNetwork xs (h ': hs)) -> RecurrentNetwork (Recurrent x ': xs) (i ': h ': hs)

7061infixr 5 :~~>

7162infixr 5 :~@>

7263

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−

19964instance Show (RecurrentNetwork '[] '[i]) where

20065 show RNil = "NNil"

20166instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (FeedForward x ': xs) (i ': rs)) where

@@ -203,28 +68,39 @@ instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Feed

20368instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recurrent x ': xs) (i ': rs)) where

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

20570

71+-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)

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

73+data RecurrentInputs :: [*] -> * where

74+ RINil :: RecurrentInputs '[]

75+ (:~~+>) :: UpdateLayer x

76+ => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)

77+ (:~@+>) :: (SingI (RecurrentShape x), RecurrentUpdateLayer x)

78+ => !(S (RecurrentShape x)) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)

79+infixr 5 :~~+>

80+infixr 5 :~@+>

20681

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

20883-- recurrent network and a set of random inputs for it is with the randomRecurrent.

209−class CreatableRecurrent (xs :: [Type]) (ss :: [Shape]) where

84+class CreatableRecurrent (xs :: [*]) (ss :: [Shape]) where

21085 -- | Create a network of the types requested

211− randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss)

86+ randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss, RecurrentInputs xs)

21287

21388instance SingI i => CreatableRecurrent '[] '[i] where

21489 randomRecurrent =

215− return RNil

90+ return (RNil, RINil)

21691

21792instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where

21893 randomRecurrent = do

21994 thisLayer <- createRandom

220− rest <- randomRecurrent

221− return (thisLayer :~~> rest)

95+ (rest, resti) <- randomRecurrent

96+ return (thisLayer :~~> rest, () :~~+> resti)

22297

22398instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where

22499 randomRecurrent = do

225100 thisLayer <- createRandom

226− rest <- randomRecurrent

227− return (thisLayer :~@> rest)

101+ thisShape <- randomOfShape

102+ (rest, resti) <- randomRecurrent

103+ return (thisLayer :~@> rest, thisShape :~@+> resti)

228104

229105-- | Add very simple serialisation to the recurrent network

230106instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where

@@ -243,86 +119,20 @@ instance (Serialize (RecurrentInputs '[])) where

243119 put _ = return ()

244120 get = return RINil

245121

246−instance (UpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

122+instance (UpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

247123 put ( () :~~+> rest) = put rest

248124 get = ( () :~~+> ) <$> get

249125

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'

126+instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

127+ put ( i :~@+> rest ) = do

128+ _ <- (case i of

129+ (S1D x) -> putListOf put . LA.toList . LAS.extract $ x

130+ (S2D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

131+ (S3D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

132+ ) :: PutM ()

133+ put rest

134+

135+ get = do

136+ Just i <- fromStorable . V.fromList <$> getListOf get

137+ rest <- get

138+ return ( i :~@+> rest)

src/Grenade/Recurrent/Core/Runner.hs+121−88

@@ -6,105 +6,138 @@

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE FlexibleContexts #-}

88{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE RecordWildCards #-}

910

11+-- GHC 7.10 doesn't think that go is complete

12+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

1013module Grenade.Recurrent.Core.Runner (

11− runRecurrentExamples

12− , runRecurrentBackprop

13− , backPropagateRecurrent

14− , trainRecurrent

15−

16− , RecurrentGradients

14+ trainRecurrent

15+ , runRecurrent

1716 ) where

1817

19−import Data.List ( foldl' )

20−import Grenade.Core

18+import Data.Singletons.Prelude

19+import Grenade.Core.Network

20+import Grenade.Core.Shape

2121

2222import 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−

5523

5624-- | 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))

25+--

26+-- TODO: split this nicely into backpropagate and update.

27+--

28+-- QUESTION: Should we return a list of gradients or the sum of

29+-- the gradients? It's different taking into account

30+-- momentum and L2.

31+trainRecurrent :: forall shapes layers. SingI (Last shapes)

8332 => LearningParameters

8433 -> RecurrentNetwork layers shapes

8534 -> RecurrentInputs layers

8635 -> [(S (Head shapes), Maybe (S (Last shapes)))]

8736 -> (RecurrentNetwork layers shapes, RecurrentInputs layers)

8837trainRecurrent 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

38+ updateBack $ go inputs network recinputs

39+ where

40+ inputs = fst <$> examples

41+ targets = snd <$> examples

42+ updateBack (a,recgrad,_) = (a,updateRecInputs rate recinputs recgrad)

43+

44+ go :: forall js sublayers. (Last js ~ Last shapes)

45+ => [S (Head js)] -- ^ input vector

46+ -> RecurrentNetwork sublayers js -- ^ network to train

47+ -> RecurrentInputs sublayers

48+ -> (RecurrentNetwork sublayers js, RecurrentInputs sublayers, [S (Head js)])

49+

50+ -- This is a simple non-recurrent layer, just map it forwards

51+ -- Note we're doing training here, we could just return a list of gradients

52+ -- (and probably will in future).

53+ go !xs (layer :~~> n) (() :~~+> nIn)

54+ = let tys = runForwards layer <$> xs

55+ tapes = fst <$> tys

56+ ys = snd <$> tys

57+ -- recursively run the rest of the network, and get the gradients from above.

58+ (newFN, ig, grads) = go ys n nIn

59+ -- calculate the gradient for this layer to pass down,

60+ back = uncurry (runBackwards layer) <$> zip (reverse tapes) grads

61+ -- the new trained layer.

62+ newlayer = runUpdates rate layer (fst <$> back)

63+

64+ in (newlayer :~~> newFN, () :~~+> ig, snd <$> back)

65+

66+ -- This is a recurrent layer, so we need to do a scan, first input to last, providing

67+ -- the recurrent shape output to the next layer.

68+ go !xs (layer :~@> n) (g :~@+> nIn)

69+ = let tys = scanlFrom layer g xs

70+ tapes = fst <$> tys

71+ ys = snd <$> tys

72+

73+ (newFN, ig, grads) = go ys n nIn

74+

75+ backExamples = zip (reverse tapes) grads

76+

77+ (rg, back) = myscanbackward layer backExamples

78+ -- the new trained layer.

79+ newlayer = runUpdates rate layer (fst <$> back)

80+ in (newlayer :~@> newFN, rg :~@+> ig, snd <$> back)

81+

82+ -- Handle the output layer, bouncing the derivatives back down.

83+ -- We may not have a target for each example, so when we don't use 0 gradient.

84+ go !xs RNil RINil

85+ = (RNil, RINil, reverse (zipWith makeError xs targets))

86+ where

87+ makeError :: S (Last shapes) -> Maybe (S (Last shapes)) -> S (Last shapes)

88+ makeError _ Nothing = 0

89+ makeError y (Just t) = y - t

90+

91+ updateRecInputs :: forall sublayers.

92+ LearningParameters

93+ -> RecurrentInputs sublayers

94+ -> RecurrentInputs sublayers

95+ -> RecurrentInputs sublayers

96+

97+ updateRecInputs l@LearningParameters {..} (() :~~+> xs) (() :~~+> ys)

98+ = () :~~+> updateRecInputs l xs ys

99+

100+ updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)

101+ = (realToFrac (learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys

102+

103+ updateRecInputs _ RINil RINil

104+ = RINil

105+

106+scanlFrom :: forall x i o. RecurrentLayer x i o

107+ => x -- ^ the layer

108+ -> S (RecurrentShape x) -- ^ place to start

109+ -> [S i] -- ^ list of inputs to scan through

110+ -> [(RecTape x i o, S o)] -- ^ list of scan inputs and outputs

111+scanlFrom !layer !recShape (x:xs) =

112+ let (tape, lerec, lepush) = runRecurrentForwards layer recShape x

113+ in (tape, lepush) : scanlFrom layer lerec xs

114+scanlFrom _ _ [] = []

115+

116+myscanbackward :: forall x i o. RecurrentLayer x i o

117+ => x -- ^ the layer

118+ -> [(RecTape x i o, S o)] -- ^ the list of inputs and output to scan over

119+ -> (S (RecurrentShape x), [(Gradient x, S i)]) -- ^ list of gradients to fold and inputs to backprop

120+myscanbackward layer =

121+ goX 0

122+ where

123+ goX :: S (RecurrentShape x) -> [(RecTape x i o, S o)] -> (S (RecurrentShape x), [(Gradient x, S i)])

124+ goX !lastback ((recTape, backgrad):xs) =

125+ let (layergrad, recgrad, ingrad) = runRecurrentBackwards layer recTape lastback backgrad

126+ (pushedback, ll) = goX recgrad xs

127+ in (pushedback, (layergrad, ingrad) : ll)

128+ goX !lastback [] = (lastback, [])

129+

130+-- | Just forwards propagation with no training.

131+runRecurrent :: RecurrentNetwork layers shapes

132+ -> RecurrentInputs layers -> S (Head shapes)

133+ -> (RecurrentInputs layers, S (Last shapes))

134+runRecurrent (layer :~~> n) (() :~~+> nr) !x

135+ = let (_, ys) = runForwards layer x

136+ (nr', o) = runRecurrent n nr ys

137+ in (() :~~+> nr', o)

138+runRecurrent (layer :~@> n) (recin :~@+> nr) !x

139+ = let (_, recin', y) = runRecurrentForwards layer recin x

140+ (nr', o) = runRecurrent n nr y

141+ in (recin' :~@+> nr', o)

142+runRecurrent RNil RINil !x

143+ = (RINil, x)

src/Grenade/Recurrent/Layers.hsdeleted−9

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

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.hs+14−12

@@ -1,12 +1,14 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE TypeOperators #-}

55{-# LANGUAGE TypeFamilies #-}

66{-# LANGUAGE MultiParamTypeClasses #-}

77{-# LANGUAGE FlexibleContexts #-}

88{-# LANGUAGE UndecidableInstances #-}

99

10+-- GHC 7.10 doesn't see recurrent run functions as total.

11+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

1012module Grenade.Recurrent.Layers.BasicRecurrent (

1113 BasicRecurrent (..)

1214 , randomBasicRecurrent

@@ -16,19 +18,19 @@ module Grenade.Recurrent.Layers.BasicRecurrent (

1618

1719import Control.Monad.Random ( MonadRandom, getRandom )

1820

19−

20−import Data.Kind (Type)

21+import Data.Singletons.TypeLits

2122

2223import Numeric.LinearAlgebra.Static

2324

2425import GHC.TypeLits

2526

26−import Grenade.Core

27−import Grenade.Recurrent.Core

27+import Grenade.Core.Network

28+import Grenade.Core.Shape

29+import Grenade.Recurrent.Core.Network

2830

2931data BasicRecurrent :: Nat -- Input layer size

3032 -> Nat -- Output layer size

31− -> Type where

33+ -> * where

3234 BasicRecurrent :: ( KnownNat input

3335 , KnownNat output

3436 , KnownNat matrixCols

@@ -41,7 +43,7 @@ data BasicRecurrent :: Nat -- Input layer size

4143

4244data BasicRecurrent' :: Nat -- Input layer size

4345 -> Nat -- Output layer size

44− -> Type where

46+ -> * where

4547 BasicRecurrent' :: ( KnownNat input

4648 , KnownNat output

4749 , KnownNat matrixCols

@@ -56,18 +58,18 @@ instance Show (BasicRecurrent i o) where

5658instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

5759 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

5860

59− runUpdate lp (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

60− let newBiasMomentum = konst (learningMomentum lp) * oldBiasMomentum - konst (learningRate lp) * biasGradient

61+ runUpdate LearningParameters {..} (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

62+ let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient

6163 newBias = oldBias + newBiasMomentum

62− newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient

63− regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations

64+ newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient

65+ regulariser = konst (learningRegulariser * learningRate) * oldActivations

6466 newActivations = oldActivations + newMomentum - regulariser

6567 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

6668

6769 createRandom = randomBasicRecurrent

6870

6971instance (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)

72+ type RecurrentShape (BasicRecurrent i o) = 'D1 o

7173

7274instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

7375

src/Grenade/Recurrent/Layers/ConcatRecurrent.hsdeleted−180

@@ -1,180 +0,0 @@

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.hs+87−59

@@ -1,8 +1,8 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE BangPatterns #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE GADTs #-}

54{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE RecordWildCards #-}

66{-# LANGUAGE TypeOperators #-}

77{-# LANGUAGE TypeFamilies #-}

88{-# LANGUAGE MultiParamTypeClasses #-}

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

1010{-# LANGUAGE ViewPatterns #-}

1111{-# LANGUAGE ScopedTypeVariables #-}

1212

13+-- GHC 7.10 doesn't see recurrent run functions as total.

14+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

1315module Grenade.Recurrent.Layers.LSTM (

1416 LSTM (..)

1517 , LSTMWeights (..)

@@ -18,33 +20,35 @@ module Grenade.Recurrent.Layers.LSTM (

1820

1921import Control.Monad.Random ( MonadRandom, getRandom )

2022

23+

2124-- import Data.List ( foldl1' )

2225import Data.Proxy

2326import Data.Serialize

24−import Data.Kind (Type)

27+import Data.Singletons.TypeLits

2528

2629import qualified Numeric.LinearAlgebra as LA

2730import Numeric.LinearAlgebra.Static

2831

29−import Grenade.Core

30−import Grenade.Recurrent.Core

32+import Grenade.Core.Network

33+import Grenade.Core.Shape

34+

3135import Grenade.Layers.Internal.Update

32−import GHC.TypeLits

3336

37+import Grenade.Recurrent.Core.Network

3438

3539-- | Long Short Term Memory Recurrent unit

3640--

3741-- This is a Peephole formulation, so the recurrent shape is

3842-- just the cell state, the previous output is not held or used

3943-- at all.

40−data LSTM :: Nat -> Nat -> Type where

44+data LSTM :: Nat -> Nat -> * where

4145 LSTM :: ( KnownNat input

4246 , KnownNat output

4347 ) => !(LSTMWeights input output) -- Weights

4448 -> !(LSTMWeights input output) -- Momentums

4549 -> LSTM input output

4650

47−data LSTMWeights :: Nat -> Nat -> Type where

51+data LSTMWeights :: Nat -> Nat -> * where

4852 LSTMWeights :: ( KnownNat input

4953 , KnownNat output

5054 ) => {

@@ -71,7 +75,7 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

7175

7276 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

7377 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

74− runUpdate lp (LSTM w m) g =

78+ runUpdate LearningParameters {..} (LSTM w m) g =

7579 let (wf, wf') = u lstmWf w m g

7680 (uf, uf') = u lstmUf w m g

7781 (bf, bf') = v lstmBf w m g

@@ -88,11 +92,11 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

8892 -- Utility function for updating with the momentum, gradients, and weights.

8993 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

9094 u e (e -> weights) (e -> momentum) (e -> gradient) =

91− descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

95+ decendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum

9296

9397 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

9498 v e (e -> weights) (e -> momentum) (e -> gradient) =

95− descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

99+ decendVector learningRate learningMomentum learningRegulariser weights gradient momentum

96100

97101 -- There's a lot of updates here, so to try and minimise the number of data copies

98102 -- we'll create a mutable bucket for each.

@@ -124,33 +128,27 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

124128instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

125129 -- The recurrent shape is the same size as the output.

126130 -- It's actually the cell state however, as this is a peephole variety LSTM.

127− type RecurrentShape (LSTM i o) = S ('D1 o)

131+ type RecurrentShape (LSTM i o) = 'D1 o

128132

129133instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

130134

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)

135+ type RecTape (LSTM i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))

134136 -- Forward propagation for the LSTM layer.

135137 -- The size of the cell state is also the size of the output.

136− runRecurrentForwards (LSTM lw _) (S1D cell) (S1D input) =

138+ runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =

137139 let -- Forget state vector

138− f_s = lstmBf lw + lstmWf lw #> input + lstmUf lw #> cell

139− f_t = sigmoid f_s

140+ f_t = sigmoid $ lstmBf + lstmWf #> input + lstmUf #> cell

140141 -- Input state vector

141− i_s = lstmBi lw + lstmWi lw #> input + lstmUi lw #> cell

142− i_t = sigmoid i_s

142+ i_t = sigmoid $ lstmBi + lstmWi #> input + lstmUi #> cell

143143 -- Output state vector

144− o_s = lstmBo lw + lstmWo lw #> input + lstmUo lw #> cell

145− o_t = sigmoid o_s

144+ o_t = sigmoid $ lstmBo + lstmWo #> input + lstmUo #> cell

146145 -- Cell input state vector

147− c_s = lstmBc lw + lstmWc lw #> input

148− c_x = tanh c_s

146+ c_x = tanh $ lstmBc + lstmWc #> input

149147 -- Cell state

150148 c_t = f_t * cell + i_t * c_x

151149 -- Output (it's sometimes recommended to use tanh c_t)

152150 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)

151+ in ((S1D cell, S1D input), S1D c_t, S1D h_t)

154152

155153 -- Run a backpropogation step for an LSTM layer.

156154 -- We're doing all the derivatives by hand here, so one should

@@ -158,8 +156,29 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

158156 --

159157 -- There's a test version using the AD library without hmatrix in the test

160158 -- 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

159+ runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (S1D cell, S1D input) (S1D cellGrad) (S1D h_t') =

160+ -- We're not keeping the Wengert tape during the forward pass,

161+ -- so we're duplicating some work here.

162+ --

163+ -- If I was being generous, I'd call it checkpointing.

164+ --

165+ -- Maybe think about better ways to store some intermediate states.

166+ let -- Forget state vector

167+ f_s = lstmBf + lstmWf #> input + lstmUf #> cell

168+ f_t = sigmoid f_s

169+ -- Input state vector

170+ i_s = lstmBi + lstmWi #> input + lstmUi #> cell

171+ i_t = sigmoid i_s

172+ -- Output state vector

173+ o_s = lstmBo + lstmWo #> input + lstmUo #> cell

174+ o_t = sigmoid o_s

175+ -- Cell input state vector

176+ c_s = lstmBc + lstmWc #> input

177+ c_x = tanh c_s

178+ -- Cell state

179+ c_t = f_t * cell + i_t * c_x

180+

181+ -- Reverse Mode AD Derivitives

163182 c_t' = h_t' * o_t + cellGrad

164183

165184 f_t' = c_t' * cell

@@ -175,8 +194,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

175194 c_s' = tanh' c_s * c_x'

176195

177196 -- 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'

197+ cell' = tr lstmUf #> f_s' + tr lstmUo #> o_s' + tr lstmUi #> i_s' + c_t' * f_t

198+ input' = tr lstmWf #> f_s' + tr lstmWo #> o_s' + tr lstmWi #> i_s' + tr lstmWc #> c_s'

180199

181200 -- Calculate the gradient Matricies for the input

182201 lstmWf' = f_s' `outer` input

@@ -221,8 +240,7 @@ randomLSTM = do

221240

222241-- | Maths

223242--

224−-- TODO: Move to not here

225−-- Optimise backwards derivative

243+-- TODO: move to not here

226244sigmoid :: Floating a => a -> a

227245sigmoid x = 1 / (1 + exp (-x))

228246

@@ -235,34 +253,44 @@ tanh' :: (Floating a) => a -> a

235253tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

236254

237255instance (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

256+ put (LSTM LSTMWeights {..} _) = do

257+ u lstmWf

258+ u lstmUf

259+ v lstmBf

260+ u lstmWi

261+ u lstmUi

262+ v lstmBi

263+ u lstmWo

264+ u lstmUo

265+ v lstmBo

266+ u lstmWc

267+ v lstmBc

268+ where

269+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

270+ u = putListOf put . LA.toList . LA.flatten . extract

271+ v :: forall a. (KnownNat a) => Putter (R a)

272+ v = putListOf put . LA.toList . extract

255273

256274 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

275+ lstmWf <- u

276+ lstmUf <- u

277+ lstmBf <- v

278+ lstmWi <- u

279+ lstmUi <- u

280+ lstmBi <- v

281+ lstmWo <- u

282+ lstmUo <- u

283+ lstmBo <- v

284+ lstmWc <- u

285+ lstmBc <- v

286+ return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

287+ where

288+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

289+ u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

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

291+ v :: forall a. (KnownNat a) => Get (R a)

292+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

293+

294+ w0 = konst 0

295+ u0 = konst 0

296+ v0 = konst 0

src/Grenade/Layers/Trivial.hs → src/Grenade/Recurrent/Layers/Trivial.hsrenamed+4−14

@@ -3,25 +3,15 @@

33{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

55{-# 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 (

6+module Grenade.Recurrent.Layers.Trivial (

147 Trivial (..)

158 ) where

169

1710import Data.Serialize

1811

19−import Grenade.Core

12+import Grenade.Core.Network

2013

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.

14+-- | A trivial layer.

2515data Trivial = Trivial

2616 deriving Show

2717

@@ -36,5 +26,5 @@ instance UpdateLayer Trivial where

3626

3727instance (a ~ b) => Layer Trivial a b where

3828 type Tape Trivial a b = ()

39− runForwards _ a = ((), a)

29+ runForwards _ x = ((), x)

4030 runBackwards _ _ y = ((), y)

src/Grenade/Utils/OneHot.hs+5−6

@@ -22,6 +22,7 @@ import Data.Map ( Map )

2222import qualified Data.Map as M

2323

2424import Data.Proxy

25+import Data.Singletons.TypeLits

2526

2627import Data.Vector ( Vector )

2728import qualified Data.Vector as V

@@ -30,7 +31,6 @@ import qualified Data.Vector.Storable as VS

3031import Numeric.LinearAlgebra ( maxIndex )

3132import Numeric.LinearAlgebra.Devel

3233import Numeric.LinearAlgebra.Static

33−import GHC.TypeLits

3434

3535import Grenade.Core.Shape

3636

@@ -52,16 +52,15 @@ oneHot hot =

5252

5353-- | Create a one hot map from any enumerable.

5454-- 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)

55+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Maybe (Map a Int, Vector a)

5656hotMap n as =

5757 let len = fromIntegral $ natVal n

5858 uniq = [ c | (c:_) <- group $ sort as]

5959 hotl = length uniq

60− in if hotl == len

60+ in if hotl <= len

6161 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")

62+ Just (M.fromList $ zip uniq [0..], V.fromList uniq)

63+ else Nothing

6564

6665-- | From a map and value, create a 1D Shape

6766-- with one index hot (1) with the rest 0.

stack.yamldeleted−78

@@ -1,78 +0,0 @@

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.lockdeleted−19

@@ -1,19 +0,0 @@

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+26−30

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE TemplateHaskell #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE GADTs #-}

@@ -16,21 +15,16 @@ import Data.Singletons ()

1615import GHC.TypeLits

1716import GHC.TypeLits.Witnesses

1817

19−#if MIN_VERSION_base(4,9,0)

20−import Data.Kind (Type)

21−#endif

22−

23−import Grenade.Core

18+import Grenade.Core.Shape

19+import Grenade.Core.Network

2420import Grenade.Layers.Convolution

2521

26−import Hedgehog

27−import qualified Hedgehog.Gen as Gen

22+import Disorder.Jack

2823

29−import Test.Hedgehog.Hmatrix

30−import Test.Hedgehog.TypeLits

31−import Test.Hedgehog.Compat

24+import Test.Jack.Hmatrix

25+import Test.Jack.TypeLits

3226

33−data OpaqueConvolution :: Type where

27+data OpaqueConvolution :: * where

3428 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution

3529

3630instance Show OpaqueConvolution where

@@ -44,10 +38,10 @@ genConvolution :: ( KnownNat channels

4438 , KnownNat strideColumns

4539 , KnownNat kernelFlattened

4640 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

47− ) => Gen (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

41+ ) => Jack (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

4842genConvolution = Convolution <$> uniformSample <*> uniformSample

4943

50−genOpaqueOpaqueConvolution :: Gen OpaqueConvolution

44+genOpaqueOpaqueConvolution :: Jack OpaqueConvolution

5145genOpaqueOpaqueConvolution = do

5246 channels <- genNat

5347 filters <- genNat

@@ -63,17 +57,17 @@ genOpaqueOpaqueConvolution = do

6357 p2 = natDict pkc

6458 p3 = natDict pch

6559 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

60+ Dict -> OpaqueConvolution <$> (genConvolution :: Jack (Convolution ch fl kr kc sr sc))

7261

62+prop_conv_net_witness =

63+ gamble genOpaqueOpaqueConvolution $ \onet ->

64+ (case onet of

65+ (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> True

66+ ) :: Bool

7367

74−prop_conv_net = property $

75− blindForAll genOpaqueOpaqueConvolution >>= \onet ->

76− case onet of

68+prop_conv_net =

69+ gamble genOpaqueOpaqueConvolution $ \onet ->

70+ (case onet of

7771 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->

7872 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]

7973 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

@@ -81,15 +75,15 @@ prop_conv_net = property $

8175 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)

8276 sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)

8377

84− in forAll (Gen.element (ok sr kr)) >>= \er ->

85− forAll (Gen.element (ok sc kc)) >>= \ec ->

78+ in gamble (elements (ok sr kr)) $ \er ->

79+ gamble (elements (ok sc kc)) $ \ec ->

8680 let rr = ((er - kr) `div` sr) + 1

8781 rc = ((ec - kc) `div` sc) + 1

8882 Just er' = someNatVal er

8983 Just ec' = someNatVal ec

9084 Just rr' = someNatVal rr

9185 Just rc' = someNatVal rc

92− in case (er', ec', rr', rc') of

86+ in (case (er', ec', rr', rc') of

9387 ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->

9488 case ( natDict pinr %* natDict (Proxy :: Proxy channels)

9589 , natDict pour %* natDict (Proxy :: Proxy filters)

@@ -97,12 +91,14 @@ prop_conv_net = property $

9791 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

9892 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

9993 (Dict, Dict, Dict, Dict) ->

100− blindForAll (S3D <$> uniformSample) >>= \(input :: S ('D3 inRows inCols channels)) ->

94+ gamble (S3D <$> uniformSample) $ \(input :: S ('D3 inRows inCols channels)) ->

10195 let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input

10296 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))

10397 = runBackwards convLayer tape output

104− in backed `seq` success

105−

98+ in backed `seq` True

99+ ) :: Property

100+ ) :: Property

106101

102+return []

107103tests :: IO Bool

108−tests = checkParallel $$(discover)

104+tests = $quickCheckAll

test/Test/Grenade/Layers/FullyConnected.hs+19−22

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE BangPatterns #-}

32{-# LANGUAGE TemplateHaskell #-}

43{-# LANGUAGE DataKinds #-}

@@ -13,28 +12,25 @@ import Data.Singletons ()

1312

1413import GHC.TypeLits

1514

16−#if MIN_VERSION_base(4,9,0)

17−import Data.Kind (Type)

18−#endif

19−

20−import Grenade.Core

15+import Grenade.Core.Shape

16+import Grenade.Core.Network

2117import Grenade.Layers.FullyConnected

2218

23−import Hedgehog

19+import Disorder.Jack

20+

21+import Test.Jack.Hmatrix

2422

25−import Test.Hedgehog.Compat

26−import Test.Hedgehog.Hmatrix

2723

28−data OpaqueFullyConnected :: Type where

24+data OpaqueFullyConnected :: * where

2925 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected

3026

3127instance Show OpaqueFullyConnected where

3228 show (OpaqueFullyConnected n) = show n

3329

34−genOpaqueFullyConnected :: Gen OpaqueFullyConnected

30+genOpaqueFullyConnected :: Jack OpaqueFullyConnected

3531genOpaqueFullyConnected = do

36− input :: Integer <- choose 2 100

37− output :: Integer <- choose 1 100

32+ input :: Integer <- choose (2, 100)

33+ output :: Integer <- choose (1, 100)

3834 let Just input' = someNatVal input

3935 let Just output' = someNatVal output

4036 case (input', output') of

@@ -46,13 +42,14 @@ genOpaqueFullyConnected = do

4642 return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')

4743

4844prop_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−

45+prop_fully_connected_forwards =

46+ gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->

47+ gamble (S1D <$> randomVector) $ \(input :: S ('D1 i)) ->

48+ let (tape, output :: S ('D1 o)) = runForwards fclayer input

49+ backed :: (Gradient (FullyConnected i o), S ('D1 i))

50+ = runBackwards fclayer tape output

51+ in backed `seq` True

52+

53+return []

5754tests :: IO Bool

58−tests = checkParallel $$(discover)

55+tests = $quickCheckAll

test/Test/Grenade/Layers/Internal/Convolution.hs+29−34

@@ -12,46 +12,41 @@ import Grenade.Layers.Internal.Convolution

1212

1313import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

1414

15−import Hedgehog

16−import qualified Hedgehog.Gen as Gen

17−import qualified Hedgehog.Range as Range

15+import Disorder.Jack

1816

1917import qualified Test.Grenade.Layers.Internal.Reference as Reference

20−import Test.Hedgehog.Compat

2118

2219prop_im2col_col2im_symmetrical_with_kernel_stride =

2320 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

21+ in gamble (choose (2, 100)) $ \height ->

22+ gamble (choose (2, 100)) $ \width ->

23+ gamble ((height `div`) <$> elements (factors height)) $ \kernel_h ->

24+ gamble ((width `div`) <$> elements (factors width)) $ \kernel_w ->

25+ gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

26+ let input' = (height >< width) input

27+ stride_h = kernel_h

28+ stride_w = kernel_w

29+ out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input'

30+ in input' === out

3531

3632prop_im2col_col2im_behaves_as_reference =

3733 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−

34+ in gamble (choose (2, 100)) $ \height ->

35+ gamble (choose (2, 100)) $ \width ->

36+ gamble (choose (2, height - 1)) $ \kernel_h ->

37+ gamble (choose (2, width - 1)) $ \kernel_w ->

38+ gamble (elements (ok height kernel_h)) $ \stride_h ->

39+ gamble (elements (ok width kernel_w)) $ \stride_w ->

40+ gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

41+ let input' = (height >< width) input

42+ outFast = im2col kernel_h kernel_w stride_h stride_w input'

43+ retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast

44+

45+ outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input'

46+ retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference

47+ in outFast === outReference .&&. retFast === retReference

48+

49+

50+return []

5651tests :: IO Bool

57−tests = checkParallel $$(discover)

52+tests = $quickCheckAll

test/Test/Grenade/Layers/Internal/Pooling.hs+18−24

@@ -12,34 +12,28 @@ import Grenade.Layers.Internal.Pooling

1212

1313import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

1414

15−import Hedgehog

16−import qualified Hedgehog.Gen as Gen

17−import qualified Hedgehog.Range as Range

15+import Disorder.Jack

1816

1917import qualified Test.Grenade.Layers.Internal.Reference as Reference

20−import Test.Hedgehog.Compat

2118

2219prop_poolForwards_poolBackwards_behaves_as_reference =

2320 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

2421 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−

22+ in gamble (choose (2, 100)) $ \height ->

23+ gamble (choose (2, 100)) $ \width ->

24+ gamble (choose (1, height - 1)) $ \kernel_h ->

25+ gamble (choose (1, width - 1)) $ \kernel_w ->

26+ gamble (elements (ok height kernel_h)) $ \stride_h ->

27+ gamble (elements (ok width kernel_w)) $ \stride_w ->

28+ gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

29+ let input' = (height >< width) input

30+ outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'

31+ retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast

32+

33+ outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'

34+ retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference

35+ in outFast === outReference .&&. retFast === retReference

36+

37+return []

4438tests :: IO Bool

45−tests = checkParallel $$(discover)

39+tests = $quickCheckAll

test/Test/Grenade/Layers/Nonlinear.hsdeleted−54

@@ -1,54 +0,0 @@

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.hsdeleted−49

@@ -1,49 +0,0 @@

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+14−19

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE TemplateHaskell #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE KindSignatures #-}

@@ -10,40 +9,36 @@ module Test.Grenade.Layers.Pooling where

109import Data.Proxy

1110import Data.Singletons ()

1211

13−#if MIN_VERSION_base(4,9,0)

14−import Data.Kind (Type)

15−#endif

16−

1712import GHC.TypeLits

1813import Grenade.Layers.Pooling

1914

20−import Hedgehog

15+import Disorder.Jack

2116

22−import Test.Hedgehog.Compat

2317

24−data OpaquePooling :: Type where

18+data OpaquePooling :: * where

2519 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

2620

2721instance Show OpaquePooling where

2822 show (OpaquePooling n) = show n

2923

30−genOpaquePooling :: Gen OpaquePooling

24+genOpaquePooling :: Jack OpaquePooling

3125genOpaquePooling = do

32− ~(Just kernelHeight) <- someNatVal <$> choose 2 15

33− ~(Just kernelWidth ) <- someNatVal <$> choose 2 15

34− ~(Just strideHeight) <- someNatVal <$> choose 2 15

35− ~(Just strideWidth ) <- someNatVal <$> choose 2 15

26+ Just kernelHeight <- someNatVal <$> choose (2, 15)

27+ Just kernelWidth <- someNatVal <$> choose (2, 15)

28+ Just strideHeight <- someNatVal <$> choose (2, 15)

29+ Just strideWidth <- someNatVal <$> choose (2, 15)

3630

3731 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

3832 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

3933 return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)

4034

4135prop_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

36+ gamble genOpaquePooling $ \onet ->

37+ (case onet of

38+ (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) -> True

39+ ) :: Bool

40+

4741

42+return []

4843tests :: IO Bool

49−tests = checkParallel $$(discover)

44+tests = $quickCheckAll

test/Test/Grenade/Network.hsdeleted−504

@@ -1,504 +0,0 @@

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.hs+54−83

@@ -10,10 +10,7 @@

1010{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

1111module Test.Grenade.Recurrent.Layers.LSTM where

1212

13−import Hedgehog

14−import Hedgehog.Internal.Source

15−import Hedgehog.Internal.Show

16−import Hedgehog.Internal.Property ( failWith, Diff (..) )

13+import Disorder.Jack

1714

1815import Data.Foldable ( toList )

1916import Data.Singletons.TypeLits

@@ -26,9 +23,9 @@ import qualified Numeric.LinearAlgebra.Static as S

2623

2724

2825import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

29−import Test.Hedgehog.Hmatrix

26+import Test.Jack.Hmatrix

3027

31−genLSTM :: forall i o. (KnownNat i, KnownNat o) => Gen (LSTM i o)

28+genLSTM :: forall i o. (KnownNat i, KnownNat o) => Jack (LSTM i o)

3229genLSTM = do

3330 let w = uniformSample

3431 u = uniformSample

@@ -42,89 +39,63 @@ genLSTM = do

4239 <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

4340

4441prop_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−

42+ gamble randomVector $ \(input :: S.R 3) ->

43+ gamble randomVector $ \(cell :: S.R 2) ->

44+ gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

45+ let actual = runRecurrentForwards net (S1D cell) (S1D input)

46+ in case actual of

47+ ((S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->

48+ let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut

49+ output' = Reference.Vector . H.toList . S.extract $ output

50+ refNet = Reference.lstmToReference lstmWeights

51+ refCell = Reference.Vector . H.toList . S.extract $ cell

52+ refInput = Reference.Vector . H.toList . S.extract $ input

53+ (refCO, refO) = Reference.runLSTM refNet refCell refInput

54+ in toList refCO ~~~ toList cellOut' .&&. toList refO ~~~ toList output'

6255

6356prop_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)

57+ gamble randomVector $ \(input :: S.R 3) ->

58+ gamble randomVector $ \(cell :: S.R 2) ->

59+ gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

60+ let actualBacks = runRecurrentBackwards net (S1D cell) (S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

61+ in case actualBacks of

62+ (actualGradients, _, _) ->

63+ let refNet = Reference.lstmToReference lstmWeights

64+ refCell = Reference.Vector . H.toList . S.extract $ cell

65+ refInput = Reference.Vector . H.toList . S.extract $ input

66+ refGradients = Reference.runLSTMback refCell refInput refNet

67+ in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)

7868

7969prop_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)

70+ gamble randomVector $ \(input :: S.R 3) ->

71+ gamble randomVector $ \(cell :: S.R 2) ->

72+ gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

73+ let actualBacks = runRecurrentBackwards net (S1D cell) (S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

74+ in case actualBacks of

75+ (_, _, S1D actualGradients) ->

76+ let refNet = Reference.lstmToReference lstmWeights

77+ refCell = Reference.Vector . H.toList . S.extract $ cell

78+ refInput = Reference.Vector . H.toList . S.extract $ input

79+ refGradients = Reference.runLSTMbackOnInput refCell refNet refInput

80+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

9481

9582prop_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) ""

83+ gamble randomVector $ \(input :: S.R 3) ->

84+ gamble randomVector $ \(cell :: S.R 2) ->

85+ gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

86+ let actualBacks = runRecurrentBackwards net (S1D cell) (S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

87+ in case actualBacks of

88+ (_, S1D actualGradients, _) ->

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.runLSTMbackOnCell refInput refNet refCell

93+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

94+

95+

96+(~~~) as bs = all (< 1e-8) (zipWith (-) as bs)

12797infix 4 ~~~

12898

99+return []

129100tests :: IO Bool

130−tests = checkParallel $$(discover)

101+tests = $quickCheckAll

test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+21−25

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

66{-# LANGUAGE DeriveFunctor #-}

77{-# LANGUAGE DeriveFoldable #-}

88{-# LANGUAGE DeriveTraversable #-}

9+{-# LANGUAGE RecordWildCards #-}

910{-# LANGUAGE FlexibleContexts #-}

1011{-# LANGUAGE RankNTypes #-}

1112

@@ -14,13 +15,9 @@ module Test.Grenade.Recurrent.Layers.LSTM.Reference where

1415

1516import Data.Reflection

1617import Numeric.AD.Mode.Reverse

17−import Numeric.AD.Internal.Reverse (Tape)

18+import Numeric.AD.Internal.Reverse ( Tape )

1819

19−import GHC.TypeLits (KnownNat)

20−

21−import Grenade.Recurrent.Layers.LSTM (LSTMWeights (..))

2220import qualified Grenade.Recurrent.Layers.LSTM as LSTM

23−

2421import qualified Numeric.LinearAlgebra.Static as S

2522import qualified Numeric.LinearAlgebra as H

2623

@@ -57,32 +54,31 @@ data RefLSTM a = RefLSTM

5754 , refLstmBc :: Vector a -- Bias Cell (b_c)

5855 } deriving (Functor, Foldable, Traversable, Eq, Show)

5956

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− }

57+lstmToReference :: LSTM.LSTMWeights a b -> RefLSTM Double

58+lstmToReference LSTM.LSTMWeights {..} =

59+ let refLstmWf = Matrix . H.toLists . S.extract $ lstmWf -- Weight Forget (W_f)

60+ refLstmUf = Matrix . H.toLists . S.extract $ lstmUf -- Cell State Forget (U_f)

61+ refLstmBf = Vector . H.toList . S.extract $ lstmBf -- Bias Forget (b_f)

62+ refLstmWi = Matrix . H.toLists . S.extract $ lstmWi -- Weight Input (W_i)

63+ refLstmUi = Matrix . H.toLists . S.extract $ lstmUi -- Cell State Input (U_i)

64+ refLstmBi = Vector . H.toList . S.extract $ lstmBi -- Bias Input (b_i)

65+ refLstmWo = Matrix . H.toLists . S.extract $ lstmWo -- Weight Output (W_o)

66+ refLstmUo = Matrix . H.toLists . S.extract $ lstmUo -- Cell State Output (U_o)

67+ refLstmBo = Vector . H.toList . S.extract $ lstmBo -- Bias Output (b_o)

68+ refLstmWc = Matrix . H.toLists . S.extract $ lstmWc -- Weight Cell (W_c)

69+ refLstmBc = Vector . H.toList . S.extract $ lstmBc -- Bias Cell (b_c)

70+ in RefLSTM {..}

7571

7672runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

77−runLSTM rl cell input =

73+runLSTM RefLSTM {..} cell input =

7874 let -- Forget state vector

79− f_t = sigmoid $ refLstmBf rl #+ refLstmWf rl #> input #+ refLstmUf rl #> cell

75+ f_t = sigmoid $ refLstmBf #+ refLstmWf #> input #+ refLstmUf #> cell

8076 -- Input state vector

81− i_t = sigmoid $ refLstmBi rl #+ refLstmWi rl #> input #+ refLstmUi rl #> cell

77+ i_t = sigmoid $ refLstmBi #+ refLstmWi #> input #+ refLstmUi #> cell

8278 -- Output state vector

83− o_t = sigmoid $ refLstmBo rl #+ refLstmWo rl #> input #+ refLstmUo rl #> cell

79+ o_t = sigmoid $ refLstmBo #+ refLstmWo #> input #+ refLstmUo #> cell

8480 -- Cell input state vector

85− c_x = fmap tanh $ refLstmBc rl #+ refLstmWc rl #> input

81+ c_x = fmap tanh $ refLstmBc #+ refLstmWc #> input

8682 -- Cell state

8783 c_t = f_t #* cell #+ i_t #* c_x

8884 -- Output (it's sometimes recommended to use tanh c_t)

test/Test/Hedgehog/Compat.hsdeleted−21

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

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.hsdeleted−42

@@ -1,42 +0,0 @@

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.hsdeleted−65

@@ -1,65 +0,0 @@

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/Jack/Hmatrix.hsnew file+29

@@ -0,0 +1,29 @@

1+{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE GADTs #-}

5+

6+module Test.Jack.Hmatrix where

7+

8+import Grenade

9+import Data.Singletons

10+

11+import Disorder.Jack

12+

13+import GHC.TypeLits

14+

15+import qualified Numeric.LinearAlgebra.Static as HStatic

16+

17+randomVector :: forall n. KnownNat n => Jack (HStatic.R n)

18+randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> sizedNat

19+

20+uniformSample :: forall m n. (KnownNat m, KnownNat n) => Jack (HStatic.L m n)

21+uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> sizedNat

22+

23+-- | Generate random data of the desired shape

24+genOfShape :: forall x. ( SingI x ) => Jack (S x)

25+genOfShape =

26+ case (sing :: Sing x) of

27+ D1Sing -> S1D <$> randomVector

28+ D2Sing -> S2D <$> uniformSample

29+ D3Sing -> S3D <$> uniformSample

test/Test/Jack/TypeLits.hsnew file+47

@@ -0,0 +1,47 @@

1+{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+

5+module Test.Jack.TypeLits where

6+

7+import Data.Constraint

8+import Data.Singletons

9+import Disorder.Jack

10+

11+import Grenade

12+

13+import GHC.TypeLits

14+import GHC.TypeLits.Witnesses

15+

16+genNat :: Jack SomeNat

17+genNat = do

18+ Just n <- someNatVal <$> choose (1, 10)

19+ return n

20+

21+genShape :: Jack (SomeSing Shape)

22+genShape

23+ = oneOf [

24+ genD1

25+ , genD2

26+ , genD3

27+ ]

28+ where

29+ genD1 = do

30+ n <- genNat

31+ return $ case n of

32+ SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

33+

34+ genD2 = do

35+ n <- genNat

36+ m <- genNat

37+ return $ case (n, m) of

38+ (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

39+

40+ genD3 = do

41+ n <- genNat

42+ m <- genNat

43+ o <- genNat

44+ return $ case (n, m, o) of

45+ (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->

46+ case natDict px %* natDict pz of

47+ Dict -> SomeSing (sing :: Sing ('D3 x y z))

test/test.hs+2−24

@@ -1,47 +1,25 @@

1−import Control.Monad

2−

3−import qualified Test.Grenade.Network

1+import Disorder.Core.Main

42

53import qualified Test.Grenade.Layers.Pooling

64import qualified Test.Grenade.Layers.Convolution

75import qualified Test.Grenade.Layers.FullyConnected

86import qualified Test.Grenade.Layers.Nonlinear

9−import qualified Test.Grenade.Layers.PadCrop

107

118import qualified Test.Grenade.Layers.Internal.Convolution

129import qualified Test.Grenade.Layers.Internal.Pooling

1310

1411import qualified Test.Grenade.Recurrent.Layers.LSTM

1512

16−import System.Exit

17−import System.IO

18−

1913main :: IO ()

2014main =

2115 disorderMain [

22− Test.Grenade.Network.tests

23−

24− , Test.Grenade.Layers.Pooling.tests

16+ Test.Grenade.Layers.Pooling.tests

2517 , Test.Grenade.Layers.Convolution.tests

2618 , Test.Grenade.Layers.FullyConnected.tests

2719 , Test.Grenade.Layers.Nonlinear.tests

28− , Test.Grenade.Layers.PadCrop.tests

2920

3021 , Test.Grenade.Layers.Internal.Convolution.tests

3122 , Test.Grenade.Layers.Internal.Pooling.tests

3223

3324 , Test.Grenade.Recurrent.Layers.LSTM.tests

34−

3525 ]

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