master..7d476bf · grenade

.gitignore+1−3

since splitsnapshots

unifiedsplit

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

1−cabal.project.local

2.cabal-sandbox/

1.cabal-sandbox/

3cabal.sandbox.config

2cabal.sandbox.config

4dist/

3dist/

5−dist-newstyle/

4+

6−.stack-work/

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

2All rights reserved.

3

4Redistribution 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 @@

1Grenade

2=======

3

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

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

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

7−

8−

9```

4```

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

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

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

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

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

15

10

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

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

17

12

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

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

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

20

15

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

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

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

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

23```haskell

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

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]

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

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]

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

31− , 'D1 80, 'D1 80, 'D1 10, 'D1 10]

32

21

33randomMnist :: MonadRandom m => m MNIST

22randomMnist :: MonadRandom m => m MNIST

34randomMnist = randomNetwork

23randomMnist = randomNetwork

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

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

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

43with

32with

44```haskell

33```haskell

45−type Shakespeare

46− = RecurrentNetwork

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

34+type Shakespeare = RecurrentNetwork '[ 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 ]

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

49```

36```

50

37

51Design

38Design

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

58The definition of a network is surprisingly simple:

45The definition of a network is surprisingly simple:

59```haskell

46```haskell

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

47data Network :: [*] -> [Shape] -> * where

61− NNil :: SingI i

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

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

63−

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

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

65− => !x

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

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

68```

50```

69

51

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

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

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

89```

71```

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

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

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

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

93have no learnable parameters.

75have no learnable parameters.

94

76

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

77The 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

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

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

104it will result in a compile time error.

86it will result in a compile time error.

105

87

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−

145Build Instructions

88Build Instructions

146------------------

89------------------

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)

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

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

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

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

150build using:

93build using:

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

159./mafia test

102./mafia test

160```

103```

161

104

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.

163

106

164Thanks

107Thanks

165------

108------

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

185Contributing

128Contributing

186------------

129------------

187Contributions are welcome.

130Contributions 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+45−4

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

5

6import Grenade

7import Grenade.Recurrent

8+import Grenade.Layers.Internal.Update

9+

10+import qualified Numeric.LinearAlgebra.Static as H

8

11

9main :: IO ()

12main :: IO ()

10main = do

13main = do

14+ layer60 :: LSTM 40 60 <- createRandom

15+ layer512 :: LSTM 40 512 <- createRandom

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

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

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

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

12− lstm :: RecNet <- randomRecurrent

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

13

23

14 defaultMain [

24 defaultMain [

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

26+ , bench "forwards-512" $ nf (nfT3 . 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+ ]

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

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

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

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

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

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

18 ]

36 ]

19 ]

37 ]

20

38

39+testRun60 :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> ((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' = curry . runRecurrentBackwards

44+

45+testRun512 :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> ((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' = curry . 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+

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

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

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

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

23

59

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

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

62+

24

63

25type R = Recurrent

64type R = Recurrent

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

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

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

66 '[ 'D1 40, 'D1 512, 'D1 40 ]

28

67

68+type RecInput = RecurrentInputs '[ R (LSTM 40 512), R (LSTM 512 40) ]

69+

29lp :: LearningParameters

70lp :: LearningParameters

30lp = LearningParameters 0.1 0 0

71lp = LearningParameters 0.1 0 0

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

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

1−#include "gradient_descent.h"

1+#include "gradient_decent.h"

2

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

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

4 const double* weights,

5 const double* gradient,

6 const double* last,

7 double* outputWeights, double* outputMomentum) {

8

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

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

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

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

12 }

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

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

1#include <stdio.h>

2#include <stdint.h>

3

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

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

5 const double* weights,

6 const double* gradient,

7 const double* last,

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+123−113

@@ -1,69 +1,46 @@

1name: grenade

2−version: 0.1.0

2+version: 0.0.1

3license: BSD2

4−license-file: LICENSE

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

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

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

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

8−synopsis: Practical Deep Learning in Haskell

7+synopsis: grenade

9−category: AI, Machine Learning

8+category: System

10−cabal-version: >= 1.10

9+cabal-version: >= 1.8

11build-type: Simple

10build-type: Simple

12−description:

11+description: grenade.

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

14− recurrent neural network library for precise specifications and

15− complex deep neural networks in Haskell.

16− .

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

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

19− networks with reverse automatic differentiation to calculate their

20− gradients; and applying gradient descent for learning.

21− .

22− Documentation and examples are available on github

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

24

12

25extra-source-files:

13extra-source-files:

26− README.md

27− cbits/im2col.h

14+ cbits/im2col.h

28− cbits/im2col.c

15+ cbits/im2col.c

29− cbits/gradient_descent.h

16+ cbits/gradient_decent.h

30− cbits/gradient_descent.c

17+ cbits/gradient_decent.c

31− cbits/pad.h

18+ cbits/pad.h

32− cbits/pad.c

19+ cbits/pad.c

33−

34−source-repository head

35− type: git

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

37

20

38library

21library

39 build-depends:

22 build-depends:

40 base >= 4.8 && < 5

23 base >= 4.8 && < 5

41− , bytestring >= 0.10.0

24+ , bytestring == 0.10.*

42− , containers >= 0.5 && < 0.7

25+ , containers

43− , cereal >= 0.5 && < 0.6

44− , deepseq >= 1.4 && < 1.5

26+ , deepseq

27+ , either == 4.4.*

28+ , cereal

29+ , exceptions == 0.8.*

45− , hmatrix >= 0.18 && < 0.21

30+ , hmatrix == 0.18.*

46− , MonadRandom >= 0.4 && < 0.6

31+ , MonadRandom

32+ , mtl >= 2.2.1 && < 2.3

47− , primitive >= 0.6 && < 0.8

33+ , primitive

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

34+ , text == 1.2.*

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

35+ , transformers

50− , singletons

36+ , singletons >= 2.1 && < 2.3

51− , singletons-base

52− , vector >= 0.11 && < 0.13

37+ , vector == 0.11.*

53

38

54 ghc-options:

39 ghc-options:

55 -Wall

40 -Wall

56 hs-source-dirs:

41 hs-source-dirs:

57 src

42 src

58

43

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

67

44

68 exposed-modules:

45 exposed-modules:

69 Grenade

46 Grenade

@@ -73,26 +50,19 @@ library

73 Grenade.Core.Network

50 Grenade.Core.Network

74 Grenade.Core.Runner

51 Grenade.Core.Runner

75 Grenade.Core.Shape

52 Grenade.Core.Shape

76−

77− Grenade.Layers

53+ Grenade.Layers.Crop

78 Grenade.Layers.Concat

54 Grenade.Layers.Concat

79 Grenade.Layers.Convolution

55 Grenade.Layers.Convolution

80− Grenade.Layers.Crop

81− Grenade.Layers.Deconvolution

82 Grenade.Layers.Dropout

56 Grenade.Layers.Dropout

83− Grenade.Layers.Elu

84 Grenade.Layers.FullyConnected

57 Grenade.Layers.FullyConnected

85− Grenade.Layers.Inception

58+ Grenade.Layers.Reshape

86 Grenade.Layers.Logit

59 Grenade.Layers.Logit

87 Grenade.Layers.Merge

60 Grenade.Layers.Merge

88− Grenade.Layers.Pad

89− Grenade.Layers.Pooling

90 Grenade.Layers.Relu

61 Grenade.Layers.Relu

91− Grenade.Layers.Reshape

62+ Grenade.Layers.Elu

92− Grenade.Layers.Sinusoid

93− Grenade.Layers.Softmax

94 Grenade.Layers.Tanh

63 Grenade.Layers.Tanh

95− Grenade.Layers.Trivial

64+ Grenade.Layers.Pad

65+ Grenade.Layers.Pooling

96

66

97 Grenade.Layers.Internal.Convolution

67 Grenade.Layers.Internal.Convolution

98 Grenade.Layers.Internal.Pad

68 Grenade.Layers.Internal.Pad

@@ -101,79 +71,123 @@ library

101

71

102 Grenade.Recurrent

72 Grenade.Recurrent

103

73

104− Grenade.Recurrent.Core

105− Grenade.Recurrent.Core.Layer

106 Grenade.Recurrent.Core.Network

74 Grenade.Recurrent.Core.Network

107 Grenade.Recurrent.Core.Runner

75 Grenade.Recurrent.Core.Runner

108

76

109− Grenade.Recurrent.Layers

110 Grenade.Recurrent.Layers.BasicRecurrent

77 Grenade.Recurrent.Layers.BasicRecurrent

111− Grenade.Recurrent.Layers.ConcatRecurrent

112 Grenade.Recurrent.Layers.LSTM

78 Grenade.Recurrent.Layers.LSTM

113

79

114 Grenade.Utils.OneHot

80 Grenade.Utils.OneHot

115

81

116− includes: cbits/im2col.h

82+ includes: cbits/im2col.h

117− cbits/gradient_descent.h

83+ cbits/gradient_decent.h

118− cbits/pad.h

84+ cbits/pad.h

119− c-sources: cbits/im2col.c

85+ c-sources: cbits/im2col.c

120− cbits/gradient_descent.c

86+ cbits/gradient_decent.c

121− cbits/pad.c

87+ cbits/pad.c

122

88

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

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

124

90

125−test-suite test

91+executable feedforward

126− type: exitcode-stdio-1.0

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

93+ main-is: main/feedforward.hs

94+ build-depends: base

95+ , grenade

96+ , attoparsec

97+ , bytestring

98+ , cereal

99+ , either

100+ , optparse-applicative == 0.13.*

101+ , text == 1.2.*

102+ , mtl >= 2.2.1 && < 2.3

103+ , hmatrix

104+ , transformers

105+ , singletons

106+ , semigroups

107+ , MonadRandom

127

108

128− main-is: test.hs

109+executable mnist

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

111+ main-is: main/mnist.hs

112+ build-depends: base

113+ , grenade

114+ , attoparsec

115+ , either

116+ , optparse-applicative == 0.13.*

117+ , text == 1.2.*

118+ , mtl >= 2.2.1 && < 2.3

119+ , hmatrix >= 0.18 && < 0.19

120+ , transformers

121+ , semigroups

122+ , singletons

123+ , MonadRandom

124+ , vector

129

125

126+executable recurrent

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

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

128+ main-is: main/recurrent.hs

129+ build-depends: base

130+ , grenade

131+ , attoparsec

132+ , either

133+ , optparse-applicative == 0.13.*

134+ , text == 1.2.*

135+ , mtl >= 2.2.1 && < 2.3

136+ , hmatrix >= 0.18 && < 0.19

137+ , transformers

138+ , semigroups

139+ , singletons

140+ , MonadRandom

131

141

132− hs-source-dirs:

133− test

134

142

135− default-language: Haskell2010

143+executable shakespeare

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

145+ main-is: main/shakespeare.hs

146+ build-depends: base

147+ , grenade

148+ , attoparsec

149+ , bytestring

150+ , cereal

151+ , either

152+ , optparse-applicative == 0.13.*

153+ , text == 1.2.*

154+ , mtl >= 2.2.1 && < 2.3

155+ , hmatrix >= 0.18 && < 0.19

156+ , transformers

157+ , semigroups

158+ , singletons

159+ , vector

160+ , MonadRandom

161+ , containers

136

162

137− other-modules: Test.Hedgehog.Compat

138− Test.Hedgehog.Hmatrix

139− Test.Hedgehog.TypeLits

140

163

141− Test.Grenade.Network

164+test-suite test

142− Test.Grenade.Layers.Convolution

165+ type: exitcode-stdio-1.0

143− Test.Grenade.Layers.FullyConnected

144− Test.Grenade.Layers.Nonlinear

145− Test.Grenade.Layers.PadCrop

146− Test.Grenade.Layers.Pooling

147− Test.Grenade.Layers.Internal.Convolution

148− Test.Grenade.Layers.Internal.Pooling

149− Test.Grenade.Layers.Internal.Reference

150

166

151− Test.Grenade.Recurrent.Layers.LSTM

167+ main-is: test.hs

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

153

168

154− if impl(ghc < 8.0)

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

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

156− cpp-options: -DType=*

157

170

158− if impl(ghc >= 8.6)

171+ hs-source-dirs:

159− default-extensions: NoStarIsType

172+ test

160

173

161 build-depends:

174 build-depends:

162− base

175+ base >= 4.8 && < 5

163 , grenade

176 , grenade

164− , hedgehog >= 1.0 && < 1.1

177+ , ambiata-disorder-core

178+ , ambiata-disorder-jack

165 , hmatrix

179 , hmatrix

166 , mtl

180 , mtl

167 , singletons

181 , singletons

168 , text == 1.2.*

182 , text == 1.2.*

169− , typelits-witnesses < 0.4

183+ , typelits-witnesses

170− , transformers

171 , constraints

184 , constraints

185+ , QuickCheck >= 2.7 && < 2.9

186+ , quickcheck-instances == 0.3.*

172 , MonadRandom

187 , MonadRandom

173 , random

188 , random

174 , ad

189 , ad

175 , reflection

190 , reflection

176− , vector

177

191

178

192

179benchmark bench

193benchmark bench

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

186 hs-source-dirs:

200 hs-source-dirs:

187 bench

201 bench

188

202

189− default-language: Haskell2010

190−

191 build-depends:

203 build-depends:

192− base

204+ base >= 3 && < 5

193− , bytestring

205+ , bytestring == 0.10.*

194− , criterion >= 1.1 && < 1.6

206+ , criterion == 1.1.*

195 , grenade

207 , grenade

196 , hmatrix

208 , hmatrix

197

209

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

205 hs-source-dirs:

217 hs-source-dirs:

206 bench

218 bench

207

219

208− default-language: Haskell2010

209−

210 build-depends:

220 build-depends:

211− base

221+ base >= 3 && < 5

212− , bytestring

222+ , bytestring == 0.10.*

213− , criterion

223+ , criterion == 1.1.*

214 , grenade

224 , grenade

215 , hmatrix

225 , 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−3

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

11

10

12import qualified Data.ByteString as B

11import qualified Data.ByteString as B

13import Data.Serialize

12import Data.Serialize

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

15import Data.Semigroup ( (<>) )

13import Data.Semigroup ( (<>) )

16−#endif

14+

17import GHC.TypeLits

15import GHC.TypeLits

18

16

19import qualified Numeric.LinearAlgebra.Static as SA

17import qualified Numeric.LinearAlgebra.Static as SA

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

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TupleSections #-}

5{-# LANGUAGE TupleSections #-}

7{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

9−

10import Control.Applicative

8import Control.Applicative

11import Control.Monad

9import Control.Monad

12import Control.Monad.Random

10import Control.Monad.Random

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

14

12

15import qualified Data.Attoparsec.Text as A

13import qualified Data.Attoparsec.Text as A

16import Data.List ( foldl' )

14import Data.List ( foldl' )

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

18import Data.Semigroup ( (<>) )

15import Data.Semigroup ( (<>) )

19−#endif

20−

21import qualified Data.Text as T

16import qualified Data.Text as T

22import qualified Data.Text.IO as T

17import qualified Data.Text.IO as T

23import qualified Data.Vector.Storable as V

18import qualified Data.Vector.Storable as V

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

30import Grenade

25import Grenade

31import Grenade.Utils.OneHot

26import Grenade.Utils.OneHot

32

27

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−

42-- The definition of our convolutional neural network.

28-- The definition of our convolutional neural network.

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

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

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

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

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

48

34

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

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

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

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

51−--

37+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, Reshape, Relu, FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]

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

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

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

54−--

55−type MNIST =

56− Network

57− '[ Reshape,

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

59− Pooling 2 2 2 2, Relu,

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

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

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

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

64− 'D3 12 12 18, 'D3 4 4 18, 'D3 4 4 18,

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

66

39

67randomMnist :: MonadRandom m => m MNIST

40randomMnist :: MonadRandom m => m MNIST

68randomMnist = randomNetwork

41randomMnist = randomNetwork

examples/main/recurrent.hs → main/recurrent.hsrenamed+11−10

@@ -9,12 +9,12 @@

9import Control.Monad ( foldM )

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

11

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

12+#if __GLASGOW_HASKELL__ < 800

13import Data.List ( unfoldr )

14#else

15import Data.List ( cycle, unfoldr )

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

17#endif

16#endif

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

18

19import qualified Numeric.LinearAlgebra.Static as SA

20

@@ -23,6 +23,7 @@ import Options.Applicative

23import Grenade

24import Grenade.Recurrent

25

26+{-# OPTIONS_GHC -fno-redundant-imports #-}

26-- The defininition for our simple recurrent network.

27-- The defininition for our simple recurrent network.

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

28-- This file just trains a network to generate a repeating sequence

28-- of 0 0 1.

29-- of 0 0 1.

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

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

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

32type R = Recurrent

33type R = Recurrent

33

34

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

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

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

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

36

37

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

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

38

39

39−randomNet :: MonadRandom m => m RecNet

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

40randomNet = randomRecurrent

41randomNet = randomRecurrent

41

42

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

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

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

69 unfoldr go (s, i)

70 unfoldr go (s, i)

70 where

71 where

71 go (x, y) =

72 go (x, y) =

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

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

73− o' = heat o

74+ o' = heat o

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

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

75

76

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

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

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

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

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

83 putStrLn "Training network..."

84 putStrLn "Training network..."

84

85

85− net0 <- randomNet

86+ (net0, i0) <- randomNet

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

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

87

88

88 let results = generateRecurrent trained bestInput (c 1)

89 let results = generateRecurrent trained bestInput (c 1)

89

90

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

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

2+{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

@@ -13,16 +13,18 @@ import Control.Monad.Trans.Except

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

14import Data.List ( foldl' )

15import Data.Maybe ( fromMaybe )

16−

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

17

18import qualified Data.Vector as V

19import Data.Vector ( Vector )

20

21import qualified Data.Map as M

22+import Data.Proxy ( Proxy (..) )

22

23

23import qualified Data.ByteString as B

24import qualified Data.ByteString as B

24import Data.Serialize

25import Data.Serialize

25

26

27+import Data.Singletons.Prelude

26import GHC.TypeLits

28import GHC.TypeLits

27

29

28import Numeric.LinearAlgebra.Static ( konst )

30import Numeric.LinearAlgebra.Static ( konst )

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

34import Grenade.Utils.OneHot

36import Grenade.Utils.OneHot

35

37

36import System.IO.Unsafe ( unsafeInterleaveIO )

38import System.IO.Unsafe ( unsafeInterleaveIO )

37−import Data.Proxy

38−import Prelude.Singletons

39

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

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

42-- about an hour.

43--

44−-- Grab the input from

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

46−--

47-- This is a first class recurrent net.

44-- This is a first class recurrent net.

48--

45--

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

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

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

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

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

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

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

66

63

67−randomNet :: MonadRandom m => m Shakespeare

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

68randomNet = randomRecurrent

65randomNet = randomRecurrent

69

66

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

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

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

72loadShakespeare path = do

69loadShakespeare path = do

73 contents <- lift $ readFile path

70 contents <- lift $ readFile path

74 let annotated = annotateCapitals contents

71 let annotated = annotateCapitals contents

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

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

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

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

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

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

78

75

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

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

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

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

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

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

82 in case reverse e of

79 in case reverse e of

83 (o : l : xs) ->

80 (o : l : xs) ->

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

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

85− in trainRecurrent lrate net recIns examples

82+ in trainRecurrent rate net recIns examples

86 _ -> error "Not enough input"

83 _ -> error "Not enough input"

87 where

84 where

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

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

89

86

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

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

91−runShakespeare opts = do

88+runShakespeare ShakespeareOpts {..} = do

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

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

93 (net0, i0) <- lift $

90 (net0, i0) <- lift $

94− case loadPath opts of

91+ case loadPath of

95 Just loadFile -> netLoad loadFile

92 Just loadFile -> netLoad loadFile

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

93+ Nothing -> randomNet

97

94

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

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

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

96+ xs <- take (iterations `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

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

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

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

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

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

