3e9549e..master · grenade

.gitignore+3−1

since splitsnapshots

unifiedsplit

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

1+cabal.project.local

1.cabal-sandbox/

2.cabal-sandbox/

2cabal.sandbox.config

3cabal.sandbox.config

3dist/

4dist/

4−

5+dist-newstyle/

6+.stack-work/

.gitmodulesdeleted−15

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

1−[submodule "lib/disorder"]

2− path = lib/disorder

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

4−[submodule "lib/x"]

5− path = lib/x

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

7−[submodule "lib/p"]

8− path = lib/p

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

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

11− path = lib/disorder.hs

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

13−[submodule "lib/hmatrix"]

14− path = lib/hmatrix

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

.travis.yml+12−14

@@ -2,32 +2,30 @@

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.

4env:

5+ - GHCVER=8.0.2

5− - CABALVER=1.22 GHCVER=7.10.3

6+ - GHCVER=8.2.2

6− - CABALVER=1.24 GHCVER=8.0.1

7+ - GHCVER=8.4.4

8+ - GHCVER=8.6.5

9+ - GHCVER=8.8.3

10+ - GHCVER=8.10.1

7

11

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

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

9before_install:

13before_install:

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

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

11 - travis_retry sudo apt-get update

15 - travis_retry sudo apt-get update

12− - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER happy-1.19.5 alex-3.1.7 libblas-dev liblapack-dev

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

13− - export PATH=/opt/alex/3.1.7/bin:/opt/happy/1.19.5/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH

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

14

18

15install:

19install:

16− - cabal --version

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

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

18− - travis_retry cabal update

21+ - travis_retry cabal-3.2 update

19− - git submodule update --init

20− - cabal sandbox init

21− - CABAL_SOURCES=$(find lib -maxdepth 4 ! -path lib/\*/bin/\* ! -path lib/\*/lib/\* -name \*.cabal | xargs -L 1 dirname)

22− - for CABAL_SOURCE in $CABAL_SOURCES; do cabal sandbox add-source -- $CABAL_SOURCE; done

23−

24− - cabal install --enable-tests --enable-benchmarks

25

22

26notifications:

23notifications:

27 email: false

24 email: false

28

25

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

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.

30script:

27script:

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

31− - cabal build

29+ - cabal-3.2 build all

32− - cabal test --show-details=streaming

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

33

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+57−6

@@ -2,6 +2,9 @@ Grenade

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+

5

8

6```

9```

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

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

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

12

15

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

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

14

17

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

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

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

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

17

20

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

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

@@ -20,8 +23,12 @@ specified and initialised with random weights in a few lines of code with

20```haskell

23```haskell

21type MNIST

24type MNIST

22 = Network

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

23− '[ 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]

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

24− '[ '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]

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

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

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

25

32

26randomMnist :: MonadRandom m => m MNIST

33randomMnist :: MonadRandom m => m MNIST

27randomMnist = randomNetwork

34randomMnist = randomNetwork

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

82```

89```

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

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

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

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

85−appropriate for each layer, and may be trivial for layers like `Rulu` which

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

86have no learnable parameters.

93have no learnable parameters.

87

94

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

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

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

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

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

97it will result in a compile time error.

104it will result in a compile time error.

98

105

106+Composition

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

108+

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

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

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

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

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

114+write any Network which can be expressed as a

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

116+

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

118+```haskell

119+type Residual net = Merge Trivial net

120+```

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

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

123+and merge the original image with the output.

124+

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

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

127+as inception style convolutions.

128+

129+Generative Adversarial Networks

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

131+

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

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

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

135+training function in 10 lines of code.

136+

137+Layer Zoo

138+---------

139+

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

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

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

143+elu, tanh, and fully connected.

144+

99Build Instructions

145Build Instructions

100------------------

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

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

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

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

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

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

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

104build using:

150build using:

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

113./mafia test

159./mafia test

114```

160```

115

161

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

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

117

163

118Thanks

164Thanks

119------

165------

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

139Contributing

185Contributing

140------------

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

141Contributions are welcome.

187Contributions are welcome.

188+

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

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

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

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

bench/bench-lstm.hs+4−45

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

5

6import Grenade

7import Grenade.Recurrent

8−import Grenade.Layers.Internal.Update

9−

10−import qualified Numeric.LinearAlgebra.Static as H

11

8

12main :: IO ()

9main :: IO ()

13main = do

10main = do

14− layer60 :: LSTM 40 60 <- createRandom

15− layer512 :: LSTM 40 512 <- createRandom

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

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

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

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

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

12+ lstm :: RecNet <- 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

23

13

24 defaultMain [

14 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− ]

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

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

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

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

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

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

36 ]

18 ]

37 ]

19 ]

38

20

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−

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

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

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

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

59

23

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

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

62−

63

24

64type R = Recurrent

25type R = Recurrent

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

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

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

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

67

28

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

69−

70lp :: LearningParameters

29lp :: LearningParameters

71lp = LearningParameters 0.1 0 0

30lp = LearningParameters 0.1 0 0

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

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

1−#include "gradient_decent.h"

1+#include "gradient_descent.h"

2

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

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

4 const double* weights,

5 const double* gradient,

6 const double* last,

7 double* outputWeights, double* outputMomentum) {

8

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

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_decent.h → cbits/gradient_descent.hrenamed+1−1

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

1#include <stdio.h>

2#include <stdint.h>

3

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

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

5 const double* weights,

6 const double* gradient,

7 const double* last,

examples/LICENSEnew file+10

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

3+

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

5+

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

7+

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

9+

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

examples/grenade-examples.cabalnew file+109

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

1+name: grenade-examples

2+version: 0.0.1

3+license: BSD2

4+license-file: LICENSE

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

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

8+synopsis: grenade-examples

9+category: System

10+cabal-version: >= 1.8

11+build-type: Simple

12+description: grenade-examples

13+

14+source-repository head

15+ type: git

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

17+

18+library

19+

20+executable feedforward

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

22+ main-is: main/feedforward.hs

23+ build-depends: base

24+ , grenade

25+ , attoparsec

26+ , bytestring

27+ , cereal

28+ , either

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

30+ , text == 1.2.*

31+ , mtl >= 2.2.1 && < 2.3

32+ , hmatrix

33+ , transformers

34+ , singletons

35+ , semigroups

36+ , MonadRandom

37+

38+executable mnist

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

40+ main-is: main/mnist.hs

41+ build-depends: base

42+ , grenade

43+ , attoparsec

44+ , either

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

46+ , text == 1.2.*

47+ , mtl >= 2.2.1 && < 2.3

48+ , hmatrix >= 0.18 && < 0.21

49+ , transformers

50+ , semigroups

51+ , singletons

52+ , MonadRandom

53+ , vector

54+

55+executable gan-mnist

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

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

58+ build-depends: base

59+ , grenade

60+ , attoparsec

61+ , bytestring

62+ , cereal

63+ , either

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

65+ , text == 1.2.*

66+ , mtl >= 2.2.1 && < 2.3

67+ , hmatrix >= 0.18 && < 0.21

68+ , transformers

69+ , semigroups

70+ , singletons

71+ , MonadRandom

72+ , vector

73+

74+executable recurrent

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

76+ main-is: main/recurrent.hs

77+ build-depends: base

78+ , grenade

79+ , attoparsec

80+ , either

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

82+ , text == 1.2.*

83+ , mtl >= 2.2.1 && < 2.3

84+ , hmatrix >= 0.18 && < 0.21

85+ , transformers

86+ , semigroups

87+ , singletons

88+ , MonadRandom

89+

90+executable shakespeare

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

92+ main-is: main/shakespeare.hs

93+ build-depends: base

94+ , grenade

95+ , attoparsec

96+ , bytestring

97+ , cereal

98+ , either

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

100+ , text == 1.2.*

101+ , mtl >= 2.2.1 && < 2.3

102+ , hmatrix >= 0.18 && < 0.21

103+ , transformers

104+ , semigroups

105+ , singletons

106+ , singletons-base

107+ , vector

108+ , MonadRandom

109+ , containers

examples/mafianew file+62

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

1+#!/bin/sh -eu

2+

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

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

5+

6+latest_version () {

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

8+}

9+

10+build_version() {

11+ MAFIA_VERSION="$1"

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

13+ MAFIA_FILE=mafia-$MAFIA_VERSION

14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE

15+ mkdir -p $MAFIA_VERSIONS

16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

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

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

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

20+ exit 1

21+ }

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

23+ got=$?

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

25+ exit "$got"

26+ }

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

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

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

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

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

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

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

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

35+ exit 0

36+ }

37+}

38+

39+enable_version() {

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

41+ MAFIA_VERSION="$(latest_version)"

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

43+ else

44+ MAFIA_VERSION="$1"

45+ fi

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

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

48+}

49+

50+exec_mafia () {

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

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

53+}

54+

55+#

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

57+#

58+

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

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

61+*) exec_mafia "$@"

62+esac

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

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

