adf7312..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/

.travis.yml+12−10

@@ -2,28 +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− - cabal sandbox init

20− - cabal install --enable-tests --enable-benchmarks

21+ - travis_retry cabal-3.2 update

2122

2223notifications:

2324 email: false

2425

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

2627script:

27− - cabal build

28− - 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

2931

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+68−27

@@ -1,30 +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>

88synopsis: Practical Deep Learning in Haskell

9−category: System

10−cabal-version: >= 1.8

9+category: AI, Machine Learning

10+cabal-version: >= 1.10

1111build-type: Simple

1212description:

1313 Grenade is a composable, dependently typed, practical, and fast

14− recurrent neural network library for concise and precise

15− specifications of complex networks in Haskell.

14+ recurrent neural network library for precise specifications and

15+ complex deep neural networks in Haskell.

1616 .

1717 Grenade provides an API for composing layers of a neural network

18− into a sequence parallel graph in a type safe manner.

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.

1921 .

2022 Documentation and examples are available on github

2123 <https://github.com/HuwCampbell/grenade>.

2224

2325extra-source-files:

26+ README.md

2427 cbits/im2col.h

2528 cbits/im2col.c

26− cbits/gradient_decent.h

27− cbits/gradient_decent.c

29+ cbits/gradient_descent.h

30+ cbits/gradient_descent.c

2831 cbits/pad.h

2932 cbits/pad.c

3033

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

3538library

3639 build-depends:

3740 base >= 4.8 && < 5

38− , bytestring == 0.10.*

39− , containers >= 0.5 && < 0.6

41+ , bytestring >= 0.10.0

42+ , containers >= 0.5 && < 0.7

4043 , cereal >= 0.5 && < 0.6

4144 , deepseq >= 1.4 && < 1.5

42− , exceptions == 0.8.*

43− , hmatrix == 0.18.*

45+ , hmatrix >= 0.18 && < 0.21

4446 , MonadRandom >= 0.4 && < 0.6

45− , mtl >= 2.2.1 && < 2.3

46− , primitive >= 0.6 && < 0.7

47− , text == 1.2.*

48− , 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

4952 , vector >= 0.11 && < 0.13

5053

5154 ghc-options:

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

5356 hs-source-dirs:

5457 src

5558

59+ default-language: Haskell2010

60+

5661 if impl(ghc < 8.0)

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

63+ cpp-options: -DType=*

5864

65+ if impl(ghc >= 8.6)

66+ default-extensions: NoStarIsType

5967

6068 exposed-modules:

6169 Grenade

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

8189 Grenade.Layers.Pooling

8290 Grenade.Layers.Relu

8391 Grenade.Layers.Reshape

92+ Grenade.Layers.Sinusoid

8493 Grenade.Layers.Softmax

8594 Grenade.Layers.Tanh

8695 Grenade.Layers.Trivial

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

99108

100109 Grenade.Recurrent.Layers

101110 Grenade.Recurrent.Layers.BasicRecurrent

111+ Grenade.Recurrent.Layers.ConcatRecurrent

102112 Grenade.Recurrent.Layers.LSTM

103113

104114 Grenade.Utils.OneHot

105115

106116 includes: cbits/im2col.h

107− cbits/gradient_decent.h

117+ cbits/gradient_descent.h

108118 cbits/pad.h

109119 c-sources: cbits/im2col.c

110− cbits/gradient_decent.c

120+ cbits/gradient_descent.c

111121 cbits/pad.c

112122

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

@@ -122,21 +132,48 @@ test-suite test

122132 hs-source-dirs:

123133 test

124134

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+

125161 build-depends:

126− base >= 4.8 && < 5

162+ base

127163 , grenade

128− , hedgehog >= 0.1 && < 0.2

164+ , hedgehog >= 1.0 && < 1.1

129165 , hmatrix

130166 , mtl

131167 , singletons

132168 , text == 1.2.*

133− , typelits-witnesses

169+ , typelits-witnesses < 0.4

134170 , transformers

135171 , constraints

136172 , MonadRandom

137173 , random

138174 , ad

139175 , reflection

176+ , vector

140177

141178

142179benchmark bench

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

149186 hs-source-dirs:

150187 bench

151188

189+ default-language: Haskell2010

190+

152191 build-depends:

153− base >= 3 && < 5

154− , bytestring == 0.10.*

155− , criterion == 1.1.*

192+ base

193+ , bytestring

194+ , criterion >= 1.1 && < 1.6

156195 , grenade

157196 , hmatrix