103 putStrLn (unAnnotateCapitals results)

100 putStrLn (unAnnotateCapitals results)

104 return (trained, bestInput)

101 return (trained, bestInput)

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

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

106

103

107− case savePath opts of

104+ case savePath of

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

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

109 Nothing -> return ()

106 Nothing -> return ()

110

107

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

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

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

116 -> Vector a

113 -> Vector a

117 -> S ('D1 n)

114 -> S ('D1 n)

118 -> IO [a]

115 -> IO [a]

119−generateParagraph n s temp hotmap hotdict =

116+generateParagraph n s temperature hotmap hotdict =

120 go s

117 go s

121 where

118 where

122 go x y =

119 go x y =

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

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

124− un <- sample temp hotdict o

121+ un <- sample temperature hotdict o

125− Just re <- return $ makeHot hotmap un

122+ Just re <- return $ makeHot hotmap un

126− rest <- unsafeInterleaveIO $ go ns re

123+ rest <- unsafeInterleaveIO $ go ns re

127 return (un : rest)

124 return (un : rest)

128

125

129data ShakespeareOpts = ShakespeareOpts {

126data ShakespeareOpts = ShakespeareOpts {

src/Grenade.hs+20−50

@@ -1,53 +1,23 @@

1module Grenade (

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

3− -- for machine learning with Grenade.

4−

5− -- * Exported modules

6− --

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

8− module Grenade.Core

2+ module X

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−

20 ) where

3 ) where

21

4

22−import Grenade.Core

5+import Grenade.Core.LearningParameters as X

23−import Grenade.Layers

6+import Grenade.Core.Layer as X

24−

7+import Grenade.Core.Network as X

25−{- $library

8+import Grenade.Core.Runner as X

26−Grenade is a purely functional deep learning library.

9+import Grenade.Core.Shape as X

27−

10+import Grenade.Layers.Concat as X

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

11+import Grenade.Layers.Crop as X

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

12+import Grenade.Layers.Dropout as X

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

13+import Grenade.Layers.Pad as X

31−the hmatrix library.

14+import Grenade.Layers.Pooling as X

32−

15+import Grenade.Layers.Reshape as X

33−-}

16+import Grenade.Layers.FullyConnected as X

34−

17+import Grenade.Layers.Logit as X

35−{- $example

18+import Grenade.Layers.Merge as X

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

19+import Grenade.Layers.Convolution as X

37−under the examples folder.

20+import Grenade.Layers.Relu as X

38−

21+import Grenade.Layers.Elu as X

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

22+import Grenade.Layers.Tanh as X

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

23+import Grenade.Layers.Softmax as X

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

42−

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

44−>

45−> randomMyNet :: MonadRandom MyNet

46−> randomMyNet = randomNetwork

47−

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

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

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

51−-}

52−

53−

src/Grenade/Core.hs+5−10

@@ -1,13 +1,8 @@

1module Grenade.Core (

2− module Grenade.Core.Layer

2+ module X

3− , module Grenade.Core.LearningParameters

4− , module Grenade.Core.Network

5− , module Grenade.Core.Runner

6− , module Grenade.Core.Shape

7 ) where

3 ) where

8

4

9−import Grenade.Core.Layer

5+import Grenade.Core.Layer as X

10−import Grenade.Core.LearningParameters

6+import Grenade.Core.LearningParameters as X

11−import Grenade.Core.Network

12−import Grenade.Core.Runner

13−import Grenade.Core.Shape

7+import Grenade.Core.Shape as X

8+import Grenade.Core.Network as X

src/Grenade/Core/Layer.hs+11−43

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

@@ -8,30 +7,11 @@

8{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FlexibleInstances #-}

10{-|

9{-|

11−Module : Grenade.Core.Layer

10+Module : Grenade.Core.Network

12−Description : Defines the Layer Classes

11+Description : Core definition a simple neural etwork

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

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

14License : BSD2

13License : BSD2

15Stability : experimental

14Stability : 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-}

15-}

36module Grenade.Core.Layer (

16module Grenade.Core.Layer (

37 Layer (..)

17 Layer (..)

@@ -42,21 +22,15 @@ import Control.Monad.Random ( MonadRandom )

42

22

43import Data.List ( foldl' )

23import Data.List ( foldl' )

44

24

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

46−import Data.Kind (Type)

47−#endif

48−

49import Grenade.Core.Shape

25import Grenade.Core.Shape

50import Grenade.Core.LearningParameters

26import Grenade.Core.LearningParameters

51

27

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

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

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

29+-- shape independent.

54−--

55class UpdateLayer x where

30class UpdateLayer x where

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

31 -- | The type for the gradient for this layer.

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

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

58− type Gradient x :: Type

33+ type Gradient x :: *

59−

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

34 -- | Update a layer with its gradient and learning parameters

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

35 runUpdate :: LearningParameters -> x -> Gradient x -> x

62

36

@@ -70,23 +44,17 @@ class UpdateLayer x where

70 {-# MINIMAL runUpdate, createRandom #-}

44 {-# MINIMAL runUpdate, createRandom #-}

71

45

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

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

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

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

74−-- appropriate.

75−--

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

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

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

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

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

50 -- to generate the back propagated gradients efficiently. As a

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

51 -- default, `S i` is fine.

80− type Tape x i o :: Type

52+ type Tape x i o :: *

81−

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

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

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

54 -- layer, and give the output from this layer.

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

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

85−

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

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

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

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

88− -- from the layer above.

58+ -- the layer above.

89− --

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

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

91− -- further.

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

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

src/Grenade/Core/LearningParameters.hs−11

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

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

8module Grenade.Core.LearningParameters (

1module 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 (..)

2 LearningParameters (..)

14 ) where

3 ) where

15

4

src/Grenade/Core/Network.hs+64−111

@@ -10,50 +10,48 @@

10{-# LANGUAGE FlexibleInstances #-}

11{-|

12Module : Grenade.Core.Network

13−Description : Core definition of a Neural Network

13+Description : Core definition a simple neural etwork

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

15License : BSD2

16Stability : experimental

17

18−This module defines the core data types and functions

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

19−for non-recurrent neural networks.

19+Neural network we support.

20+

20-}

21-}

21

22

23+#if __GLASGOW_HASKELL__ < 800

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

25+#endif

26+

22module Grenade.Core.Network (

27module Grenade.Core.Network (

23 Network (..)

28 Network (..)

24 , Gradients (..)

29 , Gradients (..)

25 , Tapes (..)

30 , Tapes (..)

31+ , CreatableNetwork (..)

26

32

27− , runNetwork

28− , runGradient

29 , applyUpdate

33 , applyUpdate

30−

31− , randomNetwork

32 ) where

34 ) where

33

35

34import Control.Monad.Random ( MonadRandom )

36import Control.Monad.Random ( MonadRandom )

35

37

36import Data.Singletons

38import Data.Singletons

39+import Data.Singletons.Prelude

37import Data.Serialize

40import Data.Serialize

38

41

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

40−import Data.Kind (Type)

41−#endif

42−

43import Grenade.Core.Layer

42import Grenade.Core.Layer

44import Grenade.Core.LearningParameters

43import Grenade.Core.LearningParameters

45import Grenade.Core.Shape

44import Grenade.Core.Shape

46−import Prelude.Singletons

47

45

48-- | Type of a network.

46-- | Type of a network.

49--

47--

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

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

51--

49--

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

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

53--

51--

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

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

55-- transform the data shapes of the network.

53-- transform the data shapes of the network.

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

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

57 NNil :: SingI i

55 NNil :: SingI i

58 => Network '[] '[i]

56 => Network '[] '[i]

59

57

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

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

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

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

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

70

68

71−-- | Gradient of a network.

72−--

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

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

75− GNil :: Gradients '[]

76−

77− (:/>) :: UpdateLayer x

78− => Gradient x

79− -> Gradients xs

80− -> Gradients (x ': xs)

81−

82−-- | Wegnert Tape of a network.

83−--

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

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

86− TNil :: SingI i

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

88−

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

90− => !(Tape x i h)

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

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

93−

94

69

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.

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

148−applyUpdate :: LearningParameters

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

149− -> Network layers shapes

72+applyUpdate _ NNil GNil

150− -> Gradients layers

73+ = NNil

151− -> Network layers shapes

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

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

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

75 = runUpdate rate layer gradient :~> applyUpdate rate rest grest

154

76

155−applyUpdate _ NNil GNil

156− = NNil

157

77

78+

79+-- | Gradients of a network.

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

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

82+ GNil :: Gradients '[]

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

84+

85+-- | Wegnert Tapes of a network.

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

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

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

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

90+

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

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

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

92+-- network is with the randomNetwork.

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

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

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

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

162− --

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

164− -- network is not sound.

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

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

166

96

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

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

@@ -182,16 +112,39 @@ instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o '

182

112

183-- | Ultimate composition.

113-- | Ultimate composition.

184--

114--

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

115+-- This allows a complete network to be treated as a layer in a bigger network.

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

116instance CreatableNetwork sublayers subshapes => UpdateLayer (Network sublayers subshapes) where

187 type Gradient (Network sublayers subshapes) = Gradients sublayers

117 type Gradient (Network sublayers subshapes) = Gradients sublayers

188− runUpdate = applyUpdate

118+ runUpdate = applyUpdate

189 createRandom = randomNetwork

119 createRandom = randomNetwork

190

120

191−-- | Ultimate composition.

192−--

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

194instance (CreatableNetwork sublayers subshapes, i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (Network sublayers subshapes) i o where

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

122 type Tape (Network sublayers subshapes) i o = Tapes sublayers subshapes

123+

196− runForwards = runNetwork

124+ runForwards net i =

197− runBackwards = runGradient

125+ go i net

126+ where

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

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

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

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

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

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

133+ (tapes, answer) = go forward n

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

135+ go !x NNil

136+ = (TNil, x)

137+

138+ runBackwards net tapes o =

139+ go net tapes

140+ where

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

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

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

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

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

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

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

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

149+ go NNil TNil

150+ = (GNil, o)

src/Grenade/Core/Runner.hs+40−26

@@ -1,58 +1,72 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE GADTs #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

3{-|

7{-|

4−Module : Grenade.Core.Runner

8+Module : Grenade.Core.Shape

5−Description : Functions to perform training and backpropagation

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

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

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

7License : BSD2

11License : BSD2

8Stability : experimental

12Stability : experimental

13+

14+This module defines simple back propagation and training functions

15+for a network.

9-}

16-}

17+

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

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

10module Grenade.Core.Runner (

20module Grenade.Core.Runner (

11 train

21 train

12 , backPropagate

22 , backPropagate

13 , runNet

23 , runNet

24+ , applyUpdate

14 ) where

25 ) where

15

26

27+import Data.Singletons.Prelude

16

28

29+import Grenade.Core.Layer

17import Grenade.Core.LearningParameters

30import Grenade.Core.LearningParameters

18import Grenade.Core.Network

31import Grenade.Core.Network

19import Grenade.Core.Shape

32import Grenade.Core.Shape

20−import Data.Singletons

21−import Prelude.Singletons

22

33

23-- | Perform reverse automatic differentiation on the network

34-- | Perform reverse automatic differentiation on the network

24-- for the current input and expected output.

35-- for the current input and expected output.

25--

36--

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

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

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

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

28−-- or log-loss respectively.

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

29−--

40+-- implemented.

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

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

32−--

33−backPropagate :: SingI (Last shapes)

41+backPropagate :: forall shapes layers.

34− => Network layers shapes

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

35− -> S (Head shapes)

36− -> S (Last shapes)

37− -> Gradients layers

38backPropagate network input target =

43backPropagate network input target =

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

44+ fst $ go input network

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

45+ where

41− in grads

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

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

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

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

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

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

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

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

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

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

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

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

42

58

59+ -- Bouncing the derivatives back down.

60+ go !x NNil

61+ = (GNil, x - target)

43

62

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

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

45−train :: SingI (Last shapes)

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

46− => LearningParameters

47− -> Network layers shapes

48− -> S (Head shapes)

49− -> S (Last shapes)

50− -> Network layers shapes

51train rate network input output =

65train rate network input output =

52 let grads = backPropagate network input output

66 let grads = backPropagate network input output

53 in applyUpdate rate network grads

67 in applyUpdate rate network grads

54

68

55−

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

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

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

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

58−runNet net = snd . runNetwork net

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

72+runNet NNil !x = x

src/Grenade/Core/Shape.hs+32−60

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

8{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE UndecidableInstances #-}

11+

12+-- Ghc 7.10 fails to recognise n2 is complete.

13+#if __GLASGOW_HASKELL__ < 800

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

15+#endif

12{-|

16{-|

13Module : Grenade.Core.Shape

17Module : Grenade.Core.Shape

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

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

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

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

16License : BSD2

20License : BSD2

17Stability : experimental

21Stability : experimental

18

22

19−

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

24+are understood by Grenade.

20-}

25-}

21module Grenade.Core.Shape (

26module Grenade.Core.Shape (

27+ Shape (..)

22− S (..)

28+ , S (..)

23− , Shape (..)

29+ , Sing (..)

24− , SShape (..)

25 , randomOfShape

30 , randomOfShape

26 , fromStorable

31 , fromStorable

27 ) where

32 ) where

28

33

29import Control.DeepSeq (NFData (..))

34import Control.DeepSeq (NFData (..))

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

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

31−import Data.Kind (Type)

36+

32import Data.Proxy

37import Data.Proxy

33−import Data.Serialize

34import Data.Singletons

38import Data.Singletons

39+import Data.Singletons.TypeLits

35import Data.Vector.Storable ( Vector )

40import Data.Vector.Storable ( Vector )

36import qualified Data.Vector.Storable as V

41import qualified Data.Vector.Storable as V

42+

37import GHC.TypeLits

43import GHC.TypeLits

44+

38import qualified Numeric.LinearAlgebra.Static as H

45import qualified Numeric.LinearAlgebra.Static as H

39import Numeric.LinearAlgebra.Static

46import Numeric.LinearAlgebra.Static

40import qualified Numeric.LinearAlgebra as NLA

47import qualified Numeric.LinearAlgebra as NLA

@@ -52,19 +59,21 @@ data Shape

52 | D3 Nat Nat Nat

59 | D3 Nat Nat Nat

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

60 -- ^ Three dimensional matrix. Row, Column, Channels.

54

61

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

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

56−--

57-- All shapes are held in contiguous memory.

63-- All shapes are held in contiguous memory.

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

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

59data S (n :: Shape) where

65data S (n :: Shape) where

66+ -- | One dimensional data

60 S1D :: ( KnownNat len )

67 S1D :: ( KnownNat len )

61 => R len

68 => R len

62 -> S ('D1 len)

69 -> S ('D1 len)

63

70

71+ -- | Two dimensional data

64 S2D :: ( KnownNat rows, KnownNat columns )

72 S2D :: ( KnownNat rows, KnownNat columns )

65 => L rows columns

73 => L rows columns

66 -> S ('D2 rows columns)

74 -> S ('D2 rows columns)

67

75

76+ -- | Three dimensional data

68 S3D :: ( KnownNat rows

77 S3D :: ( KnownNat rows

69 , KnownNat columns

78 , KnownNat columns

70 , KnownNat depth

79 , KnownNat depth

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

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

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

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

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

81-- We can also keep our code TH free, which is great.

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

91data instance Sing (n :: Shape) where

92− D1Sing :: Sing a -> Sing ('D1 a)

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

93− D2Sing :: Sing a -> Sing b -> Sing ('D2 a b)

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

94− D3Sing :: KnownNat (a * c) => Sing a -> Sing b -> Sing c -> Sing ('D3 a b c)

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

95−#endif

96

95

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

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

98 sing = D1Sing

97 sing = D1Sing

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

148randomOfShape = do

147randomOfShape = do

149 seed :: Int <- getRandom

148 seed :: Int <- getRandom

150 return $ case (sing :: Sing x) of

149 return $ case (sing :: Sing x) of

151− D1Sing ->

152− S1D (randomVector seed Uniform * 2 - 1)

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

153−

154− D2Sing ->

155− S2D (uniformSample seed (-1) 1)

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

156−

157− D3Sing ->

158− S3D (uniformSample seed (-1) 1)

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

159

153

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

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

161--

155--

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

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

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

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

164fromStorable xs = case sing :: Sing x of

158fromStorable xs = case sing :: Sing x of

165− D1Sing ->

166− S1D <$> H.create xs

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

167−

168− D2Sing ->

169− S2D <$> mkL xs

160+ D2Sing -> S2D <$> mkL xs

170−

171− D3Sing ->

172− S3D <$> mkL xs

161+ D3Sing -> S3D <$> mkL xs

173 where

162 where

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

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

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

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

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

180 then H.create $ NLA.reshape columns v

169 then H.create $ NLA.reshape columns v

181 else Nothing

170 else Nothing

182

171

183−

184−instance SingI x => Serialize (S x) where

185− put i = (case i of

186− (S1D x) -> putListOf put . NLA.toList . H.extract $ x

187− (S2D x) -> putListOf put . NLA.toList . NLA.flatten . H.extract $ x

188− (S3D x) -> putListOf put . NLA.toList . NLA.flatten . H.extract $ x

189− ) :: PutM ()

190−

191− get = do

192− Just i <- fromStorable . V.fromList <$> getListOf get

193− return i

194−

195-- Helper function for creating the number instances

172-- Helper function for creating the number instances

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

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

197n1 f (S1D x) = S1D (f x)

174n1 f (S1D x) = S1D (f x)

@@ -205,13 +182,8 @@ n2 f (S2D x) (S2D y) = S2D (f x y)

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

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

206

183

207-- Helper function for creating the number instances

184-- Helper function for creating the number instances

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

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

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

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

210− D1Sing ->

211− S1D (konst x)

187+ D1Sing -> S1D (konst x)

212−

213− D2Sing ->

214− S2D (konst x)

188+ D2Sing -> S2D (konst x)

215−

216− D3Sing ->

217− S3D (konst x)

189+ 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.hs+3−17

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

@@ -9,29 +8,20 @@

9{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FlexibleInstances #-}

10{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE StandaloneDeriving #-}

10{-# LANGUAGE StandaloneDeriving #-}

12−{-# LANGUAGE UndecidableInstances #-}

13{-|

11{-|

14−Module : Grenade.Layers.Concat

12+Module : Grenade.Core.Network

15−Description : Concatenation layer

13+Description : Core definition a simple neural etwork

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

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

17License : BSD2

15License : BSD2

18Stability : experimental

16Stability : experimental

19−

20−This module provides the concatenation layer, which runs two chilld layers in parallel and combines their outputs.

21-}

17-}

22module Grenade.Layers.Concat (

18module Grenade.Layers.Concat (

23 Concat (..)

19 Concat (..)

24 ) where

20 ) where

25

21

26−import Data.Serialize

27−

28import Data.Singletons

22import Data.Singletons

29import GHC.TypeLits

23import GHC.TypeLits

30

24

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

32−import Data.Kind (Type)

33−#endif

34−

35import Grenade.Core

25import Grenade.Core

36

26

37import Numeric.LinearAlgebra.Static ( row, (===), splitRows, unrow, (#), split, R )

27import Numeric.LinearAlgebra.Static ( row, (===), splitRows, unrow, (#), split, R )

@@ -49,7 +39,7 @@ import Numeric.LinearAlgebra.Static ( row, (===), splitRows, unrow, (#

49--

39--

50-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad

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

41-- and Crop layers to ensure this is the case.

52−data Concat :: Shape -> Type -> Shape -> Type -> Type where

42+data Concat :: Shape -> * -> Shape -> * -> * where

53 Concat :: x -> y -> Concat m x n y

43 Concat :: x -> y -> Concat m x n y

54

44

55instance (Show x, Show y) => Show (Concat m x n y) where

45instance (Show x, Show y) => Show (Concat m x n y) where

@@ -133,7 +123,3 @@ instance ( SingI i

133 (x', xB :: S i) = runBackwards x xTape (S3D ox :: S ('D3 rows cols m))

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

124 (y', yB :: S i) = runBackwards y yTape (S3D oy :: S ('D3 rows cols n))

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

125 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+62−89

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleContexts #-}

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

21module Grenade.Layers.Convolution (

10module Grenade.Layers.Convolution (

22 Convolution (..)

11 Convolution (..)

23 , Convolution' (..)

12 , Convolution' (..)

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

28import Data.Maybe

17import Data.Maybe

29import Data.Proxy

18import Data.Proxy

30import Data.Serialize

19import Data.Serialize

20+import Data.Singletons.TypeLits

31

21

32import GHC.TypeLits

22import GHC.TypeLits

33−import Data.Kind (Type)

34

23

35import Numeric.LinearAlgebra hiding ( uniformSample, konst )

24import Numeric.LinearAlgebra hiding ( uniformSample, konst )

36import qualified Numeric.LinearAlgebra as LA

25import qualified Numeric.LinearAlgebra as LA

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

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

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

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

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

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

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

60− -> Type where

49+ -> * where

61 Convolution :: ( KnownNat channels

50 Convolution :: ( KnownNat channels

62 , KnownNat filters

51 , KnownNat filters

63 , KnownNat kernelRows

52 , KnownNat kernelRows

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

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

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

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

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

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

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

79− -> Type where

68+ -> * where

80 Convolution' :: ( KnownNat channels

69 Convolution' :: ( KnownNat channels

81 , KnownNat filters

70 , KnownNat filters

82 , KnownNat kernelRows

71 , KnownNat kernelRows

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

130 , KnownNat strideColumns

119 , KnownNat strideColumns

131 , KnownNat (kernelRows * kernelColumns * channels)

120 , KnownNat (kernelRows * kernelColumns * channels)

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

121 ) => 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)

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

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

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

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

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

136 in Convolution newKernel newMomentum

125 in Convolution newKernel newMomentum

137

126

138 createRandom = randomConvolution

127 createRandom = randomConvolution

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

152 let mm = konst 0

141 let mm = konst 0

153 return $ Convolution wN mm

142 return $ Convolution wN mm

154

143

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

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

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

157instance ( KnownNat kernelRows

145instance ( KnownNat kernelRows

158 , KnownNat kernelCols

146 , KnownNat kernelCols

159 , KnownNat filters

147 , KnownNat filters

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

163 , KnownNat inputCols

151 , KnownNat inputCols

164 , KnownNat outputRows

152 , KnownNat outputRows

165 , KnownNat outputCols

153 , KnownNat outputCols

166− , KnownNat channels

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

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

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

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

169− , KnownNat (kernelRows * kernelCols * channels)

156+ , KnownNat (kernelRows * kernelCols * 1)

170 , KnownNat (outputRows * filters)

157 , KnownNat (outputRows * filters)

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

158+ ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('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)

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

174−

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

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

176 let ex = extract input

161 let ex = extract input

177 ek = extract kernel

162 ek = extract kernel

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

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

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

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

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

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

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

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

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

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

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

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

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

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

186−

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

169+ c = im2col kx ky sx sy ex

188 mt = c LA.<> ek

170 mt = c LA.<> ek

189 r = col2vid 1 1 1 1 ox oy mt

171 r = col2vid 1 1 1 1 ox oy mt

190 rs = fromJust . create $ r

172 rs = fromJust . create $ r

191− in (S3D input, S3D rs)

173+ in (S2D input, S3D rs)

174+

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

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

193 let ex = extract input

176 let ex = extract input

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

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

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

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

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

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

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

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

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

202

185

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

186+ c = im2col kx ky sx sy ex

204

187

205 eo = extract dEdy

188 eo = extract dEdy

206 ek = extract kernel

189 ek = extract kernel

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

208 vs = vid2col 1 1 1 1 ox oy eo

191 vs = vid2col 1 1 1 1 ox oy eo

209

192

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

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

211−

212 dW = vs LA.<> tr ek

194 dW = vs LA.<> tr ek

213

195

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

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

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

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

216

198

217

199

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

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

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

219instance ( KnownNat kernelRows

202instance ( KnownNat kernelRows

220 , KnownNat kernelCols

203 , KnownNat kernelCols

221 , KnownNat filters

204 , KnownNat filters

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

225 , KnownNat inputCols

208 , KnownNat inputCols

226 , KnownNat outputRows

209 , KnownNat outputRows

227 , KnownNat outputCols

210 , KnownNat outputCols

211+ , KnownNat channels

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

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

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

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

230− , KnownNat (kernelRows * kernelCols * 1)

214+ , KnownNat (kernelRows * kernelCols * channels)

231 , KnownNat (outputRows * filters)

215 , KnownNat (outputRows * filters)

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

216+ ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('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))

236

217

237− runBackwards c tape grads =

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

238− case runBackwards c tape grads of

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

240

219

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

221+ let ex = extract input

222+ ek = extract kernel

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

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

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

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

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

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

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

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

241

231

242−-- | A two dimensional image may have a convolution filter applied to it producing

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

243−-- a two dimensional image if both channels and filters is 1.

233+ mt = c LA.<> ek

244−instance ( KnownNat kernelRows

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

245− , KnownNat kernelCols

235+ rs = fromJust . create $ r

246− , KnownNat strideRows

236+ in (S3D input, S3D rs)

247− , KnownNat strideCols

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

248− , KnownNat inputRows

238+ let ex = extract input

249− , KnownNat inputCols

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

250− , KnownNat outputRows

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

251− , KnownNat outputCols

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

252− , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)

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

253− , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)

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

254− , KnownNat (kernelRows * kernelCols * 1)

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

255− , KnownNat (outputRows * 1)

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

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

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

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)

261

247

262− runBackwards c tape (S2D grads) =

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

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)

265

249

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

250+ eo = extract dEdy

267−instance ( KnownNat kernelRows

251+ ek = extract kernel

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)

285

252

286− runBackwards c tape (S2D grads) =

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

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

254+

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

256+

257+ dW = vs LA.<> tr ek

258+

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

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

src/Grenade/Layers/Crop.hs+4−19

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

@@ -6,24 +5,14 @@

6{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

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

17module Grenade.Layers.Crop (

8module Grenade.Layers.Crop (

18 Crop (..)

9 Crop (..)

19 ) where

10 ) where

20

11

21import Data.Maybe

12import Data.Maybe

22import Data.Proxy

13import Data.Proxy

23−import Data.Serialize

14+import Data.Singletons.TypeLits

24−

25import GHC.TypeLits

15import GHC.TypeLits

26−import Data.Kind (Type)

27

16

28import Grenade.Core

17import Grenade.Core

29import Grenade.Layers.Internal.Pad

18import Grenade.Layers.Internal.Pad

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

35data Crop :: Nat

24data Crop :: Nat

36 -> Nat

25 -> Nat

37 -> Nat

26 -> Nat

38− -> Nat -> Type where

27+ -> Nat -> * where

39 Crop :: Crop cropLeft cropTop cropRight cropBottom

28 Crop :: Crop cropLeft cropTop cropRight cropBottom

40

29

41instance Show (Crop cropLeft cropTop cropRight cropBottom) where

30instance Show (Crop cropLeft cropTop cropRight cropBottom) where

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

46 runUpdate _ x _ = x

35 runUpdate _ x _ = x

47 createRandom = return Crop

36 createRandom = return Crop

48

37

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

50− put _ = return ()

51− get = return Crop

52−

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

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

54instance ( KnownNat cropLeft

39instance ( KnownNat cropLeft

55 , KnownNat cropTop

40 , KnownNat cropTop

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

59 , KnownNat inputColumns

44 , KnownNat inputColumns

60 , KnownNat outputRows

45 , KnownNat outputRows

61 , KnownNat outputColumns

46 , KnownNat outputColumns

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

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

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

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

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

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

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

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

66 runForwards Crop (S2D input) =

51 runForwards Crop (S2D input) =

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/Elu.hs+3−10

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

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

12module Grenade.Layers.Elu (

5module Grenade.Layers.Elu (

13 Elu (..)

6 Elu (..)

14 ) where

7 ) where

@@ -36,12 +29,12 @@ instance Serialize Elu where

36 get = return Elu

29 get = return Elu

37

30

38instance ( KnownNat i) => Layer Elu ('D1 i) ('D1 i) where

31instance ( KnownNat i) => Layer Elu ('D1 i) ('D1 i) where

39− type Tape Elu ('D1 i) ('D1 i) = LAS.R i

32+ type Tape Elu ('D1 i) ('D1 i) = S ('D1 i)

40

33

41− runForwards _ (S1D y) = (y, S1D (elu y))

34+ runForwards _ (S1D y) = (S1D y, S1D (elu y))

42 where

35 where

43 elu = LAS.dvmap (\a -> if a <= 0 then exp a - 1 else a)

36 elu = LAS.dvmap (\a -> if a <= 0 then exp a - 1 else a)

44− runBackwards _ y (S1D dEdy) = ((), S1D (elu' y * dEdy))

37+ runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (elu' y * dEdy))

45 where

38 where

46 elu' = LAS.dvmap (\a -> if a <= 0 then exp a else 1)

39 elu' = LAS.dvmap (\a -> if a <= 0 then exp a else 1)

47

40

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

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

1{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

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

13

14

14import Data.Proxy

15import Data.Proxy

15import Data.Serialize

16import Data.Serialize

17+import Data.Singletons.TypeLits

16

18

17import qualified Numeric.LinearAlgebra as LA

19import qualified Numeric.LinearAlgebra as LA

18import Numeric.LinearAlgebra.Static

20import Numeric.LinearAlgebra.Static

@@ -20,7 +22,6 @@ import Numeric.LinearAlgebra.Static

20import Grenade.Core

22import Grenade.Core

21

23

22import Grenade.Layers.Internal.Update

24import Grenade.Layers.Internal.Update

23−import GHC.TypeLits

24

25

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

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

26data FullyConnected i o = FullyConnected

27data FullyConnected i o = FullyConnected

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

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

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

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

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

39

40

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

41+ runUpdate LearningParameters {..} (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+ let (newBias, newBiasMomentum) = decendVector learningRate learningMomentum learningRegulariser oldBias biasGradient oldBiasMomentum

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

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

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

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

44

45

45 createRandom = randomFullyConnected

46 createRandom = randomFullyConnected

46

47

47instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o) where

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

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

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

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

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

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

51

52

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

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

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

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

54 let wB' = dEdy

55 let wB' = dEdy

55 mm' = dEdy `outer` x

56 mm' = dEdy `outer` x

56 -- calcluate derivatives for next step

57 -- calcluate derivatives for next step

src/Grenade/Layers/Inception.hs+13−32

@@ -9,18 +9,13 @@

9{-# LANGUAGE ScopedTypeVariables #-}

10{-|

11Module : Grenade.Core.Network

12−Description : Inception style parallel convolutional network composition.

12+Description : Core definition a simple neural etwork

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

14License : BSD2

15Stability : experimental

16−

17−Export an Inception style type, which can be used to build up

18−complex multiconvolution size networks.

19-}

16-}

20module Grenade.Layers.Inception (

17module Grenade.Layers.Inception (

21 Inception

18 Inception

22− , InceptionMini

23− , Resnet

24 ) where

19 ) where

25

20

26import GHC.TypeLits

21import GHC.TypeLits

@@ -29,39 +24,25 @@ import Grenade.Core

29import Grenade.Layers.Convolution

24import Grenade.Layers.Convolution

30import Grenade.Layers.Pad

25import Grenade.Layers.Pad

31import Grenade.Layers.Concat

26import Grenade.Layers.Concat

32−import Grenade.Layers.Merge

33−import Grenade.Layers.Trivial

34

27

35−-- | Type of an inception layer.

28+

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.

47type Inception rows cols channels chx chy chz

29type 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) ]

30+ = Network '[ Concat ('D3 (rows - 2) (cols - 2) (chx + chy)) (InceptionS rows cols channels chx chy) ('D3 (rows - 2) (cols - 2) chz) (Inception7x7 rows cols channels chz) ]

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

31+ '[ 'D3 rows cols channels, 'D3 (rows -2) (cols -2) (chx + chy + chz) ]

50

32

51−type InceptionMini rows cols channels chx chy

33+type InceptionS 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) ]

34+ = Network '[ Concat ('D3 (rows - 2) (cols - 2) chx) (Inception3x3 rows cols channels chx) ('D3 (rows - 2) (cols - 2) chy) (Inception5x5 rows cols channels chy) ]

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

35+ '[ 'D3 rows cols channels, 'D3 (rows -2) (cols -2) (chx + chy) ]

54

36

55type Inception3x3 rows cols channels chx

37type Inception3x3 rows cols channels chx

56− = Network '[ Pad 1 1 1 1, Convolution channels chx 3 3 1 1 ]

38+ = Network '[ Convolution channels chx 3 3 1 1 ]

57− '[ 'D3 rows cols channels, 'D3 (rows + 2) (cols + 2) channels, 'D3 rows cols chx ]

39+ '[ 'D3 rows cols channels, 'D3 (rows -2) (cols -2) chx ]

58

40

59type Inception5x5 rows cols channels chx

41type Inception5x5 rows cols channels chx

60− = Network '[ Pad 2 2 2 2, Convolution channels chx 5 5 1 1 ]

42+ = Network '[ Pad 1 1 1 1, Convolution channels chx 5 5 1 1 ]

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

43+ '[ 'D3 rows cols channels, 'D3 (rows + 2) (cols + 2) channels, 'D3 (rows - 2) (cols - 2) chx ]

62

44

63type Inception7x7 rows cols channels chx

45type Inception7x7 rows cols channels chx

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

46+ = Network '[ Pad 2 2 2 2, Convolution channels chx 7 7 1 1 ]

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

47+ '[ 'D3 rows cols channels, 'D3 (rows + 4) (cols + 4) channels, 'D3 (rows - 2) (cols - 2) chx ]

66

48

67−type Resnet branch = Merge Trivial branch

src/Grenade/Layers/Internal/Update.hs+12−12

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

1{-# LANGUAGE ForeignFunctionInterface #-}

2module Grenade.Layers.Internal.Update (

3− descendMatrix

3+ decendMatrix

4− , descendVector

4+ , decendVector

5 ) where

6

7import Data.Maybe ( fromJust )

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

17

18import System.IO.Unsafe ( unsafePerformIO )

19

20−descendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)

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−descendMatrix rate momentum regulariser weights gradient lastUpdate =

21+decendMatrix rate momentum regulariser weights gradient lastUpdate =

22 let (rows, cols) = size weights

23 len = rows * cols

24 -- Most gradients come in in ColumnMajor,

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

29 weights' = flatten . tr . extract $ weights

30 gradient' = flatten . tr . extract $ gradient

31 lastUpdate' = flatten . tr . extract $ lastUpdate

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

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

33

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

35 -- using the internal vectors.

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

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

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

39

40−descendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)

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

41−descendVector rate momentum regulariser weights gradient lastUpdate =

41+decendVector rate momentum regulariser weights gradient lastUpdate =

42 let len = size weights

43 weights' = extract weights

44 gradient' = extract gradient

45 lastUpdate' = extract lastUpdate

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

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

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

48

49−descendUnsafe :: Int -> Double -> Double -> Double -> Vector Double -> Vector Double -> Vector Double -> (Vector Double, Vector Double)

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

50−descendUnsafe len rate momentum regulariser weights gradient lastUpdate =

50+decendUnsafe len rate momentum regulariser weights gradient lastUpdate =

51 unsafePerformIO $ do

52 outWPtr <- mallocForeignPtrArray len

53 outMPtr <- mallocForeignPtrArray len

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

60 withForeignPtr lPtr $ \lPtr' ->

61 withForeignPtr outWPtr $ \outWPtr' ->

62 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'

64

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

66

67foreign import ccall unsafe

68− descend_cpu

68+ decend_cpu

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

70

src/Grenade/Layers/Logit.hs+9−23

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

3{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

6−{-|

7−Module : Grenade.Layers.Logit

8−Description : Sigmoid nonlinear layer

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

10−License : BSD2

11−Stability : experimental

12−-}

13module Grenade.Layers.Logit (

6module Grenade.Layers.Logit (

14 Logit (..)

7 Logit (..)

15 ) where

8 ) where

@@ -21,7 +14,6 @@ import Data.Singletons

21import Grenade.Core

14import Grenade.Core

22

15

23-- | A Logit layer.

16-- | A Logit layer.

24−--

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

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

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

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

27-- problems.

19-- problems.

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

34 createRandom = return Logit

26 createRandom = return Logit

35

27

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

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

37− -- Wengert tape optimisation:

38− --

39− -- Derivative of the sigmoid function is

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

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

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

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

44 type Tape Logit a b = S a

29 type Tape Logit a b = S a

45− runForwards _ a =

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

46− let l = sigmoid a

47− in (l, l)

48− runBackwards _ l g =

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

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

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

51

32

52instance Serialize Logit where

33instance Serialize Logit where

53 put _ = return ()

34 put _ = return ()

54 get = return Logit

35 get = return Logit

55

36

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

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

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

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

39+

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

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

42+ where

43+ logix = logistic x

src/Grenade/Layers/Merge.hs+2−13

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

@@ -11,7 +10,7 @@

11{-# LANGUAGE StandaloneDeriving #-}

10{-# LANGUAGE StandaloneDeriving #-}

12{-|

11{-|

13Module : Grenade.Core.Network

12Module : Grenade.Core.Network

14−Description : Merging layer for parallel network composition

13+Description : Core definition a simple neural etwork

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

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

16License : BSD2

15License : BSD2

17Stability : experimental

16Stability : experimental

@@ -20,21 +19,15 @@ module Grenade.Layers.Merge (

20 Merge (..)

19 Merge (..)

21 ) where

20 ) where

22

21

23−import Data.Serialize

24−

25import Data.Singletons

22import Data.Singletons

26

23

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

28−import Data.Kind (Type)

29−#endif

30−

31import Grenade.Core

24import Grenade.Core

32

25

33-- | A Merging layer.

26-- | A Merging layer.

34--

27--

35-- Similar to Concat layer, except sums the activations instead of creating a larger

28-- Similar to Concat layer, except sums the activations instead of creating a larger

36-- shape.

29-- shape.

37−data Merge :: Type -> Type -> Type where

30+data Merge :: * -> * -> * where

38 Merge :: x -> y -> Merge x y

31 Merge :: x -> y -> Merge x y

39

32

40instance (Show x, Show y) => Show (Merge x y) where

33instance (Show x, Show y) => Show (Merge x y) where

@@ -60,7 +53,3 @@ instance (SingI i, SingI o, Layer x i o, Layer y i o) => Layer (Merge x y) i o w

60 let (x', xB) = runBackwards x xTape o

53 let (x', xB) = runBackwards x xTape o

61 (y', yB) = runBackwards y yTape o

54 (y', yB) = runBackwards y yTape o

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

55 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+4−16

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

@@ -6,14 +5,6 @@

6{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE FlexibleContexts #-}

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

17module Grenade.Layers.Pad (

8module Grenade.Layers.Pad (

18 Pad (..)

9 Pad (..)

19 ) where

10 ) where

@@ -21,9 +12,8 @@ module Grenade.Layers.Pad (

21import Data.Maybe

12import Data.Maybe

22import Data.Proxy

13import Data.Proxy

23import Data.Serialize

14import Data.Serialize

24−

15+import Data.Singletons.TypeLits

25import GHC.TypeLits

16import GHC.TypeLits

26−import Data.Kind (Type)

27

17

28import Grenade.Core

18import Grenade.Core

29import Grenade.Layers.Internal.Pad

19import Grenade.Layers.Internal.Pad

@@ -32,12 +22,10 @@ import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)

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

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

33

23

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

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

35−--

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

37data Pad :: Nat

25data Pad :: Nat

38 -> Nat

26 -> Nat

39 -> Nat

27 -> Nat

40− -> Nat -> Type where

28+ -> Nat -> * where

41 Pad :: Pad padLeft padTop padRight padBottom

29 Pad :: Pad padLeft padTop padRight padBottom

42

30

43instance Show (Pad padLeft padTop padRight padBottom) where

31instance Show (Pad padLeft padTop padRight padBottom) where

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

52 put _ = return ()

40 put _ = return ()

53 get = return Pad

41 get = return Pad

54

42

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

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

56instance ( KnownNat padLeft

44instance ( KnownNat padLeft

57 , KnownNat padTop

45 , KnownNat padTop

58 , KnownNat padRight

46 , KnownNat padRight

@@ -82,7 +70,7 @@ instance ( KnownNat padLeft

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

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

83 in ((), S2D . fromJust . create $ vs)

71 in ((), S2D . fromJust . create $ vs)

84

72

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

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

86instance ( KnownNat padLeft

74instance ( KnownNat padLeft

87 , KnownNat padTop

75 , KnownNat padTop

88 , KnownNat padRight

76 , KnownNat padRight

src/Grenade/Layers/Pooling.hs+3−14

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE StandaloneDeriving #-}

3{-# LANGUAGE StandaloneDeriving #-}

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

7{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE FlexibleContexts #-}

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

18module Grenade.Layers.Pooling (

9module Grenade.Layers.Pooling (

19 Pooling (..)

10 Pooling (..)

20 ) where

11 ) where

@@ -22,9 +13,8 @@ module Grenade.Layers.Pooling (

22import Data.Maybe

13import Data.Maybe

23import Data.Proxy

14import Data.Proxy

24import Data.Serialize

15import Data.Serialize

25−

16+import Data.Singletons.TypeLits

26import GHC.TypeLits

17import GHC.TypeLits

27−import Data.Kind (Type)

28

18

29import Grenade.Core

19import Grenade.Core

30import Grenade.Layers.Internal.Pooling

20import Grenade.Layers.Internal.Pooling

@@ -32,21 +22,20 @@ import Grenade.Layers.Internal.Pooling

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

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

33

23

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

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

35−--

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

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

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

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

38--

27--

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

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

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

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

41--

30--

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

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

43 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

32 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

44

33

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

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

46 show Pooling = "Pooling"

35 show Pooling = "Pooling"

47

36

48instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

37instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

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

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

50 runUpdate _ Pooling _ = Pooling

39 runUpdate _ Pooling _ = Pooling

51 createRandom = return Pooling

40 createRandom = return Pooling

52

41

src/Grenade/Layers/Relu.hs−7

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

2{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeFamilies #-}

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

12module Grenade.Layers.Relu (

5module Grenade.Layers.Relu (

13 Relu (..)

6 Relu (..)

14 ) where

7 ) where

src/Grenade/Layers/Reshape.hs+3−23

@@ -3,20 +3,13 @@

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

14module Grenade.Layers.Reshape (

6module Grenade.Layers.Reshape (

15 Reshape (..)

7 Reshape (..)

16 ) where

8 ) where

17

9

18import Data.Serialize

10import Data.Serialize

19

11

12+import Data.Singletons.TypeLits

20import GHC.TypeLits

13import GHC.TypeLits

21

14

22import Numeric.LinearAlgebra.Static

15import Numeric.LinearAlgebra.Static

@@ -26,12 +19,9 @@ import Grenade.Core

26

19

27-- | Reshape Layer

20-- | Reshape Layer

28--

21--

29−-- The Reshape layer can flatten any 2D or 3D image to 1D vector with the

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

30−-- same number of activations, as well as cast up from 1D to a 2D or 3D

31−-- shape.

32--

23--

33−-- Can also be used to turn a 3D image with only one channel into a 2D image

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

34−-- or vice versa.

35data Reshape = Reshape

25data Reshape = Reshape

36 deriving Show

26 deriving Show

37

27

@@ -60,16 +50,6 @@ instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer Reshape ('D2 x y)

60 runForwards _ (S2D y) = ((), S3D y)

50 runForwards _ (S2D y) = ((), S3D y)

61 runBackwards _ _ (S3D y) = ((), S2D y)

51 runBackwards _ _ (S3D y) = ((), S2D y)

62

52

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−

73instance Serialize Reshape where

53instance Serialize Reshape where

74 put _ = return ()

54 put _ = return ()

75 get = return Reshape

55 get = return Reshape

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.hs−11

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

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

13module Grenade.Layers.Softmax (

6module Grenade.Layers.Softmax (

14 Softmax (..)

7 Softmax (..)

15 , softmax

8 , softmax

@@ -24,12 +17,8 @@ import Grenade.Core

24import Numeric.LinearAlgebra.Static as LAS

17import Numeric.LinearAlgebra.Static as LAS

25

18

26-- | A Softmax layer

19-- | A Softmax layer

27−--

28-- This layer is like a logit layer, but normalises

20-- This layer is like a logit layer, but normalises

29-- a set of matricies to be probabilities.

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

33data Softmax = Softmax

22data Softmax = Softmax

34 deriving Show

23 deriving Show

35

24

src/Grenade/Layers/Tanh.hs+3−10

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

1{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

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

13module Grenade.Layers.Tanh (

6module Grenade.Layers.Tanh (

14 Tanh (..)

7 Tanh (..)

15 ) where

8 ) where

@@ -20,7 +13,7 @@ import Data.Singletons

20import Grenade.Core

13import Grenade.Core

21

14

22-- | A Tanh layer.

15-- | A Tanh layer.

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

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

24data Tanh = Tanh

17data Tanh = Tanh

25 deriving Show

18 deriving Show

26

19

src/Grenade/Layers/Trivial.hs+3−14

@@ -3,25 +3,15 @@

3{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE FlexibleInstances #-}

6−{-|

7−Module : Grenade.Core.Trivial

8−Description : Trivial layer which perfoms no operations on the data

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

10−License : BSD2

11−Stability : experimental

12−-}

13module Grenade.Layers.Trivial (

6module Grenade.Layers.Trivial (

14 Trivial (..)

7 Trivial (..)

15 ) where

8 ) where

16

9

17import Data.Serialize

10import Data.Serialize

18

11

19−import Grenade.Core

12+import Grenade.Core.Network

20

13

21−-- | A Trivial layer.

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

25data Trivial = Trivial

15data Trivial = Trivial

26 deriving Show

16 deriving Show

27

17

@@ -35,6 +25,5 @@ instance UpdateLayer Trivial where

35 createRandom = return Trivial

25 createRandom = return Trivial

36

26

37instance (a ~ b) => Layer Trivial a b where

27instance (a ~ b) => Layer Trivial a b where

38− type Tape Trivial a b = ()

39− runForwards _ a = ((), a)

28+ runForwards _ = id

40 runBackwards _ _ y = ((), y)

29 runBackwards _ _ y = ((), y)

src/Grenade/Recurrent.hs+5−26

@@ -1,29 +1,8 @@

1module Grenade.Recurrent (

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

2+ module X

3− -- for recurrent networks in Grenade.

4−

5− -- * Exported modules

6− --

7− -- | The core types and runners for Recurrent Networks.

8− module Grenade.Recurrent.Core

9−

10− -- | The recurrent neural network layer zoo

11− , module Grenade.Recurrent.Layers

12−

13− -- * Overview of recurrent Networks

14− -- $recurrent

15−

16 ) where

3 ) where

17

4

18−import Grenade.Recurrent.Core

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

19−import Grenade.Recurrent.Layers

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

20−

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

21−{- $recurrent

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

22−There are two ways in which deep learning libraries choose to represent

23−recurrent Neural Networks, as an unrolled graph, or at a first class

24−level. Grenade chooses the latter representation, and provides a network

25−type which is specifically suited for recurrent neural networks.

26−

27−Currently grenade supports two layers, a basic recurrent layer, and an

28−LSTM layer.

29−-}

src/Grenade/Recurrent/Core.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+64−246

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

@@ -7,54 +6,54 @@

7{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE EmptyDataDecls #-}

8{-# LANGUAGE EmptyDataDecls #-}

10−{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE BangPatterns #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−

15module Grenade.Recurrent.Core.Network (

9module Grenade.Recurrent.Core.Network (

16 Recurrent

10 Recurrent

17 , FeedForward

11 , FeedForward

18−

12+ , RecurrentLayer (..)

13+ , RecurrentUpdateLayer (..)

19 , RecurrentNetwork (..)

14 , RecurrentNetwork (..)

20 , RecurrentInputs (..)

15 , RecurrentInputs (..)

21− , RecurrentTape (..)

16+ , CreatableRecurrent (..)

22− , RecurrentGradient (..)

23−

24− , randomRecurrent

25− , runRecurrent

26− , runRecurrent'

27− , applyRecurrentUpdate

28 ) where

17 ) where

29

18

30

19

31import Control.Monad.Random ( MonadRandom )

20import Control.Monad.Random ( MonadRandom )

21+import Data.Singletons ( SingI )

32import Data.Serialize

22import Data.Serialize

33−

23+import qualified Data.Vector.Storable as V

34−import Data.Kind (Type)

35

24

36import Grenade.Core

25import Grenade.Core

37−import Grenade.Recurrent.Core.Layer

26+

38−import Prelude.Singletons

27+import qualified Numeric.LinearAlgebra as LA

28+import qualified Numeric.LinearAlgebra.Static as LAS

29+

39

30

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

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

41-- forward layer.

32-- forward layer.

42−data FeedForward :: Type -> Type

33+data FeedForward :: * -> *

43-- | Witness type to say indicate we're building up with a recurrent layer.

34-- | Witness type to say indicate we're building up with a recurrent layer.

44−data Recurrent :: Type -> Type

35+data Recurrent :: * -> *

45−

36+

46−-- | Type of a recurrent neural network.

37+-- | Class for a recurrent layer.

47−--

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

48−-- The [Type] type specifies the types of the layers.

39+-- of an extra recurrent data shape.

49−--

40+class UpdateLayer x => RecurrentUpdateLayer x where

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

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

51−--

42+ type RecurrentShape x :: Shape

52−-- The definition is similar to a Network, but every layer in the

43+

53−-- type is tagged by whether it's a FeedForward Layer of a Recurrent layer.

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

54−--

45+ -- | Wengert Tape

55−-- Often, to make the definitions more concise, one will use a type alias

46+ type RecTape x i o :: *

56−-- for these empty data types.

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

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

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

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

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

52+ -- the layer above.

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

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

55+

57−data RecurrentNetwork :: [Type] -> [Shape] -> Type where

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

58 RNil :: SingI i

57 RNil :: SingI i

59 => RecurrentNetwork '[] '[i]

58 => RecurrentNetwork '[] '[i]

60

59

@@ -70,132 +69,6 @@ data RecurrentNetwork :: [Type] -> [Shape] -> Type where

70infixr 5 :~~>

69infixr 5 :~~>

71infixr 5 :~@>

70infixr 5 :~@>

72

71

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−

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

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

200 show RNil = "NNil"

73 show RNil = "NNil"

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

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

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

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

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

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

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

205

78

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

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

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

82+ RINil :: RecurrentInputs '[]

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

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

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

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

87+infixr 5 :~~+>

88+infixr 5 :~@+>

206

89

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

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

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

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

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

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

210 -- | Create a network of the types requested

93 -- | Create a network of the types requested

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

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

212

95

213instance SingI i => CreatableRecurrent '[] '[i] where

96instance SingI i => CreatableRecurrent '[] '[i] where

214 randomRecurrent =

97 randomRecurrent =

215− return RNil

98+ return (RNil, RINil)

216

99

217instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where

100instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where

218 randomRecurrent = do

101 randomRecurrent = do

219 thisLayer <- createRandom

102 thisLayer <- createRandom

220− rest <- randomRecurrent

103+ (rest, resti) <- randomRecurrent

221− return (thisLayer :~~> rest)

104+ return (thisLayer :~~> rest, () :~~+> resti)

222

105

223instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where

106instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where

224 randomRecurrent = do

107 randomRecurrent = do

225 thisLayer <- createRandom

108 thisLayer <- createRandom

109+ thisShape <- randomOfShape

226− rest <- randomRecurrent

110+ (rest, resti) <- randomRecurrent

227− return (thisLayer :~@> rest)

111+ return (thisLayer :~@> rest, thisShape :~@+> resti)

228

112

229-- | Add very simple serialisation to the recurrent network

113-- | Add very simple serialisation to the recurrent network

230instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where

114instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where

@@ -243,86 +127,20 @@ instance (Serialize (RecurrentInputs '[])) where

243 put _ = return ()

127 put _ = return ()

244 get = return RINil

128 get = return RINil

245

129

246−instance (UpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

130+instance (UpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

247 put ( () :~~+> rest) = put rest

131 put ( () :~~+> rest) = put rest

248 get = ( () :~~+> ) <$> get

132 get = ( () :~~+> ) <$> get

249

133

250−instance (Serialize (RecurrentShape x), Fractional (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

134+instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

251− put ( i :~@+> rest ) = put i >> put rest

135+ put ( i :~@+> rest ) = do

136+ _ <- (case i of

137+ (S1D x) -> putListOf put . LA.toList . LAS.extract $ x

138+ (S2D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

139+ (S3D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

140+ ) :: PutM ()

141+ put rest

142+

252− get = (:~@+>) <$> get <*> get

143+ get = do

253−

144+ Just i <- fromStorable . V.fromList <$> getListOf get

254−

145+ rest <- get

255−-- Num instance for `RecurrentInputs layers`

146+ return ( i :~@+> rest)

256−-- Not sure if this is really needed, as I only need a `fromInteger 0` at

257−-- the moment for training, to create a null gradient on the recurrent

258−-- edge.

259−--

260−-- It does raise an interesting question though? Is a 0 gradient actually

261−-- the best?

262−--

263−-- I could imaging that weakly push back towards the optimum input could

264−-- help make a more stable generator.

265−instance (Num (RecurrentInputs '[])) where

266− (+) _ _ = RINil

267− (-) _ _ = RINil

268− (*) _ _ = RINil

269− abs _ = RINil

270− signum _ = RINil

271− fromInteger _ = RINil

272−

273−instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where

274− (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)

275− (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)

276− (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)

277− abs (() :~~+> x) = () :~~+> abs x

278− signum (() :~~+> x) = () :~~+> signum x

279− fromInteger x = () :~~+> fromInteger x

280−

281−instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where

282− (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')

283− (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')

284− (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')

285− abs (x :~@+> x') = abs x :~@+> abs x'

286− signum (x :~@+> x') = signum x :~@+> signum x'

287− fromInteger x = fromInteger x :~@+> fromInteger x

288−

289−instance (Fractional (RecurrentInputs '[])) where

290− (/) _ _ = RINil

291− recip _ = RINil

292− fromRational _ = RINil

293−

294−instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (FeedForward x ': ys))) where

295− (/) (() :~~+> x) (() :~~+> y) = () :~~+> (x / y)

296− recip (() :~~+> x) = () :~~+> recip x

297− fromRational x = () :~~+> fromRational x

298−

299−instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (Recurrent x ': ys))) where

300− (/) (x :~@+> x') (y :~@+> y') = (x / y) :~@+> (x' / y')

301− recip (x :~@+> x') = recip x :~@+> recip x'

302− fromRational x = fromRational x :~@+> fromRational x

303−

304−

305−-- | Ultimate composition.

306−--

307−-- This allows a complete network to be treated as a layer in a larger network.

308−instance CreatableRecurrent sublayers subshapes => UpdateLayer (RecurrentNetwork sublayers subshapes) where

309− type Gradient (RecurrentNetwork sublayers subshapes) = RecurrentGradient sublayers

310− runUpdate = applyRecurrentUpdate

311− createRandom = randomRecurrent

312−

313−-- | Ultimate composition.

314−--

315−-- This allows a complete network to be treated as a layer in a larger network.

316−instance CreatableRecurrent sublayers subshapes => RecurrentUpdateLayer (RecurrentNetwork sublayers subshapes) where

317− type RecurrentShape (RecurrentNetwork sublayers subshapes) = RecurrentInputs sublayers

318−

319−-- | Ultimate composition.

320−--

321−-- This allows a complete network to be treated as a layer in a larger network.

322−instance ( CreatableRecurrent sublayers subshapes

323− , i ~ (Head subshapes), o ~ (Last subshapes)

324− , Num (RecurrentShape (RecurrentNetwork sublayers subshapes))

325− ) => RecurrentLayer (RecurrentNetwork sublayers subshapes) i o where

326− type RecTape (RecurrentNetwork sublayers subshapes) i o = RecurrentTape sublayers subshapes

327− runRecurrentForwards = runRecurrent

328− runRecurrentBackwards = runRecurrent'

src/Grenade/Recurrent/Core/Runner.hs+122−87

@@ -3,108 +3,143 @@

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE CPP #-}

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE RecordWildCards #-}

9

11

10−module Grenade.Recurrent.Core.Runner (

12+#if __GLASGOW_HASKELL__ < 800

11− runRecurrentExamples

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

12− , runRecurrentBackprop

14+#endif

13− , backPropagateRecurrent

14− , trainRecurrent

15

16− , RecurrentGradients

16+module Grenade.Recurrent.Core.Runner (

17+ trainRecurrent

18+ , runRecurrent

17 ) where

19 ) where

18

20

19−import Data.List ( foldl' )

21+import Data.Singletons.Prelude

20import Grenade.Core

22import Grenade.Core

21

23

22import Grenade.Recurrent.Core.Network

24import Grenade.Recurrent.Core.Network

23−import Prelude.Singletons

24−

25−type RecurrentGradients layers = [RecurrentGradient layers]

26−

27−runRecurrentExamples :: forall shapes layers.

28− RecurrentNetwork layers shapes

29− -> RecurrentInputs layers

30− -> [S (Head shapes)]

31− -> ([(RecurrentTape layers shapes, S (Last shapes))], RecurrentInputs layers)

32−runRecurrentExamples net =

33− go

34− where

35− go !side [] = ([], side)

36− go !side (!x : xs) =

37− let (!tape, !side', !o) = runRecurrent net side x

38− (!res, !finalSide) = go side' xs

39− in (( tape, o ) : res, finalSide)

40−

41−runRecurrentBackprop :: forall layers shapes.

42− RecurrentNetwork layers shapes

43− -> RecurrentInputs layers

44− -> [(RecurrentTape layers shapes, S (Last shapes))]

45− -> ([(RecurrentGradient layers, S (Head shapes))], RecurrentInputs layers)

46−runRecurrentBackprop net =

47− go

48− where

49− go !side [] = ([], side)

50− go !side ((!tape,!x):xs) =

51− let (res, !side') = go side xs

52− (!grad, !finalSide, !o) = runRecurrent' net tape side' x

53− in (( grad, o ) : res, finalSide)

54−

55

25

56-- | Drive and network and collect its back propogated gradients.

26-- | Drive and network and collect its back propogated gradients.

57−backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

27+--

58− => RecurrentNetwork layers shapes

28+-- TODO: split this nicely into backpropagate and update.

59− -> RecurrentInputs layers

29+--

60− -> [(S (Head shapes), Maybe (S (Last shapes)))]

30+-- QUESTION: Should we return a list of gradients or the sum of

61− -> (RecurrentGradients layers, RecurrentInputs layers)

31+-- the gradients? It's different taking into account

62−backPropagateRecurrent network recinputs examples =

32+-- momentum and L2.

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

33+trainRecurrent :: forall shapes layers. SingI (Last shapes)

83 => LearningParameters

34 => LearningParameters

84 -> RecurrentNetwork layers shapes

35 -> RecurrentNetwork layers shapes

85 -> RecurrentInputs layers

36 -> RecurrentInputs layers

86 -> [(S (Head shapes), Maybe (S (Last shapes)))]

37 -> [(S (Head shapes), Maybe (S (Last shapes)))]

87 -> (RecurrentNetwork layers shapes, RecurrentInputs layers)

38 -> (RecurrentNetwork layers shapes, RecurrentInputs layers)

88trainRecurrent rate network recinputs examples =

39trainRecurrent rate network recinputs examples =

89− let (gradients, recinputs') = backPropagateRecurrent network recinputs examples

40+ updateBack $ go inputs network recinputs

90−

41+ where

91− newInputs = updateRecInputs rate recinputs recinputs'

42+ inputs = fst <$> examples

92−

43+ targets = snd <$> examples

93− newNetwork = foldl' (applyRecurrentUpdate rate) network gradients

44+ updateBack (a,recgrad,_) = (a,updateRecInputs rate recinputs recgrad)

94−

45+

95− in (newNetwork, newInputs)

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

96−

47+ => [S (Head js)] -- ^ input vector

48+ -> RecurrentNetwork sublayers js -- ^ network to train

49+ -> RecurrentInputs sublayers

50+ -> (RecurrentNetwork sublayers js, RecurrentInputs sublayers, [S (Head js)])

51+

52+ -- This is a simple non-recurrent layer, just map it forwards

53+ -- Note we're doing training here, we could just return a list of gradients

54+ -- (and probably will in future).

55+ go !xs (layer :~~> n) (() :~~+> nIn)

56+ = let tys = runForwards layer <$> xs

57+ tapes = fst <$> tys

58+ ys = snd <$> tys

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

60+ (newFN, ig, grads) = go ys n nIn

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

62+ back = uncurry (runBackwards layer) <$> zip (reverse tapes) grads

63+ -- the new trained layer.

64+ newlayer = runUpdates rate layer (fst <$> back)

65+

66+ in (newlayer :~~> newFN, () :~~+> ig, snd <$> back)

67+

68+ -- This is a recurrent layer, so we need to do a scan, first input to last, providing

69+ -- the recurrent shape output to the next layer.

70+ go !xs (layer :~@> n) (g :~@+> nIn)

71+ = let tys = scanlFrom layer g xs

72+ tapes = fst <$> tys

73+ ys = snd <$> tys

74+

75+ (newFN, ig, grads) = go ys n nIn

76+

77+ backExamples = zip (reverse tapes) grads

78+

79+ (rg, back) = myscanbackward layer backExamples

80+ -- the new trained layer.

81+ newlayer = runUpdates rate layer (fst <$> back)

82+ in (newlayer :~@> newFN, rg :~@+> ig, snd <$> back)

83+

84+ -- Handle the output layer, bouncing the derivatives back down.

85+ -- We may not have a target for each example, so when we don't use 0 gradient.

86+ go !xs RNil RINil

87+ = (RNil, RINil, reverse (zipWith makeError xs targets))

88+ where

89+ makeError :: S (Last shapes) -> Maybe (S (Last shapes)) -> S (Last shapes)

90+ makeError _ Nothing = 0

91+ makeError y (Just t) = y - t

92+

97−updateRecInputs :: Fractional (RecurrentInputs sublayers)

93+ updateRecInputs :: forall sublayers.

98− => LearningParameters

94+ LearningParameters

99− -> RecurrentInputs sublayers

95+ -> RecurrentInputs sublayers

100− -> RecurrentInputs sublayers

96+ -> RecurrentInputs sublayers

101− -> RecurrentInputs sublayers

97+ -> RecurrentInputs sublayers

102−

98+

103−updateRecInputs lp (() :~~+> xs) (() :~~+> ys)

99+ updateRecInputs l@LearningParameters {..} (() :~~+> xs) (() :~~+> ys)

104− = () :~~+> updateRecInputs lp xs ys

100+ = () :~~+> updateRecInputs l xs ys

105−

101+

106−updateRecInputs lp (x :~@+> xs) (y :~@+> ys)

102+ updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)

107− = (realToFrac (1 - learningRate lp * learningRegulariser lp) * x - realToFrac (learningRate lp) * y) :~@+> updateRecInputs lp xs ys

103+ = (realToFrac (learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys

108−

104+

109−updateRecInputs _ RINil RINil

105+ updateRecInputs _ RINil RINil

110− = RINil

106+ = RINil

107+

108+scanlFrom :: forall x i o. RecurrentLayer x i o

109+ => x -- ^ the layer

110+ -> S (RecurrentShape x) -- ^ place to start

111+ -> [S i] -- ^ list of inputs to scan through

112+ -> [(RecTape x i o, S o)] -- ^ list of scan inputs and outputs

113+scanlFrom !layer !recShape (x:xs) =

114+ let (tape, lerec, lepush) = runRecurrentForwards layer recShape x

115+ in (tape, lepush) : scanlFrom layer lerec xs

116+scanlFrom _ _ [] = []

117+

118+myscanbackward :: forall x i o. RecurrentLayer x i o

119+ => x -- ^ the layer

120+ -> [(RecTape x i o, S o)] -- ^ the list of inputs and output to scan over

121+ -> (S (RecurrentShape x), [(Gradient x, S i)]) -- ^ list of gradients to fold and inputs to backprop

122+myscanbackward layer =

123+ goX 0

124+ where

125+ goX :: S (RecurrentShape x) -> [(RecTape x i o, S o)] -> (S (RecurrentShape x), [(Gradient x, S i)])

126+ goX !lastback ((recTape, backgrad):xs) =

127+ let (layergrad, recgrad, ingrad) = runRecurrentBackwards layer recTape lastback backgrad

128+ (pushedback, ll) = goX recgrad xs

129+ in (pushedback, (layergrad, ingrad) : ll)

130+ goX !lastback [] = (lastback, [])

131+

132+-- | Just forwards propagation with no training.

133+runRecurrent :: RecurrentNetwork layers shapes

134+ -> RecurrentInputs layers -> S (Head shapes)

135+ -> (RecurrentInputs layers, S (Last shapes))

136+runRecurrent (layer :~~> n) (() :~~+> nr) !x

137+ = let (_, ys) = runForwards layer x

138+ (nr', o) = runRecurrent n nr ys

139+ in (() :~~+> nr', o)

140+runRecurrent (layer :~@> n) (recin :~@+> nr) !x

141+ = let (_, recin', y) = runRecurrentForwards layer recin x

142+ (nr', o) = runRecurrent n nr y

143+ in (recin' :~@+> nr', o)

144+runRecurrent RNil RINil !x

145+ = (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+12−11

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE UndecidableInstances #-}

9

10+-- GHC 7.10 doesn't see recurrent run functions as total.

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

10module Grenade.Recurrent.Layers.BasicRecurrent (

12module Grenade.Recurrent.Layers.BasicRecurrent (

11 BasicRecurrent (..)

13 BasicRecurrent (..)

12 , randomBasicRecurrent

14 , randomBasicRecurrent

@@ -16,19 +18,18 @@ module Grenade.Recurrent.Layers.BasicRecurrent (

16

18

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

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

18

20

19−

20−import Data.Kind (Type)

21+import Data.Singletons.TypeLits

21

22

22import Numeric.LinearAlgebra.Static

23import Numeric.LinearAlgebra.Static

23

24

24import GHC.TypeLits

25import GHC.TypeLits

25

26

26import Grenade.Core

27import Grenade.Core

27−import Grenade.Recurrent.Core

28+import Grenade.Recurrent.Core.Network

28

29

29data BasicRecurrent :: Nat -- Input layer size

30data BasicRecurrent :: Nat -- Input layer size

30 -> Nat -- Output layer size

31 -> Nat -- Output layer size

31− -> Type where

32+ -> * where

32 BasicRecurrent :: ( KnownNat input

33 BasicRecurrent :: ( KnownNat input

33 , KnownNat output

34 , KnownNat output

34 , KnownNat matrixCols

35 , KnownNat matrixCols

@@ -41,7 +42,7 @@ data BasicRecurrent :: Nat -- Input layer size

41

42

42data BasicRecurrent' :: Nat -- Input layer size

43data BasicRecurrent' :: Nat -- Input layer size

43 -> Nat -- Output layer size

44 -> Nat -- Output layer size

44− -> Type where

45+ -> * where

45 BasicRecurrent' :: ( KnownNat input

46 BasicRecurrent' :: ( KnownNat input

46 , KnownNat output

47 , KnownNat output

47 , KnownNat matrixCols

48 , KnownNat matrixCols

@@ -56,18 +57,18 @@ instance Show (BasicRecurrent i o) where

56instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

57instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

57 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

58 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

58

59

59− runUpdate lp (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

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

60− let newBiasMomentum = konst (learningMomentum lp) * oldBiasMomentum - konst (learningRate lp) * biasGradient

61+ let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient

61 newBias = oldBias + newBiasMomentum

62 newBias = oldBias + newBiasMomentum

62− newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient

63+ newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient

63− regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations

64+ regulariser = konst (learningRegulariser * learningRate) * oldActivations

64 newActivations = oldActivations + newMomentum - regulariser

65 newActivations = oldActivations + newMomentum - regulariser

65 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

66 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

66

67

67 createRandom = randomBasicRecurrent

68 createRandom = randomBasicRecurrent

68

69

69instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where

70instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where

70− type RecurrentShape (BasicRecurrent i o) = S ('D1 o)

71+ type RecurrentShape (BasicRecurrent i o) = 'D1 o

71

72

72instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

73instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

73

74

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+84−58

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

5{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

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

10{-# LANGUAGE ViewPatterns #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12

13+-- GHC 7.10 doesn't see recurrent run functions as total.

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

13module Grenade.Recurrent.Layers.LSTM (

15module Grenade.Recurrent.Layers.LSTM (

14 LSTM (..)

16 LSTM (..)

15 , LSTMWeights (..)

17 , LSTMWeights (..)

@@ -21,30 +23,30 @@ import Control.Monad.Random ( MonadRandom, getRandom )

21-- import Data.List ( foldl1' )

23-- import Data.List ( foldl1' )

22import Data.Proxy

24import Data.Proxy

23import Data.Serialize

25import Data.Serialize

24−import Data.Kind (Type)

26+import Data.Singletons.TypeLits

25

27

26import qualified Numeric.LinearAlgebra as LA

28import qualified Numeric.LinearAlgebra as LA

27import Numeric.LinearAlgebra.Static

29import Numeric.LinearAlgebra.Static

28

30

29import Grenade.Core

31import Grenade.Core

30−import Grenade.Recurrent.Core

32+

31import Grenade.Layers.Internal.Update

33import Grenade.Layers.Internal.Update

32−import GHC.TypeLits

33

34

35+import Grenade.Recurrent.Core.Network

34

36

35-- | Long Short Term Memory Recurrent unit

37-- | Long Short Term Memory Recurrent unit

36--

38--

37-- This is a Peephole formulation, so the recurrent shape is

39-- This is a Peephole formulation, so the recurrent shape is

38-- just the cell state, the previous output is not held or used

40-- just the cell state, the previous output is not held or used

39-- at all.

41-- at all.

40−data LSTM :: Nat -> Nat -> Type where

42+data LSTM :: Nat -> Nat -> * where

41 LSTM :: ( KnownNat input

43 LSTM :: ( KnownNat input

42 , KnownNat output

44 , KnownNat output

43 ) => !(LSTMWeights input output) -- Weights

45 ) => !(LSTMWeights input output) -- Weights

44 -> !(LSTMWeights input output) -- Momentums

46 -> !(LSTMWeights input output) -- Momentums

45 -> LSTM input output

47 -> LSTM input output

46

48

47−data LSTMWeights :: Nat -> Nat -> Type where

49+data LSTMWeights :: Nat -> Nat -> * where

48 LSTMWeights :: ( KnownNat input

50 LSTMWeights :: ( KnownNat input

49 , KnownNat output

51 , KnownNat output

50 ) => {

52 ) => {

@@ -71,7 +73,7 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

71

73

72 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

74 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

73 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

75 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

74− runUpdate lp (LSTM w m) g =

76+ runUpdate LearningParameters {..} (LSTM w m) g =

75 let (wf, wf') = u lstmWf w m g

77 let (wf, wf') = u lstmWf w m g

76 (uf, uf') = u lstmUf w m g

78 (uf, uf') = u lstmUf w m g

77 (bf, bf') = v lstmBf w m g

79 (bf, bf') = v lstmBf w m g

@@ -88,11 +90,11 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

88 -- Utility function for updating with the momentum, gradients, and weights.

90 -- Utility function for updating with the momentum, gradients, and weights.

89 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

91 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

90 u e (e -> weights) (e -> momentum) (e -> gradient) =

92 u e (e -> weights) (e -> momentum) (e -> gradient) =

91− descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

93+ decendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum

92

94

93 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

95 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

94 v e (e -> weights) (e -> momentum) (e -> gradient) =

96 v e (e -> weights) (e -> momentum) (e -> gradient) =

95− descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

97+ decendVector learningRate learningMomentum learningRegulariser weights gradient momentum

96

98

97 -- There's a lot of updates here, so to try and minimise the number of data copies

99 -- There's a lot of updates here, so to try and minimise the number of data copies

98 -- we'll create a mutable bucket for each.

100 -- we'll create a mutable bucket for each.

@@ -124,33 +126,27 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

124instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

126instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

125 -- The recurrent shape is the same size as the output.

127 -- The recurrent shape is the same size as the output.

126 -- It's actually the cell state however, as this is a peephole variety LSTM.

128 -- It's actually the cell state however, as this is a peephole variety LSTM.

127− type RecurrentShape (LSTM i o) = S ('D1 o)

129+ type RecurrentShape (LSTM i o) = 'D1 o

128

130

129instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

131instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

130

132

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)

133+ type RecTape (LSTM i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))

134 -- Forward propagation for the LSTM layer.

135 -- The size of the cell state is also the size of the output.

136− runRecurrentForwards (LSTM lw _) (S1D cell) (S1D input) =

136+ runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =

137 let -- Forget state vector

138− f_s = lstmBf lw + lstmWf lw #> input + lstmUf lw #> cell

138+ f_t = sigmoid $ lstmBf + lstmWf #> input + lstmUf #> cell

139− f_t = sigmoid f_s

140 -- Input state vector

139 -- Input state vector

141− i_s = lstmBi lw + lstmWi lw #> input + lstmUi lw #> cell

140+ i_t = sigmoid $ lstmBi + lstmWi #> input + lstmUi #> cell

142− i_t = sigmoid i_s

143 -- Output state vector

141 -- Output state vector

144− o_s = lstmBo lw + lstmWo lw #> input + lstmUo lw #> cell

142+ o_t = sigmoid $ lstmBo + lstmWo #> input + lstmUo #> cell

145− o_t = sigmoid o_s

146 -- Cell input state vector

143 -- Cell input state vector

147− c_s = lstmBc lw + lstmWc lw #> input

144+ c_x = tanh $ lstmBc + lstmWc #> input

148− c_x = tanh c_s

149 -- Cell state

145 -- Cell state

150 c_t = f_t * cell + i_t * c_x

146 c_t = f_t * cell + i_t * c_x

151 -- Output (it's sometimes recommended to use tanh c_t)

147 -- Output (it's sometimes recommended to use tanh c_t)

152 h_t = o_t * c_t

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

149+ in ((S1D cell, S1D input), S1D c_t, S1D h_t)

154

150

155 -- Run a backpropogation step for an LSTM layer.

151 -- Run a backpropogation step for an LSTM layer.

156 -- We're doing all the derivatives by hand here, so one should

152 -- We're doing all the derivatives by hand here, so one should

@@ -158,8 +154,29 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

158 --

154 --

159 -- There's a test version using the AD library without hmatrix in the test

155 -- There's a test version using the AD library without hmatrix in the test

160 -- suite. These should match always.

156 -- 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') =

157+ runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (S1D cell, S1D input) (S1D cellGrad) (S1D h_t') =

158+ -- We're not keeping the Wengert tape during the forward pass,

159+ -- so we're duplicating some work here.

160+ --

161+ -- If I was being generous, I'd call it checkpointing.

162+ --

163+ -- Maybe think about better ways to store some intermediate states.

164+ let -- Forget state vector

165+ f_s = lstmBf + lstmWf #> input + lstmUf #> cell

166+ f_t = sigmoid f_s

167+ -- Input state vector

168+ i_s = lstmBi + lstmWi #> input + lstmUi #> cell

169+ i_t = sigmoid i_s

170+ -- Output state vector

171+ o_s = lstmBo + lstmWo #> input + lstmUo #> cell

172+ o_t = sigmoid o_s

173+ -- Cell input state vector

174+ c_s = lstmBc + lstmWc #> input

175+ c_x = tanh c_s

176+ -- Cell state

177+ c_t = f_t * cell + i_t * c_x

178+

162− let -- Reverse Mode AD Derivitives

179+ -- Reverse Mode AD Derivitives

163 c_t' = h_t' * o_t + cellGrad

180 c_t' = h_t' * o_t + cellGrad

164

181

165 f_t' = c_t' * cell

182 f_t' = c_t' * cell

@@ -175,8 +192,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

175 c_s' = tanh' c_s * c_x'

192 c_s' = tanh' c_s * c_x'

176

193

177 -- The derivatives to pass sideways (recurrent) and downwards

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

195+ cell' = tr lstmUf #> f_s' + tr lstmUo #> o_s' + tr lstmUi #> 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'

196+ input' = tr lstmWf #> f_s' + tr lstmWo #> o_s' + tr lstmWi #> i_s' + tr lstmWc #> c_s'

180

197

181 -- Calculate the gradient Matricies for the input

198 -- Calculate the gradient Matricies for the input

182 lstmWf' = f_s' `outer` input

199 lstmWf' = f_s' `outer` input

@@ -221,8 +238,7 @@ randomLSTM = do

221

238

222-- | Maths

239-- | Maths

223--

240--

224−-- TODO: Move to not here

241+-- TODO: move to not here

225−-- Optimise backwards derivative

226sigmoid :: Floating a => a -> a

242sigmoid :: Floating a => a -> a

227sigmoid x = 1 / (1 + exp (-x))

243sigmoid x = 1 / (1 + exp (-x))

228

244

@@ -235,34 +251,44 @@ tanh' :: (Floating a) => a -> a

235tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

251tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

236

252

237instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

253instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

238− put (LSTM lw _) = do

254+ put (LSTM LSTMWeights {..} _) = do

239− u (lstmWf lw)

255+ u lstmWf

240− u (lstmUf lw)

256+ u lstmUf

241− v (lstmBf lw)

257+ v lstmBf

242− u (lstmWi lw)

258+ u lstmWi

243− u (lstmUi lw)

259+ u lstmUi

244− v (lstmBi lw)

260+ v lstmBi

245− u (lstmWo lw)

261+ u lstmWo

246− u (lstmUo lw)

262+ u lstmUo

247− v (lstmBo lw)

263+ v lstmBo

248− u (lstmWc lw)

264+ u lstmWc

249− v (lstmBc lw)

265+ v lstmBc

250− where

266+ where

251− u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

267+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

252− u = putListOf put . LA.toList . LA.flatten . extract

268+ u = putListOf put . LA.toList . LA.flatten . extract

253− v :: forall a. (KnownNat a) => Putter (R a)

269+ v :: forall a. (KnownNat a) => Putter (R a)

254− v = putListOf put . LA.toList . extract

270+ v = putListOf put . LA.toList . extract

255

271

256 get = do

272 get = do

257− w <- LSTMWeights <$> u <*> u <*> v <*> u <*> u <*> v <*> u <*> u <*> v <*> u <*> v

273+ lstmWf <- u

274+ lstmUf <- u

275+ lstmBf <- v

276+ lstmWi <- u

277+ lstmUi <- u

278+ lstmBi <- v

279+ lstmWo <- u

280+ lstmUo <- u

281+ lstmBo <- v

282+ lstmWc <- u

283+ lstmBc <- v

258− return $ LSTM w (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

284+ return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

259− where

285+ where

260− u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

286+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

261− u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

287+ 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

288+ 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)

289+ v :: forall a. (KnownNat a) => Get (R a)

264− v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

290+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

265−

291+

266− w0 = konst 0

292+ w0 = konst 0

267− u0 = konst 0

293+ u0 = konst 0

268− v0 = konst 0

294+ v0 = konst 0

src/Grenade/Utils/OneHot.hs+5−6

@@ -22,6 +22,7 @@ import Data.Map ( Map )

22import qualified Data.Map as M

23

24import Data.Proxy

25+import Data.Singletons.TypeLits

25

26

26import Data.Vector ( Vector )

27import Data.Vector ( Vector )

27import qualified Data.Vector as V

28import qualified Data.Vector as V

@@ -30,7 +31,6 @@ import qualified Data.Vector.Storable as VS

30import Numeric.LinearAlgebra ( maxIndex )

31import Numeric.LinearAlgebra ( maxIndex )

31import Numeric.LinearAlgebra.Devel

32import Numeric.LinearAlgebra.Devel

32import Numeric.LinearAlgebra.Static

33import Numeric.LinearAlgebra.Static

33−import GHC.TypeLits

34

35import Grenade.Core.Shape

36

@@ -52,16 +52,15 @@ oneHot hot =

52

53-- | Create a one hot map from any enumerable.

54-- Returns a map, and the ordered list for the reverse transformation

55−hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Either String (Map a Int, Vector a)

55+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Maybe (Map a Int, Vector a)

56hotMap n as =

57 let len = fromIntegral $ natVal n

58 uniq = [ c | (c:_) <- group $ sort as]

59 hotl = length uniq

60− in if hotl == len

60+ in if hotl <= len

61 then

62− Right (M.fromList $ zip uniq [0..], V.fromList uniq)

62+ Just (M.fromList $ zip uniq [0..], V.fromList uniq)

63− else

63+ else Nothing

64− Left ("Couldn't create hotMap of size " ++ show len ++ " from vector with " ++ show hotl ++ " unique characters")

65

64

66-- | From a map and value, create a 1D Shape

65-- | From a map and value, create a 1D Shape

67-- with one index hot (1) with the rest 0.

66-- 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+24−29

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE TemplateHaskell #-}

1{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

@@ -16,21 +15,15 @@ import Data.Singletons ()

16import GHC.TypeLits

15import GHC.TypeLits

17import GHC.TypeLits.Witnesses

16import GHC.TypeLits.Witnesses

18

17

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

20−import Data.Kind (Type)

21−#endif

22−

23import Grenade.Core

18import Grenade.Core

24import Grenade.Layers.Convolution

19import Grenade.Layers.Convolution

25

20

26−import Hedgehog

21+import Disorder.Jack

27−import qualified Hedgehog.Gen as Gen

28

22

29−import Test.Hedgehog.Hmatrix

23+import Test.Jack.Hmatrix

30−import Test.Hedgehog.TypeLits

24+import Test.Jack.TypeLits

31−import Test.Hedgehog.Compat

32

25

33−data OpaqueConvolution :: Type where

26+data OpaqueConvolution :: * where

34 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution

27 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution

35

28

36instance Show OpaqueConvolution where

29instance Show OpaqueConvolution where

@@ -44,10 +37,10 @@ genConvolution :: ( KnownNat channels

44 , KnownNat strideColumns

37 , KnownNat strideColumns

45 , KnownNat kernelFlattened

38 , KnownNat kernelFlattened

46 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

39 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

47− ) => Gen (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

40+ ) => Jack (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

48genConvolution = Convolution <$> uniformSample <*> uniformSample

41genConvolution = Convolution <$> uniformSample <*> uniformSample

49

42

50−genOpaqueOpaqueConvolution :: Gen OpaqueConvolution

43+genOpaqueOpaqueConvolution :: Jack OpaqueConvolution

51genOpaqueOpaqueConvolution = do

44genOpaqueOpaqueConvolution = do

52 channels <- genNat

45 channels <- genNat

53 filters <- genNat

46 filters <- genNat

@@ -63,17 +56,17 @@ genOpaqueOpaqueConvolution = do

63 p2 = natDict pkc

56 p2 = natDict pkc

64 p3 = natDict pch

57 p3 = natDict pch

65 in case p1 %* p2 %* p3 of

58 in case p1 %* p2 %* p3 of

66− Dict -> OpaqueConvolution <$> (genConvolution :: Gen (Convolution ch fl kr kc sr sc))

59+ Dict -> OpaqueConvolution <$> (genConvolution :: Jack (Convolution ch fl kr kc sr sc))

67−

68−prop_conv_net_witness = property $

69− blindForAll genOpaqueOpaqueConvolution >>= \onet ->

70− case onet of

71− (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> success

72

60

61+prop_conv_net_witness =

62+ gamble genOpaqueOpaqueConvolution $ \onet ->

63+ (case onet of

64+ (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> True

65+ ) :: Bool

73

66

74−prop_conv_net = property $

67+prop_conv_net =

75− blindForAll genOpaqueOpaqueConvolution >>= \onet ->

68+ gamble genOpaqueOpaqueConvolution $ \onet ->

76− case onet of

69+ (case onet of

77 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->

70 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->

78 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]

71 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]

79 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

72 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

@@ -81,15 +74,15 @@ prop_conv_net = property $

81 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)

74 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)

82 sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)

75 sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)

83

76

84− in forAll (Gen.element (ok sr kr)) >>= \er ->

77+ in gamble (elements (ok sr kr)) $ \er ->

85− forAll (Gen.element (ok sc kc)) >>= \ec ->

78+ gamble (elements (ok sc kc)) $ \ec ->

86 let rr = ((er - kr) `div` sr) + 1

79 let rr = ((er - kr) `div` sr) + 1

87 rc = ((ec - kc) `div` sc) + 1

80 rc = ((ec - kc) `div` sc) + 1

88 Just er' = someNatVal er

81 Just er' = someNatVal er

89 Just ec' = someNatVal ec

82 Just ec' = someNatVal ec

90 Just rr' = someNatVal rr

83 Just rr' = someNatVal rr

91 Just rc' = someNatVal rc

84 Just rc' = someNatVal rc

92− in case (er', ec', rr', rc') of

85+ in (case (er', ec', rr', rc') of

93 ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->

86 ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->

94 case ( natDict pinr %* natDict (Proxy :: Proxy channels)

87 case ( natDict pinr %* natDict (Proxy :: Proxy channels)

95 , natDict pour %* natDict (Proxy :: Proxy filters)

88 , natDict pour %* natDict (Proxy :: Proxy filters)

@@ -97,12 +90,14 @@ prop_conv_net = property $

97 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

90 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

98 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

91 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

99 (Dict, Dict, Dict, Dict) ->

92 (Dict, Dict, Dict, Dict) ->

100− blindForAll (S3D <$> uniformSample) >>= \(input :: S ('D3 inRows inCols channels)) ->

93+ gamble (S3D <$> uniformSample) $ \(input :: S ('D3 inRows inCols channels)) ->

101 let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input

94 let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input

102 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))

95 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))

103 = runBackwards convLayer tape output

96 = runBackwards convLayer tape output

104− in backed `seq` success

97+ in backed `seq` True

105−

98+ ) :: Property

99+ ) :: Property

106

100

101+return []

107tests :: IO Bool

102tests :: IO Bool

108−tests = checkParallel $$(discover)

103+tests = $quickCheckAll

test/Test/Grenade/Layers/FullyConnected.hs+17−21

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

4{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

@@ -13,28 +12,24 @@ import Data.Singletons ()

13

12

14import GHC.TypeLits

13import GHC.TypeLits

15

14

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

17−import Data.Kind (Type)

18−#endif

19−

20import Grenade.Core

15import Grenade.Core

21import Grenade.Layers.FullyConnected

16import Grenade.Layers.FullyConnected

22

17

23−import Hedgehog

18+import Disorder.Jack

19+

20+import Test.Jack.Hmatrix

24

21

25−import Test.Hedgehog.Compat

26−import Test.Hedgehog.Hmatrix

27

22

28−data OpaqueFullyConnected :: Type where

23+data OpaqueFullyConnected :: * where

29 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected

24 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected

30

25

31instance Show OpaqueFullyConnected where

26instance Show OpaqueFullyConnected where

32 show (OpaqueFullyConnected n) = show n

27 show (OpaqueFullyConnected n) = show n

33

28

34−genOpaqueFullyConnected :: Gen OpaqueFullyConnected

29+genOpaqueFullyConnected :: Jack OpaqueFullyConnected

35genOpaqueFullyConnected = do

30genOpaqueFullyConnected = do

36− input :: Integer <- choose 2 100

31+ input :: Integer <- choose (2, 100)

37− output :: Integer <- choose 1 100

32+ output :: Integer <- choose (1, 100)

38 let Just input' = someNatVal input

33 let Just input' = someNatVal input

39 let Just output' = someNatVal output

34 let Just output' = someNatVal output

40 case (input', output') of

35 case (input', output') of

@@ -46,13 +41,14 @@ genOpaqueFullyConnected = do

46 return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')

41 return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')

47

42

48prop_fully_connected_forwards :: Property

43prop_fully_connected_forwards :: Property

49−prop_fully_connected_forwards = property $ do

44+prop_fully_connected_forwards =

50− OpaqueFullyConnected (fclayer :: FullyConnected i o) <- blindForAll genOpaqueFullyConnected

45+ gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->

51− input :: S ('D1 i) <- blindForAll (S1D <$> randomVector)

46+ gamble (S1D <$> randomVector) $ \(input :: S ('D1 i)) ->

52− let (tape, output :: S ('D1 o)) = runForwards fclayer input

47+ let (tape, output :: S ('D1 o)) = runForwards fclayer input

53− backed :: (Gradient (FullyConnected i o), S ('D1 i))

48+ backed :: (Gradient (FullyConnected i o), S ('D1 i))

54− = runBackwards fclayer tape output

49+ = runBackwards fclayer tape output

55− backed `seq` success

50+ in backed `seq` True

56−

51+

52+return []

57tests :: IO Bool

53tests :: IO Bool

58−tests = checkParallel $$(discover)

54+tests = $quickCheckAll

test/Test/Grenade/Layers/Internal/Convolution.hs+29−34

@@ -12,46 +12,41 @@ import Grenade.Layers.Internal.Convolution

12

13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

14

15−import Hedgehog

15+import Disorder.Jack

16−import qualified Hedgehog.Gen as Gen

17−import qualified Hedgehog.Range as Range

18

16

19import qualified Test.Grenade.Layers.Internal.Reference as Reference

17import qualified Test.Grenade.Layers.Internal.Reference as Reference

20−import Test.Hedgehog.Compat

21

18

22prop_im2col_col2im_symmetrical_with_kernel_stride =

19prop_im2col_col2im_symmetrical_with_kernel_stride =

23 let factors n = [x | x <- [1..n], n `mod` x == 0]

20 let factors n = [x | x <- [1..n], n `mod` x == 0]

24− in property $ do

21+ in gamble (choose (2, 100)) $ \height ->

25− height <- forAll $ choose 2 100

22+ gamble (choose (2, 100)) $ \width ->

26− width <- forAll $ choose 2 100

23+ gamble ((height `div`) <$> elements (factors height)) $ \kernel_h ->

27− kernel_h <- forAll $ (height `div`) <$> Gen.element (factors height)

24+ gamble ((width `div`) <$> elements (factors width)) $ \kernel_w ->

28− kernel_w <- forAll $ (width `div`) <$> Gen.element (factors width)

25+ gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

29− input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

26+ let input' = (height >< width) input

30−

31− let stride_h = kernel_h

27+ stride_h = kernel_h

32− let stride_w = kernel_w

28+ 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

29+ 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

30+ in input' === out

35

31

36prop_im2col_col2im_behaves_as_reference =

32prop_im2col_col2im_behaves_as_reference =

37 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

33 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

38− in property $ do

39− height <- forAll (choose 2 100)

34+ in gamble (choose (2, 100)) $ \height ->

40− width <- forAll (choose 2 100)

35+ gamble (choose (2, 100)) $ \width ->

41− kernel_h <- forAll (choose 2 (height - 1))

36+ gamble (choose (2, height - 1)) $ \kernel_h ->

42− kernel_w <- forAll (choose 2 (width - 1))

37+ gamble (choose (2, width - 1)) $ \kernel_w ->

43− stride_h <- forAll (Gen.element (ok height kernel_h))

38+ gamble (elements (ok height kernel_h)) $ \stride_h ->

44− stride_w <- forAll (Gen.element (ok width kernel_w))

39+ gamble (elements (ok width kernel_w)) $ \stride_w ->

45− input <- forAll ((height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100))

40+ gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

46−

41+ let input' = (height >< width) input

47− let outFast = im2col kernel_h kernel_w stride_h stride_w input

42+ 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

43+ retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast

49−

44+

50− let outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input

45+ 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

46+ retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference

52−

53− outFast === outReference

47+ in outFast === outReference .&&. retFast === retReference

54− retFast === retReference

48+

55−

49+

50+return []

56tests :: IO Bool

51tests :: 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

12

13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

14

15−import Hedgehog

15+import Disorder.Jack

16−import qualified Hedgehog.Gen as Gen

17−import qualified Hedgehog.Range as Range

18

16

19import qualified Test.Grenade.Layers.Internal.Reference as Reference

17import qualified Test.Grenade.Layers.Internal.Reference as Reference

20−import Test.Hedgehog.Compat

21

18

22prop_poolForwards_poolBackwards_behaves_as_reference =

19prop_poolForwards_poolBackwards_behaves_as_reference =

23 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

20 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

24 output extent kernel stride = (extent - kernel) `div` stride + 1

21 output extent kernel stride = (extent - kernel) `div` stride + 1

25− in property $ do

22+ in gamble (choose (2, 100)) $ \height ->

26− height <- forAll $ choose 2 100

27− width <- forAll $ choose 2 100

23+ gamble (choose (2, 100)) $ \width ->

28− kernel_h <- forAll $ choose 1 (height - 1)

24+ gamble (choose (1, height - 1)) $ \kernel_h ->

29− kernel_w <- forAll $ choose 1 (width - 1)

25+ gamble (choose (1, width - 1)) $ \kernel_w ->

30− stride_h <- forAll $ Gen.element (ok height kernel_h)

26+ gamble (elements (ok height kernel_h)) $ \stride_h ->

31− stride_w <- forAll $ Gen.element (ok width kernel_w)

27+ gamble (elements (ok width kernel_w)) $ \stride_w ->

32− input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

28+ gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

33−

29+ let input' = (height >< width) input

34− let outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input

30+ 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

31+ retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast

36−

32+

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

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'

38− let retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input outReference

34+ retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference

39−

40− outFast === outReference

35+ in outFast === outReference .&&. retFast === retReference

41− retFast === retReference

36+

42−

37+return []

43−

44tests :: IO Bool

38tests :: IO Bool

45−tests = checkParallel $$(discover)

39+tests = $quickCheckAll

test/Test/Grenade/Layers/Nonlinear.hs+31−13

@@ -11,44 +11,62 @@ module Test.Grenade.Layers.Nonlinear where

11import Data.Singletons

12

13import Grenade

14+import GHC.TypeLits

14

15

15−import Hedgehog

16+import Disorder.Jack

16

17

17−import Test.Hedgehog.Compat

18+import Test.Jack.Hmatrix

18−import Test.Hedgehog.Hmatrix

19−import Test.Hedgehog.TypeLits

19+import Test.Jack.TypeLits

20

21import Numeric.LinearAlgebra.Static ( norm_Inf )

22

23prop_sigmoid_grad :: Property

24−prop_sigmoid_grad = property $

24+prop_sigmoid_grad =

25− forAllWith rss genShape >>= \case

25+ gambleDisplay (const "Shape") genShape $ \case

26 (SomeSing (r :: Sing s)) ->

27 withSingI r $

28− blindForAll genOfShape >>= \(ds :: S s) ->

28+ gamble 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 counterexample (show numericalGradient ++ show ret)

33− in assert ((case numericalGradient - ret of

34+ ((case numericalGradient - ret of

34 (S1D x) -> norm_Inf x < 0.0001

35 (S1D x) -> norm_Inf x < 0.0001

35 (S2D x) -> norm_Inf x < 0.0001

36 (S2D x) -> norm_Inf x < 0.0001

36 (S3D x) -> norm_Inf x < 0.0001) :: Bool)

37 (S3D x) -> norm_Inf x < 0.0001) :: Bool)

37

38

38prop_tanh_grad :: Property

39prop_tanh_grad :: Property

39−prop_tanh_grad = property $

40+prop_tanh_grad =

40− forAllWith rss genShape >>= \case

41+ gambleDisplay (const "Shape") genShape $ \case

41 (SomeSing (r :: Sing s)) ->

42 (SomeSing (r :: Sing s)) ->

42 withSingI r $

43 withSingI r $

43− blindForAll genOfShape >>= \(ds :: S s) ->

44+ gamble genOfShape $ \(ds :: S s) ->

44 let (tape, f :: S s) = runForwards Tanh ds

45 let (tape, f :: S s) = runForwards Tanh ds

45 ((), ret :: S s) = runBackwards Tanh tape (1 :: S s)

46 ((), ret :: S s) = runBackwards Tanh tape (1 :: S s)

46 (_, numer :: S s) = runForwards Tanh (ds + 0.0001)

47 (_, numer :: S s) = runForwards Tanh (ds + 0.0001)

47 numericalGradient = (numer - f) * 10000

48 numericalGradient = (numer - f) * 10000

49+ in counterexample (show numericalGradient ++ show ret)

48− in assert ((case numericalGradient - ret of

50+ ((case numericalGradient - ret of

49 (S1D x) -> norm_Inf x < 0.001

51 (S1D x) -> norm_Inf x < 0.001

50 (S2D x) -> norm_Inf x < 0.001

52 (S2D x) -> norm_Inf x < 0.001

51 (S3D x) -> norm_Inf x < 0.001) :: Bool)

53 (S3D x) -> norm_Inf x < 0.001) :: Bool)

52

54

55+prop_softmax_grad :: Property

56+prop_softmax_grad =

57+ gamble genNat $ \case

58+ (SomeNat (_ :: Proxy s)) ->

59+ gamble genOfShape $ \(ds :: S ('D1 s)) ->

60+ let (tape, f :: S ('D1 s)) = runForwards Relu ds

61+ ((), ret :: S ('D1 s)) = runBackwards Relu tape (1 :: S ('D1 s))

62+ (_, numer :: S ('D1 s)) = runForwards Relu (ds + 0.0001)

63+ numericalGradient = (numer - f) * 10000

64+ in counterexample (show numericalGradient ++ show ret)

65+ ((case numericalGradient - ret of

66+ (S1D x) -> norm_Inf x < 0.0001) :: Bool)

67+

68+

69+return []

53tests :: IO Bool

70tests :: IO Bool

54−tests = checkParallel $$(discover)

71+tests = $quickCheckAll

72+

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

2{-# LANGUAGE TemplateHaskell #-}

1{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE KindSignatures #-}

3{-# LANGUAGE KindSignatures #-}

@@ -10,40 +9,36 @@ module Test.Grenade.Layers.Pooling where

10import Data.Proxy

9import Data.Proxy

11import Data.Singletons ()

10import Data.Singletons ()

12

11

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

14−import Data.Kind (Type)

15−#endif

16−

17import GHC.TypeLits

12import GHC.TypeLits

18import Grenade.Layers.Pooling

13import Grenade.Layers.Pooling

19

14

20−import Hedgehog

15+import Disorder.Jack

21

16

22−import Test.Hedgehog.Compat

23

17

24−data OpaquePooling :: Type where

18+data OpaquePooling :: * where

25 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

19 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

26

20

27instance Show OpaquePooling where

21instance Show OpaquePooling where

28 show (OpaquePooling n) = show n

22 show (OpaquePooling n) = show n

29

23

30−genOpaquePooling :: Gen OpaquePooling

24+genOpaquePooling :: Jack OpaquePooling

31genOpaquePooling = do

25genOpaquePooling = do

32− ~(Just kernelHeight) <- someNatVal <$> choose 2 15

26+ Just kernelHeight <- someNatVal <$> choose (2, 15)

33− ~(Just kernelWidth ) <- someNatVal <$> choose 2 15

27+ Just kernelWidth <- someNatVal <$> choose (2, 15)

34− ~(Just strideHeight) <- someNatVal <$> choose 2 15

28+ Just strideHeight <- someNatVal <$> choose (2, 15)

35− ~(Just strideWidth ) <- someNatVal <$> choose 2 15

29+ Just strideWidth <- someNatVal <$> choose (2, 15)

36

30

37 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

31 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

38 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

32 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

39 return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)

33 return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)

40

34

41prop_pool_layer_witness =

35prop_pool_layer_witness =

42− property $ do

36+ gamble genOpaquePooling $ \onet ->

43− onet <- forAll genOpaquePooling

44− case onet of

37+ (case onet of

45− (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) ->

38+ (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) -> True

46− assert True

39+ ) :: Bool

40+

47

41

42+return []

48tests :: IO Bool

43tests :: 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 @@

10{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

11module Test.Grenade.Recurrent.Layers.LSTM where

12

13−import Hedgehog

13+import Disorder.Jack

14−import Hedgehog.Internal.Source

15−import Hedgehog.Internal.Show

16−import Hedgehog.Internal.Property ( failWith, Diff (..) )

17

14

18import Data.Foldable ( toList )

15import Data.Foldable ( toList )

19import Data.Singletons.TypeLits

16import Data.Singletons.TypeLits

@@ -26,9 +23,9 @@ import qualified Numeric.LinearAlgebra.Static as S

26

23

27

24

28import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

25import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

29−import Test.Hedgehog.Hmatrix

26+import Test.Jack.Hmatrix

30

27

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)

32genLSTM = do

29genLSTM = do

33 let w = uniformSample

30 let w = uniformSample

34 u = uniformSample

31 u = uniformSample

@@ -42,89 +39,63 @@ genLSTM = do

42 <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

39 <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

43

40

44prop_lstm_reference_forwards =

41prop_lstm_reference_forwards =

45− property $ do

42+ gamble randomVector $ \(input :: S.R 3) ->

46− input :: S.R 3 <- forAll randomVector

43+ gamble randomVector $ \(cell :: S.R 2) ->

47− cell :: S.R 2 <- forAll randomVector

48− net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

44+ gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

49−

50− let actual = runRecurrentForwards net (S1D cell) (S1D input)

45+ let actual = runRecurrentForwards net (S1D cell) (S1D input)

51− case actual of

46+ in case actual of

52− (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->

47+ (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->

53− let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut

48+ let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut

54− output' = Reference.Vector . H.toList . S.extract $ output

49+ output' = Reference.Vector . H.toList . S.extract $ output

55− refNet = Reference.lstmToReference lstmWeights

50+ refNet = Reference.lstmToReference lstmWeights

56− refCell = Reference.Vector . H.toList . S.extract $ cell

51+ refCell = Reference.Vector . H.toList . S.extract $ cell

57− refInput = Reference.Vector . H.toList . S.extract $ input

52+ refInput = Reference.Vector . H.toList . S.extract $ input

58− (refCO, refO) = Reference.runLSTM refNet refCell refInput

53+ (refCO, refO) = Reference.runLSTM refNet refCell refInput

59− in do toList refCO ~~~ toList cellOut'

54+ in toList refCO ~~~ toList cellOut' .&&. toList refO ~~~ toList output'

60− toList refO ~~~ toList output'

61−

62

55

63prop_lstm_reference_backwards =

56prop_lstm_reference_backwards =

64− property $ do

57+ gamble randomVector $ \(input :: S.R 3) ->

65− input :: S.R 3 <- forAll randomVector

58+ gamble randomVector $ \(cell :: S.R 2) ->

66− cell :: S.R 2 <- forAll randomVector

67− net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

59+ gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

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

60+ let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

71− case actualBacks of

61+ in case actualBacks of

72− (actualGradients, _, _ :: S ('D1 3)) ->

62+ (actualGradients, _, _ :: S ('D1 3)) ->

73− let refNet = Reference.lstmToReference lstmWeights

63+ let refNet = Reference.lstmToReference lstmWeights

74− refCell = Reference.Vector . H.toList . S.extract $ cell

64+ refCell = Reference.Vector . H.toList . S.extract $ cell

75− refInput = Reference.Vector . H.toList . S.extract $ input

65+ refInput = Reference.Vector . H.toList . S.extract $ input

76− refGradients = Reference.runLSTMback refCell refInput refNet

66+ refGradients = Reference.runLSTMback refCell refInput refNet

77− in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)

67+ in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)

78

68

79prop_lstm_reference_backwards_input =

69prop_lstm_reference_backwards_input =

80− property $ do

70+ gamble randomVector $ \(input :: S.R 3) ->

81− input :: S.R 3 <- forAll randomVector

71+ gamble randomVector $ \(cell :: S.R 2) ->

82− cell :: S.R 2 <- forAll randomVector

83− net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

72+ gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

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

73+ let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

87− case actualBacks of

74+ in case actualBacks of

88− (_, _, S1D actualGradients :: S ('D1 3)) ->

75+ (_, _, S1D actualGradients :: S ('D1 3)) ->

89− let refNet = Reference.lstmToReference lstmWeights

76+ let refNet = Reference.lstmToReference lstmWeights

90− refCell = Reference.Vector . H.toList . S.extract $ cell

77+ refCell = Reference.Vector . H.toList . S.extract $ cell

91− refInput = Reference.Vector . H.toList . S.extract $ input

78+ refInput = Reference.Vector . H.toList . S.extract $ input

92− refGradients = Reference.runLSTMbackOnInput refCell refNet refInput

79+ refGradients = Reference.runLSTMbackOnInput refCell refNet refInput

93− in toList refGradients ~~~ H.toList (S.extract actualGradients)

80+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

94

81

95prop_lstm_reference_backwards_cell =

82prop_lstm_reference_backwards_cell =

96− property $ do

83+ gamble randomVector $ \(input :: S.R 3) ->

97− input :: S.R 3 <- forAll randomVector

84+ gamble randomVector $ \(cell :: S.R 2) ->

98− cell :: S.R 2 <- forAll randomVector

99− net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

85+ gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

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

86+ let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

103− case actualBacks of

87+ in case actualBacks of

104− (_, S1D actualGradients, _ :: S ('D1 3)) ->

88+ (_, S1D actualGradients, _ :: S ('D1 3)) ->

105− let refNet = Reference.lstmToReference lstmWeights

89+ let refNet = Reference.lstmToReference lstmWeights

106− refCell = Reference.Vector . H.toList . S.extract $ cell

90+ refCell = Reference.Vector . H.toList . S.extract $ cell

107− refInput = Reference.Vector . H.toList . S.extract $ input

91+ refInput = Reference.Vector . H.toList . S.extract $ input

108− refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

92+ refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

109− in toList refGradients ~~~ H.toList (S.extract actualGradients)

93+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

110−

94+

111−(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> PropertyT m ()

95+

112−(~~~) x y =

113− if all (< 1e-8) (zipWith (-) x y) then

96+(~~~) as bs = all (< 1e-8) (zipWith (-) as bs)

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

127infix 4 ~~~

97infix 4 ~~~

128

98

99+return []

129tests :: IO Bool

100tests :: IO Bool

130−tests = checkParallel $$(discover)

101+tests = $quickCheckAll

test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+21−25

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

6{-# LANGUAGE DeriveFunctor #-}

7{-# LANGUAGE DeriveFoldable #-}

8{-# LANGUAGE DeriveTraversable #-}

9+{-# LANGUAGE RecordWildCards #-}

9{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE RankNTypes #-}

11

12

@@ -14,13 +15,9 @@ module Test.Grenade.Recurrent.Layers.LSTM.Reference where

14

15

15import Data.Reflection

16import Data.Reflection

16import Numeric.AD.Mode.Reverse

17import Numeric.AD.Mode.Reverse

17−import Numeric.AD.Internal.Reverse (Tape)

18+import Numeric.AD.Internal.Reverse ( Tape )

18

19

19−import GHC.TypeLits (KnownNat)

20−

21−import Grenade.Recurrent.Layers.LSTM (LSTMWeights (..))

22import qualified Grenade.Recurrent.Layers.LSTM as LSTM

20import qualified Grenade.Recurrent.Layers.LSTM as LSTM

23−

24import qualified Numeric.LinearAlgebra.Static as S

21import qualified Numeric.LinearAlgebra.Static as S

25import qualified Numeric.LinearAlgebra as H

22import qualified Numeric.LinearAlgebra as H

26

23

@@ -57,32 +54,31 @@ data RefLSTM a = RefLSTM

57 , refLstmBc :: Vector a -- Bias Cell (b_c)

54 , refLstmBc :: Vector a -- Bias Cell (b_c)

58 } deriving (Functor, Foldable, Traversable, Eq, Show)

55 } deriving (Functor, Foldable, Traversable, Eq, Show)

59

56

60−lstmToReference :: (KnownNat a, KnownNat b) => LSTM.LSTMWeights a b -> RefLSTM Double

57+lstmToReference :: LSTM.LSTMWeights a b -> RefLSTM Double

61−lstmToReference lw =

58+lstmToReference LSTM.LSTMWeights {..} =

62− RefLSTM

63− { refLstmWf = Matrix . H.toLists . S.extract $ lstmWf lw -- Weight Forget (W_f)

59+ let refLstmWf = Matrix . H.toLists . S.extract $ lstmWf -- Weight Forget (W_f)

64− , refLstmUf = Matrix . H.toLists . S.extract $ lstmUf lw -- Cell State Forget (U_f)

60+ refLstmUf = Matrix . H.toLists . S.extract $ lstmUf -- Cell State Forget (U_f)

65− , refLstmBf = Vector . H.toList . S.extract $ lstmBf lw -- Bias Forget (b_f)

61+ refLstmBf = Vector . H.toList . S.extract $ lstmBf -- Bias Forget (b_f)

66− , refLstmWi = Matrix . H.toLists . S.extract $ lstmWi lw -- Weight Input (W_i)

62+ refLstmWi = Matrix . H.toLists . S.extract $ lstmWi -- Weight Input (W_i)

67− , refLstmUi = Matrix . H.toLists . S.extract $ lstmUi lw -- Cell State Input (U_i)

63+ refLstmUi = Matrix . H.toLists . S.extract $ lstmUi -- Cell State Input (U_i)

68− , refLstmBi = Vector . H.toList . S.extract $ lstmBi lw -- Bias Input (b_i)

64+ refLstmBi = Vector . H.toList . S.extract $ lstmBi -- Bias Input (b_i)

69− , refLstmWo = Matrix . H.toLists . S.extract $ lstmWo lw -- Weight Output (W_o)

65+ refLstmWo = Matrix . H.toLists . S.extract $ lstmWo -- Weight Output (W_o)

70− , refLstmUo = Matrix . H.toLists . S.extract $ lstmUo lw -- Cell State Output (U_o)

66+ refLstmUo = Matrix . H.toLists . S.extract $ lstmUo -- Cell State Output (U_o)

71− , refLstmBo = Vector . H.toList . S.extract $ lstmBo lw -- Bias Output (b_o)

67+ refLstmBo = Vector . H.toList . S.extract $ lstmBo -- Bias Output (b_o)

72− , refLstmWc = Matrix . H.toLists . S.extract $ lstmWc lw -- Weight Cell (W_c)

68+ refLstmWc = Matrix . H.toLists . S.extract $ lstmWc -- Weight Cell (W_c)

73− , refLstmBc = Vector . H.toList . S.extract $ lstmBc lw -- Bias Cell (b_c)

69+ refLstmBc = Vector . H.toList . S.extract $ lstmBc -- Bias Cell (b_c)

74− }

70+ in RefLSTM {..}

75

71

76runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

72runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

77−runLSTM rl cell input =

73+runLSTM RefLSTM {..} cell input =

78 let -- Forget state vector

74 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

80 -- Input state vector

76 -- Input state vector

81− i_t = sigmoid $ refLstmBi rl #+ refLstmWi rl #> input #+ refLstmUi rl #> cell

77+ i_t = sigmoid $ refLstmBi #+ refLstmWi #> input #+ refLstmUi #> cell

82 -- Output state vector

78 -- Output state vector

83− o_t = sigmoid $ refLstmBo rl #+ refLstmWo rl #> input #+ refLstmUo rl #> cell

79+ o_t = sigmoid $ refLstmBo #+ refLstmWo #> input #+ refLstmUo #> cell

84 -- Cell input state vector

80 -- Cell input state vector

85− c_x = fmap tanh $ refLstmBc rl #+ refLstmWc rl #> input

81+ c_x = fmap tanh $ refLstmBc #+ refLstmWc #> input

86 -- Cell state

82 -- Cell state

87 c_t = f_t #* cell #+ i_t #* c_x

83 c_t = f_t #* cell #+ i_t #* c_x

88 -- Output (it's sometimes recommended to use tanh c_t)

84 -- 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+54

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

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE RankNTypes #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE PolyKinds #-}

6+module Test.Jack.TypeLits where

7+

8+import Data.Constraint

9+#if __GLASGOW_HASKELL__ < 800

10+import Data.Proxy

11+#endif

12+import Data.Singletons

13+import Disorder.Jack

14+

15+import Grenade

16+

17+import GHC.TypeLits

18+import GHC.TypeLits.Witnesses

19+

20+genNat :: Jack SomeNat

21+genNat = do

22+ Just n <- someNatVal <$> choose (1, 10)

23+ return n

24+

25+genShape :: Jack (SomeSing Shape)

26+genShape

27+ = oneOf [

28+ genD1

29+ , genD2

30+ , genD3

31+ ]

32+

33+genD1 :: Jack (SomeSing Shape)

34+genD1 = do

35+ n <- genNat

36+ return $ case n of

37+ SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

38+

39+genD2 :: Jack (SomeSing Shape)

40+genD2 = do

41+ n <- genNat

42+ m <- genNat

43+ return $ case (n, m) of

44+ (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

45+

46+genD3 :: Jack (SomeSing Shape)

47+genD3 = do

48+ n <- genNat

49+ m <- genNat

50+ o <- genNat

51+ return $ case (n, m, o) of

52+ (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->

53+ case natDict px %* natDict pz of

54+ Dict -> SomeSing (sing :: Sing ('D3 x y z))

test/test.hs+2−24

@@ -1,47 +1,25 @@

1−import Control.Monad

1+import Disorder.Core.Main

2−

3−import qualified Test.Grenade.Network

4

2

5import qualified Test.Grenade.Layers.Pooling

3import qualified Test.Grenade.Layers.Pooling

6import qualified Test.Grenade.Layers.Convolution

4import qualified Test.Grenade.Layers.Convolution

7import qualified Test.Grenade.Layers.FullyConnected

5import qualified Test.Grenade.Layers.FullyConnected

8import qualified Test.Grenade.Layers.Nonlinear

6import qualified Test.Grenade.Layers.Nonlinear

9−import qualified Test.Grenade.Layers.PadCrop

10

7

11import qualified Test.Grenade.Layers.Internal.Convolution

8import qualified Test.Grenade.Layers.Internal.Convolution

12import qualified Test.Grenade.Layers.Internal.Pooling

9import qualified Test.Grenade.Layers.Internal.Pooling

13

10

14import qualified Test.Grenade.Recurrent.Layers.LSTM

11import qualified Test.Grenade.Recurrent.Layers.LSTM

15

12

16−import System.Exit

17−import System.IO

18−

19main :: IO ()

13main :: IO ()

20main =

14main =

21 disorderMain [

15 disorderMain [

22− Test.Grenade.Network.tests

23−

24− , Test.Grenade.Layers.Pooling.tests

16+ Test.Grenade.Layers.Pooling.tests

25 , Test.Grenade.Layers.Convolution.tests

17 , Test.Grenade.Layers.Convolution.tests

26 , Test.Grenade.Layers.FullyConnected.tests

18 , Test.Grenade.Layers.FullyConnected.tests

27 , Test.Grenade.Layers.Nonlinear.tests

19 , Test.Grenade.Layers.Nonlinear.tests

28− , Test.Grenade.Layers.PadCrop.tests

29

20

30 , Test.Grenade.Layers.Internal.Convolution.tests

21 , Test.Grenade.Layers.Internal.Convolution.tests

31 , Test.Grenade.Layers.Internal.Pooling.tests

22 , Test.Grenade.Layers.Internal.Pooling.tests

32

23

33 , Test.Grenade.Recurrent.Layers.LSTM.tests

24 , Test.Grenade.Recurrent.Layers.LSTM.tests

34−

35 ]

25 ]

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