git.iko.soy/grenade
on master help sign in
swap
afb9f9b98 ahead, 0 behind
75 files changed+2862−1209
since splitsnapshots
unifiedsplit
.gitignore+3−1 .gitmodules−15 .travis.yml+12−14 LICENSE+1−1 README.md+57−6 bench/bench-lstm.hs+4−45 cbits/gradient_decent.c → cbits/gradient_descent.c+3−3 cbits/gradient_decent.h → cbits/gradient_descent.h+1−1 examples/LICENSE+10 examples/grenade-examples.cabal+109 examples/mafia+62 main/feedforward.hs → examples/main/feedforward.hs+3−1 main/gan-mnist.hs → examples/main/gan-mnist.hs+28−10 main/mnist.hs → examples/main/mnist.hs+29−2 main/recurrent.hs → examples/main/recurrent.hs+10−10 main/shakespeare.hs → examples/main/shakespeare.hs+26−23 framework/mafia+62 grenade.cabal+106−142 lib/disorder.hs−1 lib/p−1 mafia+1−123 src/Grenade.hs+50−20 src/Grenade/Core.hs+10−5 src/Grenade/Core/Layer.hs+25−4 src/Grenade/Core/LearningParameters.hs+11 src/Grenade/Core/Network.hs+17−16 src/Grenade/Core/Runner.hs+4−6 src/Grenade/Core/Shape.hs+58−32 src/Grenade/Layers.hs+35 src/Grenade/Layers/Concat.hs+17−3 src/Grenade/Layers/Convolution.hs+89−62 src/Grenade/Layers/Crop.hs+19−4 src/Grenade/Layers/Deconvolution.hs+285 src/Grenade/Layers/Elu.hs+10−3 src/Grenade/Layers/FullyConnected.hs+7−8 src/Grenade/Layers/Inception.hs+32−13 src/Grenade/Layers/Internal/Update.hs+12−12 src/Grenade/Layers/Logit.hs+23−9 src/Grenade/Layers/Merge.hs+13−2 src/Grenade/Layers/Pad.hs+16−4 src/Grenade/Layers/Pooling.hs+14−3 src/Grenade/Layers/Relu.hs+7 src/Grenade/Layers/Reshape.hs+11−4 src/Grenade/Layers/Sinusoid.hs+39 src/Grenade/Layers/Softmax.hs+11 src/Grenade/Layers/Tanh.hs+10−3 src/Grenade/Layers/Trivial.hs+14−3 src/Grenade/Recurrent.hs+26−6 src/Grenade/Recurrent/Core.hs+6−3 src/Grenade/Recurrent/Core/Layer.hs+9−6 src/Grenade/Recurrent/Core/Network.hs+122−122 src/Grenade/Recurrent/Core/Runner.hs+54−39 src/Grenade/Recurrent/Layers.hs+9 src/Grenade/Recurrent/Layers/BasicRecurrent.hs+9−13 src/Grenade/Recurrent/Layers/ConcatRecurrent.hs+180 src/Grenade/Recurrent/Layers/LSTM.hs+57−86 src/Grenade/Utils/OneHot.hs+6−5 stack.yaml+78 stack.yaml.lock+19 test/Test/Grenade/Layers/Convolution.hs+29−24 test/Test/Grenade/Layers/FullyConnected.hs+21−17 test/Test/Grenade/Layers/Internal/Convolution.hs+34−29 test/Test/Grenade/Layers/Internal/Pooling.hs+24−18 test/Test/Grenade/Layers/Nonlinear.hs+13−36 test/Test/Grenade/Layers/PadCrop.hs+19−10 test/Test/Grenade/Layers/Pooling.hs+19−14 test/Test/Grenade/Network.hs+504 test/Test/Grenade/Recurrent/Layers/LSTM.hs+83−54 test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+25−21 test/Test/Hedgehog/Compat.hs+21 test/Test/Hedgehog/Hmatrix.hs+42 test/Test/Hedgehog/TypeLits.hs+65 test/Test/Jack/Hmatrix.hs−29 test/Test/Jack/TypeLits.hs−60 test/test.hs+22−2
.gitignore+3−1
@@ -1,4 +1,6 @@
1+cabal.project.local
12.cabal-sandbox/
23cabal.sandbox.config
34dist/
4−
5+dist-newstyle/
6+.stack-work/
.gitmodulesdeleted−15
@@ -1,15 +0,0 @@
1−[submodule "lib/disorder"]
2− path = lib/disorder
3− url = https://github.com/ambiata/disorder.hs
4−[submodule "lib/x"]
5− path = lib/x
6− url = https://github.com/ambiata/x.git
7−[submodule "lib/p"]
8− path = lib/p
9− url = https://github.com/ambiata/p
10−[submodule "lib/disorder.hs"]
11− path = lib/disorder.hs
12− url = https://github.com/ambiata/disorder.hs.git
13−[submodule "lib/hmatrix"]
14− path = lib/hmatrix
15− url = https://github.com/albertoruiz/hmatrix.git
.travis.yml+12−14
@@ -2,32 +2,30 @@
22
33# 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.
44env:
5− - CABALVER=1.22 GHCVER=7.10.3
6− - CABALVER=1.24 GHCVER=8.0.1
5+ - GHCVER=8.0.2
6+ - GHCVER=8.2.2
7+ - GHCVER=8.4.4
8+ - GHCVER=8.6.5
9+ - GHCVER=8.8.3
10+ - GHCVER=8.10.1
711
812# Note: the distinction between `before_install` and `install` is not important.
913before_install:
1014 - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
1115 - 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
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
16+ - travis_retry sudo apt-get install cabal-install-3.2 ghc-$GHCVER libblas-dev liblapack-dev
17+ - export PATH=/opt/cabal/bin:/opt/ghc/$GHCVER/bin:$PATH
1418
1519install:
16− - cabal --version
1720 - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
18− - travis_retry cabal 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
21+ - travis_retry cabal-3.2 update
2522
2623notifications:
2724 email: false
2825
2926# 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.
3027script:
31− - cabal build
32− - cabal test --show-details=streaming
28+ - cabal-3.2 configure --enable-tests
29+ - cabal-3.2 build all
30+ - cabal-3.2 test --test-show-details=direct -j1
3331
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2016, Huw Campbell
1+Copyright (c) 2016-2017, Huw Campbell
22All rights reserved.
33
44Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
README.md+57−6
@@ -2,6 +2,9 @@ Grenade
22=======
33
44[![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+
58
69```
710First 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.
1215
1316💣 Machine learning which might blow up in your face 💣
1417
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
1619for concise and precise specifications of complex networks in Haskell.
1720
1821As 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
2023```haskell
2124type MNIST
2225 = Network
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]
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]
26+ '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Relu
27+ , Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Reshape, Relu
28+ , FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]
29+ '[ 'D2 28 28, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10
30+ , 'D3 8 8 16, 'D3 4 4 16, 'D1 256, 'D1 256
31+ , 'D1 80, 'D1 80, 'D1 10, 'D1 10]
2532
2633randomMnist :: MonadRandom m => m MNIST
2734randomMnist = randomNetwork
@@ -82,7 +89,7 @@ backPropagate :: forall shapes layers.
8289```
8390which takes a network, appropriate input and target data, and returns the
8491back 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
8693have no learnable parameters.
8794
8895The 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
96103and a layer can not sensibly perform the operation between two shapes, then
97104it will result in a compile time error.
98105
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+
99145Build Instructions
100146------------------
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)
102148script that is located in the repository. You will also need the `lapack` and
103149`blas` libraries and development tools. Once you have all that, Grenade can be
104150build using:
@@ -113,7 +159,7 @@ and the tests run using:
113159./mafia test
114160```
115161
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.
117163
118164Thanks
119165------
@@ -139,3 +185,8 @@ core took around 12 minutes, achieving 1.5% error rate on a 1000 sample holdout
139185Contributing
140186------------
141187Contributions 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
55
66import Grenade
77import Grenade.Recurrent
8−import Grenade.Layers.Internal.Update
9−
10−import qualified Numeric.LinearAlgebra.Static as H
118
129main :: IO ()
1310main = do
14− layer60 :: LSTM 40 60 <- createRandom
15− layer512 :: LSTM 40 512 <- createRandom
1611 input40 :: S ('D1 40) <- randomOfShape
17− rec60 :: S ('D1 60) <- randomOfShape
18− rec512 :: S ('D1 512) <- randomOfShape
19− (lstm, lstm') :: (RecNet, RecInput) <- randomRecurrent
20−
21− let upIn60 :: H.R 3600 = H.randomVector 1 H.Uniform * 2 - 1
22− let upIn512 :: H.R 262144 = H.randomVector 1 H.Uniform * 2 - 1
12+ lstm :: RecNet <- randomRecurrent
2313
2414 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)]
34− , bench "ten-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm lstm') $ replicate 10 (input40, Just input40)
35− , bench "fifty-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm lstm') $ replicate 50 (input40, Just input40)
15+ bgroup "train" [ bench "one-time-step" $ whnf (nfT2 . trainRecurrent lp lstm 0) [(input40, Just input40)]
16+ , bench "ten-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm 0) $ replicate 10 (input40, Just input40)
17+ , bench "fifty-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm 0) $ replicate 50 (input40, Just input40)
3618 ]
3719 ]
3820
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−
5721nfT2 :: (a, b) -> (a, b)
5822nfT2 (!a, !b) = (a, b)
5923
60−nfT3 :: (a, b, c) -> (b, c)
61−nfT3 (!_, !b, !c) = (b, c)
62−
6324
6425type R = Recurrent
6526type RecNet = RecurrentNetwork '[ R (LSTM 40 512), R (LSTM 512 40) ]
6627 '[ 'D1 40, 'D1 512, 'D1 40 ]
6728
68−type RecInput = RecurrentInputs '[ R (LSTM 40 512), R (LSTM 512 40) ]
69−
7029lp :: LearningParameters
7130lp = 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"
22
3−void decend_cpu(int len, double rate, double momentum, double regulariser,
3+void descend_cpu(int len, double rate, double momentum, double regulariser,
44 const double* weights,
55 const double* gradient,
66 const double* last,
77 double* outputWeights, double* outputMomentum) {
88
9− for (int i = 0; i <= len; i++) {
9+ for (int i = 0; i < len; i++) {
1010 outputMomentum[i] = momentum * last[i] - rate * gradient[i];
1111 outputWeights[i] = weights[i] + outputMomentum[i] - (rate * regulariser) * weights[i];
1212 }
cbits/gradient_decent.h → cbits/gradient_descent.hrenamed+1−1
@@ -1,7 +1,7 @@
11#include <stdio.h>
22#include <stdint.h>
33
4−void decend_cpu(int len, double rate, double momentum, double regulariser,
4+void descend_cpu(int len, double rate, double momentum, double regulariser,
55 const double* weights,
66 const double* gradient,
77 const double* last,
examples/LICENSEnew file+10
@@ -0,0 +1,10 @@
1+Copyright (c) 2016-2017, Huw Campbell
2+All rights reserved.
3+
4+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
5+
6+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
7+
8+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
9+
10+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
examples/grenade-examples.cabalnew file+109
@@ -0,0 +1,109 @@
1+name: grenade-examples
2+version: 0.0.1
3+license: BSD2
4+license-file: LICENSE
5+author: Huw Campbell <huw.campbell@gmail.com>
6+maintainer: Huw Campbell <huw.campbell@gmail.com>
7+copyright: (c) 2016-2017 Huw Campbell.
8+synopsis: grenade-examples
9+category: System
10+cabal-version: >= 1.8
11+build-type: Simple
12+description: grenade-examples
13+
14+source-repository head
15+ type: git
16+ location: https://github.com/HuwCampbell/grenade.git
17+
18+library
19+
20+executable feedforward
21+ ghc-options: -Wall -threaded -O2
22+ main-is: main/feedforward.hs
23+ build-depends: base
24+ , grenade
25+ , attoparsec
26+ , bytestring
27+ , cereal
28+ , either
29+ , optparse-applicative >= 0.13 && < 0.18
30+ , text == 1.2.*
31+ , mtl >= 2.2.1 && < 2.3
32+ , hmatrix
33+ , transformers
34+ , singletons
35+ , semigroups
36+ , MonadRandom
37+
38+executable mnist
39+ ghc-options: -Wall -threaded -O2
40+ main-is: main/mnist.hs
41+ build-depends: base
42+ , grenade
43+ , attoparsec
44+ , either
45+ , optparse-applicative >= 0.13 && < 0.18
46+ , text == 1.2.*
47+ , mtl >= 2.2.1 && < 2.3
48+ , hmatrix >= 0.18 && < 0.21
49+ , transformers
50+ , semigroups
51+ , singletons
52+ , MonadRandom
53+ , vector
54+
55+executable gan-mnist
56+ ghc-options: -Wall -threaded -O2
57+ main-is: main/gan-mnist.hs
58+ build-depends: base
59+ , grenade
60+ , attoparsec
61+ , bytestring
62+ , cereal
63+ , either
64+ , optparse-applicative >= 0.13 && < 0.18
65+ , text == 1.2.*
66+ , mtl >= 2.2.1 && < 2.3
67+ , hmatrix >= 0.18 && < 0.21
68+ , transformers
69+ , semigroups
70+ , singletons
71+ , MonadRandom
72+ , vector
73+
74+executable recurrent
75+ ghc-options: -Wall -threaded -O2
76+ main-is: main/recurrent.hs
77+ build-depends: base
78+ , grenade
79+ , attoparsec
80+ , either
81+ , optparse-applicative >= 0.13 && < 0.18
82+ , text == 1.2.*
83+ , mtl >= 2.2.1 && < 2.3
84+ , hmatrix >= 0.18 && < 0.21
85+ , transformers
86+ , semigroups
87+ , singletons
88+ , MonadRandom
89+
90+executable shakespeare
91+ ghc-options: -Wall -threaded -O2
92+ main-is: main/shakespeare.hs
93+ build-depends: base
94+ , grenade
95+ , attoparsec
96+ , bytestring
97+ , cereal
98+ , either
99+ , optparse-applicative >= 0.13 && < 0.18
100+ , text == 1.2.*
101+ , mtl >= 2.2.1 && < 2.3
102+ , hmatrix >= 0.18 && < 0.21
103+ , transformers
104+ , semigroups
105+ , singletons
106+ , singletons-base
107+ , vector
108+ , MonadRandom
109+ , containers
examples/mafianew file+62
@@ -0,0 +1,62 @@
1+#!/bin/sh -eu
2+
3+: ${MAFIA_HOME:=$HOME/.mafia}
4+: ${MAFIA_VERSIONS:=$MAFIA_HOME/versions}
5+
6+latest_version () {
7+ git ls-remote https://github.com/haskell-mafia/mafia | grep refs/heads/master | cut -f 1
8+}
9+
10+build_version() {
11+ MAFIA_VERSION="$1"
12+ MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia')
13+ MAFIA_FILE=mafia-$MAFIA_VERSION
14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE
15+ mkdir -p $MAFIA_VERSIONS
16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"
17+ git clone https://github.com/haskell-mafia/mafia $MAFIA_TEMP
18+ git --git-dir="$MAFIA_TEMP/.git" --work-tree="$MAFIA_TEMP" reset --hard $MAFIA_VERSION || {
19+ echo "mafia version ($MAFIA_VERSION) could not be found." >&2
20+ exit 1
21+ }
22+ (cd "$MAFIA_TEMP" && ./bin/bootstrap) || {
23+ got=$?
24+ echo "mafia version ($MAFIA_VERSION) could not be built." >&2
25+ exit "$got"
26+ }
27+ chmod +x "$MAFIA_TEMP/.cabal-sandbox/bin/mafia"
28+ # Ensure executable is on same file-system so final mv is atomic.
29+ mv -f "$MAFIA_TEMP/.cabal-sandbox/bin/mafia" "$MAFIA_PATH.$$"
30+ mv "$MAFIA_PATH.$$" "$MAFIA_PATH" || {
31+ rm -f "$MAFIA_PATH.$$"
32+ echo "INFO: mafia version ($MAFIA_VERSION) already exists not overiding," >&2
33+ echo "INFO: this is expected if parallel builds of the same version of" >&2
34+ echo "INFO: mafia occur, we are playing by first in, wins." >&2
35+ exit 0
36+ }
37+}
38+
39+enable_version() {
40+ if [ $# -eq 0 ]; then
41+ MAFIA_VERSION="$(latest_version)"
42+ echo "INFO: No explicit mafia version requested installing latest ($MAFIA_VERSION)." >&2
43+ else
44+ MAFIA_VERSION="$1"
45+ fi
46+ [ -x "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" ] || build_version "$MAFIA_VERSION"
47+ ln -sf "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" "$MAFIA_HOME/versions/mafia"
48+}
49+
50+exec_mafia () {
51+ [ -x "$MAFIA_HOME/versions/mafia" ] || enable_version
52+ "$MAFIA_HOME/versions/mafia" "$@"
53+}
54+
55+#
56+# The actual start of the script.....
57+#
58+
59+case "${1:-}" in
60+upgrade) shift; enable_version "$@" ;;
61+*) exec_mafia "$@"
62+esac
main/feedforward.hs → examples/main/feedforward.hsrenamed+3−1
@@ -1,4 +1,5 @@
11{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE ScopedTypeVariables #-}
45{-# LANGUAGE TypeOperators #-}
@@ -10,8 +11,9 @@ import Data.List ( foldl' )
1011
1112import qualified Data.ByteString as B
1213import Data.Serialize
14+#if ! MIN_VERSION_base(4,13,0)
1315import Data.Semigroup ( (<>) )
14−
16+#endif
1517import GHC.TypeLits
1618
1719import qualified Numeric.LinearAlgebra.Static as SA
main/gan-mnist.hs → examples/main/gan-mnist.hsrenamed+28−10
@@ -1,4 +1,5 @@
11{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE GADTs #-}
45{-# LANGUAGE ScopedTypeVariables #-}
@@ -10,8 +11,8 @@
1011-- This is a simple generative adversarial network to make pictures
1112-- of numbers similar to those in MNIST.
1213--
13−-- It demonstrates a different usage of the library. Within about an
14−-- hour it was producing examples like this:
14+-- It demonstrates a different usage of the library. Within about 15
15+-- minutes it was producing examples like this:
1516--
1617-- --.
1718-- .=-.--..#=###
@@ -43,7 +44,9 @@ import Control.Monad.Trans.Except
4344import qualified Data.Attoparsec.Text as A
4445import qualified Data.ByteString as B
4546import Data.List ( foldl' )
47+#if ! MIN_VERSION_base(4,13,0)
4648import Data.Semigroup ( (<>) )
49+#endif
4750import Data.Serialize
4851import qualified Data.Text as T
4952import qualified Data.Text.IO as T
@@ -57,11 +60,25 @@ import Options.Applicative
5760import Grenade
5861import Grenade.Utils.OneHot
5962
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]
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]
62−
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]
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 ]
63+type Discriminator =
64+ Network
65+ '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Relu
66+ , Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Relu
67+ , Reshape, FullyConnected 256 80, Logit, FullyConnected 80 1, Logit]
68+ '[ 'D2 28 28
69+ , 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10
70+ , 'D3 8 8 16, 'D3 4 4 16, 'D3 4 4 16
71+ , 'D1 256, 'D1 80, 'D1 80, 'D1 1, 'D1 1]
72+
73+type Generator =
74+ Network
75+ '[ FullyConnected 80 256, Relu, Reshape
76+ , Deconvolution 16 10 5 5 2 2, Relu
77+ , Deconvolution 10 1 8 8 2 2, Logit]
78+ '[ 'D1 80
79+ , 'D1 256, 'D1 256, 'D3 4 4 16
80+ , 'D3 11 11 10, 'D3 11 11 10
81+ , 'D2 28 28, 'D2 28 28 ]
6582
6683randomDiscriminator :: MonadRandom m => m Discriminator
6784randomDiscriminator = randomNetwork
@@ -69,7 +86,7 @@ randomDiscriminator = randomNetwork
6986randomGenerator :: MonadRandom m => m Generator
7087randomGenerator = randomNetwork
7188
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 )
7390trainExample rate discriminator generator realExample noiseSource
7491 = let (generatorTape, fakeExample) = runNetwork generator noiseSource
7592
@@ -77,9 +94,10 @@ trainExample rate discriminator generator realExample noiseSource
7794 (discriminatorTapeFake, guessFake) = runNetwork discriminator fakeExample
7895
7996 (discriminator'real, _) = runGradient discriminator discriminatorTapeReal ( guessReal - 1 )
80− (discriminator'fake, push) = runGradient discriminator discriminatorTapeFake guessFake
97+ (discriminator'fake, _) = runGradient discriminator discriminatorTapeFake guessFake
98+ (_, push) = runGradient discriminator discriminatorTapeFake ( guessFake - 1)
8199
82− (generator', _) = runGradient generator generatorTape (-push)
100+ (generator', _) = runGradient generator generatorTape push
83101
84102 newDiscriminator = foldl' (applyUpdate rate { learningRegulariser = learningRegulariser rate * 10}) discriminator [ discriminator'real, discriminator'fake ]
85103 newGenerator = applyUpdate rate generator generator'
main/mnist.hs → examples/main/mnist.hsrenamed+29−2
@@ -1,10 +1,12 @@
11{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE ScopedTypeVariables #-}
45{-# LANGUAGE TypeOperators #-}
56{-# LANGUAGE TupleSections #-}
67{-# LANGUAGE TypeFamilies #-}
78{-# LANGUAGE FlexibleContexts #-}
9+
810import Control.Applicative
911import Control.Monad
1012import Control.Monad.Random
@@ -12,7 +14,10 @@ import Control.Monad.Trans.Except
1214
1315import qualified Data.Attoparsec.Text as A
1416import Data.List ( foldl' )
17+#if ! MIN_VERSION_base(4,13,0)
1518import Data.Semigroup ( (<>) )
19+#endif
20+
1621import qualified Data.Text as T
1722import qualified Data.Text.IO as T
1823import qualified Data.Vector.Storable as V
@@ -25,6 +30,15 @@ import Options.Applicative
2530import Grenade
2631import Grenade.Utils.OneHot
2732
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+
2842-- The definition of our convolutional neural network.
2943-- In the type signature, we have a type level list of shapes which are passed between the layers.
3044-- One can see that the images we are inputing are two dimensional with 28 * 28 pixels.
@@ -34,8 +48,21 @@ import Grenade.Utils.OneHot
3448
3549-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,
3650-- 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]
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]
51+--
52+-- /NOTE:/ This model is actually too complex for MNIST, and one should use the type given in the readme instead.
53+-- This one is just here to demonstrate Inception layers in use.
54+--
55+type MNIST =
56+ Network
57+ '[ Reshape,
58+ Concat ('D3 28 28 1) Trivial ('D3 28 28 14) (InceptionMini 28 28 1 5 9),
59+ Pooling 2 2 2 2, Relu,
60+ Concat ('D3 14 14 3) (Convolution 15 3 1 1 1 1) ('D3 14 14 15) (InceptionMini 14 14 15 5 10), Crop 1 1 1 1, Pooling 3 3 3 3, Relu,
61+ Reshape, FL 288 80, FL 80 10 ]
62+ '[ 'D2 28 28, 'D3 28 28 1,
63+ 'D3 28 28 15, 'D3 14 14 15, 'D3 14 14 15, 'D3 14 14 18,
64+ 'D3 12 12 18, 'D3 4 4 18, 'D3 4 4 18,
65+ 'D1 288, 'D1 80, 'D1 10 ]
3966
4067randomMnist :: MonadRandom m => m MNIST
4168randomMnist = randomNetwork
main/recurrent.hs → examples/main/recurrent.hsrenamed+10−10
@@ -9,12 +9,12 @@
99import Control.Monad ( foldM )
1010import Control.Monad.Random ( MonadRandom, getRandomR )
1111
12−#if __GLASGOW_HASKELL__ < 800
12+#if MIN_VERSION_base(4,13,0)
1313import Data.List ( unfoldr )
1414#else
1515import Data.List ( cycle, unfoldr )
16−#endif
1716import Data.Semigroup ( (<>) )
17+#endif
1818
1919import qualified Numeric.LinearAlgebra.Static as SA
2020
@@ -31,12 +31,12 @@ import Grenade.Recurrent
3131-- creation function know how to treat the layers.
3232type R = Recurrent
3333
34−type RecNet = RecurrentNetwork '[ R (LSTM 1 4), R (LSTM 4 1)]
35− '[ 'D1 1, 'D1 4, 'D1 1 ]
34+type RecNet = RecurrentNetwork '[ R (LSTM 1 1)]
35+ '[ 'D1 1, 'D1 1]
3636
37−type RecInput = RecurrentInputs '[ R (LSTM 1 4), R (LSTM 4 1)]
37+type RecInput = RecurrentInputs '[ R (LSTM 1 1)]
3838
39−randomNet :: MonadRandom m => m (RecNet, RecInput)
39+randomNet :: MonadRandom m => m RecNet
4040randomNet = randomRecurrent
4141
4242netTest :: MonadRandom m => RecNet -> RecInput -> LearningParameters -> Int -> m (RecNet, RecInput)
@@ -69,8 +69,8 @@ generateRecurrent n s i =
6969 unfoldr go (s, i)
7070 where
7171 go (x, y) =
72− do let (ns, o) = runRecurrent n x y
73− o' = heat o
72+ do let (_, ns, o) = runRecurrent n x y
73+ o' = heat o
7474 Just (o', (ns, fromIntegral o'))
7575
7676 heat :: S ('D1 1) -> Int
@@ -82,8 +82,8 @@ main = do
8282 FeedForwardOpts examples rate <- execParser (info (feedForward' <**> helper) idm)
8383 putStrLn "Training network..."
8484
85− (net0, i0) <- randomNet
86− (trained, bestInput) <- netTest net0 i0 rate examples
85+ net0 <- randomNet
86+ (trained, bestInput) <- netTest net0 0 rate examples
8787
8888 let results = generateRecurrent trained bestInput (c 1)
8989
main/shakespeare.hs → examples/main/shakespeare.hsrenamed+26−23
@@ -1,5 +1,5 @@
11{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE CPP #-}
33{-# LANGUAGE DataKinds #-}
44{-# LANGUAGE ScopedTypeVariables #-}
55{-# LANGUAGE TypeOperators #-}
@@ -13,18 +13,16 @@ import Control.Monad.Trans.Except
1313import Data.Char ( isUpper, toUpper, toLower )
1414import Data.List ( foldl' )
1515import Data.Maybe ( fromMaybe )
16−import Data.Semigroup ( (<>) )
16+
1717
1818import qualified Data.Vector as V
1919import Data.Vector ( Vector )
2020
2121import qualified Data.Map as M
22−import Data.Proxy ( Proxy (..) )
2322
2423import qualified Data.ByteString as B
2524import Data.Serialize
2625
27−import Data.Singletons.Prelude
2826import GHC.TypeLits
2927
3028import Numeric.LinearAlgebra.Static ( konst )
@@ -36,11 +34,16 @@ import Grenade.Recurrent
3634import Grenade.Utils.OneHot
3735
3836import System.IO.Unsafe ( unsafeInterleaveIO )
37+import Data.Proxy
38+import Prelude.Singletons
3939
4040-- The defininition for our natural language recurrent network.
4141-- This network is able to learn and generate simple words in
4242-- about an hour.
4343--
44+-- Grab the input from
45+-- https://raw.githubusercontent.com/karpathy/char-rnn/master/data/tinyshakespeare/input.txt
46+--
4447-- This is a first class recurrent net.
4548--
4649-- 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
6164-- The definition of the "sideways" input, which the network is fed recurrently.
6265type Shakespearian = RecurrentInputs '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyConnected 40 40), F Logit]
6366
64−randomNet :: MonadRandom m => m (Shakespeare, Shakespearian)
67+randomNet :: MonadRandom m => m Shakespeare
6568randomNet = randomRecurrent
6669
6770-- | 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
6972loadShakespeare path = do
7073 contents <- lift $ readFile path
7174 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
7376 hot <- ExceptT . return . note "Couldn't generate hot values" $ traverse (`M.lookup` m) annotated
7477 return (V.fromList hot, m, cs)
7578
7679trainSlice :: 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 =
7881 let e = fmap (x . oneHot) . V.toList $ V.slice offset size input
7982 in case reverse e of
8083 (o : l : xs) ->
8184 let examples = reverse $ (l, Just o) : ((,Nothing) <$> xs)
82− in trainRecurrent rate net recIns examples
85+ in trainRecurrent lrate net recIns examples
8386 _ -> error "Not enough input"
8487 where
8588 x = fromMaybe (error "Hot variable didn't fit.")
8689
8790runShakespeare :: ShakespeareOpts -> ExceptT String IO ()
88−runShakespeare ShakespeareOpts {..} = do
89− (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare trainingFile
91+runShakespeare opts = do
92+ (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare $ trainingFile opts
9093 (net0, i0) <- lift $
91− case loadPath of
94+ case loadPath opts of
9295 Just loadFile -> netLoad loadFile
93− Nothing -> randomNet
96+ Nothing -> (,0) <$> randomNet
9497
9598 (trained, bestInput) <- lift $ foldM (\(!net, !io) size -> do
96− xs <- take (iterations `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
98− results <- take 1000 <$> generateParagraph trained bestInput temperature oneHotMap oneHotDictionary ( S1D $ konst 0)
99+ xs <- take (iterations opts `div` 10) <$> getRandomRs (0, length shakespeare - size - 1)
100+ let (!trained, !bestInput) = foldl' (\(!n, !i) offset -> trainSlice (rate opts) n i shakespeare offset size) (net, io) xs
101+ results <- take 1000 <$> generateParagraph trained bestInput (temperature opts) oneHotMap oneHotDictionary ( S1D $ konst 0)
99102 putStrLn ("TRAINING STEP WITH SIZE: " ++ show size)
100103 putStrLn (unAnnotateCapitals results)
101104 return (trained, bestInput)
102− ) (net0, i0) $ replicate 10 sequenceSize
105+ ) (net0, i0) $ replicate 10 (sequenceSize opts)
103106
104− case savePath of
105− Just saveFile -> lift . B.writeFile saveFile $ runPut (put (trained, bestInput))
107+ case savePath opts of
108+ Just saveFile -> lift . B.writeFile saveFile $ runPut (put trained >> put bestInput)
106109 Nothing -> return ()
107110
108111generateParagraph :: 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
113116 -> Vector a
114117 -> S ('D1 n)
115118 -> IO [a]
116−generateParagraph n s temperature hotmap hotdict =
119+generateParagraph n s temp hotmap hotdict =
117120 go s
118121 where
119122 go x y =
120− do let (ns, o) = runRecurrent n x y
121− un <- sample temperature hotdict o
122− Just re <- return $ makeHot hotmap un
123− rest <- unsafeInterleaveIO $ go ns re
123+ do let (_, ns, o) = runRecurrent n x y
124+ un <- sample temp hotdict o
125+ Just re <- return $ makeHot hotmap un
126+ rest <- unsafeInterleaveIO $ go ns re
124127 return (un : rest)
125128
126129data 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 @@
11name: grenade
2−version: 0.0.1
2+version: 0.1.0
33license: BSD2
44license-file: LICENSE
55author: Huw Campbell <huw.campbell@gmail.com>
66maintainer: Huw Campbell <huw.campbell@gmail.com>
7−copyright: (c) 2015 Huw Campbell.
8−synopsis: grenade
9−category: System
10−cabal-version: >= 1.8
7+copyright: (c) 2016-2017 Huw Campbell.
8+synopsis: Practical Deep Learning in Haskell
9+category: AI, Machine Learning
10+cabal-version: >= 1.10
1111build-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>.
1324
1425extra-source-files:
15− cbits/im2col.h
16− cbits/im2col.c
17− cbits/gradient_decent.h
18− cbits/gradient_decent.c
19− cbits/pad.h
20− cbits/pad.c
26+ README.md
27+ cbits/im2col.h
28+ cbits/im2col.c
29+ cbits/gradient_descent.h
30+ cbits/gradient_descent.c
31+ cbits/pad.h
32+ cbits/pad.c
2133
2234source-repository head
2335 type: git
@@ -26,26 +38,32 @@ source-repository head
2638library
2739 build-depends:
2840 base >= 4.8 && < 5
29− , bytestring == 0.10.*
30− , containers
31− , deepseq
32− , either == 4.4.*
33− , cereal
34− , exceptions == 0.8.*
35− , hmatrix == 0.18.*
36− , MonadRandom
37− , mtl >= 2.2.1 && < 2.3
38− , primitive
39− , text == 1.2.*
40− , transformers
41− , singletons >= 2.1 && < 2.3
42− , vector == 0.11.*
41+ , bytestring >= 0.10.0
42+ , containers >= 0.5 && < 0.7
43+ , cereal >= 0.5 && < 0.6
44+ , deepseq >= 1.4 && < 1.5
45+ , hmatrix >= 0.18 && < 0.21
46+ , MonadRandom >= 0.4 && < 0.6
47+ , primitive >= 0.6 && < 0.8
48+ -- Versions of singletons are *tightly* coupled with the
49+ -- GHC version so its fine to drop version bounds.
50+ , singletons
51+ , singletons-base
52+ , vector >= 0.11 && < 0.13
4353
4454 ghc-options:
4555 -Wall
4656 hs-source-dirs:
4757 src
4858
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
4967
5068 exposed-modules:
5169 Grenade
@@ -55,19 +73,26 @@ library
5573 Grenade.Core.Network
5674 Grenade.Core.Runner
5775 Grenade.Core.Shape
58− Grenade.Layers.Crop
76+
77+ Grenade.Layers
5978 Grenade.Layers.Concat
6079 Grenade.Layers.Convolution
80+ Grenade.Layers.Crop
81+ Grenade.Layers.Deconvolution
6182 Grenade.Layers.Dropout
83+ Grenade.Layers.Elu
6284 Grenade.Layers.FullyConnected
63− Grenade.Layers.Reshape
85+ Grenade.Layers.Inception
6486 Grenade.Layers.Logit
6587 Grenade.Layers.Merge
66− Grenade.Layers.Relu
67− Grenade.Layers.Elu
68− Grenade.Layers.Tanh
6988 Grenade.Layers.Pad
7089 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
7196
7297 Grenade.Layers.Internal.Convolution
7398 Grenade.Layers.Internal.Pad
@@ -81,111 +106,21 @@ library
81106 Grenade.Recurrent.Core.Network
82107 Grenade.Recurrent.Core.Runner
83108
109+ Grenade.Recurrent.Layers
84110 Grenade.Recurrent.Layers.BasicRecurrent
111+ Grenade.Recurrent.Layers.ConcatRecurrent
85112 Grenade.Recurrent.Layers.LSTM
86113
87114 Grenade.Utils.OneHot
88115
89− includes: cbits/im2col.h
90− cbits/gradient_decent.h
91− cbits/pad.h
92− c-sources: cbits/im2col.c
93− cbits/gradient_decent.c
94− 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
116+ includes: cbits/im2col.h
117+ cbits/gradient_descent.h
118+ cbits/pad.h
119+ c-sources: cbits/im2col.c
120+ cbits/gradient_descent.c
121+ cbits/pad.c
188122
123+ cc-options: -std=c99 -O3 -msse4.2 -Wall -Werror -DCABAL=1
189124
190125test-suite test
191126 type: exitcode-stdio-1.0
@@ -197,23 +132,48 @@ test-suite test
197132 hs-source-dirs:
198133 test
199134
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+
200161 build-depends:
201− base >= 4.8 && < 5
162+ base
202163 , grenade
203− , ambiata-disorder-core
204− , ambiata-disorder-jack
164+ , hedgehog >= 1.0 && < 1.1
205165 , hmatrix
206166 , mtl
207167 , singletons
208168 , text == 1.2.*
209− , typelits-witnesses
169+ , typelits-witnesses < 0.4
170+ , transformers
210171 , constraints
211− , QuickCheck >= 2.7 && < 2.9
212− , quickcheck-instances == 0.3.*
213172 , MonadRandom
214173 , random
215174 , ad
216175 , reflection
176+ , vector
217177
218178
219179benchmark bench
@@ -226,10 +186,12 @@ benchmark bench
226186 hs-source-dirs:
227187 bench
228188
189+ default-language: Haskell2010
190+
229191 build-depends:
230− base >= 3 && < 5
231− , bytestring == 0.10.*
232− , criterion == 1.1.*
192+ base
193+ , bytestring
194+ , criterion >= 1.1 && < 1.6
233195 , grenade
234196 , hmatrix
235197
@@ -243,9 +205,11 @@ benchmark bench-lstm
243205 hs-source-dirs:
244206 bench
245207
208+ default-language: Haskell2010
209+
246210 build-depends:
247− base >= 3 && < 5
248− , bytestring == 0.10.*
249− , criterion == 1.1.*
211+ base
212+ , bytestring
213+ , criterion
250214 , grenade
251215 , 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 @@
11module Grenade (
2− module X
2+ -- | This is an empty module which simply re-exports public definitions
3+ -- for machine learning with Grenade.
4+
5+ -- * Exported modules
6+ --
7+ -- | The core types and runners for Grenade.
8+ module Grenade.Core
9+
10+ -- | The neural network layer zoo
11+ , module Grenade.Layers
12+
13+
14+ -- * Overview of the library
15+ -- $library
16+
17+ -- * Example usage
18+ -- $example
19+
320 ) where
421
5−import Grenade.Core.LearningParameters as X
6−import Grenade.Core.Layer as X
7−import Grenade.Core.Network as X
8−import Grenade.Core.Runner as X
9−import Grenade.Core.Shape as X
10−import Grenade.Layers.Concat as X
11−import Grenade.Layers.Crop as X
12−import Grenade.Layers.Dropout as X
13−import Grenade.Layers.Pad as X
14−import Grenade.Layers.Pooling as X
15−import Grenade.Layers.Reshape as X
16−import Grenade.Layers.FullyConnected as X
17−import Grenade.Layers.Logit as X
18−import Grenade.Layers.Merge as X
19−import Grenade.Layers.Convolution as X
20−import Grenade.Layers.Relu as X
21−import Grenade.Layers.Elu as X
22−import Grenade.Layers.Tanh as X
23−import Grenade.Layers.Softmax as X
22+import Grenade.Core
23+import Grenade.Layers
24+
25+{- $library
26+Grenade is a purely functional deep learning library.
27+
28+It provides an expressive type level API for the construction
29+of complex neural network architectures. Backing this API is and
30+implementation written using BLAS and LAPACK, mostly provided by
31+the hmatrix library.
32+
33+-}
34+
35+{- $example
36+A few examples are provided at https://github.com/HuwCampbell/grenade
37+under the examples folder.
38+
39+The starting place is to write your neural network type and a
40+function to create a random layer of that type. The following
41+is a simple example which runs a logistic regression.
42+
43+> type MyNet = Network '[ FullyConnected 10 1, Logit ] '[ 'D1 10, 'D1 1, 'D1 1 ]
44+>
45+> randomMyNet :: MonadRandom MyNet
46+> randomMyNet = randomNetwork
47+
48+The function `randomMyNet` witnesses the `CreatableNetwork`
49+constraint of the neural network, and in doing so, ensures the network
50+can be built, and hence, that the architecture is sound.
51+-}
52+
53+
src/Grenade/Core.hs+10−5
@@ -1,8 +1,13 @@
11module 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
37 ) where
48
5−import Grenade.Core.Layer as X
6−import Grenade.Core.LearningParameters as X
7−import Grenade.Core.Shape as X
8−import Grenade.Core.Network as X
9+import Grenade.Core.Layer
10+import Grenade.Core.LearningParameters
11+import Grenade.Core.Network
12+import Grenade.Core.Runner
13+import Grenade.Core.Shape
src/Grenade/Core/Layer.hs+25−4
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE TypeOperators #-}
@@ -7,14 +8,30 @@
78{-# LANGUAGE RankNTypes #-}
89{-# LANGUAGE FlexibleInstances #-}
910{-|
10−Module : Grenade.Core.Network
11−Description : Core definition a simple neural etwork
11+Module : Grenade.Core.Layer
12+Description : Defines the Layer Classes
1213Copyright : (c) Huw Campbell, 2016-2017
1314License : BSD2
1415Stability : experimental
1516
1617This module defines what a Layer is in a Grenade
1718neural 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.
1835-}
1936module Grenade.Core.Layer (
2037 Layer (..)
@@ -25,6 +42,10 @@ import Control.Monad.Random ( MonadRandom )
2542
2643import Data.List ( foldl' )
2744
45+#if MIN_VERSION_base(4,9,0)
46+import Data.Kind (Type)
47+#endif
48+
2849import Grenade.Core.Shape
2950import Grenade.Core.LearningParameters
3051
@@ -34,7 +55,7 @@ import Grenade.Core.LearningParameters
3455class UpdateLayer x where
3556 -- | The type for the gradient for this layer.
3657 -- Unit if there isn't a gradient to pass back.
37− type Gradient x :: *
58+ type Gradient x :: Type
3859
3960 -- | Update a layer with its gradient and learning parameters
4061 runUpdate :: LearningParameters -> x -> Gradient x -> x
@@ -56,7 +77,7 @@ class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where
5677 -- | The Wengert tape for this layer. Includes all that is required
5778 -- to generate the back propagated gradients efficiently. As a
5879 -- default, `S i` is fine.
59− type Tape x i o :: *
80+ type Tape x i o :: Type
6081
6182 -- | Used in training and scoring. Take the input from the previous
6283 -- 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+-}
18module 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+
213 LearningParameters (..)
314 ) where
415
src/Grenade/Core/Network.hs+17−16
@@ -10,7 +10,7 @@
1010{-# LANGUAGE FlexibleInstances #-}
1111{-|
1212Module : Grenade.Core.Network
13−Description : Core definition a simple neural etwork
13+Description : Core definition of a Neural Network
1414Copyright : (c) Huw Campbell, 2016-2017
1515License : BSD2
1616Stability : experimental
@@ -19,10 +19,6 @@ This module defines the core data types and functions
1919for non-recurrent neural networks.
2020-}
2121
22−#if __GLASGOW_HASKELL__ < 800
23−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
24−#endif
25−
2622module Grenade.Core.Network (
2723 Network (..)
2824 , Gradients (..)
@@ -38,22 +34,26 @@ module Grenade.Core.Network (
3834import Control.Monad.Random ( MonadRandom )
3935
4036import Data.Singletons
41−import Data.Singletons.Prelude
4237import Data.Serialize
4338
39+#if MIN_VERSION_base(4,9,0)
40+import Data.Kind (Type)
41+#endif
42+
4443import Grenade.Core.Layer
4544import Grenade.Core.LearningParameters
4645import Grenade.Core.Shape
46+import Prelude.Singletons
4747
4848-- | Type of a network.
4949--
50−-- The [*] type specifies the types of the layers.
50+-- The @[*]@ type specifies the types of the layers.
5151--
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.
5353--
5454-- Can be considered to be a heterogeneous list of layers which are able to
5555-- transform the data shapes of the network.
56−data Network :: [*] -> [Shape] -> * where
56+data Network :: [Type] -> [Shape] -> Type where
5757 NNil :: SingI i
5858 => Network '[] '[i]
5959
@@ -71,7 +71,7 @@ instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) wh
7171-- | Gradient of a network.
7272--
7373-- Parameterised on the layers of the network.
74−data Gradients :: [*] -> * where
74+data Gradients :: [Type] -> Type where
7575 GNil :: Gradients '[]
7676
7777 (:/>) :: UpdateLayer x
@@ -82,7 +82,7 @@ data Gradients :: [*] -> * where
8282-- | Wegnert Tape of a network.
8383--
8484-- Parameterised on the layers and shapes of the network.
85−data Tapes :: [*] -> [Shape] -> * where
85+data Tapes :: [Type] -> [Shape] -> Type where
8686 TNil :: SingI i
8787 => Tapes '[] '[i]
8888
@@ -96,7 +96,6 @@ data Tapes :: [*] -> [Shape] -> * where
9696--
9797-- This gives the output, and the Wengert tape required for back
9898-- propagation.
99−--
10099runNetwork :: forall layers shapes.
101100 Network layers shapes
102101 -> S (Head shapes)
@@ -124,7 +123,6 @@ runNetwork =
124123--
125124-- Gives the gradients for the layer, and the gradient across the
126125-- input (which may not be required).
127−--
128126runGradient :: forall layers shapes.
129127 Network layers shapes
130128 -> Tapes layers shapes
@@ -146,7 +144,7 @@ runGradient net tapes o =
146144 = (GNil, o)
147145
148146
149−-- | Apply one step of stochastic gradient decent across the network.
147+-- | Apply one step of stochastic gradient descent across the network.
150148applyUpdate :: LearningParameters
151149 -> Network layers shapes
152150 -> Gradients layers
@@ -159,7 +157,7 @@ applyUpdate _ NNil GNil
159157
160158-- | A network can easily be created by hand with (:~>), but an easy way to
161159-- initialise a random network is with the randomNetwork.
162−class CreatableNetwork (xs :: [*]) (ss :: [Shape]) where
160+class CreatableNetwork (xs :: [Type]) (ss :: [Shape]) where
163161 -- | Create a network with randomly initialised weights.
164162 --
165163 -- 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 '
184182
185183-- | Ultimate composition.
186184--
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.
188186instance CreatableNetwork sublayers subshapes => UpdateLayer (Network sublayers subshapes) where
189187 type Gradient (Network sublayers subshapes) = Gradients sublayers
190188 runUpdate = applyUpdate
191189 createRandom = randomNetwork
192190
191+-- | Ultimate composition.
192+--
193+-- This allows a complete network to be treated as a layer in a larger network.
193194instance (CreatableNetwork sublayers subshapes, i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (Network sublayers subshapes) i o where
194195 type Tape (Network sublayers subshapes) i o = Tapes sublayers subshapes
195196 runForwards = runNetwork
src/Grenade/Core/Runner.hs+4−6
@@ -1,14 +1,11 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE FlexibleContexts #-}
33{-|
4−Module : Grenade.Core.Shape
5−Description : Core definition of the Shapes of data we understand
4+Module : Grenade.Core.Runner
5+Description : Functions to perform training and backpropagation
66Copyright : (c) Huw Campbell, 2016-2017
77License : BSD2
88Stability : experimental
9−
10−This module defines simple back propagation and training functions
11−for a network.
129-}
1310module Grenade.Core.Runner (
1411 train
@@ -16,11 +13,12 @@ module Grenade.Core.Runner (
1613 , runNet
1714 ) where
1815
19−import Data.Singletons.Prelude
2016
2117import Grenade.Core.LearningParameters
2218import Grenade.Core.Network
2319import Grenade.Core.Shape
20+import Data.Singletons
21+import Prelude.Singletons
2422
2523-- | Perform reverse automatic differentiation on the network
2624-- for the current input and expected output.
src/Grenade/Core/Shape.hs+58−32
@@ -8,41 +8,33 @@
88{-# LANGUAGE FlexibleContexts #-}
99{-# LANGUAGE ScopedTypeVariables #-}
1010{-# LANGUAGE RankNTypes #-}
11−
12−-- Ghc 7.10 fails to recognise n2 is complete.
13−#if __GLASGOW_HASKELL__ < 800
14−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
15−#endif
11+{-# LANGUAGE UndecidableInstances #-}
1612{-|
1713Module : 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
1915Copyright : (c) Huw Campbell, 2016-2017
2016License : BSD2
2117Stability : experimental
2218
23−This module defines the core data types for the shapes of data that
24−are understood by Grenade.
19+
2520-}
2621module Grenade.Core.Shape (
27− Shape (..)
28− , S (..)
29− , Sing (..)
30−
22+ S (..)
23+ , Shape (..)
24+ , SShape (..)
3125 , randomOfShape
3226 , fromStorable
3327 ) where
3428
3529import Control.DeepSeq (NFData (..))
3630import Control.Monad.Random ( MonadRandom, getRandom )
37−
31+import Data.Kind (Type)
3832import Data.Proxy
33+import Data.Serialize
3934import Data.Singletons
40−import Data.Singletons.TypeLits
4135import Data.Vector.Storable ( Vector )
4236import qualified Data.Vector.Storable as V
43−
4437import GHC.TypeLits
45−
4638import qualified Numeric.LinearAlgebra.Static as H
4739import Numeric.LinearAlgebra.Static
4840import qualified Numeric.LinearAlgebra as NLA
@@ -65,17 +57,14 @@ data Shape
6557-- All shapes are held in contiguous memory.
6658-- 3D is held in a matrix (usually row oriented) which has height depth * rows.
6759data S (n :: Shape) where
68− -- | One dimensional data
6960 S1D :: ( KnownNat len )
7061 => R len
7162 -> S ('D1 len)
7263
73− -- | Two dimensional data
7464 S2D :: ( KnownNat rows, KnownNat columns )
7565 => L rows columns
7666 -> S ('D2 rows columns)
7767
78− -- | Three dimensional data
7968 S3D :: ( KnownNat rows
8069 , KnownNat columns
8170 , KnownNat depth
@@ -90,10 +79,20 @@ deriving instance Show (S n)
9079-- These could probably be derived with template haskell, but this seems
9180-- clear and makes adding the KnownNat constraints simple.
9281-- 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
9391data instance Sing (n :: Shape) where
94− D1Sing :: KnownNat a => Sing ('D1 a)
95− D2Sing :: (KnownNat a, KnownNat b) => Sing ('D2 a b)
96− D3Sing :: (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => Sing ('D3 a b c)
92+ D1Sing :: Sing a -> Sing ('D1 a)
93+ D2Sing :: Sing a -> Sing b -> Sing ('D2 a b)
94+ D3Sing :: KnownNat (a * c) => Sing a -> Sing b -> Sing c -> Sing ('D3 a b c)
95+#endif
9796
9897instance KnownNat a => SingI ('D1 a) where
9998 sing = D1Sing
@@ -149,18 +148,28 @@ randomOfShape :: forall x m. ( MonadRandom m, SingI x ) => m (S x)
149148randomOfShape = do
150149 seed :: Int <- getRandom
151150 return $ case (sing :: Sing x) of
152− D1Sing -> S1D (randomVector seed Uniform * 2 - 1)
153− D2Sing -> S2D (uniformSample seed (-1) 1)
154− D3Sing -> S3D (uniformSample seed (-1) 1)
151+ D1Sing ->
152+ S1D (randomVector seed Uniform * 2 - 1)
153+
154+ D2Sing ->
155+ S2D (uniformSample seed (-1) 1)
156+
157+ D3Sing ->
158+ S3D (uniformSample seed (-1) 1)
155159
156160-- | Generate a shape from a Storable Vector.
157161--
158162-- Returns Nothing if the vector is of the wrong size.
159163fromStorable :: forall x. SingI x => Vector Double -> Maybe (S x)
160164fromStorable xs = case sing :: Sing x of
161− D1Sing -> S1D <$> H.create xs
162− D2Sing -> S2D <$> mkL xs
163− D3Sing -> S3D <$> mkL xs
165+ D1Sing ->
166+ S1D <$> H.create xs
167+
168+ D2Sing ->
169+ S2D <$> mkL xs
170+
171+ D3Sing ->
172+ S3D <$> mkL xs
164173 where
165174 mkL :: forall rows columns. (KnownNat rows, KnownNat columns)
166175 => Vector Double -> Maybe (L rows columns)
@@ -171,6 +180,18 @@ fromStorable xs = case sing :: Sing x of
171180 then H.create $ NLA.reshape columns v
172181 else Nothing
173182
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+
174195-- Helper function for creating the number instances
175196n1 :: ( forall a. Floating a => a -> a ) -> S x -> S x
176197n1 f (S1D x) = S1D (f x)
@@ -184,8 +205,13 @@ n2 f (S2D x) (S2D y) = S2D (f x y)
184205n2 f (S3D x) (S3D y) = S3D (f x y)
185206
186207-- 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
188209nk x = case (sing :: Sing x) of
189− D1Sing -> S1D (konst x)
190− D2Sing -> S2D (konst x)
191− D3Sing -> S3D (konst x)
210+ D1Sing ->
211+ S1D (konst x)
212+
213+ D2Sing ->
214+ S2D (konst x)
215+
216+ D3Sing ->
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 #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE TypeOperators #-}
@@ -8,20 +9,29 @@
89{-# LANGUAGE FlexibleInstances #-}
910{-# LANGUAGE ScopedTypeVariables #-}
1011{-# LANGUAGE StandaloneDeriving #-}
12+{-# LANGUAGE UndecidableInstances #-}
1113{-|
12−Module : Grenade.Core.Network
13−Description : Core definition a simple neural etwork
14+Module : Grenade.Layers.Concat
15+Description : Concatenation layer
1416Copyright : (c) Huw Campbell, 2016-2017
1517License : BSD2
1618Stability : experimental
19+
20+This module provides the concatenation layer, which runs two chilld layers in parallel and combines their outputs.
1721-}
1822module Grenade.Layers.Concat (
1923 Concat (..)
2024 ) where
2125
26+import Data.Serialize
27+
2228import Data.Singletons
2329import GHC.TypeLits
2430
31+#if MIN_VERSION_base(4,9,0)
32+import Data.Kind (Type)
33+#endif
34+
2535import Grenade.Core
2636
2737import Numeric.LinearAlgebra.Static ( row, (===), splitRows, unrow, (#), split, R )
@@ -39,7 +49,7 @@ import Numeric.LinearAlgebra.Static ( row, (===), splitRows, unrow, (#
3949--
4050-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad
4151-- and Crop layers to ensure this is the case.
42−data Concat :: Shape -> * -> Shape -> * -> * where
52+data Concat :: Shape -> Type -> Shape -> Type -> Type where
4353 Concat :: x -> y -> Concat m x n y
4454
4555instance (Show x, Show y) => Show (Concat m x n y) where
@@ -123,3 +133,7 @@ instance ( SingI i
123133 (x', xB :: S i) = runBackwards x xTape (S3D ox :: S ('D3 rows cols m))
124134 (y', yB :: S i) = runBackwards y yTape (S3D oy :: S ('D3 rows cols n))
125135 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 #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE RecordWildCards #-}
44{-# LANGUAGE GADTs #-}
55{-# LANGUAGE TypeOperators #-}
66{-# LANGUAGE TypeFamilies #-}
77{-# LANGUAGE MultiParamTypeClasses #-}
88{-# LANGUAGE FlexibleInstances #-}
99{-# LANGUAGE FlexibleContexts #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+{-|
12+Module : Grenade.Layers.Convolution
13+Description : Convolution layer
14+Copyright : (c) Huw Campbell, 2016-2017
15+License : BSD2
16+Stability : experimental
17+
18+This module provides the Convolution layer, which is critical in many computer vision tasks.
19+
20+-}
1021module Grenade.Layers.Convolution (
1122 Convolution (..)
1223 , Convolution' (..)
@@ -17,9 +28,9 @@ import Control.Monad.Random hiding ( fromList )
1728import Data.Maybe
1829import Data.Proxy
1930import Data.Serialize
20−import Data.Singletons.TypeLits
2131
2232import GHC.TypeLits
33+import Data.Kind (Type)
2334
2435import Numeric.LinearAlgebra hiding ( uniformSample, konst )
2536import qualified Numeric.LinearAlgebra as LA
@@ -46,7 +57,7 @@ data Convolution :: Nat -- Number of channels, for the first layer this could be
4657 -> Nat -- The number of column in the kernel filter
4758 -> Nat -- The row stride of the convolution filter
4859 -> Nat -- The columns stride of the convolution filter
49− -> * where
60+ -> Type where
5061 Convolution :: ( KnownNat channels
5162 , KnownNat filters
5263 , KnownNat kernelRows
@@ -65,7 +76,7 @@ data Convolution' :: Nat -- Number of channels, for the first layer this could b
6576 -> Nat -- The number of column in the kernel filter
6677 -> Nat -- The row stride of the convolution filter
6778 -> Nat -- The columns stride of the convolution filter
68− -> * where
79+ -> Type where
6980 Convolution' :: ( KnownNat channels
7081 , KnownNat filters
7182 , KnownNat kernelRows
@@ -119,9 +130,9 @@ instance ( KnownNat channels
119130 , KnownNat strideColumns
120131 , KnownNat (kernelRows * kernelColumns * channels)
121132 ) => 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)
123− runUpdate LearningParameters {..} (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =
124− let (newKernel, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldKernel kernelGradient oldMomentum
133+ type Gradient (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Convolution' channels filters kernelRows kernelColumns strideRows strideColumns)
134+ runUpdate lp (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =
135+ let (newKernel, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldKernel kernelGradient oldMomentum
125136 in Convolution newKernel newMomentum
126137
127138 createRandom = randomConvolution
@@ -141,7 +152,8 @@ instance ( KnownNat channels
141152 let mm = konst 0
142153 return $ Convolution wN mm
143154
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.
145157instance ( KnownNat kernelRows
146158 , KnownNat kernelCols
147159 , KnownNat filters
@@ -151,28 +163,33 @@ instance ( KnownNat kernelRows
151163 , KnownNat inputCols
152164 , KnownNat outputRows
153165 , KnownNat outputCols
166+ , KnownNat channels
154167 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
155168 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
156− , KnownNat (kernelRows * kernelCols * 1)
169+ , KnownNat (kernelRows * kernelCols * channels)
157170 , KnownNat (outputRows * filters)
158− ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where
159− type Tape (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D2 inputRows inputCols)
160− runForwards (Convolution kernel _) (S2D input) =
171+ ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where
172+
173+ type Tape (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)
174+
175+ runForwards (Convolution kernel _) (S3D input) =
161176 let ex = extract input
162177 ek = extract kernel
178+ ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
179+ iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
163180 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
164181 ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
165182 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
166183 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
167184 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
168185 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
169− c = im2col kx ky sx sy ex
186+
187+ c = vid2col kx ky sx sy ix iy ex
170188 mt = c LA.<> ek
171189 r = col2vid 1 1 1 1 ox oy mt
172190 rs = fromJust . create $ r
173− in (S2D input, S3D rs)
174−
175− runBackwards (Convolution kernel _) (S2D input) (S3D dEdy) =
191+ in (S3D input, S3D rs)
192+ runBackwards (Convolution kernel _) (S3D input) (S3D dEdy) =
176193 let ex = extract input
177194 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
178195 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
@@ -183,7 +200,7 @@ instance ( KnownNat kernelRows
183200 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
184201 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
185202
186− c = im2col kx ky sx sy ex
203+ c = vid2col kx ky sx sy ix iy ex
187204
188205 eo = extract dEdy
189206 ek = extract kernel
@@ -191,14 +208,14 @@ instance ( KnownNat kernelRows
191208 vs = vid2col 1 1 1 1 ox oy eo
192209
193210 kN = fromJust . create $ tr c LA.<> vs
211+
194212 dW = vs LA.<> tr ek
195213
196− xW = col2im kx ky sx sy ix iy dW
197− in (Convolution' kN, S2D . fromJust . create $ xW)
214+ xW = col2vid kx ky sx sy ix iy dW
215+ in (Convolution' kN, S3D . fromJust . create $ xW)
198216
199217
200−-- | A three dimensional image (or 2d with many channels) can have
201−-- an appropriately sized convolution filter run across it.
218+-- | A two dimentional image may have a convolution filter applied to it
202219instance ( KnownNat kernelRows
203220 , KnownNat kernelCols
204221 , KnownNat filters
@@ -208,53 +225,63 @@ instance ( KnownNat kernelRows
208225 , KnownNat inputCols
209226 , KnownNat outputRows
210227 , KnownNat outputCols
211− , KnownNat channels
212228 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
213229 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
214− , KnownNat (kernelRows * kernelCols * channels)
230+ , KnownNat (kernelRows * kernelCols * 1)
215231 , KnownNat (outputRows * filters)
216− ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('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)
219−
220− runForwards (Convolution kernel _) (S3D input) =
221− let ex = extract input
222− ek = extract kernel
223− ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
224− iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
225− kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
226− ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
227− sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
228− sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
229− ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
230− oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
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)
232+ ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where
233+ type Tape (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols 1)
234+ runForwards c (S2D input) =
235+ runForwards c (S3D input :: S ('D3 inputRows inputCols 1))
247236
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)
249240
250− eo = extract dEdy
251− ek = extract kernel
252241
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)
254261
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)
256265
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)
258285
259− xW = col2vid kx ky sx sy ix iy dW
260− in (Convolution' kN, S3D . fromJust . create $ xW)
286+ runBackwards c tape (S2D grads) =
287+ runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1))
src/Grenade/Layers/Crop.hs+19−4
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE ScopedTypeVariables #-}
34{-# LANGUAGE GADTs #-}
@@ -5,14 +6,24 @@
56{-# LANGUAGE TypeFamilies #-}
67{-# LANGUAGE FlexibleContexts #-}
78{-# 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+-}
817module Grenade.Layers.Crop (
918 Crop (..)
1019 ) where
1120
1221import Data.Maybe
1322import Data.Proxy
14−import Data.Singletons.TypeLits
23+import Data.Serialize
24+
1525import GHC.TypeLits
26+import Data.Kind (Type)
1627
1728import Grenade.Core
1829import Grenade.Layers.Internal.Pad
@@ -24,7 +35,7 @@ import Numeric.LinearAlgebra.Static (extract, create)
2435data Crop :: Nat
2536 -> Nat
2637 -> Nat
27− -> Nat -> * where
38+ -> Nat -> Type where
2839 Crop :: Crop cropLeft cropTop cropRight cropBottom
2940
3041instance Show (Crop cropLeft cropTop cropRight cropBottom) where
@@ -35,6 +46,10 @@ instance UpdateLayer (Crop l t r b) where
3546 runUpdate _ x _ = x
3647 createRandom = return Crop
3748
49+instance Serialize (Crop l t r b) where
50+ put _ = return ()
51+ get = return Crop
52+
3853-- | A two dimentional image can be cropped.
3954instance ( KnownNat cropLeft
4055 , KnownNat cropTop
@@ -44,8 +59,8 @@ instance ( KnownNat cropLeft
4459 , KnownNat inputColumns
4560 , KnownNat outputRows
4661 , KnownNat outputColumns
47− , (inputRows - cropTop - cropBottom) ~ outputRows
48− , (inputColumns - cropLeft - cropRight) ~ outputColumns
62+ , (outputRows + cropTop + cropBottom) ~ inputRows
63+ , (outputColumns + cropLeft + cropRight) ~ inputColumns
4964 ) => Layer (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where
5065 type Tape (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = ()
5166 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 @@
22{-# LANGUAGE TypeOperators #-}
33{-# LANGUAGE TypeFamilies #-}
44{-# 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+-}
512module Grenade.Layers.Elu (
613 Elu (..)
714 ) where
@@ -29,12 +36,12 @@ instance Serialize Elu where
2936 get = return Elu
3037
3138instance ( 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
3340
34− runForwards _ (S1D y) = (S1D y, S1D (elu y))
41+ runForwards _ (S1D y) = (y, S1D (elu y))
3542 where
3643 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))
3845 where
3946 elu' = LAS.dvmap (\a -> if a <= 0 then exp a else 1)
4047
src/Grenade/Layers/FullyConnected.hs+7−8
@@ -1,5 +1,4 @@
11{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE RecordWildCards #-}
32{-# LANGUAGE TypeOperators #-}
43{-# LANGUAGE TypeFamilies #-}
54{-# LANGUAGE MultiParamTypeClasses #-}
@@ -14,7 +13,6 @@ import Control.Monad.Random hiding (fromList)
1413
1514import Data.Proxy
1615import Data.Serialize
17−import Data.Singletons.TypeLits
1816
1917import qualified Numeric.LinearAlgebra as LA
2018import Numeric.LinearAlgebra.Static
@@ -22,6 +20,7 @@ import Numeric.LinearAlgebra.Static
2220import Grenade.Core
2321
2422import Grenade.Layers.Internal.Update
23+import GHC.TypeLits
2524
2625-- | A basic fully connected (or inner product) neural network layer.
2726data FullyConnected i o = FullyConnected
@@ -38,20 +37,20 @@ instance Show (FullyConnected i o) where
3837instance (KnownNat i, KnownNat o) => UpdateLayer (FullyConnected i o) where
3938 type Gradient (FullyConnected i o) = (FullyConnected' i o)
4039
41− runUpdate LearningParameters {..} (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =
42− let (newBias, newBiasMomentum) = decendVector learningRate learningMomentum learningRegulariser oldBias biasGradient oldBiasMomentum
43− (newActivations, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldActivations activationGradient oldMomentum
40+ runUpdate lp (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =
41+ let (newBias, newBiasMomentum) = descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldBias biasGradient oldBiasMomentum
42+ (newActivations, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldActivations activationGradient oldMomentum
4443 in FullyConnected (FullyConnected' newBias newActivations) (FullyConnected' newBiasMomentum newMomentum)
4544
4645 createRandom = randomFullyConnected
4746
4847instance (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
5049 -- 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))
5251
5352 -- 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) =
5554 let wB' = dEdy
5655 mm' = dEdy `outer` x
5756 -- calcluate derivatives for next step
src/Grenade/Layers/Inception.hs+32−13
@@ -9,13 +9,18 @@
99{-# LANGUAGE ScopedTypeVariables #-}
1010{-|
1111Module : Grenade.Core.Network
12−Description : Core definition a simple neural etwork
12+Description : Inception style parallel convolutional network composition.
1313Copyright : (c) Huw Campbell, 2016-2017
1414License : BSD2
1515Stability : experimental
16+
17+Export an Inception style type, which can be used to build up
18+complex multiconvolution size networks.
1619-}
1720module Grenade.Layers.Inception (
1821 Inception
22+ , InceptionMini
23+ , Resnet
1924 ) where
2025
2126import GHC.TypeLits
@@ -24,25 +29,39 @@ import Grenade.Core
2429import Grenade.Layers.Convolution
2530import Grenade.Layers.Pad
2631import Grenade.Layers.Concat
32+import Grenade.Layers.Merge
33+import Grenade.Layers.Trivial
2734
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.
2947type 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) ]
31− '[ 'D3 rows cols channels, 'D3 (rows -2) (cols -2) (chx + chy + chz) ]
48+ = Network '[ Concat ('D3 rows cols (chx + chy)) (InceptionMini rows cols channels chx chy) ('D3 rows cols chz) (Inception7x7 rows cols channels chz) ]
49+ '[ 'D3 rows cols channels, 'D3 rows cols (chx + chy + chz) ]
3250
33−type InceptionS 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) ]
35− '[ 'D3 rows cols channels, 'D3 (rows -2) (cols -2) (chx + chy) ]
51+type InceptionMini rows cols channels chx chy
52+ = Network '[ Concat ('D3 rows cols chx) (Inception3x3 rows cols channels chx) ('D3 rows cols chy) (Inception5x5 rows cols channels chy) ]
53+ '[ 'D3 rows cols channels, 'D3 rows cols (chx + chy) ]
3654
3755type Inception3x3 rows cols channels chx
38− = Network '[ Convolution channels chx 3 3 1 1 ]
39− '[ 'D3 rows cols channels, 'D3 (rows -2) (cols -2) chx ]
56+ = Network '[ Pad 1 1 1 1, Convolution channels chx 3 3 1 1 ]
57+ '[ 'D3 rows cols channels, 'D3 (rows + 2) (cols + 2) channels, 'D3 rows cols chx ]
4058
4159type Inception5x5 rows cols channels chx
42− = Network '[ Pad 1 1 1 1, Convolution channels chx 5 5 1 1 ]
43− '[ 'D3 rows cols channels, 'D3 (rows + 2) (cols + 2) channels, 'D3 (rows - 2) (cols - 2) chx ]
60+ = Network '[ Pad 2 2 2 2, Convolution channels chx 5 5 1 1 ]
61+ '[ 'D3 rows cols channels, 'D3 (rows + 4) (cols + 4) channels, 'D3 rows cols chx ]
4462
4563type Inception7x7 rows cols channels chx
46− = Network '[ Pad 2 2 2 2, Convolution channels chx 7 7 1 1 ]
47− '[ 'D3 rows cols channels, 'D3 (rows + 4) (cols + 4) channels, 'D3 (rows - 2) (cols - 2) chx ]
64+ = Network '[ Pad 3 3 3 3, Convolution channels chx 7 7 1 1 ]
65+ '[ 'D3 rows cols channels, 'D3 (rows + 6) (cols + 6) channels, 'D3 rows cols chx ]
4866
67+type Resnet branch = Merge Trivial branch
src/Grenade/Layers/Internal/Update.hs+12−12
@@ -1,7 +1,7 @@
11{-# LANGUAGE ForeignFunctionInterface #-}
22module Grenade.Layers.Internal.Update (
3− decendMatrix
4− , decendVector
3+ descendMatrix
4+ , descendVector
55 ) where
66
77import Data.Maybe ( fromJust )
@@ -17,8 +17,8 @@ import qualified Numeric.LinearAlgebra.Devel as U
1717
1818import System.IO.Unsafe ( unsafePerformIO )
1919
20−decendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)
21−decendMatrix rate momentum regulariser weights gradient lastUpdate =
20+descendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)
21+descendMatrix rate momentum regulariser weights gradient lastUpdate =
2222 let (rows, cols) = size weights
2323 len = rows * cols
2424 -- Most gradients come in in ColumnMajor,
@@ -29,7 +29,7 @@ decendMatrix rate momentum regulariser weights gradient lastUpdate =
2929 weights' = flatten . tr . extract $ weights
3030 gradient' = flatten . tr . extract $ gradient
3131 lastUpdate' = flatten . tr . extract $ lastUpdate
32− (vw, vm) = decendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'
32+ (vw, vm) = descendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'
3333
3434 -- Note that it's ColumnMajor, as we did a transpose before
3535 -- using the internal vectors.
@@ -37,17 +37,17 @@ decendMatrix rate momentum regulariser weights gradient lastUpdate =
3737 mm = U.matrixFromVector U.ColumnMajor rows cols vm
3838 in (fromJust . create $ mw, fromJust . create $ mm)
3939
40−decendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)
41−decendVector rate momentum regulariser weights gradient lastUpdate =
40+descendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)
41+descendVector rate momentum regulariser weights gradient lastUpdate =
4242 let len = size weights
4343 weights' = extract weights
4444 gradient' = extract gradient
4545 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'
4747 in (fromJust $ create vw, fromJust $ create vm)
4848
49−decendUnsafe :: Int -> Double -> Double -> Double -> Vector Double -> Vector Double -> Vector Double -> (Vector Double, Vector Double)
50−decendUnsafe len rate momentum regulariser weights gradient lastUpdate =
49+descendUnsafe :: Int -> Double -> Double -> Double -> Vector Double -> Vector Double -> Vector Double -> (Vector Double, Vector Double)
50+descendUnsafe len rate momentum regulariser weights gradient lastUpdate =
5151 unsafePerformIO $ do
5252 outWPtr <- mallocForeignPtrArray len
5353 outMPtr <- mallocForeignPtrArray len
@@ -60,11 +60,11 @@ decendUnsafe len rate momentum regulariser weights gradient lastUpdate =
6060 withForeignPtr lPtr $ \lPtr' ->
6161 withForeignPtr outWPtr $ \outWPtr' ->
6262 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'
6464
6565 return (U.unsafeFromForeignPtr0 outWPtr len, U.unsafeFromForeignPtr0 outMPtr len)
6666
6767foreign import ccall unsafe
68− decend_cpu
68+ descend_cpu
6969 :: Int -> Double -> Double -> Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()
7070
src/Grenade/Layers/Logit.hs+23−9
@@ -3,6 +3,13 @@
33{-# LANGUAGE TypeFamilies #-}
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE MultiParamTypeClasses #-}
6+{-|
7+Module : Grenade.Layers.Logit
8+Description : Sigmoid nonlinear layer
9+Copyright : (c) Huw Campbell, 2016-2017
10+License : BSD2
11+Stability : experimental
12+-}
613module Grenade.Layers.Logit (
714 Logit (..)
815 ) where
@@ -14,6 +21,7 @@ import Data.Singletons
1421import Grenade.Core
1522
1623-- | A Logit layer.
24+--
1725-- A layer which can act between any shape of the same dimension, perfoming an sigmoid function.
1826-- This layer should be used as the output layer of a network for logistic regression (classification)
1927-- problems.
@@ -26,18 +34,24 @@ instance UpdateLayer Logit where
2634 createRandom = return Logit
2735
2836instance (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.
2944 type Tape Logit a b = S a
30− runForwards _ a = (a, logistic a)
31− runBackwards _ a g = ((), logistic' a * g)
45+ runForwards _ a =
46+ let l = sigmoid a
47+ in (l, l)
48+ runBackwards _ l g =
49+ let sigmoid' = l * (1 - l)
50+ in ((), sigmoid' * g)
3251
3352instance Serialize Logit where
3453 put _ = return ()
3554 get = return Logit
3655
37−logistic :: Floating a => a -> a
38−logistic x = 1 / (1 + exp (-x))
39−
40−logistic' :: Floating a => a -> a
41−logistic' x = logix * (1 - logix)
42− where
43− logix = logistic x
56+sigmoid :: Floating a => a -> a
57+sigmoid x = 1 / (1 + exp (-x))
src/Grenade/Layers/Merge.hs+13−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE TypeOperators #-}
@@ -10,7 +11,7 @@
1011{-# LANGUAGE StandaloneDeriving #-}
1112{-|
1213Module : Grenade.Core.Network
13−Description : Core definition a simple neural etwork
14+Description : Merging layer for parallel network composition
1415Copyright : (c) Huw Campbell, 2016-2017
1516License : BSD2
1617Stability : experimental
@@ -19,15 +20,21 @@ module Grenade.Layers.Merge (
1920 Merge (..)
2021 ) where
2122
23+import Data.Serialize
24+
2225import Data.Singletons
2326
27+#if MIN_VERSION_base(4,9,0)
28+import Data.Kind (Type)
29+#endif
30+
2431import Grenade.Core
2532
2633-- | A Merging layer.
2734--
2835-- Similar to Concat layer, except sums the activations instead of creating a larger
2936-- shape.
30−data Merge :: * -> * -> * where
37+data Merge :: Type -> Type -> Type where
3138 Merge :: x -> y -> Merge x y
3239
3340instance (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
5360 let (x', xB) = runBackwards x xTape o
5461 (y', yB) = runBackwards y yTape o
5562 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 #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE ScopedTypeVariables #-}
34{-# LANGUAGE GADTs #-}
@@ -5,6 +6,14 @@
56{-# LANGUAGE TypeFamilies #-}
67{-# LANGUAGE MultiParamTypeClasses #-}
78{-# 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+-}
817module Grenade.Layers.Pad (
918 Pad (..)
1019 ) where
@@ -12,8 +21,9 @@ module Grenade.Layers.Pad (
1221import Data.Maybe
1322import Data.Proxy
1423import Data.Serialize
15−import Data.Singletons.TypeLits
24+
1625import GHC.TypeLits
26+import Data.Kind (Type)
1727
1828import Grenade.Core
1929import Grenade.Layers.Internal.Pad
@@ -22,10 +32,12 @@ import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)
2232import Numeric.LinearAlgebra.Static (extract, create)
2333
2434-- | A padding layer for a neural network.
35+--
36+-- Pads on the X and Y dimension of an image.
2537data Pad :: Nat
2638 -> Nat
2739 -> Nat
28− -> Nat -> * where
40+ -> Nat -> Type where
2941 Pad :: Pad padLeft padTop padRight padBottom
3042
3143instance Show (Pad padLeft padTop padRight padBottom) where
@@ -40,7 +52,7 @@ instance Serialize (Pad l t r b) where
4052 put _ = return ()
4153 get = return Pad
4254
43−-- | A two dimentional image can be padped.
55+-- | A two dimentional image can be padded.
4456instance ( KnownNat padLeft
4557 , KnownNat padTop
4658 , KnownNat padRight
@@ -70,7 +82,7 @@ instance ( KnownNat padLeft
7082 vs = subMatrix (padt, padl) (nrows, ncols) m
7183 in ((), S2D . fromJust . create $ vs)
7284
73−-- | A two dimentional image can be padped.
85+-- | A two dimentional image can be padded.
7486instance ( KnownNat padLeft
7587 , KnownNat padTop
7688 , KnownNat padRight
src/Grenade/Layers/Pooling.hs+14−3
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE ScopedTypeVariables #-}
34{-# LANGUAGE StandaloneDeriving #-}
@@ -6,6 +7,14 @@
67{-# LANGUAGE TypeFamilies #-}
78{-# LANGUAGE MultiParamTypeClasses #-}
89{-# 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+-}
918module Grenade.Layers.Pooling (
1019 Pooling (..)
1120 ) where
@@ -13,8 +22,9 @@ module Grenade.Layers.Pooling (
1322import Data.Maybe
1423import Data.Proxy
1524import Data.Serialize
16−import Data.Singletons.TypeLits
25+
1726import GHC.TypeLits
27+import Data.Kind (Type)
1828
1929import Grenade.Core
2030import Grenade.Layers.Internal.Pooling
@@ -22,20 +32,21 @@ import Grenade.Layers.Internal.Pooling
2232import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)
2333
2434-- | A pooling layer for a neural network.
35+--
2536-- Does a max pooling, looking over a kernel similarly to the convolution network, but returning
2637-- maxarg only. This layer is often used to provide minor amounts of translational invariance.
2738--
2839-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:
2940-- `out = (in - kernel) / stride + 1` for both dimensions.
3041--
31−data Pooling :: Nat -> Nat -> Nat -> Nat -> * where
42+data Pooling :: Nat -> Nat -> Nat -> Nat -> Type where
3243 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns
3344
3445instance Show (Pooling k k' s s') where
3546 show Pooling = "Pooling"
3647
3748instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where
38− type Gradient (Pooling kr kc sr sc) = ()
49+ type Gradient (Pooling kernelRows kernelColumns strideRows strideColumns) = ()
3950 runUpdate _ Pooling _ = Pooling
4051 createRandom = return Pooling
4152
src/Grenade/Layers/Relu.hs+7
@@ -2,6 +2,13 @@
22{-# LANGUAGE TypeOperators #-}
33{-# LANGUAGE TypeFamilies #-}
44{-# LANGUAGE MultiParamTypeClasses #-}
5+{-|
6+Module : Grenade.Layers.Relu
7+Description : Rectifying linear unit layer
8+Copyright : (c) Huw Campbell, 2016-2017
9+License : BSD2
10+Stability : experimental
11+-}
512module Grenade.Layers.Relu (
613 Relu (..)
714 ) where
src/Grenade/Layers/Reshape.hs+11−4
@@ -3,13 +3,20 @@
33{-# LANGUAGE TypeFamilies #-}
44{-# LANGUAGE MultiParamTypeClasses #-}
55{-# 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+-}
614module Grenade.Layers.Reshape (
715 Reshape (..)
816 ) where
917
1018import Data.Serialize
1119
12−import Data.Singletons.TypeLits
1320import GHC.TypeLits
1421
1522import Numeric.LinearAlgebra.Static
@@ -19,9 +26,9 @@ import Grenade.Core
1926
2027-- | Reshape Layer
2128--
22−-- Flattens input down to D1 from either 2D or 3D data.
23−--
24−-- Casts input D1 up to either 2D or 3D data if the shapes are good.
29+-- The Reshape layer can flatten any 2D or 3D image to 1D vector with the
30+-- same number of activations, as well as cast up from 1D to a 2D or 3D
31+-- shape.
2532--
2633-- Can also be used to turn a 3D image with only one channel into a 2D image
2734-- 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 @@
33{-# LANGUAGE TypeFamilies #-}
44{-# LANGUAGE FlexibleInstances #-}
55{-# 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+-}
613module Grenade.Layers.Softmax (
714 Softmax (..)
815 , softmax
@@ -17,8 +24,12 @@ import Grenade.Core
1724import Numeric.LinearAlgebra.Static as LAS
1825
1926-- | A Softmax layer
27+--
2028-- This layer is like a logit layer, but normalises
2129-- 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.
2233data Softmax = Softmax
2334 deriving Show
2435
src/Grenade/Layers/Tanh.hs+10−3
@@ -1,8 +1,15 @@
11{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE TypeFamilies #-}
42{-# LANGUAGE FlexibleInstances #-}
53{-# 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+-}
613module Grenade.Layers.Tanh (
714 Tanh (..)
815 ) where
@@ -13,7 +20,7 @@ import Data.Singletons
1320import Grenade.Core
1421
1522-- | 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.
1724data Tanh = Tanh
1825 deriving Show
1926
src/Grenade/Layers/Trivial.hs+14−3
@@ -3,15 +3,25 @@
33{-# LANGUAGE TypeFamilies #-}
44{-# LANGUAGE MultiParamTypeClasses #-}
55{-# LANGUAGE FlexibleInstances #-}
6+{-|
7+Module : Grenade.Core.Trivial
8+Description : Trivial layer which perfoms no operations on the data
9+Copyright : (c) Huw Campbell, 2016-2017
10+License : BSD2
11+Stability : experimental
12+-}
613module Grenade.Layers.Trivial (
714 Trivial (..)
815 ) where
916
1017import Data.Serialize
1118
12−import Grenade.Core.Network
19+import Grenade.Core
1320
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.
1525data Trivial = Trivial
1626 deriving Show
1727
@@ -25,5 +35,6 @@ instance UpdateLayer Trivial where
2535 createRandom = return Trivial
2636
2737instance (a ~ b) => Layer Trivial a b where
28− runForwards _ = id
38+ type Tape Trivial a b = ()
39+ runForwards _ a = ((), a)
2940 runBackwards _ _ y = ((), y)
src/Grenade/Recurrent.hs+26−6
@@ -1,9 +1,29 @@
11module 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+
316 ) where
417
5−import Grenade.Recurrent.Core.Layer as X
6−import Grenade.Recurrent.Core.Network as X
7−import Grenade.Recurrent.Core.Runner as X
8−import Grenade.Recurrent.Layers.BasicRecurrent as X
9−import Grenade.Recurrent.Layers.LSTM as X
18+import Grenade.Recurrent.Core
19+import Grenade.Recurrent.Layers
20+
21+{- $recurrent
22+There are two ways in which deep learning libraries choose to represent
23+recurrent Neural Networks, as an unrolled graph, or at a first class
24+level. Grenade chooses the latter representation, and provides a network
25+type which is specifically suited for recurrent neural networks.
26+
27+Currently grenade supports two layers, a basic recurrent layer, and an
28+LSTM layer.
29+-}
src/Grenade/Recurrent/Core.hs+6−3
@@ -1,6 +1,9 @@
11module Grenade.Recurrent.Core (
2− module X
2+ module Grenade.Recurrent.Core.Layer
3+ , module Grenade.Recurrent.Core.Network
4+ , module Grenade.Recurrent.Core.Runner
35 ) where
46
5−import Grenade.Recurrent.Core.Layer as X
6−import Grenade.Recurrent.Core.Network as X
7+import Grenade.Recurrent.Core.Layer
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 #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE TypeFamilies #-}
34{-# LANGUAGE MultiParamTypeClasses #-}
@@ -8,7 +9,9 @@ module Grenade.Recurrent.Core.Layer (
89 , RecurrentUpdateLayer (..)
910 ) where
1011
11−import Data.Singletons ( SingI )
12+#if MIN_VERSION_base(4,9,0)
13+import Data.Kind (Type)
14+#endif
1215
1316import Grenade.Core
1417
@@ -17,16 +20,16 @@ import Grenade.Core
1720-- of an extra recurrent data shape.
1821class UpdateLayer x => RecurrentUpdateLayer x where
1922 -- | Shape of data that is passed between each subsequent run of the layer
20− type RecurrentShape x :: Shape
23+ type RecurrentShape x :: Type
2124
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
2326 -- | Wengert Tape
24− type RecTape x i o :: *
27+ type RecTape x i o :: Type
2528 -- | Used in training and scoring. Take the input from the previous
2629 -- 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)
2831 -- | Back propagate a step. Takes the current layer, the input that the
2932 -- layer gave from the input and the back propagated derivatives from
3033 -- the layer above.
3134 -- 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 @@
1010{-# LANGUAGE RankNTypes #-}
1111{-# LANGUAGE BangPatterns #-}
1212{-# LANGUAGE ScopedTypeVariables #-}
13−
14−#if __GLASGOW_HASKELL__ < 800
15−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
16−#endif
13+{-# LANGUAGE UndecidableInstances #-}
1714
1815module Grenade.Recurrent.Core.Network (
1916 Recurrent
@@ -21,37 +18,34 @@ module Grenade.Recurrent.Core.Network (
2118
2219 , RecurrentNetwork (..)
2320 , RecurrentInputs (..)
24− , RecurrentTapes (..)
25− , RecurrentGradients (..)
21+ , RecurrentTape (..)
22+ , RecurrentGradient (..)
2623
2724 , randomRecurrent
28− , runRecurrentNetwork
29− , runRecurrentGradient
25+ , runRecurrent
26+ , runRecurrent'
3027 , applyRecurrentUpdate
3128 ) where
3229
3330
3431import Control.Monad.Random ( MonadRandom )
35−import Data.Singletons ( SingI )
36−import Data.Singletons.Prelude ( Head, Last )
3732import Data.Serialize
38−import qualified Data.Vector.Storable as V
33+
34+import Data.Kind (Type)
3935
4036import Grenade.Core
4137import Grenade.Recurrent.Core.Layer
42−
43−import qualified Numeric.LinearAlgebra as LA
44−import qualified Numeric.LinearAlgebra.Static as LAS
38+import Prelude.Singletons
4539
4640-- | Witness type to say indicate we're building up with a normal feed
4741-- forward layer.
48−data FeedForward :: * -> *
42+data FeedForward :: Type -> Type
4943-- | Witness type to say indicate we're building up with a recurrent layer.
50−data Recurrent :: * -> *
44+data Recurrent :: Type -> Type
5145
5246-- | Type of a recurrent neural network.
5347--
54−-- The [*] type specifies the types of the layers.
48+-- The [Type] type specifies the types of the layers.
5549--
5650-- The [Shape] type specifies the shapes of data passed between the layers.
5751--
@@ -60,7 +54,7 @@ data Recurrent :: * -> *
6054--
6155-- Often, to make the definitions more concise, one will use a type alias
6256-- for these empty data types.
63−data RecurrentNetwork :: [*] -> [Shape] -> * where
57+data RecurrentNetwork :: [Type] -> [Shape] -> Type where
6458 RNil :: SingI i
6559 => RecurrentNetwork '[] '[i]
6660
@@ -79,96 +73,82 @@ infixr 5 :~@>
7973-- | Gradient of a network.
8074--
8175-- Parameterised on the layers of the network.
82−data RecurrentGradients :: [*] -> * where
83− RGNil :: RecurrentGradients '[]
76+data RecurrentGradient :: [Type] -> Type where
77+ RGNil :: RecurrentGradient '[]
8478
8579 (://>) :: UpdateLayer x
86− => [Gradient x]
87− -> RecurrentGradients xs
88− -> RecurrentGradients (phantom x ': xs)
80+ => Gradient x
81+ -> RecurrentGradient xs
82+ -> RecurrentGradient (phantom x ': xs)
8983
9084-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)
9185-- Parameterised on the layers of a Network.
92−data RecurrentInputs :: [*] -> * where
86+data RecurrentInputs :: [Type] -> Type where
9387 RINil :: RecurrentInputs '[]
9488
95− (:~~+>) :: UpdateLayer x
89+ (:~~+>) :: (UpdateLayer x, Fractional (RecurrentInputs xs))
9690 => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)
9791
98− (:~@+>) :: (SingI (RecurrentShape x), RecurrentUpdateLayer x)
99− => !(S (RecurrentShape x)) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)
92+ (:~@+>) :: (Fractional (RecurrentShape x), Fractional (RecurrentInputs xs), RecurrentUpdateLayer x)
93+ => !(RecurrentShape x) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)
10094
10195-- | All the information required to backpropogate
10296-- through time safely.
10397--
10498-- We index on the time step length as well, to ensure
10599-- that that all Tape lengths are the same.
106−data RecurrentTapes :: [*] -> [Shape] -> * where
100+data RecurrentTape :: [Type] -> [Shape] -> Type where
107101 TRNil :: SingI i
108− => RecurrentTapes '[] '[i]
102+ => RecurrentTape '[] '[i]
109103
110− (:\~>) :: [Tape x i h]
111− -> !(RecurrentTapes xs (h ': hs))
112− -> RecurrentTapes (FeedForward x ': xs) (i ': h ': hs)
104+ (:\~>) :: Tape x i h
105+ -> !(RecurrentTape xs (h ': hs))
106+ -> RecurrentTape (FeedForward x ': xs) (i ': h ': hs)
113107
108+ (:\@>) :: RecTape x i h
109+ -> !(RecurrentTape xs (h ': hs))
110+ -> RecurrentTape (Recurrent x ': xs) (i ': h ': hs)
114111
115− (:\@>) :: [RecTape x i h]
116− -> !(RecurrentTapes xs (h ': hs))
117− -> RecurrentTapes (Recurrent x ': xs) (i ': h ': hs)
118112
119−
120−runRecurrentNetwork :: forall shapes layers.
121− RecurrentNetwork layers shapes
122− -> RecurrentInputs layers
123− -> [S (Head shapes)]
124− -> (RecurrentTapes layers shapes, RecurrentInputs layers, [S (Last shapes)])
125−runRecurrentNetwork =
113+runRecurrent :: forall shapes layers.
114+ RecurrentNetwork layers shapes
115+ -> RecurrentInputs layers
116+ -> S (Head shapes)
117+ -> (RecurrentTape layers shapes, RecurrentInputs layers, S (Last shapes))
118+runRecurrent =
126119 go
127120 where
128121 go :: forall js sublayers. (Last js ~ Last shapes)
129122 => RecurrentNetwork sublayers js
130123 -> RecurrentInputs sublayers
131− -> [S (Head js)]
132− -> (RecurrentTapes 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
135− = let tys = runForwards layer <$> xs
136− feedForwardTapes = fst <$> tys
137− forwards = snd <$> tys
124+ -> S (Head js)
125+ -> (RecurrentTape sublayers js, RecurrentInputs sublayers, S (Last js))
126+ go (!layer :~~> n) (() :~~+> nIn) !x
127+ = let (!tape, !forwards) = runForwards layer x
128+
138129 -- recursively run the rest of the network, and get the gradients from above.
139− (newFN, ig, answer) = go n nIn forwards
140− in (feedForwardTapes :\~> newFN, () :~~+> ig, answer)
130+ (!newFN, !ig, !answer) = go n nIn forwards
131+ in (tape :\~> newFN, () :~~+> ig, answer)
141132
142133 -- This is a recurrent layer, so we need to do a scan, first input to last, providing
143134 -- the recurrent shape output to the next layer.
144− go (layer :~@> n) (recIn :~@+> nIn) !xs
145− = let (recOut, tys) = goR layer recIn xs
146− recurrentTapes = fst <$> tys
147− forwards = snd <$> tys
148−
135+ go (layer :~@> n) (recIn :~@+> nIn) !x
136+ = let (tape, shape, forwards) = runRecurrentForwards layer recIn x
149137 (newFN, ig, answer) = go n nIn forwards
150− in (recurrentTapes :\@> newFN, recOut :~@+> ig, answer)
138+ in (tape :\@> newFN, shape :~@+> ig, answer)
151139
152140 -- Handle the output layer, bouncing the derivatives back down.
153141 -- We may not have a target for each example, so when we don't use 0 gradient.
154142 go RNil RINil !x
155143 = (TRNil, RINil, x)
156144
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.
166− RecurrentNetwork layers shapes
167− -> RecurrentTapes layers shapes
168− -> RecurrentInputs layers
169− -> [S (Last shapes)]
170− -> (RecurrentGradients layers, RecurrentInputs layers, [S (Head shapes)])
171−runRecurrentGradient net tapes r o =
145+runRecurrent' :: forall layers shapes.
146+ RecurrentNetwork layers shapes
147+ -> RecurrentTape layers shapes
148+ -> RecurrentInputs layers
149+ -> S (Last shapes)
150+ -> (RecurrentGradient layers, RecurrentInputs layers, S (Head shapes))
151+runRecurrent' net tapes r o =
172152 go net tapes r
173153 where
174154 -- We have to be careful regarding the direction of the lists
@@ -176,51 +156,41 @@ runRecurrentGradient net tapes r o =
176156 -- through time.
177157 go :: forall js ss. (Last js ~ Last shapes)
178158 => RecurrentNetwork ss js
179− -> RecurrentTapes ss js
159+ -> RecurrentTape ss js
180160 -> RecurrentInputs ss
181− -> (RecurrentGradients ss, RecurrentInputs ss, [S (Head js)])
161+ -> (RecurrentGradient ss, RecurrentInputs ss, S (Head js))
182162 -- This is a simple non-recurrent layer
183− -- Run the rest of the network, then fmap the tapes and gradients
184− go (layer :~~> n) (feedForwardTapes :\~> nTapes) (() :~~+> nRecs) =
185− let (gradients, rins, feed) = go n nTapes nRecs
186− backs = uncurry (runBackwards layer) <$> zip (reverse feedForwardTapes) feed
187− in ((fst <$> backs) ://> gradients, () :~~+> rins, snd <$> backs)
163+ -- Run the rest of the network, update with the tapes and gradients
164+ go (!layer :~~> n) (!tape :\~> nTapes) (() :~~+> nRecs) =
165+ let (!gradients, !rins, !feed) = go n nTapes nRecs
166+ (!grad, !back) = runBackwards layer tape feed
167+ in (grad ://> gradients, () :~~+> rins, back)
188168
189169 -- This is a recurrent layer
190170 -- Run the rest of the network, scan over the tapes in reverse
191− go (layer :~@> n) (recurrentTapes :\@> nTapes) (recGrad :~@+> nRecs) =
192− let (gradients, rins, feed) = go n nTapes nRecs
193− backExamples = zip (reverse recurrentTapes) feed
194− (rg, backs) = goX layer recGrad backExamples
195− in ((fst <$> backs) ://> gradients, rg :~@+> rins, snd <$> backs)
171+ go (!layer :~@> n) (!tape :\@> nTapes) (!recGrad :~@+> nRecs) =
172+ let (!gradients, !rins, !feed) = go n nTapes nRecs
173+ (!grad, !sidegrad, !back) = runRecurrentBackwards layer tape recGrad feed
174+ in (grad ://> gradients, sidegrad :~@+> rins, back)
196175
197176 -- End of the road, so we reflect the given gradients backwards.
198177 -- Crucially, we reverse the list, so it's backwards in time as
199178 -- well.
200− go RNil TRNil RINil
201− = (RGNil, RINil, reverse 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, [])
179+ go !RNil !TRNil !RINil
180+ = (RGNil, RINil, o)
211181
212182-- | Apply a batch of gradients to the network
213183-- Uses runUpdates which can be specialised for
214184-- a layer.
215185applyRecurrentUpdate :: LearningParameters
216186 -> RecurrentNetwork layers shapes
217− -> RecurrentGradients layers
187+ -> RecurrentGradient layers
218188 -> RecurrentNetwork layers shapes
219189applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)
220− = runUpdates rate layer gradient :~~> applyRecurrentUpdate rate rest grest
190+ = runUpdate rate layer gradient :~~> applyRecurrentUpdate rate rest grest
221191
222192applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)
223− = runUpdates rate layer gradient :~@> applyRecurrentUpdate rate rest grest
193+ = runUpdate rate layer gradient :~@> applyRecurrentUpdate rate rest grest
224194
225195applyRecurrentUpdate _ RNil RGNil
226196 = RNil
@@ -236,26 +206,25 @@ instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recu
236206
237207-- | A network can easily be created by hand with (:~~>) and (:~@>), but an easy way to initialise a random
238208-- 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
240210 -- | 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)
242212
243213instance SingI i => CreatableRecurrent '[] '[i] where
244214 randomRecurrent =
245− return (RNil, RINil)
215+ return RNil
246216
247217instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where
248218 randomRecurrent = do
249219 thisLayer <- createRandom
250− (rest, resti) <- randomRecurrent
251− return (thisLayer :~~> rest, () :~~+> resti)
220+ rest <- randomRecurrent
221+ return (thisLayer :~~> rest)
252222
253223instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where
254224 randomRecurrent = do
255225 thisLayer <- createRandom
256− thisShape <- randomOfShape
257− (rest, resti) <- randomRecurrent
258− return (thisLayer :~@> rest, thisShape :~@+> resti)
226+ rest <- randomRecurrent
227+ return (thisLayer :~@> rest)
259228
260229-- | Add very simple serialisation to the recurrent network
261230instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where
@@ -274,23 +243,13 @@ instance (Serialize (RecurrentInputs '[])) where
274243 put _ = return ()
275244 get = return RINil
276245
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
278247 put ( () :~~+> rest) = put rest
279248 get = ( () :~~+> ) <$> get
280249
281−instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where
282− put ( i :~@+> rest ) = do
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
291− Just i <- fromStorable . V.fromList <$> getListOf get
292− rest <- get
293− return ( i :~@+> rest)
250+instance (Serialize (RecurrentShape x), Fractional (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where
251+ put ( i :~@+> rest ) = put i >> put rest
252+ get = (:~@+>) <$> get <*> get
294253
295254
296255-- Num instance for `RecurrentInputs layers`
@@ -311,7 +270,7 @@ instance (Num (RecurrentInputs '[])) where
311270 signum _ = RINil
312271 fromInteger _ = RINil
313272
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
315274 (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)
316275 (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)
317276 (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)
@@ -319,10 +278,51 @@ instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Fee
319278 signum (() :~~+> x) = () :~~+> signum x
320279 fromInteger x = () :~~+> fromInteger x
321280
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
323282 (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')
324283 (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')
325284 (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')
326285 abs (x :~@+> x') = abs x :~@+> abs x'
327286 signum (x :~@+> x') = signum x :~@+> signum x'
328287 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 @@
33{-# LANGUAGE DataKinds #-}
44{-# LANGUAGE ScopedTypeVariables #-}
55{-# LANGUAGE TypeOperators #-}
6−{-# LANGUAGE CPP #-}
76{-# LANGUAGE TypeFamilies #-}
87{-# LANGUAGE FlexibleContexts #-}
98{-# LANGUAGE RankNTypes #-}
10−{-# LANGUAGE RecordWildCards #-}
11−
12−#if __GLASGOW_HASKELL__ < 800
13−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
14−#endif
159
1610module Grenade.Recurrent.Core.Runner (
17− trainRecurrent
18− , runRecurrent
11+ runRecurrentExamples
12+ , runRecurrentBackprop
1913 , backPropagateRecurrent
14+ , trainRecurrent
15+
16+ , RecurrentGradients
2017 ) where
2118
22−import Data.Singletons.Prelude
19+import Data.List ( foldl' )
2320import Grenade.Core
2421
25−import Grenade.Recurrent.Core.Layer
2622import 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+
2755
2856-- | 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))
3058 => RecurrentNetwork layers shapes
3159 -> RecurrentInputs layers
3260 -> [(S (Head shapes), Maybe (S (Last shapes)))]
3361 -> (RecurrentGradients layers, RecurrentInputs layers)
3462backPropagateRecurrent network recinputs examples =
35− let (tapes, _, guesses) = runRecurrentNetwork network recinputs inputs
63+ let (outForwards, _) = runRecurrentExamples network recinputs inputs
3664
37− backPropagations = zipWith makeError guesses targets
65+ backPropagations = zipWith makeError outForwards targets
3866
39− (gradients, input', _) = runRecurrentGradient network tapes 0 backPropagations
67+ (outBackwards, input') = runRecurrentBackprop network 0 backPropagations
4068
69+ gradients = fmap fst outBackwards
4170 in (gradients, input')
4271
4372 where
@@ -45,12 +74,12 @@ backPropagateRecurrent network recinputs examples =
4574 inputs = fst <$> examples
4675 targets = snd <$> examples
4776
48− makeError :: S (Last shapes) -> Maybe (S (Last shapes)) -> S (Last shapes)
49− makeError _ Nothing = 0
50− makeError y (Just t) = y - t
77+ makeError :: (x, S (Last shapes)) -> Maybe (S (Last shapes)) -> (x, S (Last shapes))
78+ makeError (x, _) Nothing = (x, 0)
79+ makeError (x, y) (Just t) = (x, y - t)
5180
5281
53−trainRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))
82+trainRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))
5483 => LearningParameters
5584 -> RecurrentNetwork layers shapes
5685 -> RecurrentInputs layers
@@ -61,35 +90,21 @@ trainRecurrent rate network recinputs examples =
6190
6291 newInputs = updateRecInputs rate recinputs recinputs'
6392
64− newNetwork = applyRecurrentUpdate rate network gradients
93+ newNetwork = foldl' (applyRecurrentUpdate rate) network gradients
6594
6695 in (newNetwork, newInputs)
6796
68−updateRecInputs :: LearningParameters
97+updateRecInputs :: Fractional (RecurrentInputs sublayers)
98+ => LearningParameters
6999 -> RecurrentInputs sublayers
70100 -> RecurrentInputs sublayers
71101 -> RecurrentInputs sublayers
72102
73−updateRecInputs l@LearningParameters {..} (() :~~+> xs) (() :~~+> ys)
74− = () :~~+> updateRecInputs l xs ys
103+updateRecInputs lp (() :~~+> xs) (() :~~+> ys)
104+ = () :~~+> updateRecInputs lp xs ys
75105
76−updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)
77− = (realToFrac (1 - learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys
106+updateRecInputs lp (x :~@+> xs) (y :~@+> ys)
107+ = (realToFrac (1 - learningRate lp * learningRegulariser lp) * x - realToFrac (learningRate lp) * y) :~@+> updateRecInputs lp xs ys
78108
79109updateRecInputs _ RINil RINil
80110 = 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 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE DataKinds #-}
33{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE RecordWildCards #-}
54{-# LANGUAGE TypeOperators #-}
65{-# LANGUAGE TypeFamilies #-}
76{-# LANGUAGE MultiParamTypeClasses #-}
87{-# LANGUAGE FlexibleContexts #-}
98{-# LANGUAGE UndecidableInstances #-}
109
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
1510module Grenade.Recurrent.Layers.BasicRecurrent (
1611 BasicRecurrent (..)
1712 , randomBasicRecurrent
@@ -21,7 +16,8 @@ module Grenade.Recurrent.Layers.BasicRecurrent (
2116
2217import Control.Monad.Random ( MonadRandom, getRandom )
2318
24−import Data.Singletons.TypeLits
19+
20+import Data.Kind (Type)
2521
2622import Numeric.LinearAlgebra.Static
2723
@@ -32,7 +28,7 @@ import Grenade.Recurrent.Core
3228
3329data BasicRecurrent :: Nat -- Input layer size
3430 -> Nat -- Output layer size
35− -> * where
31+ -> Type where
3632 BasicRecurrent :: ( KnownNat input
3733 , KnownNat output
3834 , KnownNat matrixCols
@@ -45,7 +41,7 @@ data BasicRecurrent :: Nat -- Input layer size
4541
4642data BasicRecurrent' :: Nat -- Input layer size
4743 -> Nat -- Output layer size
48− -> * where
44+ -> Type where
4945 BasicRecurrent' :: ( KnownNat input
5046 , KnownNat output
5147 , KnownNat matrixCols
@@ -60,18 +56,18 @@ instance Show (BasicRecurrent i o) where
6056instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where
6157 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)
6258
63− runUpdate LearningParameters {..} (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =
64− let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient
59+ runUpdate lp (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =
60+ let newBiasMomentum = konst (learningMomentum lp) * oldBiasMomentum - konst (learningRate lp) * biasGradient
6561 newBias = oldBias + newBiasMomentum
66− newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient
67− regulariser = konst (learningRegulariser * learningRate) * oldActivations
62+ newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient
63+ regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations
6864 newActivations = oldActivations + newMomentum - regulariser
6965 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum
7066
7167 createRandom = randomBasicRecurrent
7268
7369instance (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)
7571
7672instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where
7773
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 #-}
21{-# LANGUAGE CPP #-}
2+{-# LANGUAGE BangPatterns #-}
33{-# LANGUAGE DataKinds #-}
44{-# LANGUAGE GADTs #-}
55{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE RecordWildCards #-}
76{-# LANGUAGE TypeOperators #-}
87{-# LANGUAGE TypeFamilies #-}
98{-# LANGUAGE MultiParamTypeClasses #-}
@@ -11,11 +10,6 @@
1110{-# LANGUAGE ViewPatterns #-}
1211{-# LANGUAGE ScopedTypeVariables #-}
1312
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−
1913module Grenade.Recurrent.Layers.LSTM (
2014 LSTM (..)
2115 , LSTMWeights (..)
@@ -27,7 +21,7 @@ import Control.Monad.Random ( MonadRandom, getRandom )
2721-- import Data.List ( foldl1' )
2822import Data.Proxy
2923import Data.Serialize
30−import Data.Singletons.TypeLits
24+import Data.Kind (Type)
3125
3226import qualified Numeric.LinearAlgebra as LA
3327import Numeric.LinearAlgebra.Static
@@ -35,6 +29,7 @@ import Numeric.LinearAlgebra.Static
3529import Grenade.Core
3630import Grenade.Recurrent.Core
3731import Grenade.Layers.Internal.Update
32+import GHC.TypeLits
3833
3934
4035-- | Long Short Term Memory Recurrent unit
@@ -42,14 +37,14 @@ import Grenade.Layers.Internal.Update
4237-- This is a Peephole formulation, so the recurrent shape is
4338-- just the cell state, the previous output is not held or used
4439-- at all.
45−data LSTM :: Nat -> Nat -> * where
40+data LSTM :: Nat -> Nat -> Type where
4641 LSTM :: ( KnownNat input
4742 , KnownNat output
4843 ) => !(LSTMWeights input output) -- Weights
4944 -> !(LSTMWeights input output) -- Momentums
5045 -> LSTM input output
5146
52−data LSTMWeights :: Nat -> Nat -> * where
47+data LSTMWeights :: Nat -> Nat -> Type where
5348 LSTMWeights :: ( KnownNat input
5449 , KnownNat output
5550 ) => {
@@ -76,7 +71,7 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where
7671
7772 -- Run the update function for each group matrix/vector of weights, momentums and gradients.
7873 -- 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 =
8075 let (wf, wf') = u lstmWf w m g
8176 (uf, uf') = u lstmUf w m g
8277 (bf, bf') = v lstmBf w m g
@@ -93,11 +88,11 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where
9388 -- Utility function for updating with the momentum, gradients, and weights.
9489 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))
9590 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
9792
9893 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))
9994 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
10196
10297 -- There's a lot of updates here, so to try and minimise the number of data copies
10398 -- we'll create a mutable bucket for each.
@@ -129,27 +124,33 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where
129124instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where
130125 -- The recurrent shape is the same size as the output.
131126 -- 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)
133128
134129instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where
135130
136− type RecTape (LSTM i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))
131+ -- The tape stores essentially every variable we calculate,
132+ -- so we don't have to run any forwards component again.
133+ type RecTape (LSTM i o) ('D1 i) ('D1 o) = (R o, R i, R o, R o, R o, R o, R o, R o, R o, R o, R o)
137134 -- Forward propagation for the LSTM layer.
138135 -- 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) =
140137 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
142140 -- 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
144143 -- 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
146146 -- 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
148149 -- Cell state
149150 c_t = f_t * cell + i_t * c_x
150151 -- Output (it's sometimes recommended to use tanh c_t)
151152 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)
153154
154155 -- Run a backpropogation step for an LSTM layer.
155156 -- 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
157158 --
158159 -- There's a test version using the AD library without hmatrix in the test
159160 -- suite. These should match always.
160− runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (S1D cell, S1D input) (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
161+ runRecurrentBackwards (LSTM lw _) (cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t) (S1D cellGrad) (S1D h_t') =
162+ let -- Reverse Mode AD Derivitives
183163 c_t' = h_t' * o_t + cellGrad
184164
185165 f_t' = c_t' * cell
@@ -195,8 +175,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w
195175 c_s' = tanh' c_s * c_x'
196176
197177 -- 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
199− input' = tr lstmWf #> f_s' + tr lstmWo #> o_s' + tr lstmWi #> i_s' + tr lstmWc #> c_s'
178+ cell' = tr (lstmUf lw) #> f_s' + tr (lstmUo lw) #> o_s' + tr (lstmUi lw) #> i_s' + c_t' * f_t
179+ input' = tr (lstmWf lw) #> f_s' + tr (lstmWo lw) #> o_s' + tr (lstmWi lw) #> i_s' + tr (lstmWc lw) #> c_s'
200180
201181 -- Calculate the gradient Matricies for the input
202182 lstmWf' = f_s' `outer` input
@@ -241,7 +221,8 @@ randomLSTM = do
241221
242222-- | Maths
243223--
244−-- TODO: move to not here
224+-- TODO: Move to not here
225+-- Optimise backwards derivative
245226sigmoid :: Floating a => a -> a
246227sigmoid x = 1 / (1 + exp (-x))
247228
@@ -254,44 +235,34 @@ tanh' :: (Floating a) => a -> a
254235tanh' t = 1 - s ^ (2 :: Int) where s = tanh t
255236
256237instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where
257− put (LSTM LSTMWeights {..} _) = do
258− u lstmWf
259− u lstmUf
260− v lstmBf
261− u lstmWi
262− u lstmUi
263− v lstmBi
264− u lstmWo
265− u lstmUo
266− v lstmBo
267− u lstmWc
268− v lstmBc
269− where
270− u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)
271− u = putListOf put . LA.toList . LA.flatten . extract
272− v :: forall a. (KnownNat a) => Putter (R a)
273− v = putListOf put . LA.toList . extract
238+ put (LSTM lw _) = do
239+ u (lstmWf lw)
240+ u (lstmUf lw)
241+ v (lstmBf lw)
242+ u (lstmWi lw)
243+ u (lstmUi lw)
244+ v (lstmBi lw)
245+ u (lstmWo lw)
246+ u (lstmUo lw)
247+ v (lstmBo lw)
248+ u (lstmWc lw)
249+ v (lstmBc lw)
250+ where
251+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)
252+ u = putListOf put . LA.toList . LA.flatten . extract
253+ v :: forall a. (KnownNat a) => Putter (R a)
254+ v = putListOf put . LA.toList . extract
274255
275256 get = do
276− lstmWf <- u
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)
288− where
289− u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)
290− 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
292− v :: forall a. (KnownNat a) => Get (R a)
293− v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get
294−
295− w0 = konst 0
296− u0 = konst 0
297− v0 = konst 0
257+ w <- LSTMWeights <$> u <*> u <*> v <*> u <*> u <*> v <*> u <*> u <*> v <*> u <*> v
258+ return $ LSTM w (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)
259+ where
260+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)
261+ u = let f = fromIntegral $ natVal (Proxy :: Proxy a)
262+ in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get
263+ v :: forall a. (KnownNat a) => Get (R a)
264+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get
265+
266+ w0 = konst 0
267+ u0 = konst 0
268+ v0 = konst 0
src/Grenade/Utils/OneHot.hs+6−5
@@ -22,7 +22,6 @@ import Data.Map ( Map )
2222import qualified Data.Map as M
2323
2424import Data.Proxy
25−import Data.Singletons.TypeLits
2625
2726import Data.Vector ( Vector )
2827import qualified Data.Vector as V
@@ -31,6 +30,7 @@ import qualified Data.Vector.Storable as VS
3130import Numeric.LinearAlgebra ( maxIndex )
3231import Numeric.LinearAlgebra.Devel
3332import Numeric.LinearAlgebra.Static
33+import GHC.TypeLits
3434
3535import Grenade.Core.Shape
3636
@@ -52,15 +52,16 @@ oneHot hot =
5252
5353-- | Create a one hot map from any enumerable.
5454-- Returns a map, and the ordered list for the reverse transformation
55−hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Maybe (Map a Int, Vector a)
55+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Either String (Map a Int, Vector a)
5656hotMap n as =
5757 let len = fromIntegral $ natVal n
5858 uniq = [ c | (c:_) <- group $ sort as]
5959 hotl = length uniq
60− in if hotl <= len
60+ in if hotl == len
6161 then
62− Just (M.fromList $ zip uniq [0..], V.fromList uniq)
63− else Nothing
62+ Right (M.fromList $ zip uniq [0..], V.fromList uniq)
63+ else
64+ Left ("Couldn't create hotMap of size " ++ show len ++ " from vector with " ++ show hotl ++ " unique characters")
6465
6566-- | From a map and value, create a 1D Shape
6667-- 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 #-}
12{-# LANGUAGE TemplateHaskell #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE GADTs #-}
@@ -15,15 +16,21 @@ import Data.Singletons ()
1516import GHC.TypeLits
1617import GHC.TypeLits.Witnesses
1718
19+#if MIN_VERSION_base(4,9,0)
20+import Data.Kind (Type)
21+#endif
22+
1823import Grenade.Core
1924import Grenade.Layers.Convolution
2025
21−import Disorder.Jack
26+import Hedgehog
27+import qualified Hedgehog.Gen as Gen
2228
23−import Test.Jack.Hmatrix
24−import Test.Jack.TypeLits
29+import Test.Hedgehog.Hmatrix
30+import Test.Hedgehog.TypeLits
31+import Test.Hedgehog.Compat
2532
26−data OpaqueConvolution :: * where
33+data OpaqueConvolution :: Type where
2734 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution
2835
2936instance Show OpaqueConvolution where
@@ -37,10 +44,10 @@ genConvolution :: ( KnownNat channels
3744 , KnownNat strideColumns
3845 , KnownNat kernelFlattened
3946 , kernelFlattened ~ (kernelRows * kernelColumns * channels)
40− ) => Jack (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)
47+ ) => Gen (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)
4148genConvolution = Convolution <$> uniformSample <*> uniformSample
4249
43−genOpaqueOpaqueConvolution :: Jack OpaqueConvolution
50+genOpaqueOpaqueConvolution :: Gen OpaqueConvolution
4451genOpaqueOpaqueConvolution = do
4552 channels <- genNat
4653 filters <- genNat
@@ -56,17 +63,17 @@ genOpaqueOpaqueConvolution = do
5663 p2 = natDict pkc
5764 p3 = natDict pch
5865 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
6072
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
6673
67−prop_conv_net =
68− gamble genOpaqueOpaqueConvolution $ \onet ->
69− (case onet of
74+prop_conv_net = property $
75+ blindForAll genOpaqueOpaqueConvolution >>= \onet ->
76+ case onet of
7077 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->
7178 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]
7279 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
@@ -74,15 +81,15 @@ prop_conv_net =
7481 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)
7582 sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)
7683
77− in gamble (elements (ok sr kr)) $ \er ->
78− gamble (elements (ok sc kc)) $ \ec ->
84+ in forAll (Gen.element (ok sr kr)) >>= \er ->
85+ forAll (Gen.element (ok sc kc)) >>= \ec ->
7986 let rr = ((er - kr) `div` sr) + 1
8087 rc = ((ec - kc) `div` sc) + 1
8188 Just er' = someNatVal er
8289 Just ec' = someNatVal ec
8390 Just rr' = someNatVal rr
8491 Just rc' = someNatVal rc
85− in (case (er', ec', rr', rc') of
92+ in case (er', ec', rr', rc') of
8693 ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->
8794 case ( natDict pinr %* natDict (Proxy :: Proxy channels)
8895 , natDict pour %* natDict (Proxy :: Proxy filters)
@@ -90,14 +97,12 @@ prop_conv_net =
9097 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
9198 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
9299 (Dict, Dict, Dict, Dict) ->
93− gamble (S3D <$> uniformSample) $ \(input :: S ('D3 inRows inCols channels)) ->
100+ blindForAll (S3D <$> uniformSample) >>= \(input :: S ('D3 inRows inCols channels)) ->
94101 let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input
95102 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))
96103 = runBackwards convLayer tape output
97− in backed `seq` True
98− ) :: Property
99− ) :: Property
104+ in backed `seq` success
105+
100106
101−return []
102107tests :: IO Bool
103−tests = $quickCheckAll
108+tests = checkParallel $$(discover)
test/Test/Grenade/Layers/FullyConnected.hs+21−17
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE BangPatterns #-}
23{-# LANGUAGE TemplateHaskell #-}
34{-# LANGUAGE DataKinds #-}
@@ -12,24 +13,28 @@ import Data.Singletons ()
1213
1314import GHC.TypeLits
1415
16+#if MIN_VERSION_base(4,9,0)
17+import Data.Kind (Type)
18+#endif
19+
1520import Grenade.Core
1621import Grenade.Layers.FullyConnected
1722
18−import Disorder.Jack
19−
20−import Test.Jack.Hmatrix
23+import Hedgehog
2124
25+import Test.Hedgehog.Compat
26+import Test.Hedgehog.Hmatrix
2227
23−data OpaqueFullyConnected :: * where
28+data OpaqueFullyConnected :: Type where
2429 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected
2530
2631instance Show OpaqueFullyConnected where
2732 show (OpaqueFullyConnected n) = show n
2833
29−genOpaqueFullyConnected :: Jack OpaqueFullyConnected
34+genOpaqueFullyConnected :: Gen OpaqueFullyConnected
3035genOpaqueFullyConnected = do
31− input :: Integer <- choose (2, 100)
32− output :: Integer <- choose (1, 100)
36+ input :: Integer <- choose 2 100
37+ output :: Integer <- choose 1 100
3338 let Just input' = someNatVal input
3439 let Just output' = someNatVal output
3540 case (input', output') of
@@ -41,14 +46,13 @@ genOpaqueFullyConnected = do
4146 return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')
4247
4348prop_fully_connected_forwards :: Property
44−prop_fully_connected_forwards =
45− gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->
46− gamble (S1D <$> randomVector) $ \(input :: S ('D1 i)) ->
47− let (tape, output :: S ('D1 o)) = runForwards fclayer input
48− backed :: (Gradient (FullyConnected i o), S ('D1 i))
49− = runBackwards fclayer tape output
50− in backed `seq` True
51−
52−return []
49+prop_fully_connected_forwards = property $ do
50+ OpaqueFullyConnected (fclayer :: FullyConnected i o) <- blindForAll genOpaqueFullyConnected
51+ input :: S ('D1 i) <- blindForAll (S1D <$> randomVector)
52+ let (tape, output :: S ('D1 o)) = runForwards fclayer input
53+ backed :: (Gradient (FullyConnected i o), S ('D1 i))
54+ = runBackwards fclayer tape output
55+ backed `seq` success
56+
5357tests :: 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
1212
1313import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
1414
15−import Disorder.Jack
15+import Hedgehog
16+import qualified Hedgehog.Gen as Gen
17+import qualified Hedgehog.Range as Range
1618
1719import qualified Test.Grenade.Layers.Internal.Reference as Reference
20+import Test.Hedgehog.Compat
1821
1922prop_im2col_col2im_symmetrical_with_kernel_stride =
2023 let factors n = [x | x <- [1..n], n `mod` x == 0]
21− in gamble (choose (2, 100)) $ \height ->
22− gamble (choose (2, 100)) $ \width ->
23− gamble ((height `div`) <$> elements (factors height)) $ \kernel_h ->
24− gamble ((width `div`) <$> elements (factors width)) $ \kernel_w ->
25− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
26− let input' = (height >< width) input
27− stride_h = kernel_h
28− stride_w = kernel_w
29− out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input'
30− in input' === out
24+ in property $ do
25+ height <- forAll $ choose 2 100
26+ width <- forAll $ choose 2 100
27+ kernel_h <- forAll $ (height `div`) <$> Gen.element (factors height)
28+ kernel_w <- forAll $ (width `div`) <$> Gen.element (factors width)
29+ input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)
30+
31+ let stride_h = kernel_h
32+ let stride_w = kernel_w
33+ let out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input
34+ input === out
3135
3236prop_im2col_col2im_behaves_as_reference =
3337 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
34− in gamble (choose (2, 100)) $ \height ->
35− gamble (choose (2, 100)) $ \width ->
36− gamble (choose (2, height - 1)) $ \kernel_h ->
37− gamble (choose (2, width - 1)) $ \kernel_w ->
38− gamble (elements (ok height kernel_h)) $ \stride_h ->
39− gamble (elements (ok width kernel_w)) $ \stride_w ->
40− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
41− let input' = (height >< width) input
42− outFast = im2col kernel_h kernel_w stride_h stride_w input'
43− retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast
44−
45− outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input'
46− retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference
47− in outFast === outReference .&&. retFast === retReference
48−
49−
50−return []
38+ in property $ do
39+ height <- forAll (choose 2 100)
40+ width <- forAll (choose 2 100)
41+ kernel_h <- forAll (choose 2 (height - 1))
42+ kernel_w <- forAll (choose 2 (width - 1))
43+ stride_h <- forAll (Gen.element (ok height kernel_h))
44+ stride_w <- forAll (Gen.element (ok width kernel_w))
45+ input <- forAll ((height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100))
46+
47+ let outFast = im2col kernel_h kernel_w stride_h stride_w input
48+ let retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast
49+
50+ let outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input
51+ let retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference
52+
53+ outFast === outReference
54+ retFast === retReference
55+
5156tests :: 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
1212
1313import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
1414
15−import Disorder.Jack
15+import Hedgehog
16+import qualified Hedgehog.Gen as Gen
17+import qualified Hedgehog.Range as Range
1618
1719import qualified Test.Grenade.Layers.Internal.Reference as Reference
20+import Test.Hedgehog.Compat
1821
1922prop_poolForwards_poolBackwards_behaves_as_reference =
2023 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
2124 output extent kernel stride = (extent - kernel) `div` stride + 1
22− in gamble (choose (2, 100)) $ \height ->
23− gamble (choose (2, 100)) $ \width ->
24− gamble (choose (1, height - 1)) $ \kernel_h ->
25− gamble (choose (1, width - 1)) $ \kernel_w ->
26− gamble (elements (ok height kernel_h)) $ \stride_h ->
27− gamble (elements (ok width kernel_w)) $ \stride_w ->
28− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
29− let input' = (height >< width) input
30− outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'
31− retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast
32−
33− outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'
34− retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference
35− in outFast === outReference .&&. retFast === retReference
36−
37−return []
25+ in property $ do
26+ height <- forAll $ choose 2 100
27+ width <- forAll $ choose 2 100
28+ kernel_h <- forAll $ choose 1 (height - 1)
29+ kernel_w <- forAll $ choose 1 (width - 1)
30+ stride_h <- forAll $ Gen.element (ok height kernel_h)
31+ stride_w <- forAll $ Gen.element (ok width kernel_w)
32+ input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)
33+
34+ let outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input
35+ let retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input outFast
36+
37+ let outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input
38+ let retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input outReference
39+
40+ outFast === outReference
41+ retFast === retReference
42+
43+
3844tests :: IO Bool
39−tests = $quickCheckAll
45+tests = checkParallel $$(discover)
test/Test/Grenade/Layers/Nonlinear.hs+13−36
@@ -1,5 +1,4 @@
11{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE CPP #-}
32{-# LANGUAGE TemplateHaskell #-}
43{-# LANGUAGE DataKinds #-}
54{-# LANGUAGE KindSignatures #-}
@@ -11,67 +10,45 @@ module Test.Grenade.Layers.Nonlinear where
1110
1211import Data.Singletons
1312
14−#if __GLASGOW_HASKELL__ < 800
15−import Data.Proxy
16−#endif
17−
1813import Grenade
19−import GHC.TypeLits
2014
21−import Disorder.Jack
15+import Hedgehog
2216
23−import Test.Jack.Hmatrix
24−import Test.Jack.TypeLits
17+import Test.Hedgehog.Compat
18+import Test.Hedgehog.Hmatrix
19+import Test.Hedgehog.TypeLits
2520
2621import Numeric.LinearAlgebra.Static ( norm_Inf )
2722
2823prop_sigmoid_grad :: Property
29−prop_sigmoid_grad =
30− gambleDisplay (const "Shape") genShape $ \case
24+prop_sigmoid_grad = property $
25+ forAllWith rss genShape >>= \case
3126 (SomeSing (r :: Sing s)) ->
3227 withSingI r $
33− gamble genOfShape $ \(ds :: S s) ->
28+ blindForAll genOfShape >>= \(ds :: S s) ->
3429 let (tape, f :: S s) = runForwards Logit ds
3530 ((), ret :: S s) = runBackwards Logit tape (1 :: S s)
3631 (_, numer :: S s) = runForwards Logit (ds + 0.0001)
3732 numericalGradient = (numer - f) * 10000
38− in counterexample (show numericalGradient ++ show ret)
39− ((case numericalGradient - ret of
33+ in assert ((case numericalGradient - ret of
4034 (S1D x) -> norm_Inf x < 0.0001
4135 (S2D x) -> norm_Inf x < 0.0001
4236 (S3D x) -> norm_Inf x < 0.0001) :: Bool)
4337
4438prop_tanh_grad :: Property
45−prop_tanh_grad =
46− gambleDisplay (const "Shape") genShape $ \case
39+prop_tanh_grad = property $
40+ forAllWith rss genShape >>= \case
4741 (SomeSing (r :: Sing s)) ->
4842 withSingI r $
49− gamble genOfShape $ \(ds :: S s) ->
43+ blindForAll genOfShape >>= \(ds :: S s) ->
5044 let (tape, f :: S s) = runForwards Tanh ds
5145 ((), ret :: S s) = runBackwards Tanh tape (1 :: S s)
5246 (_, numer :: S s) = runForwards Tanh (ds + 0.0001)
5347 numericalGradient = (numer - f) * 10000
54− in counterexample (show numericalGradient ++ show ret)
55− ((case numericalGradient - ret of
48+ in assert ((case numericalGradient - ret of
5649 (S1D x) -> norm_Inf x < 0.001
5750 (S2D x) -> norm_Inf x < 0.001
5851 (S3D x) -> norm_Inf x < 0.001) :: Bool)
5952
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 []
7553tests :: IO Bool
76−tests = $quickCheckAll
77−
54+tests = checkParallel $$(discover)
test/Test/Grenade/Layers/PadCrop.hs+19−10
@@ -7,34 +7,43 @@
77{-# LANGUAGE ScopedTypeVariables #-}
88{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
99
10−#if __GLASGOW_HASKELL__ < 800
11−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
12−#endif
13−
1410module Test.Grenade.Layers.PadCrop where
1511
1612import Grenade
1713
18−import Disorder.Jack
14+import Hedgehog
1915
2016import Numeric.LinearAlgebra.Static ( norm_Inf )
2117
22−import Test.Jack.Hmatrix
18+import Test.Hedgehog.Hmatrix
2319
2420prop_pad_crop :: Property
2521prop_pad_crop =
2622 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 ]
2723 net = Pad :~> Crop :~> NNil
28− in gamble genOfShape $ \(d :: S ('D3 7 9 5)) ->
24+ in property $
25+ forAll genOfShape >>= \(d :: S ('D3 7 9 5)) ->
26+ let (tapes, res) = runForwards net d
27+ (_ , grad) = runBackwards net tapes d
28+ in do assert $ d ~~~ res
29+ assert $ grad ~~~ d
30+
31+prop_pad_crop_2d :: Property
32+prop_pad_crop_2d =
33+ let net :: Network '[Pad 2 3 4 6, Crop 2 3 4 6] '[ 'D2 7 9, 'D2 16 15, 'D2 7 9 ]
34+ net = Pad :~> Crop :~> NNil
35+ in property $
36+ forAll genOfShape >>= \(d :: S ('D2 7 9)) ->
2937 let (tapes, res) = runForwards net d
3038 (_ , grad) = runBackwards net tapes d
31− in d ~~~ res .&&. grad ~~~ d
39+ in do assert $ d ~~~ res
40+ assert $ grad ~~~ d
3241
3342(~~~) :: S x -> S x -> Bool
3443(S1D x) ~~~ (S1D y) = norm_Inf (x - y) < 0.00001
3544(S2D x) ~~~ (S2D y) = norm_Inf (x - y) < 0.00001
3645(S3D x) ~~~ (S3D y) = norm_Inf (x - y) < 0.00001
3746
38−return []
47+
3948tests :: IO Bool
40−tests = $quickCheckAll
49+tests = checkParallel $$(discover)
test/Test/Grenade/Layers/Pooling.hs+19−14
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE TemplateHaskell #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE KindSignatures #-}
@@ -9,36 +10,40 @@ module Test.Grenade.Layers.Pooling where
910import Data.Proxy
1011import Data.Singletons ()
1112
13+#if MIN_VERSION_base(4,9,0)
14+import Data.Kind (Type)
15+#endif
16+
1217import GHC.TypeLits
1318import Grenade.Layers.Pooling
1419
15−import Disorder.Jack
20+import Hedgehog
1621
22+import Test.Hedgehog.Compat
1723
18−data OpaquePooling :: * where
24+data OpaquePooling :: Type where
1925 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling
2026
2127instance Show OpaquePooling where
2228 show (OpaquePooling n) = show n
2329
24−genOpaquePooling :: Jack OpaquePooling
30+genOpaquePooling :: Gen OpaquePooling
2531genOpaquePooling = do
26− Just kernelHeight <- someNatVal <$> choose (2, 15)
27− Just kernelWidth <- someNatVal <$> choose (2, 15)
28− Just strideHeight <- someNatVal <$> choose (2, 15)
29− Just strideWidth <- someNatVal <$> choose (2, 15)
32+ ~(Just kernelHeight) <- someNatVal <$> choose 2 15
33+ ~(Just kernelWidth ) <- someNatVal <$> choose 2 15
34+ ~(Just strideHeight) <- someNatVal <$> choose 2 15
35+ ~(Just strideWidth ) <- someNatVal <$> choose 2 15
3036
3137 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of
3238 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->
3339 return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)
3440
3541prop_pool_layer_witness =
36− gamble genOpaquePooling $ \onet ->
37− (case onet of
38− (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) -> True
39− ) :: Bool
40−
42+ property $ do
43+ onet <- forAll genOpaquePooling
44+ case onet of
45+ (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) ->
46+ assert True
4147
42−return []
4348tests :: 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 @@
1010{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
1111module Test.Grenade.Recurrent.Layers.LSTM where
1212
13−import Disorder.Jack
13+import Hedgehog
14+import Hedgehog.Internal.Source
15+import Hedgehog.Internal.Show
16+import Hedgehog.Internal.Property ( failWith, Diff (..) )
1417
1518import Data.Foldable ( toList )
1619import Data.Singletons.TypeLits
@@ -23,9 +26,9 @@ import qualified Numeric.LinearAlgebra.Static as S
2326
2427
2528import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference
26−import Test.Jack.Hmatrix
29+import Test.Hedgehog.Hmatrix
2730
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)
2932genLSTM = do
3033 let w = uniformSample
3134 u = uniformSample
@@ -39,63 +42,89 @@ genLSTM = do
3942 <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)
4043
4144prop_lstm_reference_forwards =
42− gamble randomVector $ \(input :: S.R 3) ->
43− gamble randomVector $ \(cell :: S.R 2) ->
44− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
45− let actual = runRecurrentForwards net (S1D cell) (S1D input)
46− in case actual of
47− (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->
48− let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut
49− output' = Reference.Vector . H.toList . S.extract $ output
50− refNet = Reference.lstmToReference lstmWeights
51− refCell = Reference.Vector . H.toList . S.extract $ cell
52− refInput = Reference.Vector . H.toList . S.extract $ input
53− (refCO, refO) = Reference.runLSTM refNet refCell refInput
54− in toList refCO ~~~ toList cellOut' .&&. toList refO ~~~ toList output'
45+ property $ do
46+ input :: S.R 3 <- forAll randomVector
47+ cell :: S.R 2 <- forAll randomVector
48+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
49+
50+ let actual = runRecurrentForwards net (S1D cell) (S1D input)
51+ case actual of
52+ (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->
53+ let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut
54+ output' = Reference.Vector . H.toList . S.extract $ output
55+ refNet = Reference.lstmToReference lstmWeights
56+ refCell = Reference.Vector . H.toList . S.extract $ cell
57+ refInput = Reference.Vector . H.toList . S.extract $ input
58+ (refCO, refO) = Reference.runLSTM refNet refCell refInput
59+ in do toList refCO ~~~ toList cellOut'
60+ toList refO ~~~ toList output'
61+
5562
5663prop_lstm_reference_backwards =
57− gamble randomVector $ \(input :: S.R 3) ->
58− gamble randomVector $ \(cell :: S.R 2) ->
59− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
60− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
61− in case actualBacks of
62− (actualGradients, _, _ :: S ('D1 3)) ->
63− let refNet = Reference.lstmToReference lstmWeights
64− refCell = Reference.Vector . H.toList . S.extract $ cell
65− refInput = Reference.Vector . H.toList . S.extract $ input
66− refGradients = Reference.runLSTMback refCell refInput refNet
67− in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)
64+ property $ do
65+ input :: S.R 3 <- forAll randomVector
66+ cell :: S.R 2 <- forAll randomVector
67+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
68+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))
69+ = runRecurrentForwards net (S1D cell) (S1D input)
70+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
71+ case actualBacks of
72+ (actualGradients, _, _ :: S ('D1 3)) ->
73+ let refNet = Reference.lstmToReference lstmWeights
74+ refCell = Reference.Vector . H.toList . S.extract $ cell
75+ refInput = Reference.Vector . H.toList . S.extract $ input
76+ refGradients = Reference.runLSTMback refCell refInput refNet
77+ in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)
6878
6979prop_lstm_reference_backwards_input =
70− gamble randomVector $ \(input :: S.R 3) ->
71− gamble randomVector $ \(cell :: S.R 2) ->
72− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
73− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
74− in case actualBacks of
75− (_, _, S1D actualGradients :: S ('D1 3)) ->
76− let refNet = Reference.lstmToReference lstmWeights
77− refCell = Reference.Vector . H.toList . S.extract $ cell
78− refInput = Reference.Vector . H.toList . S.extract $ input
79− refGradients = Reference.runLSTMbackOnInput refCell refNet refInput
80− in toList refGradients ~~~ H.toList (S.extract actualGradients)
80+ property $ do
81+ input :: S.R 3 <- forAll randomVector
82+ cell :: S.R 2 <- forAll randomVector
83+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
84+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))
85+ = runRecurrentForwards net (S1D cell) (S1D input)
86+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
87+ case actualBacks of
88+ (_, _, S1D actualGradients :: S ('D1 3)) ->
89+ let refNet = Reference.lstmToReference lstmWeights
90+ refCell = Reference.Vector . H.toList . S.extract $ cell
91+ refInput = Reference.Vector . H.toList . S.extract $ input
92+ refGradients = Reference.runLSTMbackOnInput refCell refNet refInput
93+ in toList refGradients ~~~ H.toList (S.extract actualGradients)
8194
8295prop_lstm_reference_backwards_cell =
83− gamble randomVector $ \(input :: S.R 3) ->
84− gamble randomVector $ \(cell :: S.R 2) ->
85− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
86− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
87− in case actualBacks of
88− (_, S1D actualGradients, _ :: S ('D1 3)) ->
89− let refNet = Reference.lstmToReference lstmWeights
90− refCell = Reference.Vector . H.toList . S.extract $ cell
91− refInput = Reference.Vector . H.toList . S.extract $ input
92− refGradients = Reference.runLSTMbackOnCell refInput refNet refCell
93− in toList refGradients ~~~ H.toList (S.extract actualGradients)
94−
95−
96−(~~~) as bs = all (< 1e-8) (zipWith (-) as bs)
96+ property $ do
97+ input :: S.R 3 <- forAll randomVector
98+ cell :: S.R 2 <- forAll randomVector
99+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
100+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))
101+ = runRecurrentForwards net (S1D cell) (S1D input)
102+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
103+ case actualBacks of
104+ (_, S1D actualGradients, _ :: S ('D1 3)) ->
105+ let refNet = Reference.lstmToReference lstmWeights
106+ refCell = Reference.Vector . H.toList . S.extract $ cell
107+ refInput = Reference.Vector . H.toList . S.extract $ input
108+ refGradients = Reference.runLSTMbackOnCell refInput refNet refCell
109+ in toList refGradients ~~~ H.toList (S.extract actualGradients)
110+
111+(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> PropertyT m ()
112+(~~~) x y =
113+ if all (< 1e-8) (zipWith (-) x y) then
114+ success
115+ else
116+ case valueDiff <$> mkValue x <*> mkValue y of
117+ Nothing ->
118+ withFrozenCallStack $
119+ failWith Nothing $ unlines [
120+ "━━━ Not Simliar ━━━"
121+ , showPretty x
122+ , showPretty y
123+ ]
124+ Just differ ->
125+ withFrozenCallStack $
126+ failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" differ) ""
97127infix 4 ~~~
98128
99−return []
100129tests :: IO Bool
101−tests = $quickCheckAll
130+tests = checkParallel $$(discover)
test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+25−21
@@ -6,7 +6,6 @@
66{-# LANGUAGE DeriveFunctor #-}
77{-# LANGUAGE DeriveFoldable #-}
88{-# LANGUAGE DeriveTraversable #-}
9−{-# LANGUAGE RecordWildCards #-}
109{-# LANGUAGE FlexibleContexts #-}
1110{-# LANGUAGE RankNTypes #-}
1211
@@ -15,9 +14,13 @@ module Test.Grenade.Recurrent.Layers.LSTM.Reference where
1514
1615import Data.Reflection
1716import Numeric.AD.Mode.Reverse
18−import Numeric.AD.Internal.Reverse ( Tape )
17+import Numeric.AD.Internal.Reverse (Tape)
1918
19+import GHC.TypeLits (KnownNat)
20+
21+import Grenade.Recurrent.Layers.LSTM (LSTMWeights (..))
2022import qualified Grenade.Recurrent.Layers.LSTM as LSTM
23+
2124import qualified Numeric.LinearAlgebra.Static as S
2225import qualified Numeric.LinearAlgebra as H
2326
@@ -54,31 +57,32 @@ data RefLSTM a = RefLSTM
5457 , refLstmBc :: Vector a -- Bias Cell (b_c)
5558 } deriving (Functor, Foldable, Traversable, Eq, Show)
5659
57−lstmToReference :: LSTM.LSTMWeights a b -> RefLSTM Double
58−lstmToReference LSTM.LSTMWeights {..} =
59− let refLstmWf = Matrix . H.toLists . S.extract $ lstmWf -- Weight Forget (W_f)
60− refLstmUf = Matrix . H.toLists . S.extract $ lstmUf -- Cell State Forget (U_f)
61− refLstmBf = Vector . H.toList . S.extract $ lstmBf -- Bias Forget (b_f)
62− refLstmWi = Matrix . H.toLists . S.extract $ lstmWi -- Weight Input (W_i)
63− refLstmUi = Matrix . H.toLists . S.extract $ lstmUi -- Cell State Input (U_i)
64− refLstmBi = Vector . H.toList . S.extract $ lstmBi -- Bias Input (b_i)
65− refLstmWo = Matrix . H.toLists . S.extract $ lstmWo -- Weight Output (W_o)
66− refLstmUo = Matrix . H.toLists . S.extract $ lstmUo -- Cell State Output (U_o)
67− refLstmBo = Vector . H.toList . S.extract $ lstmBo -- Bias Output (b_o)
68− refLstmWc = Matrix . H.toLists . S.extract $ lstmWc -- Weight Cell (W_c)
69− refLstmBc = Vector . H.toList . S.extract $ lstmBc -- Bias Cell (b_c)
70− in RefLSTM {..}
60+lstmToReference :: (KnownNat a, KnownNat b) => LSTM.LSTMWeights a b -> RefLSTM Double
61+lstmToReference lw =
62+ RefLSTM
63+ { refLstmWf = Matrix . H.toLists . S.extract $ lstmWf lw -- Weight Forget (W_f)
64+ , refLstmUf = Matrix . H.toLists . S.extract $ lstmUf lw -- Cell State Forget (U_f)
65+ , refLstmBf = Vector . H.toList . S.extract $ lstmBf lw -- Bias Forget (b_f)
66+ , refLstmWi = Matrix . H.toLists . S.extract $ lstmWi lw -- Weight Input (W_i)
67+ , refLstmUi = Matrix . H.toLists . S.extract $ lstmUi lw -- Cell State Input (U_i)
68+ , refLstmBi = Vector . H.toList . S.extract $ lstmBi lw -- Bias Input (b_i)
69+ , refLstmWo = Matrix . H.toLists . S.extract $ lstmWo lw -- Weight Output (W_o)
70+ , refLstmUo = Matrix . H.toLists . S.extract $ lstmUo lw -- Cell State Output (U_o)
71+ , refLstmBo = Vector . H.toList . S.extract $ lstmBo lw -- Bias Output (b_o)
72+ , refLstmWc = Matrix . H.toLists . S.extract $ lstmWc lw -- Weight Cell (W_c)
73+ , refLstmBc = Vector . H.toList . S.extract $ lstmBc lw -- Bias Cell (b_c)
74+ }
7175
7276runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)
73−runLSTM RefLSTM {..} cell input =
77+runLSTM rl cell input =
7478 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
7680 -- Input state vector
77− i_t = sigmoid $ refLstmBi #+ refLstmWi #> input #+ refLstmUi #> cell
81+ i_t = sigmoid $ refLstmBi rl #+ refLstmWi rl #> input #+ refLstmUi rl #> cell
7882 -- Output state vector
79− o_t = sigmoid $ refLstmBo #+ refLstmWo #> input #+ refLstmUo #> cell
83+ o_t = sigmoid $ refLstmBo rl #+ refLstmWo rl #> input #+ refLstmUo rl #> cell
8084 -- Cell input state vector
81− c_x = fmap tanh $ refLstmBc #+ refLstmWc #> input
85+ c_x = fmap tanh $ refLstmBc rl #+ refLstmWc rl #> input
8286 -- Cell state
8387 c_t = f_t #* cell #+ i_t #* c_x
8488 -- 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
24
35import qualified Test.Grenade.Layers.Pooling
46import qualified Test.Grenade.Layers.Convolution
@@ -11,10 +13,15 @@ import qualified Test.Grenade.Layers.Internal.Pooling
1113
1214import qualified Test.Grenade.Recurrent.Layers.LSTM
1315
16+import System.Exit
17+import System.IO
18+
1419main :: IO ()
1520main =
1621 disorderMain [
17− Test.Grenade.Layers.Pooling.tests
22+ Test.Grenade.Network.tests
23+
24+ , Test.Grenade.Layers.Pooling.tests
1825 , Test.Grenade.Layers.Convolution.tests
1926 , Test.Grenade.Layers.FullyConnected.tests
2027 , Test.Grenade.Layers.Nonlinear.tests
@@ -24,4 +31,17 @@ main =
2431 , Test.Grenade.Layers.Internal.Pooling.tests
2532
2633 , Test.Grenade.Recurrent.Layers.LSTM.tests
34+
2735 ]
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