packages feed

grenade (empty) → 0.1.0

raw patch · 65 files changed

+5658/−0 lines, 65 filesdep +MonadRandomdep +addep +basesetup-changed

Dependencies added: MonadRandom, ad, base, bytestring, cereal, constraints, containers, criterion, deepseq, exceptions, grenade, hedgehog, hmatrix, mtl, primitive, random, reflection, singletons, text, transformers, typelits-witnesses, vector

Files

+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2016-2017, Huw Campbell+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++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.++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.
+ README.md view
@@ -0,0 +1,184 @@+Grenade+=======++[![Build Status](https://api.travis-ci.org/HuwCampbell/grenade.svg?branch=master)](https://travis-ci.org/HuwCampbell/grenade)++```+First shalt thou take out the Holy Pin, then shalt thou count to three, no more, no less.+Three shall be the number thou shalt count, and the number of the counting shall be three.+Four shalt thou not count, neither count thou two, excepting that thou then proceed to three.+Five is right out.+```++💣 Machine learning which might blow up in your face 💣++Grenade is a composable, dependently typed, practical, and fast recurrent neural network library+for concise and precise specifications of complex networks in Haskell.++As an example, a network which can achieve ~1.5% error on MNIST can be+specified and initialised with random weights in a few lines of code with+```haskell+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]+    '[ '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]++randomMnist :: MonadRandom m => m MNIST+randomMnist = randomNetwork+```++And that's it. Because the types are so rich, there's no specific term level code+required to construct this network; although it is of course possible and+easy to construct and deconstruct the networks and layers explicitly oneself.++If recurrent neural networks are more your style, you can try defining something+["unreasonably effective"](http://karpathy.github.io/2015/05/21/rnn-effectiveness/)+with+```haskell+type Shakespeare+  = RecurrentNetwork+    '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyConnected 40 40), F Logit]+    '[ 'D1 40, 'D1 80, 'D1 40, 'D1 40, 'D1 40 ]+```++Design+------++Networks in Grenade can be thought of as a heterogeneous lists of layers, where+their type includes not only the layers of the network, but also the shapes of+data that are passed between the layers.++The definition of a network is surprisingly simple:+```haskell+data Network :: [*] -> [Shape] -> * where+    NNil  :: SingI i+          => Network '[] '[i]++    (:~>) :: (SingI i, SingI h, Layer x i h)+          => !x+          -> !(Network xs (h ': hs))+          -> Network (x ': xs) (i ': h ': hs)+```++The `Layer x i o` constraint ensures that the layer `x` can sensibly perform a+transformation between the input and output shapes `i` and `o`.++The lifted data kind `Shape` defines our 1, 2, and 3 dimension types, used to+declare what shape of data is passed between the layers.++In the MNIST example above, the input layer can be seen to be a two dimensional+(`D2`), image with 28 by 28 pixels. When the first *Convolution* layer runs, it+outputs a three dimensional (`D3`) 24x24x10 image. The last item in the list is+one dimensional (`D1`) with 10 values, representing the categories of the MNIST+data.++Usage+-----++To perform back propagation, one can call the eponymous function+```haskell+backPropagate :: forall shapes layers.+                 Network layers shapes -> S (Head shapes) -> S (Last shapes) -> Gradients layers+```+which takes a network, appropriate input and target data, and returns the+back propagated gradients for the network. The shapes of the gradients are+appropriate for each layer, and may be trivial for layers like `Rulu` which+have no learnable parameters.++The gradients however can always be applied, yielding a new (hopefully better)+layer with+```haskell+applyUpdate :: LearningParameters -> Network ls ss -> Gradients ls -> Network ls ss+```++Layers in Grenade are represented as Haskell classes, so creating one's own is+easy in downstream code. If the shapes of a network are not specified correctly+and a layer can not sensibly perform the operation between two shapes, then+it will result in a compile time error.++Composition+-----------++Networks and Layers in Grenade are easily composed at the type level. As a `Network`+is an instance of `Layer`, one can use a trained Network as a small component in a+larger network easily. Furthermore, we provide 2 layers which are designed to run+layers in parallel and merge their output (either by concatenating them across one+dimension or summing by pointwise adding their activations). This allows one to+write any Network which can be expressed as a+[series parallel graph](https://en.wikipedia.org/wiki/Series-parallel_graph).++A residual network layer specification for instance could be written as+```haskell+type Residual net = Merge Trivial net+```+If the type `net` is an instance of `Layer`, then `Residual net` will be too. It will+run the network, while retaining its input by passing it through the `Trivial` layer,+and merge the original image with the output.++See the [MNIST](https://github.com/HuwCampbell/grenade/blob/master/examples/main/mnist.hs)+example, which has been overengineered to contain both residual style learning as well+as inception style convolutions.++Generative Adversarial Networks+-------------------------------++As Grenade is purely functional, one can compose its training functions in flexible+ways. [GAN-MNIST](https://github.com/HuwCampbell/grenade/blob/master/examples/main/gan-mnist.hs)+example displays an interesting, type safe way of writing a generative adversarial+training function in 10 lines of code.++Layer Zoo+---------++Grenade layers are normal haskell data types which are an instance of `Layer`, so+it's easy to build one's own downstream code. We do however provide a decent set+of layers, including convolution, deconvolution, pooling, pad, crop, logit, relu,+elu, tanh, and fully connected.++Build Instructions+------------------+Grenade is most easily built with the [mafia](https://github.com/ambiata/mafia)+script that is located in the repository. You will also need the `lapack` and+`blas` libraries and development tools. Once you have all that, Grenade can be+build using:++```+./mafia build+```++and the tests run using:++```+./mafia test+```++Grenade builds with ghc 7.10 and 8.0.++Thanks+------+Writing a library like this has been on my mind for a while now, but a big shout+out must go to [Justin Le](https://github.com/mstksg), whose+[dependently typed fully connected network](https://blog.jle.im/entry/practical-dependent-types-in-haskell-1.html)+inspired me to get cracking, gave many ideas for the type level tools I+needed, and was a great starting point for writing this library.++Performance+-----------+Grenade is backed by hmatrix, BLAS, and LAPACK, with critical functions optimised+in C. Using the im2col trick popularised by Caffe, it should be sufficient for+many problems.++Being purely functional, it should also be easy to run batches in parallel, which+would be appropriate for larger networks, my current examples however are single+threaded.++Training 15 generations over Kaggle's 41000 sample MNIST training set on a single+core took around 12 minutes, achieving 1.5% error rate on a 1000 sample holdout set.++Contributing+------------+Contributions are welcome.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/bench-lstm.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE ScopedTypeVariables   #-}+import Criterion.Main++import           Grenade+import           Grenade.Recurrent+import           Grenade.Layers.Internal.Update++import qualified Numeric.LinearAlgebra.Static as H++main :: IO ()+main = do+  layer60  :: LSTM 40 60  <- createRandom+  layer512 :: LSTM 40 512 <- createRandom+  input40  :: S ('D1 40)  <- randomOfShape+  rec60    :: S ('D1 60)  <- randomOfShape+  rec512   :: S ('D1 512) <- randomOfShape+  (lstm, lstm')  :: (RecNet, RecInput) <- randomRecurrent++  let upIn60   :: H.R 3600    = H.randomVector 1 H.Uniform * 2 - 1+  let upIn512  :: H.R 262144  = H.randomVector 1 H.Uniform * 2 - 1++  defaultMain [+      bgroup "lstm"   [ bench "forwards-60"       $ nf (nfT3 . uncurry  (testRun60   layer60))  (rec60, input40)+                      , bench "forwards-512"      $ nf (nfT3 . uncurry  (testRun512  layer512)) (rec512, input40)+                      , bench "backwards-60"      $ nf (nfT3 . uncurry4 (testRun60'  layer60))  (rec60, input40, rec60, rec60)+                      , bench "backwards-512"     $ nf (nfT3 . uncurry4 (testRun512' layer512)) (rec512, input40, rec512, rec512)+                      ]+    , bgroup "update" [ bench "matrix-60x60"      $ nf (uncurry3 (decendVector 1 1 1)) (upIn60, upIn60, upIn60)+                      , bench "matrix-512x512"    $ nf (uncurry3 (decendVector 1 1 1)) (upIn512, upIn512, upIn512)+                      ]+    , bgroup "train"  [ bench "one-time-step"     $ whnf (nfT2 . trainRecurrent lp lstm lstm') [(input40, Just input40)]+                      , bench "ten-time-steps"    $ whnf (nfT2 . trainRecurrent lp lstm lstm') $ replicate 10 (input40, Just input40)+                      , bench "fifty-time-steps"  $ whnf (nfT2 . trainRecurrent lp lstm lstm') $ replicate 50 (input40, Just input40)+                      ]+    ]++testRun60 :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> ((S ('D1 60), S ('D1 40)), S ('D1 60), S ('D1 60))+testRun60 = runRecurrentForwards++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))+testRun60' = curry . runRecurrentBackwards++testRun512 :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> ((S ('D1 512), S ('D1 40)), S ('D1 512), S ('D1 512))+testRun512 = runRecurrentForwards++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))+testRun512' = curry . runRecurrentBackwards++uncurry4 :: (t -> t1 -> t2 -> t3 -> t4) -> (t, t1, t2, t3) -> t4+uncurry4 f (a,b,c,d) = f a b c d++uncurry3 :: (t -> t1 -> t2 -> t3) -> (t, t1, t2) -> t3+uncurry3 f (a,b,c) = f a b c++nfT2 :: (a, b) -> (a, b)+nfT2 (!a, !b) = (a, b)++nfT3 :: (a, b, c) -> (b, c)+nfT3 (!_, !b, !c) = (b, c)+++type R = Recurrent+type RecNet = RecurrentNetwork '[ R (LSTM 40 512), R (LSTM 512 40) ]+                               '[ 'D1 40, 'D1 512, 'D1 40 ]++type RecInput = RecurrentInputs '[ R (LSTM 40 512), R (LSTM 512 40) ]++lp :: LearningParameters+lp = LearningParameters 0.1 0 0
+ bench/bench.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+import Criterion.Main++import           Grenade++import           Grenade.Layers.Internal.Convolution+import           Grenade.Layers.Internal.Pooling++import           Numeric.LinearAlgebra++main :: IO ()+main = do+  x    :: S ('D2 60 60  )  <- randomOfShape+  y    :: S ('D3 60 60 1)  <- randomOfShape++  defaultMain [+      bgroup "im2col" [ bench "im2col 3x4"     $ whnf (im2col 2 2 1 1)   ((3><4) [1..])+                      , bench "im2col 28x28"   $ whnf (im2col 5 5 1 1)   ((28><28) [1..])+                      , bench "im2col 100x100" $ whnf (im2col 10 10 1 1) ((100><100) [1..])+                      ]+    , bgroup "col2im" [ bench "col2im 3x4"      $ whnf (col2im 2 2 1 1 3 4)       ((6><4) [1..])+                      , bench "col2im 28x28"    $ whnf (col2im 5 5 1 1 28 28)     ((576><25) [1..])+                      , bench "col2im 100x100"  $ whnf (col2im 10 10 1 1 100 100) ((8281><100) [1..])+                      ]+    , bgroup "poolfw" [ bench "poolforwards 3x4"      $ whnf (poolForward 1 3 4 2 2 1 1)     ((3><4) [1..])+                      , bench "poolforwards 28x28"    $ whnf (poolForward 1 28 28 5 5 1 1)    ((28><28) [1..])+                      , bench "poolforwards 100x100"  $ whnf (poolForward 1 100 100 10 10 1 1) ((100><100) [1..])+                      ]+    , bgroup "poolbw" [ bench "poolbackwards 3x4"      $ whnf (poolBackward 1 3 4 2 2 1 1   ((3><4) [1..]))     ((2><3) [1..])+                      , bench "poolbackwards 28x28"    $ whnf (poolBackward 1 28 28 5 5 1 1   ((28><28) [1..]))   ((24><24) [1..])+                      , bench "poolbackwards 100x100"  $ whnf (poolBackward 1 100 100 10 10 1 1 ((100><100) [1..])) ((91><91) [1..])+                      ]+    , bgroup "padcrop" [ bench "pad 2D 60x60"    $ whnf (testRun2D Pad) x+                       , bench "pad 3D 60x60"    $ whnf (testRun3D Pad) y+                       , bench "crop 2D 60x60"   $ whnf (testRun2D' Crop) x+                       , bench "crop 3D 60x60"   $ whnf (testRun3D' Crop) y+                       ]+    ]+++testRun2D :: Pad 1 1 1 1 -> S ('D2 60 60) -> S ('D2 62 62)+testRun2D = snd ... runForwards++testRun3D :: Pad 1 1 1 1 -> S ('D3 60 60 1) -> S ('D3 62 62 1)+testRun3D = snd ... runForwards++testRun2D' :: Crop 1 1 1 1 -> S ('D2 60 60) -> S ('D2 58 58)+testRun2D' = snd ... runForwards++testRun3D' :: Crop 1 1 1 1 -> S ('D3 60 60 1) -> S ('D3 58 58 1)+testRun3D' = snd ... runForwards++(...) :: (a -> b) -> (c -> d -> a) -> c -> d -> b+(...) = (.) . (.)
+ cbits/gradient_decent.c view
@@ -0,0 +1,13 @@+#include "gradient_decent.h"++void decend_cpu(int len, double rate, double momentum, double regulariser,+    const double* weights,+    const double* gradient,+    const double* last,+    double* outputWeights, double* outputMomentum) {++  for (int i = 0; i <= len; i++) {+      outputMomentum[i] = momentum * last[i] - rate * gradient[i];+      outputWeights[i] = weights[i] + outputMomentum[i] - (rate * regulariser) * weights[i];+  }+}
+ cbits/gradient_decent.h view
@@ -0,0 +1,9 @@+#include <stdio.h>+#include <stdint.h>++void decend_cpu(int len, double rate, double momentum, double regulariser,+    const double* weights,+    const double* gradient,+    const double* last,+    double* outputWeights, double* outputMomentum);+
+ cbits/im2col.c view
@@ -0,0 +1,128 @@+#include "im2col.h"++void im2col_cpu(const double* data_im, const int channels,+    const int height, const int width, const int kernel_h, const int kernel_w,+    const int stride_h, const int stride_w,+    double* data_col) {++  const int channel_size = height * width;++  for (int fitting_height = 0; fitting_height <= (height - kernel_h); fitting_height += stride_h) {+    for (int fitting_width = 0; fitting_width <= (width - kernel_w); fitting_width += stride_w) {+      for (int channel = 0; channel < channels; channel++) {+        for (int kernel_row = 0; kernel_row < kernel_h; kernel_row++) {+          for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {+            int input_row = fitting_height + kernel_row;+            int input_col = fitting_width + kernel_col;+            *(data_col++) = data_im[input_row * width + input_col + channel_size * channel];+          }+        }+      }+    }+  }+}++void col2im_cpu(const double* data_col, const int channels,+    const int height, const int width, const int kernel_h, const int kernel_w,+    const int stride_h, const int stride_w,+    double* data_im) {++  memset(data_im, 0, height * width * channels * sizeof(double));++  const int channel_size = height * width;++  for (int fitting_height = 0; fitting_height <= (height - kernel_h); fitting_height += stride_h) {+    for (int fitting_width = 0; fitting_width <= (width - kernel_w); fitting_width += stride_w) {+      for (int channel = 0; channel < channels; channel++) {+        for (int kernel_row = 0; kernel_row < kernel_h; kernel_row++) {+          for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {+            int input_row = fitting_height + kernel_row;+            int input_col = fitting_width + kernel_col;+            data_im[input_row * width + input_col + channel_size * channel] += *(data_col++);+          }+        }+      }+    }+  }+}++inline double max ( double a, double b ) { return a > b ? a : b; }++void pool_forwards_cpu(const double* data_im, const int channels,+    const int height, const int width, const int kernel_h, const int kernel_w,+    const int stride_h, const int stride_w,+    double* data_pooled) {++  const int channel_size = height * width;++  for (int channel = 0; channel < channels; channel++) {+    for (int fitting_height = 0; fitting_height <= (height - kernel_h); fitting_height += stride_h) {+      for (int fitting_width = 0; fitting_width <= (width - kernel_w); fitting_width += stride_w) {+        // Start with the value in 0,0+        int    max_index = fitting_height * width + fitting_width + channel_size * channel;+        double max_value = data_im[max_index];+        // Initial row, skipping the corner we've done+        for (int kernel_col = 1; kernel_col < kernel_w; kernel_col++) {+          int    input_row  = fitting_height;+          int    input_col  = fitting_width + kernel_col;+          int    data_index = input_row * width + input_col + channel_size * channel;+          double data_value = data_im[data_index];+          max_value = max ( max_value, data_value );+        }+        // The remaining rows+        for (int kernel_row = 1; kernel_row < kernel_h; kernel_row++) {+          for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {+            int    input_row = fitting_height + kernel_row;+            int    input_col = fitting_width + kernel_col;+            int    data_index = input_row * width + input_col + channel_size * channel;+            double data_value = data_im[data_index];+            max_value = max ( max_value, data_value );+          }+        }+        *(data_pooled++) = max_value;+      }+    }+  }+}++void pool_backwards_cpu(const double* data_im, const double* data_pooled,+    const int channels, const int height, const int width, const int kernel_h,+    const int kernel_w, const int stride_h, const int stride_w,+    double* data_backgrad ) {++  memset(data_backgrad, 0, height * width * channels * sizeof(double));++  const int channel_size = height * width;++  for (int channel = 0; channel < channels; channel++) {+    for (int fitting_height = 0; fitting_height <= (height - kernel_h); fitting_height += stride_h) {+      for (int fitting_width = 0; fitting_width <= (width - kernel_w); fitting_width += stride_w) {+        int    max_index = fitting_height * width + fitting_width + channel_size * channel;+        double max_value = data_im[max_index];+        for (int kernel_col = 1; kernel_col < kernel_w; kernel_col++) {+          int    input_row  = fitting_height;+          int    input_col  = fitting_width + kernel_col;+          int    data_index = input_row * width + input_col + channel_size * channel;+          double data_value = data_im[data_index];+          if ( data_value > max_value )  {+              max_index = data_index;+              max_value = data_value;+          }+        }+        for (int kernel_row = 1; kernel_row < kernel_h; kernel_row++) {+          for (int kernel_col = 0; kernel_col < kernel_w; kernel_col++) {+            int    input_row = fitting_height + kernel_row;+            int    input_col = fitting_width + kernel_col;+            int    data_index = input_row * width + input_col + channel_size * channel;+            double data_value = data_im[data_index];+            if ( data_value > max_value )  {+              max_index = data_index;+              max_value = data_value;+            }+          }+        }+        data_backgrad[max_index] += *(data_pooled++);+      }+    }+  }+}
+ cbits/im2col.h view
@@ -0,0 +1,23 @@+#include <stdio.h>+#include <stdint.h>+#include <string.h>++void im2col_cpu(const double* data_im, const int channels,+    const int height, const int width, const int kernel_h, const int kernel_w,+    const int stride_h, const int stride_w,+    double* data_col);++void col2im_cpu(const double* data_col, const int channels,+    const int height, const int width, const int kernel_h, const int kernel_w,+    const int stride_h, const int stride_w,+    double* data_im);++void pool_forwards_cpu(const double* data_im, const int channels,+    const int height, const int width, const int kernel_h, const int kernel_w,+    const int stride_h, const int stride_w,+    double* data_pooled);++void pool_backwards_cpu(const double* data_im, const double* data_pooled,+    const int channels, const int height, const int width, const int kernel_h,+    const int kernel_w, const int stride_h, const int stride_w,+    double* data_backgrad );
+ cbits/pad.c view
@@ -0,0 +1,39 @@+#include "pad.h"++void pad_cpu(double* data, const int channels,+    const int height, const int width, const int pad_left, const int pad_top,+    const int pad_right, const int pad_bottom,+    double* data_padded) {++  const int pad_width  = width + pad_left + pad_right;+  const int pad_height = height + pad_top + pad_bottom;++  memset(data_padded, 0, pad_height * pad_width * channels * sizeof(double));++  for (int channel = 0; channel < channels; channel++) {+    double* px = data_padded + (pad_width * pad_top + pad_left) + channel * (pad_width * pad_height);+    for (int y = 0; y < height; y++) {+      memcpy(px, data, sizeof(double) * width);+      px += pad_width;+      data += width;+    }+  }+}++void crop_cpu(double* data, const int channels,+    const int height, const int width, const int crop_left, const int crop_top,+    const int crop_right, const int crop_bottom,+    double* data_cropped) {++  const int crop_width  = width + crop_left + crop_right;+  const int crop_height = height + crop_top + crop_bottom;++  for (int channel = 0; channel < channels; channel++) {+    double* px = data + (crop_width * crop_top + crop_left) + channel * (crop_width * crop_height);+    for (int y = 0; y < height; y++) {+      memcpy(data_cropped, px, sizeof(double) * width);+      px += crop_width;+      data_cropped += width;+    }+  }+}
+ cbits/pad.h view
@@ -0,0 +1,13 @@+#include <stdio.h>+#include <stdint.h>+#include <string.h>++void pad_cpu(double* data_im, const int channels,+    const int height, const int width, const int pad_left, const int pad_top,+    const int pad_right, const int pad_bottom,+    double* data_col);++void crop_cpu(double* data_im, const int channels,+    const int height, const int width, const int crop_left, const int crop_top,+    const int crop_right, const int crop_bottom,+    double* data_col);
+ grenade.cabal view
@@ -0,0 +1,199 @@+name:                  grenade+version:               0.1.0+license:               BSD2+license-file:          LICENSE+author:                Huw Campbell <huw.campbell@gmail.com>+maintainer:            Huw Campbell <huw.campbell@gmail.com>+copyright:             (c) 2016-2017 Huw Campbell.+synopsis:              Practical Deep Learning in Haskell+category:              AI, Machine Learning+cabal-version:         >= 1.8+build-type:            Simple+description:+    Grenade is a composable, dependently typed, practical, and fast+    recurrent neural network library for precise specifications and+    complex deep neural networks in Haskell.+    .+    Grenade provides an API for composing layers of a neural network+    into a sequence parallel graph in a type safe manner; running+    networks with reverse automatic differentiation to calculate their+    gradients; and applying gradient decent for learning.+    .+    Documentation and examples are available on github+    <https://github.com/HuwCampbell/grenade>.++extra-source-files:+  README.md+  cbits/im2col.h+  cbits/im2col.c+  cbits/gradient_decent.h+  cbits/gradient_decent.c+  cbits/pad.h+  cbits/pad.c++source-repository head+  type: git+  location: https://github.com/HuwCampbell/grenade.git++library+  build-depends:+                       base                            >= 4.8         && < 5+                     , bytestring                      == 0.10.*+                     , containers                      >= 0.5         && < 0.6+                     , cereal                          >= 0.5         && < 0.6+                     , deepseq                         >= 1.4         && < 1.5+                     , exceptions                      == 0.8.*+                     , hmatrix                         == 0.18.*+                     , MonadRandom                     >= 0.4         && < 0.6+                     , mtl                             >= 2.2.1       && < 2.3+                     , primitive                       >= 0.6         && < 0.7+                     , text                            == 1.2.*+                     , singletons                      >= 2.1         && < 2.3+                     , vector                          >= 0.11        && < 0.13++  ghc-options:+                       -Wall+  hs-source-dirs:+                       src++  if impl(ghc < 8.0)+    ghc-options:       -fno-warn-incomplete-patterns+++  exposed-modules:+                       Grenade+                       Grenade.Core+                       Grenade.Core.Layer+                       Grenade.Core.LearningParameters+                       Grenade.Core.Network+                       Grenade.Core.Runner+                       Grenade.Core.Shape++                       Grenade.Layers+                       Grenade.Layers.Concat+                       Grenade.Layers.Convolution+                       Grenade.Layers.Crop+                       Grenade.Layers.Deconvolution+                       Grenade.Layers.Dropout+                       Grenade.Layers.Elu+                       Grenade.Layers.FullyConnected+                       Grenade.Layers.Inception+                       Grenade.Layers.Logit+                       Grenade.Layers.Merge+                       Grenade.Layers.Pad+                       Grenade.Layers.Pooling+                       Grenade.Layers.Relu+                       Grenade.Layers.Reshape+                       Grenade.Layers.Softmax+                       Grenade.Layers.Tanh+                       Grenade.Layers.Trivial++                       Grenade.Layers.Internal.Convolution+                       Grenade.Layers.Internal.Pad+                       Grenade.Layers.Internal.Pooling+                       Grenade.Layers.Internal.Update++                       Grenade.Recurrent++                       Grenade.Recurrent.Core+                       Grenade.Recurrent.Core.Layer+                       Grenade.Recurrent.Core.Network+                       Grenade.Recurrent.Core.Runner++                       Grenade.Recurrent.Layers+                       Grenade.Recurrent.Layers.BasicRecurrent+                       Grenade.Recurrent.Layers.LSTM++                       Grenade.Utils.OneHot++  includes:            cbits/im2col.h+                       cbits/gradient_decent.h+                       cbits/pad.h+  c-sources:           cbits/im2col.c+                       cbits/gradient_decent.c+                       cbits/pad.c++  cc-options:          -std=c99 -O3 -msse4.2 -Wall -Werror -DCABAL=1++test-suite test+  type:                exitcode-stdio-1.0++  main-is:             test.hs++  ghc-options:         -Wall -threaded -O2++  hs-source-dirs:+                       test+++  other-modules:       Test.Hedgehog.Compat+                       Test.Hedgehog.Hmatrix+                       Test.Hedgehog.TypeLits++                       Test.Grenade.Network+                       Test.Grenade.Layers.Convolution+                       Test.Grenade.Layers.FullyConnected+                       Test.Grenade.Layers.Nonlinear+                       Test.Grenade.Layers.PadCrop+                       Test.Grenade.Layers.Pooling+                       Test.Grenade.Layers.Internal.Convolution+                       Test.Grenade.Layers.Internal.Pooling+                       Test.Grenade.Layers.Internal.Reference++                       Test.Grenade.Recurrent.Layers.LSTM+                       Test.Grenade.Recurrent.Layers.LSTM.Reference++  if impl(ghc < 8.0)+    ghc-options:       -fno-warn-incomplete-patterns++  build-depends:+                       base                            >= 4.8         && < 5+                     , grenade+                     , hedgehog                        >= 0.1         && < 0.2+                     , hmatrix+                     , mtl+                     , singletons+                     , text                            == 1.2.*+                     , typelits-witnesses+                     , transformers+                     , constraints+                     , MonadRandom+                     , random+                     , ad+                     , reflection+                     , vector+++benchmark bench+  type:                exitcode-stdio-1.0++  main-is:             bench.hs++  ghc-options:         -Wall -threaded -O2++  hs-source-dirs:+                       bench++  build-depends:+                       base                            >= 3          && < 5+                     , bytestring                      == 0.10.*+                     , criterion                       == 1.1.*+                     , grenade+                     , hmatrix++benchmark bench-lstm+  type:                exitcode-stdio-1.0++  main-is:             bench-lstm.hs++  ghc-options:         -Wall -threaded -O2++  hs-source-dirs:+                       bench++  build-depends:+                       base                            >= 3          && < 5+                     , bytestring                      == 0.10.*+                     , criterion                       == 1.1.*+                     , grenade+                     , hmatrix
+ src/Grenade.hs view
@@ -0,0 +1,53 @@+module Grenade (+  -- | This is an empty module which simply re-exports public definitions+  --   for machine learning with Grenade.++  -- * Exported modules+  --+  -- | The core types and runners for Grenade.+    module Grenade.Core++  -- | The neural network layer zoo+  , module Grenade.Layers+++    -- * Overview of the library+    -- $library++    -- * Example usage+    -- $example++  ) where++import           Grenade.Core+import           Grenade.Layers++{- $library+Grenade is a purely functional deep learning library.++It provides an expressive type level API for the construction+of complex neural network architectures. Backing this API is and+implementation written using BLAS and LAPACK, mostly provided by+the hmatrix library.++-}++{- $example+A few examples are provided at https://github.com/HuwCampbell/grenade+under the examples folder.++The starting place is to write your neural network type and a+function to create a random layer of that type. The following+is a simple example which runs a logistic regression.++> type MyNet = Network '[ FullyConnected 10 1, Logit ] '[ 'D1 10, 'D1 1, 'D1 1 ]+>+> randomMyNet :: MonadRandom MyNet+> randomMyNet = randomNetwork++The function `randomMyNet` witnesses the `CreatableNetwork`+constraint of the neural network, and in doing so, ensures the network+can be built, and hence, that the architecture is sound.+-}++
+ src/Grenade/Core.hs view
@@ -0,0 +1,13 @@+module Grenade.Core (+    module Grenade.Core.Layer+  , module Grenade.Core.LearningParameters+  , module Grenade.Core.Network+  , module Grenade.Core.Runner+  , module Grenade.Core.Shape+  ) where++import           Grenade.Core.Layer+import           Grenade.Core.LearningParameters+import           Grenade.Core.Network+import           Grenade.Core.Runner+import           Grenade.Core.Shape
+ src/Grenade/Core/Layer.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE FlexibleInstances     #-}+{-|+Module      : Grenade.Core.Layer+Description : Defines the Layer Classes+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental++This module defines what a Layer is in a Grenade+neural network.++There are two classes of interest: `UpdateLayer` and `Layer`.++`UpdateLayer` is required for all types which are used as a layer+in a network. Having no shape information, this class is agnotostic+to the input and output data of the layer.++An instance of `Layer` on the other hand is required for usage in+a neural network, but also specifies the shapes of data that the+network can transform. Multiple instance of `Layer` are permitted+for a single type, to transform different shapes. The `Reshape` layer+for example can act as a flattening layer, and its inverse, projecting+a 1D shape up to 2 or 3 dimensions.++Instances of `Layer` should be as strict as possible, and not emit+runtime errors.+-}+module Grenade.Core.Layer (+    Layer (..)+  , UpdateLayer (..)+  ) where++import           Control.Monad.Random ( MonadRandom )++import           Data.List ( foldl' )++import           Grenade.Core.Shape+import           Grenade.Core.LearningParameters++-- | Class for updating a layer. All layers implement this, as it+--   describes how to create and update the layer.+--+class UpdateLayer x where+  -- | The type for the gradient for this layer.+  --   Unit if there isn't a gradient to pass back.+  type Gradient x :: *++  -- | Update a layer with its gradient and learning parameters+  runUpdate       :: LearningParameters -> x -> Gradient x -> x++  -- | Create a random layer, many layers will use pure+  createRandom    :: MonadRandom m => m x++  -- | Update a layer with many Gradients+  runUpdates      :: LearningParameters -> x -> [Gradient x] -> x+  runUpdates rate = foldl' (runUpdate rate)++  {-# MINIMAL runUpdate, createRandom #-}++-- | Class for a layer. All layers implement this, however, they don't+--   need to implement it for all shapes, only ones which are+--   appropriate.+--+class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where+  -- | The Wengert tape for this layer. Includes all that is required+  --   to generate the back propagated gradients efficiently. As a+  --   default, `S i` is fine.+  type Tape x i o :: *++  -- | Used in training and scoring. Take the input from the previous+  --   layer, and give the output from this layer.+  runForwards    :: x -> S i -> (Tape x i o, S o)++  -- | Back propagate a step. Takes the current layer, the input that+  --   the layer gave from the input and the back propagated derivatives+  --   from the layer above.+  --+  --   Returns the gradient layer and the derivatives to push back+  --   further.+  runBackwards   :: x -> Tape x i o -> S o -> (Gradient x, S i)
+ src/Grenade/Core/LearningParameters.hs view
@@ -0,0 +1,21 @@+{-|+Module      : Grenade.Core.LearningParameters+Description : Stochastic gradient descent learning parameters+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Core.LearningParameters (+  -- | This module contains learning algorithm specific+  --   code. Currently, this module should be consifered+  --   unstable, due to issue #26.++    LearningParameters (..)+  ) where++-- | Learning parameters for stochastic gradient descent.+data LearningParameters = LearningParameters {+    learningRate :: Double+  , learningMomentum :: Double+  , learningRegulariser :: Double+  } deriving (Eq, Show)
+ src/Grenade/Core/Network.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-|+Module      : Grenade.Core.Network+Description : Core definition of a Neural Network+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental++This module defines the core data types and functions+for non-recurrent neural networks.+-}++module Grenade.Core.Network (+    Network (..)+  , Gradients (..)+  , Tapes (..)++  , runNetwork+  , runGradient+  , applyUpdate++  , randomNetwork+  ) where++import           Control.Monad.Random ( MonadRandom )++import           Data.Singletons+import           Data.Singletons.Prelude+import           Data.Serialize++import           Grenade.Core.Layer+import           Grenade.Core.LearningParameters+import           Grenade.Core.Shape++-- | Type of a network.+--+--   The @[*]@ type specifies the types of the layers.+--+--   The @[Shape]@ type specifies the shapes of data passed between the layers.+--+--   Can be considered to be a heterogeneous list of layers which are able to+--   transform the data shapes of the network.+data Network :: [*] -> [Shape] -> * where+    NNil  :: SingI i+          => Network '[] '[i]++    (:~>) :: (SingI i, SingI h, Layer x i h)+          => !x+          -> !(Network xs (h ': hs))+          -> Network (x ': xs) (i ': h ': hs)+infixr 5 :~>++instance Show (Network '[] '[i]) where+  show NNil = "NNil"+instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) where+  show (x :~> xs) = show x ++ "\n~>\n" ++ show xs++-- | Gradient of a network.+--+--   Parameterised on the layers of the network.+data Gradients :: [*] -> * where+   GNil  :: Gradients '[]++   (:/>) :: UpdateLayer x+         => Gradient x+         -> Gradients xs+         -> Gradients (x ': xs)++-- | Wegnert Tape of a network.+--+--   Parameterised on the layers and shapes of the network.+data Tapes :: [*] -> [Shape] -> * where+   TNil  :: SingI i+         => Tapes '[] '[i]++   (:\>) :: (SingI i, SingI h, Layer x i h)+         => !(Tape x i h)+         -> !(Tapes xs (h ': hs))+         -> Tapes (x ': xs) (i ': h ': hs)+++-- | Running a network forwards with some input data.+--+--   This gives the output, and the Wengert tape required for back+--   propagation.+runNetwork :: forall layers shapes.+              Network layers shapes+           -> S (Head shapes)+           -> (Tapes layers shapes, S (Last shapes))+runNetwork =+  go+    where+  go  :: forall js ss. (Last js ~ Last shapes)+      => Network ss js+      -> S (Head js)+      -> (Tapes ss js, S (Last js))+  go (layer :~> n) !x =+    let (tape, forward) = runForwards layer x+        (tapes, answer) = go n forward+    in  (tape :\> tapes, answer)++  go NNil !x+      = (TNil, x)+++-- | Running a loss gradient back through the network.+--+--   This requires a Wengert tape, generated with the appropriate input+--   for the loss.+--+--   Gives the gradients for the layer, and the gradient across the+--   input (which may not be required).+runGradient :: forall layers shapes.+               Network layers shapes+            -> Tapes layers shapes+            -> S (Last shapes)+            -> (Gradients layers, S (Head shapes))+runGradient net tapes o =+  go net tapes+    where+  go  :: forall js ss. (Last js ~ Last shapes)+      => Network ss js+      -> Tapes ss js+      -> (Gradients ss, S (Head js))+  go (layer :~> n) (tape :\> nt) =+    let (gradients, feed)  = go n nt+        (layer', backGrad) = runBackwards layer tape feed+    in  (layer' :/> gradients, backGrad)++  go NNil TNil+      = (GNil, o)+++-- | Apply one step of stochastic gradient decent across the network.+applyUpdate :: LearningParameters+            -> Network layers shapes+            -> Gradients layers+            -> Network layers shapes+applyUpdate rate (layer :~> rest) (gradient :/> grest)+  = runUpdate rate layer gradient :~> applyUpdate rate rest grest++applyUpdate _ NNil GNil+  = NNil++-- | A network can easily be created by hand with (:~>), but an easy way to+--   initialise a random network is with the randomNetwork.+class CreatableNetwork (xs :: [*]) (ss :: [Shape]) where+  -- | Create a network with randomly initialised weights.+  --+  --   Calls to this function will not compile if the type of the neural+  --   network is not sound.+  randomNetwork :: MonadRandom m => m (Network xs ss)++instance SingI i => CreatableNetwork '[] '[i] where+  randomNetwork = return NNil++instance (SingI i, SingI o, Layer x i o, CreatableNetwork xs (o ': rs)) => CreatableNetwork (x ': xs) (i ': o ': rs) where+  randomNetwork = (:~>) <$> createRandom <*> randomNetwork++-- | Add very simple serialisation to the network+instance SingI i => Serialize (Network '[] '[i]) where+  put NNil = pure ()+  get = return NNil++instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o ': rs))) => Serialize (Network (x ': xs) (i ': o ': rs)) where+  put (x :~> r) = put x >> put r+  get = (:~>) <$> get <*> get+++-- | Ultimate composition.+--+--   This allows a complete network to be treated as a layer in a larger network.+instance CreatableNetwork sublayers subshapes => UpdateLayer (Network sublayers subshapes) where+  type Gradient (Network sublayers subshapes) = Gradients sublayers+  runUpdate    = applyUpdate+  createRandom = randomNetwork++-- | Ultimate composition.+--+--   This allows a complete network to be treated as a layer in a larger network.+instance (CreatableNetwork sublayers subshapes, i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (Network sublayers subshapes) i o where+  type Tape (Network sublayers subshapes) i o = Tapes sublayers subshapes+  runForwards  = runNetwork+  runBackwards = runGradient
+ src/Grenade/Core/Runner.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-|+Module      : Grenade.Core.Runner+Description : Functions to perform training and backpropagation+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Core.Runner (+    train+  , backPropagate+  , runNet+  ) where++import           Data.Singletons.Prelude++import           Grenade.Core.LearningParameters+import           Grenade.Core.Network+import           Grenade.Core.Shape++-- | Perform reverse automatic differentiation on the network+--   for the current input and expected output.+--+--   /Note:/ The loss function pushed backwards is appropriate+--   for both regression and classification as a squared loss+--   or log-loss respectively.+--+--   For other loss functions, use runNetwork and runGradient+--   with the back propagated gradient of your loss.+--+backPropagate :: SingI (Last shapes)+              => Network layers shapes+              -> S (Head shapes)+              -> S (Last shapes)+              -> Gradients layers+backPropagate network input target =+    let (tapes, output) = runNetwork network input+        (grads, _)      = runGradient network tapes (output - target)+    in  grads+++-- | Update a network with new weights after training with an instance.+train :: SingI (Last shapes)+      => LearningParameters+      -> Network layers shapes+      -> S (Head shapes)+      -> S (Last shapes)+      -> Network layers shapes+train rate network input output =+    let grads = backPropagate network input output+    in  applyUpdate rate network grads+++-- | Run the network with input and return the given output.+runNet :: Network layers shapes -> S (Head shapes) -> S (Last shapes)+runNet net = snd . runNetwork net
+ src/Grenade/Core/Shape.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE RankNTypes            #-}+{-|+Module      : Grenade.Core.Shape+Description : Dependently typed shapes of data which are passed between layers of a network+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+++-}+module Grenade.Core.Shape (+    Shape (..)+  , S (..)+  , Sing (..)++  , randomOfShape+  , fromStorable+  ) where++import           Control.DeepSeq (NFData (..))+import           Control.Monad.Random ( MonadRandom, getRandom )++import           Data.Proxy+import           Data.Singletons+import           Data.Singletons.TypeLits+import           Data.Vector.Storable ( Vector )+import qualified Data.Vector.Storable as V++import           GHC.TypeLits++import qualified Numeric.LinearAlgebra.Static as H+import           Numeric.LinearAlgebra.Static+import qualified Numeric.LinearAlgebra as NLA++-- | The current shapes we accept.+--   at the moment this is just one, two, and three dimensional+--   Vectors/Matricies.+--+--   These are only used with DataKinds, as Kind `Shape`, with Types 'D1, 'D2, 'D3.+data Shape+  = D1 Nat+  -- ^ One dimensional vector+  | D2 Nat Nat+  -- ^ Two dimensional matrix. Row, Column.+  | D3 Nat Nat Nat+  -- ^ Three dimensional matrix. Row, Column, Channels.++-- | Concrete data structures for a Shape.+--+--   All shapes are held in contiguous memory.+--   3D is held in a matrix (usually row oriented) which has height depth * rows.+data S (n :: Shape) where+  S1D :: ( KnownNat len )+      => R len+      -> S ('D1 len)++  S2D :: ( KnownNat rows, KnownNat columns )+      => L rows columns+      -> S ('D2 rows columns)++  S3D :: ( KnownNat rows+         , KnownNat columns+         , KnownNat depth+         , KnownNat (rows * depth))+      => L (rows * depth) columns+      -> S ('D3 rows columns depth)++deriving instance Show (S n)++-- Singleton instances.+--+-- These could probably be derived with template haskell, but this seems+-- clear and makes adding the KnownNat constraints simple.+-- We can also keep our code TH free, which is great.+data instance Sing (n :: Shape) where+  D1Sing :: Sing a -> Sing ('D1 a)+  D2Sing :: Sing a -> Sing b -> Sing ('D2 a b)+  D3Sing :: KnownNat (a * c) => Sing a -> Sing b -> Sing c -> Sing ('D3 a b c)++instance KnownNat a => SingI ('D1 a) where+  sing = D1Sing sing+instance (KnownNat a, KnownNat b) => SingI ('D2 a b) where+  sing = D2Sing sing sing+instance (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => SingI ('D3 a b c) where+  sing = D3Sing sing sing sing++instance SingI x => Num (S x) where+  (+) = n2 (+)+  (-) = n2 (-)+  (*) = n2 (*)+  abs = n1 abs+  signum = n1 signum+  fromInteger x = nk (fromInteger x)++instance SingI x => Fractional (S x) where+  (/) = n2 (/)+  recip = n1 recip+  fromRational x = nk (fromRational x)++instance SingI x => Floating (S x) where+  pi = nk pi+  exp = n1 exp+  log = n1 log+  sqrt = n1 sqrt+  (**) = n2 (**)+  logBase = n2 logBase+  sin = n1 sin+  cos = n1 cos+  tan = n1 tan+  asin = n1 asin+  acos = n1 acos+  atan = n1 atan+  sinh = n1 sinh+  cosh = n1 cosh+  tanh = n1 tanh+  asinh = n1 asinh+  acosh = n1 acosh+  atanh = n1 atanh++--+-- I haven't made shapes strict, as sometimes they're not needed+-- (the last input gradient back for instance)+--+instance NFData (S x) where+  rnf (S1D x) = rnf x+  rnf (S2D x) = rnf x+  rnf (S3D x) = rnf x++-- | Generate random data of the desired shape+randomOfShape :: forall x m. ( MonadRandom m, SingI x ) => m (S x)+randomOfShape = do+  seed :: Int <- getRandom+  return $ case (sing :: Sing x) of+    D1Sing l ->+      withKnownNat l $+        S1D (randomVector  seed Uniform * 2 - 1)++    D2Sing r c ->+      withKnownNat r $ withKnownNat c $+        S2D (uniformSample seed (-1) 1)++    D3Sing r c d ->+      withKnownNat r $ withKnownNat c $ withKnownNat d $+        S3D (uniformSample seed (-1) 1)++-- | Generate a shape from a Storable Vector.+--+--   Returns Nothing if the vector is of the wrong size.+fromStorable :: forall x. SingI x => Vector Double -> Maybe (S x)+fromStorable xs = case sing :: Sing x of+    D1Sing l ->+      withKnownNat l $+        S1D <$> H.create xs++    D2Sing r c ->+      withKnownNat r $ withKnownNat c $+        S2D <$> mkL xs++    D3Sing r c d ->+      withKnownNat r $ withKnownNat c $ withKnownNat d $+        S3D <$> mkL xs+  where+    mkL :: forall rows columns. (KnownNat rows, KnownNat columns)+        => Vector Double -> Maybe (L rows columns)+    mkL v =+      let rows    = fromIntegral $ natVal (Proxy :: Proxy rows)+          columns = fromIntegral $ natVal (Proxy :: Proxy columns)+      in  if rows * columns == V.length v+             then H.create $ NLA.reshape columns v+             else Nothing++-- Helper function for creating the number instances+n1 :: ( forall a. Floating a => a -> a ) -> S x -> S x+n1 f (S1D x) = S1D (f x)+n1 f (S2D x) = S2D (f x)+n1 f (S3D x) = S3D (f x)++-- Helper function for creating the number instances+n2 :: ( forall a. Floating a => a -> a -> a ) -> S x -> S x -> S x+n2 f (S1D x) (S1D y) = S1D (f x y)+n2 f (S2D x) (S2D y) = S2D (f x y)+n2 f (S3D x) (S3D y) = S3D (f x y)++-- Helper function for creating the number instances+nk :: forall x. SingI x => Double -> S x+nk x = case (sing :: Sing x) of+  D1Sing l ->+    withKnownNat l $+      S1D (konst x)++  D2Sing r c ->+    withKnownNat r $ withKnownNat c $+      S2D (konst x)++  D3Sing r c d ->+    withKnownNat r $ withKnownNat c $ withKnownNat d $+      S3D (konst x)
+ src/Grenade/Layers.hs view
@@ -0,0 +1,35 @@+module Grenade.Layers (+    module Grenade.Layers.Concat+  , module Grenade.Layers.Convolution+  , module Grenade.Layers.Crop+  , module Grenade.Layers.Deconvolution+  , module Grenade.Layers.Elu+  , module Grenade.Layers.FullyConnected+  , module Grenade.Layers.Inception+  , module Grenade.Layers.Logit+  , module Grenade.Layers.Merge+  , module Grenade.Layers.Pad+  , module Grenade.Layers.Pooling+  , module Grenade.Layers.Reshape+  , module Grenade.Layers.Relu+  , module Grenade.Layers.Softmax+  , module Grenade.Layers.Tanh+  , module Grenade.Layers.Trivial+  ) where++import           Grenade.Layers.Concat+import           Grenade.Layers.Convolution+import           Grenade.Layers.Crop+import           Grenade.Layers.Deconvolution+import           Grenade.Layers.Elu+import           Grenade.Layers.Pad+import           Grenade.Layers.FullyConnected+import           Grenade.Layers.Inception+import           Grenade.Layers.Logit+import           Grenade.Layers.Merge+import           Grenade.Layers.Pooling+import           Grenade.Layers.Reshape+import           Grenade.Layers.Relu+import           Grenade.Layers.Softmax+import           Grenade.Layers.Tanh+import           Grenade.Layers.Trivial
+ src/Grenade/Layers/Concat.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-|+Module      : Grenade.Layers.Concat+Description : Concatenation layer+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental++This module provides the concatenation layer, which runs two chilld layers in parallel and combines their outputs.+-}+module Grenade.Layers.Concat (+    Concat (..)+  ) where++import           Data.Serialize++import           Data.Singletons+import           GHC.TypeLits++import           Grenade.Core++import           Numeric.LinearAlgebra.Static ( row, (===), splitRows, unrow, (#), split, R )++-- | A Concatentating Layer.+--+-- This layer shares it's input state between two sublayers, and concatenates their output.+--+-- With Networks able to be Layers, this allows for very expressive composition of complex Networks.+--+-- The Concat layer has a few instances, which allow one to flexibly "bash" together the outputs.+--+-- Two 1D vectors, can go to a 2D shape with 2 rows if their lengths are identical.+-- Any 2 1D vectors can also become a longer 1D Vector.+--+-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad+-- and Crop layers to ensure this is the case.+data Concat :: Shape -> * -> Shape -> * -> * where+  Concat :: x -> y -> Concat m x n y++instance (Show x, Show y) => Show (Concat m x n y) where+  show (Concat x y) = "Concat\n" ++ show x ++ "\n" ++ show y++-- | Run two layers in parallel, combining their outputs.+instance (UpdateLayer x, UpdateLayer y) => UpdateLayer (Concat m x n y) where+  type Gradient (Concat m x n y) = (Gradient x, Gradient y)+  runUpdate lr (Concat x y) (x', y') = Concat (runUpdate lr x x') (runUpdate lr y y')+  createRandom = Concat <$> createRandom <*> createRandom++instance ( SingI i+         , Layer x i ('D1 o)+         , Layer y i ('D1 o)+         ) => Layer (Concat ('D1 o) x ('D1 o) y) i ('D2 2 o) where+  type Tape (Concat ('D1 o) x ('D1 o) y) i ('D2 2 o) = (Tape x i ('D1 o), Tape y i ('D1 o))++  runForwards (Concat x y) input =+    let (xT, xOut :: S ('D1 o)) = runForwards x input+        (yT, yOut :: S ('D1 o)) = runForwards y input+    in case (xOut, yOut) of+        (S1D xOut', S1D yOut') ->+            ((xT, yT), S2D (row xOut' === row yOut'))++  runBackwards (Concat x y) (xTape, yTape) (S2D o) =+    let (ox, oy) = splitRows o+        (x', xB :: S i) = runBackwards x xTape (S1D $ unrow ox)+        (y', yB :: S i) = runBackwards y yTape (S1D $ unrow oy)+    in  ((x', y'), xB + yB)++instance ( SingI i+         , Layer x i ('D1 m)+         , Layer y i ('D1 n)+         , KnownNat o+         , KnownNat m+         , KnownNat n+         , o ~ (m + n)+         , n ~ (o - m)+         , (m <=? o) ~ 'True+         ) => Layer (Concat ('D1 m) x ('D1 n) y) i ('D1 o) where+  type Tape (Concat ('D1 m) x ('D1 n) y) i ('D1 o) = (Tape x i ('D1 m), Tape y i ('D1 n))++  runForwards (Concat x y) input =+    let (xT, xOut :: S ('D1 m)) = runForwards x input+        (yT, yOut :: S ('D1 n)) = runForwards y input+    in case (xOut, yOut) of+        (S1D xOut', S1D yOut') ->+            ((xT, yT), S1D (xOut' # yOut'))++  runBackwards (Concat x y) (xTape, yTape) (S1D o) =+    let (ox :: R m , oy :: R n) = split o+        (x', xB :: S i) = runBackwards x xTape (S1D ox)+        (y', yB :: S i) = runBackwards y yTape (S1D oy)+    in  ((x', y'), xB + yB)++-- | Concat 3D shapes, increasing the number of channels.+instance ( SingI i+         , Layer x i ('D3 rows cols m)+         , Layer y i ('D3 rows cols n)+         , KnownNat (rows * n)+         , KnownNat (rows * m)+         , KnownNat (rows * o)+         , KnownNat o+         , KnownNat m+         , KnownNat n+         , ((rows * m) + (rows * n)) ~ (rows * o)+         , ((rows * o) - (rows * m)) ~ (rows * n)+         , ((rows * m) <=? (rows * o)) ~ 'True+         ) => Layer (Concat ('D3 rows cols m) x ('D3 rows cols n) y) i ('D3 rows cols o) where+  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))++  runForwards (Concat x y) input =+    let (xT, xOut :: S ('D3 rows cols m)) = runForwards x input+        (yT, yOut :: S ('D3 rows cols n)) = runForwards y input+    in case (xOut, yOut) of+        (S3D xOut', S3D yOut') ->+            ((xT, yT), S3D (xOut' === yOut'))++  runBackwards (Concat x y) (xTape, yTape) (S3D o) =+    let (ox, oy) = splitRows o+        (x', xB :: S i) = runBackwards x xTape (S3D ox :: S ('D3 rows cols m))+        (y', yB :: S i) = runBackwards y yTape (S3D oy :: S ('D3 rows cols n))+    in  ((x', y'), xB + yB)++instance (Serialize a, Serialize b) => Serialize (Concat sa a sb b) where+  put (Concat a b) = put a *> put b+  get = Concat <$> get <*> get
+ src/Grenade/Layers/Convolution.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE FlexibleContexts      #-}+{-|+Module      : Grenade.Layers.Convolution+Description : Convolution layer+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental++This module provides the Convolution layer, which is critical in many computer vision tasks.++-}+module Grenade.Layers.Convolution (+    Convolution (..)+  , Convolution' (..)+  , randomConvolution+  ) where++import           Control.Monad.Random hiding ( fromList )+import           Data.Maybe+import           Data.Proxy+import           Data.Serialize+import           Data.Singletons.TypeLits++import           GHC.TypeLits++import           Numeric.LinearAlgebra hiding ( uniformSample, konst )+import qualified Numeric.LinearAlgebra as LA+import           Numeric.LinearAlgebra.Static hiding ((|||), build, toRows)++import           Grenade.Core+import           Grenade.Layers.Internal.Convolution+import           Grenade.Layers.Internal.Update++-- | A convolution layer for a neural network.+--   This uses the im2col convolution trick popularised by Caffe, which essentially turns the+--   many, many, many, many loop convolution into a single matrix multiplication.+--+--   The convolution layer takes all of the kernels for the convolution, which are flattened+--   and then put into columns in the matrix.+--+--   The kernel size dictates which input and output sizes will "fit". Fitting the equation:+--   `out = (in - kernel) / stride + 1` for both dimensions.+--+--   One probably shouldn't build their own layer, but rather use the randomConvolution function.+data Convolution :: Nat -- Number of channels, for the first layer this could be RGB for instance.+                 -> Nat -- Number of filters, this is the number of channels output by the layer.+                 -> Nat -- The number of rows in the kernel filter+                 -> Nat -- The number of column in the kernel filter+                 -> Nat -- The row stride of the convolution filter+                 -> Nat -- The columns stride of the convolution filter+                 -> * where+  Convolution :: ( KnownNat channels+                 , KnownNat filters+                 , KnownNat kernelRows+                 , KnownNat kernelColumns+                 , KnownNat strideRows+                 , KnownNat strideColumns+                 , KnownNat kernelFlattened+                 , kernelFlattened ~ (kernelRows * kernelColumns * channels))+              => !(L kernelFlattened filters) -- The kernel filter weights+              -> !(L kernelFlattened filters) -- The last kernel update (or momentum)+              -> Convolution channels filters kernelRows kernelColumns strideRows strideColumns++data Convolution' :: Nat -- Number of channels, for the first layer this could be RGB for instance.+                  -> Nat -- Number of filters, this is the number of channels output by the layer.+                  -> Nat -- The number of rows in the kernel filter+                  -> Nat -- The number of column in the kernel filter+                  -> Nat -- The row stride of the convolution filter+                  -> Nat -- The columns stride of the convolution filter+                  -> * where+  Convolution' :: ( KnownNat channels+                  , KnownNat filters+                  , KnownNat kernelRows+                  , KnownNat kernelColumns+                  , KnownNat strideRows+                  , KnownNat strideColumns+                  , KnownNat kernelFlattened+                  , kernelFlattened ~ (kernelRows * kernelColumns * channels))+               => !(L kernelFlattened filters) -- The kernel filter gradient+               -> Convolution' channels filters kernelRows kernelColumns strideRows strideColumns++instance Show (Convolution c f k k' s s') where+  show (Convolution a _) = renderConv a+    where+      renderConv mm =+        let m  = extract mm+            ky = fromIntegral $ natVal (Proxy :: Proxy k)+            rs = LA.toColumns m+            ms = map (take ky) $ toLists . reshape ky <$> rs++            render n'  | n' <= 0.2  = ' '+                       | n' <= 0.4  = '.'+                       | n' <= 0.6  = '-'+                       | n' <= 0.8  = '='+                       | otherwise =  '#'++            px = (fmap . fmap . fmap) render ms+        in unlines $ foldl1 (zipWith (\a' b' -> a' ++ "   |   " ++ b')) $ px++randomConvolution :: ( MonadRandom m+                     , KnownNat channels+                     , KnownNat filters+                     , KnownNat kernelRows+                     , KnownNat kernelColumns+                     , KnownNat strideRows+                     , KnownNat strideColumns+                     , KnownNat kernelFlattened+                     , kernelFlattened ~ (kernelRows * kernelColumns * channels))+                  => m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)+randomConvolution = do+    s     <- getRandom+    let wN = uniformSample s (-1) 1+        mm = konst 0+    return $ Convolution wN mm++instance ( KnownNat channels+         , KnownNat filters+         , KnownNat kernelRows+         , KnownNat kernelColumns+         , KnownNat strideRows+         , KnownNat strideColumns+         , KnownNat (kernelRows * kernelColumns * channels)+         ) => UpdateLayer (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where+  type Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols) = (Convolution' channels filters kernelRows kernelCols strideRows strideCols)+  runUpdate LearningParameters {..} (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =+    let (newKernel, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldKernel kernelGradient oldMomentum+    in Convolution newKernel newMomentum++  createRandom = randomConvolution++instance ( KnownNat channels+         , KnownNat filters+         , KnownNat kernelRows+         , KnownNat kernelColumns+         , KnownNat strideRows+         , KnownNat strideColumns+         , KnownNat (kernelRows * kernelColumns * channels)+         ) => Serialize (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where+  put (Convolution w _) = putListOf put . toList . flatten . extract $ w+  get = do+      let f  = fromIntegral $ natVal (Proxy :: Proxy filters)+      wN    <- maybe (fail "Vector of incorrect size") return . create . reshape f . LA.fromList =<< getListOf get+      let mm = konst 0+      return $ Convolution wN mm++-- | A three dimensional image (or 2d with many channels) can have+--   an appropriately sized convolution filter run across it.+instance ( KnownNat kernelRows+         , KnownNat kernelCols+         , KnownNat filters+         , KnownNat strideRows+         , KnownNat strideCols+         , KnownNat inputRows+         , KnownNat inputCols+         , KnownNat outputRows+         , KnownNat outputCols+         , KnownNat channels+         , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)+         , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)+         , KnownNat (kernelRows * kernelCols * channels)+         , KnownNat (outputRows * filters)+         ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where++  type Tape (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)++  runForwards (Convolution kernel _) (S3D input) =+    let ex = extract input+        ek = extract kernel+        ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)+        kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)+        ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)+        sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)+        sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)+        ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)+        oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)++        c  = vid2col kx ky sx sy ix iy ex+        mt = c LA.<> ek+        r  = col2vid 1 1 1 1 ox oy mt+        rs = fromJust . create $ r+    in  (S3D input, S3D rs)+  runBackwards (Convolution kernel _) (S3D input) (S3D dEdy) =+    let ex = extract input+        ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)+        kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)+        ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)+        sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)+        sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)+        ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)+        oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)++        c  = vid2col kx ky sx sy ix iy ex++        eo = extract dEdy+        ek = extract kernel++        vs = vid2col 1 1 1 1 ox oy eo++        kN = fromJust . create $ tr c LA.<> vs++        dW = vs LA.<> tr ek++        xW = col2vid kx ky sx sy ix iy dW+    in  (Convolution' kN, S3D . fromJust . create $ xW)+++-- | A two dimentional image may have a convolution filter applied to it+instance ( KnownNat kernelRows+         , KnownNat kernelCols+         , KnownNat filters+         , KnownNat strideRows+         , KnownNat strideCols+         , KnownNat inputRows+         , KnownNat inputCols+         , KnownNat outputRows+         , KnownNat outputCols+         , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)+         , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)+         , KnownNat (kernelRows * kernelCols * 1)+         , KnownNat (outputRows * filters)+         ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where+  type Tape (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols 1)+  runForwards c (S2D input) =+    runForwards c (S3D input :: S ('D3 inputRows inputCols 1))++  runBackwards c tape grads =+    case runBackwards c tape grads of+      (c', S3D back :: S ('D3 inputRows inputCols 1)) ->  (c', S2D back)+++-- | A two dimensional image may have a convolution filter applied to it producing+--   a two dimensional image if both channels and filters is 1.+instance ( KnownNat kernelRows+         , KnownNat kernelCols+         , KnownNat strideRows+         , KnownNat strideCols+         , KnownNat inputRows+         , KnownNat inputCols+         , KnownNat outputRows+         , KnownNat outputCols+         , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)+         , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)+         , KnownNat (kernelRows * kernelCols * 1)+         , KnownNat (outputRows * 1)+         ) => Layer (Convolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) where+  type Tape (Convolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols 1)+  runForwards c (S2D input) =+    case runForwards c (S3D input :: S ('D3 inputRows inputCols 1)) of+      (tps, S3D back :: S ('D3 outputRows outputCols 1)) ->  (tps, S2D back)++  runBackwards c tape (S2D grads) =+    case runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1)) of+      (c', S3D back :: S ('D3 inputRows inputCols 1)) -> (c', S2D back)++-- | A three dimensional image can produce a 2D image from a convolution with 1 filter+instance ( KnownNat kernelRows+         , KnownNat kernelCols+         , KnownNat strideRows+         , KnownNat strideCols+         , KnownNat inputRows+         , KnownNat inputCols+         , KnownNat outputRows+         , KnownNat outputCols+         , KnownNat channels+         , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)+         , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)+         , KnownNat (kernelRows * kernelCols * channels)+         , KnownNat (outputRows * 1)+         ) => Layer (Convolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) where+  type Tape (Convolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols channels)+  runForwards c input =+    case runForwards c input of+      (tps, S3D back :: S ('D3 outputRows outputCols 1)) ->  (tps, S2D back)++  runBackwards c tape (S2D grads) =+    runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1))
+ src/Grenade/Layers/Crop.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-|+Module      : Grenade.Layers.Crop+Description : Cropping layer+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Layers.Crop (+    Crop (..)+  ) where++import           Data.Maybe+import           Data.Proxy+import           Data.Singletons.TypeLits+import           GHC.TypeLits++import           Grenade.Core+import           Grenade.Layers.Internal.Pad++import           Numeric.LinearAlgebra (konst, subMatrix, diagBlock)+import           Numeric.LinearAlgebra.Static (extract, create)++-- | A cropping layer for a neural network.+data Crop :: Nat+          -> Nat+          -> Nat+          -> Nat -> * where+  Crop :: Crop cropLeft cropTop cropRight cropBottom++instance Show (Crop cropLeft cropTop cropRight cropBottom) where+  show Crop = "Crop"++instance UpdateLayer (Crop l t r b) where+  type Gradient (Crop l t r b) = ()+  runUpdate _ x _ = x+  createRandom = return Crop++-- | A two dimentional image can be cropped.+instance ( KnownNat cropLeft+         , KnownNat cropTop+         , KnownNat cropRight+         , KnownNat cropBottom+         , KnownNat inputRows+         , KnownNat inputColumns+         , KnownNat outputRows+         , KnownNat outputColumns+         , (inputRows - cropTop - cropBottom) ~ outputRows+         , (inputColumns - cropLeft - cropRight) ~ outputColumns+         ) => Layer (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where+  type Tape (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = ()+  runForwards Crop (S2D input) =+    let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)+        cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)+        nrows = fromIntegral $ natVal (Proxy :: Proxy outputRows)+        ncols = fromIntegral $ natVal (Proxy :: Proxy outputColumns)+        m  = extract input+        r  = subMatrix (cropt, cropl) (nrows, ncols) m+    in  ((), S2D . fromJust . create $ r)+  runBackwards _ _ (S2D dEdy) =+    let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)+        cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)+        cropr = fromIntegral $ natVal (Proxy :: Proxy cropRight)+        cropb = fromIntegral $ natVal (Proxy :: Proxy cropBottom)+        eo    = extract dEdy+        vs    = diagBlock [konst 0 (cropt,cropl), eo, konst 0 (cropb,cropr)]+    in  ((), S2D . fromJust . create $ vs)+++-- | A two dimentional image can be cropped.+instance ( KnownNat cropLeft+         , KnownNat cropTop+         , KnownNat cropRight+         , KnownNat cropBottom+         , KnownNat inputRows+         , KnownNat inputColumns+         , KnownNat outputRows+         , KnownNat outputColumns+         , KnownNat channels+         , KnownNat (inputRows * channels)+         , KnownNat (outputRows * channels)+         , (outputRows + cropTop + cropBottom) ~ inputRows+         , (outputColumns + cropLeft + cropRight) ~ inputColumns+         ) => Layer (Crop cropLeft cropTop cropRight cropBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where+  type Tape (Crop cropLeft cropTop cropRight cropBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels)  = ()+  runForwards Crop (S3D input) =+    let padl  = fromIntegral $ natVal (Proxy :: Proxy cropLeft)+        padt  = fromIntegral $ natVal (Proxy :: Proxy cropTop)+        padr  = fromIntegral $ natVal (Proxy :: Proxy cropRight)+        padb  = fromIntegral $ natVal (Proxy :: Proxy cropBottom)+        inr   = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        inc   = fromIntegral $ natVal (Proxy :: Proxy inputColumns)+        outr  = fromIntegral $ natVal (Proxy :: Proxy outputRows)+        outc  = fromIntegral $ natVal (Proxy :: Proxy outputColumns)+        ch    = fromIntegral $ natVal (Proxy :: Proxy channels)+        m     = extract input+        cropped = crop ch padl padt padr padb outr outc inr inc m+    in  ((), S3D . fromJust . create $ cropped)++  runBackwards Crop () (S3D gradient) =+    let padl  = fromIntegral $ natVal (Proxy :: Proxy cropLeft)+        padt  = fromIntegral $ natVal (Proxy :: Proxy cropTop)+        padr  = fromIntegral $ natVal (Proxy :: Proxy cropRight)+        padb  = fromIntegral $ natVal (Proxy :: Proxy cropBottom)+        inr   = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        inc   = fromIntegral $ natVal (Proxy :: Proxy inputColumns)+        outr  = fromIntegral $ natVal (Proxy :: Proxy outputRows)+        outc  = fromIntegral $ natVal (Proxy :: Proxy outputColumns)+        ch    = fromIntegral $ natVal (Proxy :: Proxy channels)+        m     = extract gradient+        padded = pad ch padl padt padr padb outr outc inr inc m+    in  ((), S3D . fromJust . create $ padded)
+ src/Grenade/Layers/Deconvolution.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE FlexibleContexts      #-}+{-|+Module      : Grenade.Layers.Deconvolution+Description : Deconvolution layer+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental++A deconvolution layer is in many ways a convolution layer in reverse.+It learns a kernel to apply to each pixel location, spreading it out+into a larger layer.++This layer is important for image generation tasks, such as GANs on+images.+-}+module Grenade.Layers.Deconvolution (+    Deconvolution (..)+  , Deconvolution' (..)+  , randomDeconvolution+  ) where++import           Control.Monad.Random hiding ( fromList )+import           Data.Maybe+import           Data.Proxy+import           Data.Serialize+import           Data.Singletons.TypeLits++import           GHC.TypeLits++import           Numeric.LinearAlgebra hiding ( uniformSample, konst )+import qualified Numeric.LinearAlgebra as LA+import           Numeric.LinearAlgebra.Static hiding ((|||), build, toRows)++import           Grenade.Core+import           Grenade.Layers.Internal.Convolution+import           Grenade.Layers.Internal.Update++-- | A Deconvolution layer for a neural network.+--   This uses the im2col Convolution trick popularised by Caffe.+--+--   The Deconvolution layer is a way of spreading out a single response+--   into a larger image, and is useful in generating images.+--+data Deconvolution :: Nat -- Number of channels, for the first layer this could be RGB for instance.+                   -> Nat -- Number of filters, this is the number of channels output by the layer.+                   -> Nat -- The number of rows in the kernel filter+                   -> Nat -- The number of column in the kernel filter+                   -> Nat -- The row stride of the Deconvolution filter+                   -> Nat -- The columns stride of the Deconvolution filter+                   -> * where+  Deconvolution :: ( KnownNat channels+                   , KnownNat filters+                   , KnownNat kernelRows+                   , KnownNat kernelColumns+                   , KnownNat strideRows+                   , KnownNat strideColumns+                   , KnownNat kernelFlattened+                   , kernelFlattened ~ (kernelRows * kernelColumns * filters))+                 => !(L kernelFlattened channels) -- The kernel filter weights+                 -> !(L kernelFlattened channels) -- The last kernel update (or momentum)+                 -> Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns++data Deconvolution' :: Nat -- Number of channels, for the first layer this could be RGB for instance.+                    -> Nat -- Number of filters, this is the number of channels output by the layer.+                    -> Nat -- The number of rows in the kernel filter+                    -> Nat -- The number of column in the kernel filter+                    -> Nat -- The row stride of the Deconvolution filter+                    -> Nat -- The columns stride of the Deconvolution filter+                    -> * where+  Deconvolution' :: ( KnownNat channels+                  , KnownNat filters+                  , KnownNat kernelRows+                  , KnownNat kernelColumns+                  , KnownNat strideRows+                  , KnownNat strideColumns+                  , KnownNat kernelFlattened+                  , kernelFlattened ~ (kernelRows * kernelColumns * filters))+               => !(L kernelFlattened channels) -- The kernel filter gradient+               -> Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns++instance Show (Deconvolution c f k k' s s') where+  show (Deconvolution a _) = renderConv a+    where+      renderConv mm =+        let m  = extract mm+            ky = fromIntegral $ natVal (Proxy :: Proxy k)+            rs = LA.toColumns m+            ms = map (take ky) $ toLists . reshape ky <$> rs++            render n'  | n' <= 0.2  = ' '+                       | n' <= 0.4  = '.'+                       | n' <= 0.6  = '-'+                       | n' <= 0.8  = '='+                       | otherwise =  '#'++            px = (fmap . fmap . fmap) render ms+        in unlines $ foldl1 (zipWith (\a' b' -> a' ++ "   |   " ++ b')) $ px++randomDeconvolution :: ( MonadRandom m+                     , KnownNat channels+                     , KnownNat filters+                     , KnownNat kernelRows+                     , KnownNat kernelColumns+                     , KnownNat strideRows+                     , KnownNat strideColumns+                     , KnownNat kernelFlattened+                     , kernelFlattened ~ (kernelRows * kernelColumns * filters))+                  => m (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns)+randomDeconvolution = do+    s     <- getRandom+    let wN = uniformSample s (-1) 1+        mm = konst 0+    return $ Deconvolution wN mm++instance ( KnownNat channels+         , KnownNat filters+         , KnownNat kernelRows+         , KnownNat kernelColumns+         , KnownNat strideRows+         , KnownNat strideColumns+         , KnownNat (kernelRows * kernelColumns * filters)+         ) => UpdateLayer (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where+  type Gradient (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) = (Deconvolution' channels filters kernelRows kernelCols strideRows strideCols)+  runUpdate LearningParameters {..} (Deconvolution oldKernel oldMomentum) (Deconvolution' kernelGradient) =+    let (newKernel, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldKernel kernelGradient oldMomentum+    in Deconvolution newKernel newMomentum++  createRandom = randomDeconvolution++instance ( KnownNat channels+         , KnownNat filters+         , KnownNat kernelRows+         , KnownNat kernelColumns+         , KnownNat strideRows+         , KnownNat strideColumns+         , KnownNat (kernelRows * kernelColumns * filters)+         ) => Serialize (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where+  put (Deconvolution w _) = putListOf put . toList . flatten . extract $ w+  get = do+      let f  = fromIntegral $ natVal (Proxy :: Proxy channels)+      wN    <- maybe (fail "Vector of incorrect size") return . create . reshape f . LA.fromList =<< getListOf get+      let mm = konst 0+      return $ Deconvolution wN mm++-- | A two dimentional image may have a Deconvolution filter applied to it+instance ( KnownNat kernelRows+         , KnownNat kernelCols+         , KnownNat filters+         , KnownNat strideRows+         , KnownNat strideCols+         , KnownNat inputRows+         , KnownNat inputCols+         , KnownNat outputRows+         , KnownNat outputCols+         , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)+         , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)+         , KnownNat (kernelRows * kernelCols * filters)+         , KnownNat (outputRows * filters)+         ) => Layer (Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where+  type Tape (Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols 1)+  runForwards c (S2D input) =+    runForwards c (S3D input :: S ('D3 inputRows inputCols 1))++  runBackwards c tape grads =+    case runBackwards c tape grads of+      (c', S3D back :: S ('D3 inputRows inputCols 1)) ->  (c', S2D back)++-- | A two dimentional image may have a Deconvolution filter applied to it+instance ( KnownNat kernelRows+         , KnownNat kernelCols+         , KnownNat strideRows+         , KnownNat strideCols+         , KnownNat inputRows+         , KnownNat inputCols+         , KnownNat outputRows+         , KnownNat outputCols+         , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)+         , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)+         , KnownNat (kernelRows * kernelCols * 1)+         , KnownNat (outputRows * 1)+         ) => Layer (Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) where+  type Tape (Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols 1)+  runForwards c (S2D input) =+    case runForwards c (S3D input :: S ('D3 inputRows inputCols 1)) of+      (tps, S3D fore :: S ('D3 outputRows outputCols 1)) ->  (tps, S2D fore)++  runBackwards c tape (S2D grads) =+    case runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1)) of+      (c', S3D back :: S ('D3 inputRows inputCols 1)) ->  (c', S2D back)++-- | A two dimentional image may have a Deconvolution filter applied to it+instance ( KnownNat kernelRows+         , KnownNat kernelCols+         , KnownNat strideRows+         , KnownNat strideCols+         , KnownNat inputRows+         , KnownNat inputCols+         , KnownNat outputRows+         , KnownNat outputCols+         , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)+         , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)+         , KnownNat (kernelRows * kernelCols * 1)+         , KnownNat (outputRows * 1)+         , KnownNat channels+         ) => Layer (Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) where+  type Tape (Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols channels)+  runForwards c input =+    case runForwards c input of+      (tps, S3D fore :: S ('D3 outputRows outputCols 1)) ->  (tps, S2D fore)++  runBackwards c tape (S2D grads) =+    runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1))++-- | A three dimensional image (or 2d with many channels) can have+--   an appropriately sized Deconvolution filter run across it.+instance ( KnownNat kernelRows+         , KnownNat kernelCols+         , KnownNat filters+         , KnownNat strideRows+         , KnownNat strideCols+         , KnownNat inputRows+         , KnownNat inputCols+         , KnownNat outputRows+         , KnownNat outputCols+         , KnownNat channels+         , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)+         , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)+         , KnownNat (kernelRows * kernelCols * filters)+         , KnownNat (outputRows * filters)+         ) => Layer (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where++  type Tape (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)++  runForwards (Deconvolution kernel _) (S3D input) =+    let ex = extract input+        ek = extract kernel+        ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)+        kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)+        ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)+        sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)+        sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)+        ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)+        oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)++        c  = vid2col 1 1 1 1 ix iy ex++        mt = c LA.<> tr ek++        r  = col2vid kx ky sx sy ox oy mt+        rs = fromJust . create $ r+    in  (S3D input, S3D rs)+  runBackwards (Deconvolution kernel _) (S3D input) (S3D dEdy) =+    let ex = extract input+        ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)+        kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)+        ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)+        sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)+        sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)+        ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)+        oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)++        c  = vid2col 1 1 1 1 ix iy ex++        eo = extract dEdy+        ek = extract kernel++        vs = vid2col kx ky sx sy ox oy eo++        kN = fromJust . create . tr $ tr c LA.<> vs++        dW = vs LA.<> ek++        xW = col2vid 1 1 1 1 ix iy dW+    in  (Deconvolution' kN, S3D . fromJust . create $ xW)
+ src/Grenade/Layers/Dropout.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Grenade.Layers.Dropout (+    Dropout (..)+  , randomDropout+  ) where++import           Control.Monad.Random hiding (fromList)++import           GHC.TypeLits+import           Grenade.Core++-- Dropout layer help to reduce overfitting.+-- Idea here is that the vector is a shape of 1s and 0s, which we multiply the input by.+-- After backpropogation, we return a new matrix/vector, with different bits dropped out.+-- Double is the proportion to drop in each training iteration (like 1% or 5% would be+-- reasonable).+data Dropout = Dropout {+    dropoutRate :: Double+  , dropoutSeed :: Int+  } deriving Show++instance UpdateLayer Dropout where+  type Gradient Dropout = ()+  runUpdate _ x _ = x+  createRandom = randomDropout 0.95++randomDropout :: MonadRandom m+              => Double -> m Dropout+randomDropout rate = Dropout rate <$> getRandom++instance (KnownNat i) => Layer Dropout ('D1 i) ('D1 i) where+  type Tape Dropout ('D1 i) ('D1 i) = ()+  runForwards (Dropout _ _) (S1D x) = ((), S1D x)+  runBackwards (Dropout _ _) _ (S1D x) = ((),  S1D x)
+ src/Grenade/Layers/Elu.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-|+Module      : Grenade.Layers.Logit+Description : Exponential linear unit layer+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Layers.Elu (+    Elu (..)+  ) where++import           Data.Serialize++import           GHC.TypeLits+import           Grenade.Core++import qualified Numeric.LinearAlgebra.Static as LAS++-- | An exponential linear unit.+--   A layer which can act between any shape of the same dimension, acting as a+--   diode on every neuron individually.+data Elu = Elu+  deriving Show++instance UpdateLayer Elu where+  type Gradient Elu = ()+  runUpdate _ _ _ = Elu+  createRandom = return Elu++instance Serialize Elu where+  put _ = return ()+  get = return Elu++instance ( KnownNat i) => Layer Elu ('D1 i) ('D1 i) where+  type Tape Elu ('D1 i) ('D1 i) = S ('D1 i)++  runForwards _ (S1D y) = (S1D y, S1D (elu y))+    where+      elu = LAS.dvmap (\a -> if a <= 0 then exp a - 1 else a)+  runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (elu' y * dEdy))+    where+      elu' = LAS.dvmap (\a -> if a <= 0 then exp a else 1)++instance (KnownNat i, KnownNat j) => Layer Elu ('D2 i j) ('D2 i j) where+  type Tape Elu ('D2 i j) ('D2 i j) = S ('D2 i j)++  runForwards _ (S2D y) = (S2D y, S2D (elu y))+    where+      elu = LAS.dmmap (\a -> if a <= 0 then exp a - 1 else a)+  runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (elu' y * dEdy))+    where+      elu' = LAS.dmmap (\a -> if a <= 0 then exp a else 1)++instance (KnownNat i, KnownNat j, KnownNat k) => Layer Elu ('D3 i j k) ('D3 i j k) where++  type Tape Elu ('D3 i j k) ('D3 i j k) = S ('D3 i j k)++  runForwards _ (S3D y) = (S3D y, S3D (elu y))+    where+      elu = LAS.dmmap (\a -> if a <= 0 then exp a - 1 else a)+  runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (elu' y * dEdy))+    where+      elu' = LAS.dmmap (\a -> if a <= 0 then exp a else 1)
+ src/Grenade/Layers/FullyConnected.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+module Grenade.Layers.FullyConnected (+    FullyConnected (..)+  , FullyConnected' (..)+  , randomFullyConnected+  ) where++import           Control.Monad.Random hiding (fromList)++import           Data.Proxy+import           Data.Serialize+import           Data.Singletons.TypeLits++import qualified Numeric.LinearAlgebra as LA+import           Numeric.LinearAlgebra.Static++import           Grenade.Core++import           Grenade.Layers.Internal.Update++-- | A basic fully connected (or inner product) neural network layer.+data FullyConnected i o = FullyConnected+                        !(FullyConnected' i o)   -- Neuron weights+                        !(FullyConnected' i o)   -- Neuron momentum++data FullyConnected' i o = FullyConnected'+                         !(R o)   -- Bias+                         !(L o i) -- Activations++instance Show (FullyConnected i o) where+  show FullyConnected {} = "FullyConnected"++instance (KnownNat i, KnownNat o) => UpdateLayer (FullyConnected i o) where+  type Gradient (FullyConnected i o) = (FullyConnected' i o)++  runUpdate LearningParameters {..} (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =+    let (newBias, newBiasMomentum)    = decendVector learningRate learningMomentum learningRegulariser oldBias biasGradient oldBiasMomentum+        (newActivations, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldActivations activationGradient oldMomentum+    in FullyConnected (FullyConnected' newBias newActivations) (FullyConnected' newBiasMomentum newMomentum)++  createRandom = randomFullyConnected++instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o) where+  type Tape (FullyConnected i o) ('D1 i) ('D1 o) = S ('D1 i)+  -- Do a matrix vector multiplication and return the result.+  runForwards (FullyConnected (FullyConnected' wB wN) _) (S1D v) = (S1D v, S1D (wB + wN #> v))++  -- Run a backpropogation step for a full connected layer.+  runBackwards (FullyConnected (FullyConnected' _ wN) _) (S1D x) (S1D dEdy) =+          let wB'  = dEdy+              mm'  = dEdy `outer` x+              -- calcluate derivatives for next step+              dWs  = tr wN #> dEdy+          in  (FullyConnected' wB' mm', S1D dWs)++instance (KnownNat i, KnownNat o) => Serialize (FullyConnected i o) where+  put (FullyConnected (FullyConnected' b w) _) = do+    putListOf put . LA.toList . extract $ b+    putListOf put . LA.toList . LA.flatten . extract $ w++  get = do+      let f  = fromIntegral $ natVal (Proxy :: Proxy i)+      b     <- maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get+      k     <- maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get+      let bm = konst 0+      let mm = konst 0+      return $ FullyConnected (FullyConnected' b k) (FullyConnected' bm mm)++randomFullyConnected :: (MonadRandom m, KnownNat i, KnownNat o)+                     => m (FullyConnected i o)+randomFullyConnected = do+    s1    <- getRandom+    s2    <- getRandom+    let wB = randomVector  s1 Uniform * 2 - 1+        wN = uniformSample s2 (-1) 1+        bm = konst 0+        mm = konst 0+    return $ FullyConnected (FullyConnected' wB wN) (FullyConnected' bm mm)
+ src/Grenade/Layers/Inception.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-|+Module      : Grenade.Core.Network+Description : Inception style parallel convolutional network composition.+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental++Export an Inception style type, which can be used to build up+complex multiconvolution size networks.+-}+module Grenade.Layers.Inception (+    Inception+  , InceptionMini+  , Resnet+  ) where++import           GHC.TypeLits++import           Grenade.Core+import           Grenade.Layers.Convolution+import           Grenade.Layers.Pad+import           Grenade.Layers.Concat+import           Grenade.Layers.Merge+import           Grenade.Layers.Trivial++-- | Type of an inception layer.+--+--   It looks like a bit of a handful, but is actually pretty easy to use.+--+--   The first three type parameters are the size of the (3D) data the+--   inception layer will take. It will emit 3D data with the number of+--   channels being the sum of @chx@, @chy@, @chz@, which are the number+--   of convolution filters in the 3x3, 5x5, and 7x7 convolutions Layers+--   respectively.+--+--   The network get padded effectively before each convolution filters+--   such that the output dimension is the same x and y as the input.+type Inception rows cols channels chx chy chz+  = Network '[ Concat ('D3 rows cols (chx + chy)) (InceptionMini rows cols channels chx chy) ('D3 rows cols chz) (Inception7x7 rows cols channels chz) ]+            '[ 'D3 rows cols channels, 'D3 rows cols (chx + chy + chz) ]++type InceptionMini rows cols channels chx chy+  = Network '[ Concat ('D3 rows cols chx) (Inception3x3 rows cols channels chx) ('D3 rows cols chy) (Inception5x5 rows cols channels chy) ]+            '[ 'D3 rows cols channels, 'D3 rows cols (chx + chy) ]++type Inception3x3 rows cols channels chx+  = Network '[ Pad 1 1 1 1, Convolution channels chx 3 3 1 1 ]+            '[ 'D3 rows cols channels, 'D3 (rows + 2) (cols + 2) channels, 'D3 rows cols chx ]++type Inception5x5 rows cols channels chx+  = Network '[ Pad 2 2 2 2, Convolution channels chx 5 5 1 1 ]+            '[ 'D3 rows cols channels, 'D3 (rows + 4) (cols + 4) channels, 'D3 rows cols chx ]++type Inception7x7 rows cols channels chx+  = Network '[ Pad 3 3 3 3, Convolution channels chx 7 7 1 1 ]+            '[ 'D3 rows cols channels, 'D3 (rows + 6) (cols + 6) channels, 'D3 rows cols chx ]++type Resnet branch = Merge Trivial branch
+ src/Grenade/Layers/Internal/Convolution.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Grenade.Layers.Internal.Convolution (+    im2col+  , col2im+  , col2vid+  , vid2col+  ) where++import qualified Data.Vector.Storable as U ( unsafeToForeignPtr0, unsafeFromForeignPtr0 )++import           Foreign ( mallocForeignPtrArray, withForeignPtr )+import           Foreign.Ptr ( Ptr )++import           Numeric.LinearAlgebra ( Matrix, flatten, rows, cols )+import qualified Numeric.LinearAlgebra.Devel as U++import           System.IO.Unsafe ( unsafePerformIO )++col2vid :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+col2vid kernelRows kernelColumns strideRows strideColumns height width dataCol =+  let channels = cols dataCol `div` (kernelRows * kernelColumns)+  in  col2im_c channels height width kernelRows kernelColumns strideRows strideColumns dataCol++col2im :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+col2im kernelRows kernelColumns strideRows strideColumns height width dataCol =+  let channels = 1+  in  col2im_c channels height width kernelRows kernelColumns strideRows strideColumns dataCol++col2im_c :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+col2im_c channels height width kernelRows kernelColumns strideRows strideColumns dataCol =+  let vec = flatten dataCol+  in unsafePerformIO $ do+    outPtr <- mallocForeignPtrArray (height * width * channels)+    let (inPtr, _) = U.unsafeToForeignPtr0 vec++    withForeignPtr inPtr $ \inPtr' ->+      withForeignPtr outPtr $ \outPtr' ->+        col2im_cpu inPtr' channels height width kernelRows kernelColumns strideRows strideColumns outPtr'++    let matVec = U.unsafeFromForeignPtr0 outPtr (height * width * channels)+    return $ U.matrixFromVector U.RowMajor (height * channels) width matVec++foreign import ccall unsafe+    col2im_cpu+      :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()++vid2col :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+vid2col kernelRows kernelColumns strideRows strideColumns height width dataVid =+  let channels = rows dataVid `div` height+  in  im2col_c channels height width kernelRows kernelColumns strideRows strideColumns dataVid+++im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+im2col kernelRows kernelColumns strideRows strideColumns dataIm =+  let channels = 1+      height = rows dataIm+      width  = cols dataIm+  in  im2col_c channels height width kernelRows kernelColumns strideRows strideColumns dataIm++im2col_c :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+im2col_c channels height width kernelRows kernelColumns strideRows strideColumns dataIm =+  let vec    = flatten dataIm+      rowOut = (height - kernelRows) `div` strideRows + 1+      colOut = (width - kernelColumns) `div` strideColumns + 1+      kernelSize      = kernelRows * kernelColumns+      numberOfPatches = rowOut * colOut+  in unsafePerformIO $ do+    outPtr <- mallocForeignPtrArray (numberOfPatches * kernelSize * channels)+    let (inPtr, _) = U.unsafeToForeignPtr0 vec++    withForeignPtr inPtr $ \inPtr' ->+      withForeignPtr outPtr $ \outPtr' ->+        im2col_cpu inPtr' channels height width kernelRows kernelColumns strideRows strideColumns outPtr'++    let matVec = U.unsafeFromForeignPtr0 outPtr (numberOfPatches * kernelSize * channels)+    return $ U.matrixFromVector U.RowMajor numberOfPatches (kernelSize * channels) matVec++foreign import ccall unsafe+    im2col_cpu+      :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()
+ src/Grenade/Layers/Internal/Pad.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Grenade.Layers.Internal.Pad (+    pad+  , crop+  ) where++import qualified Data.Vector.Storable as U ( unsafeToForeignPtr0, unsafeFromForeignPtr0 )++import           Foreign ( mallocForeignPtrArray, withForeignPtr )+import           Foreign.Ptr ( Ptr )++import           Numeric.LinearAlgebra ( flatten, Matrix )+import qualified Numeric.LinearAlgebra.Devel as U++import           System.IO.Unsafe ( unsafePerformIO )++pad :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+pad channels padLeft padTop padRight padBottom rows cols rows' cols' m+ = let outMatSize      = rows' * cols' * channels+       vec             = flatten m+   in unsafePerformIO $ do+     outPtr        <- mallocForeignPtrArray outMatSize+     let (inPtr, _) = U.unsafeToForeignPtr0 vec++     withForeignPtr inPtr $ \inPtr' ->+       withForeignPtr outPtr $ \outPtr' ->+         pad_cpu inPtr' channels rows cols padLeft padTop padRight padBottom outPtr'++     let matVec = U.unsafeFromForeignPtr0 outPtr outMatSize+     return (U.matrixFromVector U.RowMajor (rows' * channels) cols' matVec)+{-# INLINE pad #-}++foreign import ccall unsafe+    pad_cpu+      :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()++crop :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+crop channels padLeft padTop padRight padBottom rows cols _ _ m+ = let outMatSize      = rows * cols * channels+       vec             = flatten m+   in unsafePerformIO $ do+     outPtr        <- mallocForeignPtrArray outMatSize+     let (inPtr, _) = U.unsafeToForeignPtr0 vec++     withForeignPtr inPtr $ \inPtr' ->+       withForeignPtr outPtr $ \outPtr' ->+         crop_cpu inPtr' channels rows cols padLeft padTop padRight padBottom outPtr'++     let matVec = U.unsafeFromForeignPtr0 outPtr outMatSize+     return (U.matrixFromVector U.RowMajor (rows * channels) cols matVec)++foreign import ccall unsafe+    crop_cpu+      :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()
+ src/Grenade/Layers/Internal/Pooling.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Grenade.Layers.Internal.Pooling (+    poolForward+  , poolBackward+  ) where++import qualified Data.Vector.Storable as U ( unsafeToForeignPtr0, unsafeFromForeignPtr0 )++import           Foreign ( mallocForeignPtrArray, withForeignPtr )+import           Foreign.Ptr ( Ptr )++import           Numeric.LinearAlgebra ( Matrix , flatten )+import qualified Numeric.LinearAlgebra.Devel as U++import           System.IO.Unsafe ( unsafePerformIO )++poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+poolForward channels height width kernelRows kernelColumns strideRows strideColumns dataIm =+  let vec             = flatten dataIm+      rowOut          = (height - kernelRows) `div` strideRows + 1+      colOut          = (width - kernelColumns) `div` strideColumns + 1+      numberOfPatches = rowOut * colOut+  in unsafePerformIO $ do+    outPtr <- mallocForeignPtrArray (numberOfPatches * channels)+    let (inPtr, _) = U.unsafeToForeignPtr0 vec++    withForeignPtr inPtr $ \inPtr' ->+      withForeignPtr outPtr $ \outPtr' ->+        pool_forwards_cpu inPtr' channels height width kernelRows kernelColumns strideRows strideColumns outPtr'++    let matVec = U.unsafeFromForeignPtr0 outPtr (numberOfPatches * channels)+    return $ U.matrixFromVector U.RowMajor (rowOut * channels) colOut matVec++foreign import ccall unsafe+    pool_forwards_cpu+      :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()++poolBackward :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double+poolBackward channels height width kernelRows kernelColumns strideRows strideColumns dataIm dataGrad =+  let vecIm     = flatten dataIm+      vecGrad   = flatten dataGrad+  in unsafePerformIO $ do+    outPtr <- mallocForeignPtrArray (height * width * channels)+    let (imPtr, _) = U.unsafeToForeignPtr0 vecIm+    let (gradPtr, _) = U.unsafeToForeignPtr0 vecGrad++    withForeignPtr imPtr $ \imPtr' ->+      withForeignPtr gradPtr $ \gradPtr' ->+        withForeignPtr outPtr $ \outPtr' ->+          pool_backwards_cpu imPtr' gradPtr' channels height width kernelRows kernelColumns strideRows strideColumns outPtr'++    let matVec = U.unsafeFromForeignPtr0 outPtr (height * width * channels)+    return $ U.matrixFromVector U.RowMajor (height * channels) width matVec++foreign import ccall unsafe+    pool_backwards_cpu+      :: Ptr Double -> Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()
+ src/Grenade/Layers/Internal/Update.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Grenade.Layers.Internal.Update (+    decendMatrix+  , decendVector+  ) where++import           Data.Maybe ( fromJust )+import qualified Data.Vector.Storable as U ( unsafeToForeignPtr0, unsafeFromForeignPtr0 )++import           Foreign ( mallocForeignPtrArray, withForeignPtr )+import           Foreign.Ptr ( Ptr )+import           GHC.TypeLits++import           Numeric.LinearAlgebra ( Vector, flatten )+import           Numeric.LinearAlgebra.Static+import qualified Numeric.LinearAlgebra.Devel as U++import           System.IO.Unsafe ( unsafePerformIO )++decendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)+decendMatrix rate momentum regulariser weights gradient lastUpdate =+  let (rows, cols) = size weights+      len          = rows * cols+      -- Most gradients come in in ColumnMajor,+      -- so we'll transpose here before flattening them+      -- into a vector to prevent a copy.+      --+      -- This gives ~15% speed improvement for LSTMs.+      weights'     = flatten . tr . extract $ weights+      gradient'    = flatten . tr . extract $ gradient+      lastUpdate'  = flatten . tr . extract $ lastUpdate+      (vw, vm)     = decendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'++      -- Note that it's ColumnMajor, as we did a transpose before+      -- using the internal vectors.+      mw           = U.matrixFromVector U.ColumnMajor rows cols vw+      mm           = U.matrixFromVector U.ColumnMajor rows cols vm+  in  (fromJust . create $ mw, fromJust . create $ mm)++decendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)+decendVector rate momentum regulariser weights gradient lastUpdate =+  let len          = size weights+      weights'     = extract weights+      gradient'    = extract gradient+      lastUpdate'  = extract lastUpdate+      (vw, vm)     = decendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'+  in  (fromJust $ create vw, fromJust $ create vm)++decendUnsafe :: Int -> Double -> Double -> Double -> Vector Double -> Vector Double -> Vector Double -> (Vector Double, Vector Double)+decendUnsafe len rate momentum regulariser weights gradient lastUpdate =+  unsafePerformIO $ do+    outWPtr <- mallocForeignPtrArray len+    outMPtr <- mallocForeignPtrArray len+    let (wPtr, _) = U.unsafeToForeignPtr0 weights+    let (gPtr, _) = U.unsafeToForeignPtr0 gradient+    let (lPtr, _) = U.unsafeToForeignPtr0 lastUpdate++    withForeignPtr wPtr $ \wPtr' ->+      withForeignPtr gPtr $ \gPtr' ->+        withForeignPtr lPtr $ \lPtr' ->+          withForeignPtr outWPtr $ \outWPtr' ->+            withForeignPtr outMPtr $ \outMPtr' ->+              decend_cpu len rate momentum regulariser wPtr' gPtr' lPtr' outWPtr' outMPtr'++    return (U.unsafeFromForeignPtr0 outWPtr len, U.unsafeFromForeignPtr0 outMPtr len)++foreign import ccall unsafe+    decend_cpu+      :: Int -> Double -> Double -> Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()+
+ src/Grenade/Layers/Logit.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-|+Module      : Grenade.Layers.Logit+Description : Sigmoid nonlinear layer+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Layers.Logit (+    Logit (..)+  ) where+++import           Data.Serialize+import           Data.Singletons++import           Grenade.Core++-- | A Logit layer.+--+--   A layer which can act between any shape of the same dimension, perfoming an sigmoid function.+--   This layer should be used as the output layer of a network for logistic regression (classification)+--   problems.+data Logit = Logit+  deriving Show++instance UpdateLayer Logit where+  type Gradient Logit = ()+  runUpdate _ _ _ = Logit+  createRandom = return Logit++instance (a ~ b, SingI a) => Layer Logit a b where+  type Tape Logit a b = S a+  runForwards _ a = (a, logistic a)+  runBackwards _ a g = ((), logistic' a * g)++instance Serialize Logit where+  put _ = return ()+  get = return Logit++logistic :: Floating a => a -> a+logistic x = 1 / (1 + exp (-x))++logistic' :: Floating a => a -> a+logistic' x = logix * (1 - logix)+  where+    logix = logistic x
+ src/Grenade/Layers/Merge.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-|+Module      : Grenade.Core.Network+Description : Merging layer for parallel network composition+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Layers.Merge (+    Merge (..)+  ) where++import           Data.Serialize++import           Data.Singletons++import           Grenade.Core++-- | A Merging layer.+--+-- Similar to Concat layer, except sums the activations instead of creating a larger+-- shape.+data Merge :: * -> * -> * where+  Merge :: x -> y -> Merge x y++instance (Show x, Show y) => Show (Merge x y) where+  show (Merge x y) = "Merge\n" ++ show x ++ "\n" ++ show y++-- | Run two layers in parallel, combining their outputs.+--   This just kind of "smooshes" the weights together.+instance (UpdateLayer x, UpdateLayer y) => UpdateLayer (Merge x y) where+  type Gradient (Merge x y) = (Gradient x, Gradient y)+  runUpdate lr (Merge x y) (x', y') = Merge (runUpdate lr x x') (runUpdate lr y y')+  createRandom = Merge <$> createRandom <*> createRandom++-- | Combine the outputs and the inputs, summing the output shape+instance (SingI i, SingI o, Layer x i o, Layer y i o) => Layer (Merge x y) i o where+  type Tape (Merge x y) i o = (Tape x i o, Tape y i o)++  runForwards (Merge x y) input =+    let (xT, xOut) = runForwards x input+        (yT, yOut) = runForwards y input+    in  ((xT, yT), xOut + yOut)++  runBackwards (Merge x y) (xTape, yTape) o =+    let (x', xB) = runBackwards x xTape o+        (y', yB) = runBackwards y yTape o+    in  ((x', y'), xB + yB)++instance (Serialize a, Serialize b) => Serialize (Merge a b) where+  put (Merge a b) = put a *> put b+  get = Merge <$> get <*> get
+ src/Grenade/Layers/Pad.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-|+Module      : Grenade.Core.Pad+Description : Padding layer for 2D and 3D images+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Layers.Pad (+    Pad (..)+  ) where++import           Data.Maybe+import           Data.Proxy+import           Data.Serialize+import           Data.Singletons.TypeLits+import           GHC.TypeLits++import           Grenade.Core+import           Grenade.Layers.Internal.Pad++import           Numeric.LinearAlgebra (konst, subMatrix, diagBlock)+import           Numeric.LinearAlgebra.Static (extract, create)++-- | A padding layer for a neural network.+--+--   Pads on the X and Y dimension of an image.+data Pad  :: Nat+          -> Nat+          -> Nat+          -> Nat -> * where+  Pad  :: Pad padLeft padTop padRight padBottom++instance Show (Pad padLeft padTop padRight padBottom) where+  show Pad = "Pad"++instance UpdateLayer (Pad l t r b) where+  type Gradient (Pad l t r b) = ()+  runUpdate _ x _ = x+  createRandom = return Pad++instance Serialize (Pad l t r b) where+  put _ = return ()+  get = return Pad++-- | A two dimentional image can be padped.+instance ( KnownNat padLeft+         , KnownNat padTop+         , KnownNat padRight+         , KnownNat padBottom+         , KnownNat inputRows+         , KnownNat inputColumns+         , KnownNat outputRows+         , KnownNat outputColumns+         , (inputRows + padTop + padBottom) ~ outputRows+         , (inputColumns + padLeft + padRight) ~ outputColumns+         ) => Layer (Pad padLeft padTop padRight padBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where+  type Tape (Pad padLeft padTop padRight padBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns)  = ()+  runForwards Pad (S2D input) =+    let padl  = fromIntegral $ natVal (Proxy :: Proxy padLeft)+        padt  = fromIntegral $ natVal (Proxy :: Proxy padTop)+        padr  = fromIntegral $ natVal (Proxy :: Proxy padRight)+        padb  = fromIntegral $ natVal (Proxy :: Proxy padBottom)+        m     = extract input+        r     = diagBlock [konst 0 (padt,padl), m, konst 0 (padb,padr)]+    in  ((), S2D . fromJust . create $ r)+  runBackwards Pad _ (S2D dEdy) =+    let padl  = fromIntegral $ natVal (Proxy :: Proxy padLeft)+        padt  = fromIntegral $ natVal (Proxy :: Proxy padTop)+        nrows = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        ncols = fromIntegral $ natVal (Proxy :: Proxy inputColumns)+        m     = extract dEdy+        vs    = subMatrix (padt, padl) (nrows, ncols) m+    in  ((), S2D . fromJust . create $ vs)++-- | A two dimentional image can be padped.+instance ( KnownNat padLeft+         , KnownNat padTop+         , KnownNat padRight+         , KnownNat padBottom+         , KnownNat inputRows+         , KnownNat inputColumns+         , KnownNat outputRows+         , KnownNat outputColumns+         , KnownNat channels+         , KnownNat (inputRows * channels)+         , KnownNat (outputRows * channels)+         , (inputRows + padTop + padBottom) ~ outputRows+         , (inputColumns + padLeft + padRight) ~ outputColumns+         ) => Layer (Pad padLeft padTop padRight padBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where+  type Tape (Pad padLeft padTop padRight padBottom) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels)  = ()+  runForwards Pad (S3D input) =+    let padl  = fromIntegral $ natVal (Proxy :: Proxy padLeft)+        padt  = fromIntegral $ natVal (Proxy :: Proxy padTop)+        padr  = fromIntegral $ natVal (Proxy :: Proxy padRight)+        padb  = fromIntegral $ natVal (Proxy :: Proxy padBottom)+        outr  = fromIntegral $ natVal (Proxy :: Proxy outputRows)+        outc  = fromIntegral $ natVal (Proxy :: Proxy outputColumns)+        inr   = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        inc   = fromIntegral $ natVal (Proxy :: Proxy inputColumns)+        ch    = fromIntegral $ natVal (Proxy :: Proxy channels)+        m     = extract input+        padded = pad ch padl padt padr padb inr inc outr outc m+    in  ((), S3D . fromJust . create $ padded)++  runBackwards Pad () (S3D gradient) =+    let padl  = fromIntegral $ natVal (Proxy :: Proxy padLeft)+        padt  = fromIntegral $ natVal (Proxy :: Proxy padTop)+        padr  = fromIntegral $ natVal (Proxy :: Proxy padRight)+        padb  = fromIntegral $ natVal (Proxy :: Proxy padBottom)+        outr  = fromIntegral $ natVal (Proxy :: Proxy outputRows)+        outc  = fromIntegral $ natVal (Proxy :: Proxy outputColumns)+        inr   = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        inc   = fromIntegral $ natVal (Proxy :: Proxy inputColumns)+        ch    = fromIntegral $ natVal (Proxy :: Proxy channels)+        m     = extract gradient+        cropped = crop ch padl padt padr padb inr inc outr outc m+    in  ((), S3D . fromJust . create $ cropped)
+ src/Grenade/Layers/Pooling.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-|+Module      : Grenade.Core.Pooling+Description : Max Pooling layer for 2D and 3D images+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Layers.Pooling (+    Pooling (..)+  ) where++import           Data.Maybe+import           Data.Proxy+import           Data.Serialize+import           Data.Singletons.TypeLits+import           GHC.TypeLits++import           Grenade.Core+import           Grenade.Layers.Internal.Pooling++import           Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)++-- | A pooling layer for a neural network.+--+--   Does a max pooling, looking over a kernel similarly to the convolution network, but returning+--   maxarg only. This layer is often used to provide minor amounts of translational invariance.+--+--   The kernel size dictates which input and output sizes will "fit". Fitting the equation:+--   `out = (in - kernel) / stride + 1` for both dimensions.+--+data Pooling :: Nat -> Nat -> Nat -> Nat -> * where+  Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns++instance Show (Pooling k k' s s') where+  show Pooling = "Pooling"++instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where+  type Gradient (Pooling kr kc sr sc) = ()+  runUpdate _ Pooling _ = Pooling+  createRandom = return Pooling++instance Serialize (Pooling kernelRows kernelColumns strideRows strideColumns) where+  put _ = return ()+  get = return Pooling++-- | A two dimentional image can be pooled.+instance ( KnownNat kernelRows+         , KnownNat kernelColumns+         , KnownNat strideRows+         , KnownNat strideColumns+         , KnownNat inputRows+         , KnownNat inputColumns+         , KnownNat outputRows+         , KnownNat outputColumns+         , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)+         , ((outputColumns - 1) * strideColumns) ~ (inputColumns - kernelColumns)+         ) => Layer (Pooling kernelRows kernelColumns strideRows strideColumns) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where+  type Tape (Pooling kernelRows kernelColumns strideRows strideColumns) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = S ('D2 inputRows inputColumns)+  runForwards Pooling (S2D input) =+    let height = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        width  = fromIntegral $ natVal (Proxy :: Proxy inputColumns)+        kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)+        ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)+        sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)+        sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)+        ex = extract input+        r  = poolForward 1 height width kx ky sx sy ex+        rs = fromJust . create $ r+    in  (S2D input, S2D rs)+  runBackwards Pooling (S2D input) (S2D dEdy) =+    let height = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        width  = fromIntegral $ natVal (Proxy :: Proxy inputColumns)+        kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)+        ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)+        sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)+        sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)+        ex = extract input+        eo = extract dEdy+        vs = poolBackward 1 height width kx ky sx sy ex eo+    in  ((), S2D . fromJust . create $ vs)+++-- | A three dimensional image can be pooled on each layer.+instance ( KnownNat kernelRows+         , KnownNat kernelColumns+         , KnownNat strideRows+         , KnownNat strideColumns+         , KnownNat inputRows+         , KnownNat inputColumns+         , KnownNat outputRows+         , KnownNat outputColumns+         , KnownNat channels+         , KnownNat (outputRows * channels)+         , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)+         , ((outputColumns - 1) * strideColumns) ~ (inputColumns - kernelColumns)+         ) => Layer (Pooling kernelRows kernelColumns strideRows strideColumns) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where+  type Tape (Pooling kernelRows kernelColumns strideRows strideColumns) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) = S ('D3 inputRows inputColumns channels)+  runForwards Pooling (S3D input) =+    let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)+        kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)+        ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)+        sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)+        sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)+        ch = fromIntegral $ natVal (Proxy :: Proxy channels)+        ex = extract input+        r  = poolForward ch ix iy kx ky sx sy ex+        rs = fromJust . create $ r+    in  (S3D input, S3D rs)+  runBackwards Pooling (S3D input) (S3D dEdy) =+    let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)+        iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)+        kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)+        ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)+        sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)+        sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)+        ch = fromIntegral $ natVal (Proxy :: Proxy channels)+        ex = extract input+        eo = extract dEdy+        vs = poolBackward ch ix iy kx ky sx sy ex eo+    in  ((), S3D . fromJust . create $ vs)
+ src/Grenade/Layers/Relu.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-|+Module      : Grenade.Layers.Relu+Description : Rectifying linear unit layer+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Layers.Relu (+    Relu (..)+  ) where++import           Data.Serialize++import           GHC.TypeLits+import           Grenade.Core++import qualified Numeric.LinearAlgebra.Static as LAS++-- | A rectifying linear unit.+--   A layer which can act between any shape of the same dimension, acting as a+--   diode on every neuron individually.+data Relu = Relu+  deriving Show++instance UpdateLayer Relu where+  type Gradient Relu = ()+  runUpdate _ _ _ = Relu+  createRandom = return Relu++instance Serialize Relu where+  put _ = return ()+  get = return Relu++instance ( KnownNat i) => Layer Relu ('D1 i) ('D1 i) where+  type Tape Relu ('D1 i) ('D1 i) = S ('D1 i)++  runForwards _ (S1D y) = (S1D y, S1D (relu y))+    where+      relu = LAS.dvmap (\a -> if a <= 0 then 0 else a)+  runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (relu' y * dEdy))+    where+      relu' = LAS.dvmap (\a -> if a <= 0 then 0 else 1)++instance (KnownNat i, KnownNat j) => Layer Relu ('D2 i j) ('D2 i j) where+  type Tape Relu ('D2 i j) ('D2 i j) = S ('D2 i j)++  runForwards _ (S2D y) = (S2D y, S2D (relu y))+    where+      relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)+  runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (relu' y * dEdy))+    where+      relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)++instance (KnownNat i, KnownNat j, KnownNat k) => Layer Relu ('D3 i j k) ('D3 i j k) where++  type Tape Relu ('D3 i j k) ('D3 i j k) = S ('D3 i j k)++  runForwards _ (S3D y) = (S3D y, S3D (relu y))+    where+      relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)+  runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (relu' y * dEdy))+    where+      relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)
+ src/Grenade/Layers/Reshape.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-|+Module      : Grenade.Layers.Reshape+Description : Multipurpose reshaping layer+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Layers.Reshape (+    Reshape (..)+  ) where++import           Data.Serialize++import           Data.Singletons.TypeLits+import           GHC.TypeLits++import           Numeric.LinearAlgebra.Static+import           Numeric.LinearAlgebra.Data as LA ( flatten )++import           Grenade.Core++-- | Reshape Layer+--+-- The Reshape layer can flatten any 2D or 3D image to 1D vector with the+-- same number of activations, as well as cast up from 1D to a 2D or 3D+-- shape.+--+-- Can also be used to turn a 3D image with only one channel into a 2D image+-- or vice versa.+data Reshape = Reshape+  deriving Show++instance UpdateLayer Reshape where+  type Gradient Reshape = ()+  runUpdate _ _ _ = Reshape+  createRandom = return Reshape++instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer Reshape ('D2 x y) ('D1 a) where+  type Tape Reshape ('D2 x y) ('D1 a) = ()+  runForwards _ (S2D y)   =  ((), fromJust' . fromStorable . flatten . extract $ y)+  runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)++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+  type Tape Reshape ('D3 x y z) ('D1 a) = ()+  runForwards _ (S3D y)     = ((), fromJust' . fromStorable . flatten . extract $ y)+  runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)++instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer Reshape ('D3 x y z) ('D2 x y) where+  type Tape Reshape ('D3 x y z) ('D2 x y) = ()+  runForwards _ (S3D y)    = ((), S2D y)+  runBackwards _ _ (S2D y) = ((), S3D y)++instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer Reshape ('D2 x y) ('D3 x y z) where+  type Tape Reshape ('D2 x y) ('D3 x y z) = ()+  runForwards _ (S2D y)    = ((), S3D y)+  runBackwards _ _ (S3D y) = ((), S2D y)++instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer Reshape ('D1 a) ('D2 x y) where+  type Tape Reshape ('D1 a) ('D2 x y) = ()+  runForwards _ (S1D y)   =  ((), fromJust' . fromStorable . extract $ y)+  runBackwards _ _ (S2D y) = ((), fromJust' . fromStorable . flatten . extract $ y)++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+  type Tape Reshape ('D1 a) ('D3 x y z) = ()+  runForwards _ (S1D y)     = ((), fromJust' . fromStorable . extract $ y)+  runBackwards _ _ (S3D y)  = ((), fromJust' . fromStorable . flatten . extract $ y)++instance Serialize Reshape where+  put _ = return ()+  get = return Reshape+++fromJust' :: Maybe x -> x+fromJust' (Just x) = x+fromJust' Nothing  = error $ "Reshape error: data shape couldn't be converted."
+ src/Grenade/Layers/Softmax.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-|+Module      : Grenade.Core.Softmax+Description : Softmax loss layer+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Layers.Softmax (+    Softmax (..)+  , softmax+  , softmax'+  ) where++import           Data.Serialize++import           GHC.TypeLits+import           Grenade.Core++import           Numeric.LinearAlgebra.Static as LAS++-- | A Softmax layer+--+--   This layer is like a logit layer, but normalises+--   a set of matricies to be probabilities.+--+--   One can use this layer as the last layer in a network+--   if they need normalised probabilities.+data Softmax = Softmax+  deriving Show++instance UpdateLayer Softmax where+  type Gradient Softmax = ()+  runUpdate _ _ _ = Softmax+  createRandom = return Softmax++instance ( KnownNat i ) => Layer Softmax ('D1 i) ('D1 i) where+  type Tape Softmax ('D1 i) ('D1 i) = S ('D1 i)++  runForwards _ (S1D y) = (S1D y, S1D (softmax y))+  runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (softmax' y dEdy))++instance Serialize Softmax where+  put _ = return ()+  get = return Softmax++softmax :: KnownNat i => LAS.R i -> LAS.R i+softmax xs =+  let xs' = LAS.dvmap exp xs+      s   = LAS.dot xs' 1+  in  LAS.dvmap (/ s) xs'++softmax' :: KnownNat i => LAS.R i -> LAS.R i -> LAS.R i+softmax' x grad =+  let yTy = outer sm sm+      d   = diag sm+      g   = d - yTy+  in  g #> grad+    where+  sm = softmax x
+ src/Grenade/Layers/Tanh.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-|+Module      : Grenade.Layers.Tanh+Description : Hyperbolic tangent nonlinear layer+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Layers.Tanh (+    Tanh (..)+  ) where++import           Data.Serialize+import           Data.Singletons++import           Grenade.Core++-- | A Tanh layer.+--   A layer which can act between any shape of the same dimension, perfoming a tanh function.+data Tanh = Tanh+  deriving Show++instance UpdateLayer Tanh where+  type Gradient Tanh = ()+  runUpdate _ _ _ = Tanh+  createRandom = return Tanh++instance Serialize Tanh where+  put _ = return ()+  get = return Tanh++instance (a ~ b, SingI a) => Layer Tanh a b where+  type Tape Tanh a b = S a+  runForwards _ a = (a, tanh a)+  runBackwards _ a g = ((), tanh' a * g)++tanh' :: (Floating a) => a -> a+tanh' t = 1 - s ^ (2 :: Int)  where s = tanh t
+ src/Grenade/Layers/Trivial.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances     #-}+{-|+Module      : Grenade.Core.Trivial+Description : Trivial layer which perfoms no operations on the data+Copyright   : (c) Huw Campbell, 2016-2017+License     : BSD2+Stability   : experimental+-}+module Grenade.Layers.Trivial (+    Trivial (..)+  ) where++import           Data.Serialize++import           Grenade.Core++-- | A Trivial layer.+--+--   This can be used to pass an unchanged value up one side of a+--   graph, for a Residual network for example.+data Trivial = Trivial+  deriving Show++instance Serialize Trivial where+  put _ = return ()+  get = return Trivial++instance UpdateLayer Trivial where+  type Gradient Trivial = ()+  runUpdate _ _ _ = Trivial+  createRandom = return Trivial++instance (a ~ b) => Layer Trivial a b where+  type Tape Trivial a b = ()+  runForwards _ a = ((), a)+  runBackwards _ _ y = ((), y)
+ src/Grenade/Recurrent.hs view
@@ -0,0 +1,29 @@+module Grenade.Recurrent (+  -- | This is an empty module which simply re-exports public definitions+  --   for recurrent networks in Grenade.++  -- * Exported modules+  --+  -- | The core types and runners for Recurrent Networks.+    module Grenade.Recurrent.Core++  -- | The recurrent neural network layer zoo+  , module Grenade.Recurrent.Layers++    -- * Overview of recurrent Networks+    -- $recurrent++  ) where++import           Grenade.Recurrent.Core+import           Grenade.Recurrent.Layers++{- $recurrent+There are two ways in which deep learning libraries choose to represent+recurrent Neural Networks, as an unrolled graph, or at a first class+level. Grenade chooses the latter representation, and provides a network+type which is specifically suited for recurrent neural networks.++Currently grenade supports two layers, a basic recurrent layer, and an+LSTM layer.+-}
+ src/Grenade/Recurrent/Core.hs view
@@ -0,0 +1,9 @@+module Grenade.Recurrent.Core (+    module Grenade.Recurrent.Core.Layer+  , module Grenade.Recurrent.Core.Network+  , module Grenade.Recurrent.Core.Runner+  ) where++import           Grenade.Recurrent.Core.Layer+import           Grenade.Recurrent.Core.Network+import           Grenade.Recurrent.Core.Runner
+ src/Grenade/Recurrent/Core/Layer.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+module Grenade.Recurrent.Core.Layer (+    RecurrentLayer (..)+  , RecurrentUpdateLayer (..)+  ) where++import           Data.Singletons ( SingI )++import           Grenade.Core++-- | Class for a recurrent layer.+--   It's quite similar to a normal layer but for the input and output+--   of an extra recurrent data shape.+class UpdateLayer x => RecurrentUpdateLayer x where+  -- | Shape of data that is passed between each subsequent run of the layer+  type RecurrentShape x   :: Shape++class (RecurrentUpdateLayer x, SingI (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where+  -- | Wengert Tape+  type RecTape x i o :: *+  -- | Used in training and scoring. Take the input from the previous+  --   layer, and give the output from this layer.+  runRecurrentForwards    :: x -> S (RecurrentShape x) -> S i -> (RecTape x i o, S (RecurrentShape x), S o)+  -- | Back propagate a step. Takes the current layer, the input that the+  --   layer gave from the input and the back propagated derivatives from+  --   the layer above.+  --   Returns the gradient layer and the derivatives to push back further.+  runRecurrentBackwards   :: x -> RecTape x i o -> S (RecurrentShape x) -> S o -> (Gradient x, S (RecurrentShape x), S i)
+ src/Grenade/Recurrent/Core/Network.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE EmptyDataDecls        #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE UndecidableInstances  #-}++module Grenade.Recurrent.Core.Network (+    Recurrent+  , FeedForward++  , RecurrentNetwork (..)+  , RecurrentInputs (..)+  , RecurrentTapes (..)+  , RecurrentGradients (..)++  , randomRecurrent+  , runRecurrentNetwork+  , runRecurrentGradient+  , applyRecurrentUpdate+  ) where+++import           Control.Monad.Random ( MonadRandom )+import           Data.Singletons ( SingI )+import           Data.Singletons.Prelude ( Head, Last )+import           Data.Serialize+import qualified Data.Vector.Storable as V++import           Grenade.Core+import           Grenade.Recurrent.Core.Layer++import qualified Numeric.LinearAlgebra as LA+import qualified Numeric.LinearAlgebra.Static as LAS++-- | Witness type to say indicate we're building up with a normal feed+--   forward layer.+data FeedForward :: * -> *+-- | Witness type to say indicate we're building up with a recurrent layer.+data Recurrent :: * -> *++-- | Type of a recurrent neural network.+--+--   The [*] type specifies the types of the layers.+--+--   The [Shape] type specifies the shapes of data passed between the layers.+--+--   The definition is similar to a Network, but every layer in the+--   type is tagged by whether it's a FeedForward Layer of a Recurrent layer.+--+--   Often, to make the definitions more concise, one will use a type alias+--   for these empty data types.+data RecurrentNetwork :: [*] -> [Shape] -> * where+  RNil   :: SingI i+         => RecurrentNetwork '[] '[i]++  (:~~>) :: (SingI i, Layer x i h)+         => !x+         -> !(RecurrentNetwork xs (h ': hs))+         -> RecurrentNetwork (FeedForward x ': xs) (i ': h ': hs)++  (:~@>) :: (SingI i, RecurrentLayer x i h)+         => !x+         -> !(RecurrentNetwork xs (h ': hs))+         -> RecurrentNetwork (Recurrent x ': xs) (i ': h ': hs)+infixr 5 :~~>+infixr 5 :~@>++-- | Gradient of a network.+--+--   Parameterised on the layers of the network.+data RecurrentGradients :: [*] -> * where+   RGNil  :: RecurrentGradients '[]++   (://>) :: UpdateLayer x+          => [Gradient x]+          -> RecurrentGradients xs+          -> RecurrentGradients (phantom x ': xs)++-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)+--   Parameterised on the layers of a Network.+data RecurrentInputs :: [*] -> * where+   RINil   :: RecurrentInputs '[]++   (:~~+>) :: UpdateLayer x+           => ()                      -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)++   (:~@+>) :: (SingI (RecurrentShape x), RecurrentUpdateLayer x)+           => !(S (RecurrentShape x)) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)++-- | All the information required to backpropogate+--   through time safely.+--+--   We index on the time step length as well, to ensure+--   that that all Tape lengths are the same.+data RecurrentTapes :: [*] -> [Shape] -> * where+   TRNil  :: SingI i+          => RecurrentTapes '[] '[i]++   (:\~>) :: [Tape x i h]+          -> !(RecurrentTapes xs (h ': hs))+          -> RecurrentTapes (FeedForward x ': xs) (i ': h ': hs)+++   (:\@>) :: [RecTape x i h]+          -> !(RecurrentTapes xs (h ': hs))+          -> RecurrentTapes (Recurrent x ': xs) (i ': h ': hs)+++runRecurrentNetwork  :: forall shapes layers.+                        RecurrentNetwork layers shapes+                     -> RecurrentInputs layers+                     -> [S (Head shapes)]+                     -> (RecurrentTapes layers shapes, RecurrentInputs layers, [S (Last shapes)])+runRecurrentNetwork =+  go+    where+  go  :: forall js sublayers. (Last js ~ Last shapes)+      => RecurrentNetwork sublayers js+      -> RecurrentInputs sublayers+      -> [S (Head js)]+      -> (RecurrentTapes sublayers js, RecurrentInputs sublayers, [S (Last js)])+  -- This is a simple non-recurrent layer, just map it forwards+  go (layer :~~> n) (() :~~+> nIn) !xs+      = let tys                 = runForwards layer <$> xs+            feedForwardTapes    = fst <$> tys+            forwards            = snd <$> tys+            -- recursively run the rest of the network, and get the gradients from above.+            (newFN, ig, answer) = go n nIn forwards+        in (feedForwardTapes :\~> newFN, () :~~+> ig, answer)++  -- This is a recurrent layer, so we need to do a scan, first input to last, providing+  -- the recurrent shape output to the next layer.+  go (layer :~@> n) (recIn :~@+> nIn) !xs+      = let (recOut, tys)       = goR layer recIn xs+            recurrentTapes      = fst <$> tys+            forwards            = snd <$> tys++            (newFN, ig, answer) = go n nIn forwards+        in (recurrentTapes :\@> newFN, recOut :~@+> ig, answer)++  -- Handle the output layer, bouncing the derivatives back down.+  -- We may not have a target for each example, so when we don't use 0 gradient.+  go RNil RINil !x+    = (TRNil, RINil, x)++  -- Helper function for recurrent layers+  -- Scans over the recurrent direction of the graph.+  goR !layer !recShape (x:xs) =+    let (tape, lerec, lepush) = runRecurrentForwards layer recShape x+        (rems, push)          = goR layer lerec xs+    in  (rems, (tape, lepush) : push)+  goR _ rin []      = (rin, [])++runRecurrentGradient :: forall layers shapes.+                        RecurrentNetwork layers shapes+                     -> RecurrentTapes layers shapes+                     -> RecurrentInputs layers+                     -> [S (Last shapes)]+                     -> (RecurrentGradients layers, RecurrentInputs layers, [S (Head shapes)])+runRecurrentGradient net tapes r o =+  go net tapes r+    where+  -- We have to be careful regarding the direction of the lists+  -- Inputs come in forwards, but our return value is backwards+  -- through time.+  go  :: forall js ss. (Last js ~ Last shapes)+      => RecurrentNetwork ss js+      -> RecurrentTapes ss js+      -> RecurrentInputs ss+      -> (RecurrentGradients ss, RecurrentInputs ss, [S (Head js)])+  -- This is a simple non-recurrent layer+  -- Run the rest of the network, then fmap the tapes and gradients+  go (layer :~~> n) (feedForwardTapes :\~> nTapes) (() :~~+> nRecs) =+    let (gradients, rins, feed)  = go n nTapes nRecs+        backs                    = uncurry (runBackwards layer) <$> zip (reverse feedForwardTapes) feed+    in  ((fst <$> backs) ://> gradients, () :~~+> rins, snd <$> backs)++  -- This is a recurrent layer+  -- Run the rest of the network, scan over the tapes in reverse+  go (layer :~@> n) (recurrentTapes :\@> nTapes) (recGrad :~@+> nRecs) =+    let (gradients, rins, feed)  = go n nTapes nRecs+        backExamples             = zip (reverse recurrentTapes) feed+        (rg, backs)              = goX layer recGrad backExamples+    in  ((fst <$> backs) ://> gradients, rg :~@+> rins, snd <$> backs)++  -- End of the road, so we reflect the given gradients backwards.+  -- Crucially, we reverse the list, so it's backwards in time as+  -- well.+  go RNil TRNil RINil+    = (RGNil, RINil, reverse o)++  -- Helper function for recurrent layers+  -- Scans over the recurrent direction of the graph.+  goX :: RecurrentLayer x i o => x -> S (RecurrentShape x) -> [(RecTape x i o, S o)] -> (S (RecurrentShape x), [(Gradient x, S i)])+  goX layer !lastback ((recTape, backgrad):xs) =+    let (layergrad, recgrad, ingrad) = runRecurrentBackwards layer recTape lastback backgrad+        (pushedback, ll)             = goX layer recgrad xs+    in  (pushedback, (layergrad, ingrad) : ll)+  goX _ !lastback []      = (lastback, [])++-- | Apply a batch of gradients to the network+--   Uses runUpdates which can be specialised for+--   a layer.+applyRecurrentUpdate :: LearningParameters+                     -> RecurrentNetwork layers shapes+                     -> RecurrentGradients layers+                     -> RecurrentNetwork layers shapes+applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)+  = runUpdates rate layer gradient :~~> applyRecurrentUpdate rate rest grest++applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)+  = runUpdates rate layer gradient :~@> applyRecurrentUpdate rate rest grest++applyRecurrentUpdate _ RNil RGNil+  = RNil+++instance Show (RecurrentNetwork '[] '[i]) where+  show RNil = "NNil"+instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (FeedForward x ': xs) (i ': rs)) where+  show (x :~~> xs) = show x ++ "\n~~>\n" ++ show xs+instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recurrent x ': xs) (i ': rs)) where+  show (x :~@> xs) = show x ++ "\n~~>\n" ++ show xs+++-- | A network can easily be created by hand with (:~~>) and (:~@>), but an easy way to initialise a random+--   recurrent network and a set of random inputs for it is with the randomRecurrent.+class CreatableRecurrent (xs :: [*]) (ss :: [Shape]) where+  -- | Create a network of the types requested+  randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss, RecurrentInputs xs)++instance SingI i => CreatableRecurrent '[] '[i] where+  randomRecurrent =+    return (RNil, RINil)++instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where+  randomRecurrent = do+    thisLayer     <- createRandom+    (rest, resti) <- randomRecurrent+    return (thisLayer :~~> rest, () :~~+> resti)++instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ':  rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where+  randomRecurrent = do+    thisLayer     <- createRandom+    thisShape     <- randomOfShape+    (rest, resti) <- randomRecurrent+    return (thisLayer :~@> rest, thisShape :~@+> resti)++-- | Add very simple serialisation to the recurrent network+instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where+  put RNil = pure ()+  get = pure RNil++instance (SingI i, Layer x i o, Serialize x, Serialize (RecurrentNetwork xs (o ': rs))) => Serialize (RecurrentNetwork (FeedForward x ': xs) (i ': o ': rs)) where+  put (x :~~> r) = put x >> put r+  get = (:~~>) <$> get <*> get++instance (SingI i, RecurrentLayer x i o, Serialize x, Serialize (RecurrentNetwork xs (o ': rs))) => Serialize (RecurrentNetwork (Recurrent x ': xs) (i ': o ': rs)) where+  put (x :~@> r) = put x >> put r+  get = (:~@>) <$> get <*> get++instance (Serialize (RecurrentInputs '[])) where+  put _ = return ()+  get = return RINil++instance (UpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where+  put ( () :~~+> rest) = put rest+  get = ( () :~~+> ) <$> get++instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where+  put ( i :~@+> rest ) = do+    _ <- (case i of+           (S1D x) -> putListOf put . LA.toList . LAS.extract $ x+           (S2D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x+           (S3D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x+         ) :: PutM ()+    put rest++  get = do+    Just i <- fromStorable . V.fromList <$> getListOf get+    rest   <- get+    return ( i :~@+> rest)+++-- Num instance for `RecurrentInputs layers`+-- Not sure if this is really needed, as I only need a `fromInteger 0` at+-- the moment for training, to create a null gradient on the recurrent+-- edge.+--+-- It does raise an interesting question though? Is a 0 gradient actually+-- the best?+--+-- I could imaging that weakly push back towards the optimum input could+-- help make a more stable generator.+instance (Num (RecurrentInputs '[])) where+  (+) _ _  = RINil+  (-) _ _  = RINil+  (*) _ _  = RINil+  abs _    = RINil+  signum _ = RINil+  fromInteger _ = RINil++instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where+  (+) (() :~~+> x) (() :~~+> y)  = () :~~+> (x + y)+  (-) (() :~~+> x) (() :~~+> y)  = () :~~+> (x - y)+  (*) (() :~~+> x) (() :~~+> y)  = () :~~+> (x * y)+  abs (() :~~+> x)      = () :~~+> abs x+  signum (() :~~+> x)   = () :~~+> signum x+  fromInteger x         = () :~~+> fromInteger x++instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where+  (+) (x :~@+> x') (y :~@+> y')  = (x + y) :~@+> (x' + y')+  (-) (x :~@+> x') (y :~@+> y')  = (x - y) :~@+> (x' - y')+  (*) (x :~@+> x') (y :~@+> y')  = (x * y) :~@+> (x' * y')+  abs (x :~@+> x')      = abs x :~@+> abs x'+  signum (x :~@+> x')   = signum x :~@+> signum x'+  fromInteger x         = fromInteger x :~@+> fromInteger x
+ src/Grenade/Recurrent/Core/Runner.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE RecordWildCards       #-}++module Grenade.Recurrent.Core.Runner (+    trainRecurrent+  , runRecurrent+  , backPropagateRecurrent+  ) where++import           Data.Singletons.Prelude+import           Grenade.Core++import           Grenade.Recurrent.Core.Layer+import           Grenade.Recurrent.Core.Network++-- | Drive and network and collect its back propogated gradients.+backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))+                       => RecurrentNetwork layers shapes+                       -> RecurrentInputs layers+                       -> [(S (Head shapes), Maybe (S (Last shapes)))]+                       -> (RecurrentGradients layers, RecurrentInputs layers)+backPropagateRecurrent network recinputs examples =+  let (tapes, _, guesses)    = runRecurrentNetwork network recinputs inputs++      backPropagations       = zipWith makeError guesses targets++      (gradients, input', _) = runRecurrentGradient network tapes 0 backPropagations++  in (gradients, input')++    where++  inputs  = fst <$> examples+  targets = snd <$> examples++  makeError :: S (Last shapes) -> Maybe (S (Last shapes)) -> S (Last shapes)+  makeError _ Nothing = 0+  makeError y (Just t) = y - t+++trainRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))+               => LearningParameters+               -> RecurrentNetwork layers shapes+               -> RecurrentInputs layers+               -> [(S (Head shapes), Maybe (S (Last shapes)))]+               -> (RecurrentNetwork layers shapes, RecurrentInputs layers)+trainRecurrent rate network recinputs examples =+  let (gradients, recinputs') = backPropagateRecurrent network recinputs examples++      newInputs               = updateRecInputs rate recinputs recinputs'++      newNetwork              = applyRecurrentUpdate rate network gradients++  in  (newNetwork, newInputs)++updateRecInputs :: LearningParameters+                -> RecurrentInputs sublayers+                -> RecurrentInputs sublayers+                -> RecurrentInputs sublayers++updateRecInputs l@LearningParameters {..} (() :~~+> xs) (() :~~+> ys)+  = () :~~+> updateRecInputs l xs ys++updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)+  = (realToFrac (1 - learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys++updateRecInputs _ RINil RINil+  = RINil++-- | Just forwards propagation with no training.+runRecurrent :: RecurrentNetwork layers shapes+             -> RecurrentInputs layers -> S (Head shapes)+             -> (RecurrentInputs layers, S (Last shapes))+runRecurrent (layer :~~> n) (()    :~~+> nr) !x+  = let (_, ys)  = runForwards layer x+        (nr', o) = runRecurrent n nr ys+    in  (() :~~+> nr', o)+runRecurrent (layer :~@> n) (recin :~@+> nr) !x+  = let (_, recin', y) = runRecurrentForwards layer recin x+        (nr', o)       = runRecurrent n nr y+    in  (recin' :~@+> nr', o)+runRecurrent RNil RINil !x+  = (RINil, x)
+ src/Grenade/Recurrent/Layers.hs view
@@ -0,0 +1,7 @@+module Grenade.Recurrent.Layers (+    module Grenade.Recurrent.Layers.BasicRecurrent+  , module Grenade.Recurrent.Layers.LSTM+  ) where++import           Grenade.Recurrent.Layers.BasicRecurrent+import           Grenade.Recurrent.Layers.LSTM
+ src/Grenade/Recurrent/Layers/BasicRecurrent.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE UndecidableInstances  #-}++module Grenade.Recurrent.Layers.BasicRecurrent (+    BasicRecurrent (..)+  , randomBasicRecurrent+  ) where++++import           Control.Monad.Random ( MonadRandom, getRandom )++import           Data.Singletons.TypeLits++import           Numeric.LinearAlgebra.Static++import           GHC.TypeLits++import           Grenade.Core+import           Grenade.Recurrent.Core++data BasicRecurrent :: Nat -- Input layer size+                    -> Nat -- Output layer size+                    -> * where+  BasicRecurrent :: ( KnownNat input+                    , KnownNat output+                    , KnownNat matrixCols+                    , matrixCols ~ (input + output))+                 => !(R output)   -- Bias neuron weights+                 -> !(R output)   -- Bias neuron momentum+                 -> !(L output matrixCols) -- Activation+                 -> !(L output matrixCols) -- Momentum+                 -> BasicRecurrent input output++data BasicRecurrent' :: Nat -- Input layer size+                     -> Nat -- Output layer size+                     -> * where+  BasicRecurrent' :: ( KnownNat input+                     , KnownNat output+                     , KnownNat matrixCols+                     , matrixCols ~ (input + output))+                  => !(R output)   -- Bias neuron gradients+                  -> !(L output matrixCols)+                  -> BasicRecurrent' input output++instance Show (BasicRecurrent i o) where+  show BasicRecurrent {} = "BasicRecurrent"++instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where+  type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)++  runUpdate LearningParameters {..} (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =+    let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient+        newBias         = oldBias + newBiasMomentum+        newMomentum     = konst learningMomentum * oldMomentum - konst learningRate * activationGradient+        regulariser     = konst (learningRegulariser * learningRate) * oldActivations+        newActivations  = oldActivations + newMomentum - regulariser+    in BasicRecurrent newBias newBiasMomentum newActivations newMomentum++  createRandom = randomBasicRecurrent++instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where+  type RecurrentShape (BasicRecurrent i o) = 'D1 o++instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where++  type RecTape (BasicRecurrent i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))+  -- Do a matrix vector multiplication and return the result.+  runRecurrentForwards (BasicRecurrent wB _ wN _) (S1D lastOutput) (S1D thisInput) =+    let thisOutput = S1D $ wB + wN #> (thisInput # lastOutput)+    in ((S1D lastOutput, S1D thisInput), thisOutput, thisOutput)++  -- Run a backpropogation step for a full connected layer.+  runRecurrentBackwards (BasicRecurrent _ _ wN _) (S1D lastOutput, S1D thisInput) (S1D dRec) (S1D dEdy) =+    let biasGradient        = (dRec + dEdy)+        layerGrad           = (dRec + dEdy) `outer` (thisInput # lastOutput)+        -- calcluate derivatives for next step+        (backGrad, recGrad) = split $ tr wN #> (dRec + dEdy)+    in  (BasicRecurrent' biasGradient layerGrad, S1D recGrad, S1D backGrad)++randomBasicRecurrent :: (MonadRandom m, KnownNat i, KnownNat o, KnownNat x, x ~ (i + o))+                     => m (BasicRecurrent i o)+randomBasicRecurrent = do+    seed1 <- getRandom+    seed2 <- getRandom+    let wB = randomVector seed1 Uniform * 2 - 1+        wN = uniformSample seed2 (-1) 1+        bm = konst 0+        mm = konst 0+    return $ BasicRecurrent wB bm wN mm
+ src/Grenade/Recurrent/Layers/LSTM.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE ViewPatterns          #-}+{-# LANGUAGE ScopedTypeVariables   #-}++module Grenade.Recurrent.Layers.LSTM (+    LSTM (..)+  , LSTMWeights (..)+  , randomLSTM+  ) where++import           Control.Monad.Random ( MonadRandom, getRandom )++-- import           Data.List ( foldl1' )+import           Data.Proxy+import           Data.Serialize+import           Data.Singletons.TypeLits++import qualified Numeric.LinearAlgebra as LA+import           Numeric.LinearAlgebra.Static++import           Grenade.Core+import           Grenade.Recurrent.Core+import           Grenade.Layers.Internal.Update+++-- | Long Short Term Memory Recurrent unit+--+--   This is a Peephole formulation, so the recurrent shape is+--   just the cell state, the previous output is not held or used+--   at all.+data LSTM :: Nat -> Nat -> * where+  LSTM :: ( KnownNat input+          , KnownNat output+          ) => !(LSTMWeights input output) -- Weights+            -> !(LSTMWeights input output) -- Momentums+            -> LSTM input output++data LSTMWeights :: Nat -> Nat -> * where+  LSTMWeights :: ( KnownNat input+                 , KnownNat output+                 ) => {+                   lstmWf :: !(L output input)  -- Weight Forget     (W_f)+                 , lstmUf :: !(L output output) -- Cell State Forget (U_f)+                 , lstmBf :: !(R output)        -- Bias Forget       (b_f)+                 , lstmWi :: !(L output input)  -- Weight Input      (W_i)+                 , lstmUi :: !(L output output) -- Cell State Input  (U_i)+                 , lstmBi :: !(R output)        -- Bias Input        (b_i)+                 , lstmWo :: !(L output input)  -- Weight Output     (W_o)+                 , lstmUo :: !(L output output) -- Cell State Output (U_o)+                 , lstmBo :: !(R output)        -- Bias Output       (b_o)+                 , lstmWc :: !(L output input)  -- Weight Cell       (W_c)+                 , lstmBc :: !(R output)        -- Bias Cell         (b_c)+                 } -> LSTMWeights input output++instance Show (LSTM i o) where+  show LSTM {} = "LSTM"++instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where+  -- The gradients are the same shape as the weights and momentum+  -- This seems to be a general pattern, maybe it should be enforced.+  type Gradient (LSTM i o) = (LSTMWeights i o)++  -- Run the update function for each group matrix/vector of weights, momentums and gradients.+  -- Hmm, maybe the function should be used instead of passing in the learning parameters.+  runUpdate LearningParameters {..} (LSTM w m) g =+    let (wf, wf') = u lstmWf w m g+        (uf, uf') = u lstmUf w m g+        (bf, bf') = v lstmBf w m g+        (wi, wi') = u lstmWi w m g+        (ui, ui') = u lstmUi w m g+        (bi, bi') = v lstmBi w m g+        (wo, wo') = u lstmWo w m g+        (uo, uo') = u lstmUo w m g+        (bo, bo') = v lstmBo w m g+        (wc, wc') = u lstmWc w m g+        (bc, bc') = v lstmBc w m g+    in LSTM (LSTMWeights wf uf bf wi ui bi wo uo bo wc bc) (LSTMWeights wf' uf' bf' wi' ui' bi' wo' uo' bo' wc' bc')+      where+    -- Utility function for updating with the momentum, gradients, and weights.+    u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))+    u e (e -> weights) (e -> momentum) (e -> gradient) =+      decendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum++    v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))+    v e (e -> weights) (e -> momentum) (e -> gradient) =+      decendVector learningRate learningMomentum learningRegulariser weights gradient momentum++  -- There's a lot of updates here, so to try and minimise the number of data copies+  -- we'll create a mutable bucket for each.+  -- runUpdates rate lstm gs =+  --   let combinedGradient = foldl1' uu gs+  --   in  runUpdate rate lstm combinedGradient+  --     where+  --   uu :: (KnownNat i, KnownNat o) => LSTMWeights i o -> LSTMWeights i o -> LSTMWeights i o+  --   uu a b =+  --     let wf = u lstmWf a b+  --         uf = u lstmUf a b+  --         bf = v lstmBf a b+  --         wi = u lstmWi a b+  --         ui = u lstmUi a b+  --         bi = v lstmBi a b+  --         wo = u lstmWo a b+  --         uo = u lstmUo a b+  --         bo = v lstmBo a b+  --         wc = u lstmWc a b+  --         bc = v lstmBc a b+  --     in LSTMWeights wf uf bf wi ui bi wo uo bo wc bc+  --   u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> L out ix+  --   u e (e -> a) (e -> b) = tr $ tr a + tr b++  --   v :: forall x ix. (x -> (R ix)) -> x -> x -> R ix+  --   v e (e -> a) (e -> b) = a + b+  createRandom = randomLSTM++instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where+  -- The recurrent shape is the same size as the output.+  -- It's actually the cell state however, as this is a peephole variety LSTM.+  type RecurrentShape (LSTM i o) = 'D1 o++instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where++  type RecTape (LSTM i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))+  -- Forward propagation for the LSTM layer.+  -- The size of the cell state is also the size of the output.+  runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =+    let -- Forget state vector+        f_t = sigmoid $ lstmBf + lstmWf #> input + lstmUf #> cell+        -- Input state vector+        i_t = sigmoid $ lstmBi + lstmWi #> input + lstmUi #> cell+        -- Output state vector+        o_t = sigmoid $ lstmBo + lstmWo #> input + lstmUo #> cell+        -- Cell input state vector+        c_x = tanh    $ lstmBc + lstmWc #> input+        -- Cell state+        c_t = f_t * cell + i_t * c_x+        -- Output (it's sometimes recommended to use tanh c_t)+        h_t = o_t * c_t+    in ((S1D cell, S1D input), S1D c_t, S1D h_t)++  -- Run a backpropogation step for an LSTM layer.+  -- We're doing all the derivatives by hand here, so one should+  -- be extra careful when changing this.+  --+  -- There's a test version using the AD library without hmatrix in the test+  -- suite. These should match always.+  runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (S1D cell, S1D input) (S1D cellGrad) (S1D h_t') =+    -- We're not keeping the Wengert tape during the forward pass,+    -- so we're duplicating some work here.+    --+    -- If I was being generous, I'd call it checkpointing.+    --+    -- Maybe think about better ways to store some intermediate states.+    let -- Forget state vector+        f_s = lstmBf + lstmWf #> input + lstmUf #> cell+        f_t = sigmoid f_s+        -- Input state vector+        i_s = lstmBi + lstmWi #> input + lstmUi #> cell+        i_t = sigmoid i_s+        -- Output state vector+        o_s = lstmBo + lstmWo #> input + lstmUo #> cell+        o_t = sigmoid o_s+        -- Cell input state vector+        c_s = lstmBc + lstmWc #> input+        c_x = tanh c_s+        -- Cell state+        c_t = f_t * cell + i_t * c_x++        -- Reverse Mode AD Derivitives+        c_t' = h_t' * o_t + cellGrad++        f_t' = c_t' * cell+        f_s' = sigmoid' f_s * f_t'++        o_t' = h_t' * c_t+        o_s' = sigmoid' o_s * o_t'++        i_t' = c_t' * c_x+        i_s' = sigmoid' i_s * i_t'++        c_x' = c_t' * i_t+        c_s' = tanh' c_s * c_x'++        -- The derivatives to pass sideways (recurrent) and downwards+        cell'  = tr lstmUf #> f_s' + tr lstmUo #> o_s' + tr lstmUi #> i_s' + c_t' * f_t+        input' = tr lstmWf #> f_s' + tr lstmWo #> o_s' + tr lstmWi #> i_s' + tr lstmWc #> c_s'++        -- Calculate the gradient Matricies for the input+        lstmWf' = f_s' `outer` input+        lstmWi' = i_s' `outer` input+        lstmWo' = o_s' `outer` input+        lstmWc' = c_s' `outer` input++        -- Calculate the gradient Matricies for the cell+        lstmUf' = f_s' `outer` cell+        lstmUi' = i_s' `outer` cell+        lstmUo' = o_s' `outer` cell++        -- The biases just get the values, but we'll write it so it's obvious+        lstmBf' = f_s'+        lstmBi' = i_s'+        lstmBo' = o_s'+        lstmBc' = c_s'++        gradients = LSTMWeights lstmWf' lstmUf' lstmBf' lstmWi' lstmUi' lstmBi' lstmWo' lstmUo' lstmBo' lstmWc' lstmBc'+    in  (gradients, S1D cell', S1D input')++-- | Generate an LSTM layer with random Weights+--   one can also just call createRandom from UpdateLayer+--+--   Has forget gate biases set to 1 to encourage early learning.+--+--   https://github.com/karpathy/char-rnn/commit/0dfeaa454e687dd0278f036552ea1e48a0a408c9+--+randomLSTM :: forall m i o. (MonadRandom m, KnownNat i, KnownNat o)+           => m (LSTM i o)+randomLSTM = do+    let w = (\s -> uniformSample s (-1) 1 ) <$> getRandom+        u = (\s -> uniformSample s (-1) 1 ) <$> getRandom+        v = (\s -> randomVector s Uniform * 2 - 1) <$> getRandom++        w0 = konst 0+        u0 = konst 0+        v0 = konst 0++    LSTM <$> (LSTMWeights <$> w <*> u <*> pure (konst 1) <*> w <*> u <*> v <*> w <*> u <*> v <*> w <*> v)+         <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)++-- | Maths+--+-- TODO: move to not here+sigmoid :: Floating a => a -> a+sigmoid x = 1 / (1 + exp (-x))++sigmoid' :: Floating a => a -> a+sigmoid' x = logix * (1 - logix)+  where+    logix = sigmoid x++tanh' :: (Floating a) => a -> a+tanh' t = 1 - s ^ (2 :: Int)  where s = tanh t++instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where+  put (LSTM LSTMWeights {..} _) = do+    u lstmWf+    u lstmUf+    v lstmBf+    u lstmWi+    u lstmUi+    v lstmBi+    u lstmWo+    u lstmUo+    v lstmBo+    u lstmWc+    v lstmBc+      where+    u :: forall a b. (KnownNat a, KnownNat b) => Putter  (L b a)+    u = putListOf put . LA.toList . LA.flatten . extract+    v :: forall a. (KnownNat a) => Putter (R a)+    v = putListOf put . LA.toList . extract++  get = do+    lstmWf <- u+    lstmUf <- u+    lstmBf <- v+    lstmWi <- u+    lstmUi <- u+    lstmBi <- v+    lstmWo <- u+    lstmUo <- u+    lstmBo <- v+    lstmWc <- u+    lstmBc <- v+    return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)+      where+    u :: forall a b. (KnownNat a, KnownNat b) => Get  (L b a)+    u = let f = fromIntegral $ natVal (Proxy :: Proxy a)+        in  maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get+    v :: forall a. (KnownNat a) => Get (R a)+    v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get++    w0 = konst 0+    u0 = konst 0+    v0 = konst 0
+ src/Grenade/Utils/OneHot.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE RankNTypes            #-}++module Grenade.Utils.OneHot (+    oneHot+  , hotMap+  , makeHot+  , unHot+  , sample+  ) where++import qualified Control.Monad.Random as MR++import           Data.List ( group, sort )++import           Data.Map ( Map )+import qualified Data.Map as M++import           Data.Proxy+import           Data.Singletons.TypeLits++import           Data.Vector ( Vector )+import qualified Data.Vector as V+import qualified Data.Vector.Storable as VS++import           Numeric.LinearAlgebra ( maxIndex )+import           Numeric.LinearAlgebra.Devel+import           Numeric.LinearAlgebra.Static++import           Grenade.Core.Shape++-- | From an int which is hot, create a 1D Shape+--   with one index hot (1) with the rest 0.+--   Rerurns Nothing if the hot number is larger+--   than the length of the vector.+oneHot :: forall n. (KnownNat n)+       => Int -> Maybe (S ('D1 n))+oneHot hot =+  let len = fromIntegral $ natVal (Proxy :: Proxy n)+  in if hot < len+      then+        fmap S1D . create $ runSTVector $ do+        vec    <- newVector 0 len+        writeVector vec hot 1+        return vec+      else Nothing++-- | Create a one hot map from any enumerable.+--   Returns a map, and the ordered list for the reverse transformation+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Maybe (Map a Int, Vector a)+hotMap n as =+  let len  = fromIntegral $ natVal n+      uniq = [ c | (c:_) <- group $ sort as]+      hotl = length uniq+  in if hotl <= len+      then+        Just (M.fromList $ zip uniq [0..], V.fromList uniq)+      else Nothing++-- | From a map and value, create a 1D Shape+--   with one index hot (1) with the rest 0.+--   Rerurns Nothing if the hot number is larger+--   than the length of the vector or the map+--   doesn't contain the value.+makeHot :: forall a n. (Ord a, KnownNat n)+        => Map a Int -> a -> Maybe (S ('D1 n))+makeHot m x = do+  hot    <- M.lookup x m+  let len = fromIntegral $ natVal (Proxy :: Proxy n)+  if hot < len+      then+        fmap S1D . create $ runSTVector $ do+        vec    <- newVector 0 len+        writeVector vec hot 1+        return vec+      else Nothing++unHot :: forall a n. KnownNat n+      => Vector a -> S ('D1 n) -> Maybe a+unHot v (S1D xs)+  = (V.!?) v+  $ maxIndex (extract xs)++sample :: forall a n m. (KnownNat n, MR.MonadRandom m)+       => Double -> Vector a -> S ('D1 n) -> m a+sample temperature v (S1D xs) = do+  ix <- MR.fromList . zip [0..] . fmap (toRational . exp . (/ temperature) . log) . VS.toList . extract $ xs+  return $ v V.! ix
+ test/Test/Grenade/Layers/Convolution.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE TypeOperators         #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Grenade.Layers.Convolution where++import           Unsafe.Coerce+import           Data.Constraint+import           Data.Proxy+import           Data.Singletons ()+import           GHC.TypeLits+import           GHC.TypeLits.Witnesses++import           Grenade.Core+import           Grenade.Layers.Convolution++import           Hedgehog+import qualified Hedgehog.Gen as Gen++import           Test.Hedgehog.Hmatrix+import           Test.Hedgehog.TypeLits+import           Test.Hedgehog.Compat++data OpaqueConvolution :: * where+     OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution++instance Show OpaqueConvolution where+    show (OpaqueConvolution n) = show n++genConvolution :: ( KnownNat channels+                  , KnownNat filters+                  , KnownNat kernelRows+                  , KnownNat kernelColumns+                  , KnownNat strideRows+                  , KnownNat strideColumns+                  , KnownNat kernelFlattened+                  , kernelFlattened ~ (kernelRows * kernelColumns * channels)+                  , Monad m+                  ) => Gen.Gen m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)+genConvolution = Convolution <$> uniformSample <*> uniformSample++genOpaqueOpaqueConvolution :: Monad m => Gen m OpaqueConvolution+genOpaqueOpaqueConvolution = do+    channels <- genNat+    filters  <- genNat+    kernel_h <- genNat+    kernel_w <- genNat+    stride_h <- genNat+    stride_w <- genNat+    case (channels, filters, kernel_h, kernel_w, stride_h, stride_w) of+       ( SomeNat (pch :: Proxy ch), SomeNat  (_   :: Proxy fl),+         SomeNat (pkr :: Proxy kr), SomeNat  (pkc :: Proxy kc),+         SomeNat (_   :: Proxy sr), SomeNat  (_   :: Proxy sc)) ->+          let p1 = natDict pkr+              p2 = natDict pkc+              p3 = natDict pch+          in  case p1 %* p2 %* p3 of+            Dict -> OpaqueConvolution <$> (genConvolution :: Monad n => Gen n (Convolution ch fl kr kc sr sc))++prop_conv_net_witness = property $+  blindForAll genOpaqueOpaqueConvolution >>= \onet ->+    case onet of+       (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> success+++prop_conv_net = property $+  blindForAll genOpaqueOpaqueConvolution >>= \onet ->+    case onet of+       (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->+          let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]+              kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)+              kc = fromIntegral $ natVal (Proxy :: Proxy kernelCols)+              sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)+              sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)++          in  forAll (Gen.element (ok sr kr)) >>= \er ->+                  forAll (Gen.element (ok sc kc)) >>= \ec ->+                      let rr = ((er - kr) `div` sr) + 1+                          rc = ((ec - kc) `div` sc) + 1+                          Just er' = someNatVal er+                          Just ec' = someNatVal ec+                          Just rr' = someNatVal rr+                          Just rc' = someNatVal rc+                      in case (er', ec', rr', rc') of+                            ( SomeNat (pinr :: Proxy inRows), SomeNat (_  :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->+                              case ( natDict pinr %* natDict (Proxy :: Proxy channels)+                                   , natDict pour %* natDict (Proxy :: Proxy filters)+                                   -- Fake it till you make it.+                                   , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))+                                   , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of+                                (Dict, Dict, Dict, Dict) ->+                                    blindForAll (S3D <$> uniformSample) >>= \(input :: S ('D3 inRows inCols channels)) ->+                                        let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input+                                            backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))+                                                                                              = runBackwards convLayer tape output+                                        in  backed `seq` success+++tests :: IO Bool+tests = $$(checkConcurrent)
+ test/Test/Grenade/Layers/FullyConnected.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Grenade.Layers.FullyConnected where++import           Data.Proxy+import           Data.Singletons ()++import           GHC.TypeLits++import           Grenade.Core+import           Grenade.Layers.FullyConnected++import           Hedgehog++import           Test.Hedgehog.Compat+import           Test.Hedgehog.Hmatrix++data OpaqueFullyConnected :: * where+     OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected++instance Show OpaqueFullyConnected where+    show (OpaqueFullyConnected n) = show n++genOpaqueFullyConnected :: Monad m => Gen m OpaqueFullyConnected+genOpaqueFullyConnected = do+    input   :: Integer  <- choose 2 100+    output  :: Integer  <- choose 1 100+    let Just input'      = someNatVal input+    let Just output'     = someNatVal output+    case (input', output') of+       (SomeNat (Proxy :: Proxy i'), SomeNat (Proxy :: Proxy o')) -> do+            wB    <- randomVector+            bM    <- randomVector+            wN    <- uniformSample+            kM    <- uniformSample+            return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')++prop_fully_connected_forwards :: Property+prop_fully_connected_forwards = property $ do+    OpaqueFullyConnected (fclayer :: FullyConnected i o) <- blindForAll genOpaqueFullyConnected+    input :: S ('D1 i) <- blindForAll (S1D <$> randomVector)+    let (tape, output :: S ('D1 o)) = runForwards fclayer input+        backed :: (Gradient (FullyConnected i o), S ('D1 i))+                                    = runBackwards fclayer tape output+    backed `seq` success++tests :: IO Bool+tests = $$(checkConcurrent)
+ test/Test/Grenade/Layers/Internal/Convolution.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE TypeOperators       #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Grenade.Layers.Internal.Convolution where++import           Grenade.Layers.Internal.Convolution++import           Numeric.LinearAlgebra hiding (uniformSample, konst, (===))++import           Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import qualified Test.Grenade.Layers.Internal.Reference as Reference+import           Test.Hedgehog.Compat++prop_im2col_col2im_symmetrical_with_kernel_stride =+  let factors n = [x | x <- [1..n], n `mod` x == 0]+  in  property $ do+        height   <- forAll $ choose 2 100+        width    <- forAll $ choose 2 100+        kernel_h <- forAll $ (height `div`)    <$> Gen.element (factors height)+        kernel_w <- forAll $ (width `div`)     <$> Gen.element (factors width)+        input    <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)++        let stride_h = kernel_h+        let stride_w = kernel_w+        let out      = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input+        input === out++prop_im2col_col2im_behaves_as_reference =+  let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]+  in  property $ do+        height   <- forAll (choose 2 100)+        width    <- forAll (choose 2 100)+        kernel_h <- forAll (choose 2 (height - 1))+        kernel_w <- forAll (choose 2 (width - 1))+        stride_h <- forAll (Gen.element (ok height kernel_h))+        stride_w <- forAll (Gen.element (ok width kernel_w))+        input    <- forAll ((height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100))++        let outFast       = im2col kernel_h kernel_w stride_h stride_w input+        let retFast       = col2im kernel_h kernel_w stride_h stride_w height width outFast++        let outReference  = Reference.im2col kernel_h kernel_w stride_h stride_w  input+        let retReference  = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference++        outFast === outReference+        retFast === retReference++return []+tests :: IO Bool+tests = $$(checkConcurrent)
+ test/Test/Grenade/Layers/Internal/Pooling.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE TypeOperators       #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Grenade.Layers.Internal.Pooling where++import           Grenade.Layers.Internal.Pooling++import           Numeric.LinearAlgebra hiding (uniformSample, konst, (===))++import           Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import qualified Test.Grenade.Layers.Internal.Reference as Reference+import           Test.Hedgehog.Compat++prop_poolForwards_poolBackwards_behaves_as_reference =+  let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]+      output extent kernel stride = (extent - kernel) `div` stride + 1+  in  property $ do+        height   <- forAll $ choose 2 100+        width    <- forAll $ choose 2 100+        kernel_h <- forAll $ choose 1 (height - 1)+        kernel_w <- forAll $ choose 1 (width - 1)+        stride_h <- forAll $ Gen.element (ok height kernel_h)+        stride_w <- forAll $ Gen.element (ok width kernel_w)+        input    <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)++        let outFast       = poolForward 1 height width kernel_h kernel_w stride_h stride_w input+        let retFast       = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input outFast++        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+        let retReference  = Reference.poolBackward kernel_h kernel_w stride_h stride_w  input outReference++        outFast === outReference+        retFast === retReference+++tests :: IO Bool+tests = $$(checkConcurrent)
+ test/Test/Grenade/Layers/Internal/Reference.hs view
@@ -0,0 +1,100 @@+module Test.Grenade.Layers.Internal.Reference where++import           Numeric.LinearAlgebra++im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+im2col nrows ncols srows scols m =+  let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols+  in  im2colFit starts nrows ncols m++vid2col :: Int -> Int -> Int -> Int -> Int -> Int -> [Matrix Double] -> Matrix Double+vid2col nrows ncols srows scols inputrows inputcols ms =+  let starts = fittingStarts inputrows nrows srows inputcols ncols scols+      subs   = fmap (im2colFit starts nrows ncols) ms+  in  foldl1 (|||) subs++im2colFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double+im2colFit starts nrows ncols m =+  let imRows = fmap (\start -> flatten $ subMatrix start (nrows, ncols) m) starts+  in  fromRows imRows++col2vid :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> [Matrix Double]+col2vid nrows ncols srows scols drows dcols m =+  let starts = fittingStart (cols m) (nrows * ncols) (nrows * ncols)+      r      = rows m+      mats   = fmap (\s -> subMatrix (0,s) (r, nrows * ncols) m) starts+      colSts = fittingStarts drows nrows srows dcols ncols scols+  in  fmap (col2imfit colSts nrows ncols drows dcols) mats++col2im :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+col2im krows kcols srows scols drows dcols m =+  let starts     = fittingStarts drows krows srows dcols kcols scols+  in  col2imfit starts krows kcols drows dcols m++col2imfit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+col2imfit starts krows kcols drows dcols m =+  let indicies   = (\[a,b] -> (a,b)) <$> sequence [[0..(krows-1)], [0..(kcols-1)]]+      convs      = fmap (zip indicies . toList) . toRows $ m+      pairs      = zip convs starts+      accums     = concatMap (\(conv',(stx',sty')) -> fmap (\((ix,iy), val) -> ((ix + stx', iy + sty'), val)) conv') pairs+  in  accum (konst 0 (drows, dcols)) (+) accums++poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+poolForward nrows ncols srows scols outputRows outputCols m =+  let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols+  in  poolForwardFit starts nrows ncols outputRows outputCols m++poolForwardList :: Functor f => Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> f (Matrix Double) -> f (Matrix Double)+poolForwardList nrows ncols srows scols inRows inCols outputRows outputCols ms =+  let starts = fittingStarts inRows nrows srows inCols ncols scols+  in  poolForwardFit starts nrows ncols outputRows outputCols <$> ms++poolForwardFit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double+poolForwardFit starts nrows ncols _ outputCols m =+  let els    = fmap (\start -> maxElement $ subMatrix start (nrows, ncols) m) starts+  in  matrix outputCols els++poolBackward :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double+poolBackward krows kcols srows scols inputMatrix gradientMatrix =+  let inRows     = rows inputMatrix+      inCols     = cols inputMatrix+      starts     = fittingStarts inRows krows srows inCols kcols scols+  in  poolBackwardFit starts krows kcols inputMatrix gradientMatrix++poolBackwardList :: Functor f => Int -> Int -> Int -> Int -> Int -> Int -> f (Matrix Double, Matrix Double) -> f (Matrix Double)+poolBackwardList krows kcols srows scols inRows inCols inputMatrices =+  let starts     = fittingStarts inRows krows srows inCols kcols scols+  in  uncurry (poolBackwardFit starts krows kcols) <$> inputMatrices++poolBackwardFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double+poolBackwardFit starts krows kcols inputMatrix gradientMatrix =+  let inRows     = rows inputMatrix+      inCols     = cols inputMatrix+      inds       = fmap (\start -> maxIndex $ subMatrix start (krows, kcols) inputMatrix) starts+      grads      = toList $ flatten gradientMatrix+      grads'     = zip3 starts grads inds+      accums     = fmap (\((stx',sty'),grad,(inx, iny)) -> ((stx' + inx, sty' + iny), grad)) grads'+  in  accum (konst 0 (inRows, inCols)) (+) accums++-- | These functions are not even remotely safe, but it's only called from the statically typed+--   commands, so we should be good ?!?!?+--   Returns the starting sub matrix locations which fit inside the larger matrix for the+--   convolution. Takes into account the stride and kernel size.+fittingStarts :: Int -> Int -> Int -> Int -> Int -> Int -> [(Int,Int)]+fittingStarts nrows kernelrows steprows ncols kernelcols stepcolsh =+  let rs = fittingStart nrows kernelrows steprows+      cs = fittingStart ncols kernelcols stepcolsh+      ls = sequence [rs, cs]+  in  fmap (\[a,b] -> (a,b)) ls++-- | Returns the starting sub vector which fit inside the larger vector for the+--   convolution. Takes into account the stride and kernel size.+fittingStart :: Int -> Int -> Int -> [Int]+fittingStart width kernel steps =+  let go left | left + kernel < width+              = left : go (left + steps)+              | left + kernel == width+              = [left]+              | otherwise+              = []+  in go 0
+ test/Test/Grenade/Layers/Nonlinear.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase          #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Grenade.Layers.Nonlinear where++import           Data.Singletons++import           Grenade++import           Hedgehog++import           Test.Hedgehog.Compat+import           Test.Hedgehog.Hmatrix+import           Test.Hedgehog.TypeLits++import           Numeric.LinearAlgebra.Static ( norm_Inf )++prop_sigmoid_grad :: Property+prop_sigmoid_grad = property $+    blindForAll genShape >>= \case+        (SomeSing (r :: Sing s)) ->+            withSingI r $+                blindForAll genOfShape >>= \(ds :: S s) ->+                    let (tape, f  :: S s)  = runForwards Logit ds+                        ((), ret  :: S s)  = runBackwards Logit tape (1 :: S s)+                        (_, numer :: S s)  = runForwards Logit (ds + 0.0001)+                        numericalGradient  = (numer - f) * 10000+                    in assert ((case numericalGradient - ret of+                           (S1D x) -> norm_Inf x < 0.0001+                           (S2D x) -> norm_Inf x < 0.0001+                           (S3D x) -> norm_Inf x < 0.0001) :: Bool)++prop_tanh_grad :: Property+prop_tanh_grad = property $+    blindForAll genShape >>= \case+        (SomeSing (r :: Sing s)) ->+            withSingI r $+                blindForAll genOfShape >>=  \(ds :: S s) ->+                    let (tape, f  :: S s)  = runForwards Tanh ds+                        ((), ret  :: S s)  = runBackwards Tanh tape (1 :: S s)+                        (_, numer :: S s)  = runForwards Tanh (ds + 0.0001)+                        numericalGradient  = (numer - f) * 10000+                    in assert ((case numericalGradient - ret of+                           (S1D x) -> norm_Inf x < 0.001+                           (S2D x) -> norm_Inf x < 0.001+                           (S3D x) -> norm_Inf x < 0.001) :: Bool)++tests :: IO Bool+tests = $$(checkConcurrent)+
+ test/Test/Grenade/Layers/PadCrop.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++#if __GLASGOW_HASKELL__ < 800+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+#endif++module Test.Grenade.Layers.PadCrop where++import           Grenade++import           Hedgehog++import           Numeric.LinearAlgebra.Static ( norm_Inf )++import           Test.Hedgehog.Hmatrix++prop_pad_crop :: Property+prop_pad_crop =+  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 ]+      net = Pad :~> Crop :~> NNil+  in  property $+    forAll genOfShape >>= \(d :: S ('D3 7 9 5)) ->+      let (tapes, res)  = runForwards  net d+          (_    , grad) = runBackwards net tapes d+      in  do assert $ d ~~~ res+             assert $ grad ~~~ d++prop_pad_crop_2d :: Property+prop_pad_crop_2d =+  let net :: Network '[Pad 2 3 4 6, Crop 2 3 4 6] '[ 'D2 7 9, 'D2 16 15, 'D2 7 9 ]+      net = Pad :~> Crop :~> NNil+  in  property $+    forAll genOfShape >>= \(d :: S ('D2 7 9)) ->+      let (tapes, res)  = runForwards  net d+          (_    , grad) = runBackwards net tapes d+      in  do assert $ d ~~~ res+             assert $ grad ~~~ d++(~~~) :: S x -> S x -> Bool+(S1D x) ~~~ (S1D y) = norm_Inf (x - y) < 0.00001+(S2D x) ~~~ (S2D y) = norm_Inf (x - y) < 0.00001+(S3D x) ~~~ (S3D y) = norm_Inf (x - y) < 0.00001+++tests :: IO Bool+tests = $$(checkConcurrent)
+ test/Test/Grenade/Layers/Pooling.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Grenade.Layers.Pooling where++import           Data.Proxy+import           Data.Singletons ()++import           GHC.TypeLits+import           Grenade.Layers.Pooling++import           Hedgehog+import qualified Hedgehog.Gen as Gen++import           Test.Hedgehog.Compat++data OpaquePooling :: * where+     OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling++instance Show OpaquePooling where+    show (OpaquePooling n) = show n++genOpaquePooling :: Monad m => Gen.Gen m OpaquePooling+genOpaquePooling = do+    Just kernelHeight <- someNatVal <$> choose 2 15+    Just kernelWidth  <- someNatVal <$> choose 2 15+    Just strideHeight <- someNatVal <$> choose 2 15+    Just strideWidth  <- someNatVal <$> choose 2 15++    case (kernelHeight, kernelWidth, strideHeight, strideWidth) of+       (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->+            return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)++prop_pool_layer_witness =+  property $ do+    onet <- forAll genOpaquePooling+    case onet of+      (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) ->+        assert True++tests :: IO Bool+tests = $$(checkConcurrent)
+ test/Test/Grenade/Network.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE FlexibleContexts      #-}+module Test.Grenade.Network where++import           Control.Monad ( guard )+import           Control.Monad.ST ( runST )++import           Data.Constraint+#if __GLASGOW_HASKELL__ < 800+import           Data.Proxy+#endif+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Storable.Mutable as VS ( write )+import           Data.Singletons+import           Data.Singletons.Prelude.List+import           Data.Singletons.TypeLits++-- import           Data.Type.Equality++import           Hedgehog+import qualified Hedgehog.Gen as Gen+import           Hedgehog.Internal.Source+import           Hedgehog.Internal.Property ( failWith )++import           Grenade++import           GHC.TypeLits+import           GHC.TypeLits.Witnesses+import           Test.Hedgehog.Compat+import           Test.Hedgehog.TypeLits+import           Test.Hedgehog.Hmatrix+import           Test.Grenade.Layers.Convolution++import           Numeric.LinearAlgebra ( flatten )+import           Numeric.LinearAlgebra.Static ( extract, norm_Inf )+import           Unsafe.Coerce++data SomeNetwork :: * where+    SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork++instance Show SomeNetwork where+  show (SomeNetwork net) = show net++-- | Generate a random network of a random type+--+-- This is slightly insane for a few reasons. Everything must be wrapped up+-- in a SomeNetwork.+genNetwork :: Monad m => Gen.Gen m SomeNetwork+genNetwork =+  Gen.recursive Gen.choice [+      do SomeSing ( r :: Sing final ) <- genShape+         withSingI r $+           pure (SomeNetwork (NNil :: Network '[] '[ final ] ))+    ] [+      do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork+         case ( sing :: Sing shapes ) of+           SNil -> Gen.discard+           SCons ( h :: Sing h ) ( _ :: Sing hs ) ->+             withSingI h $+              case h of+                 D1Sing l -> withKnownNat l $+                   Gen.choice [+                     pure (SomeNetwork (Tanh    :~> rest :: Network ( Tanh    ': layers ) ( h ': h ': hs )))+                   , pure (SomeNetwork (Logit   :~> rest :: Network ( Logit   ': layers ) ( h ': h ': hs )))+                   , pure (SomeNetwork (Relu    :~> rest :: Network ( Relu    ': layers ) ( h ': h ': hs )))+                   , pure (SomeNetwork (Elu     :~> rest :: Network ( Elu     ': layers ) ( h ': h ': hs )))+                   , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))+                   , do -- Reshape to two dimensions+                        let divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]+                        let len = natVal l+                        rs  <- Gen.element $ divisors len+                        let cs  = len `quot` rs+                        case ( someNatVal rs, someNatVal cs, someNatVal len ) of+                          ( Just (SomeNat (rs' :: Proxy inRows)), Just (SomeNat (cs' :: Proxy inCols)), Just (SomeNat (_ :: Proxy outLen ) )) ->+                            let p1 = natDict rs'+                                p2 = natDict cs'+                            in  case ( p1 %* p2, unsafeCoerce (Dict :: Dict ()) :: Dict ((inRows * inCols) ~ outLen), unsafeCoerce (Dict :: Dict ()) :: Dict (( 'D1 outLen ) ~ h )) of+                                  ( Dict, Dict, Dict ) ->+                                    pure (SomeNetwork (Reshape :~> rest :: Network ( Reshape ': layers ) ( ('D2 inRows inCols) ': h ': hs )))+                          _ -> Gen.discard -- Doesn't occur+                   ]+                 D2Sing r c -> withKnownNat r $ withKnownNat c $+                   Gen.choice [+                     pure (SomeNetwork (Tanh    :~> rest :: Network ( Tanh    ': layers ) ( h ': h ': hs )))+                   , pure (SomeNetwork (Logit   :~> rest :: Network ( Logit   ': layers ) ( h ': h ': hs )))+                   , pure (SomeNetwork (Relu    :~> rest :: Network ( Relu    ': layers ) ( h ': h ': hs )))+                   , pure (SomeNetwork (Elu     :~> rest :: Network ( Elu     ': layers ) ( h ': h ': hs )))+                   , do -- Build a convolution layer with one filter output+                        -- Figure out some kernel sizes which work for this layer+                        -- There must be a better way than this...+                        let output_r = natVal r+                        let output_c = natVal c++                        let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]++                        -- Get some kernels which will fit+                        kernel_r <- choose 1 output_r+                        kernel_c <- choose 1 output_c++                        -- Build up some strides which also fit+                        stride_r <- Gen.element $ ok output_r kernel_r+                        stride_c <- Gen.element $ ok output_c kernel_c++                        -- Determine the input size+                        let input_r = (output_r - 1) * stride_r + kernel_r+                        let input_c = (output_c - 1) * stride_c + kernel_c++                        guard (input_r < 100)+                        guard (input_c < 100)++                        -- Remake types for input+                        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+                          ( Just (SomeNat (_    :: Proxy inRows)),     Just (SomeNat  (_    :: Proxy inCols)),+                            Just (SomeNat (_    :: Proxy outRows)),    Just (SomeNat  (_    :: Proxy outCols)),+                            Just (SomeNat (pkr  :: Proxy kernelRows)), Just (SomeNat  (pkc  :: Proxy kernelCols)),+                            Just (SomeNat (_    :: Proxy strideRows)), Just (SomeNat  (_    :: Proxy strideCols))) ->+                              let p1 = natDict pkr+                                  p2 = natDict pkc+                              in  case ( p1 %* p2+                                        -- Fake it till you make it.+                                        , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))+                                        , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))+                                        , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of+                                    (Dict, Dict, Dict, Dict) -> do+                                        conv <- genConvolution+                                        pure (SomeNetwork (conv :~> rest :: Network ( Convolution 1 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))+                          _ -> Gen.discard -- Can't occur+                   , do -- Build a convolution layer with one filter output+                        -- Figure out some kernel sizes which work for this layer+                        -- There must be a better way than this...+                        let output_r = natVal r+                        let output_c = natVal c++                        let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]++                        -- Get some kernels which will fit+                        kernel_r <- choose 1 output_r+                        kernel_c <- choose 1 output_c+                        channels <- choose 1 10++                        -- Build up some strides which also fit+                        stride_r <- Gen.element $ ok output_r kernel_r+                        stride_c <- Gen.element $ ok output_c kernel_c++                        -- Determine the input size+                        let input_r = (output_r - 1) * stride_r + kernel_r+                        let input_c = (output_c - 1) * stride_c + kernel_c++                        guard (input_r < 100)+                        guard (input_c < 100)++                        -- Remake types for input+                        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+                          ( Just (SomeNat (chan :: Proxy channels)),+                            Just (SomeNat (pinr :: Proxy inRows)),     Just (SomeNat  (_    :: Proxy inCols)),+                            Just (SomeNat (_    :: Proxy outRows)),    Just (SomeNat  (_    :: Proxy outCols)),+                            Just (SomeNat (pkr  :: Proxy kernelRows)), Just (SomeNat  (pkc  :: Proxy kernelCols)),+                            Just (SomeNat (_    :: Proxy strideRows)), Just (SomeNat  (_    :: Proxy strideCols))) ->+                              let p1 = natDict pkr+                                  p2 = natDict pkc+                                  p3 = natDict chan+                              in  case ( p1 %* p2 %* p3+                                        , natDict pinr %* natDict chan+                                        -- Fake it till you make it.+                                        , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))+                                        , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))+                                        , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of+                                    (Dict, Dict, Dict, Dict, Dict) -> do+                                        conv <- genConvolution+                                        pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))+                          _ -> Gen.discard -- Can't occur+                   , do -- Build a Pooling layer+                        let output_r = natVal r+                        let output_c = natVal c++                        let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]++                        -- Get some kernels which will fit+                        kernel_r <- choose 1 output_r+                        kernel_c <- choose 1 output_c++                        -- Build up some strides which also fit+                        stride_r <- Gen.element $ ok output_r kernel_r+                        stride_c <- Gen.element $ ok output_c kernel_c++                        -- Determine the input size+                        let input_r = (output_r - 1) * stride_r + kernel_r+                        let input_c = (output_c - 1) * stride_c + kernel_c++                        guard (input_r < 100)+                        guard (input_c < 100)++                        -- Remake types for input+                        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+                          ( Just (SomeNat (_    :: Proxy inRows)),     Just (SomeNat  (_    :: Proxy inCols)),+                            Just (SomeNat (_    :: Proxy outRows)),    Just (SomeNat  (_    :: Proxy outCols)),+                            Just (SomeNat (pkr  :: Proxy kernelRows)), Just (SomeNat  (pkc  :: Proxy kernelCols)),+                            Just (SomeNat (_    :: Proxy strideRows)), Just (SomeNat  (_    :: Proxy strideCols))) ->+                              let p1 = natDict pkr+                                  p2 = natDict pkc+                              in  case ( p1 %* p2+                                        -- Fake it till you make it.+                                        , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))+                                        , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))+                                        , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of+                                    (Dict, Dict, Dict, Dict) ->+                                        pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))+                          _ -> Gen.discard -- Can't occur+                   ]+                 D3Sing r c d -> withKnownNat d $ withKnownNat r $ withKnownNat c $+                   Gen.choice [+                     pure (SomeNetwork (Tanh    :~> rest :: Network ( Tanh    ': layers ) ( h ': h ': hs )))+                   , pure (SomeNetwork (Logit   :~> rest :: Network ( Logit   ': layers ) ( h ': h ': hs )))+                   , pure (SomeNetwork (Relu    :~> rest :: Network ( Relu    ': layers ) ( h ': h ': hs )))+                   , pure (SomeNetwork (Elu     :~> rest :: Network ( Elu     ': layers ) ( h ': h ': hs )))+                   ]+    ]++-- | Test a partial derivative numerically for a random network and input+--+-- This is the most important test.+prop_auto_diff :: Property+prop_auto_diff = withTests 10000 . property $ do+  SomeNetwork (network :: Network layers shapes) <- forAll genNetwork+  (input  :: S (Head shapes))     <- forAllRender nice genOfShape+  (target :: S (Last shapes))     <- forAllRender nice oneUp+  (tested :: S (Head shapes))     <- forAllRender nice oneUp++  let (!tapes, !output) = runNetwork network input+  let (_, !backgrad)    = runGradient network tapes target+  let inputDiff         = input + tested * 0.00001+  let expected          = maxVal ( backgrad * tested )+  let (_, !outputDiff)  = runNetwork network inputDiff+  let result            = maxVal ( outputDiff * target - output * target ) / 0.00001++  result ~~~ expected++-- Make a shape where all are 0 except for 1 value, which is 1.+oneUp :: forall shape m. ( Monad m, SingI shape ) => Gen.Gen m (S shape)+oneUp =+  case ( sing :: Sing shape ) of+    D1Sing l -> withKnownNat l $+      let x = 0 :: S ( shape )+      in  case x of+              ( S1D x' ) -> do+              let ex = extract x'+              let len = VS.length ex+              ix <- choose 0 (len - 1)+              let nx = runST $ do ex' <- VS.thaw ex+                                  VS.write ex' ix 1.0+                                  VS.freeze ex'+              maybe Gen.discard pure . fromStorable $ nx++    D2Sing r c -> withKnownNat r $ withKnownNat c $+      let x = 0 :: S ( shape )+      in  case x of+              ( S2D x' ) -> do+              let ex = flatten ( extract x' )+              let len = VS.length ex+              ix <- choose 0 (len - 1)+              let nx = runST $ do ex' <- VS.thaw ex+                                  VS.write ex' ix 1+                                  VS.freeze ex'+              maybe Gen.discard pure . fromStorable $ nx++    D3Sing r c d -> withKnownNat r $ withKnownNat c $ withKnownNat d $+      let x = 0 :: S ( shape )+      in  case x of+              ( S3D x' ) -> do+              let ex = flatten ( extract x' )+              let len = VS.length ex+              ix <- choose 0 (len - 1)+              let nx = runST $ do ex' <- VS.thaw ex+                                  VS.write ex' ix 1+                                  VS.freeze ex'+              maybe Gen.discard pure . fromStorable $ nx++maxVal :: S shape -> Double+maxVal ( S1D x ) = norm_Inf x+maxVal ( S2D x ) = norm_Inf x+maxVal ( S3D x ) = norm_Inf x++(~~~) :: (Monad m, HasCallStack) => Double -> Double -> Test m ()+(~~~) x y =+  if abs (x - y) < 1e-5 then+    success+  else+    withFrozenCallStack $+    failWith Nothing $ unlines [+        "━━━ Not Simliar ━━━"+        , show x+        , show y+        ]+infix 4 ~~~+++tests :: IO Bool+tests = $$(checkConcurrent)
+ test/Test/Grenade/Recurrent/Layers/LSTM.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE RankNTypes            #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Grenade.Recurrent.Layers.LSTM where++import           Hedgehog+import qualified Hedgehog.Gen as Gen+import           Hedgehog.Internal.Source+import           Hedgehog.Internal.Show+import           Hedgehog.Internal.Property ( failWith, Diff (..) )++import           Data.Foldable ( toList )+import           Data.Singletons.TypeLits++import           Grenade+import           Grenade.Recurrent++import qualified Numeric.LinearAlgebra as H+import qualified Numeric.LinearAlgebra.Static as S+++import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference+import           Test.Hedgehog.Hmatrix++genLSTM :: forall i o m. (KnownNat i, KnownNat o, Monad m) => Gen.Gen m (LSTM i o)+genLSTM = do+    let w = uniformSample+        u = uniformSample+        v = randomVector++        w0 = S.konst 0+        u0 = S.konst 0+        v0 = S.konst 0++    LSTM <$> (LSTMWeights <$> w <*> u <*> v <*> w <*> u <*> v <*> w <*> u <*> v <*> w <*> v)+         <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)++prop_lstm_reference_forwards =+  property $ do+    input :: S.R 3                       <- forAll randomVector+    cell :: S.R 2                        <- forAll randomVector+    net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM++    let actual          = runRecurrentForwards net (S1D cell) (S1D input)+    case actual of+      (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->+        let cellOut'        = Reference.Vector . H.toList . S.extract $ cellOut+            output'         = Reference.Vector . H.toList . S.extract $ output+            refNet          = Reference.lstmToReference lstmWeights+            refCell         = Reference.Vector . H.toList . S.extract $ cell+            refInput        = Reference.Vector . H.toList . S.extract $ input+            (refCO, refO)   = Reference.runLSTM refNet refCell refInput+        in do toList refCO ~~~ toList cellOut'+              toList refO ~~~ toList output'+++prop_lstm_reference_backwards =+  property $ do+    input :: S.R 3                       <- forAll randomVector+    cell :: S.R 2                        <- forAll randomVector+    net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM+    let actualBacks     = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))+    case actualBacks of+      (actualGradients, _, _ :: S ('D1 3)) ->+        let refNet          = Reference.lstmToReference lstmWeights+            refCell         = Reference.Vector . H.toList . S.extract $ cell+            refInput        = Reference.Vector . H.toList . S.extract $ input+            refGradients    = Reference.runLSTMback refCell refInput refNet+        in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)++prop_lstm_reference_backwards_input =+  property $ do+    input :: S.R 3                       <- forAll randomVector+    cell :: S.R 2                        <- forAll randomVector+    net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM+    let actualBacks     = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))+    case actualBacks of+      (_, _, S1D actualGradients :: S ('D1 3)) ->+        let refNet          = Reference.lstmToReference lstmWeights+            refCell         = Reference.Vector . H.toList . S.extract $ cell+            refInput        = Reference.Vector . H.toList . S.extract $ input+            refGradients    = Reference.runLSTMbackOnInput refCell refNet refInput+        in toList refGradients ~~~ H.toList (S.extract actualGradients)++prop_lstm_reference_backwards_cell =+  property $ do+    input :: S.R 3                       <- forAll randomVector+    cell :: S.R 2                        <- forAll randomVector+    net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM+    let actualBacks     = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))+    case actualBacks of+      (_, S1D actualGradients, _ :: S ('D1 3)) ->+        let refNet          = Reference.lstmToReference lstmWeights+            refCell         = Reference.Vector . H.toList . S.extract $ cell+            refInput        = Reference.Vector . H.toList . S.extract $ input+            refGradients    = Reference.runLSTMbackOnCell refInput refNet refCell+        in toList refGradients ~~~ H.toList (S.extract actualGradients)++(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> Test m ()+(~~~) x y =+  if all (< 1e-8) (zipWith (-) x y) then+    success+  else+    case valueDiff <$> mkValue x <*> mkValue y of+      Nothing ->+        withFrozenCallStack $+          failWith Nothing $ unlines [+              "━━━ Not Simliar ━━━"+            , showPretty x+            , showPretty y+            ]+      Just diff ->+        withFrozenCallStack $+          failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" diff) ""+infix 4 ~~~++tests :: IO Bool+tests = $$(checkConcurrent)
+ test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE DeriveFoldable        #-}+{-# LANGUAGE DeriveTraversable     #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE RankNTypes            #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Grenade.Recurrent.Layers.LSTM.Reference where++import           Data.Reflection+import           Numeric.AD.Mode.Reverse+import           Numeric.AD.Internal.Reverse ( Tape )++import qualified Grenade.Recurrent.Layers.LSTM as LSTM+import qualified Numeric.LinearAlgebra.Static as S+import qualified Numeric.LinearAlgebra as H++--+-- This module contains a set of list only versions of+-- an LSTM layer which can be used with the AD library.+--+-- Using this, we can check to make sure that our fast+-- back propagation implementation is correct.+--++-- | List only matrix deriving functor+data Matrix a = Matrix {+    matrixWeights         :: [[a]]+  } deriving (Functor, Foldable, Traversable, Eq, Show)++-- | List only vector deriving functor+data Vector a = Vector {+    vectorWeights         :: [a]+  } deriving (Functor, Foldable, Traversable, Eq, Show)++-- | List only LSTM weights+data RefLSTM a = RefLSTM+    { refLstmWf :: Matrix a -- Weight Forget     (W_f)+    , refLstmUf :: Matrix a -- Cell State Forget (U_f)+    , refLstmBf :: Vector a -- Bias Forget       (b_f)+    , refLstmWi :: Matrix a -- Weight Input      (W_i)+    , refLstmUi :: Matrix a -- Cell State Input  (U_i)+    , refLstmBi :: Vector a -- Bias Input        (b_i)+    , refLstmWo :: Matrix a -- Weight Output     (W_o)+    , refLstmUo :: Matrix a -- Cell State Output (U_o)+    , refLstmBo :: Vector a -- Bias Output       (b_o)+    , refLstmWc :: Matrix a -- Weight Cell       (W_c)+    , refLstmBc :: Vector a -- Bias Cell         (b_c)+    } deriving (Functor, Foldable, Traversable, Eq, Show)++lstmToReference :: LSTM.LSTMWeights a b -> RefLSTM Double+lstmToReference LSTM.LSTMWeights {..} =+    let refLstmWf = Matrix . H.toLists . S.extract $ lstmWf -- Weight Forget     (W_f)+        refLstmUf = Matrix . H.toLists . S.extract $ lstmUf -- Cell State Forget (U_f)+        refLstmBf = Vector . H.toList  . S.extract $ lstmBf -- Bias Forget       (b_f)+        refLstmWi = Matrix . H.toLists . S.extract $ lstmWi -- Weight Input      (W_i)+        refLstmUi = Matrix . H.toLists . S.extract $ lstmUi -- Cell State Input  (U_i)+        refLstmBi = Vector . H.toList  . S.extract $ lstmBi -- Bias Input        (b_i)+        refLstmWo = Matrix . H.toLists . S.extract $ lstmWo -- Weight Output     (W_o)+        refLstmUo = Matrix . H.toLists . S.extract $ lstmUo -- Cell State Output (U_o)+        refLstmBo = Vector . H.toList  . S.extract $ lstmBo -- Bias Output       (b_o)+        refLstmWc = Matrix . H.toLists . S.extract $ lstmWc -- Weight Cell       (W_c)+        refLstmBc = Vector . H.toList  . S.extract $ lstmBc -- Bias Cell         (b_c)+    in RefLSTM {..}++runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)+runLSTM RefLSTM {..} cell input =+    let -- Forget state vector+        f_t = sigmoid   $ refLstmBf #+ refLstmWf #> input #+ refLstmUf #> cell+        -- Input state vector+        i_t = sigmoid   $ refLstmBi #+ refLstmWi #> input #+ refLstmUi #> cell+        -- Output state vector+        o_t = sigmoid   $ refLstmBo #+ refLstmWo #> input #+ refLstmUo #> cell+        -- Cell input state vector+        c_x = fmap tanh $ refLstmBc #+ refLstmWc #> input+        -- Cell state+        c_t = f_t #* cell #+ i_t #* c_x+        -- Output (it's sometimes recommended to use tanh c_t)+        h_t = o_t #* c_t+    in (c_t, h_t)++runLSTMback :: forall a. Floating a => Vector a -> Vector a -> RefLSTM a -> RefLSTM a+runLSTMback cell input =+  grad f+    where+  f :: forall s. Reifies s Tape => RefLSTM (Reverse s a) -> Reverse s a+  f net =+    let cell'   = fmap auto cell+        input'  = fmap auto input+        (cells, forwarded) = runLSTM net cell' input'+    in  sum forwarded + sum cells++runLSTMbackOnInput :: forall a. Floating a => Vector a -> RefLSTM a -> Vector a -> Vector a+runLSTMbackOnInput cell net =+  grad f+    where+  f :: forall s. Reifies s Tape => Vector (Reverse s a) -> Reverse s a+  f input =+    let cell'   = fmap auto cell+        net'    = fmap auto net+        (cells, forwarded) = runLSTM net' cell' input+    in  sum forwarded + sum cells++runLSTMbackOnCell :: forall a. Floating a => Vector a -> RefLSTM a -> Vector a -> Vector a+runLSTMbackOnCell input net =+  grad f+    where+  f :: forall s. Reifies s Tape => Vector (Reverse s a) -> Reverse s a+  f cell =+    let input'  = fmap auto input+        net'    = fmap auto net+        (cells, forwarded) = runLSTM net' cell input'+    in  sum forwarded + sum cells++-- | Helper to multiply a matrix by a vector+matMult :: Num a => Matrix a -> Vector a -> Vector a+matMult (Matrix m) (Vector v) = Vector result+  where+    lrs = map length m+    l   = length v+    result = if all (== l) lrs+             then map (\r -> sum $ zipWith (*) r v) m+             else error $ "Matrix has rows of length " ++ show lrs +++                          " but vector is of length " ++ show l++(#>) :: Num a => Matrix a -> Vector a -> Vector a+(#>) = matMult+infixr 8 #>++(#+) :: Num a => Vector a -> Vector a -> Vector a+(#+) (Vector as) (Vector bs) = Vector $ zipWith (+) as bs+infixl 6 #+++(#-) :: Num a => Vector a -> Vector a -> Vector a+(#-) (Vector as) (Vector bs) = Vector $ zipWith (-) as bs+infixl 6 #-++(#*) :: Num a => Vector a -> Vector a -> Vector a+(#*) (Vector as) (Vector bs) = Vector $ zipWith (*) as bs+infixl 7 #*++sigmoid :: (Functor f, Floating a) => f a -> f a+sigmoid xs = (\x -> 1 / (1 + exp (-x))) <$> xs
+ test/Test/Hedgehog/Compat.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE RankNTypes            #-}+module Test.Hedgehog.Compat (+    (...)+  , choose+  , blindForAll+  , semiBlindForAll+  , forAllRender+  )where++import           Control.Monad.Trans.Class (MonadTrans(..))++import           Data.Typeable ( typeOf )++import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import           Hedgehog.Internal.Property+import           Hedgehog.Internal.Source+import           Hedgehog.Internal.Show++(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+(...) = (.) . (.)+{-# INLINE (...) #-}++choose :: ( Monad m, Integral a ) => a -> a -> Gen.Gen m a+choose = Gen.integral ... Range.constant++blindForAll :: Monad m => Gen.Gen m a -> Test m a+blindForAll = Test . lift . lift++semiBlindForAll :: (Monad m, Show a, HasCallStack) => Gen.Gen m a -> Test m a+semiBlindForAll gen = do+  x <- Test . lift $ lift gen+  writeLog $ Input (getCaller callStack) (typeOf ()) (showPretty x)+  return x++forAllRender :: (Monad m, HasCallStack) => ( a -> String ) -> Gen.Gen m a -> Test m a+forAllRender render gen = do+  x <- Test . lift $ lift gen+  writeLog $ Input (getCaller callStack) (typeOf ()) (render x)+  return x
+ test/Test/Hedgehog/Hmatrix.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE GADTs                 #-}++module Test.Hedgehog.Hmatrix where++import           Grenade+import           Data.Singletons+import           Data.Singletons.TypeLits++import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import qualified Numeric.LinearAlgebra.Static as HStatic++randomVector :: forall m n. ( Monad m, KnownNat n ) =>  Gen.Gen m (HStatic.R n)+randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded++uniformSample :: forall mm m n. ( Monad mm, KnownNat m, KnownNat n ) => Gen.Gen mm (HStatic.L m n)+uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded++-- | Generate random data of the desired shape+genOfShape :: forall m x. ( Monad m, SingI x ) =>  Gen.Gen m (S x)+genOfShape =+  case (sing :: Sing x) of+    D1Sing l ->+      withKnownNat l $+        S1D <$> randomVector+    D2Sing r c ->+      withKnownNat r $ withKnownNat c $+        S2D <$> uniformSample+    D3Sing r c d ->+      withKnownNat r $ withKnownNat c $ withKnownNat d $+        S3D <$> uniformSample++nice :: S shape -> String+nice (S1D x) = show . HStatic.extract $ x+nice (S2D x) = show . HStatic.extract $ x+nice (S3D x) = show . HStatic.extract $ x
+ test/Test/Hedgehog/TypeLits.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE GADTs                 #-}+module Test.Hedgehog.TypeLits where++import           Data.Constraint+#if __GLASGOW_HASKELL__ < 800+import           Data.Proxy+#endif+import           Data.Singletons++import qualified Hedgehog.Gen as Gen++import           Grenade++import           GHC.TypeLits+import           GHC.TypeLits.Witnesses+import           Test.Hedgehog.Compat++genNat :: Monad m => Gen.Gen m SomeNat+genNat = do+  Just n <- someNatVal <$> choose 1 10+  return n++#if __GLASGOW_HASKELL__ < 800+type Shape' = ('KProxy :: KProxy Shape)+#else+type Shape' = Shape+#endif++genShape :: Monad m => Gen.Gen m (SomeSing Shape')+genShape+  = Gen.choice [+      genD1+    , genD2+    , genD3+    ]++genD1 :: Monad m => Gen.Gen m (SomeSing Shape')+genD1 = do+  n <- genNat+  return $ case n of+    SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))++genD2 :: Monad m => Gen.Gen m (SomeSing Shape')+genD2 = do+  n <- genNat+  m <- genNat+  return $ case (n, m) of+    (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))++genD3 :: Monad m => Gen.Gen m (SomeSing Shape')+genD3 = do+  n <- genNat+  m <- genNat+  o <- genNat+  return $ case (n, m, o) of+    (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->+        case natDict px %* natDict pz of+          Dict -> SomeSing (sing :: Sing ('D3 x y z))
+ test/test.hs view
@@ -0,0 +1,47 @@+import           Control.Monad++import qualified Test.Grenade.Network++import qualified Test.Grenade.Layers.Pooling+import qualified Test.Grenade.Layers.Convolution+import qualified Test.Grenade.Layers.FullyConnected+import qualified Test.Grenade.Layers.Nonlinear+import qualified Test.Grenade.Layers.PadCrop++import qualified Test.Grenade.Layers.Internal.Convolution+import qualified Test.Grenade.Layers.Internal.Pooling++import qualified Test.Grenade.Recurrent.Layers.LSTM++import           System.Exit+import           System.IO++main :: IO ()+main =+  disorderMain [+      Test.Grenade.Network.tests++    , Test.Grenade.Layers.Pooling.tests+    , Test.Grenade.Layers.Convolution.tests+    , Test.Grenade.Layers.FullyConnected.tests+    , Test.Grenade.Layers.Nonlinear.tests+    , Test.Grenade.Layers.PadCrop.tests++    , Test.Grenade.Layers.Internal.Convolution.tests+    , Test.Grenade.Layers.Internal.Pooling.tests++    , Test.Grenade.Recurrent.Layers.LSTM.tests++    ]++disorderMain :: [IO Bool] -> IO ()+disorderMain tests = do+  lineBuffer+  rs <- sequence tests+  unless (and rs) exitFailure+++lineBuffer :: IO ()+lineBuffer = do+  hSetBuffering stdout LineBuffering+  hSetBuffering stderr LineBuffering