1{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

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

10

11

11import qualified Data.ByteString as B

12import qualified Data.ByteString as B

12import Data.Serialize

13import Data.Serialize

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

13import Data.Semigroup ( (<>) )

15import Data.Semigroup ( (<>) )

14−

16+#endif

15import GHC.TypeLits

17import GHC.TypeLits

16

18

17import qualified Numeric.LinearAlgebra.Static as SA

19import qualified Numeric.LinearAlgebra.Static as SA

main/gan-mnist.hs → examples/main/gan-mnist.hsrenamed+28−10

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

1{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ScopedTypeVariables #-}

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

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

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

11-- of numbers similar to those in MNIST.

12-- of numbers similar to those in MNIST.

12--

13--

13−-- It demonstrates a different usage of the library, within a few hours

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

14−-- was producing examples like this:

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

15--

16--

16-- --.

17-- --.

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

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

@@ -43,7 +44,9 @@ import Control.Monad.Trans.Except

43import qualified Data.Attoparsec.Text as A

44import qualified Data.Attoparsec.Text as A

44import qualified Data.ByteString as B

45import qualified Data.ByteString as B

45import Data.List ( foldl' )

46import Data.List ( foldl' )

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

46import Data.Semigroup ( (<>) )

48import Data.Semigroup ( (<>) )

49+#endif

47import Data.Serialize

50import Data.Serialize

48import qualified Data.Text as T

51import qualified Data.Text as T

49import qualified Data.Text.IO as T

52import qualified Data.Text.IO as T

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

57import Grenade

60import Grenade

58import Grenade.Utils.OneHot

61import Grenade.Utils.OneHot

59

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

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

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

68+ '[ 'D2 28 28

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

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

62−

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

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

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

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

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 ]

65

82

66randomDiscriminator :: MonadRandom m => m Discriminator

83randomDiscriminator :: MonadRandom m => m Discriminator

67randomDiscriminator = randomNetwork

84randomDiscriminator = randomNetwork

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

69randomGenerator :: MonadRandom m => m Generator

86randomGenerator :: MonadRandom m => m Generator

70randomGenerator = randomNetwork

87randomGenerator = randomNetwork

71

88

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

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

73trainExample rate discriminator generator realExample noiseSource

90trainExample rate discriminator generator realExample noiseSource

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

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

75

92

@@ -77,9 +94,10 @@ trainExample rate discriminator generator realExample noiseSource

77 (discriminatorTapeFake, guessFake) = runNetwork discriminator fakeExample

94 (discriminatorTapeFake, guessFake) = runNetwork discriminator fakeExample

78

95

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

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

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

80− (discriminator'fake, push) = runGradient discriminator discriminatorTapeFake guessFake

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

81

99

82− (generator', _) = runGradient generator generatorTape (-push)

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

83

101

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

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

85 newGenerator = applyUpdate rate generator generator'

103 newGenerator = applyUpdate rate generator generator'

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

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

1{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TupleSections #-}

6{-# LANGUAGE TupleSections #-}

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE FlexibleContexts #-}

9+

8import Control.Applicative

10import Control.Applicative

9import Control.Monad

11import Control.Monad

10import Control.Monad.Random

12import Control.Monad.Random

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

12

14

13import qualified Data.Attoparsec.Text as A

15import qualified Data.Attoparsec.Text as A

14import Data.List ( foldl' )

16import Data.List ( foldl' )

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

15import Data.Semigroup ( (<>) )

18import Data.Semigroup ( (<>) )

19+#endif

20+

16import qualified Data.Text as T

21import qualified Data.Text as T

17import qualified Data.Text.IO as T

22import qualified Data.Text.IO as T

18import qualified Data.Vector.Storable as V

23import qualified Data.Vector.Storable as V

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

25import Grenade

30import Grenade

26import Grenade.Utils.OneHot

31import Grenade.Utils.OneHot

27

32

33+-- It's logistic regression!

34+--

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

36+-- type.

37+type FL i o =

38+ Network

39+ '[ FullyConnected i o, Logit ]

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

41+

28-- The definition of our convolutional neural network.

42-- The definition of our convolutional neural network.

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

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

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

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

@@ -34,8 +48,21 @@ import Grenade.Utils.OneHot

34

48

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

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

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

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

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]

51+--

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]

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

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

54+--

55+type MNIST =

56+ Network

57+ '[ Reshape,

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

59+ Pooling 2 2 2 2, Relu,

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

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

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

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

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

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

39

66

40randomMnist :: MonadRandom m => m MNIST

67randomMnist :: MonadRandom m => m MNIST

41randomMnist = randomNetwork

68randomMnist = randomNetwork

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

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

9import Control.Monad ( foldM )

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

11

12−#if __GLASGOW_HASKELL__ < 800

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

13import Data.List ( unfoldr )

14#else

15import Data.List ( cycle, unfoldr )

16−#endif

17import Data.Semigroup ( (<>) )

16import Data.Semigroup ( (<>) )

17+#endif

18

19import qualified Numeric.LinearAlgebra.Static as SA

20

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

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

32type R = Recurrent

33

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

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

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

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

36

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

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

38

39−randomNet :: MonadRandom m => m (RecNet, RecInput)

39+randomNet :: MonadRandom m => m RecNet

40randomNet = randomRecurrent

41

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

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

69 unfoldr go (s, i)

70 where

71 go (x, y) =

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

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

73− o' = heat o

73+ o' = heat o

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

75

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

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

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

83 putStrLn "Training network..."

84

85− (net0, i0) <- randomNet

85+ net0 <- randomNet

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

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

87

88 let results = generateRecurrent trained bestInput (c 1)

89

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

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

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

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

14import Data.List ( foldl' )

15import Data.Maybe ( fromMaybe )

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

16+

17

18import qualified Data.Vector as V

19import Data.Vector ( Vector )

20

21import qualified Data.Map as M

22−import Data.Proxy ( Proxy (..) )

23

22

24import qualified Data.ByteString as B

23import qualified Data.ByteString as B

25import Data.Serialize

24import Data.Serialize

26

25

27−import Data.Singletons.Prelude

28import GHC.TypeLits

26import GHC.TypeLits

29

27

30import Numeric.LinearAlgebra.Static ( konst )

28import Numeric.LinearAlgebra.Static ( konst )

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

36import Grenade.Utils.OneHot

34import Grenade.Utils.OneHot

37

35

38import System.IO.Unsafe ( unsafeInterleaveIO )

36import 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+--

44-- This is a first class recurrent net.

47-- This is a first class recurrent net.

45--

48--

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

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

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

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

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

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

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

63

66

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

67+randomNet :: MonadRandom m => m Shakespeare

65randomNet = randomRecurrent

68randomNet = randomRecurrent

66

69

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

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

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

69loadShakespeare path = do

72loadShakespeare path = do

70 contents <- lift $ readFile path

73 contents <- lift $ readFile path

71 let annotated = annotateCapitals contents

74 let annotated = annotateCapitals contents

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

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

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

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

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

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

75

78

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

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

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

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

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

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

79 in case reverse e of

82 in case reverse e of

80 (o : l : xs) ->

83 (o : l : xs) ->

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

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

82− in trainRecurrent rate net recIns examples

85+ in trainRecurrent lrate net recIns examples

83 _ -> error "Not enough input"

86 _ -> error "Not enough input"

84 where

87 where

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

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

86

89

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

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

88−runShakespeare ShakespeareOpts {..} = do

91+runShakespeare opts = do

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

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

90 (net0, i0) <- lift $

93 (net0, i0) <- lift $

91− case loadPath of

94+ case loadPath opts of

92 Just loadFile -> netLoad loadFile

95 Just loadFile -> netLoad loadFile

93− Nothing -> randomNet

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

94

97

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

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

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

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

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

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

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

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

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

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

100 putStrLn (unAnnotateCapitals results)

103 putStrLn (unAnnotateCapitals results)

101 return (trained, bestInput)

104 return (trained, bestInput)

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

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

103

106

104− case savePath of

107+ case savePath opts of

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

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

106 Nothing -> return ()

109 Nothing -> return ()

107

110

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

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

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

113 -> Vector a

116 -> Vector a

114 -> S ('D1 n)

117 -> S ('D1 n)

115 -> IO [a]

118 -> IO [a]

116−generateParagraph n s temperature hotmap hotdict =

119+generateParagraph n s temp hotmap hotdict =

117 go s

120 go s

118 where

121 where

119 go x y =

122 go x y =

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

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

121− un <- sample temperature hotdict o

124+ un <- sample temp hotdict o

122− Just re <- return $ makeHot hotmap un

125+ Just re <- return $ makeHot hotmap un

123− rest <- unsafeInterleaveIO $ go ns re

126+ rest <- unsafeInterleaveIO $ go ns re

124 return (un : rest)

127 return (un : rest)

125

128

126data ShakespeareOpts = ShakespeareOpts {

129data ShakespeareOpts = ShakespeareOpts {

framework/mafianew file+62

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

1+#!/bin/sh -eu

2+

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

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

5+

6+latest_version () {

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

8+}

9+

10+build_version() {

11+ MAFIA_VERSION="$1"

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

13+ MAFIA_FILE=mafia-$MAFIA_VERSION

14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE

15+ mkdir -p $MAFIA_VERSIONS

16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

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

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

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

20+ exit 1

21+ }

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

23+ got=$?

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

25+ exit "$got"

26+ }

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

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

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

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

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

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

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

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

35+ exit 0

36+ }

37+}

38+

39+enable_version() {

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

41+ MAFIA_VERSION="$(latest_version)"

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

43+ else

44+ MAFIA_VERSION="$1"

45+ fi

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

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

48+}

49+

50+exec_mafia () {

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

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

53+}

54+

55+#

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

57+#

58+

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

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

61+*) exec_mafia "$@"

62+esac

grenade.cabal+106−142

@@ -1,23 +1,35 @@

1name: grenade

2−version: 0.0.1

2+version: 0.1.0

3license: BSD2

4license-file: LICENSE

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

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

8−synopsis: grenade

8+synopsis: Practical Deep Learning in Haskell

9−category: System

9+category: AI, Machine Learning

10−cabal-version: >= 1.8

10+cabal-version: >= 1.10

11build-type: Simple

12−description: grenade.

12+description:

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

14+ recurrent neural network library for precise specifications and

15+ complex deep neural networks in Haskell.

16+ .

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

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

19+ networks with reverse automatic differentiation to calculate their

20+ gradients; and applying gradient descent for learning.

21+ .

22+ Documentation and examples are available on github

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

13

24

14extra-source-files:

25extra-source-files:

26+ README.md

15− cbits/im2col.h

27+ cbits/im2col.h

16− cbits/im2col.c

28+ cbits/im2col.c

17− cbits/gradient_decent.h

29+ cbits/gradient_descent.h

18− cbits/gradient_decent.c

30+ cbits/gradient_descent.c

19− cbits/pad.h

31+ cbits/pad.h

20− cbits/pad.c

32+ cbits/pad.c

21

33

22source-repository head

34source-repository head

23 type: git

35 type: git

@@ -26,26 +38,32 @@ source-repository head

26library

38library

27 build-depends:

39 build-depends:

28 base >= 4.8 && < 5

40 base >= 4.8 && < 5

29− , bytestring == 0.10.*

41+ , bytestring >= 0.10.0

30− , containers

42+ , containers >= 0.5 && < 0.7

31− , deepseq

32− , either == 4.4.*

33− , cereal

43+ , cereal >= 0.5 && < 0.6

34− , exceptions == 0.8.*

44+ , deepseq >= 1.4 && < 1.5

35− , hmatrix == 0.18.*

45+ , hmatrix >= 0.18 && < 0.21

36− , MonadRandom

46+ , MonadRandom >= 0.4 && < 0.6

37− , mtl >= 2.2.1 && < 2.3

38− , primitive

47+ , primitive >= 0.6 && < 0.8

39− , text == 1.2.*

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

40− , transformers

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

50+ , singletons

41− , singletons >= 2.1 && < 2.3

51+ , singletons-base

42− , vector == 0.11.*

52+ , vector >= 0.11 && < 0.13

43

53

44 ghc-options:

54 ghc-options:

45 -Wall

55 -Wall

46 hs-source-dirs:

56 hs-source-dirs:

47 src

57 src

48

58

59+ default-language: Haskell2010

60+

61+ if impl(ghc < 8.0)

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

63+ cpp-options: -DType=*

64+

65+ if impl(ghc >= 8.6)

66+ default-extensions: NoStarIsType

49

67

50 exposed-modules:

68 exposed-modules:

51 Grenade

69 Grenade

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

55 Grenade.Core.Network

73 Grenade.Core.Network

56 Grenade.Core.Runner

74 Grenade.Core.Runner

57 Grenade.Core.Shape

75 Grenade.Core.Shape

76+

58− Grenade.Layers.Crop

77+ Grenade.Layers

59 Grenade.Layers.Concat

78 Grenade.Layers.Concat

60 Grenade.Layers.Convolution

79 Grenade.Layers.Convolution

80+ Grenade.Layers.Crop

81+ Grenade.Layers.Deconvolution

61 Grenade.Layers.Dropout

82 Grenade.Layers.Dropout

83+ Grenade.Layers.Elu

62 Grenade.Layers.FullyConnected

84 Grenade.Layers.FullyConnected

63− Grenade.Layers.Reshape

85+ Grenade.Layers.Inception

64 Grenade.Layers.Logit

86 Grenade.Layers.Logit

65 Grenade.Layers.Merge

87 Grenade.Layers.Merge

66− Grenade.Layers.Relu

67− Grenade.Layers.Elu

68− Grenade.Layers.Tanh

69 Grenade.Layers.Pad

88 Grenade.Layers.Pad

70 Grenade.Layers.Pooling

89 Grenade.Layers.Pooling

90+ Grenade.Layers.Relu

91+ Grenade.Layers.Reshape

92+ Grenade.Layers.Sinusoid

93+ Grenade.Layers.Softmax

94+ Grenade.Layers.Tanh

95+ Grenade.Layers.Trivial

71

96

72 Grenade.Layers.Internal.Convolution

97 Grenade.Layers.Internal.Convolution

73 Grenade.Layers.Internal.Pad

98 Grenade.Layers.Internal.Pad

@@ -81,111 +106,21 @@ library

81 Grenade.Recurrent.Core.Network

106 Grenade.Recurrent.Core.Network

82 Grenade.Recurrent.Core.Runner

107 Grenade.Recurrent.Core.Runner

83

108

109+ Grenade.Recurrent.Layers

84 Grenade.Recurrent.Layers.BasicRecurrent

110 Grenade.Recurrent.Layers.BasicRecurrent

111+ Grenade.Recurrent.Layers.ConcatRecurrent

85 Grenade.Recurrent.Layers.LSTM

112 Grenade.Recurrent.Layers.LSTM

86

113

87 Grenade.Utils.OneHot

114 Grenade.Utils.OneHot

88

115

89− includes: cbits/im2col.h

116+ includes: cbits/im2col.h

90− cbits/gradient_decent.h

117+ cbits/gradient_descent.h

91− cbits/pad.h

118+ cbits/pad.h

92− c-sources: cbits/im2col.c

119+ c-sources: cbits/im2col.c

93− cbits/gradient_decent.c

120+ cbits/gradient_descent.c

94− cbits/pad.c

121+ cbits/pad.c

95−

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

97−

98−executable feedforward

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

100− main-is: main/feedforward.hs

101− build-depends: base

102− , grenade

103− , attoparsec

104− , bytestring

105− , cereal

106− , either

107− , optparse-applicative == 0.13.*

108− , text == 1.2.*

109− , mtl >= 2.2.1 && < 2.3

110− , hmatrix

111− , transformers

112− , singletons

113− , semigroups

114− , MonadRandom

115−

116−executable mnist

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

118− main-is: main/mnist.hs

119− build-depends: base

120− , grenade

121− , attoparsec

122− , either

123− , optparse-applicative == 0.13.*

124− , text == 1.2.*

125− , mtl >= 2.2.1 && < 2.3

126− , hmatrix >= 0.18 && < 0.19

127− , transformers

128− , semigroups

129− , singletons

130− , MonadRandom

131− , vector

132−

133−executable gan-mnist

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

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

136− build-depends: base

137− , grenade

138− , attoparsec

139− , bytestring

140− , cereal

141− , either

142− , optparse-applicative == 0.13.*

143− , text == 1.2.*

144− , mtl >= 2.2.1 && < 2.3

145− , hmatrix >= 0.18 && < 0.19

146− , transformers

147− , semigroups

148− , singletons

149− , MonadRandom

150− , vector

151−

152−executable recurrent

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

154− main-is: main/recurrent.hs

155− build-depends: base

156− , grenade

157− , attoparsec

158− , either

159− , optparse-applicative == 0.13.*

160− , text == 1.2.*

161− , mtl >= 2.2.1 && < 2.3

162− , hmatrix >= 0.18 && < 0.19

163− , transformers

164− , semigroups

165− , singletons

166− , MonadRandom

167−

168−

169−executable shakespeare

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

171− main-is: main/shakespeare.hs

172− build-depends: base

173− , grenade

174− , attoparsec

175− , bytestring

176− , cereal

177− , either

178− , optparse-applicative == 0.13.*

179− , text == 1.2.*

180− , mtl >= 2.2.1 && < 2.3

181− , hmatrix >= 0.18 && < 0.19

182− , transformers

183− , semigroups

184− , singletons

185− , vector

186− , MonadRandom

187− , containers

188

122

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

189

124

190test-suite test

125test-suite test

191 type: exitcode-stdio-1.0

126 type: exitcode-stdio-1.0

@@ -197,23 +132,48 @@ test-suite test

197 hs-source-dirs:

132 hs-source-dirs:

198 test

133 test

199

134

135+ default-language: Haskell2010

136+

137+ other-modules: Test.Hedgehog.Compat

138+ Test.Hedgehog.Hmatrix

139+ Test.Hedgehog.TypeLits

140+

141+ Test.Grenade.Network

142+ Test.Grenade.Layers.Convolution

143+ Test.Grenade.Layers.FullyConnected

144+ Test.Grenade.Layers.Nonlinear

145+ Test.Grenade.Layers.PadCrop

146+ Test.Grenade.Layers.Pooling

147+ Test.Grenade.Layers.Internal.Convolution

148+ Test.Grenade.Layers.Internal.Pooling

149+ Test.Grenade.Layers.Internal.Reference

150+

151+ Test.Grenade.Recurrent.Layers.LSTM

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

153+

154+ if impl(ghc < 8.0)

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

156+ cpp-options: -DType=*

157+

158+ if impl(ghc >= 8.6)

159+ default-extensions: NoStarIsType

160+

200 build-depends:

161 build-depends:

201− base >= 4.8 && < 5

162+ base

202 , grenade

163 , grenade

203− , ambiata-disorder-core

164+ , hedgehog >= 1.0 && < 1.1

204− , ambiata-disorder-jack

205 , hmatrix

165 , hmatrix

206 , mtl

166 , mtl

207 , singletons

167 , singletons

208 , text == 1.2.*

168 , text == 1.2.*

209− , typelits-witnesses

169+ , typelits-witnesses < 0.4

170+ , transformers

210 , constraints

171 , constraints

211− , QuickCheck >= 2.7 && < 2.9

212− , quickcheck-instances == 0.3.*

213 , MonadRandom

172 , MonadRandom

214 , random

173 , random

215 , ad

174 , ad

216 , reflection

175 , reflection

176+ , vector

217

177

218

178

219benchmark bench

179benchmark bench

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

226 hs-source-dirs:

186 hs-source-dirs:

227 bench

187 bench

228

188

189+ default-language: Haskell2010

190+

229 build-depends:

191 build-depends:

230− base >= 3 && < 5

192+ base

231− , bytestring == 0.10.*

193+ , bytestring

232− , criterion == 1.1.*

194+ , criterion >= 1.1 && < 1.6

233 , grenade

195 , grenade

234 , hmatrix

196 , hmatrix

235

197

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

243 hs-source-dirs:

205 hs-source-dirs:

244 bench

206 bench

245

207

208+ default-language: Haskell2010

209+

246 build-depends:

210 build-depends:

247− base >= 3 && < 5

211+ base

248− , bytestring == 0.10.*

212+ , bytestring

249− , criterion == 1.1.*

213+ , criterion

250 , grenade

214 , grenade

251 , hmatrix

215 , hmatrix

lib/disorder.hsdeleted−1

Submodule changed.

lib/pdeleted−1

Submodule changed.

mafiamode 100755 → 120000+1−123

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

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

@@ -0,0 +1 @@

1+framework/mafia

src/Grenade.hs+50−20

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

1module Grenade (

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

3+ -- for machine learning with Grenade.

4+

5+ -- * Exported modules

6+ --

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

2− module X

8+ module Grenade.Core

9+

10+ -- | The neural network layer zoo

11+ , module Grenade.Layers

12+

13+

14+ -- * Overview of the library

15+ -- $library

16+

17+ -- * Example usage

18+ -- $example

19+

3 ) where

20 ) where

4

21

5−import Grenade.Core.LearningParameters as X

22+import Grenade.Core

6−import Grenade.Core.Layer as X

23+import Grenade.Layers

7−import Grenade.Core.Network as X

24+

8−import Grenade.Core.Runner as X

25+{- $library

9−import Grenade.Core.Shape as X

26+Grenade is a purely functional deep learning library.

10−import Grenade.Layers.Concat as X

27+

11−import Grenade.Layers.Crop as X

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

12−import Grenade.Layers.Dropout as X

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

13−import Grenade.Layers.Pad as X

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

14−import Grenade.Layers.Pooling as X

31+the hmatrix library.

15−import Grenade.Layers.Reshape as X

32+

16−import Grenade.Layers.FullyConnected as X

33+-}

17−import Grenade.Layers.Logit as X

34+

18−import Grenade.Layers.Merge as X

35+{- $example

19−import Grenade.Layers.Convolution as X

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

20−import Grenade.Layers.Relu as X

37+under the examples folder.

21−import Grenade.Layers.Elu as X

38+

22−import Grenade.Layers.Tanh as X

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

23−import Grenade.Layers.Softmax as X

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

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

42+

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

44+>

45+> randomMyNet :: MonadRandom MyNet

46+> randomMyNet = randomNetwork

47+

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

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

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

51+-}

52+

53+

src/Grenade/Core.hs+10−5

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

1module Grenade.Core (

2− module X

2+ module Grenade.Core.Layer

3+ , module Grenade.Core.LearningParameters

4+ , module Grenade.Core.Network

5+ , module Grenade.Core.Runner

6+ , module Grenade.Core.Shape

3 ) where

7 ) where

4

8

5−import Grenade.Core.Layer as X

9+import Grenade.Core.Layer

6−import Grenade.Core.LearningParameters as X

10+import Grenade.Core.LearningParameters

7−import Grenade.Core.Shape as X

8−import Grenade.Core.Network as X

11+import Grenade.Core.Network

12+import Grenade.Core.Runner

13+import Grenade.Core.Shape

src/Grenade/Core/Layer.hs+25−4

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

@@ -7,14 +8,30 @@

7{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

9{-|

10{-|

10−Module : Grenade.Core.Network

11+Module : Grenade.Core.Layer

11−Description : Core definition a simple neural etwork

12+Description : Defines the Layer Classes

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

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

13License : BSD2

14License : BSD2

14Stability : experimental

15Stability : experimental

15

16

16This module defines what a Layer is in a Grenade

17This module defines what a Layer is in a Grenade

17neural network.

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

18-}

35-}

19module Grenade.Core.Layer (

36module Grenade.Core.Layer (

20 Layer (..)

37 Layer (..)

@@ -25,6 +42,10 @@ import Control.Monad.Random ( MonadRandom )

25

42

26import Data.List ( foldl' )

43import Data.List ( foldl' )

27

44

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

46+import Data.Kind (Type)

47+#endif

48+

28import Grenade.Core.Shape

49import Grenade.Core.Shape

29import Grenade.Core.LearningParameters

50import Grenade.Core.LearningParameters

30

51

@@ -34,7 +55,7 @@ import Grenade.Core.LearningParameters

34class UpdateLayer x where

55class UpdateLayer x where

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

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

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

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

37− type Gradient x :: *

58+ type Gradient x :: Type

38

59

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

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

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

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

@@ -56,7 +77,7 @@ class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where

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

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

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

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

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

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

59− type Tape x i o :: *

80+ type Tape x i o :: Type

60

81

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

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

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

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

src/Grenade/Core/LearningParameters.hs+11

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

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

1module Grenade.Core.LearningParameters (

8module 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+

2 LearningParameters (..)

13 LearningParameters (..)

3 ) where

14 ) where

4

15

src/Grenade/Core/Network.hs+17−16

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

10{-# LANGUAGE FlexibleInstances #-}

11{-|

12Module : Grenade.Core.Network

13−Description : Core definition a simple neural etwork

13+Description : Core definition of a Neural Network

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

15License : BSD2

16Stability : experimental

@@ -19,10 +19,6 @@ This module defines the core data types and functions

19for non-recurrent neural networks.

20-}

21

22−#if __GLASGOW_HASKELL__ < 800

23−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

24−#endif

25−

26module Grenade.Core.Network (

22module Grenade.Core.Network (

27 Network (..)

23 Network (..)

28 , Gradients (..)

24 , Gradients (..)

@@ -38,22 +34,26 @@ module Grenade.Core.Network (

38import Control.Monad.Random ( MonadRandom )

34import Control.Monad.Random ( MonadRandom )

39

35

40import Data.Singletons

36import Data.Singletons

41−import Data.Singletons.Prelude

42import Data.Serialize

37import Data.Serialize

43

38

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

40+import Data.Kind (Type)

41+#endif

42+

44import Grenade.Core.Layer

43import Grenade.Core.Layer

45import Grenade.Core.LearningParameters

44import Grenade.Core.LearningParameters

46import Grenade.Core.Shape

45import Grenade.Core.Shape

46+import Prelude.Singletons

47

48-- | Type of a network.

49--

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

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

51--

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

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

53--

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

55-- transform the data shapes of the network.

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

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

57 NNil :: SingI i

58 => Network '[] '[i]

59

@@ -71,7 +71,7 @@ instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) wh

71-- | Gradient of a network.

72--

73-- Parameterised on the layers of the network.

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

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

75 GNil :: Gradients '[]

76

77 (:/>) :: UpdateLayer x

@@ -82,7 +82,7 @@ data Gradients :: [*] -> * where

82-- | Wegnert Tape of a network.

83--

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

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

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

86 TNil :: SingI i

87 => Tapes '[] '[i]

88

@@ -96,7 +96,6 @@ data Tapes :: [*] -> [Shape] -> * where

96--

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

98-- propagation.

99−--

100runNetwork :: forall layers shapes.

99runNetwork :: forall layers shapes.

101 Network layers shapes

100 Network layers shapes

102 -> S (Head shapes)

101 -> S (Head shapes)

@@ -124,7 +123,6 @@ runNetwork =

124--

123--

125-- Gives the gradients for the layer, and the gradient across the

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

126-- input (which may not be required).

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

127−--

128runGradient :: forall layers shapes.

126runGradient :: forall layers shapes.

129 Network layers shapes

127 Network layers shapes

130 -> Tapes layers shapes

128 -> Tapes layers shapes

@@ -146,7 +144,7 @@ runGradient net tapes o =

146 = (GNil, o)

144 = (GNil, o)

147

145

148

146

149−-- | Apply one step of stochastic gradient decent across the network.

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

150applyUpdate :: LearningParameters

148applyUpdate :: LearningParameters

151 -> Network layers shapes

149 -> Network layers shapes

152 -> Gradients layers

150 -> Gradients layers

@@ -159,7 +157,7 @@ applyUpdate _ NNil GNil

159

157

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

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

161-- initialise a random network is with the randomNetwork.

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

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

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

163 -- | Create a network with randomly initialised weights.

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

164 --

162 --

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

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

@@ -184,12 +182,15 @@ instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o '

184

182

185-- | Ultimate composition.

183-- | Ultimate composition.

186--

184--

187−-- This allows a complete network to be treated as a layer in a bigger network.

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

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

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

189 type Gradient (Network sublayers subshapes) = Gradients sublayers

187 type Gradient (Network sublayers subshapes) = Gradients sublayers

190 runUpdate = applyUpdate

188 runUpdate = applyUpdate

191 createRandom = randomNetwork

189 createRandom = randomNetwork

192

190

191+-- | Ultimate composition.

192+--

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

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

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

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

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

195 runForwards = runNetwork

196 runForwards = runNetwork

src/Grenade/Core/Runner.hs+4−6

@@ -1,14 +1,11 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-|

4−Module : Grenade.Core.Shape

4+Module : Grenade.Core.Runner

5−Description : Core definition of the Shapes of data we understand

5+Description : Functions to perform training and backpropagation

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

7License : BSD2

8Stability : experimental

9−

10−This module defines simple back propagation and training functions

11−for a network.

12-}

9-}

13module Grenade.Core.Runner (

10module Grenade.Core.Runner (

14 train

11 train

@@ -16,11 +13,12 @@ module Grenade.Core.Runner (

16 , runNet

13 , runNet

17 ) where

14 ) where

18

15

19−import Data.Singletons.Prelude

20

16

21import Grenade.Core.LearningParameters

17import Grenade.Core.LearningParameters

22import Grenade.Core.Network

18import Grenade.Core.Network

23import Grenade.Core.Shape

19import Grenade.Core.Shape

20+import Data.Singletons

21+import Prelude.Singletons

24

22

25-- | Perform reverse automatic differentiation on the network

23-- | Perform reverse automatic differentiation on the network

26-- for the current input and expected output.

24-- for the current input and expected output.

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

@@ -8,41 +8,33 @@

8{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE RankNTypes #-}

11−

11+{-# LANGUAGE UndecidableInstances #-}

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

13−#if __GLASGOW_HASKELL__ < 800

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

15−#endif

16{-|

12{-|

17Module : Grenade.Core.Shape

13Module : Grenade.Core.Shape

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

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

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

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

20License : BSD2

16License : BSD2

21Stability : experimental

17Stability : experimental

22

18

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

19+

24−are understood by Grenade.

25-}

20-}

26module Grenade.Core.Shape (

21module Grenade.Core.Shape (

22+ S (..)

27− Shape (..)

23+ , Shape (..)

28− , S (..)

24+ , SShape (..)

29− , Sing (..)

30−

31 , randomOfShape

25 , randomOfShape

32 , fromStorable

26 , fromStorable

33 ) where

27 ) where

34

28

35import Control.DeepSeq (NFData (..))

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

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

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

37−

31+import Data.Kind (Type)

38import Data.Proxy

32import Data.Proxy

33+import Data.Serialize

39import Data.Singletons

34import Data.Singletons

40−import Data.Singletons.TypeLits

41import Data.Vector.Storable ( Vector )

35import Data.Vector.Storable ( Vector )

42import qualified Data.Vector.Storable as V

36import qualified Data.Vector.Storable as V

43−

44import GHC.TypeLits

37import GHC.TypeLits

45−

46import qualified Numeric.LinearAlgebra.Static as H

38import qualified Numeric.LinearAlgebra.Static as H

47import Numeric.LinearAlgebra.Static

39import Numeric.LinearAlgebra.Static

48import qualified Numeric.LinearAlgebra as NLA

40import qualified Numeric.LinearAlgebra as NLA

@@ -65,17 +57,14 @@ data Shape

65-- All shapes are held in contiguous memory.

57-- All shapes are held in contiguous memory.

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

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

67data S (n :: Shape) where

59data S (n :: Shape) where

68− -- | One dimensional data

69 S1D :: ( KnownNat len )

60 S1D :: ( KnownNat len )

70 => R len

61 => R len

71 -> S ('D1 len)

62 -> S ('D1 len)

72

63

73− -- | Two dimensional data

74 S2D :: ( KnownNat rows, KnownNat columns )

64 S2D :: ( KnownNat rows, KnownNat columns )

75 => L rows columns

65 => L rows columns

76 -> S ('D2 rows columns)

66 -> S ('D2 rows columns)

77

67

78− -- | Three dimensional data

79 S3D :: ( KnownNat rows

68 S3D :: ( KnownNat rows

80 , KnownNat columns

69 , KnownNat columns

81 , KnownNat depth

70 , KnownNat depth

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

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

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

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

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

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

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

82+#if MIN_VERSION_singletons(2,6,0)

83+-- In singletons 2.6 Sing switched from a data family to a type family.

84+type instance Sing = SShape

85+

86+data SShape :: Shape -> Type where

87+ D1Sing :: KnownNat a => SShape ('D1 a)

88+ D2Sing :: (KnownNat a, KnownNat b) => SShape ('D2 a b)

89+ D3Sing :: (KnownNat (a * c), KnownNat a, KnownNat b, KnownNat c) => SShape ('D3 a b c)

90+#else

93data instance Sing (n :: Shape) where

91data instance Sing (n :: Shape) where

94− D1Sing :: KnownNat a => Sing ('D1 a)

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

95− D2Sing :: (KnownNat a, KnownNat b) => Sing ('D2 a b)

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

96− D3Sing :: (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => Sing ('D3 a b c)

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

95+#endif

97

96

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

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

99 sing = D1Sing

98 sing = D1Sing

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

149randomOfShape = do

148randomOfShape = do

150 seed :: Int <- getRandom

149 seed :: Int <- getRandom

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

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

151+ D1Sing ->

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

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

153+

154+ D2Sing ->

153− D2Sing -> S2D (uniformSample seed (-1) 1)

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

156+

157+ D3Sing ->

154− D3Sing -> S3D (uniformSample seed (-1) 1)

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

155

159

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

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

157--

161--

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

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

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

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

160fromStorable xs = case sing :: Sing x of

164fromStorable xs = case sing :: Sing x of

165+ D1Sing ->

161− D1Sing -> S1D <$> H.create xs

166+ S1D <$> H.create xs

167+

168+ D2Sing ->

162− D2Sing -> S2D <$> mkL xs

169+ S2D <$> mkL xs

170+

171+ D3Sing ->

163− D3Sing -> S3D <$> mkL xs

172+ S3D <$> mkL xs

164 where

173 where

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

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

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

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

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

171 then H.create $ NLA.reshape columns v

180 then H.create $ NLA.reshape columns v

172 else Nothing

181 else Nothing

173

182

183+

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

185+ put i = (case i of

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

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

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

189+ ) :: PutM ()

190+

191+ get = do

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

193+ return i

194+

174-- Helper function for creating the number instances

195-- Helper function for creating the number instances

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

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

176n1 f (S1D x) = S1D (f x)

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

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

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

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

185

206

186-- Helper function for creating the number instances

207-- Helper function for creating the number instances

187−nk :: forall x. SingI x => Double -> S x

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

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

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

210+ D1Sing ->

189− D1Sing -> S1D (konst x)

211+ S1D (konst x)

212+

213+ D2Sing ->

190− D2Sing -> S2D (konst x)

214+ S2D (konst x)

215+

216+ D3Sing ->

191− D3Sing -> S3D (konst x)

217+ S3D (konst x)

src/Grenade/Layers.hsnew file+35

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

1+module Grenade.Layers (

2+ module Grenade.Layers.Concat

3+ , module Grenade.Layers.Convolution

4+ , module Grenade.Layers.Crop

5+ , module Grenade.Layers.Deconvolution

6+ , module Grenade.Layers.Elu

7+ , module Grenade.Layers.FullyConnected

8+ , module Grenade.Layers.Inception

9+ , module Grenade.Layers.Logit

10+ , module Grenade.Layers.Merge

11+ , module Grenade.Layers.Pad

12+ , module Grenade.Layers.Pooling

13+ , module Grenade.Layers.Reshape

14+ , module Grenade.Layers.Relu

15+ , module Grenade.Layers.Softmax

16+ , module Grenade.Layers.Tanh

17+ , module Grenade.Layers.Trivial

18+ ) where

19+

20+import Grenade.Layers.Concat

21+import Grenade.Layers.Convolution

22+import Grenade.Layers.Crop

23+import Grenade.Layers.Deconvolution

24+import Grenade.Layers.Elu

25+import Grenade.Layers.Pad

26+import Grenade.Layers.FullyConnected

27+import Grenade.Layers.Inception

28+import Grenade.Layers.Logit

29+import Grenade.Layers.Merge

30+import Grenade.Layers.Pooling

31+import Grenade.Layers.Reshape

32+import Grenade.Layers.Relu

33+import Grenade.Layers.Softmax

34+import Grenade.Layers.Tanh

35+import Grenade.Layers.Trivial

src/Grenade/Layers/Concat.hs+17−3

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

8{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE StandaloneDeriving #-}

11{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE UndecidableInstances #-}

11{-|

13{-|

12−Module : Grenade.Core.Network

14+Module : Grenade.Layers.Concat

13−Description : Core definition a simple neural etwork

15+Description : Concatenation layer

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

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

15License : BSD2

17License : BSD2

16Stability : experimental

18Stability : experimental

19+

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

17-}

21-}

18module Grenade.Layers.Concat (

22module Grenade.Layers.Concat (

19 Concat (..)

23 Concat (..)

20 ) where

24 ) where

21

25

26+import Data.Serialize

27+

22import Data.Singletons

28import Data.Singletons

23import GHC.TypeLits

29import GHC.TypeLits

24

30

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

32+import Data.Kind (Type)

33+#endif

34+

25import Grenade.Core

35import Grenade.Core

26

36

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

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

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

39--

49--

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

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

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

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

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

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

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

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

44

54

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

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

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

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

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

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

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

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

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

136+

137+instance (Serialize a, Serialize b) => Serialize (Concat sa a sb b) where

138+ put (Concat a b) = put a *> put b

139+ get = Concat <$> get <*> get

src/Grenade/Layers/Convolution.hs+89−62

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# 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+-}

10module Grenade.Layers.Convolution (

21module Grenade.Layers.Convolution (

11 Convolution (..)

22 Convolution (..)

12 , Convolution' (..)

23 , Convolution' (..)

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

17import Data.Maybe

28import Data.Maybe

18import Data.Proxy

29import Data.Proxy

19import Data.Serialize

30import Data.Serialize

20−import Data.Singletons.TypeLits

21

31

22import GHC.TypeLits

32import GHC.TypeLits

33+import Data.Kind (Type)

23

34

24import Numeric.LinearAlgebra hiding ( uniformSample, konst )

35import Numeric.LinearAlgebra hiding ( uniformSample, konst )

25import qualified Numeric.LinearAlgebra as LA

36import qualified Numeric.LinearAlgebra as LA

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

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

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

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

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

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

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

49− -> * where

60+ -> Type where

50 Convolution :: ( KnownNat channels

61 Convolution :: ( KnownNat channels

51 , KnownNat filters

62 , KnownNat filters

52 , KnownNat kernelRows

63 , KnownNat kernelRows

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

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

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

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

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

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

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

68− -> * where

79+ -> Type where

69 Convolution' :: ( KnownNat channels

80 Convolution' :: ( KnownNat channels

70 , KnownNat filters

81 , KnownNat filters

71 , KnownNat kernelRows

82 , KnownNat kernelRows

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

119 , KnownNat strideColumns

130 , KnownNat strideColumns

120 , KnownNat (kernelRows * kernelColumns * channels)

131 , KnownNat (kernelRows * kernelColumns * channels)

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

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

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

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

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

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

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

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

125 in Convolution newKernel newMomentum

136 in Convolution newKernel newMomentum

126

137

127 createRandom = randomConvolution

138 createRandom = randomConvolution

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

141 let mm = konst 0

152 let mm = konst 0

142 return $ Convolution wN mm

153 return $ Convolution wN mm

143

154

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

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

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

145instance ( KnownNat kernelRows

157instance ( KnownNat kernelRows

146 , KnownNat kernelCols

158 , KnownNat kernelCols

147 , KnownNat filters

159 , KnownNat filters

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

151 , KnownNat inputCols

163 , KnownNat inputCols

152 , KnownNat outputRows

164 , KnownNat outputRows

153 , KnownNat outputCols

165 , KnownNat outputCols

166+ , KnownNat channels

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

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

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

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

156− , KnownNat (kernelRows * kernelCols * 1)

169+ , KnownNat (kernelRows * kernelCols * channels)

157 , KnownNat (outputRows * filters)

170 , KnownNat (outputRows * filters)

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

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

172+

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

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

174+

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

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

161 let ex = extract input

176 let ex = extract input

162 ek = extract kernel

177 ek = extract kernel

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

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

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

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

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

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

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

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

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

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

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

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

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

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

186+

169− c = im2col kx ky sx sy ex

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

170 mt = c LA.<> ek

188 mt = c LA.<> ek

171 r = col2vid 1 1 1 1 ox oy mt

189 r = col2vid 1 1 1 1 ox oy mt

172 rs = fromJust . create $ r

190 rs = fromJust . create $ r

173− in (S2D input, S3D rs)

191+ in (S3D input, S3D rs)

174−

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

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

176 let ex = extract input

193 let ex = extract input

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

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

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

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

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

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

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

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

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

185

202

186− c = im2col kx ky sx sy ex

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

187

204

188 eo = extract dEdy

205 eo = extract dEdy

189 ek = extract kernel

206 ek = extract kernel

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

191 vs = vid2col 1 1 1 1 ox oy eo

208 vs = vid2col 1 1 1 1 ox oy eo

192

209

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

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

211+

194 dW = vs LA.<> tr ek

212 dW = vs LA.<> tr ek

195

213

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

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

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

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

198

216

199

217

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

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

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

202instance ( KnownNat kernelRows

219instance ( KnownNat kernelRows

203 , KnownNat kernelCols

220 , KnownNat kernelCols

204 , KnownNat filters

221 , KnownNat filters

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

208 , KnownNat inputCols

225 , KnownNat inputCols

209 , KnownNat outputRows

226 , KnownNat outputRows

210 , KnownNat outputCols

227 , KnownNat outputCols

211− , KnownNat channels

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

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

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

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

214− , KnownNat (kernelRows * kernelCols * channels)

230+ , KnownNat (kernelRows * kernelCols * 1)

215 , KnownNat (outputRows * filters)

231 , KnownNat (outputRows * filters)

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

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

217−

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

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

219−

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

234+ runForwards c (S2D input) =

221− let ex = extract input

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

222− ek = extract kernel

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

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

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

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

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

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

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

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

231−

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

233− mt = c LA.<> ek

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

235− rs = fromJust . create $ r

236− in (S3D input, S3D rs)

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

238− let ex = extract input

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

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

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

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

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

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

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

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

247

236

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

237+ runBackwards c tape grads =

238+ case runBackwards c tape grads of

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

249

240

250− eo = extract dEdy

251− ek = extract kernel

252

241

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

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

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

244+instance ( KnownNat kernelRows

245+ , KnownNat kernelCols

246+ , KnownNat strideRows

247+ , KnownNat strideCols

248+ , KnownNat inputRows

249+ , KnownNat inputCols

250+ , KnownNat outputRows

251+ , KnownNat outputCols

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

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

254+ , KnownNat (kernelRows * kernelCols * 1)

255+ , KnownNat (outputRows * 1)

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

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

258+ runForwards c (S2D input) =

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

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

254

261

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

262+ runBackwards c tape (S2D grads) =

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

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

256

265

257− dW = vs LA.<> tr ek

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

267+instance ( KnownNat kernelRows

268+ , KnownNat kernelCols

269+ , KnownNat strideRows

270+ , KnownNat strideCols

271+ , KnownNat inputRows

272+ , KnownNat inputCols

273+ , KnownNat outputRows

274+ , KnownNat outputCols

275+ , KnownNat channels

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

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

278+ , KnownNat (kernelRows * kernelCols * channels)

279+ , KnownNat (outputRows * 1)

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

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

282+ runForwards c input =

283+ case runForwards c input of

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

258

285

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

286+ runBackwards c tape (S2D grads) =

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

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

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

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

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+{-|

11+Module : Grenade.Layers.Crop

12+Description : Cropping layer

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

14+License : BSD2

15+Stability : experimental

16+-}

8module Grenade.Layers.Crop (

17module Grenade.Layers.Crop (

9 Crop (..)

18 Crop (..)

10 ) where

19 ) where

11

20

12import Data.Maybe

21import Data.Maybe

13import Data.Proxy

22import Data.Proxy

14−import Data.Singletons.TypeLits

23+import Data.Serialize

24+

15import GHC.TypeLits

25import GHC.TypeLits

26+import Data.Kind (Type)

16

27

17import Grenade.Core

28import Grenade.Core

18import Grenade.Layers.Internal.Pad

29import Grenade.Layers.Internal.Pad

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

24data Crop :: Nat

35data Crop :: Nat

25 -> Nat

36 -> Nat

26 -> Nat

37 -> Nat

27− -> Nat -> * where

38+ -> Nat -> Type where

28 Crop :: Crop cropLeft cropTop cropRight cropBottom

39 Crop :: Crop cropLeft cropTop cropRight cropBottom

29

40

30instance Show (Crop cropLeft cropTop cropRight cropBottom) where

41instance Show (Crop cropLeft cropTop cropRight cropBottom) where

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

35 runUpdate _ x _ = x

46 runUpdate _ x _ = x

36 createRandom = return Crop

47 createRandom = return Crop

37

48

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

50+ put _ = return ()

51+ get = return Crop

52+

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

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

39instance ( KnownNat cropLeft

54instance ( KnownNat cropLeft

40 , KnownNat cropTop

55 , KnownNat cropTop

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

44 , KnownNat inputColumns

59 , KnownNat inputColumns

45 , KnownNat outputRows

60 , KnownNat outputRows

46 , KnownNat outputColumns

61 , KnownNat outputColumns

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

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

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

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

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

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

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

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

51 runForwards Crop (S2D input) =

66 runForwards Crop (S2D input) =

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

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

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+{-|

12+Module : Grenade.Layers.Deconvolution

13+Description : Deconvolution layer

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

15+License : BSD2

16+Stability : experimental

17+

18+A deconvolution layer is in many ways a convolution layer in reverse.

19+It learns a kernel to apply to each pixel location, spreading it out

20+into a larger layer.

21+

22+This layer is important for image generation tasks, such as GANs on

23+images.

24+-}

25+module Grenade.Layers.Deconvolution (

26+ Deconvolution (..)

27+ , Deconvolution' (..)

28+ , randomDeconvolution

29+ ) where

30+

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

32+import Data.Maybe

33+import Data.Proxy

34+import Data.Serialize

35+

36+import GHC.TypeLits

37+import Data.Kind (Type)

38+

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

40+import qualified Numeric.LinearAlgebra as LA

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

42+

43+import Grenade.Core

44+import Grenade.Layers.Internal.Convolution

45+import Grenade.Layers.Internal.Update

46+

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

48+-- This uses the im2col Convolution trick popularised by Caffe.

49+--

50+-- The Deconvolution layer is a way of spreading out a single response

51+-- into a larger image, and is useful in generating images.

52+--

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

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

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

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

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

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

59+ -> Type where

60+ Deconvolution :: ( KnownNat channels

61+ , KnownNat filters

62+ , KnownNat kernelRows

63+ , KnownNat kernelColumns

64+ , KnownNat strideRows

65+ , KnownNat strideColumns

66+ , KnownNat kernelFlattened

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

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

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

70+ -> Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns

71+

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

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

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

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

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

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

78+ -> Type where

79+ Deconvolution' :: ( KnownNat channels

80+ , KnownNat filters

81+ , KnownNat kernelRows

82+ , KnownNat kernelColumns

83+ , KnownNat strideRows

84+ , KnownNat strideColumns

85+ , KnownNat kernelFlattened

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

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

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

89+

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

91+ show (Deconvolution a _) = renderConv a

92+ where

93+ renderConv mm =

94+ let m = extract mm

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

96+ rs = LA.toColumns m

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

98+

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

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

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

102+ | n' <= 0.8 = '='

103+ | otherwise = '#'

104+

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

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

107+

108+randomDeconvolution :: ( MonadRandom m

109+ , KnownNat channels

110+ , KnownNat filters

111+ , KnownNat kernelRows

112+ , KnownNat kernelColumns

113+ , KnownNat strideRows

114+ , KnownNat strideColumns

115+ , KnownNat kernelFlattened

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

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

118+randomDeconvolution = do

119+ s <- getRandom

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

121+ mm = konst 0

122+ return $ Deconvolution wN mm

123+

124+instance ( KnownNat channels

125+ , KnownNat filters

126+ , KnownNat kernelRows

127+ , KnownNat kernelColumns

128+ , KnownNat strideRows

129+ , KnownNat strideColumns

130+ , KnownNat (kernelRows * kernelColumns * filters)

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

132+ type Gradient (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns)

133+ runUpdate lp (Deconvolution oldKernel oldMomentum) (Deconvolution' kernelGradient) =

134+ let (newKernel, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldKernel kernelGradient oldMomentum

135+ in Deconvolution newKernel newMomentum

136+

137+ createRandom = randomDeconvolution

138+

139+instance ( KnownNat channels

140+ , KnownNat filters

141+ , KnownNat kernelRows

142+ , KnownNat kernelColumns

143+ , KnownNat strideRows

144+ , KnownNat strideColumns

145+ , KnownNat (kernelRows * kernelColumns * filters)

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

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

148+ get = do

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

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

151+ let mm = konst 0

152+ return $ Deconvolution wN mm

153+

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

155+instance ( KnownNat kernelRows

156+ , KnownNat kernelCols

157+ , KnownNat filters

158+ , KnownNat strideRows

159+ , KnownNat strideCols

160+ , KnownNat inputRows

161+ , KnownNat inputCols

162+ , KnownNat outputRows

163+ , KnownNat outputCols

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

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

166+ , KnownNat (kernelRows * kernelCols * filters)

167+ , KnownNat (outputRows * filters)

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

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

170+ runForwards c (S2D input) =

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

172+

173+ runBackwards c tape grads =

174+ case runBackwards c tape grads of

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

176+

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

178+instance ( KnownNat kernelRows

179+ , KnownNat kernelCols

180+ , KnownNat strideRows

181+ , KnownNat strideCols

182+ , KnownNat inputRows

183+ , KnownNat inputCols

184+ , KnownNat outputRows

185+ , KnownNat outputCols

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

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

188+ , KnownNat (kernelRows * kernelCols * 1)

189+ , KnownNat (outputRows * 1)

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

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

192+ runForwards c (S2D input) =

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

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

195+

196+ runBackwards c tape (S2D grads) =

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

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

199+

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

201+instance ( KnownNat kernelRows

202+ , KnownNat kernelCols

203+ , KnownNat strideRows

204+ , KnownNat strideCols

205+ , KnownNat inputRows

206+ , KnownNat inputCols

207+ , KnownNat outputRows

208+ , KnownNat outputCols

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

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

211+ , KnownNat (kernelRows * kernelCols * 1)

212+ , KnownNat (outputRows * 1)

213+ , KnownNat channels

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

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

216+ runForwards c input =

217+ case runForwards c input of

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

219+

220+ runBackwards c tape (S2D grads) =

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

222+

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

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

225+instance ( KnownNat kernelRows

226+ , KnownNat kernelCols

227+ , KnownNat filters

228+ , KnownNat strideRows

229+ , KnownNat strideCols

230+ , KnownNat inputRows

231+ , KnownNat inputCols

232+ , KnownNat outputRows

233+ , KnownNat outputCols

234+ , KnownNat channels

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

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

237+ , KnownNat (kernelRows * kernelCols * filters)

238+ , KnownNat (outputRows * filters)

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

240+

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

242+

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

244+ let ex = extract input

245+ ek = extract kernel

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

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

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

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

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

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

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

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

254+

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

256+

257+ mt = c LA.<> tr ek

258+

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

260+ rs = fromJust . create $ r

261+ in (S3D input, S3D rs)

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

263+ let ex = extract input

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

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

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

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

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

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

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

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

272+

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

274+

275+ eo = extract dEdy

276+ ek = extract kernel

277+

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

279+

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

281+

282+ dW = vs LA.<> ek

283+

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

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

src/Grenade/Layers/Elu.hs+10−3

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

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

5module Grenade.Layers.Elu (

12module Grenade.Layers.Elu (

6 Elu (..)

13 Elu (..)

7 ) where

14 ) where

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

29 get = return Elu

36 get = return Elu

30

37

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

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

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

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

33

40

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

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

35 where

42 where

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

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

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

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

38 where

45 where

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

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

40

47

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

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

1{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE TypeOperators #-}

2{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeFamilies #-}

3{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

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

14

13

15import Data.Proxy

14import Data.Proxy

16import Data.Serialize

15import Data.Serialize

17−import Data.Singletons.TypeLits

18

16

19import qualified Numeric.LinearAlgebra as LA

17import qualified Numeric.LinearAlgebra as LA

20import Numeric.LinearAlgebra.Static

18import Numeric.LinearAlgebra.Static

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

22import Grenade.Core

20import Grenade.Core

23

21

24import Grenade.Layers.Internal.Update

22import Grenade.Layers.Internal.Update

23+import GHC.TypeLits

25

24

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

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

27data FullyConnected i o = FullyConnected

26data FullyConnected i o = FullyConnected

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

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

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

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

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

40

39

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

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

42− let (newBias, newBiasMomentum) = decendVector learningRate learningMomentum learningRegulariser oldBias biasGradient oldBiasMomentum

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

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

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

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

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

45

44

46 createRandom = randomFullyConnected

45 createRandom = randomFullyConnected

47

46

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

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

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

48+ type Tape (FullyConnected i o) ('D1 i) ('D1 o) = R i

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

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

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

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

52

51

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

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

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

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

55 let wB' = dEdy

54 let wB' = dEdy

56 mm' = dEdy `outer` x

55 mm' = dEdy `outer` x

57 -- calcluate derivatives for next step

56 -- calcluate derivatives for next step

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

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

9{-# LANGUAGE ScopedTypeVariables #-}

10{-|

11Module : Grenade.Core.Network

12−Description : Core definition a simple neural etwork

12+Description : Inception style parallel convolutional network composition.

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.

16-}

19-}

17module Grenade.Layers.Inception (

20module Grenade.Layers.Inception (

18 Inception

21 Inception

22+ , InceptionMini

23+ , Resnet

19 ) where

24 ) where

20

25

21import GHC.TypeLits

26import GHC.TypeLits

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

24import Grenade.Layers.Convolution

29import Grenade.Layers.Convolution

25import Grenade.Layers.Pad

30import Grenade.Layers.Pad

26import Grenade.Layers.Concat

31import Grenade.Layers.Concat

32+import Grenade.Layers.Merge

33+import Grenade.Layers.Trivial

27

34

28−

35+-- | Type of an inception layer.

36+--

37+-- It looks like a bit of a handful, but is actually pretty easy to use.

38+--

39+-- The first three type parameters are the size of the (3D) data the

40+-- inception layer will take. It will emit 3D data with the number of

41+-- channels being the sum of @chx@, @chy@, @chz@, which are the number

42+-- of convolution filters in the 3x3, 5x5, and 7x7 convolutions Layers

43+-- respectively.

44+--

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

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

29type Inception rows cols channels chx chy chz

47type Inception rows cols channels chx chy 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) ]

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

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

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

32

50

33−type InceptionS rows cols channels chx chy

51+type InceptionMini rows cols channels chx 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) ]

52+ = Network '[ Concat ('D3 rows cols chx) (Inception3x3 rows cols channels chx) ('D3 rows cols chy) (Inception5x5 rows cols channels chy) ]

35− '[ 'D3 rows cols channels, 'D3 (rows -2) (cols -2) (chx + chy) ]

53+ '[ 'D3 rows cols channels, 'D3 rows cols (chx + chy) ]

36

54

37type Inception3x3 rows cols channels chx

55type Inception3x3 rows cols channels chx

38− = Network '[ Convolution channels chx 3 3 1 1 ]

56+ = Network '[ Pad 1 1 1 1, Convolution channels chx 3 3 1 1 ]

39− '[ 'D3 rows cols channels, 'D3 (rows -2) (cols -2) chx ]

57+ '[ 'D3 rows cols channels, 'D3 (rows + 2) (cols + 2) channels, 'D3 rows cols chx ]

40

58

41type Inception5x5 rows cols channels chx

59type Inception5x5 rows cols channels chx

42− = Network '[ Pad 1 1 1 1, Convolution channels chx 5 5 1 1 ]

60+ = Network '[ Pad 2 2 2 2, Convolution channels chx 5 5 1 1 ]

43− '[ 'D3 rows cols channels, 'D3 (rows + 2) (cols + 2) channels, 'D3 (rows - 2) (cols - 2) chx ]

61+ '[ 'D3 rows cols channels, 'D3 (rows + 4) (cols + 4) channels, 'D3 rows cols chx ]

44

62

45type Inception7x7 rows cols channels chx

63type Inception7x7 rows cols channels chx

46− = Network '[ Pad 2 2 2 2, Convolution channels chx 7 7 1 1 ]

64+ = Network '[ Pad 3 3 3 3, Convolution channels chx 7 7 1 1 ]

47− '[ 'D3 rows cols channels, 'D3 (rows + 4) (cols + 4) channels, 'D3 (rows - 2) (cols - 2) chx ]

65+ '[ 'D3 rows cols channels, 'D3 (rows + 6) (cols + 6) channels, 'D3 rows cols chx ]

48

66

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− decendMatrix

3+ descendMatrix

4− , decendVector

4+ , descendVector

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−decendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)

20+descendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)

21−decendMatrix rate momentum regulariser weights gradient lastUpdate =

21+descendMatrix rate momentum regulariser weights gradient lastUpdate =

22 let (rows, cols) = size weights

23 len = rows * cols

24 -- Most gradients come in in ColumnMajor,

@@ -29,7 +29,7 @@ decendMatrix 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) = decendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'

32+ (vw, vm) = descendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'

33

34 -- Note that it's ColumnMajor, as we did a transpose before

35 -- using the internal vectors.

@@ -37,17 +37,17 @@ decendMatrix 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−decendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)

40+descendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)

41−decendVector rate momentum regulariser weights gradient lastUpdate =

41+descendVector rate momentum regulariser weights gradient lastUpdate =

42 let len = size weights

43 weights' = extract weights

44 gradient' = extract gradient

45 lastUpdate' = extract lastUpdate

46− (vw, vm) = decendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'

46+ (vw, vm) = descendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'

47 in (fromJust $ create vw, fromJust $ create vm)

48

49−decendUnsafe :: Int -> Double -> Double -> Double -> Vector Double -> Vector Double -> Vector Double -> (Vector Double, Vector Double)

49+descendUnsafe :: Int -> Double -> Double -> Double -> Vector Double -> Vector Double -> Vector Double -> (Vector Double, Vector Double)

50−decendUnsafe len rate momentum regulariser weights gradient lastUpdate =

50+descendUnsafe len rate momentum regulariser weights gradient lastUpdate =

51 unsafePerformIO $ do

52 outWPtr <- mallocForeignPtrArray len

53 outMPtr <- mallocForeignPtrArray len

@@ -60,11 +60,11 @@ decendUnsafe len rate momentum regulariser weights gradient lastUpdate =

60 withForeignPtr lPtr $ \lPtr' ->

61 withForeignPtr outWPtr $ \outWPtr' ->

62 withForeignPtr outMPtr $ \outMPtr' ->

63− decend_cpu len rate momentum regulariser wPtr' gPtr' lPtr' outWPtr' outMPtr'

63+ descend_cpu len rate momentum regulariser wPtr' gPtr' lPtr' outWPtr' outMPtr'

64

65 return (U.unsafeFromForeignPtr0 outWPtr len, U.unsafeFromForeignPtr0 outMPtr len)

66

67foreign import ccall unsafe

68− decend_cpu

68+ descend_cpu

69 :: Int -> Double -> Double -> Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()

70

src/Grenade/Layers/Logit.hs+23−9

@@ -3,6 +3,13 @@

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+-}

6module Grenade.Layers.Logit (

13module Grenade.Layers.Logit (

7 Logit (..)

14 Logit (..)

8 ) where

15 ) where

@@ -14,6 +21,7 @@ import Data.Singletons

14import Grenade.Core

21import Grenade.Core

15

22

16-- | A Logit layer.

23-- | A Logit layer.

24+--

17-- A layer which can act between any shape of the same dimension, perfoming an sigmoid function.

25-- A layer which can act between any shape of the same dimension, perfoming an sigmoid function.

18-- This layer should be used as the output layer of a network for logistic regression (classification)

26-- This layer should be used as the output layer of a network for logistic regression (classification)

19-- problems.

27-- problems.

@@ -26,18 +34,24 @@ instance UpdateLayer Logit where

26 createRandom = return Logit

34 createRandom = return Logit

27

35

28instance (a ~ b, SingI a) => Layer Logit a b where

36instance (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.

29 type Tape Logit a b = S a

44 type Tape Logit a b = S a

30− runForwards _ a = (a, logistic a)

45+ runForwards _ a =

46+ let l = sigmoid a

47+ in (l, l)

31− runBackwards _ a g = ((), logistic' a * g)

48+ runBackwards _ l g =

49+ let sigmoid' = l * (1 - l)

50+ in ((), sigmoid' * g)

32

51

33instance Serialize Logit where

52instance Serialize Logit where

34 put _ = return ()

53 put _ = return ()

35 get = return Logit

54 get = return Logit

36

55

37−logistic :: Floating a => a -> a

56+sigmoid :: Floating a => a -> a

38−logistic x = 1 / (1 + exp (-x))

57+sigmoid 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+13−2

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

@@ -10,7 +11,7 @@

10{-# LANGUAGE StandaloneDeriving #-}

11{-# LANGUAGE StandaloneDeriving #-}

11{-|

12{-|

12Module : Grenade.Core.Network

13Module : Grenade.Core.Network

13−Description : Core definition a simple neural etwork

14+Description : Merging layer for parallel network composition

14Copyright : (c) Huw Campbell, 2016-2017

15Copyright : (c) Huw Campbell, 2016-2017

15License : BSD2

16License : BSD2

16Stability : experimental

17Stability : experimental

@@ -19,15 +20,21 @@ module Grenade.Layers.Merge (

19 Merge (..)

20 Merge (..)

20 ) where

21 ) where

21

22

23+import Data.Serialize

24+

22import Data.Singletons

25import Data.Singletons

23

26

27+#if MIN_VERSION_base(4,9,0)

28+import Data.Kind (Type)

29+#endif

30+

24import Grenade.Core

31import Grenade.Core

25

32

26-- | A Merging layer.

33-- | A Merging layer.

27--

34--

28-- Similar to Concat layer, except sums the activations instead of creating a larger

35-- Similar to Concat layer, except sums the activations instead of creating a larger

29-- shape.

36-- shape.

30−data Merge :: * -> * -> * where

37+data Merge :: Type -> Type -> Type where

31 Merge :: x -> y -> Merge x y

38 Merge :: x -> y -> Merge x y

32

39

33instance (Show x, Show y) => Show (Merge x y) where

40instance (Show x, Show y) => Show (Merge x y) where

@@ -53,3 +60,7 @@ instance (SingI i, SingI o, Layer x i o, Layer y i o) => Layer (Merge x y) i o w

53 let (x', xB) = runBackwards x xTape o

60 let (x', xB) = runBackwards x xTape o

54 (y', yB) = runBackwards y yTape o

61 (y', yB) = runBackwards y yTape o

55 in ((x', y'), xB + yB)

62 in ((x', y'), xB + yB)

63+

64+instance (Serialize a, Serialize b) => Serialize (Merge a b) where

65+ put (Merge a b) = put a *> put b

66+ get = Merge <$> get <*> get

src/Grenade/Layers/Pad.hs+16−4

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

@@ -5,6 +6,14 @@

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE FlexibleContexts #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+{-|

11+Module : Grenade.Core.Pad

12+Description : Padding layer for 2D and 3D images

13+Copyright : (c) Huw Campbell, 2016-2017

14+License : BSD2

15+Stability : experimental

16+-}

8module Grenade.Layers.Pad (

17module Grenade.Layers.Pad (

9 Pad (..)

18 Pad (..)

10 ) where

19 ) where

@@ -12,8 +21,9 @@ module Grenade.Layers.Pad (

12import Data.Maybe

21import Data.Maybe

13import Data.Proxy

22import Data.Proxy

14import Data.Serialize

23import Data.Serialize

15−import Data.Singletons.TypeLits

24+

16import GHC.TypeLits

25import GHC.TypeLits

26+import Data.Kind (Type)

17

27

18import Grenade.Core

28import Grenade.Core

19import Grenade.Layers.Internal.Pad

29import Grenade.Layers.Internal.Pad

@@ -22,10 +32,12 @@ import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)

22import Numeric.LinearAlgebra.Static (extract, create)

32import Numeric.LinearAlgebra.Static (extract, create)

23

33

24-- | A padding layer for a neural network.

34-- | A padding layer for a neural network.

35+--

36+-- Pads on the X and Y dimension of an image.

25data Pad :: Nat

37data Pad :: Nat

26 -> Nat

38 -> Nat

27 -> Nat

39 -> Nat

28− -> Nat -> * where

40+ -> Nat -> Type where

29 Pad :: Pad padLeft padTop padRight padBottom

41 Pad :: Pad padLeft padTop padRight padBottom

30

42

31instance Show (Pad padLeft padTop padRight padBottom) where

43instance Show (Pad padLeft padTop padRight padBottom) where

@@ -40,7 +52,7 @@ instance Serialize (Pad l t r b) where

40 put _ = return ()

52 put _ = return ()

41 get = return Pad

53 get = return Pad

42

54

43−-- | A two dimentional image can be padped.

55+-- | A two dimentional image can be padded.

44instance ( KnownNat padLeft

56instance ( KnownNat padLeft

45 , KnownNat padTop

57 , KnownNat padTop

46 , KnownNat padRight

58 , KnownNat padRight

@@ -70,7 +82,7 @@ instance ( KnownNat padLeft

70 vs = subMatrix (padt, padl) (nrows, ncols) m

82 vs = subMatrix (padt, padl) (nrows, ncols) m

71 in ((), S2D . fromJust . create $ vs)

83 in ((), S2D . fromJust . create $ vs)

72

84

73−-- | A two dimentional image can be padped.

85+-- | A two dimentional image can be padded.

74instance ( KnownNat padLeft

86instance ( KnownNat padLeft

75 , KnownNat padTop

87 , KnownNat padTop

76 , KnownNat padRight

88 , KnownNat padRight

src/Grenade/Layers/Pooling.hs+14−3

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE StandaloneDeriving #-}

4{-# LANGUAGE StandaloneDeriving #-}

@@ -6,6 +7,14 @@

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE FlexibleContexts #-}

9{-# 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+-}

9module Grenade.Layers.Pooling (

18module Grenade.Layers.Pooling (

10 Pooling (..)

19 Pooling (..)

11 ) where

20 ) where

@@ -13,8 +22,9 @@ module Grenade.Layers.Pooling (

13import Data.Maybe

22import Data.Maybe

14import Data.Proxy

23import Data.Proxy

15import Data.Serialize

24import Data.Serialize

16−import Data.Singletons.TypeLits

25+

17import GHC.TypeLits

26import GHC.TypeLits

27+import Data.Kind (Type)

18

28

19import Grenade.Core

29import Grenade.Core

20import Grenade.Layers.Internal.Pooling

30import Grenade.Layers.Internal.Pooling

@@ -22,20 +32,21 @@ import Grenade.Layers.Internal.Pooling

22import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)

32import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)

23

33

24-- | A pooling layer for a neural network.

34-- | A pooling layer for a neural network.

35+--

25-- Does a max pooling, looking over a kernel similarly to the convolution network, but returning

36-- Does a max pooling, looking over a kernel similarly to the convolution network, but returning

26-- maxarg only. This layer is often used to provide minor amounts of translational invariance.

37-- maxarg only. This layer is often used to provide minor amounts of translational invariance.

27--

38--

28-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:

39-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:

29-- `out = (in - kernel) / stride + 1` for both dimensions.

40-- `out = (in - kernel) / stride + 1` for both dimensions.

30--

41--

31−data Pooling :: Nat -> Nat -> Nat -> Nat -> * where

42+data Pooling :: Nat -> Nat -> Nat -> Nat -> Type where

32 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

43 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

33

44

34instance Show (Pooling k k' s s') where

45instance Show (Pooling k k' s s') where

35 show Pooling = "Pooling"

46 show Pooling = "Pooling"

36

47

37instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

48instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

38− type Gradient (Pooling kr kc sr sc) = ()

49+ type Gradient (Pooling kernelRows kernelColumns strideRows strideColumns) = ()

39 runUpdate _ Pooling _ = Pooling

50 runUpdate _ Pooling _ = Pooling

40 createRandom = return Pooling

51 createRandom = return Pooling

41

52

src/Grenade/Layers/Relu.hs+7

@@ -2,6 +2,13 @@

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+-}

5module Grenade.Layers.Relu (

12module Grenade.Layers.Relu (

6 Relu (..)

13 Relu (..)

7 ) where

14 ) where

src/Grenade/Layers/Reshape.hs+11−4

@@ -3,13 +3,20 @@

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+-}

6module Grenade.Layers.Reshape (

14module Grenade.Layers.Reshape (

7 Reshape (..)

15 Reshape (..)

8 ) where

16 ) where

9

17

10import Data.Serialize

18import Data.Serialize

11

19

12−import Data.Singletons.TypeLits

13import GHC.TypeLits

20import GHC.TypeLits

14

21

15import Numeric.LinearAlgebra.Static

22import Numeric.LinearAlgebra.Static

@@ -19,9 +26,9 @@ import Grenade.Core

19

26

20-- | Reshape Layer

27-- | Reshape Layer

21--

28--

22−-- Flattens input down to D1 from either 2D or 3D data.

29+-- The Reshape layer can flatten any 2D or 3D image to 1D vector with the

23−--

30+-- same number of activations, as well as cast up from 1D to a 2D or 3D

24−-- Casts input D1 up to either 2D or 3D data if the shapes are good.

31+-- shape.

25--

32--

26-- Can also be used to turn a 3D image with only one channel into a 2D image

33-- Can also be used to turn a 3D image with only one channel into a 2D image

27-- or vice versa.

34-- or vice versa.

src/Grenade/Layers/Sinusoid.hsnew file+39

@@ -0,0 +1,39 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-|

7+Module : Grenade.Layers.Sinusoid

8+Description : Sinusoid nonlinear layer

9+Copyright : (c) Manuel Schneckenreither, 2018

10+License : BSD2

11+Stability : experimental

12+-}

13+module Grenade.Layers.Sinusoid (

14+ Sinusoid (..)

15+ ) where

16+

17+import Data.Serialize

18+import Data.Singletons

19+

20+import Grenade.Core

21+

22+-- | A Sinusoid layer.

23+-- A layer which can act between any shape of the same dimension, performing a sin function.

24+data Sinusoid = Sinusoid

25+ deriving Show

26+

27+instance UpdateLayer Sinusoid where

28+ type Gradient Sinusoid = ()

29+ runUpdate _ _ _ = Sinusoid

30+ createRandom = return Sinusoid

31+

32+instance Serialize Sinusoid where

33+ put _ = return ()

34+ get = return Sinusoid

35+

36+instance (a ~ b, SingI a) => Layer Sinusoid a b where

37+ type Tape Sinusoid a b = S a

38+ runForwards _ a = (a, sin a)

39+ runBackwards _ a g = ((), cos a * g)

src/Grenade/Layers/Softmax.hs+11

@@ -3,6 +3,13 @@

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+-}

6module Grenade.Layers.Softmax (

13module Grenade.Layers.Softmax (

7 Softmax (..)

14 Softmax (..)

8 , softmax

15 , softmax

@@ -17,8 +24,12 @@ import Grenade.Core

17import Numeric.LinearAlgebra.Static as LAS

24import Numeric.LinearAlgebra.Static as LAS

18

25

19-- | A Softmax layer

26-- | A Softmax layer

27+--

20-- This layer is like a logit layer, but normalises

28-- This layer is like a logit layer, but normalises

21-- a set of matricies to be probabilities.

29-- a set of matricies to be probabilities.

30+--

31+-- One can use this layer as the last layer in a network

32+-- if they need normalised probabilities.

22data Softmax = Softmax

33data Softmax = Softmax

23 deriving Show

34 deriving Show

24

35

src/Grenade/Layers/Tanh.hs+10−3

@@ -1,8 +1,15 @@

1{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeOperators #-}

3−{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-|

7+Module : Grenade.Layers.Tanh

8+Description : Hyperbolic tangent nonlinear layer

9+Copyright : (c) Huw Campbell, 2016-2017

10+License : BSD2

11+Stability : experimental

12+-}

6module Grenade.Layers.Tanh (

13module Grenade.Layers.Tanh (

7 Tanh (..)

14 Tanh (..)

8 ) where

15 ) where

@@ -13,7 +20,7 @@ import Data.Singletons

13import Grenade.Core

20import Grenade.Core

14

21

15-- | A Tanh layer.

22-- | A Tanh layer.

16−-- A layer which can act between any shape of the same dimension, perfoming a tanh function.

23+-- A layer which can act between any shape of the same dimension, performing a tanh function.

17data Tanh = Tanh

24data Tanh = Tanh

18 deriving Show

25 deriving Show

19

26

src/Grenade/Layers/Trivial.hs+14−3

@@ -3,15 +3,25 @@

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+-}

6module Grenade.Layers.Trivial (

13module Grenade.Layers.Trivial (

7 Trivial (..)

14 Trivial (..)

8 ) where

15 ) where

9

16

10import Data.Serialize

17import Data.Serialize

11

18

12−import Grenade.Core.Network

19+import Grenade.Core

13

20

14−-- | A trivial layer.

21+-- | A Trivial layer.

22+--

23+-- This can be used to pass an unchanged value up one side of a

24+-- graph, for a Residual network for example.

15data Trivial = Trivial

25data Trivial = Trivial

16 deriving Show

26 deriving Show

17

27

@@ -25,5 +35,6 @@ instance UpdateLayer Trivial where

25 createRandom = return Trivial

35 createRandom = return Trivial

26

36

27instance (a ~ b) => Layer Trivial a b where

37instance (a ~ b) => Layer Trivial a b where

38+ type Tape Trivial a b = ()

28− runForwards _ = id

39+ runForwards _ a = ((), a)

29 runBackwards _ _ y = ((), y)

40 runBackwards _ _ y = ((), y)

src/Grenade/Recurrent.hs+26−6

@@ -1,9 +1,29 @@

1module Grenade.Recurrent (

2− module X

2+ -- | This is an empty module which simply re-exports public definitions

3+ -- for recurrent networks in Grenade.

4+

5+ -- * Exported modules

6+ --

7+ -- | The core types and runners for Recurrent Networks.

8+ module Grenade.Recurrent.Core

9+

10+ -- | The recurrent neural network layer zoo

11+ , module Grenade.Recurrent.Layers

12+

13+ -- * Overview of recurrent Networks

14+ -- $recurrent

15+

3 ) where

16 ) where

4

17

5−import Grenade.Recurrent.Core.Layer as X

18+import Grenade.Recurrent.Core

6−import Grenade.Recurrent.Core.Network as X

19+import Grenade.Recurrent.Layers

7−import Grenade.Recurrent.Core.Runner as X

20+

8−import Grenade.Recurrent.Layers.BasicRecurrent as X

21+{- $recurrent

9−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.hs+6−3

@@ -1,6 +1,9 @@

1module Grenade.Recurrent.Core (

2− module X

2+ module Grenade.Recurrent.Core.Layer

3+ , module Grenade.Recurrent.Core.Network

4+ , module Grenade.Recurrent.Core.Runner

3 ) where

5 ) where

4

6

5−import Grenade.Recurrent.Core.Layer as X

7+import Grenade.Recurrent.Core.Layer

6−import Grenade.Recurrent.Core.Network as X

8+import Grenade.Recurrent.Core.Network

9+import Grenade.Recurrent.Core.Runner

src/Grenade/Recurrent/Core/Layer.hs+9−6

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE TypeFamilies #-}

3{-# LANGUAGE TypeFamilies #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

@@ -8,7 +9,9 @@ module Grenade.Recurrent.Core.Layer (

8 , RecurrentUpdateLayer (..)

9 , RecurrentUpdateLayer (..)

9 ) where

10 ) where

10

11

12+#if MIN_VERSION_base(4,9,0)

11−import Data.Singletons ( SingI )

13+import Data.Kind (Type)

14+#endif

12

15

13import Grenade.Core

16import Grenade.Core

14

17

@@ -17,16 +20,16 @@ import Grenade.Core

17-- of an extra recurrent data shape.

20-- of an extra recurrent data shape.

18class UpdateLayer x => RecurrentUpdateLayer x where

21class UpdateLayer x => RecurrentUpdateLayer x where

19 -- | Shape of data that is passed between each subsequent run of the layer

22 -- | Shape of data that is passed between each subsequent run of the layer

20− type RecurrentShape x :: Shape

23+ type RecurrentShape x :: Type

21

24

22−class (RecurrentUpdateLayer x, SingI (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where

25+class (RecurrentUpdateLayer x, Num (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where

23 -- | Wengert Tape

26 -- | Wengert Tape

24− type RecTape x i o :: *

27+ type RecTape x i o :: Type

25 -- | Used in training and scoring. Take the input from the previous

28 -- | Used in training and scoring. Take the input from the previous

26 -- layer, and give the output from this layer.

29 -- layer, and give the output from this layer.

27− runRecurrentForwards :: x -> S (RecurrentShape x) -> S i -> (RecTape x i o, S (RecurrentShape x), S o)

30+ runRecurrentForwards :: x -> RecurrentShape x -> S i -> (RecTape x i o, RecurrentShape x, S o)

28 -- | Back propagate a step. Takes the current layer, the input that the

31 -- | Back propagate a step. Takes the current layer, the input that the

29 -- layer gave from the input and the back propagated derivatives from

32 -- layer gave from the input and the back propagated derivatives from

30 -- the layer above.

33 -- the layer above.

31 -- Returns the gradient layer and the derivatives to push back further.

34 -- Returns the gradient layer and the derivatives to push back further.

32− runRecurrentBackwards :: x -> RecTape x i o -> S (RecurrentShape x) -> S o -> (Gradient x, S (RecurrentShape x), S i)

35+ runRecurrentBackwards :: x -> RecTape x i o -> RecurrentShape x -> S o -> (Gradient x, RecurrentShape x, S i)

src/Grenade/Recurrent/Core/Network.hs+122−122

@@ -10,10 +10,7 @@

10{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE BangPatterns #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13−

13+{-# LANGUAGE UndecidableInstances #-}

14−#if __GLASGOW_HASKELL__ < 800

15−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

16−#endif

17

14

18module Grenade.Recurrent.Core.Network (

15module Grenade.Recurrent.Core.Network (

19 Recurrent

16 Recurrent

@@ -21,37 +18,34 @@ module Grenade.Recurrent.Core.Network (

21

18

22 , RecurrentNetwork (..)

19 , RecurrentNetwork (..)

23 , RecurrentInputs (..)

20 , RecurrentInputs (..)

24− , RecurrentTapes (..)

21+ , RecurrentTape (..)

25− , RecurrentGradients (..)

22+ , RecurrentGradient (..)

26

23

27 , randomRecurrent

24 , randomRecurrent

28− , runRecurrentNetwork

25+ , runRecurrent

29− , runRecurrentGradient

26+ , runRecurrent'

30 , applyRecurrentUpdate

27 , applyRecurrentUpdate

31 ) where

28 ) where

32

29

33

30

34import Control.Monad.Random ( MonadRandom )

31import Control.Monad.Random ( MonadRandom )

35−import Data.Singletons ( SingI )

36−import Data.Singletons.Prelude ( Head, Last )

37import Data.Serialize

32import Data.Serialize

38−import qualified Data.Vector.Storable as V

33+

34+import Data.Kind (Type)

39

35

40import Grenade.Core

36import Grenade.Core

41import Grenade.Recurrent.Core.Layer

37import Grenade.Recurrent.Core.Layer

42−

38+import Prelude.Singletons

43−import qualified Numeric.LinearAlgebra as LA

44−import qualified Numeric.LinearAlgebra.Static as LAS

45

39

46-- | Witness type to say indicate we're building up with a normal feed

40-- | Witness type to say indicate we're building up with a normal feed

47-- forward layer.

41-- forward layer.

48−data FeedForward :: * -> *

42+data FeedForward :: Type -> Type

49-- | Witness type to say indicate we're building up with a recurrent layer.

43-- | Witness type to say indicate we're building up with a recurrent layer.

50−data Recurrent :: * -> *

44+data Recurrent :: Type -> Type

51

45

52-- | Type of a recurrent neural network.

46-- | Type of a recurrent neural network.

53--

47--

54−-- The [*] type specifies the types of the layers.

48+-- The [Type] type specifies the types of the layers.

55--

49--

56-- 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.

57--

51--

@@ -60,7 +54,7 @@ data Recurrent :: * -> *

60--

54--

61-- Often, to make the definitions more concise, one will use a type alias

55-- Often, to make the definitions more concise, one will use a type alias

62-- for these empty data types.

56-- for these empty data types.

63−data RecurrentNetwork :: [*] -> [Shape] -> * where

57+data RecurrentNetwork :: [Type] -> [Shape] -> Type where

64 RNil :: SingI i

58 RNil :: SingI i

65 => RecurrentNetwork '[] '[i]

59 => RecurrentNetwork '[] '[i]

66

60

@@ -79,96 +73,82 @@ infixr 5 :~@>

79-- | Gradient of a network.

73-- | Gradient of a network.

80--

74--

81-- Parameterised on the layers of the network.

75-- Parameterised on the layers of the network.

82−data RecurrentGradients :: [*] -> * where

76+data RecurrentGradient :: [Type] -> Type where

83− RGNil :: RecurrentGradients '[]

77+ RGNil :: RecurrentGradient '[]

84

78

85 (://>) :: UpdateLayer x

79 (://>) :: UpdateLayer x

86− => [Gradient x]

80+ => Gradient x

87− -> RecurrentGradients xs

81+ -> RecurrentGradient xs

88− -> RecurrentGradients (phantom x ': xs)

82+ -> RecurrentGradient (phantom x ': xs)

89

83

90-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)

84-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)

91-- Parameterised on the layers of a Network.

85-- Parameterised on the layers of a Network.

92−data RecurrentInputs :: [*] -> * where

86+data RecurrentInputs :: [Type] -> Type where

93 RINil :: RecurrentInputs '[]

87 RINil :: RecurrentInputs '[]

94

88

95− (:~~+>) :: UpdateLayer x

89+ (:~~+>) :: (UpdateLayer x, Fractional (RecurrentInputs xs))

96 => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)

90 => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)

97

91

98− (:~@+>) :: (SingI (RecurrentShape x), RecurrentUpdateLayer x)

92+ (:~@+>) :: (Fractional (RecurrentShape x), Fractional (RecurrentInputs xs), RecurrentUpdateLayer x)

99− => !(S (RecurrentShape x)) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)

93+ => !(RecurrentShape x) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)

100

94

101-- | All the information required to backpropogate

95-- | All the information required to backpropogate

102-- through time safely.

96-- through time safely.

103--

97--

104-- We index on the time step length as well, to ensure

98-- We index on the time step length as well, to ensure

105-- that that all Tape lengths are the same.

99-- that that all Tape lengths are the same.

106−data RecurrentTapes :: [*] -> [Shape] -> * where

100+data RecurrentTape :: [Type] -> [Shape] -> Type where

107 TRNil :: SingI i

101 TRNil :: SingI i

108− => RecurrentTapes '[] '[i]

102+ => RecurrentTape '[] '[i]

109

103

110− (:\~>) :: [Tape x i h]

104+ (:\~>) :: Tape x i h

111− -> !(RecurrentTapes xs (h ': hs))

105+ -> !(RecurrentTape xs (h ': hs))

112− -> RecurrentTapes (FeedForward x ': xs) (i ': h ': hs)

106+ -> RecurrentTape (FeedForward x ': xs) (i ': h ': hs)

113

107

108+ (:\@>) :: RecTape x i h

109+ -> !(RecurrentTape xs (h ': hs))

110+ -> RecurrentTape (Recurrent x ': xs) (i ': h ': hs)

114

111

115− (:\@>) :: [RecTape x i h]

116− -> !(RecurrentTapes xs (h ': hs))

117− -> RecurrentTapes (Recurrent x ': xs) (i ': h ': hs)

118

112

119−

120−runRecurrentNetwork :: forall shapes layers.

113+runRecurrent :: forall shapes layers.

121− RecurrentNetwork layers shapes

114+ RecurrentNetwork layers shapes

122− -> RecurrentInputs layers

115+ -> RecurrentInputs layers

123− -> [S (Head shapes)]

116+ -> S (Head shapes)

124− -> (RecurrentTapes layers shapes, RecurrentInputs layers, [S (Last shapes)])

117+ -> (RecurrentTape layers shapes, RecurrentInputs layers, S (Last shapes))

125−runRecurrentNetwork =

118+runRecurrent =

126 go

119 go

127 where

120 where

128 go :: forall js sublayers. (Last js ~ Last shapes)

121 go :: forall js sublayers. (Last js ~ Last shapes)

129 => RecurrentNetwork sublayers js

122 => RecurrentNetwork sublayers js

130 -> RecurrentInputs sublayers

123 -> RecurrentInputs sublayers

131− -> [S (Head js)]

124+ -> S (Head js)

132− -> (RecurrentTapes sublayers js, RecurrentInputs sublayers, [S (Last js)])

125+ -> (RecurrentTape sublayers js, RecurrentInputs sublayers, S (Last js))

133− -- This is a simple non-recurrent layer, just map it forwards

134− go (layer :~~> n) (() :~~+> nIn) !xs

126+ go (!layer :~~> n) (() :~~+> nIn) !x

135− = let tys = runForwards layer <$> xs

127+ = let (!tape, !forwards) = runForwards layer x

136− feedForwardTapes = fst <$> tys

128+

137− forwards = snd <$> tys

138 -- recursively run the rest of the network, and get the gradients from above.

129 -- recursively run the rest of the network, and get the gradients from above.

139− (newFN, ig, answer) = go n nIn forwards

130+ (!newFN, !ig, !answer) = go n nIn forwards

140− in (feedForwardTapes :\~> newFN, () :~~+> ig, answer)

131+ in (tape :\~> newFN, () :~~+> ig, answer)

141

132

142 -- This is a recurrent layer, so we need to do a scan, first input to last, providing

133 -- This is a recurrent layer, so we need to do a scan, first input to last, providing

143 -- the recurrent shape output to the next layer.

134 -- the recurrent shape output to the next layer.

144− go (layer :~@> n) (recIn :~@+> nIn) !xs

135+ go (layer :~@> n) (recIn :~@+> nIn) !x

145− = let (recOut, tys) = goR layer recIn xs

136+ = let (tape, shape, forwards) = runRecurrentForwards layer recIn x

146− recurrentTapes = fst <$> tys

147− forwards = snd <$> tys

148−

149 (newFN, ig, answer) = go n nIn forwards

137 (newFN, ig, answer) = go n nIn forwards

150− in (recurrentTapes :\@> newFN, recOut :~@+> ig, answer)

138+ in (tape :\@> newFN, shape :~@+> ig, answer)

151

139

152 -- Handle the output layer, bouncing the derivatives back down.

140 -- Handle the output layer, bouncing the derivatives back down.

153 -- We may not have a target for each example, so when we don't use 0 gradient.

141 -- We may not have a target for each example, so when we don't use 0 gradient.

154 go RNil RINil !x

142 go RNil RINil !x

155 = (TRNil, RINil, x)

143 = (TRNil, RINil, x)

156

144

157− -- Helper function for recurrent layers

158− -- Scans over the recurrent direction of the graph.

159− goR !layer !recShape (x:xs) =

160− let (tape, lerec, lepush) = runRecurrentForwards layer recShape x

161− (rems, push) = goR layer lerec xs

162− in (rems, (tape, lepush) : push)

163− goR _ rin [] = (rin, [])

164−

165−runRecurrentGradient :: forall layers shapes.

145+runRecurrent' :: forall layers shapes.

166− RecurrentNetwork layers shapes

146+ RecurrentNetwork layers shapes

167− -> RecurrentTapes layers shapes

147+ -> RecurrentTape layers shapes

168− -> RecurrentInputs layers

148+ -> RecurrentInputs layers

169− -> [S (Last shapes)]

149+ -> S (Last shapes)

170− -> (RecurrentGradients layers, RecurrentInputs layers, [S (Head shapes)])

150+ -> (RecurrentGradient layers, RecurrentInputs layers, S (Head shapes))

171−runRecurrentGradient net tapes r o =

151+runRecurrent' net tapes r o =

172 go net tapes r

152 go net tapes r

173 where

153 where

174 -- We have to be careful regarding the direction of the lists

154 -- We have to be careful regarding the direction of the lists

@@ -176,51 +156,41 @@ runRecurrentGradient net tapes r o =

176 -- through time.

156 -- through time.

177 go :: forall js ss. (Last js ~ Last shapes)

157 go :: forall js ss. (Last js ~ Last shapes)

178 => RecurrentNetwork ss js

158 => RecurrentNetwork ss js

179− -> RecurrentTapes ss js

159+ -> RecurrentTape ss js

180 -> RecurrentInputs ss

160 -> RecurrentInputs ss

181− -> (RecurrentGradients ss, RecurrentInputs ss, [S (Head js)])

161+ -> (RecurrentGradient ss, RecurrentInputs ss, S (Head js))

182 -- This is a simple non-recurrent layer

162 -- This is a simple non-recurrent layer

183− -- Run the rest of the network, then fmap the tapes and gradients

163+ -- Run the rest of the network, update with the tapes and gradients

184− go (layer :~~> n) (feedForwardTapes :\~> nTapes) (() :~~+> nRecs) =

164+ go (!layer :~~> n) (!tape :\~> nTapes) (() :~~+> nRecs) =

185− let (gradients, rins, feed) = go n nTapes nRecs

165+ let (!gradients, !rins, !feed) = go n nTapes nRecs

186− backs = uncurry (runBackwards layer) <$> zip (reverse feedForwardTapes) feed

166+ (!grad, !back) = runBackwards layer tape feed

187− in ((fst <$> backs) ://> gradients, () :~~+> rins, snd <$> backs)

167+ in (grad ://> gradients, () :~~+> rins, back)

188

168

189 -- This is a recurrent layer

169 -- This is a recurrent layer

190 -- Run the rest of the network, scan over the tapes in reverse

170 -- Run the rest of the network, scan over the tapes in reverse

191− go (layer :~@> n) (recurrentTapes :\@> nTapes) (recGrad :~@+> nRecs) =

171+ go (!layer :~@> n) (!tape :\@> nTapes) (!recGrad :~@+> nRecs) =

192− let (gradients, rins, feed) = go n nTapes nRecs

172+ let (!gradients, !rins, !feed) = go n nTapes nRecs

193− backExamples = zip (reverse recurrentTapes) feed

173+ (!grad, !sidegrad, !back) = runRecurrentBackwards layer tape recGrad feed

194− (rg, backs) = goX layer recGrad backExamples

195− in ((fst <$> backs) ://> gradients, rg :~@+> rins, snd <$> backs)

174+ in (grad ://> gradients, sidegrad :~@+> rins, back)

196

175

197 -- End of the road, so we reflect the given gradients backwards.

176 -- End of the road, so we reflect the given gradients backwards.

198 -- Crucially, we reverse the list, so it's backwards in time as

177 -- Crucially, we reverse the list, so it's backwards in time as

199 -- well.

178 -- well.

200− go RNil TRNil RINil

179+ go !RNil !TRNil !RINil

201− = (RGNil, RINil, reverse o)

180+ = (RGNil, RINil, o)

202−

203− -- Helper function for recurrent layers

204− -- Scans over the recurrent direction of the graph.

205− goX :: RecurrentLayer x i o => x -> S (RecurrentShape x) -> [(RecTape x i o, S o)] -> (S (RecurrentShape x), [(Gradient x, S i)])

206− goX layer !lastback ((recTape, backgrad):xs) =

207− let (layergrad, recgrad, ingrad) = runRecurrentBackwards layer recTape lastback backgrad

208− (pushedback, ll) = goX layer recgrad xs

209− in (pushedback, (layergrad, ingrad) : ll)

210− goX _ !lastback [] = (lastback, [])

211

181

212-- | Apply a batch of gradients to the network

182-- | Apply a batch of gradients to the network

213-- Uses runUpdates which can be specialised for

183-- Uses runUpdates which can be specialised for

214-- a layer.

184-- a layer.

215applyRecurrentUpdate :: LearningParameters

185applyRecurrentUpdate :: LearningParameters

216 -> RecurrentNetwork layers shapes

186 -> RecurrentNetwork layers shapes

217− -> RecurrentGradients layers

187+ -> RecurrentGradient layers

218 -> RecurrentNetwork layers shapes

188 -> RecurrentNetwork layers shapes

219applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)

189applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)

220− = runUpdates rate layer gradient :~~> applyRecurrentUpdate rate rest grest

190+ = runUpdate rate layer gradient :~~> applyRecurrentUpdate rate rest grest

221

191

222applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)

192applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)

223− = runUpdates rate layer gradient :~@> applyRecurrentUpdate rate rest grest

193+ = runUpdate rate layer gradient :~@> applyRecurrentUpdate rate rest grest

224

194

225applyRecurrentUpdate _ RNil RGNil

195applyRecurrentUpdate _ RNil RGNil

226 = RNil

196 = RNil

@@ -236,26 +206,25 @@ instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recu

236

206

237-- | A network can easily be created by hand with (:~~>) and (:~@>), but an easy way to initialise a random

207-- | A network can easily be created by hand with (:~~>) and (:~@>), but an easy way to initialise a random

238-- recurrent network and a set of random inputs for it is with the randomRecurrent.

208-- recurrent network and a set of random inputs for it is with the randomRecurrent.

239−class CreatableRecurrent (xs :: [*]) (ss :: [Shape]) where

209+class CreatableRecurrent (xs :: [Type]) (ss :: [Shape]) where

240 -- | Create a network of the types requested

210 -- | Create a network of the types requested

241− randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss, RecurrentInputs xs)

211+ randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss)

242

212

243instance SingI i => CreatableRecurrent '[] '[i] where

213instance SingI i => CreatableRecurrent '[] '[i] where

244 randomRecurrent =

214 randomRecurrent =

245− return (RNil, RINil)

215+ return RNil

246

216

247instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where

217instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where

248 randomRecurrent = do

218 randomRecurrent = do

249 thisLayer <- createRandom

219 thisLayer <- createRandom

250− (rest, resti) <- randomRecurrent

220+ rest <- randomRecurrent

251− return (thisLayer :~~> rest, () :~~+> resti)

221+ return (thisLayer :~~> rest)

252

222

253instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where

223instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where

254 randomRecurrent = do

224 randomRecurrent = do

255 thisLayer <- createRandom

225 thisLayer <- createRandom

256− thisShape <- randomOfShape

257− (rest, resti) <- randomRecurrent

226+ rest <- randomRecurrent

258− return (thisLayer :~@> rest, thisShape :~@+> resti)

227+ return (thisLayer :~@> rest)

259

228

260-- | Add very simple serialisation to the recurrent network

229-- | Add very simple serialisation to the recurrent network

261instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where

230instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where

@@ -274,23 +243,13 @@ instance (Serialize (RecurrentInputs '[])) where

274 put _ = return ()

243 put _ = return ()

275 get = return RINil

244 get = return RINil

276

245

277−instance (UpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

246+instance (UpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

278 put ( () :~~+> rest) = put rest

247 put ( () :~~+> rest) = put rest

279 get = ( () :~~+> ) <$> get

248 get = ( () :~~+> ) <$> get

280

249

281−instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

250+instance (Serialize (RecurrentShape x), Fractional (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

282− put ( i :~@+> rest ) = do

251+ put ( i :~@+> rest ) = put i >> put rest

283− _ <- (case i of

284− (S1D x) -> putListOf put . LA.toList . LAS.extract $ x

285− (S2D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

286− (S3D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

287− ) :: PutM ()

288− put rest

289−

290− get = do

252+ get = (:~@+>) <$> get <*> get

291− Just i <- fromStorable . V.fromList <$> getListOf get

292− rest <- get

293− return ( i :~@+> rest)

294

253

295

254

296-- Num instance for `RecurrentInputs layers`

255-- Num instance for `RecurrentInputs layers`

@@ -311,7 +270,7 @@ instance (Num (RecurrentInputs '[])) where

311 signum _ = RINil

270 signum _ = RINil

312 fromInteger _ = RINil

271 fromInteger _ = RINil

313

272

314−instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where

273+instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where

315 (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)

274 (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)

316 (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)

275 (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)

317 (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)

276 (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)

@@ -319,10 +278,51 @@ instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Fee

319 signum (() :~~+> x) = () :~~+> signum x

278 signum (() :~~+> x) = () :~~+> signum x

320 fromInteger x = () :~~+> fromInteger x

279 fromInteger x = () :~~+> fromInteger x

321

280

322−instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where

281+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where

323 (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')

282 (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')

324 (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')

283 (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')

325 (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')

284 (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')

326 abs (x :~@+> x') = abs x :~@+> abs x'

285 abs (x :~@+> x') = abs x :~@+> abs x'

327 signum (x :~@+> x') = signum x :~@+> signum x'

286 signum (x :~@+> x') = signum x :~@+> signum x'

328 fromInteger x = fromInteger x :~@+> fromInteger 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+54−39

@@ -3,41 +3,70 @@

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

6−{-# LANGUAGE CPP #-}

7{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RankNTypes #-}

10−{-# LANGUAGE RecordWildCards #-}

11−

12−#if __GLASGOW_HASKELL__ < 800

13−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

14−#endif

15

9

16module Grenade.Recurrent.Core.Runner (

10module Grenade.Recurrent.Core.Runner (

17− trainRecurrent

11+ runRecurrentExamples

18− , runRecurrent

12+ , runRecurrentBackprop

19 , backPropagateRecurrent

13 , backPropagateRecurrent

14+ , trainRecurrent

15+

16+ , RecurrentGradients

20 ) where

17 ) where

21

18

22−import Data.Singletons.Prelude

19+import Data.List ( foldl' )

23import Grenade.Core

20import Grenade.Core

24

21

25−import Grenade.Recurrent.Core.Layer

26import Grenade.Recurrent.Core.Network

22import 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+

27

55

28-- | Drive and network and collect its back propogated gradients.

56-- | Drive and network and collect its back propogated gradients.

29−backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))

57+backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

30 => RecurrentNetwork layers shapes

58 => RecurrentNetwork layers shapes

31 -> RecurrentInputs layers

59 -> RecurrentInputs layers

32 -> [(S (Head shapes), Maybe (S (Last shapes)))]

60 -> [(S (Head shapes), Maybe (S (Last shapes)))]

33 -> (RecurrentGradients layers, RecurrentInputs layers)

61 -> (RecurrentGradients layers, RecurrentInputs layers)

34backPropagateRecurrent network recinputs examples =

62backPropagateRecurrent network recinputs examples =

35− let (tapes, _, guesses) = runRecurrentNetwork network recinputs inputs

63+ let (outForwards, _) = runRecurrentExamples network recinputs inputs

36

64

37− backPropagations = zipWith makeError guesses targets

65+ backPropagations = zipWith makeError outForwards targets

38

66

39− (gradients, input', _) = runRecurrentGradient network tapes 0 backPropagations

67+ (outBackwards, input') = runRecurrentBackprop network 0 backPropagations

40

68

69+ gradients = fmap fst outBackwards

41 in (gradients, input')

70 in (gradients, input')

42

71

43 where

72 where

@@ -45,12 +74,12 @@ backPropagateRecurrent network recinputs examples =

45 inputs = fst <$> examples

74 inputs = fst <$> examples

46 targets = snd <$> examples

75 targets = snd <$> examples

47

76

48− makeError :: S (Last shapes) -> Maybe (S (Last shapes)) -> S (Last shapes)

77+ makeError :: (x, S (Last shapes)) -> Maybe (S (Last shapes)) -> (x, S (Last shapes))

49− makeError _ Nothing = 0

78+ makeError (x, _) Nothing = (x, 0)

50− makeError y (Just t) = y - t

79+ makeError (x, y) (Just t) = (x, y - t)

51

80

52

81

53−trainRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))

82+trainRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

54 => LearningParameters

83 => LearningParameters

55 -> RecurrentNetwork layers shapes

84 -> RecurrentNetwork layers shapes

56 -> RecurrentInputs layers

85 -> RecurrentInputs layers

@@ -61,35 +90,21 @@ trainRecurrent rate network recinputs examples =

61

90

62 newInputs = updateRecInputs rate recinputs recinputs'

91 newInputs = updateRecInputs rate recinputs recinputs'

63

92

64− newNetwork = applyRecurrentUpdate rate network gradients

93+ newNetwork = foldl' (applyRecurrentUpdate rate) network gradients

65

94

66 in (newNetwork, newInputs)

95 in (newNetwork, newInputs)

67

96

97+updateRecInputs :: Fractional (RecurrentInputs sublayers)

68−updateRecInputs :: LearningParameters

98+ => LearningParameters

69 -> RecurrentInputs sublayers

99 -> RecurrentInputs sublayers

70 -> RecurrentInputs sublayers

100 -> RecurrentInputs sublayers

71 -> RecurrentInputs sublayers

101 -> RecurrentInputs sublayers

72

102

73−updateRecInputs l@LearningParameters {..} (() :~~+> xs) (() :~~+> ys)

103+updateRecInputs lp (() :~~+> xs) (() :~~+> ys)

74− = () :~~+> updateRecInputs l xs ys

104+ = () :~~+> updateRecInputs lp xs ys

75

105

76−updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)

106+updateRecInputs lp (x :~@+> xs) (y :~@+> ys)

77− = (realToFrac (1 - learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys

107+ = (realToFrac (1 - learningRate lp * learningRegulariser lp) * x - realToFrac (learningRate lp) * y) :~@+> updateRecInputs lp xs ys

78

108

79updateRecInputs _ RINil RINil

109updateRecInputs _ RINil RINil

80 = RINil

110 = RINil

81−

82−-- | Just forwards propagation with no training.

83−runRecurrent :: RecurrentNetwork layers shapes

84− -> RecurrentInputs layers -> S (Head shapes)

85− -> (RecurrentInputs layers, S (Last shapes))

86−runRecurrent (layer :~~> n) (() :~~+> nr) !x

87− = let (_, ys) = runForwards layer x

88− (nr', o) = runRecurrent n nr ys

89− in (() :~~+> nr', o)

90−runRecurrent (layer :~@> n) (recin :~@+> nr) !x

91− = let (_, recin', y) = runRecurrentForwards layer recin x

92− (nr', o) = runRecurrent n nr y

93− in (recin' :~@+> nr', o)

94−runRecurrent RNil RINil !x

95− = (RINil, x)

src/Grenade/Recurrent/Layers.hsnew file+9

@@ -0,0 +1,9 @@

1+module Grenade.Recurrent.Layers (

2+ module Grenade.Recurrent.Layers.BasicRecurrent

3+ , module Grenade.Recurrent.Layers.ConcatRecurrent

4+ , module Grenade.Recurrent.Layers.LSTM

5+ ) where

6+

7+import Grenade.Recurrent.Layers.BasicRecurrent

8+import Grenade.Recurrent.Layers.ConcatRecurrent

9+import Grenade.Recurrent.Layers.LSTM

src/Grenade/Recurrent/Layers/BasicRecurrent.hs+9−13

@@ -1,17 +1,12 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE UndecidableInstances #-}

8{-# LANGUAGE UndecidableInstances #-}

10

9

11−-- GHC 7.10 doesn't see recurrent run functions as total.

12−#if __GLASGOW_HASKELL__ < 800

13−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

14−#endif

15module Grenade.Recurrent.Layers.BasicRecurrent (

10module Grenade.Recurrent.Layers.BasicRecurrent (

16 BasicRecurrent (..)

11 BasicRecurrent (..)

17 , randomBasicRecurrent

12 , randomBasicRecurrent

@@ -21,7 +16,8 @@ module Grenade.Recurrent.Layers.BasicRecurrent (

21

16

22import Control.Monad.Random ( MonadRandom, getRandom )

17import Control.Monad.Random ( MonadRandom, getRandom )

23

18

19+

24−import Data.Singletons.TypeLits

20+import Data.Kind (Type)

25

21

26import Numeric.LinearAlgebra.Static

22import Numeric.LinearAlgebra.Static

27

23

@@ -32,7 +28,7 @@ import Grenade.Recurrent.Core

32

28

33data BasicRecurrent :: Nat -- Input layer size

29data BasicRecurrent :: Nat -- Input layer size

34 -> Nat -- Output layer size

30 -> Nat -- Output layer size

35− -> * where

31+ -> Type where

36 BasicRecurrent :: ( KnownNat input

32 BasicRecurrent :: ( KnownNat input

37 , KnownNat output

33 , KnownNat output

38 , KnownNat matrixCols

34 , KnownNat matrixCols

@@ -45,7 +41,7 @@ data BasicRecurrent :: Nat -- Input layer size

45

41

46data BasicRecurrent' :: Nat -- Input layer size

42data BasicRecurrent' :: Nat -- Input layer size

47 -> Nat -- Output layer size

43 -> Nat -- Output layer size

48− -> * where

44+ -> Type where

49 BasicRecurrent' :: ( KnownNat input

45 BasicRecurrent' :: ( KnownNat input

50 , KnownNat output

46 , KnownNat output

51 , KnownNat matrixCols

47 , KnownNat matrixCols

@@ -60,18 +56,18 @@ instance Show (BasicRecurrent i o) where

60instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

56instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

61 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

57 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

62

58

63− runUpdate LearningParameters {..} (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

59+ runUpdate lp (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

64− let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient

60+ let newBiasMomentum = konst (learningMomentum lp) * oldBiasMomentum - konst (learningRate lp) * biasGradient

65 newBias = oldBias + newBiasMomentum

61 newBias = oldBias + newBiasMomentum

66− newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient

62+ newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient

67− regulariser = konst (learningRegulariser * learningRate) * oldActivations

63+ regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations

68 newActivations = oldActivations + newMomentum - regulariser

64 newActivations = oldActivations + newMomentum - regulariser

69 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

65 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

70

66

71 createRandom = randomBasicRecurrent

67 createRandom = randomBasicRecurrent

72

68

73instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where

69instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where

74− type RecurrentShape (BasicRecurrent i o) = 'D1 o

70+ type RecurrentShape (BasicRecurrent i o) = S ('D1 o)

75

71

76instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

72instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

77

73

src/Grenade/Recurrent/Layers/ConcatRecurrent.hsnew file+180

@@ -0,0 +1,180 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE FlexibleInstances #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+{-|

14+Module : Grenade.Layers.Concat

15+Description : Concatenation layer

16+Copyright : (c) Huw Campbell, 2016-2017

17+License : BSD2

18+Stability : experimental

19+

20+This module provides the concatenation layer, which runs two chilld layers in parallel and combines their outputs.

21+-}

22+module Grenade.Recurrent.Layers.ConcatRecurrent (

23+ ConcatRecurrent (..)

24+ ) where

25+

26+import Data.Serialize

27+

28+import Data.Singletons

29+import GHC.TypeLits

30+

31+#if MIN_VERSION_base(4,9,0)

32+import Data.Kind (Type)

33+#endif

34+

35+import Grenade.Core

36+import Grenade.Recurrent.Core

37+

38+import Numeric.LinearAlgebra.Static ( (#), split, R )

39+

40+-- | A Concatentating Layer.

41+--

42+-- This layer shares it's input state between two sublayers, and concatenates their output.

43+--

44+-- With Networks able to be Layers, this allows for very expressive composition of complex Networks.

45+--

46+-- The Concat layer has a few instances, which allow one to flexibly "bash" together the outputs.

47+--

48+-- Two 1D vectors, can go to a 2D shape with 2 rows if their lengths are identical.

49+-- Any 2 1D vectors can also become a longer 1D Vector.

50+--

51+-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad

52+-- and Crop layers to ensure this is the case.

53+data ConcatRecurrent :: Shape -> Type -> Shape -> Type -> Type where

54+ ConcatRecLeft :: x -> y -> ConcatRecurrent m (Recurrent x) n (FeedForward y)

55+ ConcatRecRight :: x -> y -> ConcatRecurrent m (FeedForward x) n (Recurrent y)

56+ ConcatRecBoth :: x -> y -> ConcatRecurrent m (Recurrent x) n (Recurrent y)

57+

58+instance (Show x, Show y) => Show (ConcatRecurrent m (p x) n (q y)) where

59+ show (ConcatRecLeft x y) = "ConcatRecLeft\n" ++ show x ++ "\n" ++ show y

60+ show (ConcatRecRight x y) = "ConcatRecRight\n" ++ show x ++ "\n" ++ show y

61+ show (ConcatRecBoth x y) = "ConcatRecBoth\n" ++ show x ++ "\n" ++ show y

62+

63+instance (RecurrentUpdateLayer x, UpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where

64+ type Gradient (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = (Gradient x, Gradient y)

65+ runUpdate lr (ConcatRecLeft x y) (x', y')

66+ = ConcatRecLeft (runUpdate lr x x') (runUpdate lr y y')

67+ createRandom

68+ = ConcatRecLeft <$> createRandom <*> createRandom

69+

70+instance (UpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where

71+ type Gradient (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = (Gradient x, Gradient y)

72+ runUpdate lr (ConcatRecRight x y) (x', y')

73+ = ConcatRecRight (runUpdate lr x x') (runUpdate lr y y')

74+ createRandom

75+ = ConcatRecRight <$> createRandom <*> createRandom

76+

77+instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where

78+ type Gradient (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = (Gradient x, Gradient y)

79+ runUpdate lr (ConcatRecBoth x y) (x', y')

80+ = ConcatRecBoth (runUpdate lr x x') (runUpdate lr y y')

81+ createRandom

82+ = ConcatRecBoth <$> createRandom <*> createRandom

83+

84+instance (RecurrentUpdateLayer x, UpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where

85+ type RecurrentShape (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = RecurrentShape x

86+

87+instance (UpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where

88+ type RecurrentShape (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = RecurrentShape y

89+

90+instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where

91+ type RecurrentShape (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = RecurrentInputs '[ Recurrent x, Recurrent y ]

92+

93+instance ( SingI i

94+ , Layer x i ('D1 m)

95+ , RecurrentLayer y i ('D1 n)

96+ , KnownNat o

97+ , KnownNat m

98+ , KnownNat n

99+ , o ~ (m + n)

100+ , n ~ (o - m)

101+ , (m <=? o) ~ 'True

102+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) where

103+ type RecTape (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) = (Tape x i ('D1 m), RecTape y i ('D1 n))

104+

105+ runRecurrentForwards (ConcatRecRight x y) s input =

106+ let (xT, xOut :: S ('D1 m)) = runForwards x input

107+ (yT, side, yOut :: S ('D1 n)) = runRecurrentForwards y s input

108+ in case (xOut, yOut) of

109+ (S1D xOut', S1D yOut') ->

110+ ((xT, yT), side, S1D (xOut' # yOut'))

111+

112+ runRecurrentBackwards (ConcatRecRight x y) (xTape, yTape) s (S1D o) =

113+ let (ox :: R m , oy :: R n) = split o

114+ (x', xB :: S i) = runBackwards x xTape (S1D ox)

115+ (y', side, yB :: S i) = runRecurrentBackwards y yTape s (S1D oy)

116+ in ((x', y'), side, xB + yB)

117+

118+instance ( SingI i

119+ , RecurrentLayer x i ('D1 m)

120+ , Layer y i ('D1 n)

121+ , KnownNat o

122+ , KnownNat m

123+ , KnownNat n

124+ , o ~ (m + n)

125+ , n ~ (o - m)

126+ , (m <=? o) ~ 'True

127+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) where

128+ type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) = (RecTape x i ('D1 m), Tape y i ('D1 n))

129+

130+ runRecurrentForwards (ConcatRecLeft x y) s input =

131+ let (xT, side, xOut :: S ('D1 m)) = runRecurrentForwards x s input

132+ (yT, yOut :: S ('D1 n)) = runForwards y input

133+ in case (xOut, yOut) of

134+ (S1D xOut', S1D yOut') ->

135+ ((xT, yT), side, S1D (xOut' # yOut'))

136+

137+ runRecurrentBackwards (ConcatRecLeft x y) (xTape, yTape) s (S1D o) =

138+ let (ox :: R m , oy :: R n) = split o

139+ (x', side, xB :: S i) = runRecurrentBackwards x xTape s (S1D ox)

140+ (y', yB :: S i) = runBackwards y yTape (S1D oy)

141+ in ((x', y'), side, xB + yB)

142+

143+instance ( SingI i

144+ , RecurrentLayer x i ('D1 m)

145+ , RecurrentLayer y i ('D1 n)

146+ , Fractional (RecurrentShape x)

147+ , Fractional (RecurrentShape y)

148+ , KnownNat o

149+ , KnownNat m

150+ , KnownNat n

151+ , o ~ (m + n)

152+ , n ~ (o - m)

153+ , (m <=? o) ~ 'True

154+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) where

155+ type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) = (RecTape x i ('D1 m), RecTape y i ('D1 n))

156+

157+ runRecurrentForwards (ConcatRecBoth x y) (sx :~@+> (sy :~@+> RINil)) input =

158+ let (xT, s'x, xOut :: S ('D1 m)) = runRecurrentForwards x sx input

159+ (yT, s'y, yOut :: S ('D1 n)) = runRecurrentForwards y sy input

160+ in case (xOut, yOut) of

161+ (S1D xOut', S1D yOut') ->

162+ ((xT, yT), (s'x :~@+> (s'y :~@+> RINil)), S1D (xOut' # yOut'))

163+

164+ runRecurrentBackwards (ConcatRecBoth x y) (xTape, yTape) (sx :~@+> (sy :~@+> RINil)) (S1D o) =

165+ let (ox :: R m , oy :: R n) = split o

166+ (x', s'x, xB :: S i) = runRecurrentBackwards x xTape sx (S1D ox)

167+ (y', s'y, yB :: S i) = runRecurrentBackwards y yTape sy (S1D oy)

168+ in ((x', y'), (s'x :~@+> (s'y :~@+> RINil)), xB + yB)

169+

170+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (FeedForward a) sb (Recurrent b)) where

171+ put (ConcatRecRight a b) = put a *> put b

172+ get = ConcatRecRight <$> get <*> get

173+

174+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (Recurrent b)) where

175+ put (ConcatRecBoth a b) = put a *> put b

176+ get = ConcatRecBoth <$> get <*> get

177+

178+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (FeedForward b)) where

179+ put (ConcatRecLeft a b) = put a *> put b

180+ get = ConcatRecLeft <$> get <*> get

src/Grenade/Recurrent/Layers/LSTM.hs+57−86

@@ -1,9 +1,8 @@

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE CPP #-}

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE RankNTypes #-}

6−{-# LANGUAGE RecordWildCards #-}

7{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeOperators #-}

8{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

@@ -11,11 +10,6 @@

11{-# LANGUAGE ViewPatterns #-}

10{-# LANGUAGE ViewPatterns #-}

12{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

13

12

14−-- GHC 7.10 doesn't see recurrent run functions as total.

15−#if __GLASGOW_HASKELL__ < 800

16−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

17−#endif

18−

19module Grenade.Recurrent.Layers.LSTM (

13module Grenade.Recurrent.Layers.LSTM (

20 LSTM (..)

14 LSTM (..)

21 , LSTMWeights (..)

15 , LSTMWeights (..)

@@ -27,7 +21,7 @@ import Control.Monad.Random ( MonadRandom, getRandom )

27-- import Data.List ( foldl1' )

21-- import Data.List ( foldl1' )

28import Data.Proxy

22import Data.Proxy

29import Data.Serialize

23import Data.Serialize

30−import Data.Singletons.TypeLits

24+import Data.Kind (Type)

31

25

32import qualified Numeric.LinearAlgebra as LA

26import qualified Numeric.LinearAlgebra as LA

33import Numeric.LinearAlgebra.Static

27import Numeric.LinearAlgebra.Static

@@ -35,6 +29,7 @@ import Numeric.LinearAlgebra.Static

35import Grenade.Core

29import Grenade.Core

36import Grenade.Recurrent.Core

30import Grenade.Recurrent.Core

37import Grenade.Layers.Internal.Update

31import Grenade.Layers.Internal.Update

32+import GHC.TypeLits

38

33

39

34

40-- | Long Short Term Memory Recurrent unit

35-- | Long Short Term Memory Recurrent unit

@@ -42,14 +37,14 @@ import Grenade.Layers.Internal.Update

42-- This is a Peephole formulation, so the recurrent shape is

37-- This is a Peephole formulation, so the recurrent shape is

43-- just the cell state, the previous output is not held or used

38-- just the cell state, the previous output is not held or used

44-- at all.

39-- at all.

45−data LSTM :: Nat -> Nat -> * where

40+data LSTM :: Nat -> Nat -> Type where

46 LSTM :: ( KnownNat input

41 LSTM :: ( KnownNat input

47 , KnownNat output

42 , KnownNat output

48 ) => !(LSTMWeights input output) -- Weights

43 ) => !(LSTMWeights input output) -- Weights

49 -> !(LSTMWeights input output) -- Momentums

44 -> !(LSTMWeights input output) -- Momentums

50 -> LSTM input output

45 -> LSTM input output

51

46

52−data LSTMWeights :: Nat -> Nat -> * where

47+data LSTMWeights :: Nat -> Nat -> Type where

53 LSTMWeights :: ( KnownNat input

48 LSTMWeights :: ( KnownNat input

54 , KnownNat output

49 , KnownNat output

55 ) => {

50 ) => {

@@ -76,7 +71,7 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

76

71

77 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

72 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

78 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

73 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

79− runUpdate LearningParameters {..} (LSTM w m) g =

74+ runUpdate lp (LSTM w m) g =

80 let (wf, wf') = u lstmWf w m g

75 let (wf, wf') = u lstmWf w m g

81 (uf, uf') = u lstmUf w m g

76 (uf, uf') = u lstmUf w m g

82 (bf, bf') = v lstmBf w m g

77 (bf, bf') = v lstmBf w m g

@@ -93,11 +88,11 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

93 -- Utility function for updating with the momentum, gradients, and weights.

88 -- Utility function for updating with the momentum, gradients, and weights.

94 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

89 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

95 u e (e -> weights) (e -> momentum) (e -> gradient) =

90 u e (e -> weights) (e -> momentum) (e -> gradient) =

96− decendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum

91+ descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

97

92

98 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

93 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

99 v e (e -> weights) (e -> momentum) (e -> gradient) =

94 v e (e -> weights) (e -> momentum) (e -> gradient) =

100− decendVector learningRate learningMomentum learningRegulariser weights gradient momentum

95+ descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

101

96

102 -- There's a lot of updates here, so to try and minimise the number of data copies

97 -- There's a lot of updates here, so to try and minimise the number of data copies

103 -- we'll create a mutable bucket for each.

98 -- we'll create a mutable bucket for each.

@@ -129,27 +124,33 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

129instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

124instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

130 -- The recurrent shape is the same size as the output.

125 -- The recurrent shape is the same size as the output.

131 -- It's actually the cell state however, as this is a peephole variety LSTM.

126 -- It's actually the cell state however, as this is a peephole variety LSTM.

132− type RecurrentShape (LSTM i o) = 'D1 o

127+ type RecurrentShape (LSTM i o) = S ('D1 o)

133

128

134instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

129instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

135

130

131+ -- The tape stores essentially every variable we calculate,

132+ -- so we don't have to run any forwards component again.

136− type RecTape (LSTM i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))

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)

137 -- Forward propagation for the LSTM layer.

134 -- Forward propagation for the LSTM layer.

138 -- The size of the cell state is also the size of the output.

135 -- The size of the cell state is also the size of the output.

139− runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =

136+ runRecurrentForwards (LSTM lw _) (S1D cell) (S1D input) =

140 let -- Forget state vector

137 let -- Forget state vector

141− f_t = sigmoid $ lstmBf + lstmWf #> input + lstmUf #> cell

138+ f_s = lstmBf lw + lstmWf lw #> input + lstmUf lw #> cell

139+ f_t = sigmoid f_s

142 -- Input state vector

140 -- Input state vector

143− i_t = sigmoid $ lstmBi + lstmWi #> input + lstmUi #> cell

141+ i_s = lstmBi lw + lstmWi lw #> input + lstmUi lw #> cell

142+ i_t = sigmoid i_s

144 -- Output state vector

143 -- Output state vector

145− o_t = sigmoid $ lstmBo + lstmWo #> input + lstmUo #> cell

144+ o_s = lstmBo lw + lstmWo lw #> input + lstmUo lw #> cell

145+ o_t = sigmoid o_s

146 -- Cell input state vector

147− c_x = tanh $ lstmBc + lstmWc #> input

147+ c_s = lstmBc lw + lstmWc lw #> input

148+ c_x = tanh c_s

148 -- Cell state

149 -- Cell state

149 c_t = f_t * cell + i_t * c_x

150 c_t = f_t * cell + i_t * c_x

150 -- Output (it's sometimes recommended to use tanh c_t)

151 -- Output (it's sometimes recommended to use tanh c_t)

151 h_t = o_t * c_t

152 h_t = o_t * c_t

152− in ((S1D cell, S1D input), S1D c_t, S1D h_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)

153

154

154 -- Run a backpropogation step for an LSTM layer.

155 -- Run a backpropogation step for an LSTM layer.

155 -- We're doing all the derivatives by hand here, so one should

156 -- We're doing all the derivatives by hand here, so one should

@@ -157,29 +158,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

157 --

158 --

158 -- There's a test version using the AD library without hmatrix in the test

159 -- There's a test version using the AD library without hmatrix in the test

159 -- suite. These should match always.

160 -- suite. These should match always.

160− runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (S1D cell, S1D input) (S1D cellGrad) (S1D h_t') =

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') =

161− -- We're not keeping the Wengert tape during the forward pass,

162− -- so we're duplicating some work here.

163− --

164− -- If I was being generous, I'd call it checkpointing.

165− --

166− -- Maybe think about better ways to store some intermediate states.

167− let -- Forget state vector

168− f_s = lstmBf + lstmWf #> input + lstmUf #> cell

169− f_t = sigmoid f_s

170− -- Input state vector

171− i_s = lstmBi + lstmWi #> input + lstmUi #> cell

172− i_t = sigmoid i_s

173− -- Output state vector

174− o_s = lstmBo + lstmWo #> input + lstmUo #> cell

175− o_t = sigmoid o_s

176− -- Cell input state vector

177− c_s = lstmBc + lstmWc #> input

178− c_x = tanh c_s

179− -- Cell state

180− c_t = f_t * cell + i_t * c_x

181−

182− -- Reverse Mode AD Derivitives

162+ let -- Reverse Mode AD Derivitives

183 c_t' = h_t' * o_t + cellGrad

163 c_t' = h_t' * o_t + cellGrad

184

164

185 f_t' = c_t' * cell

165 f_t' = c_t' * cell

@@ -195,8 +175,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

195 c_s' = tanh' c_s * c_x'

175 c_s' = tanh' c_s * c_x'

196

176

197 -- The derivatives to pass sideways (recurrent) and downwards

177 -- The derivatives to pass sideways (recurrent) and downwards

198− cell' = tr lstmUf #> f_s' + tr lstmUo #> o_s' + tr lstmUi #> i_s' + c_t' * f_t

178+ cell' = tr (lstmUf lw) #> f_s' + tr (lstmUo lw) #> o_s' + tr (lstmUi lw) #> i_s' + c_t' * f_t

199− input' = tr lstmWf #> f_s' + tr lstmWo #> o_s' + tr lstmWi #> i_s' + tr lstmWc #> c_s'

179+ input' = tr (lstmWf lw) #> f_s' + tr (lstmWo lw) #> o_s' + tr (lstmWi lw) #> i_s' + tr (lstmWc lw) #> c_s'

200

180

201 -- Calculate the gradient Matricies for the input

181 -- Calculate the gradient Matricies for the input

202 lstmWf' = f_s' `outer` input

182 lstmWf' = f_s' `outer` input

@@ -241,7 +221,8 @@ randomLSTM = do

241

221

242-- | Maths

222-- | Maths

243--

223--

244−-- TODO: move to not here

224+-- TODO: Move to not here

225+-- Optimise backwards derivative

245sigmoid :: Floating a => a -> a

226sigmoid :: Floating a => a -> a

246sigmoid x = 1 / (1 + exp (-x))

227sigmoid x = 1 / (1 + exp (-x))

247

228

@@ -254,44 +235,34 @@ tanh' :: (Floating a) => a -> a

254tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

235tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

255

236

256instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

237instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

257− put (LSTM LSTMWeights {..} _) = do

238+ put (LSTM lw _) = do

258− u lstmWf

239+ u (lstmWf lw)

259− u lstmUf

240+ u (lstmUf lw)

260− v lstmBf

241+ v (lstmBf lw)

261− u lstmWi

242+ u (lstmWi lw)

262− u lstmUi

243+ u (lstmUi lw)

263− v lstmBi

244+ v (lstmBi lw)

264− u lstmWo

245+ u (lstmWo lw)

265− u lstmUo

246+ u (lstmUo lw)

266− v lstmBo

247+ v (lstmBo lw)

267− u lstmWc

248+ u (lstmWc lw)

268− v lstmBc

249+ v (lstmBc lw)

269− where

250+ where

270− u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

251+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

271− u = putListOf put . LA.toList . LA.flatten . extract

252+ u = putListOf put . LA.toList . LA.flatten . extract

272− v :: forall a. (KnownNat a) => Putter (R a)

253+ v :: forall a. (KnownNat a) => Putter (R a)

273− v = putListOf put . LA.toList . extract

254+ v = putListOf put . LA.toList . extract

274

255

275 get = do

256 get = do

276− lstmWf <- u

257+ w <- LSTMWeights <$> u <*> u <*> v <*> u <*> u <*> v <*> u <*> u <*> v <*> u <*> v

277− lstmUf <- u

278− lstmBf <- v

279− lstmWi <- u

280− lstmUi <- u

281− lstmBi <- v

282− lstmWo <- u

283− lstmUo <- u

284− lstmBo <- v

285− lstmWc <- u

286− lstmBc <- v

287− return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

258+ return $ LSTM w (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

288− where

259+ where

289− u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

260+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

290− u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

261+ u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

291− in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

262+ in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

292− v :: forall a. (KnownNat a) => Get (R a)

263+ v :: forall a. (KnownNat a) => Get (R a)

293− v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

264+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

294−

265+

295− w0 = konst 0

266+ w0 = konst 0

296− u0 = konst 0

267+ u0 = konst 0

297− v0 = konst 0

268+ v0 = konst 0

src/Grenade/Utils/OneHot.hs+6−5

@@ -22,7 +22,6 @@ import Data.Map ( Map )

22import qualified Data.Map as M

23

24import Data.Proxy

25−import Data.Singletons.TypeLits

26

25

27import Data.Vector ( Vector )

26import Data.Vector ( Vector )

28import qualified Data.Vector as V

27import qualified Data.Vector as V

@@ -31,6 +30,7 @@ import qualified Data.Vector.Storable as VS

31import Numeric.LinearAlgebra ( maxIndex )

30import Numeric.LinearAlgebra ( maxIndex )

32import Numeric.LinearAlgebra.Devel

31import Numeric.LinearAlgebra.Devel

33import Numeric.LinearAlgebra.Static

32import Numeric.LinearAlgebra.Static

33+import GHC.TypeLits

34

35import Grenade.Core.Shape

36

@@ -52,15 +52,16 @@ 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] -> Maybe (Map a Int, Vector a)

55+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Either String (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− Just (M.fromList $ zip uniq [0..], V.fromList uniq)

62+ Right (M.fromList $ zip uniq [0..], V.fromList uniq)

63− else Nothing

63+ else

64+ Left ("Couldn't create hotMap of size " ++ show len ++ " from vector with " ++ show hotl ++ " unique characters")

64

65

65-- | From a map and value, create a 1D Shape

66-- | From a map and value, create a 1D Shape

66-- with one index hot (1) with the rest 0.

67-- with one index hot (1) with the rest 0.

stack.yamlnew file+78

@@ -0,0 +1,78 @@

1+# This file was automatically generated by 'stack init'

2+#

3+# Some commonly used options have been documented as comments in this file.

4+# For advanced use and comprehensive documentation of the format, please see:

5+# https://docs.haskellstack.org/en/stable/yaml_configuration/

6+

7+# A warning or info to be displayed to the user on config load.

8+# user-message: |

9+

10+# Resolver to choose a 'specific' stackage snapshot or a compiler version.

11+# A snapshot resolver dictates the compiler version and the set of packages

12+# to be used for project dependencies. For example:

13+#

14+# resolver: lts-3.5

15+# resolver: nightly-2015-09-21

16+# resolver: ghc-7.10.2

17+#

18+# The location of a snapshot can be provided as a file or url. Stack assumes

19+# a snapshot provided as a file might change, whereas a url resource does not.

20+#

21+# resolver: ./custom-snapshot.yaml

22+# resolver: https://example.com/snapshots/2018-01-01.yaml

23+resolver: lts-20.18

24+

25+# User packages to be built.

26+# Various formats can be used as shown in the example below.

27+#

28+# packages:

29+# - some-directory

30+# - https://example.com/foo/bar/baz-0.0.2.tar.gz

31+# subdirs:

32+# - auto-update

33+# - wai

34+packages:

35+ - .

36+ - examples

37+

38+# Dependency packages to be pulled from upstream that are not in the resolver.

39+# These entries can reference officially published versions as well as

40+# forks / in-progress versions pinned to a git hash. For example:

41+#

42+# extra-deps:

43+# - acme-missiles-0.3

44+# - git: https://github.com/commercialhaskell/stack.git

45+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

46+#

47+extra-deps:

48+ - typelits-witnesses-0.3.0.3

49+

50+# Override default flag values for local packages and extra-deps

51+# flags: {}

52+

53+# Extra package databases containing global packages

54+# extra-package-dbs: []

55+

56+# Control whether we use the GHC we find on the path

57+# system-ghc: true

58+#

59+# Require a specific version of stack, using version ranges

60+# require-stack-version: -any # Default

61+# require-stack-version: ">=2.1"

62+#

63+# Override the architecture used by stack, especially useful on Windows

64+# arch: i386

65+# arch: x86_64

66+#

67+# Extra directories used by stack for building

68+# extra-include-dirs: [/path/to/dir]

69+# extra-lib-dirs: [/path/to/dir]

70+#

71+# Allow a newer minor version of GHC than the snapshot specifies

72+# compiler-check: newer-minor

73+

74+nix:

75+ enable: true

76+ packages:

77+ - blas

78+ - lapack

stack.yaml.locknew file+19

@@ -0,0 +1,19 @@

1+# This file was autogenerated by Stack.

2+# You should not edit this file by hand.

3+# For more information, please see the documentation at:

4+# https://docs.haskellstack.org/en/stable/lock_files

5+

6+packages:

7+- completed:

8+ hackage: typelits-witnesses-0.3.0.3@sha256:2d9df4ac6ff3077bfd2bf659e4b495e157723ac5b45c519762853f55df5c16db,2738

9+ pantry-tree:

10+ sha256: 6a42a462f98e94933b6e9721acd912c6c6b6a4743635efd15cc5871908c816a0

11+ size: 469

12+ original:

13+ hackage: typelits-witnesses-0.3.0.3

14+snapshots:

15+- completed:

16+ sha256: 9fa4bece7acfac1fc7930c5d6e24606004b09e80aa0e52e9f68b148201008db9

17+ size: 649606

18+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/18.yaml

19+ original: lts-20.18

test/Test/Grenade/Layers/Convolution.hs+29−24

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

@@ -15,15 +16,21 @@ import Data.Singletons ()

15import GHC.TypeLits

16import GHC.TypeLits

16import GHC.TypeLits.Witnesses

17import GHC.TypeLits.Witnesses

17

18

19+#if MIN_VERSION_base(4,9,0)

20+import Data.Kind (Type)

21+#endif

22+

18import Grenade.Core

23import Grenade.Core

19import Grenade.Layers.Convolution

24import Grenade.Layers.Convolution

20

25

21−import Disorder.Jack

26+import Hedgehog

27+import qualified Hedgehog.Gen as Gen

22

28

23−import Test.Jack.Hmatrix

29+import Test.Hedgehog.Hmatrix

24−import Test.Jack.TypeLits

30+import Test.Hedgehog.TypeLits

31+import Test.Hedgehog.Compat

25

32

26−data OpaqueConvolution :: * where

33+data OpaqueConvolution :: Type where

27 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution

34 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution

28

35

29instance Show OpaqueConvolution where

36instance Show OpaqueConvolution where

@@ -37,10 +44,10 @@ genConvolution :: ( KnownNat channels

37 , KnownNat strideColumns

44 , KnownNat strideColumns

38 , KnownNat kernelFlattened

45 , KnownNat kernelFlattened

39 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

46 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

40− ) => Jack (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

47+ ) => Gen (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

41genConvolution = Convolution <$> uniformSample <*> uniformSample

48genConvolution = Convolution <$> uniformSample <*> uniformSample

42

49

43−genOpaqueOpaqueConvolution :: Jack OpaqueConvolution

50+genOpaqueOpaqueConvolution :: Gen OpaqueConvolution

44genOpaqueOpaqueConvolution = do

51genOpaqueOpaqueConvolution = do

45 channels <- genNat

52 channels <- genNat

46 filters <- genNat

53 filters <- genNat

@@ -56,17 +63,17 @@ genOpaqueOpaqueConvolution = do

56 p2 = natDict pkc

63 p2 = natDict pkc

57 p3 = natDict pch

64 p3 = natDict pch

58 in case p1 %* p2 %* p3 of

65 in case p1 %* p2 %* p3 of

59− Dict -> OpaqueConvolution <$> (genConvolution :: Jack (Convolution ch fl kr kc sr sc))

66+ Dict -> OpaqueConvolution <$> (genConvolution :: Gen (Convolution ch fl kr kc sr sc))

67+

68+prop_conv_net_witness = property $

69+ blindForAll genOpaqueOpaqueConvolution >>= \onet ->

70+ case onet of

71+ (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> success

60

72

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

66

73

67−prop_conv_net =

74+prop_conv_net = property $

68− gamble genOpaqueOpaqueConvolution $ \onet ->

75+ blindForAll genOpaqueOpaqueConvolution >>= \onet ->

69− (case onet of

76+ case onet of

70 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->

77 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->

71 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]

78 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]

72 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

79 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

@@ -74,15 +81,15 @@ prop_conv_net =

74 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)

81 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)

75 sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)

82 sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)

76

83

77− in gamble (elements (ok sr kr)) $ \er ->

84+ in forAll (Gen.element (ok sr kr)) >>= \er ->

78− gamble (elements (ok sc kc)) $ \ec ->

85+ forAll (Gen.element (ok sc kc)) >>= \ec ->

79 let rr = ((er - kr) `div` sr) + 1

86 let rr = ((er - kr) `div` sr) + 1

80 rc = ((ec - kc) `div` sc) + 1

87 rc = ((ec - kc) `div` sc) + 1

81 Just er' = someNatVal er

88 Just er' = someNatVal er

82 Just ec' = someNatVal ec

89 Just ec' = someNatVal ec

83 Just rr' = someNatVal rr

90 Just rr' = someNatVal rr

84 Just rc' = someNatVal rc

91 Just rc' = someNatVal rc

85− in (case (er', ec', rr', rc') of

92+ in case (er', ec', rr', rc') of

86 ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->

93 ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->

87 case ( natDict pinr %* natDict (Proxy :: Proxy channels)

94 case ( natDict pinr %* natDict (Proxy :: Proxy channels)

88 , natDict pour %* natDict (Proxy :: Proxy filters)

95 , natDict pour %* natDict (Proxy :: Proxy filters)

@@ -90,14 +97,12 @@ prop_conv_net =

90 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

97 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

91 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

98 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

92 (Dict, Dict, Dict, Dict) ->

99 (Dict, Dict, Dict, Dict) ->

93− gamble (S3D <$> uniformSample) $ \(input :: S ('D3 inRows inCols channels)) ->

100+ blindForAll (S3D <$> uniformSample) >>= \(input :: S ('D3 inRows inCols channels)) ->

94 let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input

101 let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input

95 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))

102 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))

96 = runBackwards convLayer tape output

103 = runBackwards convLayer tape output

97− in backed `seq` True

104+ in backed `seq` success

98− ) :: Property

105+

99− ) :: Property

100

106

101−return []

102tests :: IO Bool

107tests :: IO Bool

103−tests = $quickCheckAll

108+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/FullyConnected.hs+21−17

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

@@ -12,24 +13,28 @@ import Data.Singletons ()

12

13

13import GHC.TypeLits

14import GHC.TypeLits

14

15

16+#if MIN_VERSION_base(4,9,0)

17+import Data.Kind (Type)

18+#endif

19+

15import Grenade.Core

20import Grenade.Core

16import Grenade.Layers.FullyConnected

21import Grenade.Layers.FullyConnected

17

22

18−import Disorder.Jack

23+import Hedgehog

19−

20−import Test.Jack.Hmatrix

21

24

25+import Test.Hedgehog.Compat

26+import Test.Hedgehog.Hmatrix

22

27

23−data OpaqueFullyConnected :: * where

28+data OpaqueFullyConnected :: Type where

24 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected

29 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected

25

30

26instance Show OpaqueFullyConnected where

31instance Show OpaqueFullyConnected where

27 show (OpaqueFullyConnected n) = show n

32 show (OpaqueFullyConnected n) = show n

28

33

29−genOpaqueFullyConnected :: Jack OpaqueFullyConnected

34+genOpaqueFullyConnected :: Gen OpaqueFullyConnected

30genOpaqueFullyConnected = do

35genOpaqueFullyConnected = do

31− input :: Integer <- choose (2, 100)

36+ input :: Integer <- choose 2 100

32− output :: Integer <- choose (1, 100)

37+ output :: Integer <- choose 1 100

33 let Just input' = someNatVal input

38 let Just input' = someNatVal input

34 let Just output' = someNatVal output

39 let Just output' = someNatVal output

35 case (input', output') of

40 case (input', output') of

@@ -41,14 +46,13 @@ genOpaqueFullyConnected = do

41 return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')

46 return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')

42

47

43prop_fully_connected_forwards :: Property

48prop_fully_connected_forwards :: Property

44−prop_fully_connected_forwards =

49+prop_fully_connected_forwards = property $ do

45− gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->

50+ OpaqueFullyConnected (fclayer :: FullyConnected i o) <- blindForAll genOpaqueFullyConnected

46− gamble (S1D <$> randomVector) $ \(input :: S ('D1 i)) ->

51+ input :: S ('D1 i) <- blindForAll (S1D <$> randomVector)

47− let (tape, output :: S ('D1 o)) = runForwards fclayer input

52+ let (tape, output :: S ('D1 o)) = runForwards fclayer input

48− backed :: (Gradient (FullyConnected i o), S ('D1 i))

53+ backed :: (Gradient (FullyConnected i o), S ('D1 i))

49− = runBackwards fclayer tape output

54+ = runBackwards fclayer tape output

50− in backed `seq` True

55+ backed `seq` success

51−

56+

52−return []

53tests :: IO Bool

57tests :: IO Bool

54−tests = $quickCheckAll

58+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Internal/Convolution.hs+34−29

@@ -12,41 +12,46 @@ import Grenade.Layers.Internal.Convolution

12

13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

14

15−import Disorder.Jack

15+import Hedgehog

16+import qualified Hedgehog.Gen as Gen

17+import qualified Hedgehog.Range as Range

16

18

17import qualified Test.Grenade.Layers.Internal.Reference as Reference

19import qualified Test.Grenade.Layers.Internal.Reference as Reference

20+import Test.Hedgehog.Compat

18

21

19prop_im2col_col2im_symmetrical_with_kernel_stride =

22prop_im2col_col2im_symmetrical_with_kernel_stride =

20 let factors n = [x | x <- [1..n], n `mod` x == 0]

23 let factors n = [x | x <- [1..n], n `mod` x == 0]

21− in gamble (choose (2, 100)) $ \height ->

24+ in property $ do

22− gamble (choose (2, 100)) $ \width ->

25+ height <- forAll $ choose 2 100

23− gamble ((height `div`) <$> elements (factors height)) $ \kernel_h ->

26+ width <- forAll $ choose 2 100

24− gamble ((width `div`) <$> elements (factors width)) $ \kernel_w ->

27+ kernel_h <- forAll $ (height `div`) <$> Gen.element (factors height)

25− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

28+ kernel_w <- forAll $ (width `div`) <$> Gen.element (factors width)

26− let input' = (height >< width) input

29+ input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

30+

27− stride_h = kernel_h

31+ let stride_h = kernel_h

28− stride_w = kernel_w

32+ let stride_w = kernel_w

29− out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input'

33+ let out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input

30− in input' === out

34+ input === out

31

35

32prop_im2col_col2im_behaves_as_reference =

36prop_im2col_col2im_behaves_as_reference =

33 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

37 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

38+ in property $ do

34− in gamble (choose (2, 100)) $ \height ->

39+ height <- forAll (choose 2 100)

35− gamble (choose (2, 100)) $ \width ->

40+ width <- forAll (choose 2 100)

36− gamble (choose (2, height - 1)) $ \kernel_h ->

41+ kernel_h <- forAll (choose 2 (height - 1))

37− gamble (choose (2, width - 1)) $ \kernel_w ->

42+ kernel_w <- forAll (choose 2 (width - 1))

38− gamble (elements (ok height kernel_h)) $ \stride_h ->

43+ stride_h <- forAll (Gen.element (ok height kernel_h))

39− gamble (elements (ok width kernel_w)) $ \stride_w ->

44+ stride_w <- forAll (Gen.element (ok width kernel_w))

40− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

45+ input <- forAll ((height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100))

41− let input' = (height >< width) input

46+

42− outFast = im2col kernel_h kernel_w stride_h stride_w input'

47+ let outFast = im2col kernel_h kernel_w stride_h stride_w input

43− retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast

48+ let retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast

44−

49+

45− outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input'

50+ let outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input

46− retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference

51+ let retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference

52+

47− in outFast === outReference .&&. retFast === retReference

53+ outFast === outReference

48−

54+ retFast === retReference

49−

55+

50−return []

51tests :: IO Bool

56tests :: IO Bool

52−tests = $quickCheckAll

57+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Internal/Pooling.hs+24−18

@@ -12,28 +12,34 @@ import Grenade.Layers.Internal.Pooling

12

13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

14

15−import Disorder.Jack

15+import Hedgehog

16+import qualified Hedgehog.Gen as Gen

17+import qualified Hedgehog.Range as Range

16

18

17import qualified Test.Grenade.Layers.Internal.Reference as Reference

19import qualified Test.Grenade.Layers.Internal.Reference as Reference

20+import Test.Hedgehog.Compat

18

21

19prop_poolForwards_poolBackwards_behaves_as_reference =

22prop_poolForwards_poolBackwards_behaves_as_reference =

20 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

23 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

21 output extent kernel stride = (extent - kernel) `div` stride + 1

24 output extent kernel stride = (extent - kernel) `div` stride + 1

22− in gamble (choose (2, 100)) $ \height ->

25+ in property $ do

26+ height <- forAll $ choose 2 100

23− gamble (choose (2, 100)) $ \width ->

27+ width <- forAll $ choose 2 100

24− gamble (choose (1, height - 1)) $ \kernel_h ->

28+ kernel_h <- forAll $ choose 1 (height - 1)

25− gamble (choose (1, width - 1)) $ \kernel_w ->

29+ kernel_w <- forAll $ choose 1 (width - 1)

26− gamble (elements (ok height kernel_h)) $ \stride_h ->

30+ stride_h <- forAll $ Gen.element (ok height kernel_h)

27− gamble (elements (ok width kernel_w)) $ \stride_w ->

31+ stride_w <- forAll $ Gen.element (ok width kernel_w)

28− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

32+ input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

29− let input' = (height >< width) input

33+

30− outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'

34+ let outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input

31− retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast

35+ let retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input outFast

32−

36+

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'

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

34− retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference

38+ let retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input outReference

39+

35− in outFast === outReference .&&. retFast === retReference

40+ outFast === outReference

36−

41+ retFast === retReference

37−return []

42+

43+

38tests :: IO Bool

44tests :: IO Bool

39−tests = $quickCheckAll

45+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Nonlinear.hs+13−36

@@ -1,5 +1,4 @@

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

3{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

4{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE KindSignatures #-}

4{-# LANGUAGE KindSignatures #-}

@@ -11,67 +10,45 @@ module Test.Grenade.Layers.Nonlinear where

11

10

12import Data.Singletons

11import Data.Singletons

13

12

14−#if __GLASGOW_HASKELL__ < 800

15−import Data.Proxy

16−#endif

17−

18import Grenade

13import Grenade

19−import GHC.TypeLits

20

14

21−import Disorder.Jack

15+import Hedgehog

22

16

23−import Test.Jack.Hmatrix

17+import Test.Hedgehog.Compat

18+import Test.Hedgehog.Hmatrix

24−import Test.Jack.TypeLits

19+import Test.Hedgehog.TypeLits

25

20

26import Numeric.LinearAlgebra.Static ( norm_Inf )

21import Numeric.LinearAlgebra.Static ( norm_Inf )

27

22

28prop_sigmoid_grad :: Property

23prop_sigmoid_grad :: Property

29−prop_sigmoid_grad =

24+prop_sigmoid_grad = property $

30− gambleDisplay (const "Shape") genShape $ \case

25+ forAllWith rss genShape >>= \case

31 (SomeSing (r :: Sing s)) ->

26 (SomeSing (r :: Sing s)) ->

32 withSingI r $

27 withSingI r $

33− gamble genOfShape $ \(ds :: S s) ->

28+ blindForAll genOfShape >>= \(ds :: S s) ->

34 let (tape, f :: S s) = runForwards Logit ds

29 let (tape, f :: S s) = runForwards Logit ds

35 ((), ret :: S s) = runBackwards Logit tape (1 :: S s)

30 ((), ret :: S s) = runBackwards Logit tape (1 :: S s)

36 (_, numer :: S s) = runForwards Logit (ds + 0.0001)

31 (_, numer :: S s) = runForwards Logit (ds + 0.0001)

37 numericalGradient = (numer - f) * 10000

32 numericalGradient = (numer - f) * 10000

38− in counterexample (show numericalGradient ++ show ret)

39− ((case numericalGradient - ret of

33+ in assert ((case numericalGradient - ret of

40 (S1D x) -> norm_Inf x < 0.0001

34 (S1D x) -> norm_Inf x < 0.0001

41 (S2D x) -> norm_Inf x < 0.0001

35 (S2D x) -> norm_Inf x < 0.0001

42 (S3D x) -> norm_Inf x < 0.0001) :: Bool)

36 (S3D x) -> norm_Inf x < 0.0001) :: Bool)

43

37

44prop_tanh_grad :: Property

38prop_tanh_grad :: Property

45−prop_tanh_grad =

39+prop_tanh_grad = property $

46− gambleDisplay (const "Shape") genShape $ \case

40+ forAllWith rss genShape >>= \case

47 (SomeSing (r :: Sing s)) ->

41 (SomeSing (r :: Sing s)) ->

48 withSingI r $

42 withSingI r $

49− gamble genOfShape $ \(ds :: S s) ->

43+ blindForAll genOfShape >>= \(ds :: S s) ->

50 let (tape, f :: S s) = runForwards Tanh ds

44 let (tape, f :: S s) = runForwards Tanh ds

51 ((), ret :: S s) = runBackwards Tanh tape (1 :: S s)

45 ((), ret :: S s) = runBackwards Tanh tape (1 :: S s)

52 (_, numer :: S s) = runForwards Tanh (ds + 0.0001)

46 (_, numer :: S s) = runForwards Tanh (ds + 0.0001)

53 numericalGradient = (numer - f) * 10000

47 numericalGradient = (numer - f) * 10000

54− in counterexample (show numericalGradient ++ show ret)

55− ((case numericalGradient - ret of

48+ in assert ((case numericalGradient - ret of

56 (S1D x) -> norm_Inf x < 0.001

49 (S1D x) -> norm_Inf x < 0.001

57 (S2D x) -> norm_Inf x < 0.001

50 (S2D x) -> norm_Inf x < 0.001

58 (S3D x) -> norm_Inf x < 0.001) :: Bool)

51 (S3D x) -> norm_Inf x < 0.001) :: Bool)

59

52

60−prop_softmax_grad :: Property

61−prop_softmax_grad =

62− gamble genNat $ \case

63− (SomeNat (_ :: Proxy s)) ->

64− gamble genOfShape $ \(ds :: S ('D1 s)) ->

65− let (tape, f :: S ('D1 s)) = runForwards Relu ds

66− ((), ret :: S ('D1 s)) = runBackwards Relu tape (1 :: S ('D1 s))

67− (_, numer :: S ('D1 s)) = runForwards Relu (ds + 0.0001)

68− numericalGradient = (numer - f) * 10000

69− in counterexample (show numericalGradient ++ show ret)

70− ((case numericalGradient - ret of

71− (S1D x) -> norm_Inf x < 0.0001) :: Bool)

72−

73−

74−return []

75tests :: IO Bool

53tests :: IO Bool

76−tests = $quickCheckAll

54+tests = checkParallel $$(discover)

77−

test/Test/Grenade/Layers/PadCrop.hs+19−10

@@ -7,34 +7,43 @@

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

9

10−#if __GLASGOW_HASKELL__ < 800

11−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

12−#endif

13−

14module Test.Grenade.Layers.PadCrop where

10module Test.Grenade.Layers.PadCrop where

15

11

16import Grenade

12import Grenade

17

13

18−import Disorder.Jack

14+import Hedgehog

19

15

20import Numeric.LinearAlgebra.Static ( norm_Inf )

16import Numeric.LinearAlgebra.Static ( norm_Inf )

21

17

22−import Test.Jack.Hmatrix

18+import Test.Hedgehog.Hmatrix

23

19

24prop_pad_crop :: Property

20prop_pad_crop :: Property

25prop_pad_crop =

21prop_pad_crop =

26 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 ]

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 ]

27 net = Pad :~> Crop :~> NNil

23 net = Pad :~> Crop :~> NNil

24+ in property $

28− in gamble genOfShape $ \(d :: S ('D3 7 9 5)) ->

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)) ->

29 let (tapes, res) = runForwards net d

37 let (tapes, res) = runForwards net d

30 (_ , grad) = runBackwards net tapes d

38 (_ , grad) = runBackwards net tapes d

31− in d ~~~ res .&&. grad ~~~ d

39+ in do assert $ d ~~~ res

40+ assert $ grad ~~~ d

32

41

33(~~~) :: S x -> S x -> Bool

42(~~~) :: S x -> S x -> Bool

34(S1D x) ~~~ (S1D y) = norm_Inf (x - y) < 0.00001

43(S1D x) ~~~ (S1D y) = norm_Inf (x - y) < 0.00001

35(S2D x) ~~~ (S2D y) = norm_Inf (x - y) < 0.00001

44(S2D x) ~~~ (S2D y) = norm_Inf (x - y) < 0.00001

36(S3D x) ~~~ (S3D y) = norm_Inf (x - y) < 0.00001

45(S3D x) ~~~ (S3D y) = norm_Inf (x - y) < 0.00001

37

46

38−return []

47+

39tests :: IO Bool

48tests :: IO Bool

40−tests = $quickCheckAll

49+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Pooling.hs+19−14

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE KindSignatures #-}

4{-# LANGUAGE KindSignatures #-}

@@ -9,36 +10,40 @@ module Test.Grenade.Layers.Pooling where

9import Data.Proxy

10import Data.Proxy

10import Data.Singletons ()

11import Data.Singletons ()

11

12

13+#if MIN_VERSION_base(4,9,0)

14+import Data.Kind (Type)

15+#endif

16+

12import GHC.TypeLits

17import GHC.TypeLits

13import Grenade.Layers.Pooling

18import Grenade.Layers.Pooling

14

19

15−import Disorder.Jack

20+import Hedgehog

16

21

22+import Test.Hedgehog.Compat

17

23

18−data OpaquePooling :: * where

24+data OpaquePooling :: Type where

19 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

25 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

20

26

21instance Show OpaquePooling where

27instance Show OpaquePooling where

22 show (OpaquePooling n) = show n

28 show (OpaquePooling n) = show n

23

29

24−genOpaquePooling :: Jack OpaquePooling

30+genOpaquePooling :: Gen OpaquePooling

25genOpaquePooling = do

31genOpaquePooling = do

26− Just kernelHeight <- someNatVal <$> choose (2, 15)

32+ ~(Just kernelHeight) <- someNatVal <$> choose 2 15

27− Just kernelWidth <- someNatVal <$> choose (2, 15)

33+ ~(Just kernelWidth ) <- someNatVal <$> choose 2 15

28− Just strideHeight <- someNatVal <$> choose (2, 15)

34+ ~(Just strideHeight) <- someNatVal <$> choose 2 15

29− Just strideWidth <- someNatVal <$> choose (2, 15)

35+ ~(Just strideWidth ) <- someNatVal <$> choose 2 15

30

36

31 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

37 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

32 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

38 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

33 return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)

39 return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)

34

40

35prop_pool_layer_witness =

41prop_pool_layer_witness =

42+ property $ do

36− gamble genOpaquePooling $ \onet ->

43+ onet <- forAll genOpaquePooling

37− (case onet of

44+ case onet of

38− (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) -> True

45+ (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) ->

39− ) :: Bool

46+ assert True

40−

41

47

42−return []

43tests :: IO Bool

48tests :: IO Bool

44−tests = $quickCheckAll

49+tests = checkParallel $$(discover)

test/Test/Grenade/Network.hsnew file+504

@@ -0,0 +1,504 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE TypeOperators #-}

9+{-# LANGUAGE TemplateHaskell #-}

10+{-# LANGUAGE FlexibleContexts #-}

11+module Test.Grenade.Network where

12+

13+import Control.Monad ( guard )

14+import Control.Monad.ST ( runST )

15+

16+import Data.Constraint

17+import qualified Data.Vector.Storable as VS

18+import qualified Data.Vector.Storable.Mutable as VS ( write )

19+import Data.Singletons

20+import Data.Singletons.Prelude.List

21+import Data.Singletons.TypeLits

22+

23+import Hedgehog

24+import qualified Hedgehog.Gen as Gen

25+import Hedgehog.Internal.Source

26+import Hedgehog.Internal.Property ( failWith )

27+

28+import Grenade

29+

30+#if MIN_VERSION_base(4,11,0)

31+import GHC.TypeLits hiding (natVal)

32+#else

33+import GHC.TypeLits

34+#endif

35+#if MIN_VERSION_base(4,9,0)

36+import Data.Kind (Type)

37+#endif

38+

39+import GHC.TypeLits.Witnesses

40+import Test.Hedgehog.Compat

41+import Test.Hedgehog.TypeLits

42+import Test.Hedgehog.Hmatrix

43+import Test.Grenade.Layers.Convolution

44+

45+import Numeric.LinearAlgebra ( flatten )

46+import Numeric.LinearAlgebra.Static ( extract, norm_Inf )

47+import Unsafe.Coerce

48+

49+data SomeNetwork :: Type where

50+ SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork

51+

52+instance Show SomeNetwork where

53+ show (SomeNetwork net) = show net

54+

55+-- | Generate a random network of a random type

56+--

57+-- This is slightly insane for a few reasons. Everything must be wrapped up

58+-- in a SomeNetwork.

59+genNetwork :: Gen SomeNetwork

60+genNetwork =

61+ Gen.recursive Gen.choice [

62+ do SomeSing ( r :: Sing final ) <- genShape

63+ withSingI r $

64+ pure (SomeNetwork (NNil :: Network '[] '[ final ] ))

65+ ] [

66+ do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork

67+ case ( sing :: Sing shapes ) of

68+ SNil -> Gen.discard -- Can't occur

69+ SCons ( h :: Sing h ) ( _ :: Sing hs ) ->

70+ withSingI h $

71+ case h of

72+ D1Sing l@SNat ->

73+ Gen.choice [

74+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

75+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

76+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

77+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

78+ , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))

79+ , do -- Reshape to two dimensions

80+ let divisors :: Integer -> [Integer]

81+ divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]

82+ let len = fromIntegral $ natVal l

83+ rs <- Gen.element $ divisors len

84+ let cs = len `quot` rs

85+ case ( someNatVal rs, someNatVal cs, someNatVal len ) of

86+ ( Just (SomeNat (rs' :: Proxy inRows)), Just (SomeNat (cs' :: Proxy inCols)), Just (SomeNat (_ :: Proxy outLen ) )) ->

87+ let p1 = natDict rs'

88+ p2 = natDict cs'

89+ in case ( p1 %* p2, unsafeCoerce (Dict :: Dict ()) :: Dict ((inRows * inCols) ~ outLen), unsafeCoerce (Dict :: Dict ()) :: Dict (( 'D1 outLen ) ~ h )) of

90+ ( Dict, Dict, Dict ) ->

91+ pure (SomeNetwork (Reshape :~> rest :: Network ( Reshape ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

92+ _ -> Gen.discard -- Doesn't occur

93+ ]

94+ D2Sing r@SNat c@SNat ->

95+ Gen.choice [

96+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

97+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

98+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

99+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

100+ , do -- Build a convolution layer with one filter output

101+ -- Figure out some kernel sizes which work for this layer

102+ -- There must be a better way than this...

103+ let output_r = fromIntegral $ natVal r

104+ let output_c = fromIntegral $ natVal c

105+

106+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

107+

108+ -- Get some kernels which will fit

109+ kernel_r <- choose 1 output_r

110+ kernel_c <- choose 1 output_c

111+

112+ -- Build up some strides which also fit

113+ stride_r <- Gen.element $ ok output_r kernel_r

114+ stride_c <- Gen.element $ ok output_c kernel_c

115+

116+ -- Determine the input size

117+ let input_r = (output_r - 1) * stride_r + kernel_r

118+ let input_c = (output_c - 1) * stride_c + kernel_c

119+

120+ guard (input_r < 100)

121+ guard (input_c < 100)

122+

123+ -- Remake types for input

124+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

125+ ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

126+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

127+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

128+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

129+ let p1 = natDict pkr

130+ p2 = natDict pkc

131+ in case ( p1 %* p2

132+ -- Fake it till you make it.

133+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))

134+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

135+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

136+ (Dict, Dict, Dict, Dict) -> do

137+ conv <- genConvolution

138+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution 1 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

139+ _ -> Gen.discard -- Can't occur

140+ , do -- Build a convolution layer with one filter output

141+ -- Figure out some kernel sizes which work for this layer

142+ -- There must be a better way than this...

143+ let output_r = fromIntegral $ natVal r

144+ let output_c = fromIntegral $ natVal c

145+

146+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

147+

148+ -- Get some kernels which will fit

149+ kernel_r <- choose 1 output_r

150+ kernel_c <- choose 1 output_c

151+ channels <- choose 1 10

152+

153+ -- Build up some strides which also fit

154+ stride_r <- Gen.element $ ok output_r kernel_r

155+ stride_c <- Gen.element $ ok output_c kernel_c

156+

157+ -- Determine the input size

158+ let input_r = (output_r - 1) * stride_r + kernel_r

159+ let input_c = (output_c - 1) * stride_c + kernel_c

160+

161+ guard (input_r < 100)

162+ guard (input_c < 100)

163+

164+ -- Remake types for input

165+ case ( someNatVal channels, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

166+ ( Just (SomeNat (chan :: Proxy channels)),

167+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

168+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

169+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

170+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

171+ let p1 = natDict pkr

172+ p2 = natDict pkc

173+ p3 = natDict chan

174+ in case ( p1 %* p2 %* p3

175+ , natDict pinr %* natDict chan

176+ -- Fake it till you make it.

177+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))

178+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

179+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

180+ (Dict, Dict, Dict, Dict, Dict) -> do

181+ conv <- genConvolution

182+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

183+ _ -> Gen.discard -- Can't occur

184+ , do -- Build a Pooling layer

185+ let output_r = fromIntegral $ natVal r

186+ let output_c = fromIntegral $ natVal c

187+

188+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

189+

190+ -- Get some kernels which will fit

191+ kernel_r <- choose 1 output_r

192+ kernel_c <- choose 1 output_c

193+

194+ -- Build up some strides which also fit

195+ stride_r <- Gen.element $ ok output_r kernel_r

196+ stride_c <- Gen.element $ ok output_c kernel_c

197+

198+ -- Determine the input size

199+ let input_r = (output_r - 1) * stride_r + kernel_r

200+ let input_c = (output_c - 1) * stride_c + kernel_c

201+

202+ guard (input_r < 100)

203+ guard (input_c < 100)

204+

205+ -- Remake types for input

206+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

207+ ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

208+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

209+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

210+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

211+ let p1 = natDict pkr

212+ p2 = natDict pkc

213+ in case ( p1 %* p2

214+ -- Fake it till you make it.

215+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))

216+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

217+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

218+ (Dict, Dict, Dict, Dict) ->

219+ pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

220+ _ -> Gen.discard -- Can't occur

221+ , do -- Build a Pad layer

222+ let output_r = fromIntegral $ natVal r

223+ let output_c = fromIntegral $ natVal c

224+

225+ pad_left <- choose 0 (output_r - 1)

226+ pad_right <- choose 0 (output_r - 1 - pad_left)

227+ pad_top <- choose 0 (output_c - 1)

228+ pad_bottom <- choose 0 (output_c - 1 - pad_top)

229+

230+ let input_r = output_r - pad_top - pad_bottom

231+ let input_c = output_c - pad_left - pad_right

232+

233+ guard (input_r > 1)

234+ guard (input_c > 1)

235+

236+ -- Remake types for input

237+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal pad_left, someNatVal pad_right, someNatVal pad_top, someNatVal pad_bottom ) of

238+ ( Just (SomeNat (_ :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

239+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

240+ Just (SomeNat (_ :: Proxy padLeft)), Just (SomeNat (_ :: Proxy padRight)),

241+ Just (SomeNat (_ :: Proxy padTop)), Just (SomeNat (_ :: Proxy padBottom))) ->

242+ case ( (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outputRows outputColumns) ~ h ))

243+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputRows + padTop + padBottom) ~ outputRows) )

244+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputColumns + padLeft + padRight) ~ outputColumns ))) of

245+ ( Dict, Dict, Dict ) ->

246+ pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D2 inputRows inputColumns) ': h ': hs )))

247+ _ -> Gen.discard -- Can't occur

248+ , do -- Build a Crop layer

249+ let output_r = fromIntegral $ natVal r

250+ let output_c = fromIntegral $ natVal c

251+

252+ crop_left <- choose 0 10

253+ crop_right <- choose 0 10

254+ crop_top <- choose 0 10

255+ crop_bottom <- choose 0 10

256+

257+ let input_r = output_r + crop_top + crop_bottom

258+ let input_c = output_c + crop_left + crop_right

259+

260+ -- Remake types for input

261+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal crop_left, someNatVal crop_right, someNatVal crop_top, someNatVal crop_bottom ) of

262+ ( Just (SomeNat (_ :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

263+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

264+ Just (SomeNat (_ :: Proxy cropLeft)), Just (SomeNat (_ :: Proxy cropRight)),

265+ Just (SomeNat (_ :: Proxy cropTop)), Just (SomeNat (_ :: Proxy cropBottom))) ->

266+ case ( (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outputRows outputColumns) ~ h ))

267+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputRows + cropTop + cropBottom) ~ inputRows ) )

268+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputColumns + cropLeft + cropRight) ~ inputColumns ))) of

269+ (Dict, Dict, Dict) ->

270+ pure (SomeNetwork (Crop :~> rest :: Network ( Crop cropLeft cropTop cropRight cropBottom ': layers ) ( ('D2 inputRows inputColumns) ': h ': hs )))

271+ _ -> Gen.discard -- Can't occur

272+ ]

273+ D3Sing r@SNat c@SNat f@SNat ->

274+ Gen.choice [

275+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

276+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

277+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

278+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

279+ , do -- Build a convolution layer with one filter output

280+ -- Figure out some kernel sizes which work for this layer

281+ -- There must be a better way than this...

282+ let output_r = fromIntegral $ natVal r

283+ let output_c = fromIntegral $ natVal c

284+ let output_f = fromIntegral $ natVal f

285+

286+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

287+

288+ -- Get some kernels which will fit

289+ kernel_r <- choose 1 output_r

290+ kernel_c <- choose 1 output_c

291+ channels <- choose 1 10

292+

293+ -- Build up some strides which also fit

294+ stride_r <- Gen.element $ ok output_r kernel_r

295+ stride_c <- Gen.element $ ok output_c kernel_c

296+

297+ -- Determine the input size

298+ let input_r = (output_r - 1) * stride_r + kernel_r

299+ let input_c = (output_c - 1) * stride_c + kernel_c

300+

301+ guard (input_r < 100)

302+ guard (input_c < 100)

303+

304+ -- Remake types for input

305+ case ( someNatVal channels, someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

306+ ( Just (SomeNat (chan :: Proxy channels)), Just (SomeNat (_ :: Proxy filters)),

307+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

308+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

309+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

310+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

311+ let p1 = natDict pkr

312+ p2 = natDict pkc

313+ p3 = natDict chan

314+ in case ( p1 %* p2 %* p3

315+ , natDict pinr %* natDict chan

316+ -- Fake it till you make it.

317+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outRows outCols filters) ~ h ))

318+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

319+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

320+ (Dict, Dict, Dict, Dict, Dict) -> do

321+ conv <- genConvolution

322+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels filters kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

323+ _ -> Gen.discard -- Can't occur

324+ , do -- Build a Pooling layer

325+ let output_r = fromIntegral $ natVal r

326+ let output_c = fromIntegral $ natVal c

327+ let output_f = fromIntegral $ natVal f

328+

329+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

330+

331+ -- Get some kernels which will fit

332+ kernel_r <- choose 1 output_r

333+ kernel_c <- choose 1 output_c

334+

335+ -- Build up some strides which also fit

336+ stride_r <- Gen.element $ ok output_r kernel_r

337+ stride_c <- Gen.element $ ok output_c kernel_c

338+

339+ -- Determine the input size

340+ let input_r = (output_r - 1) * stride_r + kernel_r

341+ let input_c = (output_c - 1) * stride_c + kernel_c

342+

343+ guard (input_r < 100)

344+ guard (input_c < 100)

345+

346+ -- Remake types for input

347+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

348+ ( Just (SomeNat (chan :: Proxy filters)),

349+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

350+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

351+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

352+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

353+ let p1 = natDict pkr

354+ p2 = natDict pkc

355+ p3 = natDict chan

356+ in case ( p1 %* p2 %* p3

357+ , natDict pinr %* natDict chan

358+ -- Fake it till you make it.

359+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outRows outCols filters) ~ h ))

360+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

361+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

362+ (Dict, Dict, Dict, Dict, Dict) ->

363+ pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols filters) ': h ': hs )))

364+ _ -> Gen.discard -- Can't occur

365+ , do -- Build a Pad layer

366+ let output_r = fromIntegral $ natVal r

367+ let output_c = fromIntegral $ natVal c

368+ let output_f = fromIntegral $ natVal f

369+

370+ pad_left <- choose 0 (output_r - 1)

371+ pad_right <- choose 0 (output_r - 1 - pad_left)

372+ pad_top <- choose 0 (output_c - 1)

373+ pad_bottom <- choose 0 (output_c - 1 - pad_top)

374+

375+ let input_r = output_r - pad_top - pad_bottom

376+ let input_c = output_c - pad_left - pad_right

377+

378+ guard (input_r > 1)

379+ guard (input_c > 1)

380+

381+ -- Remake types for input

382+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal pad_left, someNatVal pad_right, someNatVal pad_top, someNatVal pad_bottom ) of

383+ ( Just (SomeNat (chan :: Proxy filters)),

384+ Just (SomeNat (pinr :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

385+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

386+ Just (SomeNat (_ :: Proxy padLeft)), Just (SomeNat (_ :: Proxy padRight)),

387+ Just (SomeNat (_ :: Proxy padTop)), Just (SomeNat (_ :: Proxy padBottom))) ->

388+ case ( natDict pinr %* natDict chan

389+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outputRows outputColumns filters) ~ h ))

390+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputRows + padTop + padBottom) ~ outputRows) )

391+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputColumns + padLeft + padRight) ~ outputColumns ))) of

392+ (Dict, Dict, Dict, Dict) ->

393+ pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))

394+ _ -> Gen.discard -- Can't occur

395+ , do -- Build a Crop layer

396+ let output_r = fromIntegral $ natVal r

397+ let output_c = fromIntegral $ natVal c

398+ let output_f = fromIntegral $ natVal f

399+

400+ crop_left <- choose 0 10

401+ crop_right <- choose 0 10

402+ crop_top <- choose 0 10

403+ crop_bottom <- choose 0 10

404+

405+ let input_r = output_r + crop_top + crop_bottom

406+ let input_c = output_c + crop_left + crop_right

407+

408+ -- Remake types for input

409+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal crop_left, someNatVal crop_right, someNatVal crop_top, someNatVal crop_bottom ) of

410+ ( Just (SomeNat (chan :: Proxy filters)),

411+ Just (SomeNat (pinr :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

412+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

413+ Just (SomeNat (_ :: Proxy cropLeft)), Just (SomeNat (_ :: Proxy cropRight)),

414+ Just (SomeNat (_ :: Proxy cropTop)), Just (SomeNat (_ :: Proxy cropBottom))) ->

415+ case ( natDict pinr %* natDict chan

416+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outputRows outputColumns filters) ~ h ))

417+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputRows + cropTop + cropBottom) ~ inputRows ) )

418+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputColumns + cropLeft + cropRight) ~ inputColumns ))) of

419+ (Dict, Dict, Dict, Dict) ->

420+ pure (SomeNetwork (Crop :~> rest :: Network ( Crop cropLeft cropTop cropRight cropBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))

421+ _ -> Gen.discard -- Can't occur

422+ ]

423+ ]

424+

425+-- | Test a partial derivative numerically for a random network and input

426+--

427+-- This is the most important test.

428+prop_auto_diff :: Property

429+prop_auto_diff = withDiscards 1000 . withTests 10000 . property $ do

430+ SomeNetwork (network :: Network layers shapes) <- forAll genNetwork

431+ (input :: S (Head shapes)) <- forAllWith nice genOfShape

432+ (target :: S (Last shapes)) <- forAllWith nice oneUp

433+ (tested :: S (Head shapes)) <- forAllWith nice oneUp

434+

435+ let (!tapes, !output) = runNetwork network input

436+ let (_, !backgrad) = runGradient network tapes target

437+ let inputDiff = input + tested * 0.00001

438+ let expected = maxVal ( backgrad * tested )

439+ let (_, !outputDiff) = runNetwork network inputDiff

440+ let result = maxVal ( outputDiff * target - output * target ) / 0.00001

441+

442+ result ~~~ expected

443+

444+-- Make a shape where all are 0 except for 1 value, which is 1.

445+oneUp :: forall shape. ( SingI shape ) => Gen (S shape)

446+oneUp =

447+ case ( sing :: Sing shape ) of

448+ D1Sing SNat ->

449+ let x = 0 :: S ( shape )

450+ in case x of

451+ ( S1D x' ) -> do

452+ let ex = extract x'

453+ let len = VS.length ex

454+ ix <- choose 0 (len - 1)

455+ let nx = runST $ do ex' <- VS.thaw ex

456+ VS.write ex' ix 1.0

457+ VS.freeze ex'

458+ maybe Gen.discard pure . fromStorable $ nx

459+

460+ D2Sing SNat SNat ->

461+ let x = 0 :: S ( shape )

462+ in case x of

463+ ( S2D x' ) -> do

464+ let ex = flatten ( extract x' )

465+ let len = VS.length ex

466+ ix <- choose 0 (len - 1)

467+ let nx = runST $ do ex' <- VS.thaw ex

468+ VS.write ex' ix 1

469+ VS.freeze ex'

470+ maybe Gen.discard pure . fromStorable $ nx

471+

472+ D3Sing SNat SNat SNat ->

473+ let x = 0 :: S ( shape )

474+ in case x of

475+ ( S3D x' ) -> do

476+ let ex = flatten ( extract x' )

477+ let len = VS.length ex

478+ ix <- choose 0 (len - 1)

479+ let nx = runST $ do ex' <- VS.thaw ex

480+ VS.write ex' ix 1

481+ VS.freeze ex'

482+ maybe Gen.discard pure . fromStorable $ nx

483+

484+maxVal :: S shape -> Double

485+maxVal ( S1D x ) = norm_Inf x

486+maxVal ( S2D x ) = norm_Inf x

487+maxVal ( S3D x ) = norm_Inf x

488+

489+(~~~) :: (Monad m, HasCallStack) => Double -> Double -> PropertyT m ()

490+(~~~) x y =

491+ if abs (x - y) < 2e-5 then

492+ success

493+ else

494+ withFrozenCallStack $

495+ failWith Nothing $ unlines [

496+ "━━━ Not Simliar ━━━"

497+ , show x

498+ , show y

499+ ]

500+infix 4 ~~~

501+

502+

503+tests :: IO Bool

504+tests = checkParallel $$(discover)

test/Test/Grenade/Recurrent/Layers/LSTM.hs+83−54

@@ -10,7 +10,10 @@

10{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

11module Test.Grenade.Recurrent.Layers.LSTM where

12

13−import Disorder.Jack

13+import Hedgehog

14+import Hedgehog.Internal.Source

15+import Hedgehog.Internal.Show

16+import Hedgehog.Internal.Property ( failWith, Diff (..) )

14

17

15import Data.Foldable ( toList )

18import Data.Foldable ( toList )

16import Data.Singletons.TypeLits

19import Data.Singletons.TypeLits

@@ -23,9 +26,9 @@ import qualified Numeric.LinearAlgebra.Static as S

23

26

24

27

25import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

28import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

26−import Test.Jack.Hmatrix

29+import Test.Hedgehog.Hmatrix

27

30

28−genLSTM :: forall i o. (KnownNat i, KnownNat o) => Jack (LSTM i o)

31+genLSTM :: forall i o. (KnownNat i, KnownNat o) => Gen (LSTM i o)

29genLSTM = do

32genLSTM = do

30 let w = uniformSample

33 let w = uniformSample

31 u = uniformSample

34 u = uniformSample

@@ -39,63 +42,89 @@ genLSTM = do

39 <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

42 <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

40

43

41prop_lstm_reference_forwards =

44prop_lstm_reference_forwards =

42− gamble randomVector $ \(input :: S.R 3) ->

45+ property $ do

43− gamble randomVector $ \(cell :: S.R 2) ->

46+ input :: S.R 3 <- forAll randomVector

44− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

47+ cell :: S.R 2 <- forAll randomVector

48+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

49+

45− let actual = runRecurrentForwards net (S1D cell) (S1D input)

50+ let actual = runRecurrentForwards net (S1D cell) (S1D input)

46− in case actual of

51+ case actual of

47− (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->

52+ (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->

48− let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut

53+ let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut

49− output' = Reference.Vector . H.toList . S.extract $ output

54+ output' = Reference.Vector . H.toList . S.extract $ output

50− refNet = Reference.lstmToReference lstmWeights

55+ refNet = Reference.lstmToReference lstmWeights

51− refCell = Reference.Vector . H.toList . S.extract $ cell

56+ refCell = Reference.Vector . H.toList . S.extract $ cell

52− refInput = Reference.Vector . H.toList . S.extract $ input

57+ refInput = Reference.Vector . H.toList . S.extract $ input

53− (refCO, refO) = Reference.runLSTM refNet refCell refInput

58+ (refCO, refO) = Reference.runLSTM refNet refCell refInput

54− in toList refCO ~~~ toList cellOut' .&&. toList refO ~~~ toList output'

59+ in do toList refCO ~~~ toList cellOut'

60+ toList refO ~~~ toList output'

61+

55

62

56prop_lstm_reference_backwards =

63prop_lstm_reference_backwards =

57− gamble randomVector $ \(input :: S.R 3) ->

64+ property $ do

58− gamble randomVector $ \(cell :: S.R 2) ->

65+ input :: S.R 3 <- forAll randomVector

59− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

66+ cell :: S.R 2 <- forAll randomVector

67+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

68+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

69+ = runRecurrentForwards net (S1D cell) (S1D input)

60− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

70+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

61− in case actualBacks of

71+ case actualBacks of

62− (actualGradients, _, _ :: S ('D1 3)) ->

72+ (actualGradients, _, _ :: S ('D1 3)) ->

63− let refNet = Reference.lstmToReference lstmWeights

73+ let refNet = Reference.lstmToReference lstmWeights

64− refCell = Reference.Vector . H.toList . S.extract $ cell

74+ refCell = Reference.Vector . H.toList . S.extract $ cell

65− refInput = Reference.Vector . H.toList . S.extract $ input

75+ refInput = Reference.Vector . H.toList . S.extract $ input

66− refGradients = Reference.runLSTMback refCell refInput refNet

76+ refGradients = Reference.runLSTMback refCell refInput refNet

67− in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)

77+ in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)

68

78

69prop_lstm_reference_backwards_input =

79prop_lstm_reference_backwards_input =

70− gamble randomVector $ \(input :: S.R 3) ->

80+ property $ do

71− gamble randomVector $ \(cell :: S.R 2) ->

81+ input :: S.R 3 <- forAll randomVector

72− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

82+ cell :: S.R 2 <- forAll randomVector

83+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

84+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

85+ = runRecurrentForwards net (S1D cell) (S1D input)

73− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

86+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

74− in case actualBacks of

87+ case actualBacks of

75− (_, _, S1D actualGradients :: S ('D1 3)) ->

88+ (_, _, S1D actualGradients :: S ('D1 3)) ->

76− let refNet = Reference.lstmToReference lstmWeights

89+ let refNet = Reference.lstmToReference lstmWeights

77− refCell = Reference.Vector . H.toList . S.extract $ cell

90+ refCell = Reference.Vector . H.toList . S.extract $ cell

78− refInput = Reference.Vector . H.toList . S.extract $ input

91+ refInput = Reference.Vector . H.toList . S.extract $ input

79− refGradients = Reference.runLSTMbackOnInput refCell refNet refInput

92+ refGradients = Reference.runLSTMbackOnInput refCell refNet refInput

80− in toList refGradients ~~~ H.toList (S.extract actualGradients)

93+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

81

94

82prop_lstm_reference_backwards_cell =

95prop_lstm_reference_backwards_cell =

83− gamble randomVector $ \(input :: S.R 3) ->

96+ property $ do

84− gamble randomVector $ \(cell :: S.R 2) ->

97+ input :: S.R 3 <- forAll randomVector

85− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

98+ cell :: S.R 2 <- forAll randomVector

99+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

100+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

101+ = runRecurrentForwards net (S1D cell) (S1D input)

86− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

102+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

87− in case actualBacks of

103+ case actualBacks of

88− (_, S1D actualGradients, _ :: S ('D1 3)) ->

104+ (_, S1D actualGradients, _ :: S ('D1 3)) ->

89− let refNet = Reference.lstmToReference lstmWeights

105+ let refNet = Reference.lstmToReference lstmWeights

90− refCell = Reference.Vector . H.toList . S.extract $ cell

106+ refCell = Reference.Vector . H.toList . S.extract $ cell

91− refInput = Reference.Vector . H.toList . S.extract $ input

107+ refInput = Reference.Vector . H.toList . S.extract $ input

92− refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

108+ refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

93− in toList refGradients ~~~ H.toList (S.extract actualGradients)

109+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

94−

110+

95−

111+(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> PropertyT m ()

112+(~~~) x y =

96−(~~~) as bs = all (< 1e-8) (zipWith (-) as bs)

113+ if all (< 1e-8) (zipWith (-) x y) then

114+ success

115+ else

116+ case valueDiff <$> mkValue x <*> mkValue y of

117+ Nothing ->

118+ withFrozenCallStack $

119+ failWith Nothing $ unlines [

120+ "━━━ Not Simliar ━━━"

121+ , showPretty x

122+ , showPretty y

123+ ]

124+ Just differ ->

125+ withFrozenCallStack $

126+ failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" differ) ""

97infix 4 ~~~

127infix 4 ~~~

98

128

99−return []

100tests :: IO Bool

129tests :: IO Bool

101−tests = $quickCheckAll

130+tests = checkParallel $$(discover)

test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+25−21

@@ -6,7 +6,6 @@

6{-# LANGUAGE DeriveFunctor #-}

7{-# LANGUAGE DeriveFoldable #-}

8{-# LANGUAGE DeriveTraversable #-}

9−{-# LANGUAGE RecordWildCards #-}

10{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE FlexibleContexts #-}

11{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RankNTypes #-}

12

11

@@ -15,9 +14,13 @@ module Test.Grenade.Recurrent.Layers.LSTM.Reference where

15

14

16import Data.Reflection

15import Data.Reflection

17import Numeric.AD.Mode.Reverse

16import Numeric.AD.Mode.Reverse

18−import Numeric.AD.Internal.Reverse ( Tape )

17+import Numeric.AD.Internal.Reverse (Tape)

19

18

19+import GHC.TypeLits (KnownNat)

20+

21+import Grenade.Recurrent.Layers.LSTM (LSTMWeights (..))

20import qualified Grenade.Recurrent.Layers.LSTM as LSTM

22import qualified Grenade.Recurrent.Layers.LSTM as LSTM

23+

21import qualified Numeric.LinearAlgebra.Static as S

24import qualified Numeric.LinearAlgebra.Static as S

22import qualified Numeric.LinearAlgebra as H

25import qualified Numeric.LinearAlgebra as H

23

26

@@ -54,31 +57,32 @@ data RefLSTM a = RefLSTM

54 , refLstmBc :: Vector a -- Bias Cell (b_c)

57 , refLstmBc :: Vector a -- Bias Cell (b_c)

55 } deriving (Functor, Foldable, Traversable, Eq, Show)

58 } deriving (Functor, Foldable, Traversable, Eq, Show)

56

59

57−lstmToReference :: LSTM.LSTMWeights a b -> RefLSTM Double

60+lstmToReference :: (KnownNat a, KnownNat b) => LSTM.LSTMWeights a b -> RefLSTM Double

58−lstmToReference LSTM.LSTMWeights {..} =

61+lstmToReference lw =

62+ RefLSTM

59− let refLstmWf = Matrix . H.toLists . S.extract $ lstmWf -- Weight Forget (W_f)

63+ { refLstmWf = Matrix . H.toLists . S.extract $ lstmWf lw -- Weight Forget (W_f)

60− refLstmUf = Matrix . H.toLists . S.extract $ lstmUf -- Cell State Forget (U_f)

64+ , refLstmUf = Matrix . H.toLists . S.extract $ lstmUf lw -- Cell State Forget (U_f)

61− refLstmBf = Vector . H.toList . S.extract $ lstmBf -- Bias Forget (b_f)

65+ , refLstmBf = Vector . H.toList . S.extract $ lstmBf lw -- Bias Forget (b_f)

62− refLstmWi = Matrix . H.toLists . S.extract $ lstmWi -- Weight Input (W_i)

66+ , refLstmWi = Matrix . H.toLists . S.extract $ lstmWi lw -- Weight Input (W_i)

63− refLstmUi = Matrix . H.toLists . S.extract $ lstmUi -- Cell State Input (U_i)

67+ , refLstmUi = Matrix . H.toLists . S.extract $ lstmUi lw -- Cell State Input (U_i)

64− refLstmBi = Vector . H.toList . S.extract $ lstmBi -- Bias Input (b_i)

68+ , refLstmBi = Vector . H.toList . S.extract $ lstmBi lw -- Bias Input (b_i)

65− refLstmWo = Matrix . H.toLists . S.extract $ lstmWo -- Weight Output (W_o)

69+ , refLstmWo = Matrix . H.toLists . S.extract $ lstmWo lw -- Weight Output (W_o)

66− refLstmUo = Matrix . H.toLists . S.extract $ lstmUo -- Cell State Output (U_o)

70+ , refLstmUo = Matrix . H.toLists . S.extract $ lstmUo lw -- Cell State Output (U_o)

67− refLstmBo = Vector . H.toList . S.extract $ lstmBo -- Bias Output (b_o)

71+ , refLstmBo = Vector . H.toList . S.extract $ lstmBo lw -- Bias Output (b_o)

68− refLstmWc = Matrix . H.toLists . S.extract $ lstmWc -- Weight Cell (W_c)

72+ , refLstmWc = Matrix . H.toLists . S.extract $ lstmWc lw -- Weight Cell (W_c)

69− refLstmBc = Vector . H.toList . S.extract $ lstmBc -- Bias Cell (b_c)

73+ , refLstmBc = Vector . H.toList . S.extract $ lstmBc lw -- Bias Cell (b_c)

70− in RefLSTM {..}

74+ }

71

75

72runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

76runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

73−runLSTM RefLSTM {..} cell input =

77+runLSTM rl cell input =

74 let -- Forget state vector

78 let -- Forget state vector

75− f_t = sigmoid $ refLstmBf #+ refLstmWf #> input #+ refLstmUf #> cell

79+ f_t = sigmoid $ refLstmBf rl #+ refLstmWf rl #> input #+ refLstmUf rl #> cell

76 -- Input state vector

80 -- Input state vector

77− i_t = sigmoid $ refLstmBi #+ refLstmWi #> input #+ refLstmUi #> cell

81+ i_t = sigmoid $ refLstmBi rl #+ refLstmWi rl #> input #+ refLstmUi rl #> cell

78 -- Output state vector

82 -- Output state vector

79− o_t = sigmoid $ refLstmBo #+ refLstmWo #> input #+ refLstmUo #> cell

83+ o_t = sigmoid $ refLstmBo rl #+ refLstmWo rl #> input #+ refLstmUo rl #> cell

80 -- Cell input state vector

84 -- Cell input state vector

81− c_x = fmap tanh $ refLstmBc #+ refLstmWc #> input

85+ c_x = fmap tanh $ refLstmBc rl #+ refLstmWc rl #> input

82 -- Cell state

86 -- Cell state

83 c_t = f_t #* cell #+ i_t #* c_x

87 c_t = f_t #* cell #+ i_t #* c_x

84 -- Output (it's sometimes recommended to use tanh c_t)

88 -- Output (it's sometimes recommended to use tanh c_t)

test/Test/Hedgehog/Compat.hsnew file+21

@@ -0,0 +1,21 @@

1+{-# LANGUAGE RankNTypes #-}

2+module Test.Hedgehog.Compat (

3+ (...)

4+ , choose

5+ , blindForAll

6+ )where

7+

8+import Hedgehog (Gen)

9+import qualified Hedgehog.Gen as Gen

10+import qualified Hedgehog.Range as Range

11+import Hedgehog.Internal.Property

12+

13+(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

14+(...) = (.) . (.)

15+{-# INLINE (...) #-}

16+

17+choose :: Integral a => a -> a -> Gen a

18+choose = Gen.integral ... Range.constant

19+

20+blindForAll :: Monad m => Gen a -> PropertyT m a

21+blindForAll = forAllWith (const "blind")

test/Test/Hedgehog/Hmatrix.hsnew file+42

@@ -0,0 +1,42 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+

7+module Test.Hedgehog.Hmatrix where

8+

9+import Grenade

10+import Data.Singletons

11+import Data.Singletons.TypeLits

12+

13+import Hedgehog (Gen)

14+import qualified Hedgehog.Gen as Gen

15+import qualified Hedgehog.Range as Range

16+

17+import qualified Numeric.LinearAlgebra.Static as HStatic

18+

19+randomVector :: forall n. ( KnownNat n ) => Gen (HStatic.R n)

20+randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded

21+

22+uniformSample :: forall m n. ( KnownNat m, KnownNat n ) => Gen (HStatic.L m n)

23+uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded

24+

25+-- | Generate random data of the desired shape

26+genOfShape :: forall x. ( SingI x ) => Gen (S x)

27+genOfShape =

28+ case (sing :: Sing x) of

29+ D1Sing l ->

30+ withKnownNat l $

31+ S1D <$> randomVector

32+ D2Sing r c ->

33+ withKnownNat r $ withKnownNat c $

34+ S2D <$> uniformSample

35+ D3Sing r c d ->

36+ withKnownNat r $ withKnownNat c $ withKnownNat d $

37+ S3D <$> uniformSample

38+

39+nice :: S shape -> String

40+nice (S1D x) = show . HStatic.extract $ x

41+nice (S2D x) = show . HStatic.extract $ x

42+nice (S3D x) = show . HStatic.extract $ x

test/Test/Hedgehog/TypeLits.hsnew file+65

@@ -0,0 +1,65 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE RankNTypes #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE GADTs #-}

8+module Test.Hedgehog.TypeLits where

9+

10+import Data.Constraint (Dict (..))

11+import Data.Singletons (Proxy (..), Sing (..), SomeSing (..), sing)

12+#if MIN_VERSION_singletons(2,6,0)

13+import Data.Singletons.TypeLits (SNat (..))

14+#endif

15+

16+import Hedgehog (Gen)

17+import qualified Hedgehog.Gen as Gen

18+

19+import Grenade

20+

21+import GHC.TypeLits (SomeNat (..), natVal, someNatVal)

22+import GHC.TypeLits.Witnesses ((%*), natDict)

23+import Test.Hedgehog.Compat (choose)

24+

25+genNat :: Gen SomeNat

26+genNat = do

27+ ~(Just n) <- someNatVal <$> choose 1 10

28+ return n

29+

30+genShape :: Gen (SomeSing Shape)

31+genShape

32+ = Gen.choice [

33+ genD1

34+ , genD2

35+ , genD3

36+ ]

37+

38+genD1 :: Gen (SomeSing Shape)

39+genD1 = do

40+ n <- genNat

41+ return $ case n of

42+ SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

43+

44+genD2 :: Gen (SomeSing Shape)

45+genD2 = do

46+ n <- genNat

47+ m <- genNat

48+ return $ case (n, m) of

49+ (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

50+

51+genD3 :: Gen (SomeSing Shape)

52+genD3 = do

53+ n <- genNat

54+ m <- genNat

55+ o <- genNat

56+ return $ case (n, m, o) of

57+ (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->

58+ case natDict px %* natDict pz of

59+ Dict -> SomeSing (sing :: Sing ('D3 x y z))

60+

61+rss :: SomeSing Shape -> String

62+rss (SomeSing (r :: Sing s)) = case r of

63+ (D1Sing a@SNat) -> "D1 " ++ show (natVal a)

64+ (D2Sing a@SNat b@SNat) -> "D2 " ++ show (natVal a) ++ " " ++ show (natVal b)

65+ (D3Sing a@SNat b@SNat c@SNat) -> "D3 " ++ show (natVal a) ++ " " ++ show (natVal b) ++ " " ++ show (natVal c)

test/Test/Jack/Hmatrix.hsdeleted−29

@@ -1,29 +0,0 @@

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.hsdeleted−60

@@ -1,60 +0,0 @@

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−#if __GLASGOW_HASKELL__ < 800

26−type Shape' = ('KProxy :: KProxy Shape)

27−#else

28−type Shape' = Shape

29−#endif

30−

31−genShape :: Jack (SomeSing Shape')

32−genShape

33− = oneOf [

34− genD1

35− , genD2

36− , genD3

37− ]

38−

39−genD1 :: Jack (SomeSing Shape')

40−genD1 = do

41− n <- genNat

42− return $ case n of

43− SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

44−

45−genD2 :: Jack (SomeSing Shape')

46−genD2 = do

47− n <- genNat

48− m <- genNat

49− return $ case (n, m) of

50− (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

51−

52−genD3 :: Jack (SomeSing Shape')

53−genD3 = do

54− n <- genNat

55− m <- genNat

56− o <- genNat

57− return $ case (n, m, o) of

58− (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->

59− case natDict px %* natDict pz of

60− Dict -> SomeSing (sing :: Sing ('D3 x y z))

test/test.hs+22−2

@@ -1,4 +1,6 @@

1−import Disorder.Core.Main

1+import Control.Monad

2+

3+import qualified Test.Grenade.Network

2

4

3import qualified Test.Grenade.Layers.Pooling

5import qualified Test.Grenade.Layers.Pooling

4import qualified Test.Grenade.Layers.Convolution

6import qualified Test.Grenade.Layers.Convolution

@@ -11,10 +13,15 @@ import qualified Test.Grenade.Layers.Internal.Pooling

11

13

12import qualified Test.Grenade.Recurrent.Layers.LSTM

14import qualified Test.Grenade.Recurrent.Layers.LSTM

13

15

16+import System.Exit

17+import System.IO

18+

14main :: IO ()

19main :: IO ()

15main =

20main =

16 disorderMain [

21 disorderMain [

22+ Test.Grenade.Network.tests

23+

17− Test.Grenade.Layers.Pooling.tests

24+ , Test.Grenade.Layers.Pooling.tests

18 , Test.Grenade.Layers.Convolution.tests

25 , Test.Grenade.Layers.Convolution.tests

19 , Test.Grenade.Layers.FullyConnected.tests

26 , Test.Grenade.Layers.FullyConnected.tests

20 , Test.Grenade.Layers.Nonlinear.tests

27 , Test.Grenade.Layers.Nonlinear.tests

@@ -24,4 +31,17 @@ main =

24 , Test.Grenade.Layers.Internal.Pooling.tests

31 , Test.Grenade.Layers.Internal.Pooling.tests

25

32

26 , Test.Grenade.Recurrent.Layers.LSTM.tests

33 , Test.Grenade.Recurrent.Layers.LSTM.tests

34+

27 ]

35 ]

36+

37+disorderMain :: [IO Bool] -> IO ()

38+disorderMain tests = do

39+ lineBuffer

40+ rs <- sequence tests

41+ unless (and rs) exitFailure

42+

43+

44+lineBuffer :: IO ()

45+lineBuffer = do

46+ hSetBuffering stdout LineBuffering

47+ hSetBuffering stderr LineBuffering