158197

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

166205 hs-source-dirs:

167206 bench

168207

208+ default-language: Haskell2010

209+

169210 build-depends:

170− base >= 3 && < 5

171− , bytestring == 0.10.*

172− , criterion == 1.1.*

211+ base

212+ , bytestring

213+ , criterion

173214 , grenade

174215 , hmatrix

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/Core/Layer.hs+8−3

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE TypeOperators #-}

@@ -19,7 +20,7 @@ neural network.

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

2021

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

22−in a network. Having no shape information, this class is agnotostic

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

2324to the input and output data of the layer.

2425

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

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

4142

4243import Data.List ( foldl' )

4344

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

46+import Data.Kind (Type)

47+#endif

48+

4449import Grenade.Core.Shape

4550import Grenade.Core.LearningParameters

4651

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

5055class UpdateLayer x where

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

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

53− type Gradient x :: *

58+ type Gradient x :: Type

5459

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

5661 runUpdate :: LearningParameters -> x -> Gradient x -> x

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

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

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

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

75− type Tape x i o :: *

80+ type Tape x i o :: Type

7681

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

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

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

@@ -7,7 +7,7 @@ Stability : experimental

77-}

88module Grenade.Core.LearningParameters (

99 -- | This module contains learning algorithm specific

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

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

1111 -- unstable, due to issue #26.

1212

1313 LearningParameters (..)

src/Grenade/Core/Network.hs+11−6

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE BangPatterns #-}

34{-# LANGUAGE GADTs #-}

@@ -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

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

139144 = (GNil, o)

140145

141146

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

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

143148applyUpdate :: LearningParameters

144149 -> Network layers shapes

145150 -> Gradients layers

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

152157

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

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

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

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

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

157162 --

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

src/Grenade/Core/Runner.hs+2−1

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

1313 , runNet

1414 ) where

1515

16−import Data.Singletons.Prelude

1716

1817import Grenade.Core.LearningParameters

1918import Grenade.Core.Network

2019import Grenade.Core.Shape

20+import Data.Singletons

21+import Prelude.Singletons

2122

2223-- | Perform reverse automatic differentiation on the network

2324-- for the current input and expected output.

src/Grenade/Core/Shape.hs+57−21

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE KindSignatures #-}

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

78{-# LANGUAGE FlexibleContexts #-}

89{-# LANGUAGE ScopedTypeVariables #-}

910{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE UndecidableInstances #-}

1012{-|

1113Module : Grenade.Core.Shape

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

@@ -17,25 +19,22 @@ Stability : experimental

1719

1820-}

1921module Grenade.Core.Shape (

20− Shape (..)

21− , S (..)

22− , Sing (..)

23−

22+ S (..)

23+ , Shape (..)

24+ , SShape (..)

2425 , randomOfShape

2526 , fromStorable

2627 ) where

2728

2829import Control.DeepSeq (NFData (..))

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

30−

31+import Data.Kind (Type)

3132import Data.Proxy

33+import Data.Serialize

3234import Data.Singletons

33−import Data.Singletons.TypeLits

3435import Data.Vector.Storable ( Vector )

3536import qualified Data.Vector.Storable as V

36−

3737import GHC.TypeLits

38−

3938import qualified Numeric.LinearAlgebra.Static as H

4039import Numeric.LinearAlgebra.Static

4140import qualified Numeric.LinearAlgebra as NLA

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

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

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

8281-- 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

8391data instance Sing (n :: Shape) where

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

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

86− 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

8796

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

8998 sing = D1Sing

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

139148randomOfShape = do

140149 seed :: Int <- getRandom

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

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

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

144− 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)

145159

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

147161--

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

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

150164fromStorable xs = case sing :: Sing x of

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

152− D2Sing -> S2D <$> mkL xs

153− 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

154173 where

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

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

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

161180 then H.create $ NLA.reshape columns v

162181 else Nothing

163182

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+

164195-- Helper function for creating the number instances

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

166197n1 f (S1D x) = S1D (f x)

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

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

175206

176207-- Helper function for creating the number instances

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

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

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

179− D1Sing -> S1D (konst x)

180− D2Sing -> S2D (konst x)

181− 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+7−1

@@ -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

@@ -26,6 +28,10 @@ import Data.Serialize

2628import Data.Singletons

2729import GHC.TypeLits

2830

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

32+import Data.Kind (Type)

33+#endif

34+

2935import Grenade.Core

3036

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

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

4349--

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

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

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

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

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

4854

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

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

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

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

1011{-|

1112Module : Grenade.Layers.Convolution

1213Description : Convolution layer

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

2728import Data.Maybe

2829import Data.Proxy

2930import Data.Serialize

30−import Data.Singletons.TypeLits

3131

3232import GHC.TypeLits

33+import Data.Kind (Type)

3334

3435import Numeric.LinearAlgebra hiding ( uniformSample, konst )

3536import qualified Numeric.LinearAlgebra as LA

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

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

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

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

59− -> * where

60+ -> Type where

6061 Convolution :: ( KnownNat channels

6162 , KnownNat filters

6263 , KnownNat kernelRows

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

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

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

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

78− -> * where

79+ -> Type where

7980 Convolution' :: ( KnownNat channels

8081 , KnownNat filters

8182 , KnownNat kernelRows

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

129130 , KnownNat strideColumns

130131 , KnownNat (kernelRows * kernelColumns * channels)

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

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

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

134− 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

135136 in Convolution newKernel newMomentum

136137

137138 createRandom = randomConvolution

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE GADTs #-}

@@ -5,6 +6,7 @@

56{-# LANGUAGE TypeFamilies #-}

67{-# LANGUAGE FlexibleContexts #-}

78{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE UndecidableInstances #-}

810{-|

911Module : Grenade.Layers.Crop

1012Description : Cropping layer

@@ -18,8 +20,10 @@ module Grenade.Layers.Crop (

1820

1921import Data.Maybe

2022import Data.Proxy

21−import Data.Singletons.TypeLits

23+import Data.Serialize

24+

2225import GHC.TypeLits

26+import Data.Kind (Type)

2327

2428import Grenade.Core

2529import Grenade.Layers.Internal.Pad

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

3135data Crop :: Nat

3236 -> Nat

3337 -> Nat

34− -> Nat -> * where

38+ -> Nat -> Type where

3539 Crop :: Crop cropLeft cropTop cropRight cropBottom

3640

3741instance Show (Crop cropLeft cropTop cropRight cropBottom) where

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

4246 runUpdate _ x _ = x

4347 createRandom = return Crop

4448

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

50+ put _ = return ()

51+ get = return Crop

52+

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

4654instance ( KnownNat cropLeft

4755 , KnownNat cropTop

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

5159 , KnownNat inputColumns

5260 , KnownNat outputRows

5361 , KnownNat outputColumns

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

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

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

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

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

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

5866 runForwards Crop (S2D input) =

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

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

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

1011{-|

1112Module : Grenade.Layers.Deconvolution

1213Description : Deconvolution layer

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

3132import Data.Maybe

3233import Data.Proxy

3334import Data.Serialize

34−import Data.Singletons.TypeLits

3535

3636import GHC.TypeLits

37+import Data.Kind (Type)

3738

3839import Numeric.LinearAlgebra hiding ( uniformSample, konst )

3940import qualified Numeric.LinearAlgebra as LA

@@ -55,7 +56,7 @@ data Deconvolution :: Nat -- Number of channels, for the first layer this could

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

5657 -> Nat -- The row stride of the Deconvolution filter

5758 -> Nat -- The columns stride of the Deconvolution filter

58− -> * where

59+ -> Type where

5960 Deconvolution :: ( KnownNat channels

6061 , KnownNat filters

6162 , KnownNat kernelRows

@@ -74,7 +75,7 @@ data Deconvolution' :: Nat -- Number of channels, for the first layer this could

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

7576 -> Nat -- The row stride of the Deconvolution filter

7677 -> Nat -- The columns stride of the Deconvolution filter

77− -> * where

78+ -> Type where

7879 Deconvolution' :: ( KnownNat channels

7980 , KnownNat filters

8081 , KnownNat kernelRows

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

128129 , KnownNat strideColumns

129130 , KnownNat (kernelRows * kernelColumns * filters)

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

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

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

133− 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

134135 in Deconvolution newKernel newMomentum

135136

136137 createRandom = randomDeconvolution

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

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

3636 get = return Elu

3737

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

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

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

4040

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

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

4242 where

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

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

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

4545 where

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

4747

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+15−9

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

3434 createRandom = return Logit

3535

3636instance (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.

3744 type Tape Logit a b = S a

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

39− 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)

4051

4152instance Serialize Logit where

4253 put _ = return ()

4354 get = return Logit

4455

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

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

47−

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

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

50− where

51− logix = logistic x

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

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

src/Grenade/Layers/Merge.hs+6−1

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE TypeOperators #-}

@@ -23,13 +24,17 @@ import Data.Serialize

2324

2425import Data.Singletons

2526

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

28+import Data.Kind (Type)

29+#endif

30+

2631import Grenade.Core

2732

2833-- | A Merging layer.

2934--

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

3136-- shape.

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

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

3338 Merge :: x -> y -> Merge x y

3439

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

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE GADTs #-}

@@ -5,6 +6,7 @@

56{-# LANGUAGE TypeFamilies #-}

67{-# LANGUAGE MultiParamTypeClasses #-}

78{-# LANGUAGE FlexibleContexts #-}

9+{-# LANGUAGE UndecidableInstances #-}

810{-|

911Module : Grenade.Core.Pad

1012Description : Padding layer for 2D and 3D images

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

1921import Data.Maybe

2022import Data.Proxy

2123import Data.Serialize

22−import Data.Singletons.TypeLits

24+

2325import GHC.TypeLits

26+import Data.Kind (Type)

2427

2528import Grenade.Core

2629import Grenade.Layers.Internal.Pad

@@ -34,7 +37,7 @@ import Numeric.LinearAlgebra.Static (extract, create)

3437data Pad :: Nat

3538 -> Nat

3639 -> Nat

37− -> Nat -> * where

40+ -> Nat -> Type where

3841 Pad :: Pad padLeft padTop padRight padBottom

3942

4043instance Show (Pad padLeft padTop padRight padBottom) where

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

4952 put _ = return ()

5053 get = return Pad

5154

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

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

5356instance ( KnownNat padLeft

5457 , KnownNat padTop

5558 , KnownNat padRight

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

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

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

8184

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

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

8386instance ( KnownNat padLeft

8487 , KnownNat padTop

8588 , KnownNat padRight

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE StandaloneDeriving #-}

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

67{-# LANGUAGE TypeFamilies #-}

78{-# LANGUAGE MultiParamTypeClasses #-}

89{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

911{-|

1012Module : Grenade.Core.Pooling

1113Description : Max Pooling layer for 2D and 3D images

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

2022import Data.Maybe

2123import Data.Proxy

2224import Data.Serialize

23−import Data.Singletons.TypeLits

25+

2426import GHC.TypeLits

27+import Data.Kind (Type)

2528

2629import Grenade.Core

2730import Grenade.Layers.Internal.Pooling

@@ -36,14 +39,14 @@ import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRow

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

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

3841--

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

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

4043 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

4144

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

4346 show Pooling = "Pooling"

4447

4548instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

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

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

4750 runUpdate _ Pooling _ = Pooling

4851 createRandom = return Pooling

4952

src/Grenade/Layers/Reshape.hs+1−1

@@ -3,6 +3,7 @@

33{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

55{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE UndecidableInstances #-}

67{-|

78Module : Grenade.Layers.Reshape

89Description : Multipurpose reshaping layer

@@ -16,7 +17,6 @@ module Grenade.Layers.Reshape (

1617

1718import Data.Serialize

1819

19−import Data.Singletons.TypeLits

2020import GHC.TypeLits

2121

2222import Numeric.LinearAlgebra.Static

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/Tanh.hs+3−3

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

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeOperators #-}

3−{-# LANGUAGE TypeFamilies #-}

42{-# LANGUAGE FlexibleInstances #-}

53{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeOperators #-}

66{-|

77Module : Grenade.Layers.Tanh

88Description : Hyperbolic tangent nonlinear layer

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

2020import Grenade.Core

2121

2222-- | A Tanh layer.

23−-- 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.

2424data Tanh = Tanh

2525 deriving Show

2626

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+16−11

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE TemplateHaskell #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE GADTs #-}

@@ -15,17 +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

2126import Hedgehog

2227import qualified Hedgehog.Gen as Gen

2328

24−import Test.Jack.Hmatrix

25−import Test.Jack.TypeLits

26−import Test.Jack.Compat

29+import Test.Hedgehog.Hmatrix

30+import Test.Hedgehog.TypeLits

31+import Test.Hedgehog.Compat

2732

28−data OpaqueConvolution :: * where

33+data OpaqueConvolution :: Type where

2934 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution

3035

3136instance Show OpaqueConvolution where

@@ -39,10 +44,10 @@ genConvolution :: ( KnownNat channels

3944 , KnownNat strideColumns

4045 , KnownNat kernelFlattened

4146 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

42− ) => Jack (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

47+ ) => Gen (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

4348genConvolution = Convolution <$> uniformSample <*> uniformSample

4449

45−genOpaqueOpaqueConvolution :: Jack OpaqueConvolution

50+genOpaqueOpaqueConvolution :: Gen OpaqueConvolution

4651genOpaqueOpaqueConvolution = do

4752 channels <- genNat

4853 filters <- genNat

@@ -58,16 +63,16 @@ genOpaqueOpaqueConvolution = do

5863 p2 = natDict pkc

5964 p3 = natDict pch

6065 in case p1 %* p2 %* p3 of

61− Dict -> OpaqueConvolution <$> (genConvolution :: Jack (Convolution ch fl kr kc sr sc))

66+ Dict -> OpaqueConvolution <$> (genConvolution :: Gen (Convolution ch fl kr kc sr sc))

6267

6368prop_conv_net_witness = property $

64− forAll genOpaqueOpaqueConvolution >>= \onet ->

69+ blindForAll genOpaqueOpaqueConvolution >>= \onet ->

6570 case onet of

6671 (OpaqueConvolution ((Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) -> success

6772

6873

6974prop_conv_net = property $

70− forAll genOpaqueOpaqueConvolution >>= \onet ->

75+ blindForAll genOpaqueOpaqueConvolution >>= \onet ->

7176 case onet of

7277 (OpaqueConvolution (convLayer@(Convolution _ _) :: Convolution channels filters kernelRows kernelCols strideRows strideCols)) ->

7378 let ok stride kernel = [extent | extent <- [(kernel + 1) .. 30 ], (extent - kernel) `mod` stride == 0]

@@ -92,7 +97,7 @@ prop_conv_net = property $

9297 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

9398 , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

9499 (Dict, Dict, Dict, Dict) ->

95− forAll (S3D <$> uniformSample) >>= \(input :: S ('D3 inRows inCols channels)) ->

100+ blindForAll (S3D <$> uniformSample) >>= \(input :: S ('D3 inRows inCols channels)) ->

96101 let (tape, output :: S ('D3 outRows outCols filters)) = runForwards convLayer input

97102 backed :: (Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols), S ('D3 inRows inCols channels))

98103 = runBackwards convLayer tape output

@@ -100,4 +105,4 @@ prop_conv_net = property $

100105

101106

102107tests :: IO Bool

103−tests = $$(checkConcurrent)

108+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/FullyConnected.hs+12−8

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE BangPatterns #-}

23{-# LANGUAGE TemplateHaskell #-}

34{-# LANGUAGE DataKinds #-}

@@ -12,22 +13,25 @@ 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

1823import Hedgehog

1924

20−import Test.Jack.Hmatrix

21−import Test.Jack.Compat

22−

25+import Test.Hedgehog.Compat

26+import Test.Hedgehog.Hmatrix

2327

24−data OpaqueFullyConnected :: * where

28+data OpaqueFullyConnected :: Type where

2529 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected

2630

2731instance Show OpaqueFullyConnected where

2832 show (OpaqueFullyConnected n) = show n

2933

30−genOpaqueFullyConnected :: Jack OpaqueFullyConnected

34+genOpaqueFullyConnected :: Gen OpaqueFullyConnected

3135genOpaqueFullyConnected = do

3236 input :: Integer <- choose 2 100

3337 output :: Integer <- choose 1 100

@@ -43,12 +47,12 @@ genOpaqueFullyConnected = do

4347

4448prop_fully_connected_forwards :: Property

4549prop_fully_connected_forwards = property $ do

46− OpaqueFullyConnected (fclayer :: FullyConnected i o) <- forAll genOpaqueFullyConnected

47− input :: S ('D1 i) <- forAll (S1D <$> randomVector)

50+ OpaqueFullyConnected (fclayer :: FullyConnected i o) <- blindForAll genOpaqueFullyConnected

51+ input :: S ('D1 i) <- blindForAll (S1D <$> randomVector)

4852 let (tape, output :: S ('D1 o)) = runForwards fclayer input

4953 backed :: (Gradient (FullyConnected i o), S ('D1 i))

5054 = runBackwards fclayer tape output

5155 backed `seq` success

5256

5357tests :: IO Bool

54−tests = $$(checkConcurrent)

58+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Internal/Convolution.hs+11−13

@@ -17,22 +17,21 @@ import qualified Hedgehog.Gen as Gen

1717import qualified Hedgehog.Range as Range

1818

1919import qualified Test.Grenade.Layers.Internal.Reference as Reference

20−import Test.Jack.Compat

20+import Test.Hedgehog.Compat

2121

2222prop_im2col_col2im_symmetrical_with_kernel_stride =

2323 let factors n = [x | x <- [1..n], n `mod` x == 0]

2424 in property $ do

2525 height <- forAll $ choose 2 100

2626 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 $ Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 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)

3030

31− let input' = (height >< width) input

3231 let stride_h = kernel_h

3332 let stride_w = kernel_w

34− let out = col2im kernel_h kernel_w stride_h stride_w height width . im2col kernel_h kernel_w stride_h stride_w $ input'

35− input' === out

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

3635

3736prop_im2col_col2im_behaves_as_reference =

3837 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

@@ -43,17 +42,16 @@ prop_im2col_col2im_behaves_as_reference =

4342 kernel_w <- forAll (choose 2 (width - 1))

4443 stride_h <- forAll (Gen.element (ok height kernel_h))

4544 stride_w <- forAll (Gen.element (ok width kernel_w))

46− input <- forAll ( Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100))

47− let input' = (height >< width) input

48− let outFast = im2col kernel_h kernel_w stride_h stride_w input'

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

4948 let retFast = col2im kernel_h kernel_w stride_h stride_w height width outFast

5049

51− let outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input'

50+ let outReference = Reference.im2col kernel_h kernel_w stride_h stride_w input

5251 let retReference = Reference.col2im kernel_h kernel_w stride_h stride_w height width outReference

5352

5453 outFast === outReference

5554 retFast === retReference

5655

57−return []

5856tests :: IO Bool

59−tests = $$(checkConcurrent)

57+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Internal/Pooling.hs+7−8

@@ -17,7 +17,7 @@ import qualified Hedgehog.Gen as Gen

1717import qualified Hedgehog.Range as Range

1818

1919import qualified Test.Grenade.Layers.Internal.Reference as Reference

20−import Test.Jack.Compat

20+import Test.Hedgehog.Compat

2121

2222prop_poolForwards_poolBackwards_behaves_as_reference =

2323 let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]

@@ -29,18 +29,17 @@ prop_poolForwards_poolBackwards_behaves_as_reference =

2929 kernel_w <- forAll $ choose 1 (width - 1)

3030 stride_h <- forAll $ Gen.element (ok height kernel_h)

3131 stride_w <- forAll $ Gen.element (ok width kernel_w)

32− input <- forAll $ Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

32+ input <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

3333

34− let input' = (height >< width) input

35− let outFast = poolForward 1 height width kernel_h kernel_w stride_h stride_w input'

36− let retFast = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input' outFast

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

3736

38− 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'

39− let retReference = Reference.poolBackward kernel_h kernel_w stride_h stride_w input' outReference

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

4039

4140 outFast === outReference

4241 retFast === retReference

4342

4443

4544tests :: IO Bool

46−tests = $$(checkConcurrent)

45+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Nonlinear.hs+6−35

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

32{-# LANGUAGE TemplateHaskell #-}

43{-# LANGUAGE DataKinds #-}

54{-# LANGUAGE KindSignatures #-}

@@ -9,34 +8,21 @@

98{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

109module Test.Grenade.Layers.Nonlinear where

1110

12−

13−import Control.Monad.Trans.Class (MonadTrans(..))

14−

1511import Data.Singletons

1612

17−#if __GLASGOW_HASKELL__ < 800

18−import Data.Proxy

19−#endif

20−

2113import Grenade

22−import GHC.TypeLits

2314

2415import Hedgehog

25−import Hedgehog.Internal.Property ( Test (..) )

2616

27−import Test.Jack.Hmatrix

28−import Test.Jack.TypeLits

17+import Test.Hedgehog.Compat

18+import Test.Hedgehog.Hmatrix

19+import Test.Hedgehog.TypeLits

2920

3021import Numeric.LinearAlgebra.Static ( norm_Inf )

3122

32−-- | Generates a random input for the test by running the provided generator.

33−--

34−blindForAll :: Monad m => Gen m a -> Test m a

35−blindForAll = Test . lift . lift

36−

3723prop_sigmoid_grad :: Property

3824prop_sigmoid_grad = property $

39− blindForAll genShape >>= \case

25+ forAllWith rss genShape >>= \case

4026 (SomeSing (r :: Sing s)) ->

4127 withSingI r $

4228 blindForAll genOfShape >>= \(ds :: S s) ->

@@ -51,7 +37,7 @@ prop_sigmoid_grad = property $

5137

5238prop_tanh_grad :: Property

5339prop_tanh_grad = property $

54− blindForAll genShape >>= \case

40+ forAllWith rss genShape >>= \case

5541 (SomeSing (r :: Sing s)) ->

5642 withSingI r $

5743 blindForAll genOfShape >>= \(ds :: S s) ->

@@ -64,20 +50,5 @@ prop_tanh_grad = property $

6450 (S2D x) -> norm_Inf x < 0.001

6551 (S3D x) -> norm_Inf x < 0.001) :: Bool)

6652

67−prop_softmax_grad :: Property

68−prop_softmax_grad = property $

69− forAll genNat >>= \case

70− (SomeNat (_ :: Proxy s)) ->

71− forAll genOfShape >>= \(ds :: S ('D1 s)) ->

72− let (tape, f :: S ('D1 s)) = runForwards Relu ds

73− ((), ret :: S ('D1 s)) = runBackwards Relu tape (1 :: S ('D1 s))

74− (_, numer :: S ('D1 s)) = runForwards Relu (ds + 0.0001)

75− numericalGradient = (numer - f) * 10000

76− in assert ((case numericalGradient - ret of

77− (S1D x) -> norm_Inf x < 0.0001) :: Bool)

78−

79−

80−

8153tests :: IO Bool

82−tests = $$(checkConcurrent)

83−

54+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/PadCrop.hs+2−6

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

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

@@ -19,7 +15,7 @@ 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 =

@@ -50,4 +46,4 @@ prop_pad_crop_2d =

5046

5147

5248tests :: IO Bool

53−tests = $$(checkConcurrent)

49+tests = checkParallel $$(discover)

test/Test/Grenade/Layers/Pooling.hs+14−8

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE TemplateHaskell #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE KindSignatures #-}

@@ -9,24 +10,29 @@ 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

1520import Hedgehog

16−import Test.Jack.Compat

1721

18−data OpaquePooling :: * where

22+import Test.Hedgehog.Compat

23+

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)) ->

@@ -40,4 +46,4 @@ prop_pool_layer_witness =

4046 assert True

4147

4248tests :: IO Bool

43−tests = $$(checkConcurrent)

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+37−15

@@ -11,6 +11,9 @@

1111module Test.Grenade.Recurrent.Layers.LSTM where

1212

1313import 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,10 +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

27−import Test.Jack.Compat

29+import Test.Hedgehog.Hmatrix

2830

29−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)

3032genLSTM = do

3133 let w = uniformSample

3234 u = uniformSample

@@ -54,8 +56,8 @@ prop_lstm_reference_forwards =

5456 refCell = Reference.Vector . H.toList . S.extract $ cell

5557 refInput = Reference.Vector . H.toList . S.extract $ input

5658 (refCO, refO) = Reference.runLSTM refNet refCell refInput

57− in do assert (toList refCO ~~~ toList cellOut')

58− assert (toList refO ~~~ toList output')

59+ in do toList refCO ~~~ toList cellOut'

60+ toList refO ~~~ toList output'

5961

6062

6163prop_lstm_reference_backwards =

@@ -63,46 +65,66 @@ prop_lstm_reference_backwards =

6365 input :: S.R 3 <- forAll randomVector

6466 cell :: S.R 2 <- forAll randomVector

6567 net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

66− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

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))

6771 case actualBacks of

6872 (actualGradients, _, _ :: S ('D1 3)) ->

6973 let refNet = Reference.lstmToReference lstmWeights

7074 refCell = Reference.Vector . H.toList . S.extract $ cell

7175 refInput = Reference.Vector . H.toList . S.extract $ input

7276 refGradients = Reference.runLSTMback refCell refInput refNet

73− in assert $ toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)

77+ in toList refGradients ~~~ toList (Reference.lstmToReference actualGradients)

7478

7579prop_lstm_reference_backwards_input =

7680 property $ do

7781 input :: S.R 3 <- forAll randomVector

7882 cell :: S.R 2 <- forAll randomVector

7983 net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

80− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

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))

8187 case actualBacks of

8288 (_, _, S1D actualGradients :: S ('D1 3)) ->

8389 let refNet = Reference.lstmToReference lstmWeights

8490 refCell = Reference.Vector . H.toList . S.extract $ cell

8591 refInput = Reference.Vector . H.toList . S.extract $ input

8692 refGradients = Reference.runLSTMbackOnInput refCell refNet refInput

87− in assert $ toList refGradients ~~~ H.toList (S.extract actualGradients)

93+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

8894

8995prop_lstm_reference_backwards_cell =

9096 property $ do

9197 input :: S.R 3 <- forAll randomVector

9298 cell :: S.R 2 <- forAll randomVector

9399 net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

94− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

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))

95103 case actualBacks of

96104 (_, S1D actualGradients, _ :: S ('D1 3)) ->

97105 let refNet = Reference.lstmToReference lstmWeights

98106 refCell = Reference.Vector . H.toList . S.extract $ cell

99107 refInput = Reference.Vector . H.toList . S.extract $ input

100108 refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

101− in assert $ toList refGradients ~~~ H.toList (S.extract actualGradients)

102−

103−

104−(~~~) as bs = all (< 1e-8) (zipWith (-) as bs)

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) ""

105127infix 4 ~~~

106128

107129tests :: IO Bool

108−tests = $$(checkConcurrent)

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/Compat.hsdeleted−16

@@ -1,16 +0,0 @@

1−{-# LANGUAGE RankNTypes #-}

2−module Test.Jack.Compat where

3−

4−import Hedgehog

5−import qualified Hedgehog.Gen as Gen

6−import qualified Hedgehog.Range as Range

7−

8−type Jack x = forall m. Monad m => Gen m x

9−

10−(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

11−(...) = (.) . (.)

12−{-# INLINE (...) #-}

13−

14−choose :: Integral a => a -> a -> Jack a

15−choose = Gen.integral ... Range.constant

16−

test/Test/Jack/Hmatrix.hsdeleted−31

@@ -1,31 +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 qualified Hedgehog.Gen as Gen

12−import qualified Hedgehog.Range as Range

13−

14−import GHC.TypeLits

15−

16−import qualified Numeric.LinearAlgebra.Static as HStatic

17−import Test.Jack.Compat

18−

19−randomVector :: forall n. KnownNat n => Jack (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) => Jack (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 ) => Jack (S x)

27−genOfShape =

28− case (sing :: Sing x) of

29− D1Sing -> S1D <$> randomVector

30− D2Sing -> S2D <$> uniformSample

31− D3Sing -> S3D <$> uniformSample

test/Test/Jack/TypeLits.hsdeleted−62

@@ -1,62 +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−

14−import qualified Hedgehog.Gen as Gen

15−

16−import Grenade

17−

18−import GHC.TypeLits

19−import GHC.TypeLits.Witnesses

20−import Test.Jack.Compat

21−

22−genNat :: Jack SomeNat

23−genNat = do

24− Just n <- someNatVal <$> choose 1 10

25− return n

26−

27−#if __GLASGOW_HASKELL__ < 800

28−type Shape' = ('KProxy :: KProxy Shape)

29−#else

30−type Shape' = Shape

31−#endif

32−

33−genShape :: Jack (SomeSing Shape')

34−genShape

35− = Gen.choice [

36− genD1

37− , genD2

38− , genD3

39− ]

40−

41−genD1 :: Jack (SomeSing Shape')

42−genD1 = do

43− n <- genNat

44− return $ case n of

45− SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

46−

47−genD2 :: Jack (SomeSing Shape')

48−genD2 = do

49− n <- genNat

50− m <- genNat

51− return $ case (n, m) of

52− (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

53−

54−genD3 :: Jack (SomeSing Shape')

55−genD3 = do

56− n <- genNat

57− m <- genNat

58− o <- genNat

59− return $ case (n, m, o) of

60− (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->

61− case natDict px %* natDict pz of

62− Dict -> SomeSing (sing :: Sing ('D3 x y z))

test/test.hs+6−1

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

11import Control.Monad

22

3+import qualified Test.Grenade.Network

4+

35import qualified Test.Grenade.Layers.Pooling

46import qualified Test.Grenade.Layers.Convolution

57import qualified Test.Grenade.Layers.FullyConnected

@@ -17,7 +19,9 @@ import System.IO

1719main :: IO ()

1820main =

1921 disorderMain [

20− Test.Grenade.Layers.Pooling.tests

22+ Test.Grenade.Network.tests

23+

24+ , Test.Grenade.Layers.Pooling.tests

2125 , Test.Grenade.Layers.Convolution.tests

2226 , Test.Grenade.Layers.FullyConnected.tests

2327 , Test.Grenade.Layers.Nonlinear.tests

@@ -27,6 +31,7 @@ main =

2731 , Test.Grenade.Layers.Internal.Pooling.tests

2832

2933 , Test.Grenade.Recurrent.Layers.LSTM.tests

34+

3035 ]

3136

3237disorderMain :: [IO Bool] -> IO ()