10a6003...master · grenade

.gitignore+3−1

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

1+cabal.project.local

12.cabal-sandbox/

23cabal.sandbox.config

34dist/

4−

5+dist-newstyle/

6+.stack-work/

.gitmodulesdeleted−15

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

1−[submodule "lib/disorder"]

2− path = lib/disorder

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

4−[submodule "lib/x"]

5− path = lib/x

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

7−[submodule "lib/p"]

8− path = lib/p

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

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

11− path = lib/disorder.hs

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

13−[submodule "lib/hmatrix"]

14− path = lib/hmatrix

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

.travis.yml+12−14

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

22

33# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.

44env:

5− - CABALVER=1.22 GHCVER=7.10.3

6− - CABALVER=1.24 GHCVER=8.0.1

5+ - GHCVER=8.0.2

6+ - GHCVER=8.2.2

7+ - GHCVER=8.4.4

8+ - GHCVER=8.6.5

9+ - GHCVER=8.8.3

10+ - GHCVER=8.10.1

711

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

913before_install:

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

1115 - travis_retry sudo apt-get update

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

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

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

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

1418

1519install:

16− - cabal --version

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

18− - travis_retry cabal update

19− - git submodule update --init

20− - cabal sandbox init

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

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

23−

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

21+ - travis_retry cabal-3.2 update

2522

2623notifications:

2724 email: false

2825

2926# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.

3027script:

31− - cabal build

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

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

29+ - cabal-3.2 build all

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

3331

README.md+11−3

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

22=======

33

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

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

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

7+

58

69```

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

@@ -21,7 +24,7 @@ specified and initialised with random weights in a few lines of code with

2124type MNIST

2225 = Network

2326 '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Relu

24− , Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, FlattenLayer, Relu

27+ , Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Reshape, Relu

2528 , FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]

2629 '[ 'D2 28 28, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10

2730 , 'D3 8 8 16, 'D3 4 4 16, 'D1 256, 'D1 256

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

8689```

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

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

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

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

9093have no learnable parameters.

9194

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

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

156159./mafia test

