git.iko.soy/grenade
on master help sign in
swap
afb9f9b118 ahead, 0 behind
.gitignore+3−1
since splitsnapshots
unifiedsplit
@@ -1,4 +1,6 @@
1+cabal.project.local
1.cabal-sandbox/
2.cabal-sandbox/
2cabal.sandbox.config
3cabal.sandbox.config
3dist/
4dist/
4−
5+dist-newstyle/
6+.stack-work/
.gitmodulesdeleted−15
@@ -1,15 +0,0 @@
1−[submodule "lib/disorder"]
2− path = lib/disorder
3− url = https://github.com/ambiata/disorder.hs
4−[submodule "lib/x"]
5− path = lib/x
6− url = https://github.com/ambiata/x.git
7−[submodule "lib/p"]
8− path = lib/p
9− url = https://github.com/ambiata/p
10−[submodule "lib/disorder.hs"]
11− path = lib/disorder.hs
12− url = https://github.com/ambiata/disorder.hs.git
13−[submodule "lib/hmatrix"]
14− path = lib/hmatrix
15− url = https://github.com/albertoruiz/hmatrix.git
.travis.ymlnew file+31
@@ -0,0 +1,31 @@
1+# NB: don't set `language: haskell` here
2+
3+# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.
4+env:
5+ - GHCVER=8.0.2
6+ - GHCVER=8.2.2
7+ - GHCVER=8.4.4
8+ - GHCVER=8.6.5
9+ - GHCVER=8.8.3
10+ - GHCVER=8.10.1
11+
12+# Note: the distinction between `before_install` and `install` is not important.
13+before_install:
14+ - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
15+ - travis_retry sudo apt-get update
16+ - travis_retry sudo apt-get install cabal-install-3.2 ghc-$GHCVER libblas-dev liblapack-dev
17+ - export PATH=/opt/cabal/bin:/opt/ghc/$GHCVER/bin:$PATH
18+
19+install:
20+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
21+ - travis_retry cabal-3.2 update
22+
23+notifications:
24+ email: false
25+
26+# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
27+script:
28+ - cabal-3.2 configure --enable-tests
29+ - cabal-3.2 build all
30+ - cabal-3.2 test --test-show-details=direct -j1
31+
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2016, Huw Campbell
1+Copyright (c) 2016-2017, Huw Campbell
2All rights reserved.
2All rights reserved.
3
3
4Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
4Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
README.md+72−10
@@ -1,6 +1,11 @@
1Grenade
1Grenade
2=======
2=======
3
3
4+[![Build Status](https://api.travis-ci.org/HuwCampbell/grenade.svg?branch=master)](https://travis-ci.org/HuwCampbell/grenade)
5+[![Hackage page (downloads and API reference)][hackage-png]][hackage]
6+[![Hackage-Deps][hackage-deps-png]][hackage-deps]
7+
8+
4```
9```
5First shalt thou take out the Holy Pin, then shalt thou count to three, no more, no less.
10First shalt thou take out the Holy Pin, then shalt thou count to three, no more, no less.
6Three shall be the number thou shalt count, and the number of the counting shall be three.
11Three shall be the number thou shalt count, and the number of the counting shall be three.
@@ -10,14 +15,20 @@ Five is right out.
10
15
11💣 Machine learning which might blow up in your face 💣
16💣 Machine learning which might blow up in your face 💣
12
17
13−Grenade is a dependently typed, practical, and fast recurrent neural network library
18+Grenade is a composable, dependently typed, practical, and fast recurrent neural network library
14for concise and precise specifications of complex networks in Haskell.
19for concise and precise specifications of complex networks in Haskell.
15
20
16As an example, a network which can achieve ~1.5% error on MNIST can be
21As an example, a network which can achieve ~1.5% error on MNIST can be
17specified and initialised with random weights in a few lines of code with
22specified and initialised with random weights in a few lines of code with
18```haskell
23```haskell
24+type MNIST
25+ = Network
26+ '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Relu
27+ , Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Reshape, Relu
19−type MNIST = Network '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Relu, Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, FlattenLayer, Relu, FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]
28+ , FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]
20− '[ 'D2 28 28, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10, 'D3 8 8 16, 'D3 4 4 16, 'D1 256, 'D1 256, 'D1 80, 'D1 80, 'D1 10, 'D1 10]
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]
21
32
22randomMnist :: MonadRandom m => m MNIST
33randomMnist :: MonadRandom m => m MNIST
23randomMnist = randomNetwork
34randomMnist = randomNetwork
@@ -31,8 +42,10 @@ If recurrent neural networks are more your style, you can try defining something
31["unreasonably effective"](http://karpathy.github.io/2015/05/21/rnn-effectiveness/)
42["unreasonably effective"](http://karpathy.github.io/2015/05/21/rnn-effectiveness/)
32with
43with
33```haskell
44```haskell
45+type Shakespeare
46+ = RecurrentNetwork
34−type Shakespeare = RecurrentNetwork '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyConnected 40 40), F Logit]
47+ '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyConnected 40 40), F Logit]
35− '[ 'D1 40, 'D1 80, 'D1 40, 'D1 40, 'D1 40 ]
48+ '[ 'D1 40, 'D1 80, 'D1 40, 'D1 40, 'D1 40 ]
36```
49```
37
50
38Design
51Design
@@ -45,8 +58,13 @@ data that are passed between the layers.
45The definition of a network is surprisingly simple:
58The definition of a network is surprisingly simple:
46```haskell
59```haskell
47data Network :: [*] -> [Shape] -> * where
60data Network :: [*] -> [Shape] -> * where
61+ NNil :: SingI i
48− O :: (SingI i, SingI o, Layer x i o) => !x -> Network '[x] '[i, o]
62+ => Network '[] '[i]
63+
49− (:~>) :: (SingI i, SingI h, Layer x i h) => !x -> !(Network xs (h ': hs)) -> Network (x ': xs) (i ': h ': hs)
64+ (:~>) :: (SingI i, SingI h, Layer x i h)
65+ => !x
66+ -> !(Network xs (h ': hs))
67+ -> Network (x ': xs) (i ': h ': hs)
50```
68```
51
69
52The `Layer x i o` constraint ensures that the layer `x` can sensibly perform a
70The `Layer x i o` constraint ensures that the layer `x` can sensibly perform a
@@ -71,7 +89,7 @@ backPropagate :: forall shapes layers.
71```
89```
72which takes a network, appropriate input and target data, and returns the
90which takes a network, appropriate input and target data, and returns the
73back propagated gradients for the network. The shapes of the gradients are
91back propagated gradients for the network. The shapes of the gradients are
74−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
75have no learnable parameters.
93have no learnable parameters.
76
94
77The gradients however can always be applied, yielding a new (hopefully better)
95The gradients however can always be applied, yielding a new (hopefully better)
@@ -85,9 +103,48 @@ easy in downstream code. If the shapes of a network are not specified correctly
85and a layer can not sensibly perform the operation between two shapes, then
103and a layer can not sensibly perform the operation between two shapes, then
86it will result in a compile time error.
104it will result in a compile time error.
87
105
106+Composition
107+-----------
108+
109+Networks and Layers in Grenade are easily composed at the type level. As a `Network`
110+is an instance of `Layer`, one can use a trained Network as a small component in a
111+larger network easily. Furthermore, we provide 2 layers which are designed to run
112+layers in parallel and merge their output (either by concatenating them across one
113+dimension or summing by pointwise adding their activations). This allows one to
114+write any Network which can be expressed as a
115+[series parallel graph](https://en.wikipedia.org/wiki/Series-parallel_graph).
116+
117+A residual network layer specification for instance could be written as
118+```haskell
119+type Residual net = Merge Trivial net
120+```
121+If the type `net` is an instance of `Layer`, then `Residual net` will be too. It will
122+run the network, while retaining its input by passing it through the `Trivial` layer,
123+and merge the original image with the output.
124+
125+See the [MNIST](https://github.com/HuwCampbell/grenade/blob/master/examples/main/mnist.hs)
126+example, which has been overengineered to contain both residual style learning as well
127+as inception style convolutions.
128+
129+Generative Adversarial Networks
130+-------------------------------
131+
132+As Grenade is purely functional, one can compose its training functions in flexible
133+ways. [GAN-MNIST](https://github.com/HuwCampbell/grenade/blob/master/examples/main/gan-mnist.hs)
134+example displays an interesting, type safe way of writing a generative adversarial
135+training function in 10 lines of code.
136+
137+Layer Zoo
138+---------
139+
140+Grenade layers are normal haskell data types which are an instance of `Layer`, so
141+it's easy to build one's own downstream code. We do however provide a decent set
142+of layers, including convolution, deconvolution, pooling, pad, crop, logit, relu,
143+elu, tanh, and fully connected.
144+
88Build Instructions
145Build Instructions
89------------------
146------------------
90−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)
91script that is located in the repository. You will also need the `lapack` and
148script that is located in the repository. You will also need the `lapack` and
92`blas` libraries and development tools. Once you have all that, Grenade can be
149`blas` libraries and development tools. Once you have all that, Grenade can be
93build using:
150build using:
@@ -102,7 +159,7 @@ and the tests run using:
102./mafia test
159./mafia test
103```
160```
104
161
105−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.
106
163
107Thanks
164Thanks
108------
165------
@@ -128,3 +185,8 @@ core took around 12 minutes, achieving 1.5% error rate on a 1000 sample holdout
128Contributing
185Contributing
129------------
186------------
130Contributions are welcome.
187Contributions are welcome.
188+
189+ [hackage]: http://hackage.haskell.org/package/grenade
190+ [hackage-png]: http://img.shields.io/hackage/v/grenade.svg
191+ [hackage-deps]: http://packdeps.haskellers.com/reverse/grenade
192+ [hackage-deps-png]: https://img.shields.io/hackage-deps/v/grenade.svg
_config.ymlnew file+1
@@ -0,0 +1 @@
1+theme: jekyll-theme-minimal
bench/bench-lstm.hs+4−45
@@ -5,67 +5,26 @@ import Criterion.Main
5
5
6import Grenade
6import Grenade
7import Grenade.Recurrent
7import Grenade.Recurrent
8−import Grenade.Layers.Internal.Update
9−
10−import qualified Numeric.LinearAlgebra.Static as H
11
8
12main :: IO ()
9main :: IO ()
13main = do
10main = do
14− layer60 :: LSTM 40 60 <- createRandom
15− layer512 :: LSTM 40 512 <- createRandom
16 input40 :: S ('D1 40) <- randomOfShape
11 input40 :: S ('D1 40) <- randomOfShape
17− rec60 :: S ('D1 60) <- randomOfShape
18− rec512 :: S ('D1 512) <- randomOfShape
19− (lstm, lstm') :: (RecNet, RecInput) <- randomRecurrent
12+ lstm :: RecNet <- randomRecurrent
20−
21− let upIn60 :: H.R 3600 = H.randomVector 1 H.Uniform * 2 - 1
22− let upIn512 :: H.R 262144 = H.randomVector 1 H.Uniform * 2 - 1
23
13
24 defaultMain [
14 defaultMain [
25− bgroup "lstm" [ bench "forwards-60" $ nf (nfT3 . uncurry (testRun60 layer60)) (rec60, input40)
26− , bench "forwards-512" $ nf (nfT3 . uncurry (testRun512 layer512)) (rec512, input40)
27− , bench "backwards-60" $ nf (nfT3 . uncurry4 (testRun60' layer60)) (rec60, input40, rec60, rec60)
28− , bench "backwards-512" $ nf (nfT3 . uncurry4 (testRun512' layer512)) (rec512, input40, rec512, rec512)
29− ]
30− , bgroup "update" [ bench "matrix-60x60" $ nf (uncurry3 (decendVector 1 1 1)) (upIn60, upIn60, upIn60)
31− , bench "matrix-512x512" $ nf (uncurry3 (decendVector 1 1 1)) (upIn512, upIn512, upIn512)
32− ]
33− , bgroup "train" [ bench "one-time-step" $ whnf (nfT2 . trainRecurrent lp lstm lstm') [(input40, Just input40)]
15+ bgroup "train" [ bench "one-time-step" $ whnf (nfT2 . trainRecurrent lp lstm 0) [(input40, Just input40)]
34− , bench "ten-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm lstm') $ replicate 10 (input40, Just input40)
16+ , bench "ten-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm 0) $ replicate 10 (input40, Just input40)
35− , bench "fifty-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm lstm') $ replicate 50 (input40, Just input40)
17+ , bench "fifty-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm 0) $ replicate 50 (input40, Just input40)
36 ]
18 ]
37 ]
19 ]
38
20
39−testRun60 :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> ((S ('D1 60), S ('D1 40)), S ('D1 60), S ('D1 60))
40−testRun60 = runRecurrentForwards
41−
42−testRun60' :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> S ('D1 60) -> S ('D1 60) -> (Gradient (LSTM 40 60), S ('D1 60), S ('D1 40))
43−testRun60' = curry . runRecurrentBackwards
44−
45−testRun512 :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> ((S ('D1 512), S ('D1 40)), S ('D1 512), S ('D1 512))
46−testRun512 = runRecurrentForwards
47−
48−testRun512' :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> S ('D1 512) -> S ('D1 512) -> (Gradient (LSTM 40 512), S ('D1 512), S ('D1 40))
49−testRun512' = curry . runRecurrentBackwards
50−
51−uncurry4 :: (t -> t1 -> t2 -> t3 -> t4) -> (t, t1, t2, t3) -> t4
52−uncurry4 f (a,b,c,d) = f a b c d
53−
54−uncurry3 :: (t -> t1 -> t2 -> t3) -> (t, t1, t2) -> t3
55−uncurry3 f (a,b,c) = f a b c
56−
57nfT2 :: (a, b) -> (a, b)
21nfT2 :: (a, b) -> (a, b)
58nfT2 (!a, !b) = (a, b)
22nfT2 (!a, !b) = (a, b)
59
23
60−nfT3 :: (a, b, c) -> (b, c)
61−nfT3 (!_, !b, !c) = (b, c)
62−
63
24
64type R = Recurrent
25type R = Recurrent
65type RecNet = RecurrentNetwork '[ R (LSTM 40 512), R (LSTM 512 40) ]
26type RecNet = RecurrentNetwork '[ R (LSTM 40 512), R (LSTM 512 40) ]
66 '[ 'D1 40, 'D1 512, 'D1 40 ]
27 '[ 'D1 40, 'D1 512, 'D1 40 ]
67
28
68−type RecInput = RecurrentInputs '[ R (LSTM 40 512), R (LSTM 512 40) ]
69−
70lp :: LearningParameters
29lp :: LearningParameters
71lp = LearningParameters 0.1 0 0
30lp = LearningParameters 0.1 0 0
bench/bench.hs+47−18
@@ -1,26 +1,55 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
1import Criterion.Main
3import Criterion.Main
2
4
5+import Grenade
6+
3import Grenade.Layers.Internal.Convolution
7import Grenade.Layers.Internal.Convolution
4import Grenade.Layers.Internal.Pooling
8import Grenade.Layers.Internal.Pooling
5
9
6import Numeric.LinearAlgebra
10import Numeric.LinearAlgebra
7
11
8main :: IO ()
12main :: IO ()
13+main = do
14+ x :: S ('D2 60 60 ) <- randomOfShape
15+ y :: S ('D3 60 60 1) <- randomOfShape
16+
9−main = defaultMain [
17+ defaultMain [
10− bgroup "im2col" [ bench "im2col 3x4" $ whnf (im2col 2 2 1 1) ((3><4) [1..])
18+ bgroup "im2col" [ bench "im2col 3x4" $ whnf (im2col 2 2 1 1) ((3><4) [1..])
11− , bench "im2col 28x28" $ whnf (im2col 5 5 1 1) ((28><28) [1..])
19+ , bench "im2col 28x28" $ whnf (im2col 5 5 1 1) ((28><28) [1..])
12− , bench "im2col 100x100" $ whnf (im2col 10 10 1 1) ((100><100) [1..])
20+ , bench "im2col 100x100" $ whnf (im2col 10 10 1 1) ((100><100) [1..])
13− ]
21+ ]
14− , bgroup "col2im" [ bench "col2im 3x4" $ whnf (col2im 2 2 1 1 3 4) ((6><4) [1..])
22+ , bgroup "col2im" [ bench "col2im 3x4" $ whnf (col2im 2 2 1 1 3 4) ((6><4) [1..])
15− , bench "col2im 28x28" $ whnf (col2im 5 5 1 1 28 28) ((576><25) [1..])
23+ , bench "col2im 28x28" $ whnf (col2im 5 5 1 1 28 28) ((576><25) [1..])
16− , bench "col2im 100x100" $ whnf (col2im 10 10 1 1 100 100) ((8281><100) [1..])
24+ , bench "col2im 100x100" $ whnf (col2im 10 10 1 1 100 100) ((8281><100) [1..])
17− ]
25+ ]
18− , bgroup "poolfw" [ bench "poolforwards 3x4" $ whnf (poolForward 1 3 4 2 2 1 1) ((3><4) [1..])
26+ , bgroup "poolfw" [ bench "poolforwards 3x4" $ whnf (poolForward 1 3 4 2 2 1 1) ((3><4) [1..])
19− , bench "poolforwards 28x28" $ whnf (poolForward 1 28 28 5 5 1 1) ((28><28) [1..])
27+ , bench "poolforwards 28x28" $ whnf (poolForward 1 28 28 5 5 1 1) ((28><28) [1..])
20− , bench "poolforwards 100x100" $ whnf (poolForward 1 100 100 10 10 1 1) ((100><100) [1..])
28+ , bench "poolforwards 100x100" $ whnf (poolForward 1 100 100 10 10 1 1) ((100><100) [1..])
21− ]
29+ ]
22− , bgroup "poolbw" [ bench "poolbackwards 3x4" $ whnf (poolBackward 1 3 4 2 2 1 1 ((3><4) [1..])) ((2><3) [1..])
30+ , bgroup "poolbw" [ bench "poolbackwards 3x4" $ whnf (poolBackward 1 3 4 2 2 1 1 ((3><4) [1..])) ((2><3) [1..])
23− , bench "poolbackwards 28x28" $ whnf (poolBackward 1 28 28 5 5 1 1 ((28><28) [1..])) ((24><24) [1..])
31+ , bench "poolbackwards 28x28" $ whnf (poolBackward 1 28 28 5 5 1 1 ((28><28) [1..])) ((24><24) [1..])
24− , bench "poolbackwards 100x100" $ whnf (poolBackward 1 100 100 10 10 1 1 ((100><100) [1..])) ((91><91) [1..])
32+ , bench "poolbackwards 100x100" $ whnf (poolBackward 1 100 100 10 10 1 1 ((100><100) [1..])) ((91><91) [1..])
33+ ]
34+ , bgroup "padcrop" [ bench "pad 2D 60x60" $ whnf (testRun2D Pad) x
35+ , bench "pad 3D 60x60" $ whnf (testRun3D Pad) y
36+ , bench "crop 2D 60x60" $ whnf (testRun2D' Crop) x
37+ , bench "crop 3D 60x60" $ whnf (testRun3D' Crop) y
25− ]
38+ ]
26− ]
39+ ]
40+
41+
42+testRun2D :: Pad 1 1 1 1 -> S ('D2 60 60) -> S ('D2 62 62)
43+testRun2D = snd ... runForwards
44+
45+testRun3D :: Pad 1 1 1 1 -> S ('D3 60 60 1) -> S ('D3 62 62 1)
46+testRun3D = snd ... runForwards
47+
48+testRun2D' :: Crop 1 1 1 1 -> S ('D2 60 60) -> S ('D2 58 58)
49+testRun2D' = snd ... runForwards
50+
51+testRun3D' :: Crop 1 1 1 1 -> S ('D3 60 60 1) -> S ('D3 58 58 1)
52+testRun3D' = snd ... runForwards
53+
54+(...) :: (a -> b) -> (c -> d -> a) -> c -> d -> b
55+(...) = (.) . (.)
cbits/gradient_decent.c → cbits/gradient_descent.crenamed+3−3
@@ -1,12 +1,12 @@
1−#include "gradient_decent.h"
1+#include "gradient_descent.h"
2
2
3−void decend_cpu(int len, double rate, double momentum, double regulariser,
3+void descend_cpu(int len, double rate, double momentum, double regulariser,
4 const double* weights,
4 const double* weights,
5 const double* gradient,
5 const double* gradient,
6 const double* last,
6 const double* last,
7 double* outputWeights, double* outputMomentum) {
7 double* outputWeights, double* outputMomentum) {
8
8
9− for (int i = 0; i <= len; i++) {
9+ for (int i = 0; i < len; i++) {
10 outputMomentum[i] = momentum * last[i] - rate * gradient[i];
10 outputMomentum[i] = momentum * last[i] - rate * gradient[i];
11 outputWeights[i] = weights[i] + outputMomentum[i] - (rate * regulariser) * weights[i];
11 outputWeights[i] = weights[i] + outputMomentum[i] - (rate * regulariser) * weights[i];
12 }
12 }
cbits/gradient_decent.h → cbits/gradient_descent.hrenamed+1−1
@@ -1,7 +1,7 @@
1#include <stdio.h>
1#include <stdio.h>
2#include <stdint.h>
2#include <stdint.h>
3
3
4−void decend_cpu(int len, double rate, double momentum, double regulariser,
4+void descend_cpu(int len, double rate, double momentum, double regulariser,
5 const double* weights,
5 const double* weights,
6 const double* gradient,
6 const double* gradient,
7 const double* last,
7 const double* last,
cbits/pad.cnew file+39
@@ -0,0 +1,39 @@
1+#include "pad.h"
2+
3+void pad_cpu(double* data, const int channels,
4+ const int height, const int width, const int pad_left, const int pad_top,
5+ const int pad_right, const int pad_bottom,
6+ double* data_padded) {
7+
8+ const int pad_width = width + pad_left + pad_right;
9+ const int pad_height = height + pad_top + pad_bottom;
10+
11+ memset(data_padded, 0, pad_height * pad_width * channels * sizeof(double));
12+
13+ for (int channel = 0; channel < channels; channel++) {
14+ double* px = data_padded + (pad_width * pad_top + pad_left) + channel * (pad_width * pad_height);
15+ for (int y = 0; y < height; y++) {
16+ memcpy(px, data, sizeof(double) * width);
17+ px += pad_width;
18+ data += width;
19+ }
20+ }
21+}
22+
23+void crop_cpu(double* data, const int channels,
24+ const int height, const int width, const int crop_left, const int crop_top,
25+ const int crop_right, const int crop_bottom,
26+ double* data_cropped) {
27+
28+ const int crop_width = width + crop_left + crop_right;
29+ const int crop_height = height + crop_top + crop_bottom;
30+
31+ for (int channel = 0; channel < channels; channel++) {
32+ double* px = data + (crop_width * crop_top + crop_left) + channel * (crop_width * crop_height);
33+ for (int y = 0; y < height; y++) {
34+ memcpy(data_cropped, px, sizeof(double) * width);
35+ px += crop_width;
36+ data_cropped += width;
37+ }
38+ }
39+}
cbits/pad.hnew file+13
@@ -0,0 +1,13 @@
1+#include <stdio.h>
2+#include <stdint.h>
3+#include <string.h>
4+
5+void pad_cpu(double* data_im, const int channels,
6+ const int height, const int width, const int pad_left, const int pad_top,
7+ const int pad_right, const int pad_bottom,
8+ double* data_col);
9+
10+void crop_cpu(double* data_im, const int channels,
11+ const int height, const int width, const int crop_left, const int crop_top,
12+ const int crop_right, const int crop_bottom,
13+ double* data_col);
examples/LICENSEnew file+10
@@ -0,0 +1,10 @@
1+Copyright (c) 2016-2017, Huw Campbell
2+All rights reserved.
3+
4+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
5+
6+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
7+
8+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
9+
10+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
examples/grenade-examples.cabalnew file+109
@@ -0,0 +1,109 @@
1+name: grenade-examples
2+version: 0.0.1
3+license: BSD2
4+license-file: LICENSE
5+author: Huw Campbell <huw.campbell@gmail.com>
6+maintainer: Huw Campbell <huw.campbell@gmail.com>
7+copyright: (c) 2016-2017 Huw Campbell.
8+synopsis: grenade-examples
9+category: System
10+cabal-version: >= 1.8
11+build-type: Simple
12+description: grenade-examples
13+
14+source-repository head
15+ type: git
16+ location: https://github.com/HuwCampbell/grenade.git
17+
18+library
19+
20+executable feedforward
21+ ghc-options: -Wall -threaded -O2
22+ main-is: main/feedforward.hs
23+ build-depends: base
24+ , grenade
25+ , attoparsec
26+ , bytestring
27+ , cereal
28+ , either
29+ , optparse-applicative >= 0.13 && < 0.18
30+ , text == 1.2.*
31+ , mtl >= 2.2.1 && < 2.3
32+ , hmatrix
33+ , transformers
34+ , singletons
35+ , semigroups
36+ , MonadRandom
37+
38+executable mnist
39+ ghc-options: -Wall -threaded -O2
40+ main-is: main/mnist.hs
41+ build-depends: base
42+ , grenade
43+ , attoparsec
44+ , either
45+ , optparse-applicative >= 0.13 && < 0.18
46+ , text == 1.2.*
47+ , mtl >= 2.2.1 && < 2.3
48+ , hmatrix >= 0.18 && < 0.21
49+ , transformers
50+ , semigroups
51+ , singletons
52+ , MonadRandom
53+ , vector
54+
55+executable gan-mnist
56+ ghc-options: -Wall -threaded -O2
57+ main-is: main/gan-mnist.hs
58+ build-depends: base
59+ , grenade
60+ , attoparsec
61+ , bytestring
62+ , cereal
63+ , either
64+ , optparse-applicative >= 0.13 && < 0.18
65+ , text == 1.2.*
66+ , mtl >= 2.2.1 && < 2.3
67+ , hmatrix >= 0.18 && < 0.21
68+ , transformers
69+ , semigroups
70+ , singletons
71+ , MonadRandom
72+ , vector
73+
74+executable recurrent
75+ ghc-options: -Wall -threaded -O2
76+ main-is: main/recurrent.hs
77+ build-depends: base
78+ , grenade
79+ , attoparsec
80+ , either
81+ , optparse-applicative >= 0.13 && < 0.18
82+ , text == 1.2.*
83+ , mtl >= 2.2.1 && < 2.3
84+ , hmatrix >= 0.18 && < 0.21
85+ , transformers
86+ , semigroups
87+ , singletons
88+ , MonadRandom
89+
90+executable shakespeare
91+ ghc-options: -Wall -threaded -O2
92+ main-is: main/shakespeare.hs
93+ build-depends: base
94+ , grenade
95+ , attoparsec
96+ , bytestring
97+ , cereal
98+ , either
99+ , optparse-applicative >= 0.13 && < 0.18
100+ , text == 1.2.*
101+ , mtl >= 2.2.1 && < 2.3
102+ , hmatrix >= 0.18 && < 0.21
103+ , transformers
104+ , semigroups
105+ , singletons
106+ , singletons-base
107+ , vector
108+ , MonadRandom
109+ , containers
examples/mafianew file+62
@@ -0,0 +1,62 @@
1+#!/bin/sh -eu
2+
3+: ${MAFIA_HOME:=$HOME/.mafia}
4+: ${MAFIA_VERSIONS:=$MAFIA_HOME/versions}
5+
6+latest_version () {
7+ git ls-remote https://github.com/haskell-mafia/mafia | grep refs/heads/master | cut -f 1
8+}
9+
10+build_version() {
11+ MAFIA_VERSION="$1"
12+ MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia')
13+ MAFIA_FILE=mafia-$MAFIA_VERSION
14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE
15+ mkdir -p $MAFIA_VERSIONS
16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"
17+ git clone https://github.com/haskell-mafia/mafia $MAFIA_TEMP
18+ git --git-dir="$MAFIA_TEMP/.git" --work-tree="$MAFIA_TEMP" reset --hard $MAFIA_VERSION || {
19+ echo "mafia version ($MAFIA_VERSION) could not be found." >&2
20+ exit 1
21+ }
22+ (cd "$MAFIA_TEMP" && ./bin/bootstrap) || {
23+ got=$?
24+ echo "mafia version ($MAFIA_VERSION) could not be built." >&2
25+ exit "$got"
26+ }
27+ chmod +x "$MAFIA_TEMP/.cabal-sandbox/bin/mafia"
28+ # Ensure executable is on same file-system so final mv is atomic.
29+ mv -f "$MAFIA_TEMP/.cabal-sandbox/bin/mafia" "$MAFIA_PATH.$$"
30+ mv "$MAFIA_PATH.$$" "$MAFIA_PATH" || {
31+ rm -f "$MAFIA_PATH.$$"
32+ echo "INFO: mafia version ($MAFIA_VERSION) already exists not overiding," >&2
33+ echo "INFO: this is expected if parallel builds of the same version of" >&2
34+ echo "INFO: mafia occur, we are playing by first in, wins." >&2
35+ exit 0
36+ }
37+}
38+
39+enable_version() {
40+ if [ $# -eq 0 ]; then
41+ MAFIA_VERSION="$(latest_version)"
42+ echo "INFO: No explicit mafia version requested installing latest ($MAFIA_VERSION)." >&2
43+ else
44+ MAFIA_VERSION="$1"
45+ fi
46+ [ -x "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" ] || build_version "$MAFIA_VERSION"
47+ ln -sf "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" "$MAFIA_HOME/versions/mafia"
48+}
49+
50+exec_mafia () {
51+ [ -x "$MAFIA_HOME/versions/mafia" ] || enable_version
52+ "$MAFIA_HOME/versions/mafia" "$@"
53+}
54+
55+#
56+# The actual start of the script.....
57+#
58+
59+case "${1:-}" in
60+upgrade) shift; enable_version "$@" ;;
61+*) exec_mafia "$@"
62+esac
main/feedforward.hs → examples/main/feedforward.hsrenamed+4−1
@@ -1,4 +1,5 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
@@ -10,7 +11,9 @@ import Data.List ( foldl' )
10
11
11import qualified Data.ByteString as B
12import qualified Data.ByteString as B
12import Data.Serialize
13import Data.Serialize
13−
14+#if ! MIN_VERSION_base(4,13,0)
15+import Data.Semigroup ( (<>) )
16+#endif
14import GHC.TypeLits
17import GHC.TypeLits
15
18
16import qualified Numeric.LinearAlgebra.Static as SA
19import qualified Numeric.LinearAlgebra.Static as SA
examples/main/gan-mnist.hsnew file+185
@@ -0,0 +1,185 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE TupleSections #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE FlexibleContexts #-}
10+
11+-- This is a simple generative adversarial network to make pictures
12+-- of numbers similar to those in MNIST.
13+--
14+-- It demonstrates a different usage of the library. Within about 15
15+-- minutes it was producing examples like this:
16+--
17+-- --.
18+-- .=-.--..#=###
19+-- -##==#########.
20+-- #############-
21+-- -###-.=..-.-==
22+-- ###-
23+-- .###-
24+-- .####...==-.
25+-- -####=--.=##=
26+-- -##=- -##
27+-- =##
28+-- -##=
29+-- -###-
30+-- .####.
31+-- .#####.
32+-- ...---=#####-
33+-- .=#########. .
34+-- .#######=. .
35+-- . =-.
36+--
37+-- It's a 5!
38+--
39+import Control.Applicative
40+import Control.Monad
41+import Control.Monad.Random
42+import Control.Monad.Trans.Except
43+
44+import qualified Data.Attoparsec.Text as A
45+import qualified Data.ByteString as B
46+import Data.List ( foldl' )
47+#if ! MIN_VERSION_base(4,13,0)
48+import Data.Semigroup ( (<>) )
49+#endif
50+import Data.Serialize
51+import qualified Data.Text as T
52+import qualified Data.Text.IO as T
53+import qualified Data.Vector.Storable as V
54+
55+import qualified Numeric.LinearAlgebra.Static as SA
56+import Numeric.LinearAlgebra.Data ( toLists )
57+
58+import Options.Applicative
59+
60+import Grenade
61+import Grenade.Utils.OneHot
62+
63+type Discriminator =
64+ Network
65+ '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Relu
66+ , Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Relu
67+ , Reshape, FullyConnected 256 80, Logit, FullyConnected 80 1, Logit]
68+ '[ 'D2 28 28
69+ , 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10
70+ , 'D3 8 8 16, 'D3 4 4 16, 'D3 4 4 16
71+ , 'D1 256, 'D1 80, 'D1 80, 'D1 1, 'D1 1]
72+
73+type Generator =
74+ Network
75+ '[ FullyConnected 80 256, Relu, Reshape
76+ , Deconvolution 16 10 5 5 2 2, Relu
77+ , Deconvolution 10 1 8 8 2 2, Logit]
78+ '[ 'D1 80
79+ , 'D1 256, 'D1 256, 'D3 4 4 16
80+ , 'D3 11 11 10, 'D3 11 11 10
81+ , 'D2 28 28, 'D2 28 28 ]
82+
83+randomDiscriminator :: MonadRandom m => m Discriminator
84+randomDiscriminator = randomNetwork
85+
86+randomGenerator :: MonadRandom m => m Generator
87+randomGenerator = randomNetwork
88+
89+trainExample :: LearningParameters -> Discriminator -> Generator -> S ('D2 28 28) -> S ('D1 80) -> ( Discriminator, Generator )
90+trainExample rate discriminator generator realExample noiseSource
91+ = let (generatorTape, fakeExample) = runNetwork generator noiseSource
92+
93+ (discriminatorTapeReal, guessReal) = runNetwork discriminator realExample
94+ (discriminatorTapeFake, guessFake) = runNetwork discriminator fakeExample
95+
96+ (discriminator'real, _) = runGradient discriminator discriminatorTapeReal ( guessReal - 1 )
97+ (discriminator'fake, _) = runGradient discriminator discriminatorTapeFake guessFake
98+ (_, push) = runGradient discriminator discriminatorTapeFake ( guessFake - 1)
99+
100+ (generator', _) = runGradient generator generatorTape push
101+
102+ newDiscriminator = foldl' (applyUpdate rate { learningRegulariser = learningRegulariser rate * 10}) discriminator [ discriminator'real, discriminator'fake ]
103+ newGenerator = applyUpdate rate generator generator'
104+ in ( newDiscriminator, newGenerator )
105+
106+
107+ganTest :: (Discriminator, Generator) -> Int -> FilePath -> LearningParameters -> ExceptT String IO (Discriminator, Generator)
108+ganTest (discriminator0, generator0) iterations trainFile rate = do
109+ trainData <- fmap fst <$> readMNIST trainFile
110+
111+ lift $ foldM (runIteration trainData) ( discriminator0, generator0 ) [1..iterations]
112+
113+ where
114+
115+ showShape' :: S ('D2 a b) -> IO ()
116+ showShape' (S2D mm) = putStrLn $
117+ let m = SA.extract mm
118+ ms = toLists m
119+ render n' | n' <= 0.2 = ' '
120+ | n' <= 0.4 = '.'
121+ | n' <= 0.6 = '-'
122+ | n' <= 0.8 = '='
123+ | otherwise = '#'
124+
125+ px = (fmap . fmap) render ms
126+ in unlines px
127+
128+ runIteration :: [S ('D2 28 28)] -> (Discriminator, Generator) -> Int -> IO (Discriminator, Generator)
129+ runIteration trainData ( !discriminator, !generator ) _ = do
130+ trained' <- foldM ( \(!discriminatorX, !generatorX ) realExample -> do
131+ fakeExample <- randomOfShape
132+ return $ trainExample rate discriminatorX generatorX realExample fakeExample
133+ ) ( discriminator, generator ) trainData
134+
135+
136+ showShape' . snd . runNetwork (snd trained') =<< randomOfShape
137+
138+ return trained'
139+
140+data GanOpts = GanOpts FilePath Int LearningParameters (Maybe FilePath) (Maybe FilePath)
141+
142+mnist' :: Parser GanOpts
143+mnist' = GanOpts <$> argument str (metavar "TRAIN")
144+ <*> option auto (long "iterations" <> short 'i' <> value 15)
145+ <*> (LearningParameters
146+ <$> option auto (long "train_rate" <> short 'r' <> value 0.01)
147+ <*> option auto (long "momentum" <> value 0.9)
148+ <*> option auto (long "l2" <> value 0.0005)
149+ )
150+ <*> optional (strOption (long "load"))
151+ <*> optional (strOption (long "save"))
152+
153+
154+main :: IO ()
155+main = do
156+ GanOpts mnist iter rate load save <- execParser (info (mnist' <**> helper) idm)
157+ putStrLn "Training stupidly simply GAN"
158+ nets0 <- case load of
159+ Just loadFile -> netLoad loadFile
160+ Nothing -> (,) <$> randomDiscriminator <*> randomGenerator
161+
162+ res <- runExceptT $ ganTest nets0 iter mnist rate
163+ case res of
164+ Right nets1 -> case save of
165+ Just saveFile -> B.writeFile saveFile $ runPut (put nets1)
166+ Nothing -> return ()
167+
168+ Left err -> putStrLn err
169+
170+readMNIST :: FilePath -> ExceptT String IO [(S ('D2 28 28), S ('D1 10))]
171+readMNIST mnist = ExceptT $ do
172+ mnistdata <- T.readFile mnist
173+ return $ traverse (A.parseOnly parseMNIST) (T.lines mnistdata)
174+
175+parseMNIST :: A.Parser (S ('D2 28 28), S ('D1 10))
176+parseMNIST = do
177+ Just lab <- oneHot <$> A.decimal
178+ pixels <- many (A.char ',' >> A.double)
179+ image <- maybe (fail "Parsed row was of an incorrect size") pure (fromStorable . V.fromList $ pixels)
180+ return (image, lab)
181+
182+netLoad :: FilePath -> IO (Discriminator, Generator)
183+netLoad modelPath = do
184+ modelData <- B.readFile modelPath
185+ either fail return $ runGet (get :: Get (Discriminator, Generator)) modelData
main/mnist.hs → examples/main/mnist.hsrenamed+30−8
@@ -1,10 +1,12 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleContexts #-}
9+
8import Control.Applicative
10import Control.Applicative
9import Control.Monad
11import Control.Monad
10import Control.Monad.Random
12import Control.Monad.Random
@@ -12,6 +14,10 @@ import Control.Monad.Trans.Except
12
14
13import qualified Data.Attoparsec.Text as A
15import qualified Data.Attoparsec.Text as A
14import Data.List ( foldl' )
16import Data.List ( foldl' )
17+#if ! MIN_VERSION_base(4,13,0)
18+import Data.Semigroup ( (<>) )
19+#endif
20+
15import qualified Data.Text as T
21import qualified Data.Text as T
16import qualified Data.Text.IO as T
22import qualified Data.Text.IO as T
17import qualified Data.Vector.Storable as V
23import qualified Data.Vector.Storable as V
@@ -24,6 +30,15 @@ import Options.Applicative
24import Grenade
30import Grenade
25import Grenade.Utils.OneHot
31import Grenade.Utils.OneHot
26
32
33+-- It's logistic regression!
34+--
35+-- This network is used to show how we can embed a Network as a layer in the larger MNIST
36+-- type.
37+type FL i o =
38+ Network
39+ '[ FullyConnected i o, Logit ]
40+ '[ 'D1 i, 'D1 o, 'D1 o ]
41+
27-- The definition of our convolutional neural network.
42-- The definition of our convolutional neural network.
28-- In the type signature, we have a type level list of shapes which are passed between the layers.
43-- In the type signature, we have a type level list of shapes which are passed between the layers.
29-- One can see that the images we are inputing are two dimensional with 28 * 28 pixels.
44-- One can see that the images we are inputing are two dimensional with 28 * 28 pixels.
@@ -33,14 +48,21 @@ import Grenade.Utils.OneHot
33
48
34-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,
49-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,
35-- this network should get down to about a 1.3% error rate.
50-- this network should get down to about a 1.3% error rate.
36−type MNISTa = Network '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Elu, Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Elu, FlattenLayer ]
51+--
37− '[ 'D2 28 28, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10, 'D3 8 8 16, 'D3 4 4 16, 'D3 4 4 16, 'D1 256 ]
52+-- /NOTE:/ This model is actually too complex for MNIST, and one should use the type given in the readme instead.
38−
53+-- This one is just here to demonstrate Inception layers in use.
39−type MNISTb = Network '[ Convolution 1 10 7 7 1 1, Pooling 2 2 2 2, Elu, Convolution 10 16 4 4 1 1, Pooling 2 2 2 2, Elu, FlattenLayer ]
54+--
40− '[ 'D2 28 28, 'D3 22 22 10, 'D3 11 11 10, 'D3 11 11 10, 'D3 8 8 16, 'D3 4 4 16, 'D3 4 4 16, 'D1 256 ]
55+type MNIST =
41−
56+ Network
42−type MNIST = Network '[ (MNISTa, MNISTb), FullyConnected 256 80, Logit, FullyConnected 80 10, Logit ]
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,
43− '[ 'D2 28 28, 'D1 256, 'D1 80, 'D1 80, 'D1 10, 'D1 10 ]
65+ 'D1 288, 'D1 80, 'D1 10 ]
44
66
45randomMnist :: MonadRandom m => m MNIST
67randomMnist :: MonadRandom m => m MNIST
46randomMnist = randomNetwork
68randomMnist = randomNetwork
main/recurrent.hs → examples/main/recurrent.hsrenamed+15−8
@@ -1,4 +1,5 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
@@ -8,7 +9,13 @@
8import Control.Monad ( foldM )
9import Control.Monad ( foldM )
9import Control.Monad.Random ( MonadRandom, getRandomR )
10import Control.Monad.Random ( MonadRandom, getRandomR )
10
11
12+#if MIN_VERSION_base(4,13,0)
13+import Data.List ( unfoldr )
14+#else
11import Data.List ( cycle, unfoldr )
15import Data.List ( cycle, unfoldr )
16+import Data.Semigroup ( (<>) )
17+#endif
18+
12import qualified Numeric.LinearAlgebra.Static as SA
19import qualified Numeric.LinearAlgebra.Static as SA
13
20
14import Options.Applicative
21import Options.Applicative
@@ -24,12 +31,12 @@ import Grenade.Recurrent
24-- creation function know how to treat the layers.
31-- creation function know how to treat the layers.
25type R = Recurrent
32type R = Recurrent
26
33
27−type RecNet = RecurrentNetwork '[ R (LSTM 1 4), R (LSTM 4 1)]
34+type RecNet = RecurrentNetwork '[ R (LSTM 1 1)]
28− '[ 'D1 1, 'D1 4, 'D1 1 ]
35+ '[ 'D1 1, 'D1 1]
29
36
30−type RecInput = RecurrentInputs '[ R (LSTM 1 4), R (LSTM 4 1)]
37+type RecInput = RecurrentInputs '[ R (LSTM 1 1)]
31
38
32−randomNet :: MonadRandom m => m (RecNet, RecInput)
39+randomNet :: MonadRandom m => m RecNet
33randomNet = randomRecurrent
40randomNet = randomRecurrent
34
41
35netTest :: MonadRandom m => RecNet -> RecInput -> LearningParameters -> Int -> m (RecNet, RecInput)
42netTest :: MonadRandom m => RecNet -> RecInput -> LearningParameters -> Int -> m (RecNet, RecInput)
@@ -62,8 +69,8 @@ generateRecurrent n s i =
62 unfoldr go (s, i)
69 unfoldr go (s, i)
63 where
70 where
64 go (x, y) =
71 go (x, y) =
65− do let (ns, o) = runRecurrent n x y
72+ do let (_, ns, o) = runRecurrent n x y
66− o' = heat o
73+ o' = heat o
67 Just (o', (ns, fromIntegral o'))
74 Just (o', (ns, fromIntegral o'))
68
75
69 heat :: S ('D1 1) -> Int
76 heat :: S ('D1 1) -> Int
@@ -75,8 +82,8 @@ main = do
75 FeedForwardOpts examples rate <- execParser (info (feedForward' <**> helper) idm)
82 FeedForwardOpts examples rate <- execParser (info (feedForward' <**> helper) idm)
76 putStrLn "Training network..."
83 putStrLn "Training network..."
77
84
78− (net0, i0) <- randomNet
85+ net0 <- randomNet
79− (trained, bestInput) <- netTest net0 i0 rate examples
86+ (trained, bestInput) <- netTest net0 0 rate examples
80
87
81 let results = generateRecurrent trained bestInput (c 1)
88 let results = generateRecurrent trained bestInput (c 1)
82
89
main/shakespeare.hs → examples/main/shakespeare.hsrenamed+26−22
@@ -1,5 +1,5 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE CPP #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
@@ -14,16 +14,15 @@ import Data.Char ( isUpper, toUpper, toLower )
14import Data.List ( foldl' )
14import Data.List ( foldl' )
15import Data.Maybe ( fromMaybe )
15import Data.Maybe ( fromMaybe )
16
16
17+
17import qualified Data.Vector as V
18import qualified Data.Vector as V
18import Data.Vector ( Vector )
19import Data.Vector ( Vector )
19
20
20import qualified Data.Map as M
21import qualified Data.Map as M
21−import Data.Proxy ( Proxy (..) )
22
22
23import qualified Data.ByteString as B
23import qualified Data.ByteString as B
24import Data.Serialize
24import Data.Serialize
25
25
26−import Data.Singletons.Prelude
27import GHC.TypeLits
26import GHC.TypeLits
28
27
29import Numeric.LinearAlgebra.Static ( konst )
28import Numeric.LinearAlgebra.Static ( konst )
@@ -35,11 +34,16 @@ import Grenade.Recurrent
35import Grenade.Utils.OneHot
34import Grenade.Utils.OneHot
36
35
37import System.IO.Unsafe ( unsafeInterleaveIO )
36import System.IO.Unsafe ( unsafeInterleaveIO )
37+import Data.Proxy
38+import Prelude.Singletons
38
39
39-- The defininition for our natural language recurrent network.
40-- The defininition for our natural language recurrent network.
40-- This network is able to learn and generate simple words in
41-- This network is able to learn and generate simple words in
41-- about an hour.
42-- about an hour.
42--
43--
44+-- Grab the input from
45+-- https://raw.githubusercontent.com/karpathy/char-rnn/master/data/tinyshakespeare/input.txt
46+--
43-- This is a first class recurrent net.
47-- This is a first class recurrent net.
44--
48--
45-- The F and R types are tagging types to ensure that the runner and
49-- The F and R types are tagging types to ensure that the runner and
@@ -60,7 +64,7 @@ type Shakespeare = RecurrentNetwork '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyC
60-- The definition of the "sideways" input, which the network is fed recurrently.
64-- The definition of the "sideways" input, which the network is fed recurrently.
61type Shakespearian = RecurrentInputs '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyConnected 40 40), F Logit]
65type Shakespearian = RecurrentInputs '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyConnected 40 40), F Logit]
62
66
63−randomNet :: MonadRandom m => m (Shakespeare, Shakespearian)
67+randomNet :: MonadRandom m => m Shakespeare
64randomNet = randomRecurrent
68randomNet = randomRecurrent
65
69
66-- | Load the data files and prepare a map of characters to a compressed int representation.
70-- | Load the data files and prepare a map of characters to a compressed int representation.
@@ -68,40 +72,40 @@ loadShakespeare :: FilePath -> ExceptT String IO (Vector Int, M.Map Char Int, Ve
68loadShakespeare path = do
72loadShakespeare path = do
69 contents <- lift $ readFile path
73 contents <- lift $ readFile path
70 let annotated = annotateCapitals contents
74 let annotated = annotateCapitals contents
71− (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
72 hot <- ExceptT . return . note "Couldn't generate hot values" $ traverse (`M.lookup` m) annotated
76 hot <- ExceptT . return . note "Couldn't generate hot values" $ traverse (`M.lookup` m) annotated
73 return (V.fromList hot, m, cs)
77 return (V.fromList hot, m, cs)
74
78
75trainSlice :: LearningParameters -> Shakespeare -> Shakespearian -> Vector Int -> Int -> Int -> (Shakespeare, Shakespearian)
79trainSlice :: LearningParameters -> Shakespeare -> Shakespearian -> Vector Int -> Int -> Int -> (Shakespeare, Shakespearian)
76−trainSlice !rate !net !recIns input offset size =
80+trainSlice !lrate !net !recIns input offset size =
77 let e = fmap (x . oneHot) . V.toList $ V.slice offset size input
81 let e = fmap (x . oneHot) . V.toList $ V.slice offset size input
78 in case reverse e of
82 in case reverse e of
79 (o : l : xs) ->
83 (o : l : xs) ->
80 let examples = reverse $ (l, Just o) : ((,Nothing) <$> xs)
84 let examples = reverse $ (l, Just o) : ((,Nothing) <$> xs)
81− in trainRecurrent rate net recIns examples
85+ in trainRecurrent lrate net recIns examples
82 _ -> error "Not enough input"
86 _ -> error "Not enough input"
83 where
87 where
84 x = fromMaybe (error "Hot variable didn't fit.")
88 x = fromMaybe (error "Hot variable didn't fit.")
85
89
86runShakespeare :: ShakespeareOpts -> ExceptT String IO ()
90runShakespeare :: ShakespeareOpts -> ExceptT String IO ()
87−runShakespeare ShakespeareOpts {..} = do
91+runShakespeare opts = do
88− (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare trainingFile
92+ (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare $ trainingFile opts
89 (net0, i0) <- lift $
93 (net0, i0) <- lift $
90− case loadPath of
94+ case loadPath opts of
91 Just loadFile -> netLoad loadFile
95 Just loadFile -> netLoad loadFile
92− Nothing -> randomNet
96+ Nothing -> (,0) <$> randomNet
93
97
94 (trained, bestInput) <- lift $ foldM (\(!net, !io) size -> do
98 (trained, bestInput) <- lift $ foldM (\(!net, !io) size -> do
95− xs <- take (iterations `div` 10) <$> getRandomRs (0, length shakespeare - size - 1)
99+ xs <- take (iterations opts `div` 10) <$> getRandomRs (0, length shakespeare - size - 1)
96− let (!trained, !bestInput) = foldl' (\(!n, !i) offset -> trainSlice rate n i shakespeare offset size) (net, io) xs
100+ let (!trained, !bestInput) = foldl' (\(!n, !i) offset -> trainSlice (rate opts) n i shakespeare offset size) (net, io) xs
97− results <- take 1000 <$> generateParagraph trained bestInput temperature oneHotMap oneHotDictionary ( S1D $ konst 0)
101+ results <- take 1000 <$> generateParagraph trained bestInput (temperature opts) oneHotMap oneHotDictionary ( S1D $ konst 0)
98 putStrLn ("TRAINING STEP WITH SIZE: " ++ show size)
102 putStrLn ("TRAINING STEP WITH SIZE: " ++ show size)
99 putStrLn (unAnnotateCapitals results)
103 putStrLn (unAnnotateCapitals results)
100 return (trained, bestInput)
104 return (trained, bestInput)
101− ) (net0, i0) $ replicate 10 sequenceSize
105+ ) (net0, i0) $ replicate 10 (sequenceSize opts)
102
106
103− case savePath of
107+ case savePath opts of
104− Just saveFile -> lift . B.writeFile saveFile $ runPut (put (trained, bestInput))
108+ Just saveFile -> lift . B.writeFile saveFile $ runPut (put trained >> put bestInput)
105 Nothing -> return ()
109 Nothing -> return ()
106
110
107generateParagraph :: forall layers shapes n a. (Last shapes ~ 'D1 n, Head shapes ~ 'D1 n, KnownNat n, Ord a)
111generateParagraph :: forall layers shapes n a. (Last shapes ~ 'D1 n, Head shapes ~ 'D1 n, KnownNat n, Ord a)
@@ -112,14 +116,14 @@ generateParagraph :: forall layers shapes n a. (Last shapes ~ 'D1 n, Head shapes
112 -> Vector a
116 -> Vector a
113 -> S ('D1 n)
117 -> S ('D1 n)
114 -> IO [a]
118 -> IO [a]
115−generateParagraph n s temperature hotmap hotdict =
119+generateParagraph n s temp hotmap hotdict =
116 go s
120 go s
117 where
121 where
118 go x y =
122 go x y =
119− do let (ns, o) = runRecurrent n x y
123+ do let (_, ns, o) = runRecurrent n x y
120− un <- sample temperature hotdict o
124+ un <- sample temp hotdict o
121− Just re <- return $ makeHot hotmap un
125+ Just re <- return $ makeHot hotmap un
122− rest <- unsafeInterleaveIO $ go ns re
126+ rest <- unsafeInterleaveIO $ go ns re
123 return (un : rest)
127 return (un : rest)
124
128
125data ShakespeareOpts = ShakespeareOpts {
129data ShakespeareOpts = ShakespeareOpts {
framework/mafianew file+62
@@ -0,0 +1,62 @@
1+#!/bin/sh -eu
2+
3+: ${MAFIA_HOME:=$HOME/.mafia}
4+: ${MAFIA_VERSIONS:=$MAFIA_HOME/versions}
5+
6+latest_version () {
7+ git ls-remote https://github.com/haskell-mafia/mafia | grep refs/heads/master | cut -f 1
8+}
9+
10+build_version() {
11+ MAFIA_VERSION="$1"
12+ MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia')
13+ MAFIA_FILE=mafia-$MAFIA_VERSION
14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE
15+ mkdir -p $MAFIA_VERSIONS
16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"
17+ git clone https://github.com/haskell-mafia/mafia $MAFIA_TEMP
18+ git --git-dir="$MAFIA_TEMP/.git" --work-tree="$MAFIA_TEMP" reset --hard $MAFIA_VERSION || {
19+ echo "mafia version ($MAFIA_VERSION) could not be found." >&2
20+ exit 1
21+ }
22+ (cd "$MAFIA_TEMP" && ./bin/bootstrap) || {
23+ got=$?
24+ echo "mafia version ($MAFIA_VERSION) could not be built." >&2
25+ exit "$got"
26+ }
27+ chmod +x "$MAFIA_TEMP/.cabal-sandbox/bin/mafia"
28+ # Ensure executable is on same file-system so final mv is atomic.
29+ mv -f "$MAFIA_TEMP/.cabal-sandbox/bin/mafia" "$MAFIA_PATH.$$"
30+ mv "$MAFIA_PATH.$$" "$MAFIA_PATH" || {
31+ rm -f "$MAFIA_PATH.$$"
32+ echo "INFO: mafia version ($MAFIA_VERSION) already exists not overiding," >&2
33+ echo "INFO: this is expected if parallel builds of the same version of" >&2
34+ echo "INFO: mafia occur, we are playing by first in, wins." >&2
35+ exit 0
36+ }
37+}
38+
39+enable_version() {
40+ if [ $# -eq 0 ]; then
41+ MAFIA_VERSION="$(latest_version)"
42+ echo "INFO: No explicit mafia version requested installing latest ($MAFIA_VERSION)." >&2
43+ else
44+ MAFIA_VERSION="$1"
45+ fi
46+ [ -x "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" ] || build_version "$MAFIA_VERSION"
47+ ln -sf "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" "$MAFIA_HOME/versions/mafia"
48+}
49+
50+exec_mafia () {
51+ [ -x "$MAFIA_HOME/versions/mafia" ] || enable_version
52+ "$MAFIA_HOME/versions/mafia" "$@"
53+}
54+
55+#
56+# The actual start of the script.....
57+#
58+
59+case "${1:-}" in
60+upgrade) shift; enable_version "$@" ;;
61+*) exec_mafia "$@"
62+esac
grenade.cabal+115−115
@@ -1,45 +1,69 @@
1name: grenade
1name: grenade
2−version: 0.0.1
2+version: 0.1.0
3license: BSD2
3license: BSD2
4+license-file: LICENSE
4author: Huw Campbell <huw.campbell@gmail.com>
5author: Huw Campbell <huw.campbell@gmail.com>
5maintainer: Huw Campbell <huw.campbell@gmail.com>
6maintainer: Huw Campbell <huw.campbell@gmail.com>
6−copyright: (c) 2015 Huw Campbell.
7+copyright: (c) 2016-2017 Huw Campbell.
7−synopsis: grenade
8+synopsis: Practical Deep Learning in Haskell
8−category: System
9+category: AI, Machine Learning
9−cabal-version: >= 1.8
10+cabal-version: >= 1.10
10build-type: Simple
11build-type: Simple
11−description: grenade.
12+description:
13+ Grenade is a composable, dependently typed, practical, and fast
14+ recurrent neural network library for precise specifications and
15+ complex deep neural networks in Haskell.
16+ .
17+ Grenade provides an API for composing layers of a neural network
18+ into a sequence parallel graph in a type safe manner; running
19+ networks with reverse automatic differentiation to calculate their
20+ gradients; and applying gradient descent for learning.
21+ .
22+ Documentation and examples are available on github
23+ <https://github.com/HuwCampbell/grenade>.
12
24
13extra-source-files:
25extra-source-files:
26+ README.md
14− cbits/im2col.h
27+ cbits/im2col.h
15− cbits/im2col.c
28+ cbits/im2col.c
29+ cbits/gradient_descent.h
30+ cbits/gradient_descent.c
31+ cbits/pad.h
32+ cbits/pad.c
33+
34+source-repository head
35+ type: git
36+ location: https://github.com/HuwCampbell/grenade.git
16
37
17library
38library
18 build-depends:
39 build-depends:
19 base >= 4.8 && < 5
40 base >= 4.8 && < 5
20− , bytestring == 0.10.*
41+ , bytestring >= 0.10.0
21− , async
22− , containers
42+ , containers >= 0.5 && < 0.7
23− , deepseq
24− , either == 4.4.*
25− , cereal
43+ , cereal >= 0.5 && < 0.6
26− , exceptions == 0.8.*
44+ , deepseq >= 1.4 && < 1.5
27− , hmatrix
45+ , hmatrix >= 0.18 && < 0.21
28− , MonadRandom
46+ , MonadRandom >= 0.4 && < 0.6
29− , mtl >= 2.2.1 && < 2.3
30− , parallel == 3.2.*
31− , primitive
47+ , primitive >= 0.6 && < 0.8
32− , reflection
48+ -- Versions of singletons are *tightly* coupled with the
33− , text == 1.2.*
49+ -- GHC version so its fine to drop version bounds.
34− , transformers
35 , singletons
50 , singletons
51+ , singletons-base
36− , vector
52+ , vector >= 0.11 && < 0.13
37
53
38 ghc-options:
54 ghc-options:
39 -Wall
55 -Wall
40 hs-source-dirs:
56 hs-source-dirs:
41 src
57 src
42
58
59+ default-language: Haskell2010
60+
61+ if impl(ghc < 8.0)
62+ ghc-options: -fno-warn-incomplete-patterns
63+ cpp-options: -DType=*
64+
65+ if impl(ghc >= 8.6)
66+ default-extensions: NoStarIsType
43
67
44 exposed-modules:
68 exposed-modules:
45 Grenade
69 Grenade
@@ -49,107 +73,54 @@ library
49 Grenade.Core.Network
73 Grenade.Core.Network
50 Grenade.Core.Runner
74 Grenade.Core.Runner
51 Grenade.Core.Shape
75 Grenade.Core.Shape
76+
77+ Grenade.Layers
52− Grenade.Layers.Crop
78+ Grenade.Layers.Concat
53 Grenade.Layers.Convolution
79 Grenade.Layers.Convolution
80+ Grenade.Layers.Crop
81+ Grenade.Layers.Deconvolution
54 Grenade.Layers.Dropout
82 Grenade.Layers.Dropout
83+ Grenade.Layers.Elu
55 Grenade.Layers.FullyConnected
84 Grenade.Layers.FullyConnected
56− Grenade.Layers.Flatten
85+ Grenade.Layers.Inception
57 Grenade.Layers.Logit
86 Grenade.Layers.Logit
58− Grenade.Layers.Relu
87+ Grenade.Layers.Merge
59− Grenade.Layers.Elu
60− Grenade.Layers.Tanh
61 Grenade.Layers.Pad
88 Grenade.Layers.Pad
62 Grenade.Layers.Pooling
89 Grenade.Layers.Pooling
90+ Grenade.Layers.Relu
91+ Grenade.Layers.Reshape
92+ Grenade.Layers.Sinusoid
93+ Grenade.Layers.Softmax
94+ Grenade.Layers.Tanh
95+ Grenade.Layers.Trivial
63
96
64 Grenade.Layers.Internal.Convolution
97 Grenade.Layers.Internal.Convolution
98+ Grenade.Layers.Internal.Pad
65 Grenade.Layers.Internal.Pooling
99 Grenade.Layers.Internal.Pooling
66 Grenade.Layers.Internal.Update
100 Grenade.Layers.Internal.Update
67
101
68 Grenade.Recurrent
102 Grenade.Recurrent
69
103
104+ Grenade.Recurrent.Core
105+ Grenade.Recurrent.Core.Layer
70 Grenade.Recurrent.Core.Network
106 Grenade.Recurrent.Core.Network
71 Grenade.Recurrent.Core.Runner
107 Grenade.Recurrent.Core.Runner
72
108
109+ Grenade.Recurrent.Layers
73 Grenade.Recurrent.Layers.BasicRecurrent
110 Grenade.Recurrent.Layers.BasicRecurrent
111+ Grenade.Recurrent.Layers.ConcatRecurrent
74 Grenade.Recurrent.Layers.LSTM
112 Grenade.Recurrent.Layers.LSTM
75
113
76 Grenade.Utils.OneHot
114 Grenade.Utils.OneHot
77
115
78− includes: cbits/im2col.h
116+ includes: cbits/im2col.h
79− cbits/gradient_decent.h
117+ cbits/gradient_descent.h
118+ cbits/pad.h
80− c-sources: cbits/im2col.c
119+ c-sources: cbits/im2col.c
81− cbits/gradient_decent.c
120+ cbits/gradient_descent.c
82−
121+ cbits/pad.c
83− cc-options: -std=c99 -O3 -msse4.2 -Wall -Werror -DCABAL=1
84−
85−executable feedforward
86− ghc-options: -Wall -threaded -O2
87− main-is: main/feedforward.hs
88− build-depends: base
89− , grenade
90− , attoparsec
91− , bytestring
92− , cereal
93− , either
94− , optparse-applicative == 0.12.*
95− , text == 1.2.*
96− , mtl >= 2.2.1 && < 2.3
97− , hmatrix
98− , transformers
99− , singletons
100− , MonadRandom
101−
102−executable mnist
103− ghc-options: -Wall -threaded -O2
104− main-is: main/mnist.hs
105− build-depends: base
106− , grenade
107− , attoparsec
108− , either
109− , optparse-applicative == 0.12.*
110− , text == 1.2.*
111− , mtl >= 2.2.1 && < 2.3
112− , hmatrix >= 0.18 && < 0.19
113− , transformers
114− , singletons
115− , MonadRandom
116− , vector
117−
118−executable recurrent
119− ghc-options: -Wall -threaded -O2
120− main-is: main/recurrent.hs
121− build-depends: base
122− , grenade
123− , attoparsec
124− , either
125− , optparse-applicative == 0.12.*
126− , text == 1.2.*
127− , mtl >= 2.2.1 && < 2.3
128− , hmatrix >= 0.18 && < 0.19
129− , transformers
130− , singletons
131− , MonadRandom
132−
133−
134−executable shakespeare
135− ghc-options: -Wall -threaded -O2
136− main-is: main/shakespeare.hs
137− build-depends: base
138− , grenade
139− , attoparsec
140− , bytestring
141− , cereal
142− , either
143− , optparse-applicative == 0.12.*
144− , text == 1.2.*
145− , mtl >= 2.2.1 && < 2.3
146− , hmatrix >= 0.18 && < 0.19
147− , transformers
148− , singletons
149− , vector
150− , MonadRandom
151− , containers
152
122
123+ cc-options: -std=c99 -O3 -msse4.2 -Wall -Werror -DCABAL=1
153
124
154test-suite test
125test-suite test
155 type: exitcode-stdio-1.0
126 type: exitcode-stdio-1.0
@@ -161,23 +132,48 @@ test-suite test
161 hs-source-dirs:
132 hs-source-dirs:
162 test
133 test
163
134
135+ default-language: Haskell2010
136+
137+ other-modules: Test.Hedgehog.Compat
138+ Test.Hedgehog.Hmatrix
139+ Test.Hedgehog.TypeLits
140+
141+ Test.Grenade.Network
142+ Test.Grenade.Layers.Convolution
143+ Test.Grenade.Layers.FullyConnected
144+ Test.Grenade.Layers.Nonlinear
145+ Test.Grenade.Layers.PadCrop
146+ Test.Grenade.Layers.Pooling
147+ Test.Grenade.Layers.Internal.Convolution
148+ Test.Grenade.Layers.Internal.Pooling
149+ Test.Grenade.Layers.Internal.Reference
150+
151+ Test.Grenade.Recurrent.Layers.LSTM
152+ Test.Grenade.Recurrent.Layers.LSTM.Reference
153+
154+ if impl(ghc < 8.0)
155+ ghc-options: -fno-warn-incomplete-patterns
156+ cpp-options: -DType=*
157+
158+ if impl(ghc >= 8.6)
159+ default-extensions: NoStarIsType
160+
164 build-depends:
161 build-depends:
165− base >= 4.8 && < 5
162+ base
166 , grenade
163 , grenade
167− , ambiata-disorder-core
164+ , hedgehog >= 1.0 && < 1.1
168− , ambiata-disorder-jack
169 , hmatrix
165 , hmatrix
170 , mtl
166 , mtl
171 , singletons
167 , singletons
172 , text == 1.2.*
168 , text == 1.2.*
173− , typelits-witnesses
169+ , typelits-witnesses < 0.4
170+ , transformers
174 , constraints
171 , constraints
175− , QuickCheck >= 2.7 && < 2.9
176− , quickcheck-instances == 0.3.*
177 , MonadRandom
172 , MonadRandom
178 , random
173 , random
179 , ad
174 , ad
180 , reflection
175 , reflection
176+ , vector
181
177
182
178
183benchmark bench
179benchmark bench
@@ -190,10 +186,12 @@ benchmark bench
190 hs-source-dirs:
186 hs-source-dirs:
191 bench
187 bench
192
188
189+ default-language: Haskell2010
190+
193 build-depends:
191 build-depends:
194− base >= 3 && < 5
192+ base
195− , bytestring == 0.10.*
193+ , bytestring
196− , criterion == 1.1.*
194+ , criterion >= 1.1 && < 1.6
197 , grenade
195 , grenade
198 , hmatrix
196 , hmatrix
199
197
@@ -207,9 +205,11 @@ benchmark bench-lstm
207 hs-source-dirs:
205 hs-source-dirs:
208 bench
206 bench
209
207
208+ default-language: Haskell2010
209+
210 build-depends:
210 build-depends:
211− base >= 3 && < 5
211+ base
212− , bytestring == 0.10.*
212+ , bytestring
213− , criterion == 1.1.*
213+ , criterion
214 , grenade
214 , grenade
215 , hmatrix
215 , hmatrix
lib/disorder.hsdeleted−1

Submodule changed.

lib/pdeleted−1

Submodule changed.

mafiamode 100755 → 120000+1−123
@@ -1,123 +0,0 @@
1−#!/bin/sh -eu
2−
3−: ${MAFIA_HOME:=$HOME/.mafia}
4−
5−fetch_latest () {
6− if [ -z ${MAFIA_TEST_MODE+x} ]; then
7− TZ=$(date +"%T")
8− curl --silent "https://raw.githubusercontent.com/ambiata/mafia/master/script/mafia?$TZ"
9− else
10− cat ../script/mafia
11− fi
12−}
13−
14−latest_version () {
15− git ls-remote https://github.com/ambiata/mafia | grep refs/heads/master | cut -f 1
16−}
17−
18−local_version () {
19− awk '/^# Version: / { print $3; exit 0; }' $0
20−}
21−
22−run_upgrade () {
23− MAFIA_TEMP=$(mktemp 2>/dev/null || mktemp -t 'upgrade_mafia')
24−
25− clean_up () {
26− rm -f "$MAFIA_TEMP"
27− }
28−
29− trap clean_up EXIT
30−
31− MAFIA_CUR="$0"
32−
33− if [ -L "$MAFIA_CUR" ]; then
34− echo 'Refusing to overwrite a symlink; run `upgrade` from the canonical path.' >&2
35− exit 1
36− fi
37−
38− echo "Checking for a new version of mafia ..."
39− fetch_latest > $MAFIA_TEMP
40−
41− LATEST_VERSION=$(latest_version)
42− echo "# Version: $LATEST_VERSION" >> $MAFIA_TEMP
43−
44− if ! cmp $MAFIA_CUR $MAFIA_TEMP >/dev/null 2>&1; then
45− mv $MAFIA_TEMP $MAFIA_CUR
46− chmod +x $MAFIA_CUR
47− echo "New version found and upgraded. You can now commit it to your git repo."
48− else
49− echo "You have latest mafia."
50− fi
51−}
52−
53−exec_mafia () {
54− MAFIA_VERSION=$(local_version)
55−
56− if [ "x$MAFIA_VERSION" = "x" ]; then
57− # If we can't find the mafia version, then we need to upgrade the script.
58− run_upgrade
59− else
60− MAFIA_BIN=$MAFIA_HOME/bin
61− MAFIA_FILE=mafia-$MAFIA_VERSION
62− MAFIA_PATH=$MAFIA_BIN/$MAFIA_FILE
63−
64− [ -f "$MAFIA_PATH" ] || {
65− # Create a temporary directory which will be deleted when the script
66− # terminates. Unfortunately `mktemp` doesn't behave the same on
67− # Linux and OS/X so we need to try two different approaches.
68− MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia')
69−
70− # Create a temporary file in MAFIA_BIN so we can do an atomic copy/move dance.
71− mkdir -p $MAFIA_BIN
72−
73− clean_up () {
74− rm -rf "$MAFIA_TEMP"
75− }
76−
77− trap clean_up EXIT
78−
79− echo "Building $MAFIA_FILE in $MAFIA_TEMP"
80−
81− ( cd "$MAFIA_TEMP"
82−
83− git clone https://github.com/ambiata/mafia
84− cd mafia
85−
86− git reset --hard $MAFIA_VERSION
87−
88− bin/bootstrap ) || exit $?
89−
90− MAFIA_PATH_TEMP=$(mktemp --tmpdir=$MAFIA_BIN $MAFIA_FILE-XXXXXX 2>/dev/null || TMPDIR=$MAFIA_BIN mktemp -t $MAFIA_FILE)
91−
92− clean_up_temp () {
93− clean_up
94− rm -f "$MAFIA_PATH_TEMP"
95− }
96− trap clean_up_temp EXIT
97−
98− cp "$MAFIA_TEMP/mafia/.cabal-sandbox/bin/mafia" "$MAFIA_PATH_TEMP"
99− chmod 755 "$MAFIA_PATH_TEMP"
100− mv "$MAFIA_PATH_TEMP" "$MAFIA_PATH"
101−
102− clean_up_temp
103− }
104−
105− exec $MAFIA_PATH "$@"
106− fi
107−}
108−
109−#
110−# The actual start of the script.....
111−#
112−
113−if [ $# -gt 0 ]; then
114− MODE="$1"
115−else
116− MODE=""
117−fi
118−
119−case "$MODE" in
120−upgrade) shift; run_upgrade "$@" ;;
121−*) exec_mafia "$@"
122−esac
123−# Version: 360716306a06db842ec022a7b9f161d2208483f0
@@ -0,0 +1 @@
1+framework/mafia
src/Grenade.hs+50−18
@@ -1,21 +1,53 @@
1module Grenade (
1module Grenade (
2+ -- | This is an empty module which simply re-exports public definitions
3+ -- for machine learning with Grenade.
4+
5+ -- * Exported modules
6+ --
7+ -- | The core types and runners for Grenade.
2− module X
8+ module Grenade.Core
9+
10+ -- | The neural network layer zoo
11+ , module Grenade.Layers
12+
13+
14+ -- * Overview of the library
15+ -- $library
16+
17+ -- * Example usage
18+ -- $example
19+
3 ) where
20 ) where
4
21
5−import Grenade.Core.LearningParameters as X
22+import Grenade.Core
6−import Grenade.Core.Layer as X
23+import Grenade.Layers
7−import Grenade.Core.Network as X
24+
8−import Grenade.Core.Runner as X
25+{- $library
9−import Grenade.Core.Shape as X
26+Grenade is a purely functional deep learning library.
10−import Grenade.Layers.Crop as X
27+
11−import Grenade.Layers.Dropout as X
28+It provides an expressive type level API for the construction
12−import Grenade.Layers.Pad as X
29+of complex neural network architectures. Backing this API is and
13−import Grenade.Layers.Pooling as X
30+implementation written using BLAS and LAPACK, mostly provided by
14−import Grenade.Layers.Flatten as X
31+the hmatrix library.
15−import Grenade.Layers.FullyConnected as X
32+
16−import Grenade.Layers.Logit as X
33+-}
17−import Grenade.Layers.Convolution as X
34+
18−import Grenade.Layers.Relu as X
35+{- $example
19−import Grenade.Layers.Elu as X
36+A few examples are provided at https://github.com/HuwCampbell/grenade
20−import Grenade.Layers.Tanh as X
37+under the examples folder.
21−import Grenade.Layers.Softmax as X
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 @@
1module Grenade.Core (
1module Grenade.Core (
2− module X
2+ module Grenade.Core.Layer
3+ , module Grenade.Core.LearningParameters
4+ , module Grenade.Core.Network
5+ , module Grenade.Core.Runner
6+ , module Grenade.Core.Shape
3 ) where
7 ) where
4
8
5−import Grenade.Core.Layer as X
9+import Grenade.Core.Layer
6−import Grenade.Core.LearningParameters as X
10+import Grenade.Core.LearningParameters
7−import Grenade.Core.Shape as X
8−import Grenade.Core.Network as X
11+import Grenade.Core.Network
12+import Grenade.Core.Runner
13+import Grenade.Core.Shape
src/Grenade/Core/Layer.hs+46−36
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TypeOperators #-}
@@ -7,32 +8,55 @@
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE FlexibleInstances #-}
9{-|
10{-|
10−Module : Grenade.Core.Network
11+Module : Grenade.Core.Layer
11−Description : Core definition a simple neural etwork
12+Description : Defines the Layer Classes
12Copyright : (c) Huw Campbell, 2016-2017
13Copyright : (c) Huw Campbell, 2016-2017
13License : BSD2
14License : BSD2
14Stability : experimental
15Stability : experimental
16+
17+This module defines what a Layer is in a Grenade
18+neural network.
19+
20+There are two classes of interest: `UpdateLayer` and `Layer`.
21+
22+`UpdateLayer` is required for all types which are used as a layer
23+in a network. Having no shape information, this class is agnostic
24+to the input and output data of the layer.
25+
26+An instance of `Layer` on the other hand is required for usage in
27+a neural network, but also specifies the shapes of data that the
28+network can transform. Multiple instance of `Layer` are permitted
29+for a single type, to transform different shapes. The `Reshape` layer
30+for example can act as a flattening layer, and its inverse, projecting
31+a 1D shape up to 2 or 3 dimensions.
32+
33+Instances of `Layer` should be as strict as possible, and not emit
34+runtime errors.
15-}
35-}
16module Grenade.Core.Layer (
36module Grenade.Core.Layer (
17 Layer (..)
37 Layer (..)
18 , UpdateLayer (..)
38 , UpdateLayer (..)
19 ) where
39 ) where
20
40
21−import Control.Monad.Random (MonadRandom)
41+import Control.Monad.Random ( MonadRandom )
22
42
23import Data.List ( foldl' )
43import Data.List ( foldl' )
44+
45+#if MIN_VERSION_base(4,9,0)
24−import Data.Singletons
46+import Data.Kind (Type)
47+#endif
25
48
26import Grenade.Core.Shape
49import Grenade.Core.Shape
27import Grenade.Core.LearningParameters
50import Grenade.Core.LearningParameters
28
51
29−-- | Class for updating a layer. All layers implement this, and it is
52+-- | Class for updating a layer. All layers implement this, as it
30−-- shape independent.
53+-- describes how to create and update the layer.
54+--
31class UpdateLayer x where
55class UpdateLayer x where
32− {-# MINIMAL runUpdate, createRandom #-}
33 -- | The type for the gradient for this layer.
56 -- | The type for the gradient for this layer.
34 -- Unit if there isn't a gradient to pass back.
57 -- Unit if there isn't a gradient to pass back.
35− type Gradient x :: *
58+ type Gradient x :: Type
59+
36 -- | Update a layer with its gradient and learning parameters
60 -- | Update a layer with its gradient and learning parameters
37 runUpdate :: LearningParameters -> x -> Gradient x -> x
61 runUpdate :: LearningParameters -> x -> Gradient x -> x
38
62
@@ -43,40 +67,26 @@ class UpdateLayer x where
43 runUpdates :: LearningParameters -> x -> [Gradient x] -> x
67 runUpdates :: LearningParameters -> x -> [Gradient x] -> x
44 runUpdates rate = foldl' (runUpdate rate)
68 runUpdates rate = foldl' (runUpdate rate)
45
69
70+ {-# MINIMAL runUpdate, createRandom #-}
71+
46-- | Class for a layer. All layers implement this, however, they don't
72-- | Class for a layer. All layers implement this, however, they don't
47−-- need to implement it for all shapes, only ones which are appropriate.
73+-- need to implement it for all shapes, only ones which are
74+-- appropriate.
75+--
48class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where
76class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where
49 -- | The Wengert tape for this layer. Includes all that is required
77 -- | The Wengert tape for this layer. Includes all that is required
50 -- to generate the back propagated gradients efficiently. As a
78 -- to generate the back propagated gradients efficiently. As a
51 -- default, `S i` is fine.
79 -- default, `S i` is fine.
52− type Tape x i o :: *
80+ type Tape x i o :: Type
81+
53 -- | Used in training and scoring. Take the input from the previous
82 -- | Used in training and scoring. Take the input from the previous
54 -- layer, and give the output from this layer.
83 -- layer, and give the output from this layer.
55 runForwards :: x -> S i -> (Tape x i o, S o)
84 runForwards :: x -> S i -> (Tape x i o, S o)
56− -- | Back propagate a step. Takes the current layer, the input that the
57− -- layer gave from the input and the back propagated derivatives from
58− -- the layer above.
59− -- Returns the gradient layer and the derivatives to push back further.
60− runBackwards :: x -> Tape x i o -> S o -> (Gradient x, S i)
61−
62
85
63−-- | Run two layers in parallel, combining their outputs.
86+ -- | Back propagate a step. Takes the current layer, the input that
64−-- This just kind of "smooshes" the weights together.
87+ -- the layer gave from the input and the back propagated derivatives
65−instance (UpdateLayer x, UpdateLayer y) => UpdateLayer (x, y) where
88+ -- from the layer above.
66− type Gradient (x, y) = (Gradient x, Gradient y)
89+ --
67− runUpdate lr (x, y) (x', y') = (runUpdate lr x x', runUpdate lr y y')
90+ -- Returns the gradient layer and the derivatives to push back
68− createRandom = (,) <$> createRandom <*> createRandom
91+ -- further.
69−
92+ runBackwards :: x -> Tape x i o -> S o -> (Gradient x, S i)
70−-- | Combine the outputs and the inputs, summing the output shape
71−instance (SingI i, SingI o, Layer x i o, Layer y i o) => Layer (x, y) i o where
72− type Tape (x, y) i o = (Tape x i o, Tape y i o)
73−
74− runForwards (x, y) input =
75− let (xT, xOut) = runForwards x input
76− (yT, yOut) = runForwards y input
77− in ((xT, yT), xOut + yOut)
78−
79− runBackwards (x, y) (xTape, yTape) o =
80− let (x', xB) = runBackwards x xTape o
81− (y', yB) = runBackwards y yTape o
82− in ((x', y'), xB + yB)
src/Grenade/Core/LearningParameters.hs+11
@@ -1,4 +1,15 @@
1+{-|
2+Module : Grenade.Core.LearningParameters
3+Description : Stochastic gradient descent learning parameters
4+Copyright : (c) Huw Campbell, 2016-2017
5+License : BSD2
6+Stability : experimental
7+-}
1module Grenade.Core.LearningParameters (
8module Grenade.Core.LearningParameters (
9+ -- | This module contains learning algorithm specific
10+ -- code. Currently, this module should be considered
11+ -- unstable, due to issue #26.
12+
2 LearningParameters (..)
13 LearningParameters (..)
3 ) where
14 ) where
4
15
src/Grenade/Core/Network.hs+120−62
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
@@ -9,45 +10,57 @@
9{-# LANGUAGE FlexibleInstances #-}
10{-# LANGUAGE FlexibleInstances #-}
10{-|
11{-|
11Module : Grenade.Core.Network
12Module : Grenade.Core.Network
12−Description : Core definition a simple neural etwork
13+Description : Core definition of a Neural Network
13Copyright : (c) Huw Campbell, 2016-2017
14Copyright : (c) Huw Campbell, 2016-2017
14License : BSD2
15License : BSD2
15Stability : experimental
16Stability : experimental
16
17
17−This module defines the core data type for the simplest
18+This module defines the core data types and functions
18−Neural network we support.
19+for non-recurrent neural networks.
19−
20-}
20-}
21+
21module Grenade.Core.Network (
22module Grenade.Core.Network (
22 Network (..)
23 Network (..)
23 , Gradients (..)
24 , Gradients (..)
24 , Tapes (..)
25 , Tapes (..)
25− , CreatableNetwork (..)
26
26
27+ , runNetwork
28+ , runGradient
27 , applyUpdate
29 , applyUpdate
30+
31+ , randomNetwork
28 ) where
32 ) where
29
33
30import Control.Monad.Random ( MonadRandom )
34import Control.Monad.Random ( MonadRandom )
31
35
32import Data.Singletons
36import Data.Singletons
33−import Data.Singletons.Prelude
34import Data.Serialize
37import Data.Serialize
35
38
39+#if MIN_VERSION_base(4,9,0)
40+import Data.Kind (Type)
41+#endif
42+
36import Grenade.Core.Layer
43import Grenade.Core.Layer
37import Grenade.Core.LearningParameters
44import Grenade.Core.LearningParameters
38import Grenade.Core.Shape
45import Grenade.Core.Shape
46+import Prelude.Singletons
39
47
40-- | Type of a network.
48-- | Type of a network.
41--
49--
42−-- The [*] type specifies the types of the layers.
50+-- The @[*]@ type specifies the types of the layers.
43--
51--
44−-- 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.
45--
53--
46-- Can be considered to be a heterogeneous list of layers which are able to
54-- Can be considered to be a heterogeneous list of layers which are able to
47-- transform the data shapes of the network.
55-- transform the data shapes of the network.
48−data Network :: [*] -> [Shape] -> * where
56+data Network :: [Type] -> [Shape] -> Type where
49− NNil :: SingI i => Network '[] '[i]
57+ NNil :: SingI i
58+ => Network '[] '[i]
59+
50− (:~>) :: (SingI i, SingI h, Layer x i h) => !x -> !(Network xs (h ': hs)) -> Network (x ': xs) (i ': h ': hs)
60+ (:~>) :: (SingI i, SingI h, Layer x i h)
61+ => !x
62+ -> !(Network xs (h ': hs))
63+ -> Network (x ': xs) (i ': h ': hs)
51infixr 5 :~>
64infixr 5 :~>
52
65
53instance Show (Network '[] '[i]) where
66instance Show (Network '[] '[i]) where
@@ -55,32 +68,100 @@ instance Show (Network '[] '[i]) where
55instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) where
68instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) where
56 show (x :~> xs) = show x ++ "\n~>\n" ++ show xs
69 show (x :~> xs) = show x ++ "\n~>\n" ++ show xs
57
70
71+-- | Gradient of a network.
72+--
73+-- Parameterised on the layers of the network.
74+data Gradients :: [Type] -> Type where
75+ GNil :: Gradients '[]
76+
77+ (:/>) :: UpdateLayer x
78+ => Gradient x
79+ -> Gradients xs
80+ -> Gradients (x ': xs)
58
81
82+-- | Wegnert Tape of a network.
83+--
84+-- Parameterised on the layers and shapes of the network.
85+data Tapes :: [Type] -> [Shape] -> Type where
86+ TNil :: SingI i
87+ => Tapes '[] '[i]
88+
89+ (:\>) :: (SingI i, SingI h, Layer x i h)
90+ => !(Tape x i h)
91+ -> !(Tapes xs (h ': hs))
92+ -> Tapes (x ': xs) (i ': h ': hs)
93+
94+
95+-- | Running a network forwards with some input data.
96+--
97+-- This gives the output, and the Wengert tape required for back
98+-- propagation.
99+runNetwork :: forall layers shapes.
100+ Network layers shapes
101+ -> S (Head shapes)
102+ -> (Tapes layers shapes, S (Last shapes))
103+runNetwork =
104+ go
105+ where
106+ go :: forall js ss. (Last js ~ Last shapes)
107+ => Network ss js
108+ -> S (Head js)
109+ -> (Tapes ss js, S (Last js))
110+ go (layer :~> n) !x =
111+ let (tape, forward) = runForwards layer x
112+ (tapes, answer) = go n forward
113+ in (tape :\> tapes, answer)
114+
115+ go NNil !x
116+ = (TNil, x)
117+
118+
119+-- | Running a loss gradient back through the network.
120+--
121+-- This requires a Wengert tape, generated with the appropriate input
122+-- for the loss.
123+--
124+-- Gives the gradients for the layer, and the gradient across the
125+-- input (which may not be required).
126+runGradient :: forall layers shapes.
127+ Network layers shapes
128+ -> Tapes layers shapes
129+ -> S (Last shapes)
130+ -> (Gradients layers, S (Head shapes))
131+runGradient net tapes o =
132+ go net tapes
133+ where
134+ go :: forall js ss. (Last js ~ Last shapes)
135+ => Network ss js
136+ -> Tapes ss js
137+ -> (Gradients ss, S (Head js))
138+ go (layer :~> n) (tape :\> nt) =
139+ let (gradients, feed) = go n nt
140+ (layer', backGrad) = runBackwards layer tape feed
141+ in (layer' :/> gradients, backGrad)
142+
143+ go NNil TNil
144+ = (GNil, o)
145+
146+
59−-- | Apply one step of stochastic gradient decent across the network.
147+-- | Apply one step of stochastic gradient descent across the network.
60−applyUpdate :: LearningParameters -> Network ls ss -> Gradients ls -> Network ls ss
148+applyUpdate :: LearningParameters
61−applyUpdate _ NNil GNil
149+ -> Network layers shapes
62− = NNil
150+ -> Gradients layers
151+ -> Network layers shapes
63applyUpdate rate (layer :~> rest) (gradient :/> grest)
152applyUpdate rate (layer :~> rest) (gradient :/> grest)
64 = runUpdate rate layer gradient :~> applyUpdate rate rest grest
153 = runUpdate rate layer gradient :~> applyUpdate rate rest grest
65
154
155+applyUpdate _ NNil GNil
156+ = NNil
66
157
67−
68−-- | Gradients of a network.
69−-- Parameterised on the layers of a Network.
70−data Gradients :: [*] -> * where
71− GNil :: Gradients '[]
72− (:/>) :: UpdateLayer x => Gradient x -> Gradients xs -> Gradients (x ': xs)
73−
74−-- | Gradients of a network.
75−-- Parameterised on the layers of a Network.
76−data Tapes :: [*] -> [Shape] -> * where
77− TNil :: SingI i => Tapes '[] '[i]
78− (:\>) :: (SingI i, SingI h, Layer x i h) => !(Tape x i h) -> !(Tapes xs (h ': hs)) -> Tapes (x ': xs) (i ': h ': hs)
79−
80−-- | A network can easily be created by hand with (:~>), but an easy way to initialise a random
158+-- | A network can easily be created by hand with (:~>), but an easy way to
81−-- network is with the randomNetwork.
159+-- initialise a random network is with the randomNetwork.
82−class CreatableNetwork (xs :: [*]) (ss :: [Shape]) where
160+class CreatableNetwork (xs :: [Type]) (ss :: [Shape]) where
83− -- | Create a network of the types requested
161+ -- | Create a network with randomly initialised weights.
162+ --
163+ -- Calls to this function will not compile if the type of the neural
164+ -- network is not sound.
84 randomNetwork :: MonadRandom m => m (Network xs ss)
165 randomNetwork :: MonadRandom m => m (Network xs ss)
85
166
86instance SingI i => CreatableNetwork '[] '[i] where
167instance SingI i => CreatableNetwork '[] '[i] where
@@ -101,39 +182,16 @@ instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o '
101
182
102-- | Ultimate composition.
183-- | Ultimate composition.
103--
184--
104−-- 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.
105instance CreatableNetwork sublayers subshapes => UpdateLayer (Network sublayers subshapes) where
186instance CreatableNetwork sublayers subshapes => UpdateLayer (Network sublayers subshapes) where
106 type Gradient (Network sublayers subshapes) = Gradients sublayers
187 type Gradient (Network sublayers subshapes) = Gradients sublayers
107− runUpdate = applyUpdate
188+ runUpdate = applyUpdate
108 createRandom = randomNetwork
189 createRandom = randomNetwork
109
190
191+-- | Ultimate composition.
192+--
193+-- This allows a complete network to be treated as a layer in a larger network.
110instance (CreatableNetwork sublayers subshapes, i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (Network sublayers subshapes) i o where
194instance (CreatableNetwork sublayers subshapes, i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (Network sublayers subshapes) i o where
111 type Tape (Network sublayers subshapes) i o = Tapes sublayers subshapes
195 type Tape (Network sublayers subshapes) i o = Tapes sublayers subshapes
112−
113− runForwards net i =
196+ runForwards = runNetwork
114− go i net
197+ runBackwards = runGradient
115− where
116− go :: forall js ss. (Last js ~ Last subshapes)
117− => S (Head js) -- ^ input vector
118− -> Network ss js -- ^ network to train
119− -> (Tapes ss js, S (Last js))
120− go !x (layer :~> n) =
121− let (tape, forward) = runForwards layer x
122− (tapes, answer) = go forward n
123− in (tape :\> tapes, answer)
124− go !x NNil
125− = (TNil, x)
126−
127− runBackwards net tapes o =
128− go net tapes
129− where
130− go :: forall js ss. (Last js ~ Last subshapes)
131− => Network ss js -- ^ network to train
132− -> Tapes ss js -- ^ network to train
133− -> (Gradients ss, S (Head js))
134− go (layer :~> n) (tape :\> nt) =
135− let (gradients, feed) = go n nt
136− (layer', backGrad) = runBackwards layer tape feed
137− in (layer' :/> gradients, backGrad)
138− go NNil TNil
139− = (GNil, o)
src/Grenade/Core/Runner.hs+26−40
@@ -1,72 +1,58 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE GADTs #-}
3{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE TypeOperators #-}
6−{-# LANGUAGE TypeFamilies #-}
7{-|
3{-|
8−Module : Grenade.Core.Shape
4+Module : Grenade.Core.Runner
9−Description : Core definition of the Shapes of data we understand
5+Description : Functions to perform training and backpropagation
10Copyright : (c) Huw Campbell, 2016-2017
6Copyright : (c) Huw Campbell, 2016-2017
11License : BSD2
7License : BSD2
12Stability : experimental
8Stability : experimental
13−
14−This module defines simple back propagation and training functions
15−for a network.
16-}
9-}
17−
18−-- GHC 7.10 doesn't think that go is complete
19−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
20module Grenade.Core.Runner (
10module Grenade.Core.Runner (
21 train
11 train
22 , backPropagate
12 , backPropagate
23 , runNet
13 , runNet
24− , applyUpdate
25 ) where
14 ) where
26
15
27−import Data.Singletons.Prelude
28
16
29−import Grenade.Core.Layer
30import Grenade.Core.LearningParameters
17import Grenade.Core.LearningParameters
31import Grenade.Core.Network
18import Grenade.Core.Network
32import Grenade.Core.Shape
19import Grenade.Core.Shape
20+import Data.Singletons
21+import Prelude.Singletons
33
22
34-- | Perform reverse automatic differentiation on the network
23-- | Perform reverse automatic differentiation on the network
35-- for the current input and expected output.
24-- for the current input and expected output.
36--
25--
37-- /Note:/ The loss function pushed backwards is appropriate
26-- /Note:/ The loss function pushed backwards is appropriate
38-- for both regression and classification as a squared loss
27-- for both regression and classification as a squared loss
39−-- or log-loss respectively. Other loss functions are not yet
28+-- or log-loss respectively.
40−-- implemented.
29+--
30+-- For other loss functions, use runNetwork and runGradient
31+-- with the back propagated gradient of your loss.
32+--
41−backPropagate :: forall shapes layers.
33+backPropagate :: SingI (Last shapes)
42− Network layers shapes -> S (Head shapes) -> S (Last shapes) -> Gradients layers
34+ => Network layers shapes
35+ -> S (Head shapes)
36+ -> S (Last shapes)
37+ -> Gradients layers
43backPropagate network input target =
38backPropagate network input target =
44− fst $ go input network
39+ let (tapes, output) = runNetwork network input
45− where
40+ (grads, _) = runGradient network tapes (output - target)
46− go :: forall js sublayers. (Last js ~ Last shapes)
41+ in grads
47− => S (Head js) -- ^ input vector
48− -> Network sublayers js -- ^ network to train
49− -> (Gradients sublayers, S (Head js))
50− -- handle input from the beginning, feeding upwards.
51− go !x (layer :~> n)
52− = let (tape, y) = runForwards layer x
53− -- recursively run the rest of the network, and get the gradients from above.
54− (n', dWs') = go y n
55− -- calculate the gradient for this layer to pass down,
56− (layer', dWs) = runBackwards layer tape dWs'
57− in (layer' :/> n', dWs)
58
42
59− -- Bouncing the derivatives back down.
60− go !x NNil
61− = (GNil, x - target)
62
43
63-- | Update a network with new weights after training with an instance.
44-- | Update a network with new weights after training with an instance.
64−train :: LearningParameters -> Network layers shapes -> S (Head shapes) -> S (Last shapes) -> Network layers shapes
45+train :: SingI (Last shapes)
46+ => LearningParameters
47+ -> Network layers shapes
48+ -> S (Head shapes)
49+ -> S (Last shapes)
50+ -> Network layers shapes
65train rate network input output =
51train rate network input output =
66 let grads = backPropagate network input output
52 let grads = backPropagate network input output
67 in applyUpdate rate network grads
53 in applyUpdate rate network grads
68
54
55+
69-- | Run the network with input and return the given output.
56-- | Run the network with input and return the given output.
70runNet :: Network layers shapes -> S (Head shapes) -> S (Last shapes)
57runNet :: Network layers shapes -> S (Head shapes) -> S (Last shapes)
71−runNet (layer :~> n) !x = let (_, y) = runForwards layer x in runNet n y
58+runNet net = snd . runNetwork net
72−runNet NNil !x = x
src/Grenade/Core/Shape.hs+77−33
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE KindSignatures #-}
@@ -7,40 +8,33 @@
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE RankNTypes #-}
10−
11+{-# LANGUAGE UndecidableInstances #-}
11−-- Ghc 8.0 gives a warning on `n2 _ _ = error ...` but ghc 7.10 fails to
12−-- compile without this default pattern.
13−{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
14−
15{-|
12{-|
16Module : Grenade.Core.Shape
13Module : Grenade.Core.Shape
17−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
18Copyright : (c) Huw Campbell, 2016-2017
15Copyright : (c) Huw Campbell, 2016-2017
19License : BSD2
16License : BSD2
20Stability : experimental
17Stability : experimental
21
18
22−This module defines the core data types for the shapes of data that
19+
23−are understood by Grenade.
24-}
20-}
25module Grenade.Core.Shape (
21module Grenade.Core.Shape (
22+ S (..)
26− Shape (..)
23+ , Shape (..)
27− , S (..)
24+ , SShape (..)
28− , Sing (..)
29 , randomOfShape
25 , randomOfShape
30 , fromStorable
26 , fromStorable
31 ) where
27 ) where
32
28
33import Control.DeepSeq (NFData (..))
29import Control.DeepSeq (NFData (..))
34import Control.Monad.Random ( MonadRandom, getRandom )
30import Control.Monad.Random ( MonadRandom, getRandom )
35−
31+import Data.Kind (Type)
36import Data.Proxy
32import Data.Proxy
33+import Data.Serialize
37import Data.Singletons
34import Data.Singletons
38−import Data.Singletons.TypeLits
39import Data.Vector.Storable ( Vector )
35import Data.Vector.Storable ( Vector )
40import qualified Data.Vector.Storable as V
36import qualified Data.Vector.Storable as V
41−
42import GHC.TypeLits
37import GHC.TypeLits
43−
44import qualified Numeric.LinearAlgebra.Static as H
38import qualified Numeric.LinearAlgebra.Static as H
45import Numeric.LinearAlgebra.Static
39import Numeric.LinearAlgebra.Static
46import qualified Numeric.LinearAlgebra as NLA
40import qualified Numeric.LinearAlgebra as NLA
@@ -48,21 +42,35 @@ import qualified Numeric.LinearAlgebra as NLA
48-- | The current shapes we accept.
42-- | The current shapes we accept.
49-- at the moment this is just one, two, and three dimensional
43-- at the moment this is just one, two, and three dimensional
50-- Vectors/Matricies.
44-- Vectors/Matricies.
45+--
46+-- These are only used with DataKinds, as Kind `Shape`, with Types 'D1, 'D2, 'D3.
51data Shape
47data Shape
52 = D1 Nat
48 = D1 Nat
49+ -- ^ One dimensional vector
53 | D2 Nat Nat
50 | D2 Nat Nat
51+ -- ^ Two dimensional matrix. Row, Column.
54 | D3 Nat Nat Nat
52 | D3 Nat Nat Nat
53+ -- ^ Three dimensional matrix. Row, Column, Channels.
55
54
56−-- | Given a Shape n, these are the possible data structures with that shape.
55+-- | Concrete data structures for a Shape.
56+--
57-- All shapes are held in contiguous memory.
57-- All shapes are held in contiguous memory.
58-- 3D is held in a matrix (usually row oriented) which has height depth * rows.
58-- 3D is held in a matrix (usually row oriented) which has height depth * rows.
59data S (n :: Shape) where
59data S (n :: Shape) where
60− S1D :: ( KnownNat o ) => R o -> S ('D1 o)
60+ S1D :: ( KnownNat len )
61+ => R len
62+ -> S ('D1 len)
63+
61− S2D :: ( KnownNat rows, KnownNat columns ) => L rows columns -> S ('D2 rows columns)
64+ S2D :: ( KnownNat rows, KnownNat columns )
65+ => L rows columns
66+ -> S ('D2 rows columns)
67+
62 S3D :: ( KnownNat rows
68 S3D :: ( KnownNat rows
63 , KnownNat columns
69 , KnownNat columns
64 , KnownNat depth
70 , KnownNat depth
71+ , KnownNat (rows * depth))
72+ => L (rows * depth) columns
65− , KnownNat (rows * depth)) => L (rows * depth) columns -> S ('D3 rows columns depth)
73+ -> S ('D3 rows columns depth)
66
74
67deriving instance Show (S n)
75deriving instance Show (S n)
68
76
@@ -71,10 +79,20 @@ deriving instance Show (S n)
71-- These could probably be derived with template haskell, but this seems
79-- These could probably be derived with template haskell, but this seems
72-- clear and makes adding the KnownNat constraints simple.
80-- clear and makes adding the KnownNat constraints simple.
73-- We can also keep our code TH free, which is great.
81-- We can also keep our code TH free, which is great.
82+#if MIN_VERSION_singletons(2,6,0)
83+-- In singletons 2.6 Sing switched from a data family to a type family.
84+type instance Sing = SShape
85+
86+data SShape :: Shape -> Type where
87+ D1Sing :: KnownNat a => SShape ('D1 a)
88+ D2Sing :: (KnownNat a, KnownNat b) => SShape ('D2 a b)
89+ D3Sing :: (KnownNat (a * c), KnownNat a, KnownNat b, KnownNat c) => SShape ('D3 a b c)
90+#else
74data instance Sing (n :: Shape) where
91data instance Sing (n :: Shape) where
75− D1Sing :: KnownNat a => Sing ('D1 a)
92+ D1Sing :: Sing a -> Sing ('D1 a)
76− D2Sing :: (KnownNat a, KnownNat b) => Sing ('D2 a b)
93+ D2Sing :: Sing a -> Sing b -> Sing ('D2 a b)
77− D3Sing :: (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => Sing ('D3 a b c)
94+ D3Sing :: KnownNat (a * c) => Sing a -> Sing b -> Sing c -> Sing ('D3 a b c)
95+#endif
78
96
79instance KnownNat a => SingI ('D1 a) where
97instance KnownNat a => SingI ('D1 a) where
80 sing = D1Sing
98 sing = D1Sing
@@ -130,18 +148,28 @@ randomOfShape :: forall x m. ( MonadRandom m, SingI x ) => m (S x)
130randomOfShape = do
148randomOfShape = do
131 seed :: Int <- getRandom
149 seed :: Int <- getRandom
132 return $ case (sing :: Sing x) of
150 return $ case (sing :: Sing x) of
151+ D1Sing ->
133− D1Sing -> S1D (randomVector seed Uniform * 2 - 1)
152+ S1D (randomVector seed Uniform * 2 - 1)
153+
154+ D2Sing ->
134− D2Sing -> S2D (uniformSample seed (-1) 1)
155+ S2D (uniformSample seed (-1) 1)
156+
157+ D3Sing ->
135− D3Sing -> S3D (uniformSample seed (-1) 1)
158+ S3D (uniformSample seed (-1) 1)
136
159
137-- | Generate a shape from a Storable Vector.
160-- | Generate a shape from a Storable Vector.
138--
161--
139-- Returns Nothing if the vector is of the wrong size.
162-- Returns Nothing if the vector is of the wrong size.
140fromStorable :: forall x. SingI x => Vector Double -> Maybe (S x)
163fromStorable :: forall x. SingI x => Vector Double -> Maybe (S x)
141fromStorable xs = case sing :: Sing x of
164fromStorable xs = case sing :: Sing x of
165+ D1Sing ->
142− D1Sing -> S1D <$> H.create xs
166+ S1D <$> H.create xs
167+
168+ D2Sing ->
143− D2Sing -> S2D <$> mkL xs
169+ S2D <$> mkL xs
170+
171+ D3Sing ->
144− D3Sing -> S3D <$> mkL xs
172+ S3D <$> mkL xs
145 where
173 where
146 mkL :: forall rows columns. (KnownNat rows, KnownNat columns)
174 mkL :: forall rows columns. (KnownNat rows, KnownNat columns)
147 => Vector Double -> Maybe (L rows columns)
175 => Vector Double -> Maybe (L rows columns)
@@ -152,6 +180,18 @@ fromStorable xs = case sing :: Sing x of
152 then H.create $ NLA.reshape columns v
180 then H.create $ NLA.reshape columns v
153 else Nothing
181 else Nothing
154
182
183+
184+instance SingI x => Serialize (S x) where
185+ put i = (case i of
186+ (S1D x) -> putListOf put . NLA.toList . H.extract $ x
187+ (S2D x) -> putListOf put . NLA.toList . NLA.flatten . H.extract $ x
188+ (S3D x) -> putListOf put . NLA.toList . NLA.flatten . H.extract $ x
189+ ) :: PutM ()
190+
191+ get = do
192+ Just i <- fromStorable . V.fromList <$> getListOf get
193+ return i
194+
155-- Helper function for creating the number instances
195-- Helper function for creating the number instances
156n1 :: ( forall a. Floating a => a -> a ) -> S x -> S x
196n1 :: ( forall a. Floating a => a -> a ) -> S x -> S x
157n1 f (S1D x) = S1D (f x)
197n1 f (S1D x) = S1D (f x)
@@ -163,11 +203,15 @@ n2 :: ( forall a. Floating a => a -> a -> a ) -> S x -> S x -> S x
163n2 f (S1D x) (S1D y) = S1D (f x y)
203n2 f (S1D x) (S1D y) = S1D (f x y)
164n2 f (S2D x) (S2D y) = S2D (f x y)
204n2 f (S2D x) (S2D y) = S2D (f x y)
165n2 f (S3D x) (S3D y) = S3D (f x y)
205n2 f (S3D x) (S3D y) = S3D (f x y)
166−n2 _ _ _ = error "Impossible to have different constructors for the same shaped network"
167
206
168-- Helper function for creating the number instances
207-- Helper function for creating the number instances
169−nk :: forall x. SingI x => Double -> S x
208+nk :: forall x. (SingI x) => Double -> S x
170nk x = case (sing :: Sing x) of
209nk x = case (sing :: Sing x) of
210+ D1Sing ->
171− D1Sing -> S1D (konst x)
211+ S1D (konst x)
212+
213+ D2Sing ->
172− D2Sing -> S2D (konst x)
214+ S2D (konst x)
215+
216+ D3Sing ->
173− D3Sing -> S3D (konst x)
217+ S3D (konst x)
src/Grenade/Graph/Core/Network.hsdeleted−39
@@ -1,39 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE TypeOperators #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE RankNTypes #-}
8−
9−{-|
10−Module : Grenade.Graph.Core.Network
11−Description : Core definition of the Shapes of data we understand
12−Copyright : (c) Huw Campbell, 2016-2017
13−License : BSD2
14−Stability : experimental
15−
16−This module defines the core data types for the shapes of data that
17−are understood by Grenade.
18−-}
19−module Grenade.Graph.Core.Network (
20− Fin (..)
21− ) where
22−
23−import Data.Constraint
24−import Data.Singletons
25−import Data.Proxy
26−
27−import Grenade
28−
29−import GHC.TypeLits
30−
31−data Edge :: * where
32− E :: Fin n -> Shape -> Edge
33−
34−data Fin n where
35− Fin0 :: Fin (n + 1)
36− FinS :: Fin n -> Fin (n + 1)
37−
38−data Network :: [*] -> [Edge] -> * where { }
39−
src/Grenade/Layers.hsnew file+35
@@ -0,0 +1,35 @@
1+module Grenade.Layers (
2+ module Grenade.Layers.Concat
3+ , module Grenade.Layers.Convolution
4+ , module Grenade.Layers.Crop
5+ , module Grenade.Layers.Deconvolution
6+ , module Grenade.Layers.Elu
7+ , module Grenade.Layers.FullyConnected
8+ , module Grenade.Layers.Inception
9+ , module Grenade.Layers.Logit
10+ , module Grenade.Layers.Merge
11+ , module Grenade.Layers.Pad
12+ , module Grenade.Layers.Pooling
13+ , module Grenade.Layers.Reshape
14+ , module Grenade.Layers.Relu
15+ , module Grenade.Layers.Softmax
16+ , module Grenade.Layers.Tanh
17+ , module Grenade.Layers.Trivial
18+ ) where
19+
20+import Grenade.Layers.Concat
21+import Grenade.Layers.Convolution
22+import Grenade.Layers.Crop
23+import Grenade.Layers.Deconvolution
24+import Grenade.Layers.Elu
25+import Grenade.Layers.Pad
26+import Grenade.Layers.FullyConnected
27+import Grenade.Layers.Inception
28+import Grenade.Layers.Logit
29+import Grenade.Layers.Merge
30+import Grenade.Layers.Pooling
31+import Grenade.Layers.Reshape
32+import Grenade.Layers.Relu
33+import Grenade.Layers.Softmax
34+import Grenade.Layers.Tanh
35+import Grenade.Layers.Trivial
src/Grenade/Layers/Concat.hsnew file+139
@@ -0,0 +1,139 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE FlexibleContexts #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE FlexibleInstances #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE StandaloneDeriving #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+{-|
14+Module : Grenade.Layers.Concat
15+Description : Concatenation layer
16+Copyright : (c) Huw Campbell, 2016-2017
17+License : BSD2
18+Stability : experimental
19+
20+This module provides the concatenation layer, which runs two chilld layers in parallel and combines their outputs.
21+-}
22+module Grenade.Layers.Concat (
23+ Concat (..)
24+ ) where
25+
26+import Data.Serialize
27+
28+import Data.Singletons
29+import GHC.TypeLits
30+
31+#if MIN_VERSION_base(4,9,0)
32+import Data.Kind (Type)
33+#endif
34+
35+import Grenade.Core
36+
37+import Numeric.LinearAlgebra.Static ( row, (===), splitRows, unrow, (#), split, R )
38+
39+-- | A Concatentating Layer.
40+--
41+-- This layer shares it's input state between two sublayers, and concatenates their output.
42+--
43+-- With Networks able to be Layers, this allows for very expressive composition of complex Networks.
44+--
45+-- The Concat layer has a few instances, which allow one to flexibly "bash" together the outputs.
46+--
47+-- Two 1D vectors, can go to a 2D shape with 2 rows if their lengths are identical.
48+-- Any 2 1D vectors can also become a longer 1D Vector.
49+--
50+-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad
51+-- and Crop layers to ensure this is the case.
52+data Concat :: Shape -> Type -> Shape -> Type -> Type where
53+ Concat :: x -> y -> Concat m x n y
54+
55+instance (Show x, Show y) => Show (Concat m x n y) where
56+ show (Concat x y) = "Concat\n" ++ show x ++ "\n" ++ show y
57+
58+-- | Run two layers in parallel, combining their outputs.
59+instance (UpdateLayer x, UpdateLayer y) => UpdateLayer (Concat m x n y) where
60+ type Gradient (Concat m x n y) = (Gradient x, Gradient y)
61+ runUpdate lr (Concat x y) (x', y') = Concat (runUpdate lr x x') (runUpdate lr y y')
62+ createRandom = Concat <$> createRandom <*> createRandom
63+
64+instance ( SingI i
65+ , Layer x i ('D1 o)
66+ , Layer y i ('D1 o)
67+ ) => Layer (Concat ('D1 o) x ('D1 o) y) i ('D2 2 o) where
68+ type Tape (Concat ('D1 o) x ('D1 o) y) i ('D2 2 o) = (Tape x i ('D1 o), Tape y i ('D1 o))
69+
70+ runForwards (Concat x y) input =
71+ let (xT, xOut :: S ('D1 o)) = runForwards x input
72+ (yT, yOut :: S ('D1 o)) = runForwards y input
73+ in case (xOut, yOut) of
74+ (S1D xOut', S1D yOut') ->
75+ ((xT, yT), S2D (row xOut' === row yOut'))
76+
77+ runBackwards (Concat x y) (xTape, yTape) (S2D o) =
78+ let (ox, oy) = splitRows o
79+ (x', xB :: S i) = runBackwards x xTape (S1D $ unrow ox)
80+ (y', yB :: S i) = runBackwards y yTape (S1D $ unrow oy)
81+ in ((x', y'), xB + yB)
82+
83+instance ( SingI i
84+ , Layer x i ('D1 m)
85+ , Layer y i ('D1 n)
86+ , KnownNat o
87+ , KnownNat m
88+ , KnownNat n
89+ , o ~ (m + n)
90+ , n ~ (o - m)
91+ , (m <=? o) ~ 'True
92+ ) => Layer (Concat ('D1 m) x ('D1 n) y) i ('D1 o) where
93+ type Tape (Concat ('D1 m) x ('D1 n) y) i ('D1 o) = (Tape x i ('D1 m), Tape y i ('D1 n))
94+
95+ runForwards (Concat x y) input =
96+ let (xT, xOut :: S ('D1 m)) = runForwards x input
97+ (yT, yOut :: S ('D1 n)) = runForwards y input
98+ in case (xOut, yOut) of
99+ (S1D xOut', S1D yOut') ->
100+ ((xT, yT), S1D (xOut' # yOut'))
101+
102+ runBackwards (Concat x y) (xTape, yTape) (S1D o) =
103+ let (ox :: R m , oy :: R n) = split o
104+ (x', xB :: S i) = runBackwards x xTape (S1D ox)
105+ (y', yB :: S i) = runBackwards y yTape (S1D oy)
106+ in ((x', y'), xB + yB)
107+
108+-- | Concat 3D shapes, increasing the number of channels.
109+instance ( SingI i
110+ , Layer x i ('D3 rows cols m)
111+ , Layer y i ('D3 rows cols n)
112+ , KnownNat (rows * n)
113+ , KnownNat (rows * m)
114+ , KnownNat (rows * o)
115+ , KnownNat o
116+ , KnownNat m
117+ , KnownNat n
118+ , ((rows * m) + (rows * n)) ~ (rows * o)
119+ , ((rows * o) - (rows * m)) ~ (rows * n)
120+ , ((rows * m) <=? (rows * o)) ~ 'True
121+ ) => Layer (Concat ('D3 rows cols m) x ('D3 rows cols n) y) i ('D3 rows cols o) where
122+ type Tape (Concat ('D3 rows cols m) x ('D3 rows cols n) y) i ('D3 rows cols o) = (Tape x i ('D3 rows cols m), Tape y i ('D3 rows cols n))
123+
124+ runForwards (Concat x y) input =
125+ let (xT, xOut :: S ('D3 rows cols m)) = runForwards x input
126+ (yT, yOut :: S ('D3 rows cols n)) = runForwards y input
127+ in case (xOut, yOut) of
128+ (S3D xOut', S3D yOut') ->
129+ ((xT, yT), S3D (xOut' === yOut'))
130+
131+ runBackwards (Concat x y) (xTape, yTape) (S3D o) =
132+ let (ox, oy) = splitRows o
133+ (x', xB :: S i) = runBackwards x xTape (S3D ox :: S ('D3 rows cols m))
134+ (y', yB :: S i) = runBackwards y yTape (S3D oy :: S ('D3 rows cols n))
135+ in ((x', y'), xB + yB)
136+
137+instance (Serialize a, Serialize b) => Serialize (Concat sa a sb b) where
138+ put (Concat a b) = put a *> put b
139+ get = Concat <$> get <*> get
src/Grenade/Layers/Convolution.hs+89−62
@@ -1,12 +1,23 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE FlexibleContexts #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+{-|
12+Module : Grenade.Layers.Convolution
13+Description : Convolution layer
14+Copyright : (c) Huw Campbell, 2016-2017
15+License : BSD2
16+Stability : experimental
17+
18+This module provides the Convolution layer, which is critical in many computer vision tasks.
19+
20+-}
10module Grenade.Layers.Convolution (
21module Grenade.Layers.Convolution (
11 Convolution (..)
22 Convolution (..)
12 , Convolution' (..)
23 , Convolution' (..)
@@ -17,9 +28,9 @@ import Control.Monad.Random hiding ( fromList )
17import Data.Maybe
28import Data.Maybe
18import Data.Proxy
29import Data.Proxy
19import Data.Serialize
30import Data.Serialize
20−import Data.Singletons.TypeLits
21
31
22import GHC.TypeLits
32import GHC.TypeLits
33+import Data.Kind (Type)
23
34
24import Numeric.LinearAlgebra hiding ( uniformSample, konst )
35import Numeric.LinearAlgebra hiding ( uniformSample, konst )
25import qualified Numeric.LinearAlgebra as LA
36import qualified Numeric.LinearAlgebra as LA
@@ -46,7 +57,7 @@ data Convolution :: Nat -- Number of channels, for the first layer this could be
46 -> Nat -- The number of column in the kernel filter
57 -> Nat -- The number of column in the kernel filter
47 -> Nat -- The row stride of the convolution filter
58 -> Nat -- The row stride of the convolution filter
48 -> Nat -- The columns stride of the convolution filter
59 -> Nat -- The columns stride of the convolution filter
49− -> * where
60+ -> Type where
50 Convolution :: ( KnownNat channels
61 Convolution :: ( KnownNat channels
51 , KnownNat filters
62 , KnownNat filters
52 , KnownNat kernelRows
63 , KnownNat kernelRows
@@ -65,7 +76,7 @@ data Convolution' :: Nat -- Number of channels, for the first layer this could b
65 -> Nat -- The number of column in the kernel filter
76 -> Nat -- The number of column in the kernel filter
66 -> Nat -- The row stride of the convolution filter
77 -> Nat -- The row stride of the convolution filter
67 -> Nat -- The columns stride of the convolution filter
78 -> Nat -- The columns stride of the convolution filter
68− -> * where
79+ -> Type where
69 Convolution' :: ( KnownNat channels
80 Convolution' :: ( KnownNat channels
70 , KnownNat filters
81 , KnownNat filters
71 , KnownNat kernelRows
82 , KnownNat kernelRows
@@ -119,9 +130,9 @@ instance ( KnownNat channels
119 , KnownNat strideColumns
130 , KnownNat strideColumns
120 , KnownNat (kernelRows * kernelColumns * channels)
131 , KnownNat (kernelRows * kernelColumns * channels)
121 ) => UpdateLayer (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where
132 ) => UpdateLayer (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where
122− type Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols) = (Convolution' channels filters kernelRows kernelCols strideRows strideCols)
133+ type Gradient (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Convolution' channels filters kernelRows kernelColumns strideRows strideColumns)
123− runUpdate LearningParameters {..} (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =
134+ runUpdate lp (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =
124− let (newKernel, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldKernel kernelGradient oldMomentum
135+ let (newKernel, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldKernel kernelGradient oldMomentum
125 in Convolution newKernel newMomentum
136 in Convolution newKernel newMomentum
126
137
127 createRandom = randomConvolution
138 createRandom = randomConvolution
@@ -141,7 +152,8 @@ instance ( KnownNat channels
141 let mm = konst 0
152 let mm = konst 0
142 return $ Convolution wN mm
153 return $ Convolution wN mm
143
154
144−-- | A two dimentional image may have a convolution filter applied to it
155+-- | A three dimensional image (or 2d with many channels) can have
156+-- an appropriately sized convolution filter run across it.
145instance ( KnownNat kernelRows
157instance ( KnownNat kernelRows
146 , KnownNat kernelCols
158 , KnownNat kernelCols
147 , KnownNat filters
159 , KnownNat filters
@@ -151,28 +163,33 @@ instance ( KnownNat kernelRows
151 , KnownNat inputCols
163 , KnownNat inputCols
152 , KnownNat outputRows
164 , KnownNat outputRows
153 , KnownNat outputCols
165 , KnownNat outputCols
166+ , KnownNat channels
154 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
167 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
155 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
168 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
156− , KnownNat (kernelRows * kernelCols * 1)
169+ , KnownNat (kernelRows * kernelCols * channels)
157 , KnownNat (outputRows * filters)
170 , KnownNat (outputRows * filters)
158− ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where
171+ ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where
172+
159− type Tape (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D2 inputRows inputCols)
173+ type Tape (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)
174+
160− runForwards (Convolution kernel _) (S2D input) =
175+ runForwards (Convolution kernel _) (S3D input) =
161 let ex = extract input
176 let ex = extract input
162 ek = extract kernel
177 ek = extract kernel
178+ ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
179+ iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
163 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
180 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
164 ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
181 ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
165 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
182 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
166 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
183 sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
167 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
184 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
168 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
185 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
186+
169− c = im2col kx ky sx sy ex
187+ c = vid2col kx ky sx sy ix iy ex
170 mt = c LA.<> ek
188 mt = c LA.<> ek
171 r = col2vid 1 1 1 1 ox oy mt
189 r = col2vid 1 1 1 1 ox oy mt
172 rs = fromJust . create $ r
190 rs = fromJust . create $ r
173− in (S2D input, S3D rs)
191+ in (S3D input, S3D rs)
174−
175− runBackwards (Convolution kernel _) (S2D input) (S3D dEdy) =
192+ runBackwards (Convolution kernel _) (S3D input) (S3D dEdy) =
176 let ex = extract input
193 let ex = extract input
177 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
194 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
178 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
195 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
@@ -183,7 +200,7 @@ instance ( KnownNat kernelRows
183 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
200 ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
184 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
201 oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
185
202
186− c = im2col kx ky sx sy ex
203+ c = vid2col kx ky sx sy ix iy ex
187
204
188 eo = extract dEdy
205 eo = extract dEdy
189 ek = extract kernel
206 ek = extract kernel
@@ -191,14 +208,14 @@ instance ( KnownNat kernelRows
191 vs = vid2col 1 1 1 1 ox oy eo
208 vs = vid2col 1 1 1 1 ox oy eo
192
209
193 kN = fromJust . create $ tr c LA.<> vs
210 kN = fromJust . create $ tr c LA.<> vs
211+
194 dW = vs LA.<> tr ek
212 dW = vs LA.<> tr ek
195
213
196− xW = col2im kx ky sx sy ix iy dW
214+ xW = col2vid kx ky sx sy ix iy dW
197− in (Convolution' kN, S2D . fromJust . create $ xW)
215+ in (Convolution' kN, S3D . fromJust . create $ xW)
198
216
199
217
200−-- | A three dimensional image (or 2d with many channels) can have
218+-- | A two dimentional image may have a convolution filter applied to it
201−-- an appropriately sized convolution filter run across it.
202instance ( KnownNat kernelRows
219instance ( KnownNat kernelRows
203 , KnownNat kernelCols
220 , KnownNat kernelCols
204 , KnownNat filters
221 , KnownNat filters
@@ -208,53 +225,63 @@ instance ( KnownNat kernelRows
208 , KnownNat inputCols
225 , KnownNat inputCols
209 , KnownNat outputRows
226 , KnownNat outputRows
210 , KnownNat outputCols
227 , KnownNat outputCols
211− , KnownNat channels
212 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
228 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
213 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
229 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
214− , KnownNat (kernelRows * kernelCols * channels)
230+ , KnownNat (kernelRows * kernelCols * 1)
215 , KnownNat (outputRows * filters)
231 , KnownNat (outputRows * filters)
216− ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where
232+ ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where
217−
218− type Tape (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)
233+ type Tape (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols 1)
219−
220− runForwards (Convolution kernel _) (S3D input) =
234+ runForwards c (S2D input) =
221− let ex = extract input
235+ runForwards c (S3D input :: S ('D3 inputRows inputCols 1))
222− ek = extract kernel
223− ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
224− iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
225− kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
226− ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
227− sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
228− sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
229− ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
230− oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
231−
232− c = vid2col kx ky sx sy ix iy ex
233− mt = c LA.<> ek
234− r = col2vid 1 1 1 1 ox oy mt
235− rs = fromJust . create $ r
236− in (S3D input, S3D rs)
237− runBackwards (Convolution kernel _) (S3D input) (S3D dEdy) =
238− let ex = extract input
239− ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
240− iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
241− kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
242− ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
243− sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
244− sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
245− ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
246− oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
247
236
248− c = vid2col kx ky sx sy ix iy ex
237+ runBackwards c tape grads =
238+ case runBackwards c tape grads of
239+ (c', S3D back :: S ('D3 inputRows inputCols 1)) -> (c', S2D back)
249
240
250− eo = extract dEdy
251− ek = extract kernel
252
241
253− vs = vid2col 1 1 1 1 ox oy eo
242+-- | A two dimensional image may have a convolution filter applied to it producing
243+-- a two dimensional image if both channels and filters is 1.
244+instance ( KnownNat kernelRows
245+ , KnownNat kernelCols
246+ , KnownNat strideRows
247+ , KnownNat strideCols
248+ , KnownNat inputRows
249+ , KnownNat inputCols
250+ , KnownNat outputRows
251+ , KnownNat outputCols
252+ , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
253+ , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
254+ , KnownNat (kernelRows * kernelCols * 1)
255+ , KnownNat (outputRows * 1)
256+ ) => Layer (Convolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) where
257+ type Tape (Convolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols 1)
258+ runForwards c (S2D input) =
259+ case runForwards c (S3D input :: S ('D3 inputRows inputCols 1)) of
260+ (tps, S3D back :: S ('D3 outputRows outputCols 1)) -> (tps, S2D back)
254
261
255− kN = fromJust . create $ tr c LA.<> vs
262+ runBackwards c tape (S2D grads) =
263+ case runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1)) of
264+ (c', S3D back :: S ('D3 inputRows inputCols 1)) -> (c', S2D back)
256
265
257− dW = vs LA.<> tr ek
266+-- | A three dimensional image can produce a 2D image from a convolution with 1 filter
267+instance ( KnownNat kernelRows
268+ , KnownNat kernelCols
269+ , KnownNat strideRows
270+ , KnownNat strideCols
271+ , KnownNat inputRows
272+ , KnownNat inputCols
273+ , KnownNat outputRows
274+ , KnownNat outputCols
275+ , KnownNat channels
276+ , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
277+ , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
278+ , KnownNat (kernelRows * kernelCols * channels)
279+ , KnownNat (outputRows * 1)
280+ ) => Layer (Convolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) where
281+ type Tape (Convolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols channels)
282+ runForwards c input =
283+ case runForwards c input of
284+ (tps, S3D back :: S ('D3 outputRows outputCols 1)) -> (tps, S2D back)
258
285
259− xW = col2vid kx ky sx sy ix iy dW
286+ runBackwards c tape (S2D grads) =
260− in (Convolution' kN, S3D . fromJust . create $ xW)
287+ runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1))
src/Grenade/Layers/Crop.hs+66−4
@@ -1,19 +1,32 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+{-|
11+Module : Grenade.Layers.Crop
12+Description : Cropping layer
13+Copyright : (c) Huw Campbell, 2016-2017
14+License : BSD2
15+Stability : experimental
16+-}
7module Grenade.Layers.Crop (
17module Grenade.Layers.Crop (
8 Crop (..)
18 Crop (..)
9 ) where
19 ) where
10
20
11import Data.Maybe
21import Data.Maybe
12import Data.Proxy
22import Data.Proxy
13−import Data.Singletons.TypeLits
23+import Data.Serialize
24+
14import GHC.TypeLits
25import GHC.TypeLits
26+import Data.Kind (Type)
15
27
16import Grenade.Core
28import Grenade.Core
29+import Grenade.Layers.Internal.Pad
17
30
18import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)
31import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)
19import Numeric.LinearAlgebra.Static (extract, create)
32import Numeric.LinearAlgebra.Static (extract, create)
@@ -22,7 +35,7 @@ import Numeric.LinearAlgebra.Static (extract, create)
22data Crop :: Nat
35data Crop :: Nat
23 -> Nat
36 -> Nat
24 -> Nat
37 -> Nat
25− -> Nat -> * where
38+ -> Nat -> Type where
26 Crop :: Crop cropLeft cropTop cropRight cropBottom
39 Crop :: Crop cropLeft cropTop cropRight cropBottom
27
40
28instance Show (Crop cropLeft cropTop cropRight cropBottom) where
41instance Show (Crop cropLeft cropTop cropRight cropBottom) where
@@ -33,6 +46,10 @@ instance UpdateLayer (Crop l t r b) where
33 runUpdate _ x _ = x
46 runUpdate _ x _ = x
34 createRandom = return Crop
47 createRandom = return Crop
35
48
49+instance Serialize (Crop l t r b) where
50+ put _ = return ()
51+ get = return Crop
52+
36-- | A two dimentional image can be cropped.
53-- | A two dimentional image can be cropped.
37instance ( KnownNat cropLeft
54instance ( KnownNat cropLeft
38 , KnownNat cropTop
55 , KnownNat cropTop
@@ -42,8 +59,8 @@ instance ( KnownNat cropLeft
42 , KnownNat inputColumns
59 , KnownNat inputColumns
43 , KnownNat outputRows
60 , KnownNat outputRows
44 , KnownNat outputColumns
61 , KnownNat outputColumns
45− , (inputRows - cropTop - cropBottom) ~ outputRows
62+ , (outputRows + cropTop + cropBottom) ~ inputRows
46− , (inputColumns - cropLeft - cropRight) ~ outputColumns
63+ , (outputColumns + cropLeft + cropRight) ~ inputColumns
47 ) => Layer (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where
64 ) => Layer (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where
48 type Tape (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = ()
65 type Tape (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = ()
49 runForwards Crop (S2D input) =
66 runForwards Crop (S2D input) =
@@ -62,3 +79,48 @@ instance ( KnownNat cropLeft
62 eo = extract dEdy
79 eo = extract dEdy
63 vs = diagBlock [konst 0 (cropt,cropl), eo, konst 0 (cropb,cropr)]
80 vs = diagBlock [konst 0 (cropt,cropl), eo, konst 0 (cropb,cropr)]
64 in ((), S2D . fromJust . create $ vs)
81 in ((), S2D . fromJust . create $ vs)
82+
83+
84+-- | A two dimentional image can be cropped.
85+instance ( KnownNat cropLeft
86+ , KnownNat cropTop
87+ , KnownNat cropRight
88+ , KnownNat cropBottom
89+ , KnownNat inputRows
90+ , KnownNat inputColumns
91+ , KnownNat outputRows
92+ , KnownNat outputColumns
93+ , KnownNat channels
94+ , KnownNat (inputRows * channels)
95+ , KnownNat (outputRows * channels)
96+ , (outputRows + cropTop + cropBottom) ~ inputRows
97+ , (outputColumns + cropLeft + cropRight) ~ inputColumns
98+ ) => Layer (Crop cropLeft cropTop cropRight cropBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where
99+ type Tape (Crop cropLeft cropTop cropRight cropBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) = ()
100+ runForwards Crop (S3D input) =
101+ let padl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)
102+ padt = fromIntegral $ natVal (Proxy :: Proxy cropTop)
103+ padr = fromIntegral $ natVal (Proxy :: Proxy cropRight)
104+ padb = fromIntegral $ natVal (Proxy :: Proxy cropBottom)
105+ inr = fromIntegral $ natVal (Proxy :: Proxy inputRows)
106+ inc = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
107+ outr = fromIntegral $ natVal (Proxy :: Proxy outputRows)
108+ outc = fromIntegral $ natVal (Proxy :: Proxy outputColumns)
109+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)
110+ m = extract input
111+ cropped = crop ch padl padt padr padb outr outc inr inc m
112+ in ((), S3D . fromJust . create $ cropped)
113+
114+ runBackwards Crop () (S3D gradient) =
115+ let padl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)
116+ padt = fromIntegral $ natVal (Proxy :: Proxy cropTop)
117+ padr = fromIntegral $ natVal (Proxy :: Proxy cropRight)
118+ padb = fromIntegral $ natVal (Proxy :: Proxy cropBottom)
119+ inr = fromIntegral $ natVal (Proxy :: Proxy inputRows)
120+ inc = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
121+ outr = fromIntegral $ natVal (Proxy :: Proxy outputRows)
122+ outc = fromIntegral $ natVal (Proxy :: Proxy outputColumns)
123+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)
124+ m = extract gradient
125+ padded = pad ch padl padt padr padb outr outc inr inc m
126+ in ((), S3D . fromJust . create $ padded)
src/Grenade/Layers/Deconvolution.hsnew file+285
@@ -0,0 +1,285 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE FlexibleContexts #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+{-|
12+Module : Grenade.Layers.Deconvolution
13+Description : Deconvolution layer
14+Copyright : (c) Huw Campbell, 2016-2017
15+License : BSD2
16+Stability : experimental
17+
18+A deconvolution layer is in many ways a convolution layer in reverse.
19+It learns a kernel to apply to each pixel location, spreading it out
20+into a larger layer.
21+
22+This layer is important for image generation tasks, such as GANs on
23+images.
24+-}
25+module Grenade.Layers.Deconvolution (
26+ Deconvolution (..)
27+ , Deconvolution' (..)
28+ , randomDeconvolution
29+ ) where
30+
31+import Control.Monad.Random hiding ( fromList )
32+import Data.Maybe
33+import Data.Proxy
34+import Data.Serialize
35+
36+import GHC.TypeLits
37+import Data.Kind (Type)
38+
39+import Numeric.LinearAlgebra hiding ( uniformSample, konst )
40+import qualified Numeric.LinearAlgebra as LA
41+import Numeric.LinearAlgebra.Static hiding ((|||), build, toRows)
42+
43+import Grenade.Core
44+import Grenade.Layers.Internal.Convolution
45+import Grenade.Layers.Internal.Update
46+
47+-- | A Deconvolution layer for a neural network.
48+-- This uses the im2col Convolution trick popularised by Caffe.
49+--
50+-- The Deconvolution layer is a way of spreading out a single response
51+-- into a larger image, and is useful in generating images.
52+--
53+data Deconvolution :: Nat -- Number of channels, for the first layer this could be RGB for instance.
54+ -> Nat -- Number of filters, this is the number of channels output by the layer.
55+ -> Nat -- The number of rows in the kernel filter
56+ -> Nat -- The number of column in the kernel filter
57+ -> Nat -- The row stride of the Deconvolution filter
58+ -> Nat -- The columns stride of the Deconvolution filter
59+ -> Type where
60+ Deconvolution :: ( KnownNat channels
61+ , KnownNat filters
62+ , KnownNat kernelRows
63+ , KnownNat kernelColumns
64+ , KnownNat strideRows
65+ , KnownNat strideColumns
66+ , KnownNat kernelFlattened
67+ , kernelFlattened ~ (kernelRows * kernelColumns * filters))
68+ => !(L kernelFlattened channels) -- The kernel filter weights
69+ -> !(L kernelFlattened channels) -- The last kernel update (or momentum)
70+ -> Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns
71+
72+data Deconvolution' :: Nat -- Number of channels, for the first layer this could be RGB for instance.
73+ -> Nat -- Number of filters, this is the number of channels output by the layer.
74+ -> Nat -- The number of rows in the kernel filter
75+ -> Nat -- The number of column in the kernel filter
76+ -> Nat -- The row stride of the Deconvolution filter
77+ -> Nat -- The columns stride of the Deconvolution filter
78+ -> Type where
79+ Deconvolution' :: ( KnownNat channels
80+ , KnownNat filters
81+ , KnownNat kernelRows
82+ , KnownNat kernelColumns
83+ , KnownNat strideRows
84+ , KnownNat strideColumns
85+ , KnownNat kernelFlattened
86+ , kernelFlattened ~ (kernelRows * kernelColumns * filters))
87+ => !(L kernelFlattened channels) -- The kernel filter gradient
88+ -> Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns
89+
90+instance Show (Deconvolution c f k k' s s') where
91+ show (Deconvolution a _) = renderConv a
92+ where
93+ renderConv mm =
94+ let m = extract mm
95+ ky = fromIntegral $ natVal (Proxy :: Proxy k)
96+ rs = LA.toColumns m
97+ ms = map (take ky) $ toLists . reshape ky <$> rs
98+
99+ render n' | n' <= 0.2 = ' '
100+ | n' <= 0.4 = '.'
101+ | n' <= 0.6 = '-'
102+ | n' <= 0.8 = '='
103+ | otherwise = '#'
104+
105+ px = (fmap . fmap . fmap) render ms
106+ in unlines $ foldl1 (zipWith (\a' b' -> a' ++ " | " ++ b')) $ px
107+
108+randomDeconvolution :: ( MonadRandom m
109+ , KnownNat channels
110+ , KnownNat filters
111+ , KnownNat kernelRows
112+ , KnownNat kernelColumns
113+ , KnownNat strideRows
114+ , KnownNat strideColumns
115+ , KnownNat kernelFlattened
116+ , kernelFlattened ~ (kernelRows * kernelColumns * filters))
117+ => m (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns)
118+randomDeconvolution = do
119+ s <- getRandom
120+ let wN = uniformSample s (-1) 1
121+ mm = konst 0
122+ return $ Deconvolution wN mm
123+
124+instance ( KnownNat channels
125+ , KnownNat filters
126+ , KnownNat kernelRows
127+ , KnownNat kernelColumns
128+ , KnownNat strideRows
129+ , KnownNat strideColumns
130+ , KnownNat (kernelRows * kernelColumns * filters)
131+ ) => UpdateLayer (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where
132+ type Gradient (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns)
133+ runUpdate lp (Deconvolution oldKernel oldMomentum) (Deconvolution' kernelGradient) =
134+ let (newKernel, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldKernel kernelGradient oldMomentum
135+ in Deconvolution newKernel newMomentum
136+
137+ createRandom = randomDeconvolution
138+
139+instance ( KnownNat channels
140+ , KnownNat filters
141+ , KnownNat kernelRows
142+ , KnownNat kernelColumns
143+ , KnownNat strideRows
144+ , KnownNat strideColumns
145+ , KnownNat (kernelRows * kernelColumns * filters)
146+ ) => Serialize (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where
147+ put (Deconvolution w _) = putListOf put . toList . flatten . extract $ w
148+ get = do
149+ let f = fromIntegral $ natVal (Proxy :: Proxy channels)
150+ wN <- maybe (fail "Vector of incorrect size") return . create . reshape f . LA.fromList =<< getListOf get
151+ let mm = konst 0
152+ return $ Deconvolution wN mm
153+
154+-- | A two dimentional image may have a Deconvolution filter applied to it
155+instance ( KnownNat kernelRows
156+ , KnownNat kernelCols
157+ , KnownNat filters
158+ , KnownNat strideRows
159+ , KnownNat strideCols
160+ , KnownNat inputRows
161+ , KnownNat inputCols
162+ , KnownNat outputRows
163+ , KnownNat outputCols
164+ , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
165+ , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
166+ , KnownNat (kernelRows * kernelCols * filters)
167+ , KnownNat (outputRows * filters)
168+ ) => Layer (Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where
169+ type Tape (Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols 1)
170+ runForwards c (S2D input) =
171+ runForwards c (S3D input :: S ('D3 inputRows inputCols 1))
172+
173+ runBackwards c tape grads =
174+ case runBackwards c tape grads of
175+ (c', S3D back :: S ('D3 inputRows inputCols 1)) -> (c', S2D back)
176+
177+-- | A two dimentional image may have a Deconvolution filter applied to it
178+instance ( KnownNat kernelRows
179+ , KnownNat kernelCols
180+ , KnownNat strideRows
181+ , KnownNat strideCols
182+ , KnownNat inputRows
183+ , KnownNat inputCols
184+ , KnownNat outputRows
185+ , KnownNat outputCols
186+ , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
187+ , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
188+ , KnownNat (kernelRows * kernelCols * 1)
189+ , KnownNat (outputRows * 1)
190+ ) => Layer (Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) where
191+ type Tape (Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols 1)
192+ runForwards c (S2D input) =
193+ case runForwards c (S3D input :: S ('D3 inputRows inputCols 1)) of
194+ (tps, S3D fore :: S ('D3 outputRows outputCols 1)) -> (tps, S2D fore)
195+
196+ runBackwards c tape (S2D grads) =
197+ case runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1)) of
198+ (c', S3D back :: S ('D3 inputRows inputCols 1)) -> (c', S2D back)
199+
200+-- | A two dimentional image may have a Deconvolution filter applied to it
201+instance ( KnownNat kernelRows
202+ , KnownNat kernelCols
203+ , KnownNat strideRows
204+ , KnownNat strideCols
205+ , KnownNat inputRows
206+ , KnownNat inputCols
207+ , KnownNat outputRows
208+ , KnownNat outputCols
209+ , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
210+ , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
211+ , KnownNat (kernelRows * kernelCols * 1)
212+ , KnownNat (outputRows * 1)
213+ , KnownNat channels
214+ ) => Layer (Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) where
215+ type Tape (Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols channels)
216+ runForwards c input =
217+ case runForwards c input of
218+ (tps, S3D fore :: S ('D3 outputRows outputCols 1)) -> (tps, S2D fore)
219+
220+ runBackwards c tape (S2D grads) =
221+ runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1))
222+
223+-- | A three dimensional image (or 2d with many channels) can have
224+-- an appropriately sized Deconvolution filter run across it.
225+instance ( KnownNat kernelRows
226+ , KnownNat kernelCols
227+ , KnownNat filters
228+ , KnownNat strideRows
229+ , KnownNat strideCols
230+ , KnownNat inputRows
231+ , KnownNat inputCols
232+ , KnownNat outputRows
233+ , KnownNat outputCols
234+ , KnownNat channels
235+ , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
236+ , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
237+ , KnownNat (kernelRows * kernelCols * filters)
238+ , KnownNat (outputRows * filters)
239+ ) => Layer (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where
240+
241+ type Tape (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)
242+
243+ runForwards (Deconvolution kernel _) (S3D input) =
244+ let ex = extract input
245+ ek = extract kernel
246+ ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
247+ iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
248+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
249+ ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
250+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
251+ sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
252+ ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
253+ oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
254+
255+ c = vid2col 1 1 1 1 ix iy ex
256+
257+ mt = c LA.<> tr ek
258+
259+ r = col2vid kx ky sx sy ox oy mt
260+ rs = fromJust . create $ r
261+ in (S3D input, S3D rs)
262+ runBackwards (Deconvolution kernel _) (S3D input) (S3D dEdy) =
263+ let ex = extract input
264+ ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
265+ iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
266+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
267+ ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
268+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
269+ sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
270+ ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
271+ oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
272+
273+ c = vid2col 1 1 1 1 ix iy ex
274+
275+ eo = extract dEdy
276+ ek = extract kernel
277+
278+ vs = vid2col kx ky sx sy ox oy eo
279+
280+ kN = fromJust . create . tr $ tr c LA.<> vs
281+
282+ dW = vs LA.<> ek
283+
284+ xW = col2vid 1 1 1 1 ix iy dW
285+ in (Deconvolution' kN, S3D . fromJust . create $ xW)
src/Grenade/Layers/Elu.hs+10−3
@@ -2,6 +2,13 @@
2{-# LANGUAGE TypeOperators #-}
2{-# LANGUAGE TypeOperators #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5+{-|
6+Module : Grenade.Layers.Logit
7+Description : Exponential linear unit layer
8+Copyright : (c) Huw Campbell, 2016-2017
9+License : BSD2
10+Stability : experimental
11+-}
5module Grenade.Layers.Elu (
12module Grenade.Layers.Elu (
6 Elu (..)
13 Elu (..)
7 ) where
14 ) where
@@ -29,12 +36,12 @@ instance Serialize Elu where
29 get = return Elu
36 get = return Elu
30
37
31instance ( KnownNat i) => Layer Elu ('D1 i) ('D1 i) where
38instance ( KnownNat i) => Layer Elu ('D1 i) ('D1 i) where
32− type Tape Elu ('D1 i) ('D1 i) = S ('D1 i)
39+ type Tape Elu ('D1 i) ('D1 i) = LAS.R i
33
40
34− runForwards _ (S1D y) = (S1D y, S1D (elu y))
41+ runForwards _ (S1D y) = (y, S1D (elu y))
35 where
42 where
36 elu = LAS.dvmap (\a -> if a <= 0 then exp a - 1 else a)
43 elu = LAS.dvmap (\a -> if a <= 0 then exp a - 1 else a)
37− runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (elu' y * dEdy))
44+ runBackwards _ y (S1D dEdy) = ((), S1D (elu' y * dEdy))
38 where
45 where
39 elu' = LAS.dvmap (\a -> if a <= 0 then exp a else 1)
46 elu' = LAS.dvmap (\a -> if a <= 0 then exp a else 1)
40
47
src/Grenade/Layers/Flatten.hsdeleted−55
@@ -1,55 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−module Grenade.Layers.Flatten (
7− FlattenLayer (..)
8− ) where
9−
10−import Data.Serialize
11−
12−import Data.Singletons.TypeLits
13−import GHC.TypeLits
14−
15−import Numeric.LinearAlgebra.Static
16−import Numeric.LinearAlgebra.Data as LA ( flatten )
17−
18−import Grenade.Core
19−
20−-- | Flatten Layer
21−--
22−-- Flattens input down to D1 from either 2D or 3D data.
23−--
24−-- Can also be used to turn a 3D image with only one channel into a 2D image.
25−data FlattenLayer = FlattenLayer
26− deriving Show
27−
28−instance UpdateLayer FlattenLayer where
29− type Gradient FlattenLayer = ()
30− runUpdate _ _ _ = FlattenLayer
31− createRandom = return FlattenLayer
32−
33−instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer FlattenLayer ('D2 x y) ('D1 a) where
34− type Tape FlattenLayer ('D2 x y) ('D1 a) = ()
35− runForwards _ (S2D y) = ((), fromJust' . fromStorable . flatten . extract $ y)
36− runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)
37−
38−instance (KnownNat a, KnownNat x, KnownNat y, KnownNat (x * z), KnownNat z, a ~ (x * y * z)) => Layer FlattenLayer ('D3 x y z) ('D1 a) where
39− type Tape FlattenLayer ('D3 x y z) ('D1 a) = ()
40− runForwards _ (S3D y) = ((), fromJust' . fromStorable . flatten . extract $ y)
41− runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)
42−
43−instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer FlattenLayer ('D3 x y z) ('D2 x y) where
44− type Tape FlattenLayer ('D3 x y z) ('D2 x y) = ()
45− runForwards _ (S3D y) = ((), S2D y)
46− runBackwards _ _ (S2D y) = ((), S3D y)
47−
48−instance Serialize FlattenLayer where
49− put _ = return ()
50− get = return FlattenLayer
51−
52−
53−fromJust' :: Maybe x -> x
54−fromJust' (Just x) = x
55−fromJust' Nothing = error $ "FlattenLayer error: data shape couldn't be converted."
src/Grenade/Layers/FullyConnected.hs+7−8
@@ -1,5 +1,4 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE TypeOperators #-}
2{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
@@ -14,7 +13,6 @@ import Control.Monad.Random hiding (fromList)
14
13
15import Data.Proxy
14import Data.Proxy
16import Data.Serialize
15import Data.Serialize
17−import Data.Singletons.TypeLits
18
16
19import qualified Numeric.LinearAlgebra as LA
17import qualified Numeric.LinearAlgebra as LA
20import Numeric.LinearAlgebra.Static
18import Numeric.LinearAlgebra.Static
@@ -22,6 +20,7 @@ import Numeric.LinearAlgebra.Static
22import Grenade.Core
20import Grenade.Core
23
21
24import Grenade.Layers.Internal.Update
22import Grenade.Layers.Internal.Update
23+import GHC.TypeLits
25
24
26-- | A basic fully connected (or inner product) neural network layer.
25-- | A basic fully connected (or inner product) neural network layer.
27data FullyConnected i o = FullyConnected
26data FullyConnected i o = FullyConnected
@@ -38,20 +37,20 @@ instance Show (FullyConnected i o) where
38instance (KnownNat i, KnownNat o) => UpdateLayer (FullyConnected i o) where
37instance (KnownNat i, KnownNat o) => UpdateLayer (FullyConnected i o) where
39 type Gradient (FullyConnected i o) = (FullyConnected' i o)
38 type Gradient (FullyConnected i o) = (FullyConnected' i o)
40
39
41− runUpdate LearningParameters {..} (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =
40+ runUpdate lp (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =
42− let (newBias, newBiasMomentum) = decendVector learningRate learningMomentum learningRegulariser oldBias biasGradient oldBiasMomentum
41+ let (newBias, newBiasMomentum) = descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldBias biasGradient oldBiasMomentum
43− (newActivations, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldActivations activationGradient oldMomentum
42+ (newActivations, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldActivations activationGradient oldMomentum
44 in FullyConnected (FullyConnected' newBias newActivations) (FullyConnected' newBiasMomentum newMomentum)
43 in FullyConnected (FullyConnected' newBias newActivations) (FullyConnected' newBiasMomentum newMomentum)
45
44
46 createRandom = randomFullyConnected
45 createRandom = randomFullyConnected
47
46
48instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o) where
47instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o) where
49− type Tape (FullyConnected i o) ('D1 i) ('D1 o) = S ('D1 i)
48+ type Tape (FullyConnected i o) ('D1 i) ('D1 o) = R i
50 -- Do a matrix vector multiplication and return the result.
49 -- Do a matrix vector multiplication and return the result.
51− runForwards (FullyConnected (FullyConnected' wB wN) _) (S1D v) = (S1D v, S1D (wB + wN #> v))
50+ runForwards (FullyConnected (FullyConnected' wB wN) _) (S1D v) = (v, S1D (wB + wN #> v))
52
51
53 -- Run a backpropogation step for a full connected layer.
52 -- Run a backpropogation step for a full connected layer.
54− runBackwards (FullyConnected (FullyConnected' _ wN) _) (S1D x) (S1D dEdy) =
53+ runBackwards (FullyConnected (FullyConnected' _ wN) _) x (S1D dEdy) =
55 let wB' = dEdy
54 let wB' = dEdy
56 mm' = dEdy `outer` x
55 mm' = dEdy `outer` x
57 -- calcluate derivatives for next step
56 -- calcluate derivatives for next step
src/Grenade/Layers/Inception.hsnew file+67
@@ -0,0 +1,67 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE TypeOperators #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE FlexibleContexts #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-|
11+Module : Grenade.Core.Network
12+Description : Inception style parallel convolutional network composition.
13+Copyright : (c) Huw Campbell, 2016-2017
14+License : BSD2
15+Stability : experimental
16+
17+Export an Inception style type, which can be used to build up
18+complex multiconvolution size networks.
19+-}
20+module Grenade.Layers.Inception (
21+ Inception
22+ , InceptionMini
23+ , Resnet
24+ ) where
25+
26+import GHC.TypeLits
27+
28+import Grenade.Core
29+import Grenade.Layers.Convolution
30+import Grenade.Layers.Pad
31+import Grenade.Layers.Concat
32+import Grenade.Layers.Merge
33+import Grenade.Layers.Trivial
34+
35+-- | Type of an inception layer.
36+--
37+-- It looks like a bit of a handful, but is actually pretty easy to use.
38+--
39+-- The first three type parameters are the size of the (3D) data the
40+-- inception layer will take. It will emit 3D data with the number of
41+-- channels being the sum of @chx@, @chy@, @chz@, which are the number
42+-- of convolution filters in the 3x3, 5x5, and 7x7 convolutions Layers
43+-- respectively.
44+--
45+-- The network get padded effectively before each convolution filters
46+-- such that the output dimension is the same x and y as the input.
47+type Inception rows cols channels chx chy chz
48+ = Network '[ Concat ('D3 rows cols (chx + chy)) (InceptionMini rows cols channels chx chy) ('D3 rows cols chz) (Inception7x7 rows cols channels chz) ]
49+ '[ 'D3 rows cols channels, 'D3 rows cols (chx + chy + chz) ]
50+
51+type InceptionMini rows cols channels chx chy
52+ = Network '[ Concat ('D3 rows cols chx) (Inception3x3 rows cols channels chx) ('D3 rows cols chy) (Inception5x5 rows cols channels chy) ]
53+ '[ 'D3 rows cols channels, 'D3 rows cols (chx + chy) ]
54+
55+type Inception3x3 rows cols channels chx
56+ = Network '[ Pad 1 1 1 1, Convolution channels chx 3 3 1 1 ]
57+ '[ 'D3 rows cols channels, 'D3 (rows + 2) (cols + 2) channels, 'D3 rows cols chx ]
58+
59+type Inception5x5 rows cols channels chx
60+ = Network '[ Pad 2 2 2 2, Convolution channels chx 5 5 1 1 ]
61+ '[ 'D3 rows cols channels, 'D3 (rows + 4) (cols + 4) channels, 'D3 rows cols chx ]
62+
63+type Inception7x7 rows cols channels chx
64+ = Network '[ Pad 3 3 3 3, Convolution channels chx 7 7 1 1 ]
65+ '[ 'D3 rows cols channels, 'D3 (rows + 6) (cols + 6) channels, 'D3 rows cols chx ]
66+
67+type Resnet branch = Merge Trivial branch
src/Grenade/Layers/Internal/Pad.hsnew file+54
@@ -0,0 +1,54 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
2+module Grenade.Layers.Internal.Pad (
3+ pad
4+ , crop
5+ ) where
6+
7+import qualified Data.Vector.Storable as U ( unsafeToForeignPtr0, unsafeFromForeignPtr0 )
8+
9+import Foreign ( mallocForeignPtrArray, withForeignPtr )
10+import Foreign.Ptr ( Ptr )
11+
12+import Numeric.LinearAlgebra ( flatten, Matrix )
13+import qualified Numeric.LinearAlgebra.Devel as U
14+
15+import System.IO.Unsafe ( unsafePerformIO )
16+
17+pad :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
18+pad channels padLeft padTop padRight padBottom rows cols rows' cols' m
19+ = let outMatSize = rows' * cols' * channels
20+ vec = flatten m
21+ in unsafePerformIO $ do
22+ outPtr <- mallocForeignPtrArray outMatSize
23+ let (inPtr, _) = U.unsafeToForeignPtr0 vec
24+
25+ withForeignPtr inPtr $ \inPtr' ->
26+ withForeignPtr outPtr $ \outPtr' ->
27+ pad_cpu inPtr' channels rows cols padLeft padTop padRight padBottom outPtr'
28+
29+ let matVec = U.unsafeFromForeignPtr0 outPtr outMatSize
30+ return (U.matrixFromVector U.RowMajor (rows' * channels) cols' matVec)
31+{-# INLINE pad #-}
32+
33+foreign import ccall unsafe
34+ pad_cpu
35+ :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()
36+
37+crop :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
38+crop channels padLeft padTop padRight padBottom rows cols _ _ m
39+ = let outMatSize = rows * cols * channels
40+ vec = flatten m
41+ in unsafePerformIO $ do
42+ outPtr <- mallocForeignPtrArray outMatSize
43+ let (inPtr, _) = U.unsafeToForeignPtr0 vec
44+
45+ withForeignPtr inPtr $ \inPtr' ->
46+ withForeignPtr outPtr $ \outPtr' ->
47+ crop_cpu inPtr' channels rows cols padLeft padTop padRight padBottom outPtr'
48+
49+ let matVec = U.unsafeFromForeignPtr0 outPtr outMatSize
50+ return (U.matrixFromVector U.RowMajor (rows * channels) cols matVec)
51+
52+foreign import ccall unsafe
53+ crop_cpu
54+ :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()
src/Grenade/Layers/Internal/Update.hs+12−12
@@ -1,7 +1,7 @@
1{-# LANGUAGE ForeignFunctionInterface #-}
1{-# LANGUAGE ForeignFunctionInterface #-}
2module Grenade.Layers.Internal.Update (
2module Grenade.Layers.Internal.Update (
3− decendMatrix
3+ descendMatrix
4− , decendVector
4+ , descendVector
5 ) where
5 ) where
6
6
7import Data.Maybe ( fromJust )
7import Data.Maybe ( fromJust )
@@ -17,8 +17,8 @@ import qualified Numeric.LinearAlgebra.Devel as U
17
17
18import System.IO.Unsafe ( unsafePerformIO )
18import System.IO.Unsafe ( unsafePerformIO )
19
19
20−decendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)
20+descendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)
21−decendMatrix rate momentum regulariser weights gradient lastUpdate =
21+descendMatrix rate momentum regulariser weights gradient lastUpdate =
22 let (rows, cols) = size weights
22 let (rows, cols) = size weights
23 len = rows * cols
23 len = rows * cols
24 -- Most gradients come in in ColumnMajor,
24 -- Most gradients come in in ColumnMajor,
@@ -29,7 +29,7 @@ decendMatrix rate momentum regulariser weights gradient lastUpdate =
29 weights' = flatten . tr . extract $ weights
29 weights' = flatten . tr . extract $ weights
30 gradient' = flatten . tr . extract $ gradient
30 gradient' = flatten . tr . extract $ gradient
31 lastUpdate' = flatten . tr . extract $ lastUpdate
31 lastUpdate' = flatten . tr . extract $ lastUpdate
32− (vw, vm) = decendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'
32+ (vw, vm) = descendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'
33
33
34 -- Note that it's ColumnMajor, as we did a transpose before
34 -- Note that it's ColumnMajor, as we did a transpose before
35 -- using the internal vectors.
35 -- using the internal vectors.
@@ -37,17 +37,17 @@ decendMatrix rate momentum regulariser weights gradient lastUpdate =
37 mm = U.matrixFromVector U.ColumnMajor rows cols vm
37 mm = U.matrixFromVector U.ColumnMajor rows cols vm
38 in (fromJust . create $ mw, fromJust . create $ mm)
38 in (fromJust . create $ mw, fromJust . create $ mm)
39
39
40−decendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)
40+descendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)
41−decendVector rate momentum regulariser weights gradient lastUpdate =
41+descendVector rate momentum regulariser weights gradient lastUpdate =
42 let len = size weights
42 let len = size weights
43 weights' = extract weights
43 weights' = extract weights
44 gradient' = extract gradient
44 gradient' = extract gradient
45 lastUpdate' = extract lastUpdate
45 lastUpdate' = extract lastUpdate
46− (vw, vm) = decendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'
46+ (vw, vm) = descendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'
47 in (fromJust $ create vw, fromJust $ create vm)
47 in (fromJust $ create vw, fromJust $ create vm)
48
48
49−decendUnsafe :: Int -> Double -> Double -> Double -> Vector Double -> Vector Double -> Vector Double -> (Vector Double, Vector Double)
49+descendUnsafe :: Int -> Double -> Double -> Double -> Vector Double -> Vector Double -> Vector Double -> (Vector Double, Vector Double)
50−decendUnsafe len rate momentum regulariser weights gradient lastUpdate =
50+descendUnsafe len rate momentum regulariser weights gradient lastUpdate =
51 unsafePerformIO $ do
51 unsafePerformIO $ do
52 outWPtr <- mallocForeignPtrArray len
52 outWPtr <- mallocForeignPtrArray len
53 outMPtr <- mallocForeignPtrArray len
53 outMPtr <- mallocForeignPtrArray len
@@ -60,11 +60,11 @@ decendUnsafe len rate momentum regulariser weights gradient lastUpdate =
60 withForeignPtr lPtr $ \lPtr' ->
60 withForeignPtr lPtr $ \lPtr' ->
61 withForeignPtr outWPtr $ \outWPtr' ->
61 withForeignPtr outWPtr $ \outWPtr' ->
62 withForeignPtr outMPtr $ \outMPtr' ->
62 withForeignPtr outMPtr $ \outMPtr' ->
63− decend_cpu len rate momentum regulariser wPtr' gPtr' lPtr' outWPtr' outMPtr'
63+ descend_cpu len rate momentum regulariser wPtr' gPtr' lPtr' outWPtr' outMPtr'
64
64
65 return (U.unsafeFromForeignPtr0 outWPtr len, U.unsafeFromForeignPtr0 outMPtr len)
65 return (U.unsafeFromForeignPtr0 outWPtr len, U.unsafeFromForeignPtr0 outMPtr len)
66
66
67foreign import ccall unsafe
67foreign import ccall unsafe
68− decend_cpu
68+ descend_cpu
69 :: Int -> Double -> Double -> Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()
69 :: Int -> Double -> Double -> Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()
70
70
src/Grenade/Layers/Logit.hs+23−9
@@ -3,6 +3,13 @@
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6+{-|
7+Module : Grenade.Layers.Logit
8+Description : Sigmoid nonlinear layer
9+Copyright : (c) Huw Campbell, 2016-2017
10+License : BSD2
11+Stability : experimental
12+-}
6module Grenade.Layers.Logit (
13module Grenade.Layers.Logit (
7 Logit (..)
14 Logit (..)
8 ) where
15 ) where
@@ -14,6 +21,7 @@ import Data.Singletons
14import Grenade.Core
21import Grenade.Core
15
22
16-- | A Logit layer.
23-- | A Logit layer.
24+--
17-- A layer which can act between any shape of the same dimension, perfoming an sigmoid function.
25-- A layer which can act between any shape of the same dimension, perfoming an sigmoid function.
18-- This layer should be used as the output layer of a network for logistic regression (classification)
26-- This layer should be used as the output layer of a network for logistic regression (classification)
19-- problems.
27-- problems.
@@ -26,18 +34,24 @@ instance UpdateLayer Logit where
26 createRandom = return Logit
34 createRandom = return Logit
27
35
28instance (a ~ b, SingI a) => Layer Logit a b where
36instance (a ~ b, SingI a) => Layer Logit a b where
37+ -- Wengert tape optimisation:
38+ --
39+ -- Derivative of the sigmoid function is
40+ -- d σ(x) / dx = σ(x) • (1 - σ(x))
41+ -- but we have already calculated σ(x) in
42+ -- the forward pass, so just store that
43+ -- and use it in the backwards pass.
29 type Tape Logit a b = S a
44 type Tape Logit a b = S a
30− runForwards _ a = (a, logistic a)
45+ runForwards _ a =
46+ let l = sigmoid a
47+ in (l, l)
31− runBackwards _ a g = ((), logistic' a * g)
48+ runBackwards _ l g =
49+ let sigmoid' = l * (1 - l)
50+ in ((), sigmoid' * g)
32
51
33instance Serialize Logit where
52instance Serialize Logit where
34 put _ = return ()
53 put _ = return ()
35 get = return Logit
54 get = return Logit
36
55
37−logistic :: Floating a => a -> a
56+sigmoid :: Floating a => a -> a
38−logistic x = 1 / (1 + exp (-x))
57+sigmoid x = 1 / (1 + exp (-x))
39−
40−logistic' :: Floating a => a -> a
41−logistic' x = logix * (1 - logix)
42− where
43− logix = logistic x
src/Grenade/Layers/Merge.hsnew file+66
@@ -0,0 +1,66 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE FlexibleContexts #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE FlexibleInstances #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE StandaloneDeriving #-}
12+{-|
13+Module : Grenade.Core.Network
14+Description : Merging layer for parallel network composition
15+Copyright : (c) Huw Campbell, 2016-2017
16+License : BSD2
17+Stability : experimental
18+-}
19+module Grenade.Layers.Merge (
20+ Merge (..)
21+ ) where
22+
23+import Data.Serialize
24+
25+import Data.Singletons
26+
27+#if MIN_VERSION_base(4,9,0)
28+import Data.Kind (Type)
29+#endif
30+
31+import Grenade.Core
32+
33+-- | A Merging layer.
34+--
35+-- Similar to Concat layer, except sums the activations instead of creating a larger
36+-- shape.
37+data Merge :: Type -> Type -> Type where
38+ Merge :: x -> y -> Merge x y
39+
40+instance (Show x, Show y) => Show (Merge x y) where
41+ show (Merge x y) = "Merge\n" ++ show x ++ "\n" ++ show y
42+
43+-- | Run two layers in parallel, combining their outputs.
44+-- This just kind of "smooshes" the weights together.
45+instance (UpdateLayer x, UpdateLayer y) => UpdateLayer (Merge x y) where
46+ type Gradient (Merge x y) = (Gradient x, Gradient y)
47+ runUpdate lr (Merge x y) (x', y') = Merge (runUpdate lr x x') (runUpdate lr y y')
48+ createRandom = Merge <$> createRandom <*> createRandom
49+
50+-- | Combine the outputs and the inputs, summing the output shape
51+instance (SingI i, SingI o, Layer x i o, Layer y i o) => Layer (Merge x y) i o where
52+ type Tape (Merge x y) i o = (Tape x i o, Tape y i o)
53+
54+ runForwards (Merge x y) input =
55+ let (xT, xOut) = runForwards x input
56+ (yT, yOut) = runForwards y input
57+ in ((xT, yT), xOut + yOut)
58+
59+ runBackwards (Merge x y) (xTape, yTape) o =
60+ let (x', xB) = runBackwards x xTape o
61+ (y', yB) = runBackwards y yTape o
62+ in ((x', y'), xB + yB)
63+
64+instance (Serialize a, Serialize b) => Serialize (Merge a b) where
65+ put (Merge a b) = put a *> put b
66+ get = Merge <$> get <*> get
src/Grenade/Layers/Pad.hs+61−3
@@ -1,9 +1,19 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE FlexibleContexts #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+{-|
11+Module : Grenade.Core.Pad
12+Description : Padding layer for 2D and 3D images
13+Copyright : (c) Huw Campbell, 2016-2017
14+License : BSD2
15+Stability : experimental
16+-}
7module Grenade.Layers.Pad (
17module Grenade.Layers.Pad (
8 Pad (..)
18 Pad (..)
9 ) where
19 ) where
@@ -11,19 +21,23 @@ module Grenade.Layers.Pad (
11import Data.Maybe
21import Data.Maybe
12import Data.Proxy
22import Data.Proxy
13import Data.Serialize
23import Data.Serialize
14−import Data.Singletons.TypeLits
24+
15import GHC.TypeLits
25import GHC.TypeLits
26+import Data.Kind (Type)
16
27
17import Grenade.Core
28import Grenade.Core
29+import Grenade.Layers.Internal.Pad
18
30
19import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)
31import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)
20import Numeric.LinearAlgebra.Static (extract, create)
32import Numeric.LinearAlgebra.Static (extract, create)
21
33
22-- | A padding layer for a neural network.
34-- | A padding layer for a neural network.
35+--
36+-- Pads on the X and Y dimension of an image.
23data Pad :: Nat
37data Pad :: Nat
24 -> Nat
38 -> Nat
25 -> Nat
39 -> Nat
26− -> Nat -> * where
40+ -> Nat -> Type where
27 Pad :: Pad padLeft padTop padRight padBottom
41 Pad :: Pad padLeft padTop padRight padBottom
28
42
29instance Show (Pad padLeft padTop padRight padBottom) where
43instance Show (Pad padLeft padTop padRight padBottom) where
@@ -38,7 +52,7 @@ instance Serialize (Pad l t r b) where
38 put _ = return ()
52 put _ = return ()
39 get = return Pad
53 get = return Pad
40
54
41−-- | A two dimentional image can be padped.
55+-- | A two dimentional image can be padded.
42instance ( KnownNat padLeft
56instance ( KnownNat padLeft
43 , KnownNat padTop
57 , KnownNat padTop
44 , KnownNat padRight
58 , KnownNat padRight
@@ -67,3 +81,47 @@ instance ( KnownNat padLeft
67 m = extract dEdy
81 m = extract dEdy
68 vs = subMatrix (padt, padl) (nrows, ncols) m
82 vs = subMatrix (padt, padl) (nrows, ncols) m
69 in ((), S2D . fromJust . create $ vs)
83 in ((), S2D . fromJust . create $ vs)
84+
85+-- | A two dimentional image can be padded.
86+instance ( KnownNat padLeft
87+ , KnownNat padTop
88+ , KnownNat padRight
89+ , KnownNat padBottom
90+ , KnownNat inputRows
91+ , KnownNat inputColumns
92+ , KnownNat outputRows
93+ , KnownNat outputColumns
94+ , KnownNat channels
95+ , KnownNat (inputRows * channels)
96+ , KnownNat (outputRows * channels)
97+ , (inputRows + padTop + padBottom) ~ outputRows
98+ , (inputColumns + padLeft + padRight) ~ outputColumns
99+ ) => Layer (Pad padLeft padTop padRight padBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where
100+ type Tape (Pad padLeft padTop padRight padBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) = ()
101+ runForwards Pad (S3D input) =
102+ let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)
103+ padt = fromIntegral $ natVal (Proxy :: Proxy padTop)
104+ padr = fromIntegral $ natVal (Proxy :: Proxy padRight)
105+ padb = fromIntegral $ natVal (Proxy :: Proxy padBottom)
106+ outr = fromIntegral $ natVal (Proxy :: Proxy outputRows)
107+ outc = fromIntegral $ natVal (Proxy :: Proxy outputColumns)
108+ inr = fromIntegral $ natVal (Proxy :: Proxy inputRows)
109+ inc = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
110+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)
111+ m = extract input
112+ padded = pad ch padl padt padr padb inr inc outr outc m
113+ in ((), S3D . fromJust . create $ padded)
114+
115+ runBackwards Pad () (S3D gradient) =
116+ let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)
117+ padt = fromIntegral $ natVal (Proxy :: Proxy padTop)
118+ padr = fromIntegral $ natVal (Proxy :: Proxy padRight)
119+ padb = fromIntegral $ natVal (Proxy :: Proxy padBottom)
120+ outr = fromIntegral $ natVal (Proxy :: Proxy outputRows)
121+ outc = fromIntegral $ natVal (Proxy :: Proxy outputColumns)
122+ inr = fromIntegral $ natVal (Proxy :: Proxy inputRows)
123+ inc = fromIntegral $ natVal (Proxy :: Proxy inputColumns)
124+ ch = fromIntegral $ natVal (Proxy :: Proxy channels)
125+ m = extract gradient
126+ cropped = crop ch padl padt padr padb inr inc outr outc m
127+ in ((), S3D . fromJust . create $ cropped)
src/Grenade/Layers/Pooling.hs+14−3
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE StandaloneDeriving #-}
4{-# LANGUAGE StandaloneDeriving #-}
@@ -6,6 +7,14 @@
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE FlexibleContexts #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+{-|
12+Module : Grenade.Core.Pooling
13+Description : Max Pooling layer for 2D and 3D images
14+Copyright : (c) Huw Campbell, 2016-2017
15+License : BSD2
16+Stability : experimental
17+-}
9module Grenade.Layers.Pooling (
18module Grenade.Layers.Pooling (
10 Pooling (..)
19 Pooling (..)
11 ) where
20 ) where
@@ -13,8 +22,9 @@ module Grenade.Layers.Pooling (
13import Data.Maybe
22import Data.Maybe
14import Data.Proxy
23import Data.Proxy
15import Data.Serialize
24import Data.Serialize
16−import Data.Singletons.TypeLits
25+
17import GHC.TypeLits
26import GHC.TypeLits
27+import Data.Kind (Type)
18
28
19import Grenade.Core
29import Grenade.Core
20import Grenade.Layers.Internal.Pooling
30import Grenade.Layers.Internal.Pooling
@@ -22,20 +32,21 @@ import Grenade.Layers.Internal.Pooling
22import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)
32import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)
23
33
24-- | A pooling layer for a neural network.
34-- | A pooling layer for a neural network.
35+--
25-- Does a max pooling, looking over a kernel similarly to the convolution network, but returning
36-- Does a max pooling, looking over a kernel similarly to the convolution network, but returning
26-- maxarg only. This layer is often used to provide minor amounts of translational invariance.
37-- maxarg only. This layer is often used to provide minor amounts of translational invariance.
27--
38--
28-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:
39-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:
29-- `out = (in - kernel) / stride + 1` for both dimensions.
40-- `out = (in - kernel) / stride + 1` for both dimensions.
30--
41--
31−data Pooling :: Nat -> Nat -> Nat -> Nat -> * where
42+data Pooling :: Nat -> Nat -> Nat -> Nat -> Type where
32 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns
43 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns
33
44
34instance Show (Pooling k k' s s') where
45instance Show (Pooling k k' s s') where
35 show Pooling = "Pooling"
46 show Pooling = "Pooling"
36
47
37instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where
48instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where
38− type Gradient (Pooling kr kc sr sc) = ()
49+ type Gradient (Pooling kernelRows kernelColumns strideRows strideColumns) = ()
39 runUpdate _ Pooling _ = Pooling
50 runUpdate _ Pooling _ = Pooling
40 createRandom = return Pooling
51 createRandom = return Pooling
41
52
src/Grenade/Layers/Relu.hs+7
@@ -2,6 +2,13 @@
2{-# LANGUAGE TypeOperators #-}
2{-# LANGUAGE TypeOperators #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5+{-|
6+Module : Grenade.Layers.Relu
7+Description : Rectifying linear unit layer
8+Copyright : (c) Huw Campbell, 2016-2017
9+License : BSD2
10+Stability : experimental
11+-}
5module Grenade.Layers.Relu (
12module Grenade.Layers.Relu (
6 Relu (..)
13 Relu (..)
7 ) where
14 ) where
src/Grenade/Layers/Reshape.hsnew file+80
@@ -0,0 +1,80 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeOperators #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE UndecidableInstances #-}
7+{-|
8+Module : Grenade.Layers.Reshape
9+Description : Multipurpose reshaping layer
10+Copyright : (c) Huw Campbell, 2016-2017
11+License : BSD2
12+Stability : experimental
13+-}
14+module Grenade.Layers.Reshape (
15+ Reshape (..)
16+ ) where
17+
18+import Data.Serialize
19+
20+import GHC.TypeLits
21+
22+import Numeric.LinearAlgebra.Static
23+import Numeric.LinearAlgebra.Data as LA ( flatten )
24+
25+import Grenade.Core
26+
27+-- | Reshape Layer
28+--
29+-- The Reshape layer can flatten any 2D or 3D image to 1D vector with the
30+-- same number of activations, as well as cast up from 1D to a 2D or 3D
31+-- shape.
32+--
33+-- Can also be used to turn a 3D image with only one channel into a 2D image
34+-- or vice versa.
35+data Reshape = Reshape
36+ deriving Show
37+
38+instance UpdateLayer Reshape where
39+ type Gradient Reshape = ()
40+ runUpdate _ _ _ = Reshape
41+ createRandom = return Reshape
42+
43+instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer Reshape ('D2 x y) ('D1 a) where
44+ type Tape Reshape ('D2 x y) ('D1 a) = ()
45+ runForwards _ (S2D y) = ((), fromJust' . fromStorable . flatten . extract $ y)
46+ runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)
47+
48+instance (KnownNat a, KnownNat x, KnownNat y, KnownNat (x * z), KnownNat z, a ~ (x * y * z)) => Layer Reshape ('D3 x y z) ('D1 a) where
49+ type Tape Reshape ('D3 x y z) ('D1 a) = ()
50+ runForwards _ (S3D y) = ((), fromJust' . fromStorable . flatten . extract $ y)
51+ runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)
52+
53+instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer Reshape ('D3 x y z) ('D2 x y) where
54+ type Tape Reshape ('D3 x y z) ('D2 x y) = ()
55+ runForwards _ (S3D y) = ((), S2D y)
56+ runBackwards _ _ (S2D y) = ((), S3D y)
57+
58+instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer Reshape ('D2 x y) ('D3 x y z) where
59+ type Tape Reshape ('D2 x y) ('D3 x y z) = ()
60+ runForwards _ (S2D y) = ((), S3D y)
61+ runBackwards _ _ (S3D y) = ((), S2D y)
62+
63+instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer Reshape ('D1 a) ('D2 x y) where
64+ type Tape Reshape ('D1 a) ('D2 x y) = ()
65+ runForwards _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)
66+ runBackwards _ _ (S2D y) = ((), fromJust' . fromStorable . flatten . extract $ y)
67+
68+instance (KnownNat a, KnownNat x, KnownNat y, KnownNat (x * z), KnownNat z, a ~ (x * y * z)) => Layer Reshape ('D1 a) ('D3 x y z) where
69+ type Tape Reshape ('D1 a) ('D3 x y z) = ()
70+ runForwards _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)
71+ runBackwards _ _ (S3D y) = ((), fromJust' . fromStorable . flatten . extract $ y)
72+
73+instance Serialize Reshape where
74+ put _ = return ()
75+ get = return Reshape
76+
77+
78+fromJust' :: Maybe x -> x
79+fromJust' (Just x) = x
80+fromJust' Nothing = error $ "Reshape error: data shape couldn't be converted."
src/Grenade/Layers/Sinusoid.hsnew file+39
@@ -0,0 +1,39 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-|
7+Module : Grenade.Layers.Sinusoid
8+Description : Sinusoid nonlinear layer
9+Copyright : (c) Manuel Schneckenreither, 2018
10+License : BSD2
11+Stability : experimental
12+-}
13+module Grenade.Layers.Sinusoid (
14+ Sinusoid (..)
15+ ) where
16+
17+import Data.Serialize
18+import Data.Singletons
19+
20+import Grenade.Core
21+
22+-- | A Sinusoid layer.
23+-- A layer which can act between any shape of the same dimension, performing a sin function.
24+data Sinusoid = Sinusoid
25+ deriving Show
26+
27+instance UpdateLayer Sinusoid where
28+ type Gradient Sinusoid = ()
29+ runUpdate _ _ _ = Sinusoid
30+ createRandom = return Sinusoid
31+
32+instance Serialize Sinusoid where
33+ put _ = return ()
34+ get = return Sinusoid
35+
36+instance (a ~ b, SingI a) => Layer Sinusoid a b where
37+ type Tape Sinusoid a b = S a
38+ runForwards _ a = (a, sin a)
39+ runBackwards _ a g = ((), cos a * g)
src/Grenade/Layers/Softmax.hs+11
@@ -3,6 +3,13 @@
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6+{-|
7+Module : Grenade.Core.Softmax
8+Description : Softmax loss layer
9+Copyright : (c) Huw Campbell, 2016-2017
10+License : BSD2
11+Stability : experimental
12+-}
6module Grenade.Layers.Softmax (
13module Grenade.Layers.Softmax (
7 Softmax (..)
14 Softmax (..)
8 , softmax
15 , softmax
@@ -17,8 +24,12 @@ import Grenade.Core
17import Numeric.LinearAlgebra.Static as LAS
24import Numeric.LinearAlgebra.Static as LAS
18
25
19-- | A Softmax layer
26-- | A Softmax layer
27+--
20-- This layer is like a logit layer, but normalises
28-- This layer is like a logit layer, but normalises
21-- a set of matricies to be probabilities.
29-- a set of matricies to be probabilities.
30+--
31+-- One can use this layer as the last layer in a network
32+-- if they need normalised probabilities.
22data Softmax = Softmax
33data Softmax = Softmax
23 deriving Show
34 deriving Show
24
35
src/Grenade/Layers/Tanh.hs+10−3
@@ -1,8 +1,15 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-|
7+Module : Grenade.Layers.Tanh
8+Description : Hyperbolic tangent nonlinear layer
9+Copyright : (c) Huw Campbell, 2016-2017
10+License : BSD2
11+Stability : experimental
12+-}
6module Grenade.Layers.Tanh (
13module Grenade.Layers.Tanh (
7 Tanh (..)
14 Tanh (..)
8 ) where
15 ) where
@@ -13,7 +20,7 @@ import Data.Singletons
13import Grenade.Core
20import Grenade.Core
14
21
15-- | A Tanh layer.
22-- | A Tanh layer.
16−-- A layer which can act between any shape of the same dimension, perfoming a tanh function.
23+-- A layer which can act between any shape of the same dimension, performing a tanh function.
17data Tanh = Tanh
24data Tanh = Tanh
18 deriving Show
25 deriving Show
19
26
src/Grenade/Layers/Trivial.hsnew file+40
@@ -0,0 +1,40 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeOperators #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-|
7+Module : Grenade.Core.Trivial
8+Description : Trivial layer which perfoms no operations on the data
9+Copyright : (c) Huw Campbell, 2016-2017
10+License : BSD2
11+Stability : experimental
12+-}
13+module Grenade.Layers.Trivial (
14+ Trivial (..)
15+ ) where
16+
17+import Data.Serialize
18+
19+import Grenade.Core
20+
21+-- | A Trivial layer.
22+--
23+-- This can be used to pass an unchanged value up one side of a
24+-- graph, for a Residual network for example.
25+data Trivial = Trivial
26+ deriving Show
27+
28+instance Serialize Trivial where
29+ put _ = return ()
30+ get = return Trivial
31+
32+instance UpdateLayer Trivial where
33+ type Gradient Trivial = ()
34+ runUpdate _ _ _ = Trivial
35+ createRandom = return Trivial
36+
37+instance (a ~ b) => Layer Trivial a b where
38+ type Tape Trivial a b = ()
39+ runForwards _ a = ((), a)
40+ runBackwards _ _ y = ((), y)
src/Grenade/Recurrent.hs+26−5
@@ -1,8 +1,29 @@
1module Grenade.Recurrent (
1module Grenade.Recurrent (
2− module X
2+ -- | This is an empty module which simply re-exports public definitions
3+ -- for recurrent networks in Grenade.
4+
5+ -- * Exported modules
6+ --
7+ -- | The core types and runners for Recurrent Networks.
8+ module Grenade.Recurrent.Core
9+
10+ -- | The recurrent neural network layer zoo
11+ , module Grenade.Recurrent.Layers
12+
13+ -- * Overview of recurrent Networks
14+ -- $recurrent
15+
3 ) where
16 ) where
4
17
5−import Grenade.Recurrent.Core.Network as X
18+import Grenade.Recurrent.Core
6−import Grenade.Recurrent.Core.Runner as X
19+import Grenade.Recurrent.Layers
7−import Grenade.Recurrent.Layers.BasicRecurrent as X
20+
8−import Grenade.Recurrent.Layers.LSTM as X
21+{- $recurrent
22+There are two ways in which deep learning libraries choose to represent
23+recurrent Neural Networks, as an unrolled graph, or at a first class
24+level. Grenade chooses the latter representation, and provides a network
25+type which is specifically suited for recurrent neural networks.
26+
27+Currently grenade supports two layers, a basic recurrent layer, and an
28+LSTM layer.
29+-}
src/Grenade/Recurrent/Core.hsnew file+9
@@ -0,0 +1,9 @@
1+module Grenade.Recurrent.Core (
2+ module Grenade.Recurrent.Core.Layer
3+ , module Grenade.Recurrent.Core.Network
4+ , module Grenade.Recurrent.Core.Runner
5+ ) where
6+
7+import Grenade.Recurrent.Core.Layer
8+import Grenade.Recurrent.Core.Network
9+import Grenade.Recurrent.Core.Runner
src/Grenade/Recurrent/Core/Layer.hsnew file+35
@@ -0,0 +1,35 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+module Grenade.Recurrent.Core.Layer (
8+ RecurrentLayer (..)
9+ , RecurrentUpdateLayer (..)
10+ ) where
11+
12+#if MIN_VERSION_base(4,9,0)
13+import Data.Kind (Type)
14+#endif
15+
16+import Grenade.Core
17+
18+-- | Class for a recurrent layer.
19+-- It's quite similar to a normal layer but for the input and output
20+-- of an extra recurrent data shape.
21+class UpdateLayer x => RecurrentUpdateLayer x where
22+ -- | Shape of data that is passed between each subsequent run of the layer
23+ type RecurrentShape x :: Type
24+
25+class (RecurrentUpdateLayer x, Num (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where
26+ -- | Wengert Tape
27+ type RecTape x i o :: Type
28+ -- | Used in training and scoring. Take the input from the previous
29+ -- layer, and give the output from this layer.
30+ runRecurrentForwards :: x -> RecurrentShape x -> S i -> (RecTape x i o, RecurrentShape x, S o)
31+ -- | Back propagate a step. Takes the current layer, the input that the
32+ -- layer gave from the input and the back propagated derivatives from
33+ -- the layer above.
34+ -- Returns the gradient layer and the derivatives to push back further.
35+ runRecurrentBackwards :: x -> RecTape x i o -> RecurrentShape x -> S o -> (Gradient x, RecurrentShape x, S i)
src/Grenade/Recurrent/Core/Network.hs+258−67
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TypeOperators #-}
@@ -6,60 +7,195 @@
6{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE EmptyDataDecls #-}
9{-# LANGUAGE EmptyDataDecls #-}
10+{-# LANGUAGE RankNTypes #-}
11+{-# LANGUAGE BangPatterns #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+
9module Grenade.Recurrent.Core.Network (
15module Grenade.Recurrent.Core.Network (
10 Recurrent
16 Recurrent
11 , FeedForward
17 , FeedForward
12− , RecurrentLayer (..)
18+
13− , RecurrentUpdateLayer (..)
14 , RecurrentNetwork (..)
19 , RecurrentNetwork (..)
15 , RecurrentInputs (..)
20 , RecurrentInputs (..)
16− , CreatableRecurrent (..)
21+ , RecurrentTape (..)
22+ , RecurrentGradient (..)
23+
24+ , randomRecurrent
25+ , runRecurrent
26+ , runRecurrent'
27+ , applyRecurrentUpdate
17 ) where
28 ) where
18
29
19
30
20import Control.Monad.Random ( MonadRandom )
31import Control.Monad.Random ( MonadRandom )
21−import Data.Singletons ( SingI )
22import Data.Serialize
32import Data.Serialize
23−import qualified Data.Vector.Storable as V
24
33
25−import Grenade.Core
34+import Data.Kind (Type)
26−
27−import qualified Numeric.LinearAlgebra as LA
28−import qualified Numeric.LinearAlgebra.Static as LAS
29
35
36+import Grenade.Core
37+import Grenade.Recurrent.Core.Layer
38+import Prelude.Singletons
30
39
31-- | Witness type to say indicate we're building up with a normal feed
40-- | Witness type to say indicate we're building up with a normal feed
32-- forward layer.
41-- forward layer.
33−data FeedForward :: * -> *
42+data FeedForward :: Type -> Type
34-- | Witness type to say indicate we're building up with a recurrent layer.
43-- | Witness type to say indicate we're building up with a recurrent layer.
35−data Recurrent :: * -> *
44+data Recurrent :: Type -> Type
36−
45+
37−-- | Class for a recurrent layer.
46+-- | Type of a recurrent neural network.
38−-- It's quite similar to a normal layer but for the input and output
47+--
39−-- of an extra recurrent data shape.
48+-- The [Type] type specifies the types of the layers.
40−class UpdateLayer x => RecurrentUpdateLayer x where
49+--
41− -- | Shape of data that is passed between each subsequent run of the layer
50+-- The [Shape] type specifies the shapes of data passed between the layers.
42− type RecurrentShape x :: Shape
51+--
43−
52+-- The definition is similar to a Network, but every layer in the
44−class (RecurrentUpdateLayer x, SingI (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where
53+-- type is tagged by whether it's a FeedForward Layer of a Recurrent layer.
45− -- | Wengert Tape
54+--
46− type RecTape x i o :: *
55+-- Often, to make the definitions more concise, one will use a type alias
47− -- | Used in training and scoring. Take the input from the previous
56+-- for these empty data types.
48− -- layer, and give the output from this layer.
49− runRecurrentForwards :: x -> S (RecurrentShape x) -> S i -> (RecTape x i o, S (RecurrentShape x), S o)
50− -- | Back propagate a step. Takes the current layer, the input that the
51− -- layer gave from the input and the back propagated derivatives from
52− -- the layer above.
53− -- Returns the gradient layer and the derivatives to push back further.
54− runRecurrentBackwards :: x -> RecTape x i o -> S (RecurrentShape x) -> S o -> (Gradient x, S (RecurrentShape x), S i)
55−
56−data RecurrentNetwork :: [*] -> [Shape] -> * where
57+data RecurrentNetwork :: [Type] -> [Shape] -> Type where
58+ RNil :: SingI i
57− RNil :: SingI i => RecurrentNetwork '[] '[i]
59+ => RecurrentNetwork '[] '[i]
60+
61+ (:~~>) :: (SingI i, Layer x i h)
62+ => !x
63+ -> !(RecurrentNetwork xs (h ': hs))
58− (:~~>) :: (SingI i, Layer x i h) => !x -> !(RecurrentNetwork xs (h ': hs)) -> RecurrentNetwork (FeedForward x ': xs) (i ': h ': hs)
64+ -> RecurrentNetwork (FeedForward x ': xs) (i ': h ': hs)
65+
66+ (:~@>) :: (SingI i, RecurrentLayer x i h)
67+ => !x
68+ -> !(RecurrentNetwork xs (h ': hs))
59− (:~@>) :: (SingI i, RecurrentLayer x i h) => !x -> !(RecurrentNetwork xs (h ': hs)) -> RecurrentNetwork (Recurrent x ': xs) (i ': h ': hs)
69+ -> RecurrentNetwork (Recurrent x ': xs) (i ': h ': hs)
60infixr 5 :~~>
70infixr 5 :~~>
61infixr 5 :~@>
71infixr 5 :~@>
62
72
73+-- | Gradient of a network.
74+--
75+-- Parameterised on the layers of the network.
76+data RecurrentGradient :: [Type] -> Type where
77+ RGNil :: RecurrentGradient '[]
78+
79+ (://>) :: UpdateLayer x
80+ => Gradient x
81+ -> RecurrentGradient xs
82+ -> RecurrentGradient (phantom x ': xs)
83+
84+-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)
85+-- Parameterised on the layers of a Network.
86+data RecurrentInputs :: [Type] -> Type where
87+ RINil :: RecurrentInputs '[]
88+
89+ (:~~+>) :: (UpdateLayer x, Fractional (RecurrentInputs xs))
90+ => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)
91+
92+ (:~@+>) :: (Fractional (RecurrentShape x), Fractional (RecurrentInputs xs), RecurrentUpdateLayer x)
93+ => !(RecurrentShape x) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)
94+
95+-- | All the information required to backpropogate
96+-- through time safely.
97+--
98+-- We index on the time step length as well, to ensure
99+-- that that all Tape lengths are the same.
100+data RecurrentTape :: [Type] -> [Shape] -> Type where
101+ TRNil :: SingI i
102+ => RecurrentTape '[] '[i]
103+
104+ (:\~>) :: Tape x i h
105+ -> !(RecurrentTape xs (h ': hs))
106+ -> RecurrentTape (FeedForward x ': xs) (i ': h ': hs)
107+
108+ (:\@>) :: RecTape x i h
109+ -> !(RecurrentTape xs (h ': hs))
110+ -> RecurrentTape (Recurrent x ': xs) (i ': h ': hs)
111+
112+
113+runRecurrent :: forall shapes layers.
114+ RecurrentNetwork layers shapes
115+ -> RecurrentInputs layers
116+ -> S (Head shapes)
117+ -> (RecurrentTape layers shapes, RecurrentInputs layers, S (Last shapes))
118+runRecurrent =
119+ go
120+ where
121+ go :: forall js sublayers. (Last js ~ Last shapes)
122+ => RecurrentNetwork sublayers js
123+ -> RecurrentInputs sublayers
124+ -> S (Head js)
125+ -> (RecurrentTape sublayers js, RecurrentInputs sublayers, S (Last js))
126+ go (!layer :~~> n) (() :~~+> nIn) !x
127+ = let (!tape, !forwards) = runForwards layer x
128+
129+ -- recursively run the rest of the network, and get the gradients from above.
130+ (!newFN, !ig, !answer) = go n nIn forwards
131+ in (tape :\~> newFN, () :~~+> ig, answer)
132+
133+ -- This is a recurrent layer, so we need to do a scan, first input to last, providing
134+ -- the recurrent shape output to the next layer.
135+ go (layer :~@> n) (recIn :~@+> nIn) !x
136+ = let (tape, shape, forwards) = runRecurrentForwards layer recIn x
137+ (newFN, ig, answer) = go n nIn forwards
138+ in (tape :\@> newFN, shape :~@+> ig, answer)
139+
140+ -- Handle the output layer, bouncing the derivatives back down.
141+ -- We may not have a target for each example, so when we don't use 0 gradient.
142+ go RNil RINil !x
143+ = (TRNil, RINil, x)
144+
145+runRecurrent' :: forall layers shapes.
146+ RecurrentNetwork layers shapes
147+ -> RecurrentTape layers shapes
148+ -> RecurrentInputs layers
149+ -> S (Last shapes)
150+ -> (RecurrentGradient layers, RecurrentInputs layers, S (Head shapes))
151+runRecurrent' net tapes r o =
152+ go net tapes r
153+ where
154+ -- We have to be careful regarding the direction of the lists
155+ -- Inputs come in forwards, but our return value is backwards
156+ -- through time.
157+ go :: forall js ss. (Last js ~ Last shapes)
158+ => RecurrentNetwork ss js
159+ -> RecurrentTape ss js
160+ -> RecurrentInputs ss
161+ -> (RecurrentGradient ss, RecurrentInputs ss, S (Head js))
162+ -- This is a simple non-recurrent layer
163+ -- Run the rest of the network, update with the tapes and gradients
164+ go (!layer :~~> n) (!tape :\~> nTapes) (() :~~+> nRecs) =
165+ let (!gradients, !rins, !feed) = go n nTapes nRecs
166+ (!grad, !back) = runBackwards layer tape feed
167+ in (grad ://> gradients, () :~~+> rins, back)
168+
169+ -- This is a recurrent layer
170+ -- Run the rest of the network, scan over the tapes in reverse
171+ go (!layer :~@> n) (!tape :\@> nTapes) (!recGrad :~@+> nRecs) =
172+ let (!gradients, !rins, !feed) = go n nTapes nRecs
173+ (!grad, !sidegrad, !back) = runRecurrentBackwards layer tape recGrad feed
174+ in (grad ://> gradients, sidegrad :~@+> rins, back)
175+
176+ -- End of the road, so we reflect the given gradients backwards.
177+ -- Crucially, we reverse the list, so it's backwards in time as
178+ -- well.
179+ go !RNil !TRNil !RINil
180+ = (RGNil, RINil, o)
181+
182+-- | Apply a batch of gradients to the network
183+-- Uses runUpdates which can be specialised for
184+-- a layer.
185+applyRecurrentUpdate :: LearningParameters
186+ -> RecurrentNetwork layers shapes
187+ -> RecurrentGradient layers
188+ -> RecurrentNetwork layers shapes
189+applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)
190+ = runUpdate rate layer gradient :~~> applyRecurrentUpdate rate rest grest
191+
192+applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)
193+ = runUpdate rate layer gradient :~@> applyRecurrentUpdate rate rest grest
194+
195+applyRecurrentUpdate _ RNil RGNil
196+ = RNil
197+
198+
63instance Show (RecurrentNetwork '[] '[i]) where
199instance Show (RecurrentNetwork '[] '[i]) where
64 show RNil = "NNil"
200 show RNil = "NNil"
65instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (FeedForward x ': xs) (i ': rs)) where
201instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (FeedForward x ': xs) (i ': rs)) where
@@ -67,39 +203,28 @@ instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Feed
67instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recurrent x ': xs) (i ': rs)) where
203instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recurrent x ': xs) (i ': rs)) where
68 show (x :~@> xs) = show x ++ "\n~~>\n" ++ show xs
204 show (x :~@> xs) = show x ++ "\n~~>\n" ++ show xs
69
205
70−-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)
71−-- Parameterised on the layers of a Network.
72−data RecurrentInputs :: [*] -> * where
73− RINil :: RecurrentInputs '[]
74− (:~~+>) :: UpdateLayer x
75− => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)
76− (:~@+>) :: (SingI (RecurrentShape x), RecurrentUpdateLayer x)
77− => !(S (RecurrentShape x)) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)
78−infixr 5 :~~+>
79−infixr 5 :~@+>
80
206
81-- | A network can easily be created by hand with (:~~>) and (:~@>), but an easy way to initialise a random
207-- | A network can easily be created by hand with (:~~>) and (:~@>), but an easy way to initialise a random
82-- recurrent network and a set of random inputs for it is with the randomRecurrent.
208-- recurrent network and a set of random inputs for it is with the randomRecurrent.
83−class CreatableRecurrent (xs :: [*]) (ss :: [Shape]) where
209+class CreatableRecurrent (xs :: [Type]) (ss :: [Shape]) where
84 -- | Create a network of the types requested
210 -- | Create a network of the types requested
85− randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss, RecurrentInputs xs)
211+ randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss)
86
212
87instance SingI i => CreatableRecurrent '[] '[i] where
213instance SingI i => CreatableRecurrent '[] '[i] where
88 randomRecurrent =
214 randomRecurrent =
89− return (RNil, RINil)
215+ return RNil
90
216
91instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where
217instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where
92 randomRecurrent = do
218 randomRecurrent = do
93 thisLayer <- createRandom
219 thisLayer <- createRandom
94− (rest, resti) <- randomRecurrent
220+ rest <- randomRecurrent
95− return (thisLayer :~~> rest, () :~~+> resti)
221+ return (thisLayer :~~> rest)
96
222
97instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where
223instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where
98 randomRecurrent = do
224 randomRecurrent = do
99 thisLayer <- createRandom
225 thisLayer <- createRandom
100− thisShape <- randomOfShape
101− (rest, resti) <- randomRecurrent
226+ rest <- randomRecurrent
102− return (thisLayer :~@> rest, thisShape :~@+> resti)
227+ return (thisLayer :~@> rest)
103
228
104-- | Add very simple serialisation to the recurrent network
229-- | Add very simple serialisation to the recurrent network
105instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where
230instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where
@@ -118,20 +243,86 @@ instance (Serialize (RecurrentInputs '[])) where
118 put _ = return ()
243 put _ = return ()
119 get = return RINil
244 get = return RINil
120
245
121−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
122 put ( () :~~+> rest) = put rest
247 put ( () :~~+> rest) = put rest
123 get = ( () :~~+> ) <$> get
248 get = ( () :~~+> ) <$> get
124
249
125−instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where
250+instance (Serialize (RecurrentShape x), Fractional (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where
126− put ( i :~@+> rest ) = do
251+ put ( i :~@+> rest ) = put i >> put rest
127− _ <- (case i of
128− (S1D x) -> putListOf put . LA.toList . LAS.extract $ x
129− (S2D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x
130− (S3D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x
131− ) :: PutM ()
132− put rest
133−
134− get = do
252+ get = (:~@+>) <$> get <*> get
135− Just i <- fromStorable . V.fromList <$> getListOf get
253+
136− rest <- get
254+
137− return ( i :~@+> rest)
255+-- Num instance for `RecurrentInputs layers`
256+-- Not sure if this is really needed, as I only need a `fromInteger 0` at
257+-- the moment for training, to create a null gradient on the recurrent
258+-- edge.
259+--
260+-- It does raise an interesting question though? Is a 0 gradient actually
261+-- the best?
262+--
263+-- I could imaging that weakly push back towards the optimum input could
264+-- help make a more stable generator.
265+instance (Num (RecurrentInputs '[])) where
266+ (+) _ _ = RINil
267+ (-) _ _ = RINil
268+ (*) _ _ = RINil
269+ abs _ = RINil
270+ signum _ = RINil
271+ fromInteger _ = RINil
272+
273+instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where
274+ (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)
275+ (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)
276+ (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)
277+ abs (() :~~+> x) = () :~~+> abs x
278+ signum (() :~~+> x) = () :~~+> signum x
279+ fromInteger x = () :~~+> fromInteger x
280+
281+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where
282+ (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')
283+ (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')
284+ (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')
285+ abs (x :~@+> x') = abs x :~@+> abs x'
286+ signum (x :~@+> x') = signum x :~@+> signum x'
287+ fromInteger x = fromInteger x :~@+> fromInteger x
288+
289+instance (Fractional (RecurrentInputs '[])) where
290+ (/) _ _ = RINil
291+ recip _ = RINil
292+ fromRational _ = RINil
293+
294+instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (FeedForward x ': ys))) where
295+ (/) (() :~~+> x) (() :~~+> y) = () :~~+> (x / y)
296+ recip (() :~~+> x) = () :~~+> recip x
297+ fromRational x = () :~~+> fromRational x
298+
299+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (Recurrent x ': ys))) where
300+ (/) (x :~@+> x') (y :~@+> y') = (x / y) :~@+> (x' / y')
301+ recip (x :~@+> x') = recip x :~@+> recip x'
302+ fromRational x = fromRational x :~@+> fromRational x
303+
304+
305+-- | Ultimate composition.
306+--
307+-- This allows a complete network to be treated as a layer in a larger network.
308+instance CreatableRecurrent sublayers subshapes => UpdateLayer (RecurrentNetwork sublayers subshapes) where
309+ type Gradient (RecurrentNetwork sublayers subshapes) = RecurrentGradient sublayers
310+ runUpdate = applyRecurrentUpdate
311+ createRandom = randomRecurrent
312+
313+-- | Ultimate composition.
314+--
315+-- This allows a complete network to be treated as a layer in a larger network.
316+instance CreatableRecurrent sublayers subshapes => RecurrentUpdateLayer (RecurrentNetwork sublayers subshapes) where
317+ type RecurrentShape (RecurrentNetwork sublayers subshapes) = RecurrentInputs sublayers
318+
319+-- | Ultimate composition.
320+--
321+-- This allows a complete network to be treated as a layer in a larger network.
322+instance ( CreatableRecurrent sublayers subshapes
323+ , i ~ (Head subshapes), o ~ (Last subshapes)
324+ , Num (RecurrentShape (RecurrentNetwork sublayers subshapes))
325+ ) => RecurrentLayer (RecurrentNetwork sublayers subshapes) i o where
326+ type RecTape (RecurrentNetwork sublayers subshapes) i o = RecurrentTape sublayers subshapes
327+ runRecurrentForwards = runRecurrent
328+ runRecurrentBackwards = runRecurrent'
src/Grenade/Recurrent/Core/Runner.hs+87−119
@@ -6,137 +6,105 @@
6{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RankNTypes #-}
9−{-# LANGUAGE RecordWildCards #-}
10
9
11−-- GHC 7.10 doesn't think that go is complete
12−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
13module Grenade.Recurrent.Core.Runner (
10module Grenade.Recurrent.Core.Runner (
11+ runRecurrentExamples
12+ , runRecurrentBackprop
13+ , backPropagateRecurrent
14− trainRecurrent
14+ , trainRecurrent
15− , runRecurrent
15+
16+ , RecurrentGradients
16 ) where
17 ) where
17
18
18−import Data.Singletons.Prelude
19+import Data.List ( foldl' )
19import Grenade.Core
20import Grenade.Core
20
21
21import Grenade.Recurrent.Core.Network
22import Grenade.Recurrent.Core.Network
23+import Prelude.Singletons
24+
25+type RecurrentGradients layers = [RecurrentGradient layers]
26+
27+runRecurrentExamples :: forall shapes layers.
28+ RecurrentNetwork layers shapes
29+ -> RecurrentInputs layers
30+ -> [S (Head shapes)]
31+ -> ([(RecurrentTape layers shapes, S (Last shapes))], RecurrentInputs layers)
32+runRecurrentExamples net =
33+ go
34+ where
35+ go !side [] = ([], side)
36+ go !side (!x : xs) =
37+ let (!tape, !side', !o) = runRecurrent net side x
38+ (!res, !finalSide) = go side' xs
39+ in (( tape, o ) : res, finalSide)
40+
41+runRecurrentBackprop :: forall layers shapes.
42+ RecurrentNetwork layers shapes
43+ -> RecurrentInputs layers
44+ -> [(RecurrentTape layers shapes, S (Last shapes))]
45+ -> ([(RecurrentGradient layers, S (Head shapes))], RecurrentInputs layers)
46+runRecurrentBackprop net =
47+ go
48+ where
49+ go !side [] = ([], side)
50+ go !side ((!tape,!x):xs) =
51+ let (res, !side') = go side xs
52+ (!grad, !finalSide, !o) = runRecurrent' net tape side' x
53+ in (( grad, o ) : res, finalSide)
54+
22
55
23-- | Drive and network and collect its back propogated gradients.
56-- | Drive and network and collect its back propogated gradients.
24−--
57+backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))
25−-- TODO: split this nicely into backpropagate and update.
58+ => RecurrentNetwork layers shapes
26−--
59+ -> RecurrentInputs layers
27−-- QUESTION: Should we return a list of gradients or the sum of
60+ -> [(S (Head shapes), Maybe (S (Last shapes)))]
28−-- the gradients? It's different taking into account
61+ -> (RecurrentGradients layers, RecurrentInputs layers)
29−-- momentum and L2.
62+backPropagateRecurrent network recinputs examples =
63+ let (outForwards, _) = runRecurrentExamples network recinputs inputs
64+
65+ backPropagations = zipWith makeError outForwards targets
66+
67+ (outBackwards, input') = runRecurrentBackprop network 0 backPropagations
68+
69+ gradients = fmap fst outBackwards
70+ in (gradients, input')
71+
72+ where
73+
74+ inputs = fst <$> examples
75+ targets = snd <$> examples
76+
77+ makeError :: (x, S (Last shapes)) -> Maybe (S (Last shapes)) -> (x, S (Last shapes))
78+ makeError (x, _) Nothing = (x, 0)
79+ makeError (x, y) (Just t) = (x, y - t)
80+
81+
30−trainRecurrent :: forall shapes layers. SingI (Last shapes)
82+trainRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))
31 => LearningParameters
83 => LearningParameters
32 -> RecurrentNetwork layers shapes
84 -> RecurrentNetwork layers shapes
33 -> RecurrentInputs layers
85 -> RecurrentInputs layers
34 -> [(S (Head shapes), Maybe (S (Last shapes)))]
86 -> [(S (Head shapes), Maybe (S (Last shapes)))]
35 -> (RecurrentNetwork layers shapes, RecurrentInputs layers)
87 -> (RecurrentNetwork layers shapes, RecurrentInputs layers)
36trainRecurrent rate network recinputs examples =
88trainRecurrent rate network recinputs examples =
37− updateBack $ go inputs network recinputs
89+ let (gradients, recinputs') = backPropagateRecurrent network recinputs examples
38− where
90+
39− inputs = fst <$> examples
91+ newInputs = updateRecInputs rate recinputs recinputs'
40− targets = snd <$> examples
92+
41− updateBack (a,recgrad,_) = (a,updateRecInputs rate recinputs recgrad)
93+ newNetwork = foldl' (applyRecurrentUpdate rate) network gradients
42−
94+
43− go :: forall js sublayers. (Last js ~ Last shapes)
95+ in (newNetwork, newInputs)
44− => [S (Head js)] -- ^ input vector
96+
45− -> RecurrentNetwork sublayers js -- ^ network to train
46− -> RecurrentInputs sublayers
47− -> (RecurrentNetwork sublayers js, RecurrentInputs sublayers, [S (Head js)])
48−
49− -- This is a simple non-recurrent layer, just map it forwards
50− -- Note we're doing training here, we could just return a list of gradients
51− -- (and probably will in future).
52− go !xs (layer :~~> n) (() :~~+> nIn)
53− = let tys = runForwards layer <$> xs
54− tapes = fst <$> tys
55− ys = snd <$> tys
56− -- recursively run the rest of the network, and get the gradients from above.
57− (newFN, ig, grads) = go ys n nIn
58− -- calculate the gradient for this layer to pass down,
59− back = uncurry (runBackwards layer) <$> zip (reverse tapes) grads
60− -- the new trained layer.
61− newlayer = runUpdates rate layer (fst <$> back)
62−
63− in (newlayer :~~> newFN, () :~~+> ig, snd <$> back)
64−
65− -- This is a recurrent layer, so we need to do a scan, first input to last, providing
66− -- the recurrent shape output to the next layer.
67− go !xs (layer :~@> n) (g :~@+> nIn)
68− = let tys = scanlFrom layer g xs
69− tapes = fst <$> tys
70− ys = snd <$> tys
71−
72− (newFN, ig, grads) = go ys n nIn
73−
74− backExamples = zip (reverse tapes) grads
75−
76− (rg, back) = myscanbackward layer backExamples
77− -- the new trained layer.
78− newlayer = runUpdates rate layer (fst <$> back)
79− in (newlayer :~@> newFN, rg :~@+> ig, snd <$> back)
80−
81− -- Handle the output layer, bouncing the derivatives back down.
82− -- We may not have a target for each example, so when we don't use 0 gradient.
83− go !xs RNil RINil
84− = (RNil, RINil, reverse (zipWith makeError xs targets))
85− where
86− makeError :: S (Last shapes) -> Maybe (S (Last shapes)) -> S (Last shapes)
87− makeError _ Nothing = 0
88− makeError y (Just t) = y - t
89−
90− updateRecInputs :: forall sublayers.
97+updateRecInputs :: Fractional (RecurrentInputs sublayers)
91− LearningParameters
98+ => LearningParameters
92− -> RecurrentInputs sublayers
99+ -> RecurrentInputs sublayers
93− -> RecurrentInputs sublayers
100+ -> RecurrentInputs sublayers
94− -> RecurrentInputs sublayers
101+ -> RecurrentInputs sublayers
95−
102+
96− updateRecInputs l@LearningParameters {..} (() :~~+> xs) (() :~~+> ys)
103+updateRecInputs lp (() :~~+> xs) (() :~~+> ys)
97− = () :~~+> updateRecInputs l xs ys
104+ = () :~~+> updateRecInputs lp xs ys
98−
105+
99− updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)
106+updateRecInputs lp (x :~@+> xs) (y :~@+> ys)
100− = (realToFrac (learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys
107+ = (realToFrac (1 - learningRate lp * learningRegulariser lp) * x - realToFrac (learningRate lp) * y) :~@+> updateRecInputs lp xs ys
101−
108+
102− updateRecInputs _ RINil RINil
109+updateRecInputs _ RINil RINil
103− = RINil
110+ = RINil
104−
105−scanlFrom :: forall x i o. RecurrentLayer x i o
106− => x -- ^ the layer
107− -> S (RecurrentShape x) -- ^ place to start
108− -> [S i] -- ^ list of inputs to scan through
109− -> [(RecTape x i o, S o)] -- ^ list of scan inputs and outputs
110−scanlFrom !layer !recShape (x:xs) =
111− let (tape, lerec, lepush) = runRecurrentForwards layer recShape x
112− in (tape, lepush) : scanlFrom layer lerec xs
113−scanlFrom _ _ [] = []
114−
115−myscanbackward :: forall x i o. RecurrentLayer x i o
116− => x -- ^ the layer
117− -> [(RecTape x i o, S o)] -- ^ the list of inputs and output to scan over
118− -> (S (RecurrentShape x), [(Gradient x, S i)]) -- ^ list of gradients to fold and inputs to backprop
119−myscanbackward layer =
120− goX 0
121− where
122− goX :: S (RecurrentShape x) -> [(RecTape x i o, S o)] -> (S (RecurrentShape x), [(Gradient x, S i)])
123− goX !lastback ((recTape, backgrad):xs) =
124− let (layergrad, recgrad, ingrad) = runRecurrentBackwards layer recTape lastback backgrad
125− (pushedback, ll) = goX recgrad xs
126− in (pushedback, (layergrad, ingrad) : ll)
127− goX !lastback [] = (lastback, [])
128−
129−-- | Just forwards propagation with no training.
130−runRecurrent :: RecurrentNetwork layers shapes
131− -> RecurrentInputs layers -> S (Head shapes)
132− -> (RecurrentInputs layers, S (Last shapes))
133−runRecurrent (layer :~~> n) (() :~~+> nr) !x
134− = let (_, ys) = runForwards layer x
135− (nr', o) = runRecurrent n nr ys
136− in (() :~~+> nr', o)
137−runRecurrent (layer :~@> n) (recin :~@+> nr) !x
138− = let (_, recin', y) = runRecurrentForwards layer recin x
139− (nr', o) = runRecurrent n nr y
140− in (recin' :~@+> nr', o)
141−runRecurrent RNil RINil !x
142− = (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+11−12
@@ -1,14 +1,12 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE UndecidableInstances #-}
8{-# LANGUAGE UndecidableInstances #-}
9
9
10−-- GHC 7.10 doesn't see recurrent run functions as total.
11−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
12module Grenade.Recurrent.Layers.BasicRecurrent (
10module Grenade.Recurrent.Layers.BasicRecurrent (
13 BasicRecurrent (..)
11 BasicRecurrent (..)
14 , randomBasicRecurrent
12 , randomBasicRecurrent
@@ -18,18 +16,19 @@ module Grenade.Recurrent.Layers.BasicRecurrent (
18
16
19import Control.Monad.Random ( MonadRandom, getRandom )
17import Control.Monad.Random ( MonadRandom, getRandom )
20
18
19+
21−import Data.Singletons.TypeLits
20+import Data.Kind (Type)
22
21
23import Numeric.LinearAlgebra.Static
22import Numeric.LinearAlgebra.Static
24
23
25import GHC.TypeLits
24import GHC.TypeLits
26
25
27import Grenade.Core
26import Grenade.Core
28−import Grenade.Recurrent.Core.Network
27+import Grenade.Recurrent.Core
29
28
30data BasicRecurrent :: Nat -- Input layer size
29data BasicRecurrent :: Nat -- Input layer size
31 -> Nat -- Output layer size
30 -> Nat -- Output layer size
32− -> * where
31+ -> Type where
33 BasicRecurrent :: ( KnownNat input
32 BasicRecurrent :: ( KnownNat input
34 , KnownNat output
33 , KnownNat output
35 , KnownNat matrixCols
34 , KnownNat matrixCols
@@ -42,7 +41,7 @@ data BasicRecurrent :: Nat -- Input layer size
42
41
43data BasicRecurrent' :: Nat -- Input layer size
42data BasicRecurrent' :: Nat -- Input layer size
44 -> Nat -- Output layer size
43 -> Nat -- Output layer size
45− -> * where
44+ -> Type where
46 BasicRecurrent' :: ( KnownNat input
45 BasicRecurrent' :: ( KnownNat input
47 , KnownNat output
46 , KnownNat output
48 , KnownNat matrixCols
47 , KnownNat matrixCols
@@ -57,18 +56,18 @@ instance Show (BasicRecurrent i o) where
57instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where
56instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where
58 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)
57 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)
59
58
60− runUpdate LearningParameters {..} (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =
59+ runUpdate lp (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =
61− let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient
60+ let newBiasMomentum = konst (learningMomentum lp) * oldBiasMomentum - konst (learningRate lp) * biasGradient
62 newBias = oldBias + newBiasMomentum
61 newBias = oldBias + newBiasMomentum
63− newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient
62+ newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient
64− regulariser = konst (learningRegulariser * learningRate) * oldActivations
63+ regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations
65 newActivations = oldActivations + newMomentum - regulariser
64 newActivations = oldActivations + newMomentum - regulariser
66 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum
65 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum
67
66
68 createRandom = randomBasicRecurrent
67 createRandom = randomBasicRecurrent
69
68
70instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where
69instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where
71− type RecurrentShape (BasicRecurrent i o) = 'D1 o
70+ type RecurrentShape (BasicRecurrent i o) = S ('D1 o)
72
71
73instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where
72instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where
74
73
src/Grenade/Recurrent/Layers/ConcatRecurrent.hsnew file+180
@@ -0,0 +1,180 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE FlexibleContexts #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE FlexibleInstances #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE StandaloneDeriving #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+{-|
14+Module : Grenade.Layers.Concat
15+Description : Concatenation layer
16+Copyright : (c) Huw Campbell, 2016-2017
17+License : BSD2
18+Stability : experimental
19+
20+This module provides the concatenation layer, which runs two chilld layers in parallel and combines their outputs.
21+-}
22+module Grenade.Recurrent.Layers.ConcatRecurrent (
23+ ConcatRecurrent (..)
24+ ) where
25+
26+import Data.Serialize
27+
28+import Data.Singletons
29+import GHC.TypeLits
30+
31+#if MIN_VERSION_base(4,9,0)
32+import Data.Kind (Type)
33+#endif
34+
35+import Grenade.Core
36+import Grenade.Recurrent.Core
37+
38+import Numeric.LinearAlgebra.Static ( (#), split, R )
39+
40+-- | A Concatentating Layer.
41+--
42+-- This layer shares it's input state between two sublayers, and concatenates their output.
43+--
44+-- With Networks able to be Layers, this allows for very expressive composition of complex Networks.
45+--
46+-- The Concat layer has a few instances, which allow one to flexibly "bash" together the outputs.
47+--
48+-- Two 1D vectors, can go to a 2D shape with 2 rows if their lengths are identical.
49+-- Any 2 1D vectors can also become a longer 1D Vector.
50+--
51+-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad
52+-- and Crop layers to ensure this is the case.
53+data ConcatRecurrent :: Shape -> Type -> Shape -> Type -> Type where
54+ ConcatRecLeft :: x -> y -> ConcatRecurrent m (Recurrent x) n (FeedForward y)
55+ ConcatRecRight :: x -> y -> ConcatRecurrent m (FeedForward x) n (Recurrent y)
56+ ConcatRecBoth :: x -> y -> ConcatRecurrent m (Recurrent x) n (Recurrent y)
57+
58+instance (Show x, Show y) => Show (ConcatRecurrent m (p x) n (q y)) where
59+ show (ConcatRecLeft x y) = "ConcatRecLeft\n" ++ show x ++ "\n" ++ show y
60+ show (ConcatRecRight x y) = "ConcatRecRight\n" ++ show x ++ "\n" ++ show y
61+ show (ConcatRecBoth x y) = "ConcatRecBoth\n" ++ show x ++ "\n" ++ show y
62+
63+instance (RecurrentUpdateLayer x, UpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where
64+ type Gradient (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = (Gradient x, Gradient y)
65+ runUpdate lr (ConcatRecLeft x y) (x', y')
66+ = ConcatRecLeft (runUpdate lr x x') (runUpdate lr y y')
67+ createRandom
68+ = ConcatRecLeft <$> createRandom <*> createRandom
69+
70+instance (UpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where
71+ type Gradient (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = (Gradient x, Gradient y)
72+ runUpdate lr (ConcatRecRight x y) (x', y')
73+ = ConcatRecRight (runUpdate lr x x') (runUpdate lr y y')
74+ createRandom
75+ = ConcatRecRight <$> createRandom <*> createRandom
76+
77+instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where
78+ type Gradient (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = (Gradient x, Gradient y)
79+ runUpdate lr (ConcatRecBoth x y) (x', y')
80+ = ConcatRecBoth (runUpdate lr x x') (runUpdate lr y y')
81+ createRandom
82+ = ConcatRecBoth <$> createRandom <*> createRandom
83+
84+instance (RecurrentUpdateLayer x, UpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where
85+ type RecurrentShape (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = RecurrentShape x
86+
87+instance (UpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where
88+ type RecurrentShape (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = RecurrentShape y
89+
90+instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where
91+ type RecurrentShape (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = RecurrentInputs '[ Recurrent x, Recurrent y ]
92+
93+instance ( SingI i
94+ , Layer x i ('D1 m)
95+ , RecurrentLayer y i ('D1 n)
96+ , KnownNat o
97+ , KnownNat m
98+ , KnownNat n
99+ , o ~ (m + n)
100+ , n ~ (o - m)
101+ , (m <=? o) ~ 'True
102+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) where
103+ type RecTape (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) = (Tape x i ('D1 m), RecTape y i ('D1 n))
104+
105+ runRecurrentForwards (ConcatRecRight x y) s input =
106+ let (xT, xOut :: S ('D1 m)) = runForwards x input
107+ (yT, side, yOut :: S ('D1 n)) = runRecurrentForwards y s input
108+ in case (xOut, yOut) of
109+ (S1D xOut', S1D yOut') ->
110+ ((xT, yT), side, S1D (xOut' # yOut'))
111+
112+ runRecurrentBackwards (ConcatRecRight x y) (xTape, yTape) s (S1D o) =
113+ let (ox :: R m , oy :: R n) = split o
114+ (x', xB :: S i) = runBackwards x xTape (S1D ox)
115+ (y', side, yB :: S i) = runRecurrentBackwards y yTape s (S1D oy)
116+ in ((x', y'), side, xB + yB)
117+
118+instance ( SingI i
119+ , RecurrentLayer x i ('D1 m)
120+ , Layer y i ('D1 n)
121+ , KnownNat o
122+ , KnownNat m
123+ , KnownNat n
124+ , o ~ (m + n)
125+ , n ~ (o - m)
126+ , (m <=? o) ~ 'True
127+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) where
128+ type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) = (RecTape x i ('D1 m), Tape y i ('D1 n))
129+
130+ runRecurrentForwards (ConcatRecLeft x y) s input =
131+ let (xT, side, xOut :: S ('D1 m)) = runRecurrentForwards x s input
132+ (yT, yOut :: S ('D1 n)) = runForwards y input
133+ in case (xOut, yOut) of
134+ (S1D xOut', S1D yOut') ->
135+ ((xT, yT), side, S1D (xOut' # yOut'))
136+
137+ runRecurrentBackwards (ConcatRecLeft x y) (xTape, yTape) s (S1D o) =
138+ let (ox :: R m , oy :: R n) = split o
139+ (x', side, xB :: S i) = runRecurrentBackwards x xTape s (S1D ox)
140+ (y', yB :: S i) = runBackwards y yTape (S1D oy)
141+ in ((x', y'), side, xB + yB)
142+
143+instance ( SingI i
144+ , RecurrentLayer x i ('D1 m)
145+ , RecurrentLayer y i ('D1 n)
146+ , Fractional (RecurrentShape x)
147+ , Fractional (RecurrentShape y)
148+ , KnownNat o
149+ , KnownNat m
150+ , KnownNat n
151+ , o ~ (m + n)
152+ , n ~ (o - m)
153+ , (m <=? o) ~ 'True
154+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) where
155+ type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) = (RecTape x i ('D1 m), RecTape y i ('D1 n))
156+
157+ runRecurrentForwards (ConcatRecBoth x y) (sx :~@+> (sy :~@+> RINil)) input =
158+ let (xT, s'x, xOut :: S ('D1 m)) = runRecurrentForwards x sx input
159+ (yT, s'y, yOut :: S ('D1 n)) = runRecurrentForwards y sy input
160+ in case (xOut, yOut) of
161+ (S1D xOut', S1D yOut') ->
162+ ((xT, yT), (s'x :~@+> (s'y :~@+> RINil)), S1D (xOut' # yOut'))
163+
164+ runRecurrentBackwards (ConcatRecBoth x y) (xTape, yTape) (sx :~@+> (sy :~@+> RINil)) (S1D o) =
165+ let (ox :: R m , oy :: R n) = split o
166+ (x', s'x, xB :: S i) = runRecurrentBackwards x xTape sx (S1D ox)
167+ (y', s'y, yB :: S i) = runRecurrentBackwards y yTape sy (S1D oy)
168+ in ((x', y'), (s'x :~@+> (s'y :~@+> RINil)), xB + yB)
169+
170+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (FeedForward a) sb (Recurrent b)) where
171+ put (ConcatRecRight a b) = put a *> put b
172+ get = ConcatRecRight <$> get <*> get
173+
174+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (Recurrent b)) where
175+ put (ConcatRecBoth a b) = put a *> put b
176+ get = ConcatRecBoth <$> get <*> get
177+
178+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (FeedForward b)) where
179+ put (ConcatRecLeft a b) = put a *> put b
180+ get = ConcatRecLeft <$> get <*> get
src/Grenade/Recurrent/Layers/LSTM.hs+58−84
@@ -1,8 +1,8 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
@@ -10,8 +10,6 @@
10{-# LANGUAGE ViewPatterns #-}
10{-# LANGUAGE ViewPatterns #-}
11{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12
12
13−-- GHC 7.10 doesn't see recurrent run functions as total.
14−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
15module Grenade.Recurrent.Layers.LSTM (
13module Grenade.Recurrent.Layers.LSTM (
16 LSTM (..)
14 LSTM (..)
17 , LSTMWeights (..)
15 , LSTMWeights (..)
@@ -23,30 +21,30 @@ import Control.Monad.Random ( MonadRandom, getRandom )
23-- import Data.List ( foldl1' )
21-- import Data.List ( foldl1' )
24import Data.Proxy
22import Data.Proxy
25import Data.Serialize
23import Data.Serialize
26−import Data.Singletons.TypeLits
24+import Data.Kind (Type)
27
25
28import qualified Numeric.LinearAlgebra as LA
26import qualified Numeric.LinearAlgebra as LA
29import Numeric.LinearAlgebra.Static
27import Numeric.LinearAlgebra.Static
30
28
31import Grenade.Core
29import Grenade.Core
32−
30+import Grenade.Recurrent.Core
33import Grenade.Layers.Internal.Update
31import Grenade.Layers.Internal.Update
32+import GHC.TypeLits
34
33
35−import Grenade.Recurrent.Core.Network
36
34
37-- | Long Short Term Memory Recurrent unit
35-- | Long Short Term Memory Recurrent unit
38--
36--
39-- This is a Peephole formulation, so the recurrent shape is
37-- This is a Peephole formulation, so the recurrent shape is
40-- just the cell state, the previous output is not held or used
38-- just the cell state, the previous output is not held or used
41-- at all.
39-- at all.
42−data LSTM :: Nat -> Nat -> * where
40+data LSTM :: Nat -> Nat -> Type where
43 LSTM :: ( KnownNat input
41 LSTM :: ( KnownNat input
44 , KnownNat output
42 , KnownNat output
45 ) => !(LSTMWeights input output) -- Weights
43 ) => !(LSTMWeights input output) -- Weights
46 -> !(LSTMWeights input output) -- Momentums
44 -> !(LSTMWeights input output) -- Momentums
47 -> LSTM input output
45 -> LSTM input output
48
46
49−data LSTMWeights :: Nat -> Nat -> * where
47+data LSTMWeights :: Nat -> Nat -> Type where
50 LSTMWeights :: ( KnownNat input
48 LSTMWeights :: ( KnownNat input
51 , KnownNat output
49 , KnownNat output
52 ) => {
50 ) => {
@@ -73,7 +71,7 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where
73
71
74 -- Run the update function for each group matrix/vector of weights, momentums and gradients.
72 -- Run the update function for each group matrix/vector of weights, momentums and gradients.
75 -- Hmm, maybe the function should be used instead of passing in the learning parameters.
73 -- Hmm, maybe the function should be used instead of passing in the learning parameters.
76− runUpdate LearningParameters {..} (LSTM w m) g =
74+ runUpdate lp (LSTM w m) g =
77 let (wf, wf') = u lstmWf w m g
75 let (wf, wf') = u lstmWf w m g
78 (uf, uf') = u lstmUf w m g
76 (uf, uf') = u lstmUf w m g
79 (bf, bf') = v lstmBf w m g
77 (bf, bf') = v lstmBf w m g
@@ -90,11 +88,11 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where
90 -- Utility function for updating with the momentum, gradients, and weights.
88 -- Utility function for updating with the momentum, gradients, and weights.
91 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))
89 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))
92 u e (e -> weights) (e -> momentum) (e -> gradient) =
90 u e (e -> weights) (e -> momentum) (e -> gradient) =
93− decendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum
91+ descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum
94
92
95 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))
93 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))
96 v e (e -> weights) (e -> momentum) (e -> gradient) =
94 v e (e -> weights) (e -> momentum) (e -> gradient) =
97− decendVector learningRate learningMomentum learningRegulariser weights gradient momentum
95+ descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum
98
96
99 -- There's a lot of updates here, so to try and minimise the number of data copies
97 -- There's a lot of updates here, so to try and minimise the number of data copies
100 -- we'll create a mutable bucket for each.
98 -- we'll create a mutable bucket for each.
@@ -126,27 +124,33 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where
126instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where
124instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where
127 -- The recurrent shape is the same size as the output.
125 -- The recurrent shape is the same size as the output.
128 -- It's actually the cell state however, as this is a peephole variety LSTM.
126 -- It's actually the cell state however, as this is a peephole variety LSTM.
129− type RecurrentShape (LSTM i o) = 'D1 o
127+ type RecurrentShape (LSTM i o) = S ('D1 o)
130
128
131instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where
129instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where
132
130
131+ -- The tape stores essentially every variable we calculate,
132+ -- so we don't have to run any forwards component again.
133− type RecTape (LSTM i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))
133+ type RecTape (LSTM i o) ('D1 i) ('D1 o) = (R o, R i, R o, R o, R o, R o, R o, R o, R o, R o, R o)
134 -- Forward propagation for the LSTM layer.
134 -- Forward propagation for the LSTM layer.
135 -- The size of the cell state is also the size of the output.
135 -- The size of the cell state is also the size of the output.
136− runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =
136+ runRecurrentForwards (LSTM lw _) (S1D cell) (S1D input) =
137 let -- Forget state vector
137 let -- Forget state vector
138− 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
139 -- Input state vector
140 -- Input state vector
140− 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
141 -- Output state vector
143 -- Output state vector
142− 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
143 -- Cell input state vector
146 -- Cell input state vector
144− c_x = tanh $ lstmBc + lstmWc #> input
147+ c_s = lstmBc lw + lstmWc lw #> input
148+ c_x = tanh c_s
145 -- Cell state
149 -- Cell state
146 c_t = f_t * cell + i_t * c_x
150 c_t = f_t * cell + i_t * c_x
147 -- Output (it's sometimes recommended to use tanh c_t)
151 -- Output (it's sometimes recommended to use tanh c_t)
148 h_t = o_t * c_t
152 h_t = o_t * c_t
149− 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)
150
154
151 -- Run a backpropogation step for an LSTM layer.
155 -- Run a backpropogation step for an LSTM layer.
152 -- We're doing all the derivatives by hand here, so one should
156 -- We're doing all the derivatives by hand here, so one should
@@ -154,29 +158,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w
154 --
158 --
155 -- There's a test version using the AD library without hmatrix in the test
159 -- There's a test version using the AD library without hmatrix in the test
156 -- suite. These should match always.
160 -- suite. These should match always.
157− runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (S1D cell, S1D input) (S1D cellGrad) (S1D h_t') =
161+ runRecurrentBackwards (LSTM lw _) (cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t) (S1D cellGrad) (S1D h_t') =
158− -- We're not keeping the Wengert tape during the forward pass,
159− -- so we're duplicating some work here.
160− --
161− -- If I was being generous, I'd call it checkpointing.
162− --
163− -- Maybe think about better ways to store some intermediate states.
164− let -- Forget state vector
165− f_s = lstmBf + lstmWf #> input + lstmUf #> cell
166− f_t = sigmoid f_s
167− -- Input state vector
168− i_s = lstmBi + lstmWi #> input + lstmUi #> cell
169− i_t = sigmoid i_s
170− -- Output state vector
171− o_s = lstmBo + lstmWo #> input + lstmUo #> cell
172− o_t = sigmoid o_s
173− -- Cell input state vector
174− c_s = lstmBc + lstmWc #> input
175− c_x = tanh c_s
176− -- Cell state
177− c_t = f_t * cell + i_t * c_x
178−
179− -- Reverse Mode AD Derivitives
162+ let -- Reverse Mode AD Derivitives
180 c_t' = h_t' * o_t + cellGrad
163 c_t' = h_t' * o_t + cellGrad
181
164
182 f_t' = c_t' * cell
165 f_t' = c_t' * cell
@@ -192,8 +175,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w
192 c_s' = tanh' c_s * c_x'
175 c_s' = tanh' c_s * c_x'
193
176
194 -- The derivatives to pass sideways (recurrent) and downwards
177 -- The derivatives to pass sideways (recurrent) and downwards
195− cell' = tr lstmUf #> f_s' + tr lstmUo #> o_s' + tr lstmUi #> i_s' + c_t' * f_t
178+ cell' = tr (lstmUf lw) #> f_s' + tr (lstmUo lw) #> o_s' + tr (lstmUi lw) #> i_s' + c_t' * f_t
196− input' = tr lstmWf #> f_s' + tr lstmWo #> o_s' + tr lstmWi #> i_s' + tr lstmWc #> c_s'
179+ input' = tr (lstmWf lw) #> f_s' + tr (lstmWo lw) #> o_s' + tr (lstmWi lw) #> i_s' + tr (lstmWc lw) #> c_s'
197
180
198 -- Calculate the gradient Matricies for the input
181 -- Calculate the gradient Matricies for the input
199 lstmWf' = f_s' `outer` input
182 lstmWf' = f_s' `outer` input
@@ -238,7 +221,8 @@ randomLSTM = do
238
221
239-- | Maths
222-- | Maths
240--
223--
241−-- TODO: move to not here
224+-- TODO: Move to not here
225+-- Optimise backwards derivative
242sigmoid :: Floating a => a -> a
226sigmoid :: Floating a => a -> a
243sigmoid x = 1 / (1 + exp (-x))
227sigmoid x = 1 / (1 + exp (-x))
244
228
@@ -251,44 +235,34 @@ tanh' :: (Floating a) => a -> a
251tanh' t = 1 - s ^ (2 :: Int) where s = tanh t
235tanh' t = 1 - s ^ (2 :: Int) where s = tanh t
252
236
253instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where
237instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where
254− put (LSTM LSTMWeights {..} _) = do
238+ put (LSTM lw _) = do
255− u lstmWf
239+ u (lstmWf lw)
256− u lstmUf
240+ u (lstmUf lw)
257− v lstmBf
241+ v (lstmBf lw)
258− u lstmWi
242+ u (lstmWi lw)
259− u lstmUi
243+ u (lstmUi lw)
260− v lstmBi
244+ v (lstmBi lw)
261− u lstmWo
245+ u (lstmWo lw)
262− u lstmUo
246+ u (lstmUo lw)
263− v lstmBo
247+ v (lstmBo lw)
264− u lstmWc
248+ u (lstmWc lw)
265− v lstmBc
249+ v (lstmBc lw)
266− where
250+ where
267− u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)
251+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)
268− u = putListOf put . LA.toList . LA.flatten . extract
252+ u = putListOf put . LA.toList . LA.flatten . extract
269− v :: forall a. (KnownNat a) => Putter (R a)
253+ v :: forall a. (KnownNat a) => Putter (R a)
270− v = putListOf put . LA.toList . extract
254+ v = putListOf put . LA.toList . extract
271
255
272 get = do
256 get = do
273− lstmWf <- u
257+ w <- LSTMWeights <$> u <*> u <*> v <*> u <*> u <*> v <*> u <*> u <*> v <*> u <*> v
274− lstmUf <- u
275− lstmBf <- v
276− lstmWi <- u
277− lstmUi <- u
278− lstmBi <- v
279− lstmWo <- u
280− lstmUo <- u
281− lstmBo <- v
282− lstmWc <- u
283− lstmBc <- v
284− return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)
258+ return $ LSTM w (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)
285− where
259+ where
286− u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)
260+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)
287− u = let f = fromIntegral $ natVal (Proxy :: Proxy a)
261+ u = let f = fromIntegral $ natVal (Proxy :: Proxy a)
288− in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get
262+ in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get
289− v :: forall a. (KnownNat a) => Get (R a)
263+ v :: forall a. (KnownNat a) => Get (R a)
290− v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get
264+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get
291−
265+
292− w0 = konst 0
266+ w0 = konst 0
293− u0 = konst 0
267+ u0 = konst 0
294− v0 = konst 0
268+ v0 = konst 0
src/Grenade/Utils/OneHot.hs+6−5
@@ -22,7 +22,6 @@ import Data.Map ( Map )
22import qualified Data.Map as M
22import qualified Data.Map as M
23
23
24import Data.Proxy
24import Data.Proxy
25−import Data.Singletons.TypeLits
26
25
27import Data.Vector ( Vector )
26import Data.Vector ( Vector )
28import qualified Data.Vector as V
27import qualified Data.Vector as V
@@ -31,6 +30,7 @@ import qualified Data.Vector.Storable as VS
31import Numeric.LinearAlgebra ( maxIndex )
30import Numeric.LinearAlgebra ( maxIndex )
32import Numeric.LinearAlgebra.Devel
31import Numeric.LinearAlgebra.Devel
33import Numeric.LinearAlgebra.Static
32import Numeric.LinearAlgebra.Static
33+import GHC.TypeLits
34
34
35import Grenade.Core.Shape
35import Grenade.Core.Shape
36
36
@@ -52,15 +52,16 @@ oneHot hot =
52
52
53-- | Create a one hot map from any enumerable.
53-- | Create a one hot map from any enumerable.
54-- Returns a map, and the ordered list for the reverse transformation
54-- Returns a map, and the ordered list for the reverse transformation
55−hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Maybe (Map a Int, Vector a)
55+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Either String (Map a Int, Vector a)
56hotMap n as =
56hotMap n as =
57 let len = fromIntegral $ natVal n
57 let len = fromIntegral $ natVal n
58 uniq = [ c | (c:_) <- group $ sort as]
58 uniq = [ c | (c:_) <- group $ sort as]
59 hotl = length uniq
59 hotl = length uniq
60− in if hotl <= len
60+ in if hotl == len
61 then
61 then
62− Just (M.fromList $ zip uniq [0..], V.fromList uniq)
62+ Right (M.fromList $ zip uniq [0..], V.fromList uniq)
63− else Nothing
63+ else
64+ Left ("Couldn't create hotMap of size " ++ show len ++ " from vector with " ++ show hotl ++ " unique characters")
64
65
65-- | From a map and value, create a 1D Shape
66-- | From a map and value, create a 1D Shape
66-- with one index hot (1) with the rest 0.
67-- with one index hot (1) with the rest 0.
stack.yamlnew file+78
@@ -0,0 +1,78 @@
1+# This file was automatically generated by 'stack init'
2+#
3+# Some commonly used options have been documented as comments in this file.
4+# For advanced use and comprehensive documentation of the format, please see:
5+# https://docs.haskellstack.org/en/stable/yaml_configuration/
6+
7+# A warning or info to be displayed to the user on config load.
8+# user-message: |
9+
10+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
11+# A snapshot resolver dictates the compiler version and the set of packages
12+# to be used for project dependencies. For example:
13+#
14+# resolver: lts-3.5
15+# resolver: nightly-2015-09-21
16+# resolver: ghc-7.10.2
17+#
18+# The location of a snapshot can be provided as a file or url. Stack assumes
19+# a snapshot provided as a file might change, whereas a url resource does not.
20+#
21+# resolver: ./custom-snapshot.yaml
22+# resolver: https://example.com/snapshots/2018-01-01.yaml
23+resolver: lts-20.18
24+
25+# User packages to be built.
26+# Various formats can be used as shown in the example below.
27+#
28+# packages:
29+# - some-directory
30+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
31+# subdirs:
32+# - auto-update
33+# - wai
34+packages:
35+ - .
36+ - examples
37+
38+# Dependency packages to be pulled from upstream that are not in the resolver.
39+# These entries can reference officially published versions as well as
40+# forks / in-progress versions pinned to a git hash. For example:
41+#
42+# extra-deps:
43+# - acme-missiles-0.3
44+# - git: https://github.com/commercialhaskell/stack.git
45+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
46+#
47+extra-deps:
48+ - typelits-witnesses-0.3.0.3
49+
50+# Override default flag values for local packages and extra-deps
51+# flags: {}
52+
53+# Extra package databases containing global packages
54+# extra-package-dbs: []
55+
56+# Control whether we use the GHC we find on the path
57+# system-ghc: true
58+#
59+# Require a specific version of stack, using version ranges
60+# require-stack-version: -any # Default
61+# require-stack-version: ">=2.1"
62+#
63+# Override the architecture used by stack, especially useful on Windows
64+# arch: i386
65+# arch: x86_64
66+#
67+# Extra directories used by stack for building
68+# extra-include-dirs: [/path/to/dir]
69+# extra-lib-dirs: [/path/to/dir]
70+#
71+# Allow a newer minor version of GHC than the snapshot specifies
72+# compiler-check: newer-minor
73+
74+nix:
75+ enable: true
76+ packages:
77+ - blas
78+ - lapack
stack.yaml.locknew file+19
@@ -0,0 +1,19 @@
1+# This file was autogenerated by Stack.
2+# You should not edit this file by hand.
3+# For more information, please see the documentation at:
4+# https://docs.haskellstack.org/en/stable/lock_files
5+
6+packages:
7+- completed:
8+ hackage: typelits-witnesses-0.3.0.3@sha256:2d9df4ac6ff3077bfd2bf659e4b495e157723ac5b45c519762853f55df5c16db,2738
9+ pantry-tree:
10+ sha256: 6a42a462f98e94933b6e9721acd912c6c6b6a4743635efd15cc5871908c816a0
11+ size: 469
12+ original:
13+ hackage: typelits-witnesses-0.3.0.3
14+snapshots:
15+- completed:
16+ sha256: 9fa4bece7acfac1fc7930c5d6e24606004b09e80aa0e52e9f68b148201008db9
17+ size: 649606
18+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/18.yaml
19+ original: lts-20.18
test/Test/Grenade/Layers/Convolution.hs+29−24
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
@@ -15,15 +16,21 @@ import Data.Singletons ()
15import GHC.TypeLits
16import GHC.TypeLits
16import GHC.TypeLits.Witnesses
17import GHC.TypeLits.Witnesses
17
18
19+#if MIN_VERSION_base(4,9,0)
20+import Data.Kind (Type)
21+#endif
22+
18import Grenade.Core
23import Grenade.Core
19import Grenade.Layers.Convolution
24import Grenade.Layers.Convolution
20
25
21−import Disorder.Jack
26+import Hedgehog
27+import qualified Hedgehog.Gen as Gen
22
28
23−import Test.Jack.Hmatrix
29+import Test.Hedgehog.Hmatrix
24−import Test.Jack.TypeLits
30+import Test.Hedgehog.TypeLits
31+import Test.Hedgehog.Compat
25
32
26−data OpaqueConvolution :: * where
33+data OpaqueConvolution :: Type where
27 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution
34 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution
28
35
29instance Show OpaqueConvolution where
36instance Show OpaqueConvolution where
@@ -37,10 +44,10 @@ genConvolution :: ( KnownNat channels
37 , KnownNat strideColumns
44 , KnownNat strideColumns
38 , KnownNat kernelFlattened
45 , KnownNat kernelFlattened
39 , kernelFlattened ~ (kernelRows * kernelColumns * channels)
46 , kernelFlattened ~ (kernelRows * kernelColumns * channels)
40− ) => Jack (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)
47+ ) => Gen (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)
41genConvolution = Convolution <$> uniformSample <*> uniformSample
48genConvolution = Convolution <$> uniformSample <*> uniformSample
42
49
43−genOpaqueOpaqueConvolution :: Jack OpaqueConvolution
50+genOpaqueOpaqueConvolution :: Gen OpaqueConvolution
44genOpaqueOpaqueConvolution = do
51genOpaqueOpaqueConvolution = do
45 channels <- genNat
52 channels <- genNat
46 filters <- genNat
53 filters <- genNat
@@ -56,17 +63,17 @@ genOpaqueOpaqueConvolution = do
56 p2 = natDict pkc
63 p2 = natDict pkc
57 p3 = natDict pch
64 p3 = natDict pch
58 in case p1 %* p2 %* p3 of
65 in case p1 %* p2 %* p3 of
59− Dict -> OpaqueConvolution <$> (genConvolution :: Jack (Convolution ch fl kr kc sr sc))
66+ Dict -> OpaqueConvolution <$> (genConvolution :: Gen (Convolution ch fl kr kc sr sc))
67+
68+prop_conv_net_witness = property $
69+ blindForAll genOpaqueOpaqueConvolution >>= \onet ->
70+ case onet of
71+ (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> success
60
72
61−prop_conv_net_witness =
62− gamble genOpaqueOpaqueConvolution $ \onet ->
63− (case onet of
64− (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> True
65− ) :: Bool
66
73
67−prop_conv_net =
74+prop_conv_net = property $
68− gamble genOpaqueOpaqueConvolution $ \onet ->
75+ blindForAll genOpaqueOpaqueConvolution >>= \onet ->
69− (case onet of
76+ case onet of
70 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->
77 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->
71 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]
78 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]
72 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
79 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
@@ -74,15 +81,15 @@ prop_conv_net =
74 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)
81 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)
75 sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)
82 sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)
76
83
77− in gamble (elements (ok sr kr)) $ \er ->
84+ in forAll (Gen.element (ok sr kr)) >>= \er ->
78− gamble (elements (ok sc kc)) $ \ec ->
85+ forAll (Gen.element (ok sc kc)) >>= \ec ->
79 let rr = ((er - kr) `div` sr) + 1
86 let rr = ((er - kr) `div` sr) + 1
80 rc = ((ec - kc) `div` sc) + 1
87 rc = ((ec - kc) `div` sc) + 1
81 Just er' = someNatVal er
88 Just er' = someNatVal er
82 Just ec' = someNatVal ec
89 Just ec' = someNatVal ec
83 Just rr' = someNatVal rr
90 Just rr' = someNatVal rr
84 Just rc' = someNatVal rc
91 Just rc' = someNatVal rc
85− in (case (er', ec', rr', rc') of
92+ in case (er', ec', rr', rc') of
86 ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->
93 ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->
87 case ( natDict pinr %* natDict (Proxy :: Proxy channels)
94 case ( natDict pinr %* natDict (Proxy :: Proxy channels)
88 , natDict pour %* natDict (Proxy :: Proxy filters)
95 , natDict pour %* natDict (Proxy :: Proxy filters)
@@ -90,14 +97,12 @@ prop_conv_net =
90 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
97 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
91 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
98 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
92 (Dict, Dict, Dict, Dict) ->
99 (Dict, Dict, Dict, Dict) ->
93− gamble (S3D <$> uniformSample) $ \(input :: S ('D3 inRows inCols channels)) ->
100+ blindForAll (S3D <$> uniformSample) >>= \(input :: S ('D3 inRows inCols channels)) ->
94 let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input
101 let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input
95 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))
102 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))
96 = runBackwards convLayer tape output
103 = runBackwards convLayer tape output
97− in backed `seq` True
104+ in backed `seq` success
98− ) :: Property
105+
99− ) :: Property
100
106
101−return []
102tests :: IO Bool
107tests :: IO Bool
103−tests = $quickCheckAll
108+tests = checkParallel $$(discover)
test/Test/Grenade/Layers/FullyConnected.hs+21−17
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE TemplateHaskell #-}
3{-# LANGUAGE TemplateHaskell #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DataKinds #-}
@@ -12,24 +13,28 @@ import Data.Singletons ()
12
13
13import GHC.TypeLits
14import GHC.TypeLits
14
15
16+#if MIN_VERSION_base(4,9,0)
17+import Data.Kind (Type)
18+#endif
19+
15import Grenade.Core
20import Grenade.Core
16import Grenade.Layers.FullyConnected
21import Grenade.Layers.FullyConnected
17
22
18−import Disorder.Jack
23+import Hedgehog
19−
20−import Test.Jack.Hmatrix
21
24
25+import Test.Hedgehog.Compat
26+import Test.Hedgehog.Hmatrix
22
27
23−data OpaqueFullyConnected :: * where
28+data OpaqueFullyConnected :: Type where
24 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected
29 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected
25
30
26instance Show OpaqueFullyConnected where
31instance Show OpaqueFullyConnected where
27 show (OpaqueFullyConnected n) = show n
32 show (OpaqueFullyConnected n) = show n
28
33
29−genOpaqueFullyConnected :: Jack OpaqueFullyConnected
34+genOpaqueFullyConnected :: Gen OpaqueFullyConnected
30genOpaqueFullyConnected = do
35genOpaqueFullyConnected = do
31− input :: Integer <- choose (2, 100)
36+ input :: Integer <- choose 2 100
32− output :: Integer <- choose (1, 100)
37+ output :: Integer <- choose 1 100
33 let Just input' = someNatVal input
38 let Just input' = someNatVal input
34 let Just output' = someNatVal output
39 let Just output' = someNatVal output
35 case (input', output') of
40 case (input', output') of
@@ -41,14 +46,13 @@ genOpaqueFullyConnected = do
41 return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')
46 return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')
42
47
43prop_fully_connected_forwards :: Property
48prop_fully_connected_forwards :: Property
44−prop_fully_connected_forwards =
49+prop_fully_connected_forwards = property $ do
45− gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->
50+ OpaqueFullyConnected (fclayer :: FullyConnected i o) <- blindForAll genOpaqueFullyConnected
46− gamble (S1D <$> randomVector) $ \(input :: S ('D1 i)) ->
51+ input :: S ('D1 i) <- blindForAll (S1D <$> randomVector)
47− let (tape, output :: S ('D1 o)) = runForwards fclayer input
52+ let (tape, output :: S ('D1 o)) = runForwards fclayer input
48− backed :: (Gradient (FullyConnected i o), S ('D1 i))
53+ backed :: (Gradient (FullyConnected i o), S ('D1 i))
49− = runBackwards fclayer tape output
54+ = runBackwards fclayer tape output
50− in backed `seq` True
55+ backed `seq` success
51−
56+
52−return []
53tests :: IO Bool
57tests :: IO Bool
54−tests = $quickCheckAll
58+tests = checkParallel $$(discover)
test/Test/Grenade/Layers/Internal/Convolution.hs+34−29
@@ -12,41 +12,46 @@ import Grenade.Layers.Internal.Convolution
12
12
13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
14
14
15−import Disorder.Jack
15+import Hedgehog
16+import qualified Hedgehog.Gen as Gen
17+import qualified Hedgehog.Range as Range
16
18
17import qualified Test.Grenade.Layers.Internal.Reference as Reference
19import qualified Test.Grenade.Layers.Internal.Reference as Reference
20+import Test.Hedgehog.Compat
18
21
19prop_im2col_col2im_symmetrical_with_kernel_stride =
22prop_im2col_col2im_symmetrical_with_kernel_stride =
20 let factors n = [x | x <- [1..n], n `mod` x == 0]
23 let factors n = [x | x <- [1..n], n `mod` x == 0]
21− in gamble (choose (2, 100)) $ \height ->
24+ in property $ do
22− gamble (choose (2, 100)) $ \width ->
25+ height <- forAll $ choose 2 100
23− gamble ((height `div`) <$> elements (factors height)) $ \kernel_h ->
26+ width <- forAll $ choose 2 100
24− gamble ((width `div`) <$> elements (factors width)) $ \kernel_w ->
27+ kernel_h <- forAll $ (height `div`) <$> Gen.element (factors height)
25− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
28+ kernel_w <- forAll $ (width `div`) <$> Gen.element (factors width)
26− let input' = (height >< width) input
29+ input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)
30+
27− stride_h = kernel_h
31+ let stride_h = kernel_h
28− stride_w = kernel_w
32+ let stride_w = kernel_w
29− out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input'
33+ let out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input
30− in input' === out
34+ input === out
31
35
32prop_im2col_col2im_behaves_as_reference =
36prop_im2col_col2im_behaves_as_reference =
33 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
37 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
38+ in property $ do
34− in gamble (choose (2, 100)) $ \height ->
39+ height <- forAll (choose 2 100)
35− gamble (choose (2, 100)) $ \width ->
40+ width <- forAll (choose 2 100)
36− gamble (choose (2, height - 1)) $ \kernel_h ->
41+ kernel_h <- forAll (choose 2 (height - 1))
37− gamble (choose (2, width - 1)) $ \kernel_w ->
42+ kernel_w <- forAll (choose 2 (width - 1))
38− gamble (elements (ok height kernel_h)) $ \stride_h ->
43+ stride_h <- forAll (Gen.element (ok height kernel_h))
39− gamble (elements (ok width kernel_w)) $ \stride_w ->
44+ stride_w <- forAll (Gen.element (ok width kernel_w))
40− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
45+ input <- forAll ((height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100))
41− let input' = (height >< width) input
46+
42− outFast = im2col kernel_h kernel_w stride_h stride_w input'
47+ let outFast = im2col kernel_h kernel_w stride_h stride_w input
43− retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast
48+ let retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast
44−
49+
45− outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input'
50+ let outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input
46− retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference
51+ let retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference
52+
47− in outFast === outReference .&&. retFast === retReference
53+ outFast === outReference
48−
54+ retFast === retReference
49−
55+
50−return []
51tests :: IO Bool
56tests :: IO Bool
52−tests = $quickCheckAll
57+tests = checkParallel $$(discover)
test/Test/Grenade/Layers/Internal/Pooling.hs+24−18
@@ -12,28 +12,34 @@ import Grenade.Layers.Internal.Pooling
12
12
13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
13import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))
14
14
15−import Disorder.Jack
15+import Hedgehog
16+import qualified Hedgehog.Gen as Gen
17+import qualified Hedgehog.Range as Range
16
18
17import qualified Test.Grenade.Layers.Internal.Reference as Reference
19import qualified Test.Grenade.Layers.Internal.Reference as Reference
20+import Test.Hedgehog.Compat
18
21
19prop_poolForwards_poolBackwards_behaves_as_reference =
22prop_poolForwards_poolBackwards_behaves_as_reference =
20 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
23 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
21 output extent kernel stride = (extent - kernel) `div` stride + 1
24 output extent kernel stride = (extent - kernel) `div` stride + 1
22− in gamble (choose (2, 100)) $ \height ->
25+ in property $ do
26+ height <- forAll $ choose 2 100
23− gamble (choose (2, 100)) $ \width ->
27+ width <- forAll $ choose 2 100
24− gamble (choose (1, height - 1)) $ \kernel_h ->
28+ kernel_h <- forAll $ choose 1 (height - 1)
25− gamble (choose (1, width - 1)) $ \kernel_w ->
29+ kernel_w <- forAll $ choose 1 (width - 1)
26− gamble (elements (ok height kernel_h)) $ \stride_h ->
30+ stride_h <- forAll $ Gen.element (ok height kernel_h)
27− gamble (elements (ok width kernel_w)) $ \stride_w ->
31+ stride_w <- forAll $ Gen.element (ok width kernel_w)
28− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->
32+ input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)
29− let input' = (height >< width) input
33+
30− outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'
34+ let outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input
31− retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast
35+ let retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input outFast
32−
36+
33− outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'
37+ let outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input
34− retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference
38+ let retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input outReference
39+
35− in outFast === outReference .&&. retFast === retReference
40+ outFast === outReference
36−
41+ retFast === retReference
37−return []
42+
43+
38tests :: IO Bool
44tests :: IO Bool
39−tests = $quickCheckAll
45+tests = checkParallel $$(discover)
test/Test/Grenade/Layers/Nonlinear.hs+13−31
@@ -11,62 +11,44 @@ module Test.Grenade.Layers.Nonlinear where
11import Data.Singletons
11import Data.Singletons
12
12
13import Grenade
13import Grenade
14−import GHC.TypeLits
15
14
16−import Disorder.Jack
15+import Hedgehog
17
16
18−import Test.Jack.Hmatrix
17+import Test.Hedgehog.Compat
18+import Test.Hedgehog.Hmatrix
19−import Test.Jack.TypeLits
19+import Test.Hedgehog.TypeLits
20
20
21import Numeric.LinearAlgebra.Static ( norm_Inf )
21import Numeric.LinearAlgebra.Static ( norm_Inf )
22
22
23prop_sigmoid_grad :: Property
23prop_sigmoid_grad :: Property
24−prop_sigmoid_grad =
24+prop_sigmoid_grad = property $
25− gambleDisplay (const "Shape") genShape $ \case
25+ forAllWith rss genShape >>= \case
26 (SomeSing (r :: Sing s)) ->
26 (SomeSing (r :: Sing s)) ->
27 withSingI r $
27 withSingI r $
28− gamble genOfShape $ \(ds :: S s) ->
28+ blindForAll genOfShape >>= \(ds :: S s) ->
29 let (tape, f :: S s) = runForwards Logit ds
29 let (tape, f :: S s) = runForwards Logit ds
30 ((), ret :: S s) = runBackwards Logit tape (1 :: S s)
30 ((), ret :: S s) = runBackwards Logit tape (1 :: S s)
31 (_, numer :: S s) = runForwards Logit (ds + 0.0001)
31 (_, numer :: S s) = runForwards Logit (ds + 0.0001)
32 numericalGradient = (numer - f) * 10000
32 numericalGradient = (numer - f) * 10000
33− in counterexample (show numericalGradient ++ show ret)
34− ((case numericalGradient - ret of
33+ in assert ((case numericalGradient - ret of
35 (S1D x) -> norm_Inf x < 0.0001
34 (S1D x) -> norm_Inf x < 0.0001
36 (S2D x) -> norm_Inf x < 0.0001
35 (S2D x) -> norm_Inf x < 0.0001
37 (S3D x) -> norm_Inf x < 0.0001) :: Bool)
36 (S3D x) -> norm_Inf x < 0.0001) :: Bool)
38
37
39prop_tanh_grad :: Property
38prop_tanh_grad :: Property
40−prop_tanh_grad =
39+prop_tanh_grad = property $
41− gambleDisplay (const "Shape") genShape $ \case
40+ forAllWith rss genShape >>= \case
42 (SomeSing (r :: Sing s)) ->
41 (SomeSing (r :: Sing s)) ->
43 withSingI r $
42 withSingI r $
44− gamble genOfShape $ \(ds :: S s) ->
43+ blindForAll genOfShape >>= \(ds :: S s) ->
45 let (tape, f :: S s) = runForwards Tanh ds
44 let (tape, f :: S s) = runForwards Tanh ds
46 ((), ret :: S s) = runBackwards Tanh tape (1 :: S s)
45 ((), ret :: S s) = runBackwards Tanh tape (1 :: S s)
47 (_, numer :: S s) = runForwards Tanh (ds + 0.0001)
46 (_, numer :: S s) = runForwards Tanh (ds + 0.0001)
48 numericalGradient = (numer - f) * 10000
47 numericalGradient = (numer - f) * 10000
49− in counterexample (show numericalGradient ++ show ret)
50− ((case numericalGradient - ret of
48+ in assert ((case numericalGradient - ret of
51 (S1D x) -> norm_Inf x < 0.001
49 (S1D x) -> norm_Inf x < 0.001
52 (S2D x) -> norm_Inf x < 0.001
50 (S2D x) -> norm_Inf x < 0.001
53 (S3D x) -> norm_Inf x < 0.001) :: Bool)
51 (S3D x) -> norm_Inf x < 0.001) :: Bool)
54
52
55−prop_softmax_grad :: Property
56−prop_softmax_grad =
57− gamble genNat $ \case
58− (SomeNat (_ :: Proxy s)) ->
59− gamble genOfShape $ \(ds :: S ('D1 s)) ->
60− let (tape, f :: S ('D1 s)) = runForwards Relu ds
61− ((), ret :: S ('D1 s)) = runBackwards Relu tape (1 :: S ('D1 s))
62− (_, numer :: S ('D1 s)) = runForwards Relu (ds + 0.0001)
63− numericalGradient = (numer - f) * 10000
64− in counterexample (show numericalGradient ++ show ret)
65− ((case numericalGradient - ret of
66− (S1D x) -> norm_Inf x < 0.0001) :: Bool)
67−
68−
69−return []
70tests :: IO Bool
53tests :: IO Bool
71−tests = $quickCheckAll
54+tests = checkParallel $$(discover)
72−
test/Test/Grenade/Layers/PadCrop.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
9+
10+module Test.Grenade.Layers.PadCrop where
11+
12+import Grenade
13+
14+import Hedgehog
15+
16+import Numeric.LinearAlgebra.Static ( norm_Inf )
17+
18+import Test.Hedgehog.Hmatrix
19+
20+prop_pad_crop :: Property
21+prop_pad_crop =
22+ let net :: Network '[Pad 2 3 4 6, Crop 2 3 4 6] '[ 'D3 7 9 5, 'D3 16 15 5, 'D3 7 9 5 ]
23+ net = Pad :~> Crop :~> NNil
24+ in property $
25+ forAll genOfShape >>= \(d :: S ('D3 7 9 5)) ->
26+ let (tapes, res) = runForwards net d
27+ (_ , grad) = runBackwards net tapes d
28+ in do assert $ d ~~~ res
29+ assert $ grad ~~~ d
30+
31+prop_pad_crop_2d :: Property
32+prop_pad_crop_2d =
33+ let net :: Network '[Pad 2 3 4 6, Crop 2 3 4 6] '[ 'D2 7 9, 'D2 16 15, 'D2 7 9 ]
34+ net = Pad :~> Crop :~> NNil
35+ in property $
36+ forAll genOfShape >>= \(d :: S ('D2 7 9)) ->
37+ let (tapes, res) = runForwards net d
38+ (_ , grad) = runBackwards net tapes d
39+ in do assert $ d ~~~ res
40+ assert $ grad ~~~ d
41+
42+(~~~) :: S x -> S x -> Bool
43+(S1D x) ~~~ (S1D y) = norm_Inf (x - y) < 0.00001
44+(S2D x) ~~~ (S2D y) = norm_Inf (x - y) < 0.00001
45+(S3D x) ~~~ (S3D y) = norm_Inf (x - y) < 0.00001
46+
47+
48+tests :: IO Bool
49+tests = checkParallel $$(discover)
test/Test/Grenade/Layers/Pooling.hs+19−14
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE KindSignatures #-}
@@ -9,36 +10,40 @@ module Test.Grenade.Layers.Pooling where
9import Data.Proxy
10import Data.Proxy
10import Data.Singletons ()
11import Data.Singletons ()
11
12
13+#if MIN_VERSION_base(4,9,0)
14+import Data.Kind (Type)
15+#endif
16+
12import GHC.TypeLits
17import GHC.TypeLits
13import Grenade.Layers.Pooling
18import Grenade.Layers.Pooling
14
19
15−import Disorder.Jack
20+import Hedgehog
16
21
22+import Test.Hedgehog.Compat
17
23
18−data OpaquePooling :: * where
24+data OpaquePooling :: Type where
19 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling
25 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling
20
26
21instance Show OpaquePooling where
27instance Show OpaquePooling where
22 show (OpaquePooling n) = show n
28 show (OpaquePooling n) = show n
23
29
24−genOpaquePooling :: Jack OpaquePooling
30+genOpaquePooling :: Gen OpaquePooling
25genOpaquePooling = do
31genOpaquePooling = do
26− Just kernelHeight <- someNatVal <$> choose (2, 15)
32+ ~(Just kernelHeight) <- someNatVal <$> choose 2 15
27− Just kernelWidth <- someNatVal <$> choose (2, 15)
33+ ~(Just kernelWidth ) <- someNatVal <$> choose 2 15
28− Just strideHeight <- someNatVal <$> choose (2, 15)
34+ ~(Just strideHeight) <- someNatVal <$> choose 2 15
29− Just strideWidth <- someNatVal <$> choose (2, 15)
35+ ~(Just strideWidth ) <- someNatVal <$> choose 2 15
30
36
31 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of
37 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of
32 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->
38 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->
33 return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)
39 return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)
34
40
35prop_pool_layer_witness =
41prop_pool_layer_witness =
42+ property $ do
36− gamble genOpaquePooling $ \onet ->
43+ onet <- forAll genOpaquePooling
37− (case onet of
44+ case onet of
38− (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) -> True
45+ (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) ->
39− ) :: Bool
46+ assert True
40−
41
47
42−return []
43tests :: IO Bool
48tests :: IO Bool
44−tests = $quickCheckAll
49+tests = checkParallel $$(discover)
test/Test/Grenade/Network.hsnew file+504
@@ -0,0 +1,504 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE TemplateHaskell #-}
10+{-# LANGUAGE FlexibleContexts #-}
11+module Test.Grenade.Network where
12+
13+import Control.Monad ( guard )
14+import Control.Monad.ST ( runST )
15+
16+import Data.Constraint
17+import qualified Data.Vector.Storable as VS
18+import qualified Data.Vector.Storable.Mutable as VS ( write )
19+import Data.Singletons
20+import Data.Singletons.Prelude.List
21+import Data.Singletons.TypeLits
22+
23+import Hedgehog
24+import qualified Hedgehog.Gen as Gen
25+import Hedgehog.Internal.Source
26+import Hedgehog.Internal.Property ( failWith )
27+
28+import Grenade
29+
30+#if MIN_VERSION_base(4,11,0)
31+import GHC.TypeLits hiding (natVal)
32+#else
33+import GHC.TypeLits
34+#endif
35+#if MIN_VERSION_base(4,9,0)
36+import Data.Kind (Type)
37+#endif
38+
39+import GHC.TypeLits.Witnesses
40+import Test.Hedgehog.Compat
41+import Test.Hedgehog.TypeLits
42+import Test.Hedgehog.Hmatrix
43+import Test.Grenade.Layers.Convolution
44+
45+import Numeric.LinearAlgebra ( flatten )
46+import Numeric.LinearAlgebra.Static ( extract, norm_Inf )
47+import Unsafe.Coerce
48+
49+data SomeNetwork :: Type where
50+ SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork
51+
52+instance Show SomeNetwork where
53+ show (SomeNetwork net) = show net
54+
55+-- | Generate a random network of a random type
56+--
57+-- This is slightly insane for a few reasons. Everything must be wrapped up
58+-- in a SomeNetwork.
59+genNetwork :: Gen SomeNetwork
60+genNetwork =
61+ Gen.recursive Gen.choice [
62+ do SomeSing ( r :: Sing final ) <- genShape
63+ withSingI r $
64+ pure (SomeNetwork (NNil :: Network '[] '[ final ] ))
65+ ] [
66+ do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork
67+ case ( sing :: Sing shapes ) of
68+ SNil -> Gen.discard -- Can't occur
69+ SCons ( h :: Sing h ) ( _ :: Sing hs ) ->
70+ withSingI h $
71+ case h of
72+ D1Sing l@SNat ->
73+ Gen.choice [
74+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))
75+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))
76+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
77+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))
78+ , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))
79+ , do -- Reshape to two dimensions
80+ let divisors :: Integer -> [Integer]
81+ divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]
82+ let len = fromIntegral $ natVal l
83+ rs <- Gen.element $ divisors len
84+ let cs = len `quot` rs
85+ case ( someNatVal rs, someNatVal cs, someNatVal len ) of
86+ ( Just (SomeNat (rs' :: Proxy inRows)), Just (SomeNat (cs' :: Proxy inCols)), Just (SomeNat (_ :: Proxy outLen ) )) ->
87+ let p1 = natDict rs'
88+ p2 = natDict cs'
89+ in case ( p1 %* p2, unsafeCoerce (Dict :: Dict ()) :: Dict ((inRows * inCols) ~ outLen), unsafeCoerce (Dict :: Dict ()) :: Dict (( 'D1 outLen ) ~ h )) of
90+ ( Dict, Dict, Dict ) ->
91+ pure (SomeNetwork (Reshape :~> rest :: Network ( Reshape ': layers ) ( ('D2 inRows inCols) ': h ': hs )))
92+ _ -> Gen.discard -- Doesn't occur
93+ ]
94+ D2Sing r@SNat c@SNat ->
95+ Gen.choice [
96+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))
97+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))
98+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
99+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))
100+ , do -- Build a convolution layer with one filter output
101+ -- Figure out some kernel sizes which work for this layer
102+ -- There must be a better way than this...
103+ let output_r = fromIntegral $ natVal r
104+ let output_c = fromIntegral $ natVal c
105+
106+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
107+
108+ -- Get some kernels which will fit
109+ kernel_r <- choose 1 output_r
110+ kernel_c <- choose 1 output_c
111+
112+ -- Build up some strides which also fit
113+ stride_r <- Gen.element $ ok output_r kernel_r
114+ stride_c <- Gen.element $ ok output_c kernel_c
115+
116+ -- Determine the input size
117+ let input_r = (output_r - 1) * stride_r + kernel_r
118+ let input_c = (output_c - 1) * stride_c + kernel_c
119+
120+ guard (input_r < 100)
121+ guard (input_c < 100)
122+
123+ -- Remake types for input
124+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of
125+ ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),
126+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),
127+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),
128+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->
129+ let p1 = natDict pkr
130+ p2 = natDict pkc
131+ in case ( p1 %* p2
132+ -- Fake it till you make it.
133+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))
134+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
135+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
136+ (Dict, Dict, Dict, Dict) -> do
137+ conv <- genConvolution
138+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution 1 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))
139+ _ -> Gen.discard -- Can't occur
140+ , do -- Build a convolution layer with one filter output
141+ -- Figure out some kernel sizes which work for this layer
142+ -- There must be a better way than this...
143+ let output_r = fromIntegral $ natVal r
144+ let output_c = fromIntegral $ natVal c
145+
146+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
147+
148+ -- Get some kernels which will fit
149+ kernel_r <- choose 1 output_r
150+ kernel_c <- choose 1 output_c
151+ channels <- choose 1 10
152+
153+ -- Build up some strides which also fit
154+ stride_r <- Gen.element $ ok output_r kernel_r
155+ stride_c <- Gen.element $ ok output_c kernel_c
156+
157+ -- Determine the input size
158+ let input_r = (output_r - 1) * stride_r + kernel_r
159+ let input_c = (output_c - 1) * stride_c + kernel_c
160+
161+ guard (input_r < 100)
162+ guard (input_c < 100)
163+
164+ -- Remake types for input
165+ case ( someNatVal channels, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of
166+ ( Just (SomeNat (chan :: Proxy channels)),
167+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),
168+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),
169+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),
170+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->
171+ let p1 = natDict pkr
172+ p2 = natDict pkc
173+ p3 = natDict chan
174+ in case ( p1 %* p2 %* p3
175+ , natDict pinr %* natDict chan
176+ -- Fake it till you make it.
177+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))
178+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
179+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
180+ (Dict, Dict, Dict, Dict, Dict) -> do
181+ conv <- genConvolution
182+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))
183+ _ -> Gen.discard -- Can't occur
184+ , do -- Build a Pooling layer
185+ let output_r = fromIntegral $ natVal r
186+ let output_c = fromIntegral $ natVal c
187+
188+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
189+
190+ -- Get some kernels which will fit
191+ kernel_r <- choose 1 output_r
192+ kernel_c <- choose 1 output_c
193+
194+ -- Build up some strides which also fit
195+ stride_r <- Gen.element $ ok output_r kernel_r
196+ stride_c <- Gen.element $ ok output_c kernel_c
197+
198+ -- Determine the input size
199+ let input_r = (output_r - 1) * stride_r + kernel_r
200+ let input_c = (output_c - 1) * stride_c + kernel_c
201+
202+ guard (input_r < 100)
203+ guard (input_c < 100)
204+
205+ -- Remake types for input
206+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of
207+ ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),
208+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),
209+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),
210+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->
211+ let p1 = natDict pkr
212+ p2 = natDict pkc
213+ in case ( p1 %* p2
214+ -- Fake it till you make it.
215+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))
216+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
217+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
218+ (Dict, Dict, Dict, Dict) ->
219+ pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))
220+ _ -> Gen.discard -- Can't occur
221+ , do -- Build a Pad layer
222+ let output_r = fromIntegral $ natVal r
223+ let output_c = fromIntegral $ natVal c
224+
225+ pad_left <- choose 0 (output_r - 1)
226+ pad_right <- choose 0 (output_r - 1 - pad_left)
227+ pad_top <- choose 0 (output_c - 1)
228+ pad_bottom <- choose 0 (output_c - 1 - pad_top)
229+
230+ let input_r = output_r - pad_top - pad_bottom
231+ let input_c = output_c - pad_left - pad_right
232+
233+ guard (input_r > 1)
234+ guard (input_c > 1)
235+
236+ -- Remake types for input
237+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal pad_left, someNatVal pad_right, someNatVal pad_top, someNatVal pad_bottom ) of
238+ ( Just (SomeNat (_ :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),
239+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),
240+ Just (SomeNat (_ :: Proxy padLeft)), Just (SomeNat (_ :: Proxy padRight)),
241+ Just (SomeNat (_ :: Proxy padTop)), Just (SomeNat (_ :: Proxy padBottom))) ->
242+ case ( (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outputRows outputColumns) ~ h ))
243+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputRows + padTop + padBottom) ~ outputRows) )
244+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputColumns + padLeft + padRight) ~ outputColumns ))) of
245+ ( Dict, Dict, Dict ) ->
246+ pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D2 inputRows inputColumns) ': h ': hs )))
247+ _ -> Gen.discard -- Can't occur
248+ , do -- Build a Crop layer
249+ let output_r = fromIntegral $ natVal r
250+ let output_c = fromIntegral $ natVal c
251+
252+ crop_left <- choose 0 10
253+ crop_right <- choose 0 10
254+ crop_top <- choose 0 10
255+ crop_bottom <- choose 0 10
256+
257+ let input_r = output_r + crop_top + crop_bottom
258+ let input_c = output_c + crop_left + crop_right
259+
260+ -- Remake types for input
261+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal crop_left, someNatVal crop_right, someNatVal crop_top, someNatVal crop_bottom ) of
262+ ( Just (SomeNat (_ :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),
263+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),
264+ Just (SomeNat (_ :: Proxy cropLeft)), Just (SomeNat (_ :: Proxy cropRight)),
265+ Just (SomeNat (_ :: Proxy cropTop)), Just (SomeNat (_ :: Proxy cropBottom))) ->
266+ case ( (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outputRows outputColumns) ~ h ))
267+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputRows + cropTop + cropBottom) ~ inputRows ) )
268+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputColumns + cropLeft + cropRight) ~ inputColumns ))) of
269+ (Dict, Dict, Dict) ->
270+ pure (SomeNetwork (Crop :~> rest :: Network ( Crop cropLeft cropTop cropRight cropBottom ': layers ) ( ('D2 inputRows inputColumns) ': h ': hs )))
271+ _ -> Gen.discard -- Can't occur
272+ ]
273+ D3Sing r@SNat c@SNat f@SNat ->
274+ Gen.choice [
275+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))
276+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))
277+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
278+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))
279+ , do -- Build a convolution layer with one filter output
280+ -- Figure out some kernel sizes which work for this layer
281+ -- There must be a better way than this...
282+ let output_r = fromIntegral $ natVal r
283+ let output_c = fromIntegral $ natVal c
284+ let output_f = fromIntegral $ natVal f
285+
286+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
287+
288+ -- Get some kernels which will fit
289+ kernel_r <- choose 1 output_r
290+ kernel_c <- choose 1 output_c
291+ channels <- choose 1 10
292+
293+ -- Build up some strides which also fit
294+ stride_r <- Gen.element $ ok output_r kernel_r
295+ stride_c <- Gen.element $ ok output_c kernel_c
296+
297+ -- Determine the input size
298+ let input_r = (output_r - 1) * stride_r + kernel_r
299+ let input_c = (output_c - 1) * stride_c + kernel_c
300+
301+ guard (input_r < 100)
302+ guard (input_c < 100)
303+
304+ -- Remake types for input
305+ case ( someNatVal channels, someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of
306+ ( Just (SomeNat (chan :: Proxy channels)), Just (SomeNat (_ :: Proxy filters)),
307+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),
308+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),
309+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),
310+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->
311+ let p1 = natDict pkr
312+ p2 = natDict pkc
313+ p3 = natDict chan
314+ in case ( p1 %* p2 %* p3
315+ , natDict pinr %* natDict chan
316+ -- Fake it till you make it.
317+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outRows outCols filters) ~ h ))
318+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
319+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
320+ (Dict, Dict, Dict, Dict, Dict) -> do
321+ conv <- genConvolution
322+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels filters kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))
323+ _ -> Gen.discard -- Can't occur
324+ , do -- Build a Pooling layer
325+ let output_r = fromIntegral $ natVal r
326+ let output_c = fromIntegral $ natVal c
327+ let output_f = fromIntegral $ natVal f
328+
329+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
330+
331+ -- Get some kernels which will fit
332+ kernel_r <- choose 1 output_r
333+ kernel_c <- choose 1 output_c
334+
335+ -- Build up some strides which also fit
336+ stride_r <- Gen.element $ ok output_r kernel_r
337+ stride_c <- Gen.element $ ok output_c kernel_c
338+
339+ -- Determine the input size
340+ let input_r = (output_r - 1) * stride_r + kernel_r
341+ let input_c = (output_c - 1) * stride_c + kernel_c
342+
343+ guard (input_r < 100)
344+ guard (input_c < 100)
345+
346+ -- Remake types for input
347+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of
348+ ( Just (SomeNat (chan :: Proxy filters)),
349+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),
350+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),
351+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),
352+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->
353+ let p1 = natDict pkr
354+ p2 = natDict pkc
355+ p3 = natDict chan
356+ in case ( p1 %* p2 %* p3
357+ , natDict pinr %* natDict chan
358+ -- Fake it till you make it.
359+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outRows outCols filters) ~ h ))
360+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
361+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
362+ (Dict, Dict, Dict, Dict, Dict) ->
363+ pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols filters) ': h ': hs )))
364+ _ -> Gen.discard -- Can't occur
365+ , do -- Build a Pad layer
366+ let output_r = fromIntegral $ natVal r
367+ let output_c = fromIntegral $ natVal c
368+ let output_f = fromIntegral $ natVal f
369+
370+ pad_left <- choose 0 (output_r - 1)
371+ pad_right <- choose 0 (output_r - 1 - pad_left)
372+ pad_top <- choose 0 (output_c - 1)
373+ pad_bottom <- choose 0 (output_c - 1 - pad_top)
374+
375+ let input_r = output_r - pad_top - pad_bottom
376+ let input_c = output_c - pad_left - pad_right
377+
378+ guard (input_r > 1)
379+ guard (input_c > 1)
380+
381+ -- Remake types for input
382+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal pad_left, someNatVal pad_right, someNatVal pad_top, someNatVal pad_bottom ) of
383+ ( Just (SomeNat (chan :: Proxy filters)),
384+ Just (SomeNat (pinr :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),
385+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),
386+ Just (SomeNat (_ :: Proxy padLeft)), Just (SomeNat (_ :: Proxy padRight)),
387+ Just (SomeNat (_ :: Proxy padTop)), Just (SomeNat (_ :: Proxy padBottom))) ->
388+ case ( natDict pinr %* natDict chan
389+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outputRows outputColumns filters) ~ h ))
390+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputRows + padTop + padBottom) ~ outputRows) )
391+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputColumns + padLeft + padRight) ~ outputColumns ))) of
392+ (Dict, Dict, Dict, Dict) ->
393+ pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))
394+ _ -> Gen.discard -- Can't occur
395+ , do -- Build a Crop layer
396+ let output_r = fromIntegral $ natVal r
397+ let output_c = fromIntegral $ natVal c
398+ let output_f = fromIntegral $ natVal f
399+
400+ crop_left <- choose 0 10
401+ crop_right <- choose 0 10
402+ crop_top <- choose 0 10
403+ crop_bottom <- choose 0 10
404+
405+ let input_r = output_r + crop_top + crop_bottom
406+ let input_c = output_c + crop_left + crop_right
407+
408+ -- Remake types for input
409+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal crop_left, someNatVal crop_right, someNatVal crop_top, someNatVal crop_bottom ) of
410+ ( Just (SomeNat (chan :: Proxy filters)),
411+ Just (SomeNat (pinr :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),
412+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),
413+ Just (SomeNat (_ :: Proxy cropLeft)), Just (SomeNat (_ :: Proxy cropRight)),
414+ Just (SomeNat (_ :: Proxy cropTop)), Just (SomeNat (_ :: Proxy cropBottom))) ->
415+ case ( natDict pinr %* natDict chan
416+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outputRows outputColumns filters) ~ h ))
417+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputRows + cropTop + cropBottom) ~ inputRows ) )
418+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputColumns + cropLeft + cropRight) ~ inputColumns ))) of
419+ (Dict, Dict, Dict, Dict) ->
420+ pure (SomeNetwork (Crop :~> rest :: Network ( Crop cropLeft cropTop cropRight cropBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))
421+ _ -> Gen.discard -- Can't occur
422+ ]
423+ ]
424+
425+-- | Test a partial derivative numerically for a random network and input
426+--
427+-- This is the most important test.
428+prop_auto_diff :: Property
429+prop_auto_diff = withDiscards 1000 . withTests 10000 . property $ do
430+ SomeNetwork (network :: Network layers shapes) <- forAll genNetwork
431+ (input :: S (Head shapes)) <- forAllWith nice genOfShape
432+ (target :: S (Last shapes)) <- forAllWith nice oneUp
433+ (tested :: S (Head shapes)) <- forAllWith nice oneUp
434+
435+ let (!tapes, !output) = runNetwork network input
436+ let (_, !backgrad) = runGradient network tapes target
437+ let inputDiff = input + tested * 0.00001
438+ let expected = maxVal ( backgrad * tested )
439+ let (_, !outputDiff) = runNetwork network inputDiff
440+ let result = maxVal ( outputDiff * target - output * target ) / 0.00001
441+
442+ result ~~~ expected
443+
444+-- Make a shape where all are 0 except for 1 value, which is 1.
445+oneUp :: forall shape. ( SingI shape ) => Gen (S shape)
446+oneUp =
447+ case ( sing :: Sing shape ) of
448+ D1Sing SNat ->
449+ let x = 0 :: S ( shape )
450+ in case x of
451+ ( S1D x' ) -> do
452+ let ex = extract x'
453+ let len = VS.length ex
454+ ix <- choose 0 (len - 1)
455+ let nx = runST $ do ex' <- VS.thaw ex
456+ VS.write ex' ix 1.0
457+ VS.freeze ex'
458+ maybe Gen.discard pure . fromStorable $ nx
459+
460+ D2Sing SNat SNat ->
461+ let x = 0 :: S ( shape )
462+ in case x of
463+ ( S2D x' ) -> do
464+ let ex = flatten ( extract x' )
465+ let len = VS.length ex
466+ ix <- choose 0 (len - 1)
467+ let nx = runST $ do ex' <- VS.thaw ex
468+ VS.write ex' ix 1
469+ VS.freeze ex'
470+ maybe Gen.discard pure . fromStorable $ nx
471+
472+ D3Sing SNat SNat SNat ->
473+ let x = 0 :: S ( shape )
474+ in case x of
475+ ( S3D x' ) -> do
476+ let ex = flatten ( extract x' )
477+ let len = VS.length ex
478+ ix <- choose 0 (len - 1)
479+ let nx = runST $ do ex' <- VS.thaw ex
480+ VS.write ex' ix 1
481+ VS.freeze ex'
482+ maybe Gen.discard pure . fromStorable $ nx
483+
484+maxVal :: S shape -> Double
485+maxVal ( S1D x ) = norm_Inf x
486+maxVal ( S2D x ) = norm_Inf x
487+maxVal ( S3D x ) = norm_Inf x
488+
489+(~~~) :: (Monad m, HasCallStack) => Double -> Double -> PropertyT m ()
490+(~~~) x y =
491+ if abs (x - y) < 2e-5 then
492+ success
493+ else
494+ withFrozenCallStack $
495+ failWith Nothing $ unlines [
496+ "━━━ Not Simliar ━━━"
497+ , show x
498+ , show y
499+ ]
500+infix 4 ~~~
501+
502+
503+tests :: IO Bool
504+tests = checkParallel $$(discover)
test/Test/Grenade/Recurrent/Layers/LSTM.hs+83−54
@@ -10,7 +10,10 @@
10{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
10{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
11module Test.Grenade.Recurrent.Layers.LSTM where
11module Test.Grenade.Recurrent.Layers.LSTM where
12
12
13−import Disorder.Jack
13+import Hedgehog
14+import Hedgehog.Internal.Source
15+import Hedgehog.Internal.Show
16+import Hedgehog.Internal.Property ( failWith, Diff (..) )
14
17
15import Data.Foldable ( toList )
18import Data.Foldable ( toList )
16import Data.Singletons.TypeLits
19import Data.Singletons.TypeLits
@@ -23,9 +26,9 @@ import qualified Numeric.LinearAlgebra.Static as S
23
26
24
27
25import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference
28import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference
26−import Test.Jack.Hmatrix
29+import Test.Hedgehog.Hmatrix
27
30
28−genLSTM :: forall i o. (KnownNat i, KnownNat o) => Jack (LSTM i o)
31+genLSTM :: forall i o. (KnownNat i, KnownNat o) => Gen (LSTM i o)
29genLSTM = do
32genLSTM = do
30 let w = uniformSample
33 let w = uniformSample
31 u = uniformSample
34 u = uniformSample
@@ -39,63 +42,89 @@ genLSTM = do
39 <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)
42 <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)
40
43
41prop_lstm_reference_forwards =
44prop_lstm_reference_forwards =
42− gamble randomVector $ \(input :: S.R 3) ->
45+ property $ do
43− gamble randomVector $ \(cell :: S.R 2) ->
46+ input :: S.R 3 <- forAll randomVector
44− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
47+ cell :: S.R 2 <- forAll randomVector
48+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
49+
45− let actual = runRecurrentForwards net (S1D cell) (S1D input)
50+ let actual = runRecurrentForwards net (S1D cell) (S1D input)
46− in case actual of
51+ case actual of
47− (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->
52+ (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->
48− let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut
53+ let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut
49− output' = Reference.Vector . H.toList . S.extract $ output
54+ output' = Reference.Vector . H.toList . S.extract $ output
50− refNet = Reference.lstmToReference lstmWeights
55+ refNet = Reference.lstmToReference lstmWeights
51− refCell = Reference.Vector . H.toList . S.extract $ cell
56+ refCell = Reference.Vector . H.toList . S.extract $ cell
52− refInput = Reference.Vector . H.toList . S.extract $ input
57+ refInput = Reference.Vector . H.toList . S.extract $ input
53− (refCO, refO) = Reference.runLSTM refNet refCell refInput
58+ (refCO, refO) = Reference.runLSTM refNet refCell refInput
54− in toList refCO ~~~ toList cellOut' .&&. toList refO ~~~ toList output'
59+ in do toList refCO ~~~ toList cellOut'
60+ toList refO ~~~ toList output'
61+
55
62
56prop_lstm_reference_backwards =
63prop_lstm_reference_backwards =
57− gamble randomVector $ \(input :: S.R 3) ->
64+ property $ do
58− gamble randomVector $ \(cell :: S.R 2) ->
65+ input :: S.R 3 <- forAll randomVector
59− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
66+ cell :: S.R 2 <- forAll randomVector
67+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
68+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))
69+ = runRecurrentForwards net (S1D cell) (S1D input)
60− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
70+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
61− in case actualBacks of
71+ case actualBacks of
62− (actualGradients, _, _ :: S ('D1 3)) ->
72+ (actualGradients, _, _ :: S ('D1 3)) ->
63− let refNet = Reference.lstmToReference lstmWeights
73+ let refNet = Reference.lstmToReference lstmWeights
64− refCell = Reference.Vector . H.toList . S.extract $ cell
74+ refCell = Reference.Vector . H.toList . S.extract $ cell
65− refInput = Reference.Vector . H.toList . S.extract $ input
75+ refInput = Reference.Vector . H.toList . S.extract $ input
66− refGradients = Reference.runLSTMback refCell refInput refNet
76+ refGradients = Reference.runLSTMback refCell refInput refNet
67− in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)
77+ in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)
68
78
69prop_lstm_reference_backwards_input =
79prop_lstm_reference_backwards_input =
70− gamble randomVector $ \(input :: S.R 3) ->
80+ property $ do
71− gamble randomVector $ \(cell :: S.R 2) ->
81+ input :: S.R 3 <- forAll randomVector
72− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
82+ cell :: S.R 2 <- forAll randomVector
83+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
84+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))
85+ = runRecurrentForwards net (S1D cell) (S1D input)
73− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
86+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
74− in case actualBacks of
87+ case actualBacks of
75− (_, _, S1D actualGradients :: S ('D1 3)) ->
88+ (_, _, S1D actualGradients :: S ('D1 3)) ->
76− let refNet = Reference.lstmToReference lstmWeights
89+ let refNet = Reference.lstmToReference lstmWeights
77− refCell = Reference.Vector . H.toList . S.extract $ cell
90+ refCell = Reference.Vector . H.toList . S.extract $ cell
78− refInput = Reference.Vector . H.toList . S.extract $ input
91+ refInput = Reference.Vector . H.toList . S.extract $ input
79− refGradients = Reference.runLSTMbackOnInput refCell refNet refInput
92+ refGradients = Reference.runLSTMbackOnInput refCell refNet refInput
80− in toList refGradients ~~~ H.toList (S.extract actualGradients)
93+ in toList refGradients ~~~ H.toList (S.extract actualGradients)
81
94
82prop_lstm_reference_backwards_cell =
95prop_lstm_reference_backwards_cell =
83− gamble randomVector $ \(input :: S.R 3) ->
96+ property $ do
84− gamble randomVector $ \(cell :: S.R 2) ->
97+ input :: S.R 3 <- forAll randomVector
85− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
98+ cell :: S.R 2 <- forAll randomVector
99+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
100+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))
101+ = runRecurrentForwards net (S1D cell) (S1D input)
86− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
102+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
87− in case actualBacks of
103+ case actualBacks of
88− (_, S1D actualGradients, _ :: S ('D1 3)) ->
104+ (_, S1D actualGradients, _ :: S ('D1 3)) ->
89− let refNet = Reference.lstmToReference lstmWeights
105+ let refNet = Reference.lstmToReference lstmWeights
90− refCell = Reference.Vector . H.toList . S.extract $ cell
106+ refCell = Reference.Vector . H.toList . S.extract $ cell
91− refInput = Reference.Vector . H.toList . S.extract $ input
107+ refInput = Reference.Vector . H.toList . S.extract $ input
92− refGradients = Reference.runLSTMbackOnCell refInput refNet refCell
108+ refGradients = Reference.runLSTMbackOnCell refInput refNet refCell
93− in toList refGradients ~~~ H.toList (S.extract actualGradients)
109+ in toList refGradients ~~~ H.toList (S.extract actualGradients)
94−
110+
95−
111+(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> PropertyT m ()
112+(~~~) x y =
96−(~~~) as bs = all (< 1e-8) (zipWith (-) as bs)
113+ if all (< 1e-8) (zipWith (-) x y) then
114+ success
115+ else
116+ case valueDiff <$> mkValue x <*> mkValue y of
117+ Nothing ->
118+ withFrozenCallStack $
119+ failWith Nothing $ unlines [
120+ "━━━ Not Simliar ━━━"
121+ , showPretty x
122+ , showPretty y
123+ ]
124+ Just differ ->
125+ withFrozenCallStack $
126+ failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" differ) ""
97infix 4 ~~~
127infix 4 ~~~
98
128
99−return []
100tests :: IO Bool
129tests :: IO Bool
101−tests = $quickCheckAll
130+tests = checkParallel $$(discover)
test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+25−21
@@ -6,7 +6,6 @@
6{-# LANGUAGE DeriveFunctor #-}
6{-# LANGUAGE DeriveFunctor #-}
7{-# LANGUAGE DeriveFoldable #-}
7{-# LANGUAGE DeriveFoldable #-}
8{-# LANGUAGE DeriveTraversable #-}
8{-# LANGUAGE DeriveTraversable #-}
9−{-# LANGUAGE RecordWildCards #-}
10{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE FlexibleContexts #-}
11{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE RankNTypes #-}
12
11
@@ -15,9 +14,13 @@ module Test.Grenade.Recurrent.Layers.LSTM.Reference where
15
14
16import Data.Reflection
15import Data.Reflection
17import Numeric.AD.Mode.Reverse
16import Numeric.AD.Mode.Reverse
18−import Numeric.AD.Internal.Reverse ( Tape )
17+import Numeric.AD.Internal.Reverse (Tape)
19
18
19+import GHC.TypeLits (KnownNat)
20+
21+import Grenade.Recurrent.Layers.LSTM (LSTMWeights (..))
20import qualified Grenade.Recurrent.Layers.LSTM as LSTM
22import qualified Grenade.Recurrent.Layers.LSTM as LSTM
23+
21import qualified Numeric.LinearAlgebra.Static as S
24import qualified Numeric.LinearAlgebra.Static as S
22import qualified Numeric.LinearAlgebra as H
25import qualified Numeric.LinearAlgebra as H
23
26
@@ -54,31 +57,32 @@ data RefLSTM a = RefLSTM
54 , refLstmBc :: Vector a -- Bias Cell (b_c)
57 , refLstmBc :: Vector a -- Bias Cell (b_c)
55 } deriving (Functor, Foldable, Traversable, Eq, Show)
58 } deriving (Functor, Foldable, Traversable, Eq, Show)
56
59
57−lstmToReference :: LSTM.LSTMWeights a b -> RefLSTM Double
60+lstmToReference :: (KnownNat a, KnownNat b) => LSTM.LSTMWeights a b -> RefLSTM Double
58−lstmToReference LSTM.LSTMWeights {..} =
61+lstmToReference lw =
62+ RefLSTM
59− let refLstmWf = Matrix . H.toLists . S.extract $ lstmWf -- Weight Forget (W_f)
63+ { refLstmWf = Matrix . H.toLists . S.extract $ lstmWf lw -- Weight Forget (W_f)
60− refLstmUf = Matrix . H.toLists . S.extract $ lstmUf -- Cell State Forget (U_f)
64+ , refLstmUf = Matrix . H.toLists . S.extract $ lstmUf lw -- Cell State Forget (U_f)
61− refLstmBf = Vector . H.toList . S.extract $ lstmBf -- Bias Forget (b_f)
65+ , refLstmBf = Vector . H.toList . S.extract $ lstmBf lw -- Bias Forget (b_f)
62− refLstmWi = Matrix . H.toLists . S.extract $ lstmWi -- Weight Input (W_i)
66+ , refLstmWi = Matrix . H.toLists . S.extract $ lstmWi lw -- Weight Input (W_i)
63− refLstmUi = Matrix . H.toLists . S.extract $ lstmUi -- Cell State Input (U_i)
67+ , refLstmUi = Matrix . H.toLists . S.extract $ lstmUi lw -- Cell State Input (U_i)
64− refLstmBi = Vector . H.toList . S.extract $ lstmBi -- Bias Input (b_i)
68+ , refLstmBi = Vector . H.toList . S.extract $ lstmBi lw -- Bias Input (b_i)
65− refLstmWo = Matrix . H.toLists . S.extract $ lstmWo -- Weight Output (W_o)
69+ , refLstmWo = Matrix . H.toLists . S.extract $ lstmWo lw -- Weight Output (W_o)
66− refLstmUo = Matrix . H.toLists . S.extract $ lstmUo -- Cell State Output (U_o)
70+ , refLstmUo = Matrix . H.toLists . S.extract $ lstmUo lw -- Cell State Output (U_o)
67− refLstmBo = Vector . H.toList . S.extract $ lstmBo -- Bias Output (b_o)
71+ , refLstmBo = Vector . H.toList . S.extract $ lstmBo lw -- Bias Output (b_o)
68− refLstmWc = Matrix . H.toLists . S.extract $ lstmWc -- Weight Cell (W_c)
72+ , refLstmWc = Matrix . H.toLists . S.extract $ lstmWc lw -- Weight Cell (W_c)
69− refLstmBc = Vector . H.toList . S.extract $ lstmBc -- Bias Cell (b_c)
73+ , refLstmBc = Vector . H.toList . S.extract $ lstmBc lw -- Bias Cell (b_c)
70− in RefLSTM {..}
74+ }
71
75
72runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)
76runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)
73−runLSTM RefLSTM {..} cell input =
77+runLSTM rl cell input =
74 let -- Forget state vector
78 let -- Forget state vector
75− f_t = sigmoid $ refLstmBf #+ refLstmWf #> input #+ refLstmUf #> cell
79+ f_t = sigmoid $ refLstmBf rl #+ refLstmWf rl #> input #+ refLstmUf rl #> cell
76 -- Input state vector
80 -- Input state vector
77− i_t = sigmoid $ refLstmBi #+ refLstmWi #> input #+ refLstmUi #> cell
81+ i_t = sigmoid $ refLstmBi rl #+ refLstmWi rl #> input #+ refLstmUi rl #> cell
78 -- Output state vector
82 -- Output state vector
79− o_t = sigmoid $ refLstmBo #+ refLstmWo #> input #+ refLstmUo #> cell
83+ o_t = sigmoid $ refLstmBo rl #+ refLstmWo rl #> input #+ refLstmUo rl #> cell
80 -- Cell input state vector
84 -- Cell input state vector
81− c_x = fmap tanh $ refLstmBc #+ refLstmWc #> input
85+ c_x = fmap tanh $ refLstmBc rl #+ refLstmWc rl #> input
82 -- Cell state
86 -- Cell state
83 c_t = f_t #* cell #+ i_t #* c_x
87 c_t = f_t #* cell #+ i_t #* c_x
84 -- Output (it's sometimes recommended to use tanh c_t)
88 -- Output (it's sometimes recommended to use tanh c_t)
test/Test/Hedgehog/Compat.hsnew file+21
@@ -0,0 +1,21 @@
1+{-# LANGUAGE RankNTypes #-}
2+module Test.Hedgehog.Compat (
3+ (...)
4+ , choose
5+ , blindForAll
6+ )where
7+
8+import Hedgehog (Gen)
9+import qualified Hedgehog.Gen as Gen
10+import qualified Hedgehog.Range as Range
11+import Hedgehog.Internal.Property
12+
13+(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
14+(...) = (.) . (.)
15+{-# INLINE (...) #-}
16+
17+choose :: Integral a => a -> a -> Gen a
18+choose = Gen.integral ... Range.constant
19+
20+blindForAll :: Monad m => Gen a -> PropertyT m a
21+blindForAll = forAllWith (const "blind")
test/Test/Hedgehog/Hmatrix.hsnew file+42
@@ -0,0 +1,42 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE KindSignatures #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+
7+module Test.Hedgehog.Hmatrix where
8+
9+import Grenade
10+import Data.Singletons
11+import Data.Singletons.TypeLits
12+
13+import Hedgehog (Gen)
14+import qualified Hedgehog.Gen as Gen
15+import qualified Hedgehog.Range as Range
16+
17+import qualified Numeric.LinearAlgebra.Static as HStatic
18+
19+randomVector :: forall n. ( KnownNat n ) => Gen (HStatic.R n)
20+randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded
21+
22+uniformSample :: forall m n. ( KnownNat m, KnownNat n ) => Gen (HStatic.L m n)
23+uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded
24+
25+-- | Generate random data of the desired shape
26+genOfShape :: forall x. ( SingI x ) => Gen (S x)
27+genOfShape =
28+ case (sing :: Sing x) of
29+ D1Sing l ->
30+ withKnownNat l $
31+ S1D <$> randomVector
32+ D2Sing r c ->
33+ withKnownNat r $ withKnownNat c $
34+ S2D <$> uniformSample
35+ D3Sing r c d ->
36+ withKnownNat r $ withKnownNat c $ withKnownNat d $
37+ S3D <$> uniformSample
38+
39+nice :: S shape -> String
40+nice (S1D x) = show . HStatic.extract $ x
41+nice (S2D x) = show . HStatic.extract $ x
42+nice (S3D x) = show . HStatic.extract $ x
test/Test/Hedgehog/TypeLits.hsnew file+65
@@ -0,0 +1,65 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE GADTs #-}
8+module Test.Hedgehog.TypeLits where
9+
10+import Data.Constraint (Dict (..))
11+import Data.Singletons (Proxy (..), Sing (..), SomeSing (..), sing)
12+#if MIN_VERSION_singletons(2,6,0)
13+import Data.Singletons.TypeLits (SNat (..))
14+#endif
15+
16+import Hedgehog (Gen)
17+import qualified Hedgehog.Gen as Gen
18+
19+import Grenade
20+
21+import GHC.TypeLits (SomeNat (..), natVal, someNatVal)
22+import GHC.TypeLits.Witnesses ((%*), natDict)
23+import Test.Hedgehog.Compat (choose)
24+
25+genNat :: Gen SomeNat
26+genNat = do
27+ ~(Just n) <- someNatVal <$> choose 1 10
28+ return n
29+
30+genShape :: Gen (SomeSing Shape)
31+genShape
32+ = Gen.choice [
33+ genD1
34+ , genD2
35+ , genD3
36+ ]
37+
38+genD1 :: Gen (SomeSing Shape)
39+genD1 = do
40+ n <- genNat
41+ return $ case n of
42+ SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))
43+
44+genD2 :: Gen (SomeSing Shape)
45+genD2 = do
46+ n <- genNat
47+ m <- genNat
48+ return $ case (n, m) of
49+ (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))
50+
51+genD3 :: Gen (SomeSing Shape)
52+genD3 = do
53+ n <- genNat
54+ m <- genNat
55+ o <- genNat
56+ return $ case (n, m, o) of
57+ (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->
58+ case natDict px %* natDict pz of
59+ Dict -> SomeSing (sing :: Sing ('D3 x y z))
60+
61+rss :: SomeSing Shape -> String
62+rss (SomeSing (r :: Sing s)) = case r of
63+ (D1Sing a@SNat) -> "D1 " ++ show (natVal a)
64+ (D2Sing a@SNat b@SNat) -> "D2 " ++ show (natVal a) ++ " " ++ show (natVal b)
65+ (D3Sing a@SNat b@SNat c@SNat) -> "D3 " ++ show (natVal a) ++ " " ++ show (natVal b) ++ " " ++ show (natVal c)
test/Test/Jack/Hmatrix.hsdeleted−29
@@ -1,29 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE GADTs #-}
5−
6−module Test.Jack.Hmatrix where
7−
8−import Grenade
9−import Data.Singletons
10−
11−import Disorder.Jack
12−
13−import GHC.TypeLits
14−
15−import qualified Numeric.LinearAlgebra.Static as HStatic
16−
17−randomVector :: forall n. KnownNat n => Jack (HStatic.R n)
18−randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> sizedNat
19−
20−uniformSample :: forall m n. (KnownNat m, KnownNat n) => Jack (HStatic.L m n)
21−uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> sizedNat
22−
23−-- | Generate random data of the desired shape
24−genOfShape :: forall x. ( SingI x ) => Jack (S x)
25−genOfShape =
26− case (sing :: Sing x) of
27− D1Sing -> S1D <$> randomVector
28− D2Sing -> S2D <$> uniformSample
29− D3Sing -> S3D <$> uniformSample
test/Test/Jack/TypeLits.hsdeleted−47
@@ -1,47 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Test.Jack.TypeLits where
6−
7−import Data.Constraint
8−import Data.Singletons
9−import Disorder.Jack
10−
11−import Grenade
12−
13−import GHC.TypeLits
14−import GHC.TypeLits.Witnesses
15−
16−genNat :: Jack SomeNat
17−genNat = do
18− Just n <- someNatVal <$> choose (1, 10)
19− return n
20−
21−genShape :: Jack (SomeSing Shape)
22−genShape
23− = oneOf [
24− genD1
25− , genD2
26− , genD3
27− ]
28− where
29− genD1 = do
30− n <- genNat
31− return $ case n of
32− SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))
33−
34− genD2 = do
35− n <- genNat
36− m <- genNat
37− return $ case (n, m) of
38− (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))
39−
40− genD3 = do
41− n <- genNat
42− m <- genNat
43− o <- genNat
44− return $ case (n, m, o) of
45− (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->
46− case natDict px %* natDict pz of
47− Dict -> SomeSing (sing :: Sing ('D3 x y z))
test/test.hs+24−2
@@ -1,25 +1,47 @@
1−import Disorder.Core.Main
1+import Control.Monad
2+
3+import qualified Test.Grenade.Network
2
4
3import qualified Test.Grenade.Layers.Pooling
5import qualified Test.Grenade.Layers.Pooling
4import qualified Test.Grenade.Layers.Convolution
6import qualified Test.Grenade.Layers.Convolution
5import qualified Test.Grenade.Layers.FullyConnected
7import qualified Test.Grenade.Layers.FullyConnected
6import qualified Test.Grenade.Layers.Nonlinear
8import qualified Test.Grenade.Layers.Nonlinear
9+import qualified Test.Grenade.Layers.PadCrop
7
10
8import qualified Test.Grenade.Layers.Internal.Convolution
11import qualified Test.Grenade.Layers.Internal.Convolution
9import qualified Test.Grenade.Layers.Internal.Pooling
12import qualified Test.Grenade.Layers.Internal.Pooling
10
13
11import qualified Test.Grenade.Recurrent.Layers.LSTM
14import qualified Test.Grenade.Recurrent.Layers.LSTM
12
15
16+import System.Exit
17+import System.IO
18+
13main :: IO ()
19main :: IO ()
14main =
20main =
15 disorderMain [
21 disorderMain [
22+ Test.Grenade.Network.tests
23+
16− Test.Grenade.Layers.Pooling.tests
24+ , Test.Grenade.Layers.Pooling.tests
17 , Test.Grenade.Layers.Convolution.tests
25 , Test.Grenade.Layers.Convolution.tests
18 , Test.Grenade.Layers.FullyConnected.tests
26 , Test.Grenade.Layers.FullyConnected.tests
19 , Test.Grenade.Layers.Nonlinear.tests
27 , Test.Grenade.Layers.Nonlinear.tests
28+ , Test.Grenade.Layers.PadCrop.tests
20
29
21 , Test.Grenade.Layers.Internal.Convolution.tests
30 , Test.Grenade.Layers.Internal.Convolution.tests
22 , Test.Grenade.Layers.Internal.Pooling.tests
31 , Test.Grenade.Layers.Internal.Pooling.tests
23
32
24 , Test.Grenade.Recurrent.Layers.LSTM.tests
33 , Test.Grenade.Recurrent.Layers.LSTM.tests
34+
25 ]
35 ]
36+
37+disorderMain :: [IO Bool] -> IO ()
38+disorderMain tests = do
39+ lineBuffer
40+ rs <- sequence tests
41+ unless (and rs) exitFailure
42+
43+
44+lineBuffer :: IO ()
45+lineBuffer = do
46+ hSetBuffering stdout LineBuffering
47+ hSetBuffering stderr LineBuffering