157160```

158161

159−Grenade builds with ghc 7.10 and 8.0.

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

160163

161164Thanks

162165------

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

182185Contributing

183186------------

184187Contributions are welcome.

188+

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

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

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

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

bench/bench-lstm.hs+4−45

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

55

66import Grenade

77import Grenade.Recurrent

8−import Grenade.Layers.Internal.Update

9−

10−import qualified Numeric.LinearAlgebra.Static as H

118

129main :: IO ()

1310main = do

14− layer60 :: LSTM 40 60 <- createRandom

15− layer512 :: LSTM 40 512 <- createRandom

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

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

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

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

20−

21− let upIn60 :: H.R 3600 = H.randomVector 1 H.Uniform * 2 - 1

22− let upIn512 :: H.R 262144 = H.randomVector 1 H.Uniform * 2 - 1

12+ lstm :: RecNet <- randomRecurrent

2313

2414 defaultMain [

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

26− , bench "forwards-512" $ nf (nfT3 . uncurry (testRun512 layer512)) (rec512, input40)

27− , bench "backwards-60" $ nf (nfT3 . uncurry4 (testRun60' layer60)) (rec60, input40, rec60, rec60)

28− , bench "backwards-512" $ nf (nfT3 . uncurry4 (testRun512' layer512)) (rec512, input40, rec512, rec512)

29− ]

30− , bgroup "update" [ bench "matrix-60x60" $ nf (uncurry3 (decendVector 1 1 1)) (upIn60, upIn60, upIn60)

31− , bench "matrix-512x512" $ nf (uncurry3 (decendVector 1 1 1)) (upIn512, upIn512, upIn512)

32− ]

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

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

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

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

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

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

3618 ]

3719 ]

3820

39−testRun60 :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> ((S ('D1 60), S ('D1 40)), S ('D1 60), S ('D1 60))

40−testRun60 = runRecurrentForwards

41−

42−testRun60' :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> S ('D1 60) -> S ('D1 60) -> (Gradient (LSTM 40 60), S ('D1 60), S ('D1 40))

43−testRun60' = curry . runRecurrentBackwards

44−

45−testRun512 :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> ((S ('D1 512), S ('D1 40)), S ('D1 512), S ('D1 512))

46−testRun512 = runRecurrentForwards

47−

48−testRun512' :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> S ('D1 512) -> S ('D1 512) -> (Gradient (LSTM 40 512), S ('D1 512), S ('D1 40))

49−testRun512' = curry . runRecurrentBackwards

50−

51−uncurry4 :: (t -> t1 -> t2 -> t3 -> t4) -> (t, t1, t2, t3) -> t4

52−uncurry4 f (a,b,c,d) = f a b c d

53−

54−uncurry3 :: (t -> t1 -> t2 -> t3) -> (t, t1, t2) -> t3

55−uncurry3 f (a,b,c) = f a b c

56−

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

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

5923

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

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

62−

6324

6425type R = Recurrent

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

6627 '[ 'D1 40, 'D1 512, 'D1 40 ]

6728

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

69−

7029lp :: LearningParameters

7130lp = LearningParameters 0.1 0 0

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

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

1−#include "gradient_decent.h"

1+#include "gradient_descent.h"

22

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

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

44 const double* weights,

55 const double* gradient,

66 const double* last,

77 double* outputWeights, double* outputMomentum) {

88

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

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

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

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

1212 }

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

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

11#include <stdio.h>

22#include <stdint.h>

33

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

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

55 const double* weights,

66 const double* gradient,

77 const double* last,

examples/grenade-examples.cabal+10−9

@@ -26,7 +26,7 @@ executable feedforward

2626 , bytestring

2727 , cereal

2828 , either

29− , optparse-applicative == 0.13.*

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

3030 , text == 1.2.*

3131 , mtl >= 2.2.1 && < 2.3

3232 , hmatrix

@@ -42,10 +42,10 @@ executable mnist

4242 , grenade

4343 , attoparsec

4444 , either

45− , optparse-applicative == 0.13.*

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

4646 , text == 1.2.*

4747 , mtl >= 2.2.1 && < 2.3

48− , hmatrix >= 0.18 && < 0.19

48+ , hmatrix >= 0.18 && < 0.21

4949 , transformers

5050 , semigroups

5151 , singletons

@@ -61,10 +61,10 @@ executable gan-mnist

6161 , bytestring

6262 , cereal

6363 , either

64− , optparse-applicative == 0.13.*

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

6565 , text == 1.2.*

6666 , mtl >= 2.2.1 && < 2.3

67− , hmatrix >= 0.18 && < 0.19

67+ , hmatrix >= 0.18 && < 0.21

6868 , transformers

6969 , semigroups

7070 , singletons

@@ -78,10 +78,10 @@ executable recurrent

7878 , grenade

7979 , attoparsec

8080 , either

81− , optparse-applicative == 0.13.*

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

8282 , text == 1.2.*

8383 , mtl >= 2.2.1 && < 2.3

84− , hmatrix >= 0.18 && < 0.19

84+ , hmatrix >= 0.18 && < 0.21

8585 , transformers

8686 , semigroups

8787 , singletons

@@ -96,13 +96,14 @@ executable shakespeare

9696 , bytestring

9797 , cereal

9898 , either

99− , optparse-applicative == 0.13.*

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

100100 , text == 1.2.*

101101 , mtl >= 2.2.1 && < 2.3

102− , hmatrix >= 0.18 && < 0.19

102+ , hmatrix >= 0.18 && < 0.21

103103 , transformers

104104 , semigroups

105105 , singletons

106+ , singletons-base

106107 , vector

107108 , MonadRandom

108109 , containers

examples/mafianew file+62

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

1+#!/bin/sh -eu

2+

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

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

5+

6+latest_version () {

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

8+}

9+

10+build_version() {

11+ MAFIA_VERSION="$1"

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

13+ MAFIA_FILE=mafia-$MAFIA_VERSION

14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE

15+ mkdir -p $MAFIA_VERSIONS

16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

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

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

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

20+ exit 1

21+ }

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

23+ got=$?

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

25+ exit "$got"

26+ }

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

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

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

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

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

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

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

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

35+ exit 0

36+ }

37+}

38+

39+enable_version() {

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

41+ MAFIA_VERSION="$(latest_version)"

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

43+ else

44+ MAFIA_VERSION="$1"

45+ fi

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

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

48+}

49+

50+exec_mafia () {

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

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

53+}

54+

55+#

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

57+#

58+

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

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

61+*) exec_mafia "$@"

62+esac

examples/main/feedforward.hs+3−1

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

11{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE ScopedTypeVariables #-}

45{-# LANGUAGE TypeOperators #-}

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

1011

1112import qualified Data.ByteString as B

1213import Data.Serialize

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

1315import Data.Semigroup ( (<>) )

14−

16+#endif

1517import GHC.TypeLits

1618

1719import qualified Numeric.LinearAlgebra.Static as SA

examples/main/gan-mnist.hs+4−1

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

11{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE GADTs #-}

45{-# LANGUAGE ScopedTypeVariables #-}

@@ -11,7 +12,7 @@

1112-- of numbers similar to those in MNIST.

1213--

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

14−-- minutes hour it was producing examples like this:

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

1516--

1617-- --.

1718-- .=-.--..#=###

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

4344import qualified Data.Attoparsec.Text as A

4445import qualified Data.ByteString as B

4546import Data.List ( foldl' )

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

4648import Data.Semigroup ( (<>) )

49+#endif

4750import Data.Serialize

4851import qualified Data.Text as T

4952import qualified Data.Text.IO as T

examples/main/mnist.hs+4

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

11{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE ScopedTypeVariables #-}

45{-# LANGUAGE TypeOperators #-}

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

1314

1415import qualified Data.Attoparsec.Text as A

1516import Data.List ( foldl' )

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

1618import Data.Semigroup ( (<>) )

19+#endif

20+

1721import qualified Data.Text as T

1822import qualified Data.Text.IO as T

1923import qualified Data.Vector.Storable as V

examples/main/recurrent.hs+10−10

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

99import Control.Monad ( foldM )

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

1111

12−#if __GLASGOW_HASKELL__ < 800

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

1313import Data.List ( unfoldr )

1414#else

1515import Data.List ( cycle, unfoldr )

16−#endif

1716import Data.Semigroup ( (<>) )

17+#endif

1818

1919import qualified Numeric.LinearAlgebra.Static as SA

2020

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

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

3232type R = Recurrent

3333

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

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

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

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

3636

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

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

3838

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

39+randomNet :: MonadRandom m => m RecNet

4040randomNet = randomRecurrent

4141

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

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

6969 unfoldr go (s, i)

7070 where

7171 go (x, y) =

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

73− o' = heat o

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

73+ o' = heat o

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

7575

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

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

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

8383 putStrLn "Training network..."

8484

85− (net0, i0) <- randomNet

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

85+ net0 <- randomNet

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

8787

8888 let results = generateRecurrent trained bestInput (c 1)

8989

examples/main/shakespeare.hs+26−23

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE CPP #-}

33{-# LANGUAGE DataKinds #-}

44{-# LANGUAGE ScopedTypeVariables #-}

55{-# LANGUAGE TypeOperators #-}

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

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

1414import Data.List ( foldl' )

1515import Data.Maybe ( fromMaybe )

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

16+

1717

1818import qualified Data.Vector as V

1919import Data.Vector ( Vector )

2020

2121import qualified Data.Map as M

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

2322

2423import qualified Data.ByteString as B

2524import Data.Serialize

2625

27−import Data.Singletons.Prelude

2826import GHC.TypeLits

2927

3028import Numeric.LinearAlgebra.Static ( konst )

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

3634import Grenade.Utils.OneHot

3735

3836import System.IO.Unsafe ( unsafeInterleaveIO )

37+import Data.Proxy

38+import Prelude.Singletons

3939

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

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

4242-- about an hour.

4343--

44+-- Grab the input from

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

46+--

4447-- This is a first class recurrent net.

4548--

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

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

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

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

6366

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

67+randomNet :: MonadRandom m => m Shakespeare

6568randomNet = randomRecurrent

6669

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

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

6972loadShakespeare path = do

7073 contents <- lift $ readFile path

7174 let annotated = annotateCapitals contents

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

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

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

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

7578

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

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

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

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

7982 in case reverse e of

8083 (o : l : xs) ->

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

82− in trainRecurrent rate net recIns examples

85+ in trainRecurrent lrate net recIns examples

8386 _ -> error "Not enough input"

8487 where

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

8689

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

88−runShakespeare ShakespeareOpts {..} = do

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

91+runShakespeare opts = do

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

9093 (net0, i0) <- lift $

91− case loadPath of

94+ case loadPath opts of

9295 Just loadFile -> netLoad loadFile

93− Nothing -> randomNet

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

9497

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

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

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

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

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

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

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

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

100103 putStrLn (unAnnotateCapitals results)

101104 return (trained, bestInput)

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

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

103106

104− case savePath of

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

107+ case savePath opts of

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

106109 Nothing -> return ()

107110

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

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

113116 -> Vector a

114117 -> S ('D1 n)

115118 -> IO [a]

116−generateParagraph n s temperature hotmap hotdict =

119+generateParagraph n s temp hotmap hotdict =

117120 go s

118121 where

119122 go x y =

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

121− un <- sample temperature hotdict o

122− Just re <- return $ makeHot hotmap un

123− rest <- unsafeInterleaveIO $ go ns re

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

124+ un <- sample temp hotdict o

125+ Just re <- return $ makeHot hotmap un

126+ rest <- unsafeInterleaveIO $ go ns re

124127 return (un : rest)

125128

126129data ShakespeareOpts = ShakespeareOpts {

framework/mafianew file+62

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

1+#!/bin/sh -eu

2+

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

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

5+

6+latest_version () {

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

8+}

9+

10+build_version() {

11+ MAFIA_VERSION="$1"

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

13+ MAFIA_FILE=mafia-$MAFIA_VERSION

14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE

15+ mkdir -p $MAFIA_VERSIONS

16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

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

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

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

20+ exit 1

21+ }

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

23+ got=$?

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

25+ exit "$got"

26+ }

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

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

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

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

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

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

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

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

35+ exit 0

36+ }

37+}

38+

39+enable_version() {

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

41+ MAFIA_VERSION="$(latest_version)"

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

43+ else

44+ MAFIA_VERSION="$1"

45+ fi

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

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

48+}

49+

50+exec_mafia () {

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

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

53+}

54+

55+#

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

57+#

58+

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

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

61+*) exec_mafia "$@"

62+esac

grenade.cabal+77−29

@@ -1,21 +1,33 @@

11name: grenade

2−version: 0.0.1

2+version: 0.1.0

33license: BSD2

44license-file: LICENSE

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

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

8−synopsis: grenade

9−category: System

10−cabal-version: >= 1.8

8+synopsis: Practical Deep Learning in Haskell

9+category: AI, Machine Learning

10+cabal-version: >= 1.10

1111build-type: Simple

12−description: grenade.

12+description:

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

14+ recurrent neural network library for precise specifications and

15+ complex deep neural networks in Haskell.

16+ .

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

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

19+ networks with reverse automatic differentiation to calculate their

20+ gradients; and applying gradient descent for learning.

21+ .

22+ Documentation and examples are available on github

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

1324

1425extra-source-files:

26+ README.md

1527 cbits/im2col.h

1628 cbits/im2col.c

17− cbits/gradient_decent.h

18− cbits/gradient_decent.c

29+ cbits/gradient_descent.h

30+ cbits/gradient_descent.c

1931 cbits/pad.h

2032 cbits/pad.c

2133

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

2638library

2739 build-depends:

2840 base >= 4.8 && < 5

29− , bytestring == 0.10.*

30− , containers >= 0.5 && < 0.6

41+ , bytestring >= 0.10.0

42+ , containers >= 0.5 && < 0.7

3143 , cereal >= 0.5 && < 0.6

3244 , deepseq >= 1.4 && < 1.5

33− , exceptions == 0.8.*

34− , hmatrix == 0.18.*

45+ , hmatrix >= 0.18 && < 0.21

3546 , MonadRandom >= 0.4 && < 0.6

36− , mtl >= 2.2.1 && < 2.3

37− , primitive >= 0.6 && < 0.7

38− , text == 1.2.*

39− , singletons >= 2.1 && < 2.3

47+ , primitive >= 0.6 && < 0.8

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

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

50+ , singletons

51+ , singletons-base

4052 , vector >= 0.11 && < 0.13

4153

4254 ghc-options:

@@ -44,9 +56,14 @@ library

4456 hs-source-dirs:

4557 src

4658

59+ default-language: Haskell2010

60+

4761 if impl(ghc < 8.0)

4862 ghc-options: -fno-warn-incomplete-patterns

63+ cpp-options: -DType=*

4964

65+ if impl(ghc >= 8.6)

66+ default-extensions: NoStarIsType

5067

5168 exposed-modules:

5269 Grenade

@@ -72,6 +89,7 @@ library

7289 Grenade.Layers.Pooling

7390 Grenade.Layers.Relu

7491 Grenade.Layers.Reshape

92+ Grenade.Layers.Sinusoid

7593 Grenade.Layers.Softmax

7694 Grenade.Layers.Tanh

7795 Grenade.Layers.Trivial

@@ -90,15 +108,16 @@ library

90108

91109 Grenade.Recurrent.Layers

92110 Grenade.Recurrent.Layers.BasicRecurrent

111+ Grenade.Recurrent.Layers.ConcatRecurrent

93112 Grenade.Recurrent.Layers.LSTM

94113

95114 Grenade.Utils.OneHot

96115

97116 includes: cbits/im2col.h

98− cbits/gradient_decent.h

117+ cbits/gradient_descent.h

99118 cbits/pad.h

100119 c-sources: cbits/im2col.c

101− cbits/gradient_decent.c

120+ cbits/gradient_descent.c

102121 cbits/pad.c

103122

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

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

113132 hs-source-dirs:

114133 test

115134

135+ default-language: Haskell2010

136+

137+ other-modules: Test.Hedgehog.Compat

138+ Test.Hedgehog.Hmatrix

139+ Test.Hedgehog.TypeLits

140+

141+ Test.Grenade.Network

142+ Test.Grenade.Layers.Convolution

143+ Test.Grenade.Layers.FullyConnected

144+ Test.Grenade.Layers.Nonlinear

145+ Test.Grenade.Layers.PadCrop

146+ Test.Grenade.Layers.Pooling

147+ Test.Grenade.Layers.Internal.Convolution

148+ Test.Grenade.Layers.Internal.Pooling

149+ Test.Grenade.Layers.Internal.Reference

150+

151+ Test.Grenade.Recurrent.Layers.LSTM

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

153+

154+ if impl(ghc < 8.0)

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

156+ cpp-options: -DType=*

157+

158+ if impl(ghc >= 8.6)

159+ default-extensions: NoStarIsType

160+

116161 build-depends:

117− base >= 4.8 && < 5

162+ base

118163 , grenade

119− , ambiata-disorder-core

120− , ambiata-disorder-jack

164+ , hedgehog >= 1.0 && < 1.1

121165 , hmatrix

122166 , mtl

123167 , singletons

124168 , text == 1.2.*

125− , typelits-witnesses

169+ , typelits-witnesses < 0.4

170+ , transformers

126171 , constraints

127− , QuickCheck >= 2.7 && < 2.9

128− , quickcheck-instances == 0.3.*

129172 , MonadRandom

130173 , random

131174 , ad

132175 , reflection

176+ , vector

133177

134178

135179benchmark bench

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

142186 hs-source-dirs:

143187 bench

144188

189+ default-language: Haskell2010

190+

145191 build-depends:

146− base >= 3 && < 5

147− , bytestring == 0.10.*

148− , criterion == 1.1.*

192+ base

193+ , bytestring

194+ , criterion >= 1.1 && < 1.6

149195 , grenade

150196 , hmatrix

151197

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

159205 hs-source-dirs:

160206 bench

161207

208+ default-language: Haskell2010

209+

162210 build-depends:

163− base >= 3 && < 5

164− , bytestring == 0.10.*

165− , criterion == 1.1.*

211+ base

212+ , bytestring

213+ , criterion

166214 , grenade

167215 , hmatrix

lib/disorder.hsdeleted−1

Submodule changed.

lib/pdeleted−1

Submodule changed.

mafiamode 100755 → 120000+1−123

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

1−#!/bin/sh -eu

2−

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

4−

5−fetch_latest () {

6− if [ -z ${MAFIA_TEST_MODE+x} ]; then

7− TZ=$(date +"%T")

8− curl --silent "https://raw.githubusercontent.com/ambiata/mafia/master/script/mafia?$TZ"

9− else

10− cat ../script/mafia

11− fi

12−}

13−

14−latest_version () {

15− git ls-remote https://github.com/ambiata/mafia | grep refs/heads/master | cut -f 1

16−}

17−

18−local_version () {

19− awk '/^# Version: / { print $3; exit 0; }' $0

20−}

21−

22−run_upgrade () {

23− MAFIA_TEMP=$(mktemp 2>/dev/null || mktemp -t 'upgrade_mafia')

24−

25− clean_up () {

26− rm -f "$MAFIA_TEMP"

27− }

28−

29− trap clean_up EXIT

30−

31− MAFIA_CUR="$0"

32−

33− if [ -L "$MAFIA_CUR" ]; then

34− echo 'Refusing to overwrite a symlink; run `upgrade` from the canonical path.' >&2

35− exit 1

36− fi

37−

38− echo "Checking for a new version of mafia ..."

39− fetch_latest > $MAFIA_TEMP

40−

41− LATEST_VERSION=$(latest_version)

42− echo "# Version: $LATEST_VERSION" >> $MAFIA_TEMP

43−

44− if ! cmp $MAFIA_CUR $MAFIA_TEMP >/dev/null 2>&1; then

45− mv $MAFIA_TEMP $MAFIA_CUR

46− chmod +x $MAFIA_CUR

47− echo "New version found and upgraded. You can now commit it to your git repo."

48− else

49− echo "You have latest mafia."

50− fi

51−}

52−

53−exec_mafia () {

54− MAFIA_VERSION=$(local_version)

55−

56− if [ "x$MAFIA_VERSION" = "x" ]; then

57− # If we can't find the mafia version, then we need to upgrade the script.

58− run_upgrade

59− else

60− MAFIA_BIN=$MAFIA_HOME/bin

61− MAFIA_FILE=mafia-$MAFIA_VERSION

62− MAFIA_PATH=$MAFIA_BIN/$MAFIA_FILE

63−

64− [ -f "$MAFIA_PATH" ] || {

65− # Create a temporary directory which will be deleted when the script

66− # terminates. Unfortunately `mktemp` doesn't behave the same on

67− # Linux and OS/X so we need to try two different approaches.

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

69−

70− # Create a temporary file in MAFIA_BIN so we can do an atomic copy/move dance.

71− mkdir -p $MAFIA_BIN

72−

73− clean_up () {

74− rm -rf "$MAFIA_TEMP"

75− }

76−

77− trap clean_up EXIT

78−

79− echo "Building $MAFIA_FILE in $MAFIA_TEMP"

80−

81− ( cd "$MAFIA_TEMP"

82−

83− git clone https://github.com/ambiata/mafia

84− cd mafia

85−

86− git reset --hard $MAFIA_VERSION

87−

88− bin/bootstrap ) || exit $?

89−

90− MAFIA_PATH_TEMP=$(mktemp --tmpdir=$MAFIA_BIN $MAFIA_FILE-XXXXXX 2>/dev/null || TMPDIR=$MAFIA_BIN mktemp -t $MAFIA_FILE)

91−

92− clean_up_temp () {

93− clean_up

94− rm -f "$MAFIA_PATH_TEMP"

95− }

96− trap clean_up_temp EXIT

97−

98− cp "$MAFIA_TEMP/mafia/.cabal-sandbox/bin/mafia" "$MAFIA_PATH_TEMP"

99− chmod 755 "$MAFIA_PATH_TEMP"

100− mv "$MAFIA_PATH_TEMP" "$MAFIA_PATH"

101−

102− clean_up_temp

103− }

104−

105− exec $MAFIA_PATH "$@"

106− fi

107−}

108−

109−#

110−# The actual start of the script.....

111−#

112−

113−if [ $# -gt 0 ]; then

114− MODE="$1"

115−else

116− MODE=""

117−fi

118−

119−case "$MODE" in

120−upgrade) shift; run_upgrade "$@" ;;

121−*) exec_mafia "$@"

122−esac

123−# Version: 360716306a06db842ec022a7b9f161d2208483f0

@@ -0,0 +1 @@

1+framework/mafia

src/Grenade.hs+2−1

@@ -29,6 +29,7 @@ It provides an expressive type level API for the construction

2929of complex neural network architectures. Backing this API is and

3030implementation written using BLAS and LAPACK, mostly provided by

3131the hmatrix library.

32+

3233-}

3334

3435{- $example

@@ -45,7 +46,7 @@ is a simple example which runs a logistic regression.

4546> randomMyNet = randomNetwork

4647

4748The function `randomMyNet` witnesses the `CreatableNetwork`

48−constraint of the neural network, that is it ensures the network

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

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

5051-}

5152

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE TypeOperators #-}

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

78{-# LANGUAGE RankNTypes #-}

89{-# LANGUAGE FlexibleInstances #-}

910{-|

10−Module : Grenade.Core.Network

11−Description : Core definition a simple neural etwork

11+Module : Grenade.Core.Layer

12+Description : Defines the Layer Classes

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

1314License : BSD2

1415Stability : experimental

1516

1617This module defines what a Layer is in a Grenade

1718neural network.

19+

20+There are two classes of interest: `UpdateLayer` and `Layer`.

21+

22+`UpdateLayer` is required for all types which are used as a layer

23+in a network. Having no shape information, this class is agnostic

24+to the input and output data of the layer.

25+

26+An instance of `Layer` on the other hand is required for usage in

27+a neural network, but also specifies the shapes of data that the

28+network can transform. Multiple instance of `Layer` are permitted

29+for a single type, to transform different shapes. The `Reshape` layer

30+for example can act as a flattening layer, and its inverse, projecting

31+a 1D shape up to 2 or 3 dimensions.

32+

33+Instances of `Layer` should be as strict as possible, and not emit

34+runtime errors.

1835-}

1936module Grenade.Core.Layer (

2037 Layer (..)

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

2542

2643import Data.List ( foldl' )

2744

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

46+import Data.Kind (Type)

47+#endif

48+

2849import Grenade.Core.Shape

2950import Grenade.Core.LearningParameters

3051

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

3455class UpdateLayer x where

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

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

37− type Gradient x :: *

58+ type Gradient x :: Type

3859

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

4061 runUpdate :: LearningParameters -> x -> Gradient x -> x

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

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

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

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

59− type Tape x i o :: *

80+ type Tape x i o :: Type

6081

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

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

src/Grenade/Core/LearningParameters.hs+8−1

@@ -1,6 +1,13 @@

1+{-|

2+Module : Grenade.Core.LearningParameters

3+Description : Stochastic gradient descent learning parameters

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

5+License : BSD2

6+Stability : experimental

7+-}

18module Grenade.Core.LearningParameters (

29 -- | This module contains learning algorithm specific

3− -- code. Currently, this module should be consifered

10+ -- code. Currently, this module should be considered

411 -- unstable, due to issue #26.

512

613 LearningParameters (..)

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE BangPatterns #-}

34{-# LANGUAGE GADTs #-}

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

910{-# LANGUAGE FlexibleInstances #-}

1011{-|

1112Module : Grenade.Core.Network

12−Description : Core definition a simple neural etwork

13+Description : Core definition of a Neural Network

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

1415License : BSD2

1516Stability : experimental

@@ -33,12 +34,16 @@ module Grenade.Core.Network (

3334import Control.Monad.Random ( MonadRandom )

3435

3536import Data.Singletons

36−import Data.Singletons.Prelude

3737import Data.Serialize

3838

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

40+import Data.Kind (Type)

41+#endif

42+

3943import Grenade.Core.Layer

4044import Grenade.Core.LearningParameters

4145import Grenade.Core.Shape

46+import Prelude.Singletons

4247

4348-- | Type of a network.

4449--

@@ -48,7 +53,7 @@ import Grenade.Core.Shape

4853--

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

5055-- transform the data shapes of the network.

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

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

5257 NNil :: SingI i

5358 => Network '[] '[i]

5459

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

6671-- | Gradient of a network.

6772--

6873-- Parameterised on the layers of the network.

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

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

7075 GNil :: Gradients '[]

7176

7277 (:/>) :: UpdateLayer x

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

7782-- | Wegnert Tape of a network.

7883--

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

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

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

8186 TNil :: SingI i

8287 => Tapes '[] '[i]

8388

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

9196--

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

9398-- propagation.

94−--

9599runNetwork :: forall layers shapes.

96100 Network layers shapes

97101 -> S (Head shapes)

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

119123--

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

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

122−--

123126runGradient :: forall layers shapes.

124127 Network layers shapes

125128 -> Tapes layers shapes

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

141144 = (GNil, o)

142145

143146

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

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

145148applyUpdate :: LearningParameters

146149 -> Network layers shapes

147150 -> Gradients layers

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

154157

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

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

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

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

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

159162 --

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

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

179182

180183-- | Ultimate composition.

181184--

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

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

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

184187 type Gradient (Network sublayers subshapes) = Gradients sublayers

185188 runUpdate = applyUpdate

186189 createRandom = randomNetwork

187190

191+-- | Ultimate composition.

192+--

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

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

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

190196 runForwards = runNetwork

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

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

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE FlexibleContexts #-}

33{-|

4−Module : Grenade.Core.Shape

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

4+Module : Grenade.Core.Runner

5+Description : Functions to perform training and backpropagation

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

77License : BSD2

88Stability : experimental

9−

10−This module defines simple back propagation and training functions

11−for a network.

129-}

1310module Grenade.Core.Runner (

1411 train

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

1613 , runNet

1714 ) where

1815

19−import Data.Singletons.Prelude

2016

2117import Grenade.Core.LearningParameters

2218import Grenade.Core.Network

2319import Grenade.Core.Shape

20+import Data.Singletons

21+import Prelude.Singletons

2422

2523-- | Perform reverse automatic differentiation on the network

2624-- for the current input and expected output.

src/Grenade/Core/Shape.hs+59−24

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE KindSignatures #-}

@@ -7,36 +8,33 @@

78{-# LANGUAGE FlexibleContexts #-}

89{-# LANGUAGE ScopedTypeVariables #-}

910{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE UndecidableInstances #-}

1012{-|

1113Module : Grenade.Core.Shape

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

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

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

1416License : BSD2

1517Stability : experimental

1618

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

18−are understood by Grenade.

19+

1920-}

2021module Grenade.Core.Shape (

21− Shape (..)

22− , S (..)

23− , Sing (..)

24−

22+ S (..)

23+ , Shape (..)

24+ , SShape (..)

2525 , randomOfShape

2626 , fromStorable

2727 ) where

2828

2929import Control.DeepSeq (NFData (..))

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

31−

31+import Data.Kind (Type)

3232import Data.Proxy

33+import Data.Serialize

3334import Data.Singletons

34−import Data.Singletons.TypeLits

3535import Data.Vector.Storable ( Vector )

3636import qualified Data.Vector.Storable as V

37−

3837import GHC.TypeLits

39−

4038import qualified Numeric.LinearAlgebra.Static as H

4139import Numeric.LinearAlgebra.Static

4240import qualified Numeric.LinearAlgebra as NLA

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

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

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

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

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

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

84+type instance Sing = SShape

85+

86+data SShape :: Shape -> Type where

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

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

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

90+#else

8491data instance Sing (n :: Shape) where

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

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

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

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

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

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

95+#endif

8896

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

9098 sing = D1Sing

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

140148randomOfShape = do

141149 seed :: Int <- getRandom

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

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

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

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

151+ D1Sing ->

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

153+

154+ D2Sing ->

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

156+

157+ D3Sing ->

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

146159

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

148161--

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

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

151164fromStorable xs = case sing :: Sing x of

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

153− D2Sing -> S2D <$> mkL xs

154− D3Sing -> S3D <$> mkL xs

165+ D1Sing ->

166+ S1D <$> H.create xs

167+

168+ D2Sing ->

169+ S2D <$> mkL xs

170+

171+ D3Sing ->

172+ S3D <$> mkL xs

155173 where

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

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

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

162180 then H.create $ NLA.reshape columns v

163181 else Nothing

164182

183+

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

185+ put i = (case i of

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

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

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

189+ ) :: PutM ()

190+

191+ get = do

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

193+ return i

194+

165195-- Helper function for creating the number instances

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

167197n1 f (S1D x) = S1D (f x)

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

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

176206

177207-- Helper function for creating the number instances

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

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

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

180− D1Sing -> S1D (konst x)

181− D2Sing -> S2D (konst x)

182− D3Sing -> S3D (konst x)

210+ D1Sing ->

211+ S1D (konst x)

212+

213+ D2Sing ->

214+ S2D (konst x)

215+

216+ D3Sing ->

217+ S3D (konst x)

src/Grenade/Layers/Concat.hs+14−2

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE TypeOperators #-}

@@ -8,6 +9,7 @@

89{-# LANGUAGE FlexibleInstances #-}

910{-# LANGUAGE ScopedTypeVariables #-}

1011{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE UndecidableInstances #-}

1113{-|

1214Module : Grenade.Layers.Concat

1315Description : Concatenation layer

@@ -15,15 +17,21 @@ Copyright : (c) Huw Campbell, 2016-2017

1517License : BSD2

1618Stability : experimental

1719

18−This module provides the concatenation layer, whic used to run two separate layers in parallel and combine their outputs.

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

1921-}

2022module Grenade.Layers.Concat (

2123 Concat (..)

2224 ) where

2325

26+import Data.Serialize

27+

2428import Data.Singletons

2529import GHC.TypeLits

2630

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

32+import Data.Kind (Type)

33+#endif

34+

2735import Grenade.Core

2836

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

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

4149--

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

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

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

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

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

4654

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

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

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

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

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

136+

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

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

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

src/Grenade/Layers/Convolution.hs+18−7

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE TypeOperators #-}

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE MultiParamTypeClasses #-}

88{-# LANGUAGE FlexibleInstances #-}

99{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+{-|

12+Module : Grenade.Layers.Convolution

13+Description : Convolution layer

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

15+License : BSD2

16+Stability : experimental

17+

18+This module provides the Convolution layer, which is critical in many computer vision tasks.

19+

20+-}

1021module Grenade.Layers.Convolution (

1122 Convolution (..)

1223 , Convolution' (..)

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

1728import Data.Maybe

1829import Data.Proxy

1930import Data.Serialize

20−import Data.Singletons.TypeLits

2131

2232import GHC.TypeLits

33+import Data.Kind (Type)

2334

2435import Numeric.LinearAlgebra hiding ( uniformSample, konst )

2536import qualified Numeric.LinearAlgebra as LA

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

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

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

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

49− -> * where

60+ -> Type where

5061 Convolution :: ( KnownNat channels

5162 , KnownNat filters

5263 , KnownNat kernelRows

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

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

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

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

68− -> * where

79+ -> Type where

6980 Convolution' :: ( KnownNat channels

7081 , KnownNat filters

7182 , KnownNat kernelRows

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

119130 , KnownNat strideColumns

120131 , KnownNat (kernelRows * kernelColumns * channels)

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

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

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

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

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

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

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

125136 in Convolution newKernel newMomentum

126137

127138 createRandom = randomConvolution

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE GADTs #-}

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

56{-# LANGUAGE TypeFamilies #-}

67{-# LANGUAGE FlexibleContexts #-}

78{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+{-|

11+Module : Grenade.Layers.Crop

12+Description : Cropping layer

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

14+License : BSD2

15+Stability : experimental

16+-}

817module Grenade.Layers.Crop (

918 Crop (..)

1019 ) where

1120

1221import Data.Maybe

1322import Data.Proxy

14−import Data.Singletons.TypeLits

23+import Data.Serialize

24+

1525import GHC.TypeLits

26+import Data.Kind (Type)

1627

1728import Grenade.Core

1829import Grenade.Layers.Internal.Pad

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

2435data Crop :: Nat

2536 -> Nat

2637 -> Nat

27− -> Nat -> * where

38+ -> Nat -> Type where

2839 Crop :: Crop cropLeft cropTop cropRight cropBottom

2940

3041instance Show (Crop cropLeft cropTop cropRight cropBottom) where

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

3546 runUpdate _ x _ = x

3647 createRandom = return Crop

3748

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

50+ put _ = return ()

51+ get = return Crop

52+

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

3954instance ( KnownNat cropLeft

4055 , KnownNat cropTop

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

4459 , KnownNat inputColumns

4560 , KnownNat outputRows

4661 , KnownNat outputColumns

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

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

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

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

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

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

5166 runForwards Crop (S2D input) =

src/Grenade/Layers/Deconvolution.hs+45−35

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE TypeOperators #-}

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE MultiParamTypeClasses #-}

88{-# LANGUAGE FlexibleInstances #-}

99{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+{-|

12+Module : Grenade.Layers.Deconvolution

13+Description : Deconvolution layer

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

15+License : BSD2

16+Stability : experimental

17+

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

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

20+into a larger layer.

21+

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

23+images.

24+-}

1025module Grenade.Layers.Deconvolution (

1126 Deconvolution (..)

1227 , Deconvolution' (..)

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

1732import Data.Maybe

1833import Data.Proxy

1934import Data.Serialize

20−import Data.Singletons.TypeLits

2135

2236import GHC.TypeLits

37+import Data.Kind (Type)

2338

2439import Numeric.LinearAlgebra hiding ( uniformSample, konst )

2540import qualified Numeric.LinearAlgebra as LA

@@ -30,42 +45,37 @@ import Grenade.Layers.Internal.Convolution

3045import Grenade.Layers.Internal.Update

3146

3247-- | A Deconvolution layer for a neural network.

33−-- This uses the im2col Deconvolution trick popularised by Caffe, which essentially turns the

34−-- many, many, many, many loop Deconvolution into a single matrix multiplication.

35−--

36−-- The Deconvolution layer takes all of the kernels for the Deconvolution, which are flattened

37−-- and then put into columns in the matrix.

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

3849--

39−-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:

40−-- `out = (in - kernel) / stride + 1` for both dimensions.

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

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

4152--

42−-- One probably shouldn't build their own layer, but rather use the randomDeconvolution function.

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

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

45− -> Nat -- The number of rows in the kernel filter

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

47− -> Nat -- The row stride of the Deconvolution filter

48− -> Nat -- The columns stride of the Deconvolution filter

49− -> * where

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

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

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

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

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

59+ -> Type where

5060 Deconvolution :: ( KnownNat channels

51− , KnownNat filters

52− , KnownNat kernelRows

53− , KnownNat kernelColumns

54− , KnownNat strideRows

55− , KnownNat strideColumns

56− , KnownNat kernelFlattened

57− , kernelFlattened ~ (kernelRows * kernelColumns * filters))

58− => !(L kernelFlattened channels) -- The kernel filter weights

59− -> !(L kernelFlattened channels) -- The last kernel update (or momentum)

60− -> Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns

61+ , KnownNat filters

62+ , KnownNat kernelRows

63+ , KnownNat kernelColumns

64+ , KnownNat strideRows

65+ , KnownNat strideColumns

66+ , KnownNat kernelFlattened

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

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

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

70+ -> Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns

6171

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

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

64− -> Nat -- The number of rows in the kernel filter

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

66− -> Nat -- The row stride of the Deconvolution filter

67− -> Nat -- The columns stride of the Deconvolution filter

68− -> * where

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

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

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

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

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

78+ -> Type where

6979 Deconvolution' :: ( KnownNat channels

7080 , KnownNat filters

7181 , KnownNat kernelRows

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

119129 , KnownNat strideColumns

120130 , KnownNat (kernelRows * kernelColumns * filters)

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

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

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

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

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

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

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

125135 in Deconvolution newKernel newMomentum

126136

127137 createRandom = randomDeconvolution

src/Grenade/Layers/Elu.hs+10−3

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

22{-# LANGUAGE TypeOperators #-}

33{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

5+{-|

6+Module : Grenade.Layers.Logit

7+Description : Exponential linear unit layer

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

9+License : BSD2

10+Stability : experimental

11+-}

512module Grenade.Layers.Elu (

613 Elu (..)

714 ) where

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

2936 get = return Elu

3037

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

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

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

3340

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

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

3542 where

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

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

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

3845 where

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

4047

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

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

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE RecordWildCards #-}

32{-# LANGUAGE TypeOperators #-}

43{-# LANGUAGE TypeFamilies #-}

54{-# LANGUAGE MultiParamTypeClasses #-}

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

1413

1514import Data.Proxy

1615import Data.Serialize

17−import Data.Singletons.TypeLits

1816

1917import qualified Numeric.LinearAlgebra as LA

2018import Numeric.LinearAlgebra.Static

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

2220import Grenade.Core

2321

2422import Grenade.Layers.Internal.Update

23+import GHC.TypeLits

2524

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

2726data FullyConnected i o = FullyConnected

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

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

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

4039

41− runUpdate LearningParameters {..} (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =

42− let (newBias, newBiasMomentum) = decendVector learningRate learningMomentum learningRegulariser oldBias biasGradient oldBiasMomentum

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

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

41+ let (newBias, newBiasMomentum) = descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldBias biasGradient oldBiasMomentum

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

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

4544

4645 createRandom = randomFullyConnected

4746

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

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

48+ type Tape (FullyConnected i o) ('D1 i) ('D1 o) = R i

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

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

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

5251

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

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

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

5554 let wB' = dEdy

5655 mm' = dEdy `outer` x

5756 -- calcluate derivatives for next step

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

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

11{-# LANGUAGE ForeignFunctionInterface #-}

22module Grenade.Layers.Internal.Update (

3− decendMatrix

4− , decendVector

3+ descendMatrix

4+ , descendVector

55 ) where

66

77import Data.Maybe ( fromJust )

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

1717

1818import System.IO.Unsafe ( unsafePerformIO )

1919

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

21−decendMatrix rate momentum regulariser weights gradient lastUpdate =

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

21+descendMatrix rate momentum regulariser weights gradient lastUpdate =

2222 let (rows, cols) = size weights

2323 len = rows * cols

2424 -- Most gradients come in in ColumnMajor,

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

2929 weights' = flatten . tr . extract $ weights

3030 gradient' = flatten . tr . extract $ gradient

3131 lastUpdate' = flatten . tr . extract $ lastUpdate

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

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

3333

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

3535 -- using the internal vectors.

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

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

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

3939

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

41−decendVector rate momentum regulariser weights gradient lastUpdate =

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

41+descendVector rate momentum regulariser weights gradient lastUpdate =

4242 let len = size weights

4343 weights' = extract weights

4444 gradient' = extract gradient

4545 lastUpdate' = extract lastUpdate

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

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

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

4848

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

50−decendUnsafe len rate momentum regulariser weights gradient lastUpdate =

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

50+descendUnsafe len rate momentum regulariser weights gradient lastUpdate =

5151 unsafePerformIO $ do

5252 outWPtr <- mallocForeignPtrArray len

5353 outMPtr <- mallocForeignPtrArray len

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

6060 withForeignPtr lPtr $ \lPtr' ->

6161 withForeignPtr outWPtr $ \outWPtr' ->

6262 withForeignPtr outMPtr $ \outMPtr' ->

63− decend_cpu len rate momentum regulariser wPtr' gPtr' lPtr' outWPtr' outMPtr'

63+ descend_cpu len rate momentum regulariser wPtr' gPtr' lPtr' outWPtr' outMPtr'

6464

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

6666

6767foreign import ccall unsafe

68− decend_cpu

68+ descend_cpu

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

7070

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

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

33{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE MultiParamTypeClasses #-}

6+{-|

7+Module : Grenade.Layers.Logit

8+Description : Sigmoid nonlinear layer

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

10+License : BSD2

11+Stability : experimental

12+-}

613module Grenade.Layers.Logit (

714 Logit (..)

815 ) where

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

1421import Grenade.Core

1522

1623-- | A Logit layer.

24+--

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

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

1927-- problems.

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

2634 createRandom = return Logit

2735

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

37+ -- Wengert tape optimisation:

38+ --

39+ -- Derivative of the sigmoid function is

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

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

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

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

2944 type Tape Logit a b = S a

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

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

45+ runForwards _ a =

46+ let l = sigmoid a

47+ in (l, l)

48+ runBackwards _ l g =

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

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

3251

3352instance Serialize Logit where

3453 put _ = return ()

3554 get = return Logit

3655

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

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

39−

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

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

42− where

43− logix = logistic x

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

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

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE TypeOperators #-}

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

1011{-# LANGUAGE StandaloneDeriving #-}

1112{-|

1213Module : Grenade.Core.Network

13−Description : Core definition a simple neural etwork

14+Description : Merging layer for parallel network composition

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

1516License : BSD2

1617Stability : experimental

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

1920 Merge (..)

2021 ) where

2122

23+import Data.Serialize

24+

2225import Data.Singletons

2326

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

28+import Data.Kind (Type)

29+#endif

30+

2431import Grenade.Core

2532

2633-- | A Merging layer.

2734--

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

2936-- shape.

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

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

3138 Merge :: x -> y -> Merge x y

3239

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

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

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

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

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

63+

64+instance (Serialize a, Serialize b) => Serialize (Merge a b) where

65+ put (Merge a b) = put a *> put b

66+ get = Merge <$> get <*> get

src/Grenade/Layers/Pad.hs+16−4

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE GADTs #-}

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

56{-# LANGUAGE TypeFamilies #-}

67{-# LANGUAGE MultiParamTypeClasses #-}

78{-# LANGUAGE FlexibleContexts #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+{-|

11+Module : Grenade.Core.Pad

12+Description : Padding layer for 2D and 3D images

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

14+License : BSD2

15+Stability : experimental

16+-}

817module Grenade.Layers.Pad (

918 Pad (..)

1019 ) where

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

1221import Data.Maybe

1322import Data.Proxy

1423import Data.Serialize

15−import Data.Singletons.TypeLits

24+

1625import GHC.TypeLits

26+import Data.Kind (Type)

1727

1828import Grenade.Core

1929import Grenade.Layers.Internal.Pad

@@ -22,10 +32,12 @@ import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)

2232import Numeric.LinearAlgebra.Static (extract, create)

2333

2434-- | A padding layer for a neural network.

35+--

36+-- Pads on the X and Y dimension of an image.

2537data Pad :: Nat

2638 -> Nat

2739 -> Nat

28− -> Nat -> * where

40+ -> Nat -> Type where

2941 Pad :: Pad padLeft padTop padRight padBottom

3042

3143instance Show (Pad padLeft padTop padRight padBottom) where

@@ -40,7 +52,7 @@ instance Serialize (Pad l t r b) where

4052 put _ = return ()

4153 get = return Pad

4254

43−-- | A two dimentional image can be padped.

55+-- | A two dimentional image can be padded.

4456instance ( KnownNat padLeft

4557 , KnownNat padTop

4658 , KnownNat padRight

@@ -70,7 +82,7 @@ instance ( KnownNat padLeft

7082 vs = subMatrix (padt, padl) (nrows, ncols) m

7183 in ((), S2D . fromJust . create $ vs)

7284

73−-- | A two dimentional image can be padped.

85+-- | A two dimentional image can be padded.

7486instance ( KnownNat padLeft

7587 , KnownNat padTop

7688 , KnownNat padRight

src/Grenade/Layers/Pooling.hs+14−3

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE StandaloneDeriving #-}

@@ -6,6 +7,14 @@

67{-# LANGUAGE TypeFamilies #-}

78{-# LANGUAGE MultiParamTypeClasses #-}

89{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+{-|

12+Module : Grenade.Core.Pooling

13+Description : Max Pooling layer for 2D and 3D images

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

15+License : BSD2

16+Stability : experimental

17+-}

918module Grenade.Layers.Pooling (

1019 Pooling (..)

1120 ) where

@@ -13,8 +22,9 @@ module Grenade.Layers.Pooling (

1322import Data.Maybe

1423import Data.Proxy

1524import Data.Serialize

16−import Data.Singletons.TypeLits

25+

1726import GHC.TypeLits

27+import Data.Kind (Type)

1828

1929import Grenade.Core

2030import Grenade.Layers.Internal.Pooling

@@ -22,20 +32,21 @@ import Grenade.Layers.Internal.Pooling

2232import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)

2333

2434-- | A pooling layer for a neural network.

35+--

2536-- Does a max pooling, looking over a kernel similarly to the convolution network, but returning

2637-- maxarg only. This layer is often used to provide minor amounts of translational invariance.

2738--

2839-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:

2940-- `out = (in - kernel) / stride + 1` for both dimensions.

3041--

31−data Pooling :: Nat -> Nat -> Nat -> Nat -> * where

42+data Pooling :: Nat -> Nat -> Nat -> Nat -> Type where

3243 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

3344

3445instance Show (Pooling k k' s s') where

3546 show Pooling = "Pooling"

3647

3748instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

38− type Gradient (Pooling kr kc sr sc) = ()

49+ type Gradient (Pooling kernelRows kernelColumns strideRows strideColumns) = ()

3950 runUpdate _ Pooling _ = Pooling

4051 createRandom = return Pooling

4152

src/Grenade/Layers/Relu.hs+7

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

22{-# LANGUAGE TypeOperators #-}

33{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

5+{-|

6+Module : Grenade.Layers.Relu

7+Description : Rectifying linear unit layer

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

9+License : BSD2

10+Stability : experimental

11+-}

512module Grenade.Layers.Relu (

613 Relu (..)

714 ) where

src/Grenade/Layers/Reshape.hs+11−4

@@ -3,13 +3,20 @@

33{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

55{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE UndecidableInstances #-}

7+{-|

8+Module : Grenade.Layers.Reshape

9+Description : Multipurpose reshaping layer

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

11+License : BSD2

12+Stability : experimental

13+-}

614module Grenade.Layers.Reshape (

715 Reshape (..)

816 ) where

917

1018import Data.Serialize

1119

12−import Data.Singletons.TypeLits

1320import GHC.TypeLits

1421

1522import Numeric.LinearAlgebra.Static

@@ -19,9 +26,9 @@ import Grenade.Core

1926

2027-- | Reshape Layer

2128--

22−-- Flattens input down to D1 from either 2D or 3D data.

23−--

24−-- Casts input D1 up to either 2D or 3D data if the shapes are good.

29+-- The Reshape layer can flatten any 2D or 3D image to 1D vector with the

30+-- same number of activations, as well as cast up from 1D to a 2D or 3D

31+-- shape.

2532--

2633-- Can also be used to turn a 3D image with only one channel into a 2D image

2734-- or vice versa.

src/Grenade/Layers/Sinusoid.hsnew file+39

@@ -0,0 +1,39 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-|

7+Module : Grenade.Layers.Sinusoid

8+Description : Sinusoid nonlinear layer

9+Copyright : (c) Manuel Schneckenreither, 2018

10+License : BSD2

11+Stability : experimental

12+-}

13+module Grenade.Layers.Sinusoid (

14+ Sinusoid (..)

15+ ) where

16+

17+import Data.Serialize

18+import Data.Singletons

19+

20+import Grenade.Core

21+

22+-- | A Sinusoid layer.

23+-- A layer which can act between any shape of the same dimension, performing a sin function.

24+data Sinusoid = Sinusoid

25+ deriving Show

26+

27+instance UpdateLayer Sinusoid where

28+ type Gradient Sinusoid = ()

29+ runUpdate _ _ _ = Sinusoid

30+ createRandom = return Sinusoid

31+

32+instance Serialize Sinusoid where

33+ put _ = return ()

34+ get = return Sinusoid

35+

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

37+ type Tape Sinusoid a b = S a

38+ runForwards _ a = (a, sin a)

39+ runBackwards _ a g = ((), cos a * g)

src/Grenade/Layers/Softmax.hs+11

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

33{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE MultiParamTypeClasses #-}

6+{-|

7+Module : Grenade.Core.Softmax

8+Description : Softmax loss layer

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

10+License : BSD2

11+Stability : experimental

12+-}

613module Grenade.Layers.Softmax (

714 Softmax (..)

815 , softmax

@@ -17,8 +24,12 @@ import Grenade.Core

1724import Numeric.LinearAlgebra.Static as LAS

1825

1926-- | A Softmax layer

27+--

2028-- This layer is like a logit layer, but normalises

2129-- a set of matricies to be probabilities.

30+--

31+-- One can use this layer as the last layer in a network

32+-- if they need normalised probabilities.

2233data Softmax = Softmax

2334 deriving Show

2435

src/Grenade/Layers/Tanh.hs+10−3

@@ -1,8 +1,15 @@

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeOperators #-}

3−{-# LANGUAGE TypeFamilies #-}

42{-# LANGUAGE FlexibleInstances #-}

53{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-|

7+Module : Grenade.Layers.Tanh

8+Description : Hyperbolic tangent nonlinear layer

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

10+License : BSD2

11+Stability : experimental

12+-}

613module Grenade.Layers.Tanh (

714 Tanh (..)

815 ) where

@@ -13,7 +20,7 @@ import Data.Singletons

1320import Grenade.Core

1421

1522-- | A Tanh layer.

16−-- A layer which can act between any shape of the same dimension, perfoming a tanh function.

23+-- A layer which can act between any shape of the same dimension, performing a tanh function.

1724data Tanh = Tanh

1825 deriving Show

1926

src/Grenade/Layers/Trivial.hs+11−1

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

33{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

55{-# LANGUAGE FlexibleInstances #-}

6+{-|

7+Module : Grenade.Core.Trivial

8+Description : Trivial layer which perfoms no operations on the data

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

10+License : BSD2

11+Stability : experimental

12+-}

613module Grenade.Layers.Trivial (

714 Trivial (..)

815 ) where

@@ -11,7 +18,10 @@ import Data.Serialize

1118

1219import Grenade.Core

1320

14−-- | A trivial layer.

21+-- | A Trivial layer.

22+--

23+-- This can be used to pass an unchanged value up one side of a

24+-- graph, for a Residual network for example.

1525data Trivial = Trivial

1626 deriving Show

1727

src/Grenade/Recurrent.hs+22

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

11module Grenade.Recurrent (

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

3+ -- for recurrent networks in Grenade.

4+

5+ -- * Exported modules

6+ --

7+ -- | The core types and runners for Recurrent Networks.

28 module Grenade.Recurrent.Core

9+

10+ -- | The recurrent neural network layer zoo

311 , module Grenade.Recurrent.Layers

12+

13+ -- * Overview of recurrent Networks

14+ -- $recurrent

15+

416 ) where

517

618import Grenade.Recurrent.Core

719import Grenade.Recurrent.Layers

20+

21+{- $recurrent

22+There are two ways in which deep learning libraries choose to represent

23+recurrent Neural Networks, as an unrolled graph, or at a first class

24+level. Grenade chooses the latter representation, and provides a network

25+type which is specifically suited for recurrent neural networks.

26+

27+Currently grenade supports two layers, a basic recurrent layer, and an

28+LSTM layer.

29+-}

src/Grenade/Recurrent/Core/Layer.hs+9−6

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE TypeFamilies #-}

34{-# LANGUAGE MultiParamTypeClasses #-}

@@ -8,7 +9,9 @@ module Grenade.Recurrent.Core.Layer (

89 , RecurrentUpdateLayer (..)

910 ) where

1011

11−import Data.Singletons ( SingI )

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

13+import Data.Kind (Type)

14+#endif

1215

1316import Grenade.Core

1417

@@ -17,16 +20,16 @@ import Grenade.Core

1720-- of an extra recurrent data shape.

1821class UpdateLayer x => RecurrentUpdateLayer x where

1922 -- | Shape of data that is passed between each subsequent run of the layer

20− type RecurrentShape x :: Shape

23+ type RecurrentShape x :: Type

2124

22−class (RecurrentUpdateLayer x, SingI (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where

25+class (RecurrentUpdateLayer x, Num (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where

2326 -- | Wengert Tape

24− type RecTape x i o :: *

27+ type RecTape x i o :: Type

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

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

27− runRecurrentForwards :: x -> S (RecurrentShape x) -> S i -> (RecTape x i o, S (RecurrentShape x), S o)

30+ runRecurrentForwards :: x -> RecurrentShape x -> S i -> (RecTape x i o, RecurrentShape x, S o)

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

2932 -- layer gave from the input and the back propagated derivatives from

3033 -- the layer above.

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

32− runRecurrentBackwards :: x -> RecTape x i o -> S (RecurrentShape x) -> S o -> (Gradient x, S (RecurrentShape x), S i)

35+ runRecurrentBackwards :: x -> RecTape x i o -> RecurrentShape x -> S o -> (Gradient x, RecurrentShape x, S i)

src/Grenade/Recurrent/Core/Network.hs+122−118

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE TypeOperators #-}

@@ -17,37 +18,34 @@ module Grenade.Recurrent.Core.Network (

1718

1819 , RecurrentNetwork (..)

1920 , RecurrentInputs (..)

20− , RecurrentTapes (..)

21− , RecurrentGradients (..)

21+ , RecurrentTape (..)

22+ , RecurrentGradient (..)

2223

2324 , randomRecurrent

24− , runRecurrentNetwork

25− , runRecurrentGradient

25+ , runRecurrent

26+ , runRecurrent'

2627 , applyRecurrentUpdate

2728 ) where

2829

2930

3031import Control.Monad.Random ( MonadRandom )

31−import Data.Singletons ( SingI )

32−import Data.Singletons.Prelude ( Head, Last )

3332import Data.Serialize

34−import qualified Data.Vector.Storable as V

33+

34+import Data.Kind (Type)

3535

3636import Grenade.Core

3737import Grenade.Recurrent.Core.Layer

38−

39−import qualified Numeric.LinearAlgebra as LA

40−import qualified Numeric.LinearAlgebra.Static as LAS

38+import Prelude.Singletons

4139

4240-- | Witness type to say indicate we're building up with a normal feed

4341-- forward layer.

44−data FeedForward :: * -> *

42+data FeedForward :: Type -> Type

4543-- | Witness type to say indicate we're building up with a recurrent layer.

46−data Recurrent :: * -> *

44+data Recurrent :: Type -> Type

4745

4846-- | Type of a recurrent neural network.

4947--

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

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

5149--

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

5351--

@@ -56,7 +54,7 @@ data Recurrent :: * -> *

5654--

5755-- Often, to make the definitions more concise, one will use a type alias

5856-- for these empty data types.

59−data RecurrentNetwork :: [*] -> [Shape] -> * where

57+data RecurrentNetwork :: [Type] -> [Shape] -> Type where

6058 RNil :: SingI i

6159 => RecurrentNetwork '[] '[i]

6260

@@ -75,96 +73,82 @@ infixr 5 :~@>

7573-- | Gradient of a network.

7674--

7775-- Parameterised on the layers of the network.

78−data RecurrentGradients :: [*] -> * where

79− RGNil :: RecurrentGradients '[]

76+data RecurrentGradient :: [Type] -> Type where

77+ RGNil :: RecurrentGradient '[]

8078

8179 (://>) :: UpdateLayer x

82− => [Gradient x]

83− -> RecurrentGradients xs

84− -> RecurrentGradients (phantom x ': xs)

80+ => Gradient x

81+ -> RecurrentGradient xs

82+ -> RecurrentGradient (phantom x ': xs)

8583

8684-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)

8785-- Parameterised on the layers of a Network.

88−data RecurrentInputs :: [*] -> * where

86+data RecurrentInputs :: [Type] -> Type where

8987 RINil :: RecurrentInputs '[]

9088

91− (:~~+>) :: UpdateLayer x

89+ (:~~+>) :: (UpdateLayer x, Fractional (RecurrentInputs xs))

9290 => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)

9391

94− (:~@+>) :: (SingI (RecurrentShape x), RecurrentUpdateLayer x)

95− => !(S (RecurrentShape x)) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)

92+ (:~@+>) :: (Fractional (RecurrentShape x), Fractional (RecurrentInputs xs), RecurrentUpdateLayer x)

93+ => !(RecurrentShape x) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)

9694

9795-- | All the information required to backpropogate

9896-- through time safely.

9997--

10098-- We index on the time step length as well, to ensure

10199-- that that all Tape lengths are the same.

102−data RecurrentTapes :: [*] -> [Shape] -> * where

100+data RecurrentTape :: [Type] -> [Shape] -> Type where

103101 TRNil :: SingI i

104− => RecurrentTapes '[] '[i]

105−

106− (:\~>) :: [Tape x i h]

107− -> !(RecurrentTapes xs (h ': hs))

108− -> RecurrentTapes (FeedForward x ': xs) (i ': h ': hs)

102+ => RecurrentTape '[] '[i]

109103

104+ (:\~>) :: Tape x i h

105+ -> !(RecurrentTape xs (h ': hs))

106+ -> RecurrentTape (FeedForward x ': xs) (i ': h ': hs)

110107

111− (:\@>) :: [RecTape x i h]

112− -> !(RecurrentTapes xs (h ': hs))

113− -> RecurrentTapes (Recurrent x ': xs) (i ': h ': hs)

108+ (:\@>) :: RecTape x i h

109+ -> !(RecurrentTape xs (h ': hs))

110+ -> RecurrentTape (Recurrent x ': xs) (i ': h ': hs)

114111

115112

116−runRecurrentNetwork :: forall shapes layers.

117− RecurrentNetwork layers shapes

118− -> RecurrentInputs layers

119− -> [S (Head shapes)]

120− -> (RecurrentTapes layers shapes, RecurrentInputs layers, [S (Last shapes)])

121−runRecurrentNetwork =

113+runRecurrent :: forall shapes layers.

114+ RecurrentNetwork layers shapes

115+ -> RecurrentInputs layers

116+ -> S (Head shapes)

117+ -> (RecurrentTape layers shapes, RecurrentInputs layers, S (Last shapes))

118+runRecurrent =

122119 go

123120 where

124121 go :: forall js sublayers. (Last js ~ Last shapes)

125122 => RecurrentNetwork sublayers js

126123 -> RecurrentInputs sublayers

127− -> [S (Head js)]

128− -> (RecurrentTapes sublayers js, RecurrentInputs sublayers, [S (Last js)])

129− -- This is a simple non-recurrent layer, just map it forwards

130− go (layer :~~> n) (() :~~+> nIn) !xs

131− = let tys = runForwards layer <$> xs

132− feedForwardTapes = fst <$> tys

133− forwards = snd <$> tys

124+ -> S (Head js)

125+ -> (RecurrentTape sublayers js, RecurrentInputs sublayers, S (Last js))

126+ go (!layer :~~> n) (() :~~+> nIn) !x

127+ = let (!tape, !forwards) = runForwards layer x

128+

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

135− (newFN, ig, answer) = go n nIn forwards

136− in (feedForwardTapes :\~> newFN, () :~~+> ig, answer)

130+ (!newFN, !ig, !answer) = go n nIn forwards

131+ in (tape :\~> newFN, () :~~+> ig, answer)

137132

138133 -- This is a recurrent layer, so we need to do a scan, first input to last, providing

139134 -- the recurrent shape output to the next layer.

140− go (layer :~@> n) (recIn :~@+> nIn) !xs

141− = let (recOut, tys) = goR layer recIn xs

142− recurrentTapes = fst <$> tys

143− forwards = snd <$> tys

144−

135+ go (layer :~@> n) (recIn :~@+> nIn) !x

136+ = let (tape, shape, forwards) = runRecurrentForwards layer recIn x

145137 (newFN, ig, answer) = go n nIn forwards

146− in (recurrentTapes :\@> newFN, recOut :~@+> ig, answer)

138+ in (tape :\@> newFN, shape :~@+> ig, answer)

147139

148140 -- Handle the output layer, bouncing the derivatives back down.

149141 -- We may not have a target for each example, so when we don't use 0 gradient.

150142 go RNil RINil !x

151143 = (TRNil, RINil, x)

152144

153− -- Helper function for recurrent layers

154− -- Scans over the recurrent direction of the graph.

155− goR !layer !recShape (x:xs) =

156− let (tape, lerec, lepush) = runRecurrentForwards layer recShape x

157− (rems, push) = goR layer lerec xs

158− in (rems, (tape, lepush) : push)

159− goR _ rin [] = (rin, [])

160−

161−runRecurrentGradient :: forall layers shapes.

162− RecurrentNetwork layers shapes

163− -> RecurrentTapes layers shapes

164− -> RecurrentInputs layers

165− -> [S (Last shapes)]

166− -> (RecurrentGradients layers, RecurrentInputs layers, [S (Head shapes)])

167−runRecurrentGradient net tapes r o =

145+runRecurrent' :: forall layers shapes.

146+ RecurrentNetwork layers shapes

147+ -> RecurrentTape layers shapes

148+ -> RecurrentInputs layers

149+ -> S (Last shapes)

150+ -> (RecurrentGradient layers, RecurrentInputs layers, S (Head shapes))

151+runRecurrent' net tapes r o =

168152 go net tapes r

169153 where

170154 -- We have to be careful regarding the direction of the lists

@@ -172,51 +156,41 @@ runRecurrentGradient net tapes r o =

172156 -- through time.

173157 go :: forall js ss. (Last js ~ Last shapes)

174158 => RecurrentNetwork ss js

175− -> RecurrentTapes ss js

159+ -> RecurrentTape ss js

176160 -> RecurrentInputs ss

177− -> (RecurrentGradients ss, RecurrentInputs ss, [S (Head js)])

161+ -> (RecurrentGradient ss, RecurrentInputs ss, S (Head js))

178162 -- This is a simple non-recurrent layer

179− -- Run the rest of the network, then fmap the tapes and gradients

180− go (layer :~~> n) (feedForwardTapes :\~> nTapes) (() :~~+> nRecs) =

181− let (gradients, rins, feed) = go n nTapes nRecs

182− backs = uncurry (runBackwards layer) <$> zip (reverse feedForwardTapes) feed

183− in ((fst <$> backs) ://> gradients, () :~~+> rins, snd <$> backs)

163+ -- Run the rest of the network, update with the tapes and gradients

164+ go (!layer :~~> n) (!tape :\~> nTapes) (() :~~+> nRecs) =

165+ let (!gradients, !rins, !feed) = go n nTapes nRecs

166+ (!grad, !back) = runBackwards layer tape feed

167+ in (grad ://> gradients, () :~~+> rins, back)

184168

185169 -- This is a recurrent layer

186170 -- Run the rest of the network, scan over the tapes in reverse

187− go (layer :~@> n) (recurrentTapes :\@> nTapes) (recGrad :~@+> nRecs) =

188− let (gradients, rins, feed) = go n nTapes nRecs

189− backExamples = zip (reverse recurrentTapes) feed

190− (rg, backs) = goX layer recGrad backExamples

191− in ((fst <$> backs) ://> gradients, rg :~@+> rins, snd <$> backs)

171+ go (!layer :~@> n) (!tape :\@> nTapes) (!recGrad :~@+> nRecs) =

172+ let (!gradients, !rins, !feed) = go n nTapes nRecs

173+ (!grad, !sidegrad, !back) = runRecurrentBackwards layer tape recGrad feed

174+ in (grad ://> gradients, sidegrad :~@+> rins, back)

192175

193176 -- End of the road, so we reflect the given gradients backwards.

194177 -- Crucially, we reverse the list, so it's backwards in time as

195178 -- well.

196− go RNil TRNil RINil

197− = (RGNil, RINil, reverse o)

198−

199− -- Helper function for recurrent layers

200− -- Scans over the recurrent direction of the graph.

201− goX :: RecurrentLayer x i o => x -> S (RecurrentShape x) -> [(RecTape x i o, S o)] -> (S (RecurrentShape x), [(Gradient x, S i)])

202− goX layer !lastback ((recTape, backgrad):xs) =

203− let (layergrad, recgrad, ingrad) = runRecurrentBackwards layer recTape lastback backgrad

204− (pushedback, ll) = goX layer recgrad xs

205− in (pushedback, (layergrad, ingrad) : ll)

206− goX _ !lastback [] = (lastback, [])

179+ go !RNil !TRNil !RINil

180+ = (RGNil, RINil, o)

207181

208182-- | Apply a batch of gradients to the network

209183-- Uses runUpdates which can be specialised for

210184-- a layer.

211185applyRecurrentUpdate :: LearningParameters

212186 -> RecurrentNetwork layers shapes

213− -> RecurrentGradients layers

187+ -> RecurrentGradient layers

214188 -> RecurrentNetwork layers shapes

215189applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)

216− = runUpdates rate layer gradient :~~> applyRecurrentUpdate rate rest grest

190+ = runUpdate rate layer gradient :~~> applyRecurrentUpdate rate rest grest

217191

218192applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)

219− = runUpdates rate layer gradient :~@> applyRecurrentUpdate rate rest grest

193+ = runUpdate rate layer gradient :~@> applyRecurrentUpdate rate rest grest

220194

221195applyRecurrentUpdate _ RNil RGNil

222196 = RNil

@@ -232,26 +206,25 @@ instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recu

232206

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

234208-- recurrent network and a set of random inputs for it is with the randomRecurrent.

235−class CreatableRecurrent (xs :: [*]) (ss :: [Shape]) where

209+class CreatableRecurrent (xs :: [Type]) (ss :: [Shape]) where

236210 -- | Create a network of the types requested

237− randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss, RecurrentInputs xs)

211+ randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss)

238212

239213instance SingI i => CreatableRecurrent '[] '[i] where

240214 randomRecurrent =

241− return (RNil, RINil)

215+ return RNil

242216

243217instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where

244218 randomRecurrent = do

245219 thisLayer <- createRandom

246− (rest, resti) <- randomRecurrent

247− return (thisLayer :~~> rest, () :~~+> resti)

220+ rest <- randomRecurrent

221+ return (thisLayer :~~> rest)

248222

249223instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where

250224 randomRecurrent = do

251225 thisLayer <- createRandom

252− thisShape <- randomOfShape

253− (rest, resti) <- randomRecurrent

254− return (thisLayer :~@> rest, thisShape :~@+> resti)

226+ rest <- randomRecurrent

227+ return (thisLayer :~@> rest)

255228

256229-- | Add very simple serialisation to the recurrent network

257230instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where

@@ -270,23 +243,13 @@ instance (Serialize (RecurrentInputs '[])) where

270243 put _ = return ()

271244 get = return RINil

272245

273−instance (UpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

246+instance (UpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

274247 put ( () :~~+> rest) = put rest

275248 get = ( () :~~+> ) <$> get

276249

277−instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

278− put ( i :~@+> rest ) = do

279− _ <- (case i of

280− (S1D x) -> putListOf put . LA.toList . LAS.extract $ x

281− (S2D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

282− (S3D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

283− ) :: PutM ()

284− put rest

285−

286− get = do

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

288− rest <- get

289− return ( i :~@+> rest)

250+instance (Serialize (RecurrentShape x), Fractional (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

251+ put ( i :~@+> rest ) = put i >> put rest

252+ get = (:~@+>) <$> get <*> get

290253

291254

292255-- Num instance for `RecurrentInputs layers`

@@ -307,7 +270,7 @@ instance (Num (RecurrentInputs '[])) where

307270 signum _ = RINil

308271 fromInteger _ = RINil

309272

310−instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where

273+instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where

311274 (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)

312275 (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)

313276 (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)

@@ -315,10 +278,51 @@ instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Fee

315278 signum (() :~~+> x) = () :~~+> signum x

316279 fromInteger x = () :~~+> fromInteger x

317280

318−instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where

281+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where

319282 (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')

320283 (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')

321284 (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')

322285 abs (x :~@+> x') = abs x :~@+> abs x'

323286 signum (x :~@+> x') = signum x :~@+> signum x'

324287 fromInteger x = fromInteger x :~@+> fromInteger x

288+

289+instance (Fractional (RecurrentInputs '[])) where

290+ (/) _ _ = RINil

291+ recip _ = RINil

292+ fromRational _ = RINil

293+

294+instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (FeedForward x ': ys))) where

295+ (/) (() :~~+> x) (() :~~+> y) = () :~~+> (x / y)

296+ recip (() :~~+> x) = () :~~+> recip x

297+ fromRational x = () :~~+> fromRational x

298+

299+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (Recurrent x ': ys))) where

300+ (/) (x :~@+> x') (y :~@+> y') = (x / y) :~@+> (x' / y')

301+ recip (x :~@+> x') = recip x :~@+> recip x'

302+ fromRational x = fromRational x :~@+> fromRational x

303+

304+

305+-- | Ultimate composition.

306+--

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

308+instance CreatableRecurrent sublayers subshapes => UpdateLayer (RecurrentNetwork sublayers subshapes) where

309+ type Gradient (RecurrentNetwork sublayers subshapes) = RecurrentGradient sublayers

310+ runUpdate = applyRecurrentUpdate

311+ createRandom = randomRecurrent

312+

313+-- | Ultimate composition.

314+--

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

316+instance CreatableRecurrent sublayers subshapes => RecurrentUpdateLayer (RecurrentNetwork sublayers subshapes) where

317+ type RecurrentShape (RecurrentNetwork sublayers subshapes) = RecurrentInputs sublayers

318+

319+-- | Ultimate composition.

320+--

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

322+instance ( CreatableRecurrent sublayers subshapes

323+ , i ~ (Head subshapes), o ~ (Last subshapes)

324+ , Num (RecurrentShape (RecurrentNetwork sublayers subshapes))

325+ ) => RecurrentLayer (RecurrentNetwork sublayers subshapes) i o where

326+ type RecTape (RecurrentNetwork sublayers subshapes) i o = RecurrentTape sublayers subshapes

327+ runRecurrentForwards = runRecurrent

328+ runRecurrentBackwards = runRecurrent'

src/Grenade/Recurrent/Core/Runner.hs+54−34

@@ -6,33 +6,67 @@

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE FlexibleContexts #-}

88{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE RecordWildCards #-}

109

1110module Grenade.Recurrent.Core.Runner (

12− trainRecurrent

13− , runRecurrent

11+ runRecurrentExamples

12+ , runRecurrentBackprop

1413 , backPropagateRecurrent

14+ , trainRecurrent

15+

16+ , RecurrentGradients

1517 ) where

1618

17−import Data.Singletons.Prelude

19+import Data.List ( foldl' )

1820import Grenade.Core

1921

20−import Grenade.Recurrent.Core.Layer

2122import Grenade.Recurrent.Core.Network

23+import Prelude.Singletons

24+

25+type RecurrentGradients layers = [RecurrentGradient layers]

26+

27+runRecurrentExamples :: forall shapes layers.

28+ RecurrentNetwork layers shapes

29+ -> RecurrentInputs layers

30+ -> [S (Head shapes)]

31+ -> ([(RecurrentTape layers shapes, S (Last shapes))], RecurrentInputs layers)

32+runRecurrentExamples net =

33+ go

34+ where

35+ go !side [] = ([], side)

36+ go !side (!x : xs) =

37+ let (!tape, !side', !o) = runRecurrent net side x

38+ (!res, !finalSide) = go side' xs

39+ in (( tape, o ) : res, finalSide)

40+

41+runRecurrentBackprop :: forall layers shapes.

42+ RecurrentNetwork layers shapes

43+ -> RecurrentInputs layers

44+ -> [(RecurrentTape layers shapes, S (Last shapes))]

45+ -> ([(RecurrentGradient layers, S (Head shapes))], RecurrentInputs layers)

46+runRecurrentBackprop net =

47+ go

48+ where

49+ go !side [] = ([], side)

50+ go !side ((!tape,!x):xs) =

51+ let (res, !side') = go side xs

52+ (!grad, !finalSide, !o) = runRecurrent' net tape side' x

53+ in (( grad, o ) : res, finalSide)

54+

2255

2356-- | Drive and network and collect its back propogated gradients.

24−backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))

57+backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

2558 => RecurrentNetwork layers shapes

2659 -> RecurrentInputs layers

2760 -> [(S (Head shapes), Maybe (S (Last shapes)))]

2861 -> (RecurrentGradients layers, RecurrentInputs layers)

2962backPropagateRecurrent network recinputs examples =

30− let (tapes, _, guesses) = runRecurrentNetwork network recinputs inputs

63+ let (outForwards, _) = runRecurrentExamples network recinputs inputs

3164

32− backPropagations = zipWith makeError guesses targets

65+ backPropagations = zipWith makeError outForwards targets

3366

34− (gradients, input', _) = runRecurrentGradient network tapes 0 backPropagations

67+ (outBackwards, input') = runRecurrentBackprop network 0 backPropagations

3568

69+ gradients = fmap fst outBackwards

3670 in (gradients, input')

3771

3872 where

@@ -40,12 +74,12 @@ backPropagateRecurrent network recinputs examples =

4074 inputs = fst <$> examples

4175 targets = snd <$> examples

4276

43− makeError :: S (Last shapes) -> Maybe (S (Last shapes)) -> S (Last shapes)

44− makeError _ Nothing = 0

45− makeError y (Just t) = y - t

77+ makeError :: (x, S (Last shapes)) -> Maybe (S (Last shapes)) -> (x, S (Last shapes))

78+ makeError (x, _) Nothing = (x, 0)

79+ makeError (x, y) (Just t) = (x, y - t)

4680

4781

48−trainRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))

82+trainRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

4983 => LearningParameters

5084 -> RecurrentNetwork layers shapes

5185 -> RecurrentInputs layers

@@ -56,35 +90,21 @@ trainRecurrent rate network recinputs examples =

5690

5791 newInputs = updateRecInputs rate recinputs recinputs'

5892

59− newNetwork = applyRecurrentUpdate rate network gradients

93+ newNetwork = foldl' (applyRecurrentUpdate rate) network gradients

6094

6195 in (newNetwork, newInputs)

6296

63−updateRecInputs :: LearningParameters

97+updateRecInputs :: Fractional (RecurrentInputs sublayers)

98+ => LearningParameters

6499 -> RecurrentInputs sublayers

65100 -> RecurrentInputs sublayers

66101 -> RecurrentInputs sublayers

67102

68−updateRecInputs l@LearningParameters {..} (() :~~+> xs) (() :~~+> ys)

69− = () :~~+> updateRecInputs l xs ys

103+updateRecInputs lp (() :~~+> xs) (() :~~+> ys)

104+ = () :~~+> updateRecInputs lp xs ys

70105

71−updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)

72− = (realToFrac (1 - learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys

106+updateRecInputs lp (x :~@+> xs) (y :~@+> ys)

107+ = (realToFrac (1 - learningRate lp * learningRegulariser lp) * x - realToFrac (learningRate lp) * y) :~@+> updateRecInputs lp xs ys

73108

74109updateRecInputs _ RINil RINil

75110 = RINil

76−

77−-- | Just forwards propagation with no training.

78−runRecurrent :: RecurrentNetwork layers shapes

79− -> RecurrentInputs layers -> S (Head shapes)

80− -> (RecurrentInputs layers, S (Last shapes))

81−runRecurrent (layer :~~> n) (() :~~+> nr) !x

82− = let (_, ys) = runForwards layer x

83− (nr', o) = runRecurrent n nr ys

84− in (() :~~+> nr', o)

85−runRecurrent (layer :~@> n) (recin :~@+> nr) !x

86− = let (_, recin', y) = runRecurrentForwards layer recin x

87− (nr', o) = runRecurrent n nr y

88− in (recin' :~@+> nr', o)

89−runRecurrent RNil RINil !x

90− = (RINil, x)

src/Grenade/Recurrent/Layers.hs+2

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

11module Grenade.Recurrent.Layers (

22 module Grenade.Recurrent.Layers.BasicRecurrent

3+ , module Grenade.Recurrent.Layers.ConcatRecurrent

34 , module Grenade.Recurrent.Layers.LSTM

45 ) where

56

67import Grenade.Recurrent.Layers.BasicRecurrent

8+import Grenade.Recurrent.Layers.ConcatRecurrent

79import Grenade.Recurrent.Layers.LSTM

src/Grenade/Recurrent/Layers/BasicRecurrent.hs+10−9

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE TypeOperators #-}

55{-# LANGUAGE TypeFamilies #-}

66{-# LANGUAGE MultiParamTypeClasses #-}

@@ -16,7 +16,8 @@ module Grenade.Recurrent.Layers.BasicRecurrent (

1616

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

1818

19−import Data.Singletons.TypeLits

19+

20+import Data.Kind (Type)

2021

2122import Numeric.LinearAlgebra.Static

2223

@@ -27,7 +28,7 @@ import Grenade.Recurrent.Core

2728

2829data BasicRecurrent :: Nat -- Input layer size

2930 -> Nat -- Output layer size

30− -> * where

31+ -> Type where

3132 BasicRecurrent :: ( KnownNat input

3233 , KnownNat output

3334 , KnownNat matrixCols

@@ -40,7 +41,7 @@ data BasicRecurrent :: Nat -- Input layer size

4041

4142data BasicRecurrent' :: Nat -- Input layer size

4243 -> Nat -- Output layer size

43− -> * where

44+ -> Type where

4445 BasicRecurrent' :: ( KnownNat input

4546 , KnownNat output

4647 , KnownNat matrixCols

@@ -55,18 +56,18 @@ instance Show (BasicRecurrent i o) where

5556instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

5657 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

5758

58− runUpdate LearningParameters {..} (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

59− let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient

59+ runUpdate lp (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

60+ let newBiasMomentum = konst (learningMomentum lp) * oldBiasMomentum - konst (learningRate lp) * biasGradient

6061 newBias = oldBias + newBiasMomentum

61− newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient

62− regulariser = konst (learningRegulariser * learningRate) * oldActivations

62+ newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient

63+ regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations

6364 newActivations = oldActivations + newMomentum - regulariser

6465 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

6566

6667 createRandom = randomBasicRecurrent

6768

6869instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where

69− type RecurrentShape (BasicRecurrent i o) = 'D1 o

70+ type RecurrentShape (BasicRecurrent i o) = S ('D1 o)

7071

7172instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

7273

src/Grenade/Recurrent/Layers/ConcatRecurrent.hsnew file+180

@@ -0,0 +1,180 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE FlexibleInstances #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+{-|

14+Module : Grenade.Layers.Concat

15+Description : Concatenation layer

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

17+License : BSD2

18+Stability : experimental

19+

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

21+-}

22+module Grenade.Recurrent.Layers.ConcatRecurrent (

23+ ConcatRecurrent (..)

24+ ) where

25+

26+import Data.Serialize

27+

28+import Data.Singletons

29+import GHC.TypeLits

30+

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

32+import Data.Kind (Type)

33+#endif

34+

35+import Grenade.Core

36+import Grenade.Recurrent.Core

37+

38+import Numeric.LinearAlgebra.Static ( (#), split, R )

39+

40+-- | A Concatentating Layer.

41+--

42+-- This layer shares it's input state between two sublayers, and concatenates their output.

43+--

44+-- With Networks able to be Layers, this allows for very expressive composition of complex Networks.

45+--

46+-- The Concat layer has a few instances, which allow one to flexibly "bash" together the outputs.

47+--

48+-- Two 1D vectors, can go to a 2D shape with 2 rows if their lengths are identical.

49+-- Any 2 1D vectors can also become a longer 1D Vector.

50+--

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

52+-- and Crop layers to ensure this is the case.

53+data ConcatRecurrent :: Shape -> Type -> Shape -> Type -> Type where

54+ ConcatRecLeft :: x -> y -> ConcatRecurrent m (Recurrent x) n (FeedForward y)

55+ ConcatRecRight :: x -> y -> ConcatRecurrent m (FeedForward x) n (Recurrent y)

56+ ConcatRecBoth :: x -> y -> ConcatRecurrent m (Recurrent x) n (Recurrent y)

57+

58+instance (Show x, Show y) => Show (ConcatRecurrent m (p x) n (q y)) where

59+ show (ConcatRecLeft x y) = "ConcatRecLeft\n" ++ show x ++ "\n" ++ show y

60+ show (ConcatRecRight x y) = "ConcatRecRight\n" ++ show x ++ "\n" ++ show y

61+ show (ConcatRecBoth x y) = "ConcatRecBoth\n" ++ show x ++ "\n" ++ show y

62+

63+instance (RecurrentUpdateLayer x, UpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where

64+ type Gradient (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = (Gradient x, Gradient y)

65+ runUpdate lr (ConcatRecLeft x y) (x', y')

66+ = ConcatRecLeft (runUpdate lr x x') (runUpdate lr y y')

67+ createRandom

68+ = ConcatRecLeft <$> createRandom <*> createRandom

69+

70+instance (UpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where

71+ type Gradient (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = (Gradient x, Gradient y)

72+ runUpdate lr (ConcatRecRight x y) (x', y')

73+ = ConcatRecRight (runUpdate lr x x') (runUpdate lr y y')

74+ createRandom

75+ = ConcatRecRight <$> createRandom <*> createRandom

76+

77+instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where

78+ type Gradient (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = (Gradient x, Gradient y)

79+ runUpdate lr (ConcatRecBoth x y) (x', y')

80+ = ConcatRecBoth (runUpdate lr x x') (runUpdate lr y y')

81+ createRandom

82+ = ConcatRecBoth <$> createRandom <*> createRandom

83+

84+instance (RecurrentUpdateLayer x, UpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where

85+ type RecurrentShape (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = RecurrentShape x

86+

87+instance (UpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where

88+ type RecurrentShape (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = RecurrentShape y

89+

90+instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where

91+ type RecurrentShape (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = RecurrentInputs '[ Recurrent x, Recurrent y ]

92+

93+instance ( SingI i

94+ , Layer x i ('D1 m)

95+ , RecurrentLayer y i ('D1 n)

96+ , KnownNat o

97+ , KnownNat m

98+ , KnownNat n

99+ , o ~ (m + n)

100+ , n ~ (o - m)

101+ , (m <=? o) ~ 'True

102+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) where

103+ type RecTape (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) = (Tape x i ('D1 m), RecTape y i ('D1 n))

104+

105+ runRecurrentForwards (ConcatRecRight x y) s input =

106+ let (xT, xOut :: S ('D1 m)) = runForwards x input

107+ (yT, side, yOut :: S ('D1 n)) = runRecurrentForwards y s input

108+ in case (xOut, yOut) of

109+ (S1D xOut', S1D yOut') ->

110+ ((xT, yT), side, S1D (xOut' # yOut'))

111+

112+ runRecurrentBackwards (ConcatRecRight x y) (xTape, yTape) s (S1D o) =

113+ let (ox :: R m , oy :: R n) = split o

114+ (x', xB :: S i) = runBackwards x xTape (S1D ox)

115+ (y', side, yB :: S i) = runRecurrentBackwards y yTape s (S1D oy)

116+ in ((x', y'), side, xB + yB)

117+

118+instance ( SingI i

119+ , RecurrentLayer x i ('D1 m)

120+ , Layer y i ('D1 n)

121+ , KnownNat o

122+ , KnownNat m

123+ , KnownNat n

124+ , o ~ (m + n)

125+ , n ~ (o - m)

126+ , (m <=? o) ~ 'True

127+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) where

128+ type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) = (RecTape x i ('D1 m), Tape y i ('D1 n))

129+

130+ runRecurrentForwards (ConcatRecLeft x y) s input =

131+ let (xT, side, xOut :: S ('D1 m)) = runRecurrentForwards x s input

132+ (yT, yOut :: S ('D1 n)) = runForwards y input

133+ in case (xOut, yOut) of

134+ (S1D xOut', S1D yOut') ->

135+ ((xT, yT), side, S1D (xOut' # yOut'))

136+

137+ runRecurrentBackwards (ConcatRecLeft x y) (xTape, yTape) s (S1D o) =

138+ let (ox :: R m , oy :: R n) = split o

139+ (x', side, xB :: S i) = runRecurrentBackwards x xTape s (S1D ox)

140+ (y', yB :: S i) = runBackwards y yTape (S1D oy)

141+ in ((x', y'), side, xB + yB)

142+

143+instance ( SingI i

144+ , RecurrentLayer x i ('D1 m)

145+ , RecurrentLayer y i ('D1 n)

146+ , Fractional (RecurrentShape x)

147+ , Fractional (RecurrentShape y)

148+ , KnownNat o

149+ , KnownNat m

150+ , KnownNat n

151+ , o ~ (m + n)

152+ , n ~ (o - m)

153+ , (m <=? o) ~ 'True

154+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) where

155+ type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) = (RecTape x i ('D1 m), RecTape y i ('D1 n))

156+

157+ runRecurrentForwards (ConcatRecBoth x y) (sx :~@+> (sy :~@+> RINil)) input =

158+ let (xT, s'x, xOut :: S ('D1 m)) = runRecurrentForwards x sx input

159+ (yT, s'y, yOut :: S ('D1 n)) = runRecurrentForwards y sy input

160+ in case (xOut, yOut) of

161+ (S1D xOut', S1D yOut') ->

162+ ((xT, yT), (s'x :~@+> (s'y :~@+> RINil)), S1D (xOut' # yOut'))

163+

164+ runRecurrentBackwards (ConcatRecBoth x y) (xTape, yTape) (sx :~@+> (sy :~@+> RINil)) (S1D o) =

165+ let (ox :: R m , oy :: R n) = split o

166+ (x', s'x, xB :: S i) = runRecurrentBackwards x xTape sx (S1D ox)

167+ (y', s'y, yB :: S i) = runRecurrentBackwards y yTape sy (S1D oy)

168+ in ((x', y'), (s'x :~@+> (s'y :~@+> RINil)), xB + yB)

169+

170+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (FeedForward a) sb (Recurrent b)) where

171+ put (ConcatRecRight a b) = put a *> put b

172+ get = ConcatRecRight <$> get <*> get

173+

174+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (Recurrent b)) where

175+ put (ConcatRecBoth a b) = put a *> put b

176+ get = ConcatRecBoth <$> get <*> get

177+

178+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (FeedForward b)) where

179+ put (ConcatRecLeft a b) = put a *> put b

180+ get = ConcatRecLeft <$> get <*> get

src/Grenade/Recurrent/Layers/LSTM.hs+57−80

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE BangPatterns #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE GADTs #-}

45{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE RecordWildCards #-}

66{-# LANGUAGE TypeOperators #-}

77{-# LANGUAGE TypeFamilies #-}

88{-# LANGUAGE MultiParamTypeClasses #-}

@@ -21,7 +21,7 @@ import Control.Monad.Random ( MonadRandom, getRandom )

2121-- import Data.List ( foldl1' )

2222import Data.Proxy

2323import Data.Serialize

24−import Data.Singletons.TypeLits

24+import Data.Kind (Type)

2525

2626import qualified Numeric.LinearAlgebra as LA

2727import Numeric.LinearAlgebra.Static

@@ -29,6 +29,7 @@ import Numeric.LinearAlgebra.Static

2929import Grenade.Core

3030import Grenade.Recurrent.Core

3131import Grenade.Layers.Internal.Update

32+import GHC.TypeLits

3233

3334

3435-- | Long Short Term Memory Recurrent unit

@@ -36,14 +37,14 @@ import Grenade.Layers.Internal.Update

3637-- This is a Peephole formulation, so the recurrent shape is

3738-- just the cell state, the previous output is not held or used

3839-- at all.

39−data LSTM :: Nat -> Nat -> * where

40+data LSTM :: Nat -> Nat -> Type where

4041 LSTM :: ( KnownNat input

4142 , KnownNat output

4243 ) => !(LSTMWeights input output) -- Weights

4344 -> !(LSTMWeights input output) -- Momentums

4445 -> LSTM input output

4546

46−data LSTMWeights :: Nat -> Nat -> * where

47+data LSTMWeights :: Nat -> Nat -> Type where

4748 LSTMWeights :: ( KnownNat input

4849 , KnownNat output

4950 ) => {

@@ -70,7 +71,7 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

7071

7172 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

7273 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

73− runUpdate LearningParameters {..} (LSTM w m) g =

74+ runUpdate lp (LSTM w m) g =

7475 let (wf, wf') = u lstmWf w m g

7576 (uf, uf') = u lstmUf w m g

7677 (bf, bf') = v lstmBf w m g

@@ -87,11 +88,11 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

8788 -- Utility function for updating with the momentum, gradients, and weights.

8889 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

8990 u e (e -> weights) (e -> momentum) (e -> gradient) =

90− decendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum

91+ descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

9192

9293 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

9394 v e (e -> weights) (e -> momentum) (e -> gradient) =

94− decendVector learningRate learningMomentum learningRegulariser weights gradient momentum

95+ descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

9596

9697 -- There's a lot of updates here, so to try and minimise the number of data copies

9798 -- we'll create a mutable bucket for each.

@@ -123,27 +124,33 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

123124instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

124125 -- The recurrent shape is the same size as the output.

125126 -- It's actually the cell state however, as this is a peephole variety LSTM.

126− type RecurrentShape (LSTM i o) = 'D1 o

127+ type RecurrentShape (LSTM i o) = S ('D1 o)

127128

128129instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

129130

130− type RecTape (LSTM i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))

131+ -- The tape stores essentially every variable we calculate,

132+ -- so we don't have to run any forwards component again.

133+ type RecTape (LSTM i o) ('D1 i) ('D1 o) = (R o, R i, R o, R o, R o, R o, R o, R o, R o, R o, R o)

131134 -- Forward propagation for the LSTM layer.

132135 -- The size of the cell state is also the size of the output.

133− runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =

136+ runRecurrentForwards (LSTM lw _) (S1D cell) (S1D input) =

134137 let -- Forget state vector

135− f_t = sigmoid $ lstmBf + lstmWf #> input + lstmUf #> cell

138+ f_s = lstmBf lw + lstmWf lw #> input + lstmUf lw #> cell

139+ f_t = sigmoid f_s

136140 -- Input state vector

137− i_t = sigmoid $ lstmBi + lstmWi #> input + lstmUi #> cell

141+ i_s = lstmBi lw + lstmWi lw #> input + lstmUi lw #> cell

142+ i_t = sigmoid i_s

138143 -- Output state vector

139− o_t = sigmoid $ lstmBo + lstmWo #> input + lstmUo #> cell

144+ o_s = lstmBo lw + lstmWo lw #> input + lstmUo lw #> cell

145+ o_t = sigmoid o_s

140146 -- Cell input state vector

141− c_x = tanh $ lstmBc + lstmWc #> input

147+ c_s = lstmBc lw + lstmWc lw #> input

148+ c_x = tanh c_s

142149 -- Cell state

143150 c_t = f_t * cell + i_t * c_x

144151 -- Output (it's sometimes recommended to use tanh c_t)

145152 h_t = o_t * c_t

146− in ((S1D cell, S1D input), S1D c_t, S1D h_t)

153+ in ((cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t), S1D c_t, S1D h_t)

147154

148155 -- Run a backpropogation step for an LSTM layer.

149156 -- We're doing all the derivatives by hand here, so one should

@@ -151,29 +158,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

151158 --

152159 -- There's a test version using the AD library without hmatrix in the test

153160 -- suite. These should match always.

154− runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (S1D cell, S1D input) (S1D cellGrad) (S1D h_t') =

155− -- We're not keeping the Wengert tape during the forward pass,

156− -- so we're duplicating some work here.

157− --

158− -- If I was being generous, I'd call it checkpointing.

159− --

160− -- Maybe think about better ways to store some intermediate states.

161− let -- Forget state vector

162− f_s = lstmBf + lstmWf #> input + lstmUf #> cell

163− f_t = sigmoid f_s

164− -- Input state vector

165− i_s = lstmBi + lstmWi #> input + lstmUi #> cell

166− i_t = sigmoid i_s

167− -- Output state vector

168− o_s = lstmBo + lstmWo #> input + lstmUo #> cell

169− o_t = sigmoid o_s

170− -- Cell input state vector

171− c_s = lstmBc + lstmWc #> input

172− c_x = tanh c_s

173− -- Cell state

174− c_t = f_t * cell + i_t * c_x

175−

176− -- Reverse Mode AD Derivitives

161+ runRecurrentBackwards (LSTM lw _) (cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t) (S1D cellGrad) (S1D h_t') =

162+ let -- Reverse Mode AD Derivitives

177163 c_t' = h_t' * o_t + cellGrad

178164

179165 f_t' = c_t' * cell

@@ -189,8 +175,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

189175 c_s' = tanh' c_s * c_x'

190176

191177 -- The derivatives to pass sideways (recurrent) and downwards

192− cell' = tr lstmUf #> f_s' + tr lstmUo #> o_s' + tr lstmUi #> i_s' + c_t' * f_t

193− input' = tr lstmWf #> f_s' + tr lstmWo #> o_s' + tr lstmWi #> i_s' + tr lstmWc #> c_s'

178+ cell' = tr (lstmUf lw) #> f_s' + tr (lstmUo lw) #> o_s' + tr (lstmUi lw) #> i_s' + c_t' * f_t

179+ input' = tr (lstmWf lw) #> f_s' + tr (lstmWo lw) #> o_s' + tr (lstmWi lw) #> i_s' + tr (lstmWc lw) #> c_s'

194180

195181 -- Calculate the gradient Matricies for the input

196182 lstmWf' = f_s' `outer` input

@@ -235,7 +221,8 @@ randomLSTM = do

235221

236222-- | Maths

237223--

238−-- TODO: move to not here

224+-- TODO: Move to not here

225+-- Optimise backwards derivative

239226sigmoid :: Floating a => a -> a

240227sigmoid x = 1 / (1 + exp (-x))

241228

@@ -248,44 +235,34 @@ tanh' :: (Floating a) => a -> a

248235tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

249236

250237instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

251− put (LSTM LSTMWeights {..} _) = do

252− u lstmWf

253− u lstmUf

254− v lstmBf

255− u lstmWi

256− u lstmUi

257− v lstmBi

258− u lstmWo

259− u lstmUo

260− v lstmBo

261− u lstmWc

262− v lstmBc

263− where

264− u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

265− u = putListOf put . LA.toList . LA.flatten . extract

266− v :: forall a. (KnownNat a) => Putter (R a)

267− v = putListOf put . LA.toList . extract

238+ put (LSTM lw _) = do

239+ u (lstmWf lw)

240+ u (lstmUf lw)

241+ v (lstmBf lw)

242+ u (lstmWi lw)

243+ u (lstmUi lw)

244+ v (lstmBi lw)

245+ u (lstmWo lw)

246+ u (lstmUo lw)

247+ v (lstmBo lw)

248+ u (lstmWc lw)

249+ v (lstmBc lw)

250+ where

251+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

252+ u = putListOf put . LA.toList . LA.flatten . extract

253+ v :: forall a. (KnownNat a) => Putter (R a)

254+ v = putListOf put . LA.toList . extract

268255

269256 get = do

270− lstmWf <- u

271− lstmUf <- u

272− lstmBf <- v

273− lstmWi <- u

274− lstmUi <- u

275− lstmBi <- v

276− lstmWo <- u

277− lstmUo <- u

278− lstmBo <- v

279− lstmWc <- u

280− lstmBc <- v

281− return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

282− where

283− u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

284− u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

285− in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

286− v :: forall a. (KnownNat a) => Get (R a)

287− v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

288−

289− w0 = konst 0

290− u0 = konst 0

291− v0 = konst 0

257+ w <- LSTMWeights <$> u <*> u <*> v <*> u <*> u <*> v <*> u <*> u <*> v <*> u <*> v

258+ return $ LSTM w (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

259+ where

260+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

261+ u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

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

263+ v :: forall a. (KnownNat a) => Get (R a)

264+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

265+

266+ w0 = konst 0

267+ u0 = konst 0

268+ v0 = konst 0

src/Grenade/Utils/OneHot.hs+6−5

@@ -22,7 +22,6 @@ import Data.Map ( Map )

2222import qualified Data.Map as M

2323

2424import Data.Proxy

25−import Data.Singletons.TypeLits

2625

2726import Data.Vector ( Vector )

2827import qualified Data.Vector as V

@@ -31,6 +30,7 @@ import qualified Data.Vector.Storable as VS

3130import Numeric.LinearAlgebra ( maxIndex )

3231import Numeric.LinearAlgebra.Devel

3332import Numeric.LinearAlgebra.Static

33+import GHC.TypeLits

3434

3535import Grenade.Core.Shape

3636

@@ -52,15 +52,16 @@ oneHot hot =

5252

5353-- | Create a one hot map from any enumerable.

5454-- Returns a map, and the ordered list for the reverse transformation

55−hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Maybe (Map a Int, Vector a)

55+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Either String (Map a Int, Vector a)

5656hotMap n as =

5757 let len = fromIntegral $ natVal n

5858 uniq = [ c | (c:_) <- group $ sort as]

5959 hotl = length uniq

60− in if hotl <= len

60+ in if hotl == len

6161 then

62− Just (M.fromList $ zip uniq [0..], V.fromList uniq)

63− else Nothing

62+ Right (M.fromList $ zip uniq [0..], V.fromList uniq)

63+ else

64+ Left ("Couldn't create hotMap of size " ++ show len ++ " from vector with " ++ show hotl ++ " unique characters")

6465

6566-- | From a map and value, create a 1D Shape

6667-- with one index hot (1) with the rest 0.

stack.yamlnew file+78

@@ -0,0 +1,78 @@

1+# This file was automatically generated by 'stack init'

2+#

3+# Some commonly used options have been documented as comments in this file.

4+# For advanced use and comprehensive documentation of the format, please see:

5+# https://docs.haskellstack.org/en/stable/yaml_configuration/

6+

7+# A warning or info to be displayed to the user on config load.

8+# user-message: |

9+

10+# Resolver to choose a 'specific' stackage snapshot or a compiler version.

11+# A snapshot resolver dictates the compiler version and the set of packages

12+# to be used for project dependencies. For example:

13+#

14+# resolver: lts-3.5

15+# resolver: nightly-2015-09-21

16+# resolver: ghc-7.10.2

17+#

18+# The location of a snapshot can be provided as a file or url. Stack assumes

19+# a snapshot provided as a file might change, whereas a url resource does not.

20+#

21+# resolver: ./custom-snapshot.yaml

22+# resolver: https://example.com/snapshots/2018-01-01.yaml

23+resolver: lts-20.18

24+

25+# User packages to be built.

26+# Various formats can be used as shown in the example below.

27+#

28+# packages:

29+# - some-directory

30+# - https://example.com/foo/bar/baz-0.0.2.tar.gz

31+# subdirs:

32+# - auto-update

33+# - wai

34+packages:

35+ - .

36+ - examples

37+

38+# Dependency packages to be pulled from upstream that are not in the resolver.

39+# These entries can reference officially published versions as well as

40+# forks / in-progress versions pinned to a git hash. For example:

41+#

42+# extra-deps:

43+# - acme-missiles-0.3

44+# - git: https://github.com/commercialhaskell/stack.git

45+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

46+#

47+extra-deps:

48+ - typelits-witnesses-0.3.0.3

49+

50+# Override default flag values for local packages and extra-deps

51+# flags: {}

52+

53+# Extra package databases containing global packages

54+# extra-package-dbs: []

55+

56+# Control whether we use the GHC we find on the path

57+# system-ghc: true

58+#

59+# Require a specific version of stack, using version ranges

60+# require-stack-version: -any # Default

61+# require-stack-version: ">=2.1"

62+#

63+# Override the architecture used by stack, especially useful on Windows

64+# arch: i386

65+# arch: x86_64

66+#

67+# Extra directories used by stack for building

68+# extra-include-dirs: [/path/to/dir]

69+# extra-lib-dirs: [/path/to/dir]

70+#

71+# Allow a newer minor version of GHC than the snapshot specifies

72+# compiler-check: newer-minor

73+

74+nix:

75+ enable: true

76+ packages:

77+ - blas

78+ - lapack

stack.yaml.locknew file+19

@@ -0,0 +1,19 @@

1+# This file was autogenerated by Stack.

2+# You should not edit this file by hand.

3+# For more information, please see the documentation at:

4+# https://docs.haskellstack.org/en/stable/lock_files

5+

6+packages:

7+- completed:

8+ hackage: typelits-witnesses-0.3.0.3@sha256:2d9df4ac6ff3077bfd2bf659e4b495e157723ac5b45c519762853f55df5c16db,2738

9+ pantry-tree:

10+ sha256: 6a42a462f98e94933b6e9721acd912c6c6b6a4743635efd15cc5871908c816a0

11+ size: 469

12+ original:

13+ hackage: typelits-witnesses-0.3.0.3

14+snapshots:

15+- completed:

16+ sha256: 9fa4bece7acfac1fc7930c5d6e24606004b09e80aa0e52e9f68b148201008db9

17+ size: 649606

18+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/18.yaml

19+ original: lts-20.18

test/Test/Grenade/Layers/Convolution.hs+29−24

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE TemplateHaskell #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE GADTs #-}

@@ -15,15 +16,21 @@ import Data.Singletons ()

1516import GHC.TypeLits

1617import GHC.TypeLits.Witnesses

1718

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

20+import Data.Kind (Type)

21+#endif

22+

1823import Grenade.Core

1924import Grenade.Layers.Convolution

2025

21−import Disorder.Jack

26+import Hedgehog

27+import qualified Hedgehog.Gen as Gen

2228

23−import Test.Jack.Hmatrix

24−import Test.Jack.TypeLits

29+import Test.Hedgehog.Hmatrix

30+import Test.Hedgehog.TypeLits

31+import Test.Hedgehog.Compat

2532

26−data OpaqueConvolution :: * where

33+data OpaqueConvolution :: Type where

2734 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution

2835

2936instance Show OpaqueConvolution where

@@ -37,10 +44,10 @@ genConvolution :: ( KnownNat channels

3744 , KnownNat strideColumns

3845 , KnownNat kernelFlattened

3946 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

40− ) => Jack (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

47+ ) => Gen (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

4148genConvolution = Convolution <$> uniformSample <*> uniformSample

4249

43−genOpaqueOpaqueConvolution :: Jack OpaqueConvolution

50+genOpaqueOpaqueConvolution :: Gen OpaqueConvolution

4451genOpaqueOpaqueConvolution = do

4552 channels <- genNat

4653 filters <- genNat

@@ -56,17 +63,17 @@ genOpaqueOpaqueConvolution = do

5663 p2 = natDict pkc

5764 p3 = natDict pch

5865 in case p1 %* p2 %* p3 of

59− Dict -> OpaqueConvolution <$> (genConvolution :: Jack (Convolution ch fl kr kc sr sc))

66+ Dict -> OpaqueConvolution <$> (genConvolution :: Gen (Convolution ch fl kr kc sr sc))

67+

68+prop_conv_net_witness = property $

69+ blindForAll genOpaqueOpaqueConvolution >>= \onet ->

70+ case onet of

71+ (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> success

6072

61−prop_conv_net_witness =

62− gamble genOpaqueOpaqueConvolution $ \onet ->

63− (case onet of

64− (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> True

65− ) :: Bool

6673

67−prop_conv_net =

68− gamble genOpaqueOpaqueConvolution $ \onet ->

69− (case onet of

74+prop_conv_net = property $

75+ blindForAll genOpaqueOpaqueConvolution >>= \onet ->

76+ case onet of

7077 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->

7178 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]

7279 kr = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

@@ -74,15 +81,15 @@ prop_conv_net =

7481 sr = fromIntegral $ natVal (Proxy :: Proxy strideRows)

7582 sc = fromIntegral $ natVal (Proxy :: Proxy strideCols)

7683

77− in gamble (elements (ok sr kr)) $ \er ->

78− gamble (elements (ok sc kc)) $ \ec ->

84+ in forAll (Gen.element (ok sr kr)) >>= \er ->

85+ forAll (Gen.element (ok sc kc)) >>= \ec ->

7986 let rr = ((er - kr) `div` sr) + 1

8087 rc = ((ec - kc) `div` sc) + 1

8188 Just er' = someNatVal er

8289 Just ec' = someNatVal ec

8390 Just rr' = someNatVal rr

8491 Just rc' = someNatVal rc

85− in (case (er', ec', rr', rc') of

92+ in case (er', ec', rr', rc') of

8693 ( SomeNat (pinr :: Proxy inRows), SomeNat (_ :: Proxy inCols), SomeNat (pour :: Proxy outRows), SomeNat (_ :: Proxy outCols)) ->

8794 case ( natDict pinr %* natDict (Proxy :: Proxy channels)

8895 , natDict pour %* natDict (Proxy :: Proxy filters)

@@ -90,14 +97,12 @@ prop_conv_net =

9097 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

9198 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

9299 (Dict, Dict, Dict, Dict) ->

93− gamble (S3D <$> uniformSample) $ \(input :: S ('D3 inRows inCols channels)) ->

100+ blindForAll (S3D <$> uniformSample) >>= \(input :: S ('D3 inRows inCols channels)) ->

94101 let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input

95102 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))

96103 = runBackwards convLayer tape output

97− in backed `seq` True

98− ) :: Property

99− ) :: Property

104+ in backed `seq` success

105+

100106

101−return []

102107tests :: IO Bool

103−tests = $quickCheckAll

108+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/FullyConnected.hs+21−17

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE BangPatterns #-}

23{-# LANGUAGE TemplateHaskell #-}

34{-# LANGUAGE DataKinds #-}

@@ -12,24 +13,28 @@ import Data.Singletons ()

1213

1314import GHC.TypeLits

1415

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

17+import Data.Kind (Type)

18+#endif

19+

1520import Grenade.Core

1621import Grenade.Layers.FullyConnected

1722

18−import Disorder.Jack

19−

20−import Test.Jack.Hmatrix

23+import Hedgehog

2124

25+import Test.Hedgehog.Compat

26+import Test.Hedgehog.Hmatrix

2227

23−data OpaqueFullyConnected :: * where

28+data OpaqueFullyConnected :: Type where

2429 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected

2530

2631instance Show OpaqueFullyConnected where

2732 show (OpaqueFullyConnected n) = show n

2833

29−genOpaqueFullyConnected :: Jack OpaqueFullyConnected

34+genOpaqueFullyConnected :: Gen OpaqueFullyConnected

3035genOpaqueFullyConnected = do

31− input :: Integer <- choose (2, 100)

32− output :: Integer <- choose (1, 100)

36+ input :: Integer <- choose 2 100

37+ output :: Integer <- choose 1 100

3338 let Just input' = someNatVal input

3439 let Just output' = someNatVal output

3540 case (input', output') of

@@ -41,14 +46,13 @@ genOpaqueFullyConnected = do

4146 return . OpaqueFullyConnected $ (FullyConnected (FullyConnected' wB wN) (FullyConnected' bM kM) :: FullyConnected i' o')

4247

4348prop_fully_connected_forwards :: Property

44−prop_fully_connected_forwards =

45− gamble genOpaqueFullyConnected $ \(OpaqueFullyConnected (fclayer :: FullyConnected i o)) ->

46− gamble (S1D <$> randomVector) $ \(input :: S ('D1 i)) ->

47− let (tape, output :: S ('D1 o)) = runForwards fclayer input

48− backed :: (Gradient (FullyConnected i o), S ('D1 i))

49− = runBackwards fclayer tape output

50− in backed `seq` True

51−

52−return []

49+prop_fully_connected_forwards = property $ do

50+ OpaqueFullyConnected (fclayer :: FullyConnected i o) <- blindForAll genOpaqueFullyConnected

51+ input :: S ('D1 i) <- blindForAll (S1D <$> randomVector)

52+ let (tape, output :: S ('D1 o)) = runForwards fclayer input

53+ backed :: (Gradient (FullyConnected i o), S ('D1 i))

54+ = runBackwards fclayer tape output

55+ backed `seq` success

56+

5357tests :: IO Bool

54−tests = $quickCheckAll

58+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Internal/Convolution.hs+34−29

@@ -12,41 +12,46 @@ import Grenade.Layers.Internal.Convolution

1212

1313import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

1414

15−import Disorder.Jack

15+import Hedgehog

16+import qualified Hedgehog.Gen as Gen

17+import qualified Hedgehog.Range as Range

1618

1719import qualified Test.Grenade.Layers.Internal.Reference as Reference

20+import Test.Hedgehog.Compat

1821

1922prop_im2col_col2im_symmetrical_with_kernel_stride =

2023 let factors n = [x | x <- [1..n], n `mod` x == 0]

21− in gamble (choose (2, 100)) $ \height ->

22− gamble (choose (2, 100)) $ \width ->

23− gamble ((height `div`) <$> elements (factors height)) $ \kernel_h ->

24− gamble ((width `div`) <$> elements (factors width)) $ \kernel_w ->

25− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

26− let input' = (height >< width) input

27− stride_h = kernel_h

28− stride_w = kernel_w

29− out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input'

30− in input' === out

24+ in property $ do

25+ height <- forAll $ choose 2 100

26+ width <- forAll $ choose 2 100

27+ kernel_h <- forAll $ (height `div`) <$> Gen.element (factors height)

28+ kernel_w <- forAll $ (width `div`) <$> Gen.element (factors width)

29+ input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

30+

31+ let stride_h = kernel_h

32+ let stride_w = kernel_w

33+ let out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input

34+ input === out

3135

3236prop_im2col_col2im_behaves_as_reference =

3337 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

34− in gamble (choose (2, 100)) $ \height ->

35− gamble (choose (2, 100)) $ \width ->

36− gamble (choose (2, height - 1)) $ \kernel_h ->

37− gamble (choose (2, width - 1)) $ \kernel_w ->

38− gamble (elements (ok height kernel_h)) $ \stride_h ->

39− gamble (elements (ok width kernel_w)) $ \stride_w ->

40− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

41− let input' = (height >< width) input

42− outFast = im2col kernel_h kernel_w stride_h stride_w input'

43− retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast

44−

45− outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input'

46− retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference

47− in outFast === outReference .&&. retFast === retReference

48−

49−

50−return []

38+ in property $ do

39+ height <- forAll (choose 2 100)

40+ width <- forAll (choose 2 100)

41+ kernel_h <- forAll (choose 2 (height - 1))

42+ kernel_w <- forAll (choose 2 (width - 1))

43+ stride_h <- forAll (Gen.element (ok height kernel_h))

44+ stride_w <- forAll (Gen.element (ok width kernel_w))

45+ input <- forAll ((height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100))

46+

47+ let outFast = im2col kernel_h kernel_w stride_h stride_w input

48+ let retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast

49+

50+ let outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input

51+ let retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference

52+

53+ outFast === outReference

54+ retFast === retReference

55+

5156tests :: IO Bool

52−tests = $quickCheckAll

57+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Internal/Pooling.hs+24−18

@@ -12,28 +12,34 @@ import Grenade.Layers.Internal.Pooling

1212

1313import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

1414

15−import Disorder.Jack

15+import Hedgehog

16+import qualified Hedgehog.Gen as Gen

17+import qualified Hedgehog.Range as Range

1618

1719import qualified Test.Grenade.Layers.Internal.Reference as Reference

20+import Test.Hedgehog.Compat

1821

1922prop_poolForwards_poolBackwards_behaves_as_reference =

2023 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

2124 output extent kernel stride = (extent - kernel) `div` stride + 1

22− in gamble (choose (2, 100)) $ \height ->

23− gamble (choose (2, 100)) $ \width ->

24− gamble (choose (1, height - 1)) $ \kernel_h ->

25− gamble (choose (1, width - 1)) $ \kernel_w ->

26− gamble (elements (ok height kernel_h)) $ \stride_h ->

27− gamble (elements (ok width kernel_w)) $ \stride_w ->

28− gamble (listOfN (height * width) (height * width) sizedRealFrac) $ \input ->

29− let input' = (height >< width) input

30− outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'

31− retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast

32−

33− outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input'

34− retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference

35− in outFast === outReference .&&. retFast === retReference

36−

37−return []

25+ in property $ do

26+ height <- forAll $ choose 2 100

27+ width <- forAll $ choose 2 100

28+ kernel_h <- forAll $ choose 1 (height - 1)

29+ kernel_w <- forAll $ choose 1 (width - 1)

30+ stride_h <- forAll $ Gen.element (ok height kernel_h)

31+ stride_w <- forAll $ Gen.element (ok width kernel_w)

32+ input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

33+

34+ let outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input

35+ let retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input outFast

36+

37+ let outReference = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input

38+ let retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input outReference

39+

40+ outFast === outReference

41+ retFast === retReference

42+

43+

3844tests :: IO Bool

39−tests = $quickCheckAll

45+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Nonlinear.hs+13−36

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

32{-# LANGUAGE TemplateHaskell #-}

43{-# LANGUAGE DataKinds #-}

54{-# LANGUAGE KindSignatures #-}

@@ -11,67 +10,45 @@ module Test.Grenade.Layers.Nonlinear where

1110

1211import Data.Singletons

1312

14−#if __GLASGOW_HASKELL__ < 800

15−import Data.Proxy

16−#endif

17−

1813import Grenade

19−import GHC.TypeLits

2014

21−import Disorder.Jack

15+import Hedgehog

2216

23−import Test.Jack.Hmatrix

24−import Test.Jack.TypeLits

17+import Test.Hedgehog.Compat

18+import Test.Hedgehog.Hmatrix

19+import Test.Hedgehog.TypeLits

2520

2621import Numeric.LinearAlgebra.Static ( norm_Inf )

2722

2823prop_sigmoid_grad :: Property

29−prop_sigmoid_grad =

30− gambleDisplay (const "Shape") genShape $ \case

24+prop_sigmoid_grad = property $

25+ forAllWith rss genShape >>= \case

3126 (SomeSing (r :: Sing s)) ->

3227 withSingI r $

33− gamble genOfShape $ \(ds :: S s) ->

28+ blindForAll genOfShape >>= \(ds :: S s) ->

3429 let (tape, f :: S s) = runForwards Logit ds

3530 ((), ret :: S s) = runBackwards Logit tape (1 :: S s)

3631 (_, numer :: S s) = runForwards Logit (ds + 0.0001)

3732 numericalGradient = (numer - f) * 10000

38− in counterexample (show numericalGradient ++ show ret)

39− ((case numericalGradient - ret of

33+ in assert ((case numericalGradient - ret of

4034 (S1D x) -> norm_Inf x < 0.0001

4135 (S2D x) -> norm_Inf x < 0.0001

4236 (S3D x) -> norm_Inf x < 0.0001) :: Bool)

4337

4438prop_tanh_grad :: Property

45−prop_tanh_grad =

46− gambleDisplay (const "Shape") genShape $ \case

39+prop_tanh_grad = property $

40+ forAllWith rss genShape >>= \case

4741 (SomeSing (r :: Sing s)) ->

4842 withSingI r $

49− gamble genOfShape $ \(ds :: S s) ->

43+ blindForAll genOfShape >>= \(ds :: S s) ->

5044 let (tape, f :: S s) = runForwards Tanh ds

5145 ((), ret :: S s) = runBackwards Tanh tape (1 :: S s)

5246 (_, numer :: S s) = runForwards Tanh (ds + 0.0001)

5347 numericalGradient = (numer - f) * 10000

54− in counterexample (show numericalGradient ++ show ret)

55− ((case numericalGradient - ret of

48+ in assert ((case numericalGradient - ret of

5649 (S1D x) -> norm_Inf x < 0.001

5750 (S2D x) -> norm_Inf x < 0.001

5851 (S3D x) -> norm_Inf x < 0.001) :: Bool)

5952

60−prop_softmax_grad :: Property

61−prop_softmax_grad =

62− gamble genNat $ \case

63− (SomeNat (_ :: Proxy s)) ->

64− gamble genOfShape $ \(ds :: S ('D1 s)) ->

65− let (tape, f :: S ('D1 s)) = runForwards Relu ds

66− ((), ret :: S ('D1 s)) = runBackwards Relu tape (1 :: S ('D1 s))

67− (_, numer :: S ('D1 s)) = runForwards Relu (ds + 0.0001)

68− numericalGradient = (numer - f) * 10000

69− in counterexample (show numericalGradient ++ show ret)

70− ((case numericalGradient - ret of

71− (S1D x) -> norm_Inf x < 0.0001) :: Bool)

72−

73−

74−return []

7553tests :: IO Bool

76−tests = $quickCheckAll

77−

54+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/PadCrop.hs+12−12

@@ -7,43 +7,43 @@

77{-# LANGUAGE ScopedTypeVariables #-}

88{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

99

10−#if __GLASGOW_HASKELL__ < 800

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

12−#endif

13−

1410module Test.Grenade.Layers.PadCrop where

1511

1612import Grenade

1713

18−import Disorder.Jack

14+import Hedgehog

1915

2016import Numeric.LinearAlgebra.Static ( norm_Inf )

2117

22−import Test.Jack.Hmatrix

18+import Test.Hedgehog.Hmatrix

2319

2420prop_pad_crop :: Property

2521prop_pad_crop =

2622 let net :: Network '[Pad 2 3 4 6, Crop 2 3 4 6] '[ 'D3 7 9 5, 'D3 16 15 5, 'D3 7 9 5 ]

2723 net = Pad :~> Crop :~> NNil

28− in gamble genOfShape $ \(d :: S ('D3 7 9 5)) ->

24+ in property $

25+ forAll genOfShape >>= \(d :: S ('D3 7 9 5)) ->

2926 let (tapes, res) = runForwards net d

3027 (_ , grad) = runBackwards net tapes d

31− in d ~~~ res .&&. grad ~~~ d

28+ in do assert $ d ~~~ res

29+ assert $ grad ~~~ d

3230

3331prop_pad_crop_2d :: Property

3432prop_pad_crop_2d =

3533 let net :: Network '[Pad 2 3 4 6, Crop 2 3 4 6] '[ 'D2 7 9, 'D2 16 15, 'D2 7 9 ]

3634 net = Pad :~> Crop :~> NNil

37− in gamble genOfShape $ \(d :: S ('D2 7 9)) ->

35+ in property $

36+ forAll genOfShape >>= \(d :: S ('D2 7 9)) ->

3837 let (tapes, res) = runForwards net d

3938 (_ , grad) = runBackwards net tapes d

40− in d ~~~ res .&&. grad ~~~ d

39+ in do assert $ d ~~~ res

40+ assert $ grad ~~~ d

4141

4242(~~~) :: S x -> S x -> Bool

4343(S1D x) ~~~ (S1D y) = norm_Inf (x - y) < 0.00001

4444(S2D x) ~~~ (S2D y) = norm_Inf (x - y) < 0.00001

4545(S3D x) ~~~ (S3D y) = norm_Inf (x - y) < 0.00001

4646

47−return []

47+

4848tests :: IO Bool

49−tests = $quickCheckAll

49+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Pooling.hs+19−14

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE TemplateHaskell #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE KindSignatures #-}

@@ -9,36 +10,40 @@ module Test.Grenade.Layers.Pooling where

910import Data.Proxy

1011import Data.Singletons ()

1112

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

14+import Data.Kind (Type)

15+#endif

16+

1217import GHC.TypeLits

1318import Grenade.Layers.Pooling

1419

15−import Disorder.Jack

20+import Hedgehog

1621

22+import Test.Hedgehog.Compat

1723

18−data OpaquePooling :: * where

24+data OpaquePooling :: Type where

1925 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

2026

2127instance Show OpaquePooling where

2228 show (OpaquePooling n) = show n

2329

24−genOpaquePooling :: Jack OpaquePooling

30+genOpaquePooling :: Gen OpaquePooling

2531genOpaquePooling = do

26− Just kernelHeight <- someNatVal <$> choose (2, 15)

27− Just kernelWidth <- someNatVal <$> choose (2, 15)

28− Just strideHeight <- someNatVal <$> choose (2, 15)

29− Just strideWidth <- someNatVal <$> choose (2, 15)

32+ ~(Just kernelHeight) <- someNatVal <$> choose 2 15

33+ ~(Just kernelWidth ) <- someNatVal <$> choose 2 15

34+ ~(Just strideHeight) <- someNatVal <$> choose 2 15

35+ ~(Just strideWidth ) <- someNatVal <$> choose 2 15

3036

3137 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

3238 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

3339 return $ OpaquePooling (Pooling :: Pooling kh kw sh sw)

3440

3541prop_pool_layer_witness =

36− gamble genOpaquePooling $ \onet ->

37− (case onet of

38− (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) -> True

39− ) :: Bool

40−

42+ property $ do

43+ onet <- forAll genOpaquePooling

44+ case onet of

45+ (OpaquePooling (Pooling :: Pooling kernelRows kernelCols strideRows strideCols)) ->

46+ assert True

4147

42−return []

4348tests :: IO Bool

44−tests = $quickCheckAll

49+tests = checkParallel $$(discover)

test/Test/Grenade/Network.hsnew file+504

@@ -0,0 +1,504 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE DataKinds #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE TypeOperators #-}

9+{-# LANGUAGE TemplateHaskell #-}

10+{-# LANGUAGE FlexibleContexts #-}

11+module Test.Grenade.Network where

12+

13+import Control.Monad ( guard )

14+import Control.Monad.ST ( runST )

15+

16+import Data.Constraint

17+import qualified Data.Vector.Storable as VS

18+import qualified Data.Vector.Storable.Mutable as VS ( write )

19+import Data.Singletons

20+import Data.Singletons.Prelude.List

21+import Data.Singletons.TypeLits

22+

23+import Hedgehog

24+import qualified Hedgehog.Gen as Gen

25+import Hedgehog.Internal.Source

26+import Hedgehog.Internal.Property ( failWith )

27+

28+import Grenade

29+

30+#if MIN_VERSION_base(4,11,0)

31+import GHC.TypeLits hiding (natVal)

32+#else

33+import GHC.TypeLits

34+#endif

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

36+import Data.Kind (Type)

37+#endif

38+

39+import GHC.TypeLits.Witnesses

40+import Test.Hedgehog.Compat

41+import Test.Hedgehog.TypeLits

42+import Test.Hedgehog.Hmatrix

43+import Test.Grenade.Layers.Convolution

44+

45+import Numeric.LinearAlgebra ( flatten )

46+import Numeric.LinearAlgebra.Static ( extract, norm_Inf )

47+import Unsafe.Coerce

48+

49+data SomeNetwork :: Type where

50+ SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork

51+

52+instance Show SomeNetwork where

53+ show (SomeNetwork net) = show net

54+

55+-- | Generate a random network of a random type

56+--

57+-- This is slightly insane for a few reasons. Everything must be wrapped up

58+-- in a SomeNetwork.

59+genNetwork :: Gen SomeNetwork

60+genNetwork =

61+ Gen.recursive Gen.choice [

62+ do SomeSing ( r :: Sing final ) <- genShape

63+ withSingI r $

64+ pure (SomeNetwork (NNil :: Network '[] '[ final ] ))

65+ ] [

66+ do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork

67+ case ( sing :: Sing shapes ) of

68+ SNil -> Gen.discard -- Can't occur

69+ SCons ( h :: Sing h ) ( _ :: Sing hs ) ->

70+ withSingI h $

71+ case h of

72+ D1Sing l@SNat ->

73+ Gen.choice [

74+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

75+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

76+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

77+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

78+ , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))

79+ , do -- Reshape to two dimensions

80+ let divisors :: Integer -> [Integer]

81+ divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]

82+ let len = fromIntegral $ natVal l

83+ rs <- Gen.element $ divisors len

84+ let cs = len `quot` rs

85+ case ( someNatVal rs, someNatVal cs, someNatVal len ) of

86+ ( Just (SomeNat (rs' :: Proxy inRows)), Just (SomeNat (cs' :: Proxy inCols)), Just (SomeNat (_ :: Proxy outLen ) )) ->

87+ let p1 = natDict rs'

88+ p2 = natDict cs'

89+ in case ( p1 %* p2, unsafeCoerce (Dict :: Dict ()) :: Dict ((inRows * inCols) ~ outLen), unsafeCoerce (Dict :: Dict ()) :: Dict (( 'D1 outLen ) ~ h )) of

90+ ( Dict, Dict, Dict ) ->

91+ pure (SomeNetwork (Reshape :~> rest :: Network ( Reshape ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

92+ _ -> Gen.discard -- Doesn't occur

93+ ]

94+ D2Sing r@SNat c@SNat ->

95+ Gen.choice [

96+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

97+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

98+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

99+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

100+ , do -- Build a convolution layer with one filter output

101+ -- Figure out some kernel sizes which work for this layer

102+ -- There must be a better way than this...

103+ let output_r = fromIntegral $ natVal r

104+ let output_c = fromIntegral $ natVal c

105+

106+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

107+

108+ -- Get some kernels which will fit

109+ kernel_r <- choose 1 output_r

110+ kernel_c <- choose 1 output_c

111+

112+ -- Build up some strides which also fit

113+ stride_r <- Gen.element $ ok output_r kernel_r

114+ stride_c <- Gen.element $ ok output_c kernel_c

115+

116+ -- Determine the input size

117+ let input_r = (output_r - 1) * stride_r + kernel_r

118+ let input_c = (output_c - 1) * stride_c + kernel_c

119+

120+ guard (input_r < 100)

121+ guard (input_c < 100)

122+

123+ -- Remake types for input

124+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

125+ ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

126+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

127+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

128+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

129+ let p1 = natDict pkr

130+ p2 = natDict pkc

131+ in case ( p1 %* p2

132+ -- Fake it till you make it.

133+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))

134+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

135+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

136+ (Dict, Dict, Dict, Dict) -> do

137+ conv <- genConvolution

138+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution 1 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

139+ _ -> Gen.discard -- Can't occur

140+ , do -- Build a convolution layer with one filter output

141+ -- Figure out some kernel sizes which work for this layer

142+ -- There must be a better way than this...

143+ let output_r = fromIntegral $ natVal r

144+ let output_c = fromIntegral $ natVal c

145+

146+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

147+

148+ -- Get some kernels which will fit

149+ kernel_r <- choose 1 output_r

150+ kernel_c <- choose 1 output_c

151+ channels <- choose 1 10

152+

153+ -- Build up some strides which also fit

154+ stride_r <- Gen.element $ ok output_r kernel_r

155+ stride_c <- Gen.element $ ok output_c kernel_c

156+

157+ -- Determine the input size

158+ let input_r = (output_r - 1) * stride_r + kernel_r

159+ let input_c = (output_c - 1) * stride_c + kernel_c

160+

161+ guard (input_r < 100)

162+ guard (input_c < 100)

163+

164+ -- Remake types for input

165+ case ( someNatVal channels, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

166+ ( Just (SomeNat (chan :: Proxy channels)),

167+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

168+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

169+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

170+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

171+ let p1 = natDict pkr

172+ p2 = natDict pkc

173+ p3 = natDict chan

174+ in case ( p1 %* p2 %* p3

175+ , natDict pinr %* natDict chan

176+ -- Fake it till you make it.

177+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))

178+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

179+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

180+ (Dict, Dict, Dict, Dict, Dict) -> do

181+ conv <- genConvolution

182+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

183+ _ -> Gen.discard -- Can't occur

184+ , do -- Build a Pooling layer

185+ let output_r = fromIntegral $ natVal r

186+ let output_c = fromIntegral $ natVal c

187+

188+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

189+

190+ -- Get some kernels which will fit

191+ kernel_r <- choose 1 output_r

192+ kernel_c <- choose 1 output_c

193+

194+ -- Build up some strides which also fit

195+ stride_r <- Gen.element $ ok output_r kernel_r

196+ stride_c <- Gen.element $ ok output_c kernel_c

197+

198+ -- Determine the input size

199+ let input_r = (output_r - 1) * stride_r + kernel_r

200+ let input_c = (output_c - 1) * stride_c + kernel_c

201+

202+ guard (input_r < 100)

203+ guard (input_c < 100)

204+

205+ -- Remake types for input

206+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

207+ ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

208+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

209+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

210+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

211+ let p1 = natDict pkr

212+ p2 = natDict pkc

213+ in case ( p1 %* p2

214+ -- Fake it till you make it.

215+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))

216+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

217+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

218+ (Dict, Dict, Dict, Dict) ->

219+ pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

220+ _ -> Gen.discard -- Can't occur

221+ , do -- Build a Pad layer

222+ let output_r = fromIntegral $ natVal r

223+ let output_c = fromIntegral $ natVal c

224+

225+ pad_left <- choose 0 (output_r - 1)

226+ pad_right <- choose 0 (output_r - 1 - pad_left)

227+ pad_top <- choose 0 (output_c - 1)

228+ pad_bottom <- choose 0 (output_c - 1 - pad_top)

229+

230+ let input_r = output_r - pad_top - pad_bottom

231+ let input_c = output_c - pad_left - pad_right

232+

233+ guard (input_r > 1)

234+ guard (input_c > 1)

235+

236+ -- Remake types for input

237+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal pad_left, someNatVal pad_right, someNatVal pad_top, someNatVal pad_bottom ) of

238+ ( Just (SomeNat (_ :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

239+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

240+ Just (SomeNat (_ :: Proxy padLeft)), Just (SomeNat (_ :: Proxy padRight)),

241+ Just (SomeNat (_ :: Proxy padTop)), Just (SomeNat (_ :: Proxy padBottom))) ->

242+ case ( (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outputRows outputColumns) ~ h ))

243+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputRows + padTop + padBottom) ~ outputRows) )

244+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputColumns + padLeft + padRight) ~ outputColumns ))) of

245+ ( Dict, Dict, Dict ) ->

246+ pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D2 inputRows inputColumns) ': h ': hs )))

247+ _ -> Gen.discard -- Can't occur

248+ , do -- Build a Crop layer

249+ let output_r = fromIntegral $ natVal r

250+ let output_c = fromIntegral $ natVal c

251+

252+ crop_left <- choose 0 10

253+ crop_right <- choose 0 10

254+ crop_top <- choose 0 10

255+ crop_bottom <- choose 0 10

256+

257+ let input_r = output_r + crop_top + crop_bottom

258+ let input_c = output_c + crop_left + crop_right

259+

260+ -- Remake types for input

261+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal crop_left, someNatVal crop_right, someNatVal crop_top, someNatVal crop_bottom ) of

262+ ( Just (SomeNat (_ :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

263+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

264+ Just (SomeNat (_ :: Proxy cropLeft)), Just (SomeNat (_ :: Proxy cropRight)),

265+ Just (SomeNat (_ :: Proxy cropTop)), Just (SomeNat (_ :: Proxy cropBottom))) ->

266+ case ( (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outputRows outputColumns) ~ h ))

267+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputRows + cropTop + cropBottom) ~ inputRows ) )

268+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputColumns + cropLeft + cropRight) ~ inputColumns ))) of

269+ (Dict, Dict, Dict) ->

270+ pure (SomeNetwork (Crop :~> rest :: Network ( Crop cropLeft cropTop cropRight cropBottom ': layers ) ( ('D2 inputRows inputColumns) ': h ': hs )))

271+ _ -> Gen.discard -- Can't occur

272+ ]

273+ D3Sing r@SNat c@SNat f@SNat ->

274+ Gen.choice [

275+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

276+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

277+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

278+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

279+ , do -- Build a convolution layer with one filter output

280+ -- Figure out some kernel sizes which work for this layer

281+ -- There must be a better way than this...

282+ let output_r = fromIntegral $ natVal r

283+ let output_c = fromIntegral $ natVal c

284+ let output_f = fromIntegral $ natVal f

285+

286+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

287+

288+ -- Get some kernels which will fit

289+ kernel_r <- choose 1 output_r

290+ kernel_c <- choose 1 output_c

291+ channels <- choose 1 10

292+

293+ -- Build up some strides which also fit

294+ stride_r <- Gen.element $ ok output_r kernel_r

295+ stride_c <- Gen.element $ ok output_c kernel_c

296+

297+ -- Determine the input size

298+ let input_r = (output_r - 1) * stride_r + kernel_r

299+ let input_c = (output_c - 1) * stride_c + kernel_c

300+

301+ guard (input_r < 100)

302+ guard (input_c < 100)

303+

304+ -- Remake types for input

305+ case ( someNatVal channels, someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

306+ ( Just (SomeNat (chan :: Proxy channels)), Just (SomeNat (_ :: Proxy filters)),

307+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

308+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

309+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

310+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

311+ let p1 = natDict pkr

312+ p2 = natDict pkc

313+ p3 = natDict chan

314+ in case ( p1 %* p2 %* p3

315+ , natDict pinr %* natDict chan

316+ -- Fake it till you make it.

317+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outRows outCols filters) ~ h ))

318+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

319+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

320+ (Dict, Dict, Dict, Dict, Dict) -> do

321+ conv <- genConvolution

322+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels filters kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

323+ _ -> Gen.discard -- Can't occur

324+ , do -- Build a Pooling layer

325+ let output_r = fromIntegral $ natVal r

326+ let output_c = fromIntegral $ natVal c

327+ let output_f = fromIntegral $ natVal f

328+

329+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

330+

331+ -- Get some kernels which will fit

332+ kernel_r <- choose 1 output_r

333+ kernel_c <- choose 1 output_c

334+

335+ -- Build up some strides which also fit

336+ stride_r <- Gen.element $ ok output_r kernel_r

337+ stride_c <- Gen.element $ ok output_c kernel_c

338+

339+ -- Determine the input size

340+ let input_r = (output_r - 1) * stride_r + kernel_r

341+ let input_c = (output_c - 1) * stride_c + kernel_c

342+

343+ guard (input_r < 100)

344+ guard (input_c < 100)

345+

346+ -- Remake types for input

347+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

348+ ( Just (SomeNat (chan :: Proxy filters)),

349+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

350+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

351+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

352+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

353+ let p1 = natDict pkr

354+ p2 = natDict pkc

355+ p3 = natDict chan

356+ in case ( p1 %* p2 %* p3

357+ , natDict pinr %* natDict chan

358+ -- Fake it till you make it.

359+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outRows outCols filters) ~ h ))

360+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

361+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

362+ (Dict, Dict, Dict, Dict, Dict) ->

363+ pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols filters) ': h ': hs )))

364+ _ -> Gen.discard -- Can't occur

365+ , do -- Build a Pad layer

366+ let output_r = fromIntegral $ natVal r

367+ let output_c = fromIntegral $ natVal c

368+ let output_f = fromIntegral $ natVal f

369+

370+ pad_left <- choose 0 (output_r - 1)

371+ pad_right <- choose 0 (output_r - 1 - pad_left)

372+ pad_top <- choose 0 (output_c - 1)

373+ pad_bottom <- choose 0 (output_c - 1 - pad_top)

374+

375+ let input_r = output_r - pad_top - pad_bottom

376+ let input_c = output_c - pad_left - pad_right

377+

378+ guard (input_r > 1)

379+ guard (input_c > 1)

380+

381+ -- Remake types for input

382+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal pad_left, someNatVal pad_right, someNatVal pad_top, someNatVal pad_bottom ) of

383+ ( Just (SomeNat (chan :: Proxy filters)),

384+ Just (SomeNat (pinr :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

385+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

386+ Just (SomeNat (_ :: Proxy padLeft)), Just (SomeNat (_ :: Proxy padRight)),

387+ Just (SomeNat (_ :: Proxy padTop)), Just (SomeNat (_ :: Proxy padBottom))) ->

388+ case ( natDict pinr %* natDict chan

389+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outputRows outputColumns filters) ~ h ))

390+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputRows + padTop + padBottom) ~ outputRows) )

391+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputColumns + padLeft + padRight) ~ outputColumns ))) of

392+ (Dict, Dict, Dict, Dict) ->

393+ pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))

394+ _ -> Gen.discard -- Can't occur

395+ , do -- Build a Crop layer

396+ let output_r = fromIntegral $ natVal r

397+ let output_c = fromIntegral $ natVal c

398+ let output_f = fromIntegral $ natVal f

399+

400+ crop_left <- choose 0 10

401+ crop_right <- choose 0 10

402+ crop_top <- choose 0 10

403+ crop_bottom <- choose 0 10

404+

405+ let input_r = output_r + crop_top + crop_bottom

406+ let input_c = output_c + crop_left + crop_right

407+

408+ -- Remake types for input

409+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal crop_left, someNatVal crop_right, someNatVal crop_top, someNatVal crop_bottom ) of

410+ ( Just (SomeNat (chan :: Proxy filters)),

411+ Just (SomeNat (pinr :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

412+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

413+ Just (SomeNat (_ :: Proxy cropLeft)), Just (SomeNat (_ :: Proxy cropRight)),

414+ Just (SomeNat (_ :: Proxy cropTop)), Just (SomeNat (_ :: Proxy cropBottom))) ->

415+ case ( natDict pinr %* natDict chan

416+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outputRows outputColumns filters) ~ h ))

417+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputRows + cropTop + cropBottom) ~ inputRows ) )

418+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputColumns + cropLeft + cropRight) ~ inputColumns ))) of

419+ (Dict, Dict, Dict, Dict) ->

420+ pure (SomeNetwork (Crop :~> rest :: Network ( Crop cropLeft cropTop cropRight cropBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))

421+ _ -> Gen.discard -- Can't occur

422+ ]

423+ ]

424+

425+-- | Test a partial derivative numerically for a random network and input

426+--

427+-- This is the most important test.

428+prop_auto_diff :: Property

429+prop_auto_diff = withDiscards 1000 . withTests 10000 . property $ do

430+ SomeNetwork (network :: Network layers shapes) <- forAll genNetwork

431+ (input :: S (Head shapes)) <- forAllWith nice genOfShape

432+ (target :: S (Last shapes)) <- forAllWith nice oneUp

433+ (tested :: S (Head shapes)) <- forAllWith nice oneUp

434+

435+ let (!tapes, !output) = runNetwork network input

436+ let (_, !backgrad) = runGradient network tapes target

437+ let inputDiff = input + tested * 0.00001

438+ let expected = maxVal ( backgrad * tested )

439+ let (_, !outputDiff) = runNetwork network inputDiff

440+ let result = maxVal ( outputDiff * target - output * target ) / 0.00001

441+

442+ result ~~~ expected

443+

444+-- Make a shape where all are 0 except for 1 value, which is 1.

445+oneUp :: forall shape. ( SingI shape ) => Gen (S shape)

446+oneUp =

447+ case ( sing :: Sing shape ) of

448+ D1Sing SNat ->

449+ let x = 0 :: S ( shape )

450+ in case x of

451+ ( S1D x' ) -> do

452+ let ex = extract x'

453+ let len = VS.length ex

454+ ix <- choose 0 (len - 1)

455+ let nx = runST $ do ex' <- VS.thaw ex

456+ VS.write ex' ix 1.0

457+ VS.freeze ex'

458+ maybe Gen.discard pure . fromStorable $ nx

459+

460+ D2Sing SNat SNat ->

461+ let x = 0 :: S ( shape )

462+ in case x of

463+ ( S2D x' ) -> do

464+ let ex = flatten ( extract x' )

465+ let len = VS.length ex

466+ ix <- choose 0 (len - 1)

467+ let nx = runST $ do ex' <- VS.thaw ex

468+ VS.write ex' ix 1

469+ VS.freeze ex'

470+ maybe Gen.discard pure . fromStorable $ nx

471+

472+ D3Sing SNat SNat SNat ->

473+ let x = 0 :: S ( shape )

474+ in case x of

475+ ( S3D x' ) -> do

476+ let ex = flatten ( extract x' )

477+ let len = VS.length ex

478+ ix <- choose 0 (len - 1)

479+ let nx = runST $ do ex' <- VS.thaw ex

480+ VS.write ex' ix 1

481+ VS.freeze ex'

482+ maybe Gen.discard pure . fromStorable $ nx

483+

484+maxVal :: S shape -> Double

485+maxVal ( S1D x ) = norm_Inf x

486+maxVal ( S2D x ) = norm_Inf x

487+maxVal ( S3D x ) = norm_Inf x

488+

489+(~~~) :: (Monad m, HasCallStack) => Double -> Double -> PropertyT m ()

490+(~~~) x y =

491+ if abs (x - y) < 2e-5 then

492+ success

493+ else

494+ withFrozenCallStack $

495+ failWith Nothing $ unlines [

496+ "━━━ Not Simliar ━━━"

497+ , show x

498+ , show y

499+ ]

500+infix 4 ~~~

501+

502+

503+tests :: IO Bool

504+tests = checkParallel $$(discover)

test/Test/Grenade/Recurrent/Layers/LSTM.hs+83−54

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

1010{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

1111module Test.Grenade.Recurrent.Layers.LSTM where

1212

13−import Disorder.Jack

13+import Hedgehog

14+import Hedgehog.Internal.Source

15+import Hedgehog.Internal.Show

16+import Hedgehog.Internal.Property ( failWith, Diff (..) )

1417

1518import Data.Foldable ( toList )

1619import Data.Singletons.TypeLits

@@ -23,9 +26,9 @@ import qualified Numeric.LinearAlgebra.Static as S

2326

2427

2528import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

26−import Test.Jack.Hmatrix

29+import Test.Hedgehog.Hmatrix

2730

28−genLSTM :: forall i o. (KnownNat i, KnownNat o) => Jack (LSTM i o)

31+genLSTM :: forall i o. (KnownNat i, KnownNat o) => Gen (LSTM i o)

2932genLSTM = do

3033 let w = uniformSample

3134 u = uniformSample

@@ -39,63 +42,89 @@ genLSTM = do

3942 <*> pure (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

4043

4144prop_lstm_reference_forwards =

42− gamble randomVector $ \(input :: S.R 3) ->

43− gamble randomVector $ \(cell :: S.R 2) ->

44− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

45− let actual = runRecurrentForwards net (S1D cell) (S1D input)

46− in case actual of

47− (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->

48− let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut

49− output' = Reference.Vector . H.toList . S.extract $ output

50− refNet = Reference.lstmToReference lstmWeights

51− refCell = Reference.Vector . H.toList . S.extract $ cell

52− refInput = Reference.Vector . H.toList . S.extract $ input

53− (refCO, refO) = Reference.runLSTM refNet refCell refInput

54− in toList refCO ~~~ toList cellOut' .&&. toList refO ~~~ toList output'

45+ property $ do

46+ input :: S.R 3 <- forAll randomVector

47+ cell :: S.R 2 <- forAll randomVector

48+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

49+

50+ let actual = runRecurrentForwards net (S1D cell) (S1D input)

51+ case actual of

52+ (_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->

53+ let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut

54+ output' = Reference.Vector . H.toList . S.extract $ output

55+ refNet = Reference.lstmToReference lstmWeights

56+ refCell = Reference.Vector . H.toList . S.extract $ cell

57+ refInput = Reference.Vector . H.toList . S.extract $ input

58+ (refCO, refO) = Reference.runLSTM refNet refCell refInput

59+ in do toList refCO ~~~ toList cellOut'

60+ toList refO ~~~ toList output'

61+

5562

5663prop_lstm_reference_backwards =

57− gamble randomVector $ \(input :: S.R 3) ->

58− gamble randomVector $ \(cell :: S.R 2) ->

59− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

60− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

61− in case actualBacks of

62− (actualGradients, _, _ :: S ('D1 3)) ->

63− let refNet = Reference.lstmToReference lstmWeights

64− refCell = Reference.Vector . H.toList . S.extract $ cell

65− refInput = Reference.Vector . H.toList . S.extract $ input

66− refGradients = Reference.runLSTMback refCell refInput refNet

67− in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)

64+ property $ do

65+ input :: S.R 3 <- forAll randomVector

66+ cell :: S.R 2 <- forAll randomVector

67+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

68+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

69+ = runRecurrentForwards net (S1D cell) (S1D input)

70+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

71+ case actualBacks of

72+ (actualGradients, _, _ :: S ('D1 3)) ->

73+ let refNet = Reference.lstmToReference lstmWeights

74+ refCell = Reference.Vector . H.toList . S.extract $ cell

75+ refInput = Reference.Vector . H.toList . S.extract $ input

76+ refGradients = Reference.runLSTMback refCell refInput refNet

77+ in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)

6878

6979prop_lstm_reference_backwards_input =

70− gamble randomVector $ \(input :: S.R 3) ->

71− gamble randomVector $ \(cell :: S.R 2) ->

72− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

73− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

74− in case actualBacks of

75− (_, _, S1D actualGradients :: S ('D1 3)) ->

76− let refNet = Reference.lstmToReference lstmWeights

77− refCell = Reference.Vector . H.toList . S.extract $ cell

78− refInput = Reference.Vector . H.toList . S.extract $ input

79− refGradients = Reference.runLSTMbackOnInput refCell refNet refInput

80− in toList refGradients ~~~ H.toList (S.extract actualGradients)

80+ property $ do

81+ input :: S.R 3 <- forAll randomVector

82+ cell :: S.R 2 <- forAll randomVector

83+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

84+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

85+ = runRecurrentForwards net (S1D cell) (S1D input)

86+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

87+ case actualBacks of

88+ (_, _, S1D actualGradients :: S ('D1 3)) ->

89+ let refNet = Reference.lstmToReference lstmWeights

90+ refCell = Reference.Vector . H.toList . S.extract $ cell

91+ refInput = Reference.Vector . H.toList . S.extract $ input

92+ refGradients = Reference.runLSTMbackOnInput refCell refNet refInput

93+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

8194

8295prop_lstm_reference_backwards_cell =

83− gamble randomVector $ \(input :: S.R 3) ->

84− gamble randomVector $ \(cell :: S.R 2) ->

85− gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->

86− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

87− in case actualBacks of

88− (_, S1D actualGradients, _ :: S ('D1 3)) ->

89− let refNet = Reference.lstmToReference lstmWeights

90− refCell = Reference.Vector . H.toList . S.extract $ cell

91− refInput = Reference.Vector . H.toList . S.extract $ input

92− refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

93− in toList refGradients ~~~ H.toList (S.extract actualGradients)

94−

95−

96−(~~~) as bs = all (< 1e-8) (zipWith (-) as bs)

96+ property $ do

97+ input :: S.R 3 <- forAll randomVector

98+ cell :: S.R 2 <- forAll randomVector

99+ net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

100+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

101+ = runRecurrentForwards net (S1D cell) (S1D input)

102+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

103+ case actualBacks of

104+ (_, S1D actualGradients, _ :: S ('D1 3)) ->

105+ let refNet = Reference.lstmToReference lstmWeights

106+ refCell = Reference.Vector . H.toList . S.extract $ cell

107+ refInput = Reference.Vector . H.toList . S.extract $ input

108+ refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

109+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

110+

111+(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> PropertyT m ()

112+(~~~) x y =

113+ if all (< 1e-8) (zipWith (-) x y) then

114+ success

115+ else

116+ case valueDiff <$> mkValue x <*> mkValue y of

117+ Nothing ->

118+ withFrozenCallStack $

119+ failWith Nothing $ unlines [

120+ "━━━ Not Simliar ━━━"

121+ , showPretty x

122+ , showPretty y

123+ ]

124+ Just differ ->

125+ withFrozenCallStack $

126+ failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" differ) ""

97127infix 4 ~~~

98128

99−return []

100129tests :: IO Bool

101−tests = $quickCheckAll

130+tests = checkParallel $$(discover)

test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+25−21

@@ -6,7 +6,6 @@

66{-# LANGUAGE DeriveFunctor #-}

77{-# LANGUAGE DeriveFoldable #-}

88{-# LANGUAGE DeriveTraversable #-}

9−{-# LANGUAGE RecordWildCards #-}

109{-# LANGUAGE FlexibleContexts #-}

1110{-# LANGUAGE RankNTypes #-}

1211

@@ -15,9 +14,13 @@ module Test.Grenade.Recurrent.Layers.LSTM.Reference where

1514

1615import Data.Reflection

1716import Numeric.AD.Mode.Reverse

18−import Numeric.AD.Internal.Reverse ( Tape )

17+import Numeric.AD.Internal.Reverse (Tape)

1918

19+import GHC.TypeLits (KnownNat)

20+

21+import Grenade.Recurrent.Layers.LSTM (LSTMWeights (..))

2022import qualified Grenade.Recurrent.Layers.LSTM as LSTM

23+

2124import qualified Numeric.LinearAlgebra.Static as S

2225import qualified Numeric.LinearAlgebra as H

2326

@@ -54,31 +57,32 @@ data RefLSTM a = RefLSTM

5457 , refLstmBc :: Vector a -- Bias Cell (b_c)

5558 } deriving (Functor, Foldable, Traversable, Eq, Show)

5659

57−lstmToReference :: LSTM.LSTMWeights a b -> RefLSTM Double

58−lstmToReference LSTM.LSTMWeights {..} =

59− let refLstmWf = Matrix . H.toLists . S.extract $ lstmWf -- Weight Forget (W_f)

60− refLstmUf = Matrix . H.toLists . S.extract $ lstmUf -- Cell State Forget (U_f)

61− refLstmBf = Vector . H.toList . S.extract $ lstmBf -- Bias Forget (b_f)

62− refLstmWi = Matrix . H.toLists . S.extract $ lstmWi -- Weight Input (W_i)

63− refLstmUi = Matrix . H.toLists . S.extract $ lstmUi -- Cell State Input (U_i)

64− refLstmBi = Vector . H.toList . S.extract $ lstmBi -- Bias Input (b_i)

65− refLstmWo = Matrix . H.toLists . S.extract $ lstmWo -- Weight Output (W_o)

66− refLstmUo = Matrix . H.toLists . S.extract $ lstmUo -- Cell State Output (U_o)

67− refLstmBo = Vector . H.toList . S.extract $ lstmBo -- Bias Output (b_o)

68− refLstmWc = Matrix . H.toLists . S.extract $ lstmWc -- Weight Cell (W_c)

69− refLstmBc = Vector . H.toList . S.extract $ lstmBc -- Bias Cell (b_c)

70− in RefLSTM {..}

60+lstmToReference :: (KnownNat a, KnownNat b) => LSTM.LSTMWeights a b -> RefLSTM Double

61+lstmToReference lw =

62+ RefLSTM

63+ { refLstmWf = Matrix . H.toLists . S.extract $ lstmWf lw -- Weight Forget (W_f)

64+ , refLstmUf = Matrix . H.toLists . S.extract $ lstmUf lw -- Cell State Forget (U_f)

65+ , refLstmBf = Vector . H.toList . S.extract $ lstmBf lw -- Bias Forget (b_f)

66+ , refLstmWi = Matrix . H.toLists . S.extract $ lstmWi lw -- Weight Input (W_i)

67+ , refLstmUi = Matrix . H.toLists . S.extract $ lstmUi lw -- Cell State Input (U_i)

68+ , refLstmBi = Vector . H.toList . S.extract $ lstmBi lw -- Bias Input (b_i)

69+ , refLstmWo = Matrix . H.toLists . S.extract $ lstmWo lw -- Weight Output (W_o)

70+ , refLstmUo = Matrix . H.toLists . S.extract $ lstmUo lw -- Cell State Output (U_o)

71+ , refLstmBo = Vector . H.toList . S.extract $ lstmBo lw -- Bias Output (b_o)

72+ , refLstmWc = Matrix . H.toLists . S.extract $ lstmWc lw -- Weight Cell (W_c)

73+ , refLstmBc = Vector . H.toList . S.extract $ lstmBc lw -- Bias Cell (b_c)

74+ }

7175

7276runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

73−runLSTM RefLSTM {..} cell input =

77+runLSTM rl cell input =

7478 let -- Forget state vector

75− f_t = sigmoid $ refLstmBf #+ refLstmWf #> input #+ refLstmUf #> cell

79+ f_t = sigmoid $ refLstmBf rl #+ refLstmWf rl #> input #+ refLstmUf rl #> cell

7680 -- Input state vector

77− i_t = sigmoid $ refLstmBi #+ refLstmWi #> input #+ refLstmUi #> cell

81+ i_t = sigmoid $ refLstmBi rl #+ refLstmWi rl #> input #+ refLstmUi rl #> cell

7882 -- Output state vector

79− o_t = sigmoid $ refLstmBo #+ refLstmWo #> input #+ refLstmUo #> cell

83+ o_t = sigmoid $ refLstmBo rl #+ refLstmWo rl #> input #+ refLstmUo rl #> cell

8084 -- Cell input state vector

81− c_x = fmap tanh $ refLstmBc #+ refLstmWc #> input

85+ c_x = fmap tanh $ refLstmBc rl #+ refLstmWc rl #> input

8286 -- Cell state

8387 c_t = f_t #* cell #+ i_t #* c_x

8488 -- Output (it's sometimes recommended to use tanh c_t)

test/Test/Hedgehog/Compat.hsnew file+21

@@ -0,0 +1,21 @@

1+{-# LANGUAGE RankNTypes #-}

2+module Test.Hedgehog.Compat (

3+ (...)

4+ , choose

5+ , blindForAll

6+ )where

7+

8+import Hedgehog (Gen)

9+import qualified Hedgehog.Gen as Gen

10+import qualified Hedgehog.Range as Range

11+import Hedgehog.Internal.Property

12+

13+(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

14+(...) = (.) . (.)

15+{-# INLINE (...) #-}

16+

17+choose :: Integral a => a -> a -> Gen a

18+choose = Gen.integral ... Range.constant

19+

20+blindForAll :: Monad m => Gen a -> PropertyT m a

21+blindForAll = forAllWith (const "blind")

test/Test/Hedgehog/Hmatrix.hsnew file+42

@@ -0,0 +1,42 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+

7+module Test.Hedgehog.Hmatrix where

8+

9+import Grenade

10+import Data.Singletons

11+import Data.Singletons.TypeLits

12+

13+import Hedgehog (Gen)

14+import qualified Hedgehog.Gen as Gen

15+import qualified Hedgehog.Range as Range

16+

17+import qualified Numeric.LinearAlgebra.Static as HStatic

18+

19+randomVector :: forall n. ( KnownNat n ) => Gen (HStatic.R n)

20+randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded

21+

22+uniformSample :: forall m n. ( KnownNat m, KnownNat n ) => Gen (HStatic.L m n)

23+uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded

24+

25+-- | Generate random data of the desired shape

26+genOfShape :: forall x. ( SingI x ) => Gen (S x)

27+genOfShape =

28+ case (sing :: Sing x) of

29+ D1Sing l ->

30+ withKnownNat l $

31+ S1D <$> randomVector

32+ D2Sing r c ->

33+ withKnownNat r $ withKnownNat c $

34+ S2D <$> uniformSample

35+ D3Sing r c d ->

36+ withKnownNat r $ withKnownNat c $ withKnownNat d $

37+ S3D <$> uniformSample

38+

39+nice :: S shape -> String

40+nice (S1D x) = show . HStatic.extract $ x

41+nice (S2D x) = show . HStatic.extract $ x

42+nice (S3D x) = show . HStatic.extract $ x

test/Test/Hedgehog/TypeLits.hsnew file+65

@@ -0,0 +1,65 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE RankNTypes #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE GADTs #-}

8+module Test.Hedgehog.TypeLits where

9+

10+import Data.Constraint (Dict (..))

11+import Data.Singletons (Proxy (..), Sing (..), SomeSing (..), sing)

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

13+import Data.Singletons.TypeLits (SNat (..))

14+#endif

15+

16+import Hedgehog (Gen)

17+import qualified Hedgehog.Gen as Gen

18+

19+import Grenade

20+

21+import GHC.TypeLits (SomeNat (..), natVal, someNatVal)

22+import GHC.TypeLits.Witnesses ((%*), natDict)

23+import Test.Hedgehog.Compat (choose)

24+

25+genNat :: Gen SomeNat

26+genNat = do

27+ ~(Just n) <- someNatVal <$> choose 1 10

28+ return n

29+

30+genShape :: Gen (SomeSing Shape)

31+genShape

32+ = Gen.choice [

33+ genD1

34+ , genD2

35+ , genD3

36+ ]

37+

38+genD1 :: Gen (SomeSing Shape)

39+genD1 = do

40+ n <- genNat

41+ return $ case n of

42+ SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

43+

44+genD2 :: Gen (SomeSing Shape)

45+genD2 = do

46+ n <- genNat

47+ m <- genNat

48+ return $ case (n, m) of

49+ (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

50+

51+genD3 :: Gen (SomeSing Shape)

52+genD3 = do

53+ n <- genNat

54+ m <- genNat

55+ o <- genNat

56+ return $ case (n, m, o) of

57+ (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->

58+ case natDict px %* natDict pz of

59+ Dict -> SomeSing (sing :: Sing ('D3 x y z))

60+

61+rss :: SomeSing Shape -> String

62+rss (SomeSing (r :: Sing s)) = case r of

63+ (D1Sing a@SNat) -> "D1 " ++ show (natVal a)

64+ (D2Sing a@SNat b@SNat) -> "D2 " ++ show (natVal a) ++ " " ++ show (natVal b)

65+ (D3Sing a@SNat b@SNat c@SNat) -> "D3 " ++ show (natVal a) ++ " " ++ show (natVal b) ++ " " ++ show (natVal c)

test/Test/Jack/Hmatrix.hsdeleted−29

@@ -1,29 +0,0 @@

1−{-# LANGUAGE RankNTypes #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE GADTs #-}

5−

6−module Test.Jack.Hmatrix where

7−

8−import Grenade

9−import Data.Singletons

10−

11−import Disorder.Jack

12−

13−import GHC.TypeLits

14−

15−import qualified Numeric.LinearAlgebra.Static as HStatic

16−

17−randomVector :: forall n. KnownNat n => Jack (HStatic.R n)

18−randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> sizedNat

19−

20−uniformSample :: forall m n. (KnownNat m, KnownNat n) => Jack (HStatic.L m n)

21−uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> sizedNat

22−

23−-- | Generate random data of the desired shape

24−genOfShape :: forall x. ( SingI x ) => Jack (S x)

25−genOfShape =

26− case (sing :: Sing x) of

27− D1Sing -> S1D <$> randomVector

28− D2Sing -> S2D <$> uniformSample

29− D3Sing -> S3D <$> uniformSample

test/Test/Jack/TypeLits.hsdeleted−60

@@ -1,60 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE RankNTypes #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE PolyKinds #-}

6−module Test.Jack.TypeLits where

7−

8−import Data.Constraint

9−#if __GLASGOW_HASKELL__ < 800

10−import Data.Proxy

11−#endif

12−import Data.Singletons

13−import Disorder.Jack

14−

15−import Grenade

16−

17−import GHC.TypeLits

18−import GHC.TypeLits.Witnesses

19−

20−genNat :: Jack SomeNat

21−genNat = do

22− Just n <- someNatVal <$> choose (1, 10)

23− return n

24−

25−#if __GLASGOW_HASKELL__ < 800

26−type Shape' = ('KProxy :: KProxy Shape)

27−#else

28−type Shape' = Shape

29−#endif

30−

31−genShape :: Jack (SomeSing Shape')

32−genShape

33− = oneOf [

34− genD1

35− , genD2

36− , genD3

37− ]

38−

39−genD1 :: Jack (SomeSing Shape')

40−genD1 = do

41− n <- genNat

42− return $ case n of

43− SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

44−

45−genD2 :: Jack (SomeSing Shape')

46−genD2 = do

47− n <- genNat

48− m <- genNat

49− return $ case (n, m) of

50− (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

51−

52−genD3 :: Jack (SomeSing Shape')

53−genD3 = do

54− n <- genNat

55− m <- genNat

56− o <- genNat

57− return $ case (n, m, o) of

58− (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->

59− case natDict px %* natDict pz of

60− Dict -> SomeSing (sing :: Sing ('D3 x y z))

test/test.hs+22−2

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

1−import Disorder.Core.Main

1+import Control.Monad

2+

3+import qualified Test.Grenade.Network

24

35import qualified Test.Grenade.Layers.Pooling

46import qualified Test.Grenade.Layers.Convolution

@@ -11,10 +13,15 @@ import qualified Test.Grenade.Layers.Internal.Pooling

1113

1214import qualified Test.Grenade.Recurrent.Layers.LSTM

1315

16+import System.Exit

17+import System.IO

18+

1419main :: IO ()

1520main =

1621 disorderMain [

17− Test.Grenade.Layers.Pooling.tests

22+ Test.Grenade.Network.tests

23+

24+ , Test.Grenade.Layers.Pooling.tests

1825 , Test.Grenade.Layers.Convolution.tests

1926 , Test.Grenade.Layers.FullyConnected.tests

2027 , Test.Grenade.Layers.Nonlinear.tests

@@ -24,4 +31,17 @@ main =

2431 , Test.Grenade.Layers.Internal.Pooling.tests

2532

2633 , Test.Grenade.Recurrent.Layers.LSTM.tests

34+

2735 ]

36+

37+disorderMain :: [IO Bool] -> IO ()

38+disorderMain tests = do

39+ lineBuffer

40+ rs <- sequence tests

41+ unless (and rs) exitFailure

42+

43+

44+lineBuffer :: IO ()

45+lineBuffer = do

46+ hSetBuffering stdout LineBuffering

47+ hSetBuffering stderr LineBuffering