master..9509719 · grenade

.gitignore+1−3

since splitsnapshots

unifiedsplit

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

1−cabal.project.local

2.cabal-sandbox/

1.cabal-sandbox/

3cabal.sandbox.config

2cabal.sandbox.config

4dist/

3dist/

5−dist-newstyle/

4+

6−.stack-work/

.travis.yml+10−12

@@ -2,30 +2,28 @@

2

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

4env:

5+ - CABALVER=1.22 GHCVER=7.10.3

5− - GHCVER=8.0.2

6+ - CABALVER=1.24 GHCVER=8.0.1

6− - GHCVER=8.2.2

7− - GHCVER=8.4.4

8− - GHCVER=8.6.5

9− - GHCVER=8.8.3

10− - GHCVER=8.10.1

11

7

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

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

13before_install:

9before_install:

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

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

15 - travis_retry sudo apt-get update

11 - travis_retry sudo apt-get update

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

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

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

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

18

14

19install:

15install:

16+ - cabal --version

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

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

21− - travis_retry cabal-3.2 update

18+ - travis_retry cabal update

19+ - cabal sandbox init

20+ - cabal install --enable-tests --enable-benchmarks

22

21

23notifications:

22notifications:

24 email: false

23 email: false

25

24

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

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

27script:

26script:

28− - cabal-3.2 configure --enable-tests

29− - cabal-3.2 build all

27+ - cabal build

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

28+ - cabal test --show-details=streaming

31

29

README.md+4−6

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

3

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

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

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

7

6

8

7

9```

8```

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

24type MNIST

23type MNIST

25 = Network

24 = Network

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

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

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

26+ , Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, FlattenLayer, Relu

28 , FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]

27 , FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]

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

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

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

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

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

89```

88```

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

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

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

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

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

91+appropriate for each layer, and may be trivial for layers like `Rulu` which

93have no learnable parameters.

92have no learnable parameters.

94

93

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

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

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

159./mafia test

158./mafia test

160```

159```

161

160

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

161+Grenade builds with ghc 7.10 and 8.0.

163

162

164Thanks

163Thanks

165------

164------

@@ -188,5 +187,4 @@ Contributions are welcome.

188

187

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

188 [hackage]: http://hackage.haskell.org/package/grenade

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

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

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

190+

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

bench/bench-lstm.hs+45−4

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

5

6import Grenade

7import Grenade.Recurrent

8+import Grenade.Layers.Internal.Update

9+

10+import qualified Numeric.LinearAlgebra.Static as H

8

11

9main :: IO ()

12main :: IO ()

10main = do

13main = do

14+ layer60 :: LSTM 40 60 <- createRandom

15+ layer512 :: LSTM 40 512 <- createRandom

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

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

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

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

12− lstm :: RecNet <- randomRecurrent

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

13

23

14 defaultMain [

24 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+ ]

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

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

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

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

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

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

18 ]

36 ]

19 ]

37 ]

20

38

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+

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

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

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

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

23

59

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

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

62+

24

63

25type R = Recurrent

64type R = Recurrent

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

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

27 '[ 'D1 40, 'D1 512, 'D1 40 ]

66 '[ 'D1 40, 'D1 512, 'D1 40 ]

28

67

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

69+

29lp :: LearningParameters

70lp :: LearningParameters

30lp = LearningParameters 0.1 0 0

71lp = LearningParameters 0.1 0 0

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

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

1−#include "gradient_descent.h"

1+#include "gradient_decent.h"

2

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

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

4 const double* weights,

5 const double* gradient,

6 const double* last,

7 double* outputWeights, double* outputMomentum) {

8

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

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

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

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

12 }

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

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

1#include <stdio.h>

2#include <stdint.h>

3

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

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

5 const double* weights,

6 const double* gradient,

7 const double* last,

examples/grenade-examples.cabal+9−10

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

26 , bytestring

27 , cereal

28 , either

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

29+ , optparse-applicative == 0.13.*

30 , text == 1.2.*

31 , mtl >= 2.2.1 && < 2.3

32 , hmatrix

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

42 , grenade

43 , attoparsec

44 , either

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

45+ , optparse-applicative == 0.13.*

46 , text == 1.2.*

47 , mtl >= 2.2.1 && < 2.3

48− , hmatrix >= 0.18 && < 0.21

48+ , hmatrix >= 0.18 && < 0.19

49 , transformers

50 , semigroups

51 , singletons

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

61 , bytestring

62 , cereal

63 , either

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

64+ , optparse-applicative == 0.13.*

65 , text == 1.2.*

66 , mtl >= 2.2.1 && < 2.3

67− , hmatrix >= 0.18 && < 0.21

67+ , hmatrix >= 0.18 && < 0.19

68 , transformers

69 , semigroups

70 , singletons

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

78 , grenade

79 , attoparsec

80 , either

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

81+ , optparse-applicative == 0.13.*

82 , text == 1.2.*

83 , mtl >= 2.2.1 && < 2.3

84− , hmatrix >= 0.18 && < 0.21

84+ , hmatrix >= 0.18 && < 0.19

85 , transformers

86 , semigroups

87 , singletons

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

96 , bytestring

97 , cereal

98 , either

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

99+ , optparse-applicative == 0.13.*

100 , text == 1.2.*

101 , mtl >= 2.2.1 && < 2.3

102− , hmatrix >= 0.18 && < 0.21

102+ , hmatrix >= 0.18 && < 0.19

103 , transformers

104 , semigroups

105 , singletons

106− , singletons-base

107 , vector

106 , vector

108 , MonadRandom

107 , MonadRandom

109 , containers

108 , containers

examples/mafiadeleted−62

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

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

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

11

10

12import qualified Data.ByteString as B

11import qualified Data.ByteString as B

13import Data.Serialize

12import Data.Serialize

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

15import Data.Semigroup ( (<>) )

13import Data.Semigroup ( (<>) )

16−#endif

14+

17import GHC.TypeLits

15import GHC.TypeLits

18

16

19import qualified Numeric.LinearAlgebra.Static as SA

17import qualified Numeric.LinearAlgebra.Static as SA

examples/main/gan-mnist.hs−3

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

5{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

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

44import qualified Data.Attoparsec.Text as A

43import qualified Data.Attoparsec.Text as A

45import qualified Data.ByteString as B

44import qualified Data.ByteString as B

46import Data.List ( foldl' )

45import Data.List ( foldl' )

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

48import Data.Semigroup ( (<>) )

46import Data.Semigroup ( (<>) )

49−#endif

50import Data.Serialize

47import Data.Serialize

51import qualified Data.Text as T

48import qualified Data.Text as T

52import qualified Data.Text.IO as T

49import qualified Data.Text.IO as T

examples/main/mnist.hs−4

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

14

13

15import qualified Data.Attoparsec.Text as A

14import qualified Data.Attoparsec.Text as A

16import Data.List ( foldl' )

15import Data.List ( foldl' )

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

18import Data.Semigroup ( (<>) )

16import Data.Semigroup ( (<>) )

19−#endif

20−

21import qualified Data.Text as T

17import qualified Data.Text as T

22import qualified Data.Text.IO as T

18import qualified Data.Text.IO as T

23import qualified Data.Vector.Storable as V

19import qualified Data.Vector.Storable as V

examples/main/recurrent.hs+10−10

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

9import Control.Monad ( foldM )

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

11

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

12+#if __GLASGOW_HASKELL__ < 800

13import Data.List ( unfoldr )

14#else

15import Data.List ( cycle, unfoldr )

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

17#endif

16#endif

17+import Data.Semigroup ( (<>) )

18

19import qualified Numeric.LinearAlgebra.Static as SA

20

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

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

32type R = Recurrent

33

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

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

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

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

36

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

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

38

39−randomNet :: MonadRandom m => m RecNet

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

40randomNet = randomRecurrent

41

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

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

69 unfoldr go (s, i)

70 where

71 go (x, y) =

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

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

73− o' = heat o

73+ o' = heat o

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

75

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

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

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

83 putStrLn "Training network..."

84

85− net0 <- randomNet

85+ (net0, i0) <- randomNet

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

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

87

88 let results = generateRecurrent trained bestInput (c 1)

89

examples/main/shakespeare.hs+23−26

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

2+{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

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

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

14import Data.List ( foldl' )

15import Data.Maybe ( fromMaybe )

16−

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

17

18import qualified Data.Vector as V

19import Data.Vector ( Vector )

20

21import qualified Data.Map as M

22+import Data.Proxy ( Proxy (..) )

22

23

23import qualified Data.ByteString as B

24import qualified Data.ByteString as B

24import Data.Serialize

25import Data.Serialize

25

26

27+import Data.Singletons.Prelude

26import GHC.TypeLits

28import GHC.TypeLits

27

29

28import Numeric.LinearAlgebra.Static ( konst )

30import Numeric.LinearAlgebra.Static ( konst )

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

34import Grenade.Utils.OneHot

36import Grenade.Utils.OneHot

35

37

36import System.IO.Unsafe ( unsafeInterleaveIO )

38import System.IO.Unsafe ( unsafeInterleaveIO )

37−import Data.Proxy

38−import Prelude.Singletons

39

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

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

42-- about an hour.

43--

44−-- Grab the input from

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

46−--

47-- This is a first class recurrent net.

44-- This is a first class recurrent net.

48--

45--

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

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

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

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

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

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

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

66

63

67−randomNet :: MonadRandom m => m Shakespeare

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

68randomNet = randomRecurrent

65randomNet = randomRecurrent

69

66

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

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

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

72loadShakespeare path = do

69loadShakespeare path = do

73 contents <- lift $ readFile path

70 contents <- lift $ readFile path

74 let annotated = annotateCapitals contents

71 let annotated = annotateCapitals contents

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

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

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

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

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

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

78

75

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

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

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

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

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

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

82 in case reverse e of

79 in case reverse e of

83 (o : l : xs) ->

80 (o : l : xs) ->

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

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

85− in trainRecurrent lrate net recIns examples

82+ in trainRecurrent rate net recIns examples

86 _ -> error "Not enough input"

83 _ -> error "Not enough input"

87 where

84 where

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

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

89

86

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

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

91−runShakespeare opts = do

88+runShakespeare ShakespeareOpts {..} = do

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

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

93 (net0, i0) <- lift $

90 (net0, i0) <- lift $

94− case loadPath opts of

91+ case loadPath of

95 Just loadFile -> netLoad loadFile

92 Just loadFile -> netLoad loadFile

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

93+ Nothing -> randomNet

97

94

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

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

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

96+ xs <- take (iterations `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

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

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

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

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

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

103 putStrLn (unAnnotateCapitals results)

100 putStrLn (unAnnotateCapitals results)

104 return (trained, bestInput)

101 return (trained, bestInput)

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

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

106

103

107− case savePath opts of

104+ case savePath of

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

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

109 Nothing -> return ()

106 Nothing -> return ()

110

107

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

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

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

116 -> Vector a

113 -> Vector a

117 -> S ('D1 n)

114 -> S ('D1 n)

118 -> IO [a]

115 -> IO [a]

119−generateParagraph n s temp hotmap hotdict =

116+generateParagraph n s temperature hotmap hotdict =

120 go s

117 go s

121 where

118 where

122 go x y =

119 go x y =

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

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

124− un <- sample temp hotdict o

121+ un <- sample temperature hotdict o

125− Just re <- return $ makeHot hotmap un

122+ Just re <- return $ makeHot hotmap un

126− rest <- unsafeInterleaveIO $ go ns re

123+ rest <- unsafeInterleaveIO $ go ns re

127 return (un : rest)

124 return (un : rest)

128

125

129data ShakespeareOpts = ShakespeareOpts {

126data ShakespeareOpts = ShakespeareOpts {

framework/mafiadeleted−62

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

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+23−39

@@ -7,7 +7,7 @@ maintainer: Huw Campbell <huw.campbell@gmail.com>

8synopsis: Practical Deep Learning in Haskell

9category: AI, Machine Learning

10−cabal-version: >= 1.10

10+cabal-version: >= 1.8

11build-type: Simple

12description:

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

@@ -17,7 +17,7 @@ description:

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

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

19 networks with reverse automatic differentiation to calculate their

20− gradients; and applying gradient descent for learning.

20+ gradients; and applying gradient decent for learning.

21 .

22 Documentation and examples are available on github

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

@@ -26,8 +26,8 @@ extra-source-files:

26 README.md

27 cbits/im2col.h

28 cbits/im2col.c

29− cbits/gradient_descent.h

29+ cbits/gradient_decent.h

30− cbits/gradient_descent.c

30+ cbits/gradient_decent.c

31 cbits/pad.h

32 cbits/pad.c

33

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

38library

39 build-depends:

40 base >= 4.8 && < 5

41− , bytestring >= 0.10.0

41+ , bytestring == 0.10.*

42− , containers >= 0.5 && < 0.7

42+ , containers >= 0.5 && < 0.6

43 , cereal >= 0.5 && < 0.6

44 , deepseq >= 1.4 && < 1.5

45+ , exceptions == 0.8.*

45− , hmatrix >= 0.18 && < 0.21

46+ , hmatrix == 0.18.*

46 , MonadRandom >= 0.4 && < 0.6

47 , MonadRandom >= 0.4 && < 0.6

48+ , mtl >= 2.2.1 && < 2.3

47− , primitive >= 0.6 && < 0.8

49+ , primitive >= 0.6 && < 0.7

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

50+ , text == 1.2.*

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

51+ , singletons >= 2.1 && < 2.3

50− , singletons

51− , singletons-base

52 , vector >= 0.11 && < 0.13

53

54 ghc-options:

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

56 hs-source-dirs:

57 src

58

59− default-language: Haskell2010

60−

61 if impl(ghc < 8.0)

59 if impl(ghc < 8.0)

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

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

63− cpp-options: -DType=*

64

61

65− if impl(ghc >= 8.6)

66− default-extensions: NoStarIsType

67

62

68 exposed-modules:

63 exposed-modules:

69 Grenade

64 Grenade

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

89 Grenade.Layers.Pooling

84 Grenade.Layers.Pooling

90 Grenade.Layers.Relu

85 Grenade.Layers.Relu

91 Grenade.Layers.Reshape

86 Grenade.Layers.Reshape

92− Grenade.Layers.Sinusoid

93 Grenade.Layers.Softmax

87 Grenade.Layers.Softmax

94 Grenade.Layers.Tanh

88 Grenade.Layers.Tanh

95 Grenade.Layers.Trivial

89 Grenade.Layers.Trivial

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

108

102

109 Grenade.Recurrent.Layers

103 Grenade.Recurrent.Layers

110 Grenade.Recurrent.Layers.BasicRecurrent

104 Grenade.Recurrent.Layers.BasicRecurrent

111− Grenade.Recurrent.Layers.ConcatRecurrent

112 Grenade.Recurrent.Layers.LSTM

105 Grenade.Recurrent.Layers.LSTM

113

106

114 Grenade.Utils.OneHot

107 Grenade.Utils.OneHot

115

108

116 includes: cbits/im2col.h

109 includes: cbits/im2col.h

117− cbits/gradient_descent.h

110+ cbits/gradient_decent.h

118 cbits/pad.h

111 cbits/pad.h

119 c-sources: cbits/im2col.c

112 c-sources: cbits/im2col.c

120− cbits/gradient_descent.c

113+ cbits/gradient_decent.c

121 cbits/pad.c

114 cbits/pad.c

122

115

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

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

@@ -132,7 +125,6 @@ test-suite test

132 hs-source-dirs:

125 hs-source-dirs:

133 test

126 test

134

127

135− default-language: Haskell2010

136

128

137 other-modules: Test.Hedgehog.Compat

129 other-modules: Test.Hedgehog.Compat

138 Test.Hedgehog.Hmatrix

130 Test.Hedgehog.Hmatrix

@@ -153,20 +145,16 @@ test-suite test

153

145

154 if impl(ghc < 8.0)

146 if impl(ghc < 8.0)

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

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

156− cpp-options: -DType=*

157−

158− if impl(ghc >= 8.6)

159− default-extensions: NoStarIsType

160

148

161 build-depends:

149 build-depends:

162− base

150+ base >= 4.8 && < 5

163 , grenade

151 , grenade

164− , hedgehog >= 1.0 && < 1.1

152+ , hedgehog >= 0.1 && < 0.2

165 , hmatrix

153 , hmatrix

166 , mtl

154 , mtl

167 , singletons

155 , singletons

168 , text == 1.2.*

156 , text == 1.2.*

169− , typelits-witnesses < 0.4

157+ , typelits-witnesses

170 , transformers

158 , transformers

171 , constraints

159 , constraints

172 , MonadRandom

160 , MonadRandom

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

186 hs-source-dirs:

174 hs-source-dirs:

187 bench

175 bench

188

176

189− default-language: Haskell2010

190−

191 build-depends:

177 build-depends:

192− base

178+ base >= 3 && < 5

193− , bytestring

179+ , bytestring == 0.10.*

194− , criterion >= 1.1 && < 1.6

180+ , criterion == 1.1.*

195 , grenade

181 , grenade

196 , hmatrix

182 , hmatrix

197

183

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

205 hs-source-dirs:

191 hs-source-dirs:

206 bench

192 bench

207

193

208− default-language: Haskell2010

209−

210 build-depends:

194 build-depends:

211− base

195+ base >= 3 && < 5

212− , bytestring

196+ , bytestring == 0.10.*

213− , criterion

197+ , criterion == 1.1.*

214 , grenade

198 , grenade

215 , hmatrix

199 , hmatrix

mafiamode 120000 → 100755+123−1

@@ -1 +0,0 @@

1−framework/mafia

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

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

src/Grenade/Core/Layer.hs+3−8

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

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

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

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

21

20

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

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

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

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

24to the input and output data of the layer.

23to the input and output data of the layer.

25

24

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

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

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

42

41

43import Data.List ( foldl' )

42import Data.List ( foldl' )

44

43

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

46−import Data.Kind (Type)

47−#endif

48−

49import Grenade.Core.Shape

44import Grenade.Core.Shape

50import Grenade.Core.LearningParameters

45import Grenade.Core.LearningParameters

51

46

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

55class UpdateLayer x where

50class UpdateLayer x where

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

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

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

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

58− type Gradient x :: Type

53+ type Gradient x :: *

59

54

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

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

61 runUpdate :: LearningParameters -> x -> Gradient x -> x

56 runUpdate :: LearningParameters -> x -> Gradient x -> x

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

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

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

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

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

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

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

80− type Tape x i o :: Type

75+ type Tape x i o :: *

81

76

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

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

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

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

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

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

7-}

8module Grenade.Core.LearningParameters (

9 -- | This module contains learning algorithm specific

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

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

11 -- unstable, due to issue #26.

12

13 LearningParameters (..)

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

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

34import Control.Monad.Random ( MonadRandom )

33import Control.Monad.Random ( MonadRandom )

35

34

36import Data.Singletons

35import Data.Singletons

36+import Data.Singletons.Prelude

37import Data.Serialize

38

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

40−import Data.Kind (Type)

41−#endif

42−

43import Grenade.Core.Layer

39import Grenade.Core.Layer

44import Grenade.Core.LearningParameters

40import Grenade.Core.LearningParameters

45import Grenade.Core.Shape

41import Grenade.Core.Shape

46−import Prelude.Singletons

47

42

48-- | Type of a network.

43-- | Type of a network.

49--

44--

@@ -53,7 +48,7 @@ import Prelude.Singletons

53--

48--

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

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

55-- transform the data shapes of the network.

50-- transform the data shapes of the network.

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

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

57 NNil :: SingI i

52 NNil :: SingI i

58 => Network '[] '[i]

53 => Network '[] '[i]

59

54

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

71-- | Gradient of a network.

66-- | Gradient of a network.

72--

67--

73-- Parameterised on the layers of the network.

68-- Parameterised on the layers of the network.

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

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

75 GNil :: Gradients '[]

70 GNil :: Gradients '[]

76

71

77 (:/>) :: UpdateLayer x

72 (:/>) :: UpdateLayer x

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

82-- | Wegnert Tape of a network.

77-- | Wegnert Tape of a network.

83--

78--

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

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

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

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

86 TNil :: SingI i

81 TNil :: SingI i

87 => Tapes '[] '[i]

82 => Tapes '[] '[i]

88

83

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

144 = (GNil, o)

139 = (GNil, o)

145

140

146

141

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

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

148applyUpdate :: LearningParameters

143applyUpdate :: LearningParameters

149 -> Network layers shapes

144 -> Network layers shapes

150 -> Gradients layers

145 -> Gradients layers

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

157

152

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

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

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

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

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

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

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

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

162 --

157 --

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

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

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

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

13 , runNet

14 ) where

15

16+import Data.Singletons.Prelude

16

17

17import Grenade.Core.LearningParameters

18import Grenade.Core.LearningParameters

18import Grenade.Core.Network

19import Grenade.Core.Network

19import Grenade.Core.Shape

20import Grenade.Core.Shape

20−import Data.Singletons

21−import Prelude.Singletons

22

21

23-- | Perform reverse automatic differentiation on the network

22-- | Perform reverse automatic differentiation on the network

24-- for the current input and expected output.

23-- for the current input and expected output.

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE KindSignatures #-}

3{-# LANGUAGE KindSignatures #-}

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

8{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE UndecidableInstances #-}

12{-|

10{-|

13Module : Grenade.Core.Shape

11Module : Grenade.Core.Shape

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

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

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

19

17

20-}

18-}

21module Grenade.Core.Shape (

19module Grenade.Core.Shape (

20+ Shape (..)

22− S (..)

21+ , S (..)

23− , Shape (..)

22+ , Sing (..)

24− , SShape (..)

23+

25 , randomOfShape

24 , randomOfShape

26 , fromStorable

25 , fromStorable

27 ) where

26 ) where

28

27

29import Control.DeepSeq (NFData (..))

28import Control.DeepSeq (NFData (..))

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

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

31−import Data.Kind (Type)

30+

32import Data.Proxy

31import Data.Proxy

33−import Data.Serialize

34import Data.Singletons

32import Data.Singletons

33+import Data.Singletons.TypeLits

35import Data.Vector.Storable ( Vector )

34import Data.Vector.Storable ( Vector )

36import qualified Data.Vector.Storable as V

35import qualified Data.Vector.Storable as V

36+

37import GHC.TypeLits

38+

38import qualified Numeric.LinearAlgebra.Static as H

39import qualified Numeric.LinearAlgebra.Static as H

39import Numeric.LinearAlgebra.Static

40import Numeric.LinearAlgebra.Static

40import qualified Numeric.LinearAlgebra as NLA

41import qualified Numeric.LinearAlgebra as NLA

@@ -79,27 +80,17 @@ deriving instance Show (S n)

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

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

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

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

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

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

91data instance Sing (n :: Shape) where

83data instance Sing (n :: Shape) where

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

84 D1Sing :: Sing a -> Sing ('D1 a)

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

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

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

95−#endif

96

87

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

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

98− sing = D1Sing

89+ sing = D1Sing sing

99instance (KnownNat a, KnownNat b) => SingI ('D2 a b) where

90instance (KnownNat a, KnownNat b) => SingI ('D2 a b) where

100− sing = D2Sing

91+ sing = D2Sing sing sing

101instance (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => SingI ('D3 a b c) where

92instance (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => SingI ('D3 a b c) where

102− sing = D3Sing

93+ sing = D3Sing sing sing sing

103

94

104instance SingI x => Num (S x) where

95instance SingI x => Num (S x) where

105 (+) = n2 (+)

96 (+) = n2 (+)

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

148randomOfShape = do

139randomOfShape = do

149 seed :: Int <- getRandom

140 seed :: Int <- getRandom

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

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

151− D1Sing ->

142+ D1Sing SNat ->

152 S1D (randomVector seed Uniform * 2 - 1)

143 S1D (randomVector seed Uniform * 2 - 1)

153

144

154− D2Sing ->

145+ D2Sing SNat SNat ->

155 S2D (uniformSample seed (-1) 1)

146 S2D (uniformSample seed (-1) 1)

156

147

157− D3Sing ->

148+ D3Sing SNat SNat SNat ->

158 S3D (uniformSample seed (-1) 1)

149 S3D (uniformSample seed (-1) 1)

159

150

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

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

@@ -162,13 +153,13 @@ randomOfShape = do

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

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

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

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

164fromStorable xs = case sing :: Sing x of

155fromStorable xs = case sing :: Sing x of

165− D1Sing ->

156+ D1Sing SNat ->

166 S1D <$> H.create xs

157 S1D <$> H.create xs

167

158

168− D2Sing ->

159+ D2Sing SNat SNat ->

169 S2D <$> mkL xs

160 S2D <$> mkL xs

170

161

171− D3Sing ->

162+ D3Sing SNat SNat SNat ->

172 S3D <$> mkL xs

163 S3D <$> mkL xs

173 where

164 where

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

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

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

180 then H.create $ NLA.reshape columns v

171 then H.create $ NLA.reshape columns v

181 else Nothing

172 else Nothing

182

173

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−

195-- Helper function for creating the number instances

174-- Helper function for creating the number instances

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

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

197n1 f (S1D x) = S1D (f x)

176n1 f (S1D x) = S1D (f x)

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

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

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

206

185

207-- Helper function for creating the number instances

186-- Helper function for creating the number instances

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

187+nk :: forall x. SingI x => Double -> S x

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

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

210− D1Sing ->

189+ D1Sing SNat ->

211 S1D (konst x)

190 S1D (konst x)

212

191

213− D2Sing ->

192+ D2Sing SNat SNat ->

214 S2D (konst x)

193 S2D (konst x)

215

194

216− D3Sing ->

195+ D3Sing SNat SNat SNat ->

217 S3D (konst x)

196 S3D (konst x)

src/Grenade/Layers/Concat.hs+1−7

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

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

9{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FlexibleInstances #-}

10{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE StandaloneDeriving #-}

10{-# LANGUAGE StandaloneDeriving #-}

12−{-# LANGUAGE UndecidableInstances #-}

13{-|

11{-|

14Module : Grenade.Layers.Concat

12Module : Grenade.Layers.Concat

15Description : Concatenation layer

13Description : Concatenation layer

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

28import Data.Singletons

26import Data.Singletons

29import GHC.TypeLits

27import GHC.TypeLits

30

28

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

32−import Data.Kind (Type)

33−#endif

34−

35import Grenade.Core

29import Grenade.Core

36

30

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

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

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

49--

43--

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

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

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

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

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

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

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

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

54

48

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

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

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE UndecidableInstances #-}

11{-|

10{-|

12Module : Grenade.Layers.Convolution

11Module : Grenade.Layers.Convolution

13Description : Convolution layer

12Description : Convolution layer

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

28import Data.Maybe

27import Data.Maybe

29import Data.Proxy

28import Data.Proxy

30import Data.Serialize

29import Data.Serialize

30+import Data.Singletons.TypeLits

31

32import GHC.TypeLits

33−import Data.Kind (Type)

34

33

35import Numeric.LinearAlgebra hiding ( uniformSample, konst )

34import Numeric.LinearAlgebra hiding ( uniformSample, konst )

36import qualified Numeric.LinearAlgebra as LA

35import qualified Numeric.LinearAlgebra as LA

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

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

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

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

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

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

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

60− -> Type where

59+ -> * where

61 Convolution :: ( KnownNat channels

60 Convolution :: ( KnownNat channels

62 , KnownNat filters

61 , KnownNat filters

63 , KnownNat kernelRows

62 , KnownNat kernelRows

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

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

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

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

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

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

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

79− -> Type where

78+ -> * where

80 Convolution' :: ( KnownNat channels

79 Convolution' :: ( KnownNat channels

81 , KnownNat filters

80 , KnownNat filters

82 , KnownNat kernelRows

81 , KnownNat kernelRows

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

130 , KnownNat strideColumns

129 , KnownNat strideColumns

131 , KnownNat (kernelRows * kernelColumns * channels)

130 , KnownNat (kernelRows * kernelColumns * channels)

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

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

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

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

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

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

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

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

136 in Convolution newKernel newMomentum

135 in Convolution newKernel newMomentum

137

136

138 createRandom = randomConvolution

137 createRandom = randomConvolution

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

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

6{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE UndecidableInstances #-}

10{-|

8{-|

11Module : Grenade.Layers.Crop

9Module : Grenade.Layers.Crop

12Description : Cropping layer

10Description : Cropping layer

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

20

18

21import Data.Maybe

19import Data.Maybe

22import Data.Proxy

20import Data.Proxy

23−import Data.Serialize

21+import Data.Singletons.TypeLits

24−

25import GHC.TypeLits

22import GHC.TypeLits

26−import Data.Kind (Type)

27

23

28import Grenade.Core

24import Grenade.Core

29import Grenade.Layers.Internal.Pad

25import Grenade.Layers.Internal.Pad

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

35data Crop :: Nat

31data Crop :: Nat

36 -> Nat

32 -> Nat

37 -> Nat

33 -> Nat

38− -> Nat -> Type where

34+ -> Nat -> * where

39 Crop :: Crop cropLeft cropTop cropRight cropBottom

35 Crop :: Crop cropLeft cropTop cropRight cropBottom

40

36

41instance Show (Crop cropLeft cropTop cropRight cropBottom) where

37instance Show (Crop cropLeft cropTop cropRight cropBottom) where

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

46 runUpdate _ x _ = x

42 runUpdate _ x _ = x

47 createRandom = return Crop

43 createRandom = return Crop

48

44

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

50− put _ = return ()

51− get = return Crop

52−

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

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

54instance ( KnownNat cropLeft

46instance ( KnownNat cropLeft

55 , KnownNat cropTop

47 , KnownNat cropTop

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

59 , KnownNat inputColumns

51 , KnownNat inputColumns

60 , KnownNat outputRows

52 , KnownNat outputRows

61 , KnownNat outputColumns

53 , KnownNat outputColumns

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

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

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

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

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

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

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

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

66 runForwards Crop (S2D input) =

58 runForwards Crop (S2D input) =

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE UndecidableInstances #-}

11{-|

10{-|

12Module : Grenade.Layers.Deconvolution

11Module : Grenade.Layers.Deconvolution

13Description : Deconvolution layer

12Description : Deconvolution layer

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

32import Data.Maybe

31import Data.Maybe

33import Data.Proxy

32import Data.Proxy

34import Data.Serialize

33import Data.Serialize

34+import Data.Singletons.TypeLits

35

36import GHC.TypeLits

37−import Data.Kind (Type)

38

37

39import Numeric.LinearAlgebra hiding ( uniformSample, konst )

38import Numeric.LinearAlgebra hiding ( uniformSample, konst )

40import qualified Numeric.LinearAlgebra as LA

39import qualified Numeric.LinearAlgebra as LA

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

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

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

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

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

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

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

59− -> Type where

58+ -> * where

60 Deconvolution :: ( KnownNat channels

59 Deconvolution :: ( KnownNat channels

61 , KnownNat filters

60 , KnownNat filters

62 , KnownNat kernelRows

61 , KnownNat kernelRows

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

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

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

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

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

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

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

78− -> Type where

77+ -> * where

79 Deconvolution' :: ( KnownNat channels

78 Deconvolution' :: ( KnownNat channels

80 , KnownNat filters

79 , KnownNat filters

81 , KnownNat kernelRows

80 , KnownNat kernelRows

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

129 , KnownNat strideColumns

128 , KnownNat strideColumns

130 , KnownNat (kernelRows * kernelColumns * filters)

129 , KnownNat (kernelRows * kernelColumns * filters)

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

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

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

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

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

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

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

133+ let (newKernel, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldKernel kernelGradient oldMomentum

135 in Deconvolution newKernel newMomentum

134 in Deconvolution newKernel newMomentum

136

135

137 createRandom = randomDeconvolution

136 createRandom = randomDeconvolution

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

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

36 get = return Elu

37

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

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

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

40

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

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

42 where

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

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

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

45 where

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

47

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

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

1{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

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

13

14

14import Data.Proxy

15import Data.Proxy

15import Data.Serialize

16import Data.Serialize

17+import Data.Singletons.TypeLits

16

18

17import qualified Numeric.LinearAlgebra as LA

19import qualified Numeric.LinearAlgebra as LA

18import Numeric.LinearAlgebra.Static

20import Numeric.LinearAlgebra.Static

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

20import Grenade.Core

22import Grenade.Core

21

23

22import Grenade.Layers.Internal.Update

24import Grenade.Layers.Internal.Update

23−import GHC.TypeLits

24

25

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

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

26data FullyConnected i o = FullyConnected

27data FullyConnected i o = FullyConnected

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

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

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

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

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

39

40

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

41+ runUpdate LearningParameters {..} (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+ let (newBias, newBiasMomentum) = decendVector learningRate learningMomentum learningRegulariser oldBias biasGradient oldBiasMomentum

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

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

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

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

44

45

45 createRandom = randomFullyConnected

46 createRandom = randomFullyConnected

46

47

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

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

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

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

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

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

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

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

51

52

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

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

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

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

54 let wB' = dEdy

55 let wB' = dEdy

55 mm' = dEdy `outer` x

56 mm' = dEdy `outer` x

56 -- calcluate derivatives for next step

57 -- calcluate derivatives for next step

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

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

1{-# LANGUAGE ForeignFunctionInterface #-}

2module Grenade.Layers.Internal.Update (

3− descendMatrix

3+ decendMatrix

4− , descendVector

4+ , decendVector

5 ) where

6

7import Data.Maybe ( fromJust )

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

17

18import System.IO.Unsafe ( unsafePerformIO )

19

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

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−descendMatrix rate momentum regulariser weights gradient lastUpdate =

21+decendMatrix rate momentum regulariser weights gradient lastUpdate =

22 let (rows, cols) = size weights

23 len = rows * cols

24 -- Most gradients come in in ColumnMajor,

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

29 weights' = flatten . tr . extract $ weights

30 gradient' = flatten . tr . extract $ gradient

31 lastUpdate' = flatten . tr . extract $ lastUpdate

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

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

33

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

35 -- using the internal vectors.

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

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

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

39

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

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

41−descendVector rate momentum regulariser weights gradient lastUpdate =

41+decendVector rate momentum regulariser weights gradient lastUpdate =

42 let len = size weights

43 weights' = extract weights

44 gradient' = extract gradient

45 lastUpdate' = extract lastUpdate

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

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

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

48

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

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

50−descendUnsafe len rate momentum regulariser weights gradient lastUpdate =

50+decendUnsafe len rate momentum regulariser weights gradient lastUpdate =

51 unsafePerformIO $ do

52 outWPtr <- mallocForeignPtrArray len

53 outMPtr <- mallocForeignPtrArray len

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

60 withForeignPtr lPtr $ \lPtr' ->

61 withForeignPtr outWPtr $ \outWPtr' ->

62 withForeignPtr outMPtr $ \outMPtr' ->

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

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

64

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

66

67foreign import ccall unsafe

68− descend_cpu

68+ decend_cpu

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

70

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

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

34 createRandom = return Logit

35

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

37− -- Wengert tape optimisation:

38− --

39− -- Derivative of the sigmoid function is

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

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

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

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

44 type Tape Logit a b = S a

37 type Tape Logit a b = S a

45− runForwards _ a =

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

46− let l = sigmoid a

47− in (l, l)

48− runBackwards _ l g =

39+ runBackwards _ a g = ((), logistic' a * g)

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

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

51

40

52instance Serialize Logit where

41instance Serialize Logit where

53 put _ = return ()

42 put _ = return ()

54 get = return Logit

43 get = return Logit

55

44

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

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

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

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

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

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

24

23

25import Data.Singletons

24import Data.Singletons

26

25

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

28−import Data.Kind (Type)

29−#endif

30−

31import Grenade.Core

26import Grenade.Core

32

27

33-- | A Merging layer.

28-- | A Merging layer.

34--

29--

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

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

36-- shape.

31-- shape.

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

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

38 Merge :: x -> y -> Merge x y

33 Merge :: x -> y -> Merge x y

39

34

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

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

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

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

6{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

9−{-# LANGUAGE UndecidableInstances #-}

10{-|

8{-|

11Module : Grenade.Core.Pad

9Module : Grenade.Core.Pad

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

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

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

21import Data.Maybe

19import Data.Maybe

22import Data.Proxy

20import Data.Proxy

23import Data.Serialize

21import Data.Serialize

24−

22+import Data.Singletons.TypeLits

25import GHC.TypeLits

23import GHC.TypeLits

26−import Data.Kind (Type)

27

24

28import Grenade.Core

25import Grenade.Core

29import Grenade.Layers.Internal.Pad

26import Grenade.Layers.Internal.Pad

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

37data Pad :: Nat

34data Pad :: Nat

38 -> Nat

35 -> Nat

39 -> Nat

36 -> Nat

40− -> Nat -> Type where

37+ -> Nat -> * where

41 Pad :: Pad padLeft padTop padRight padBottom

38 Pad :: Pad padLeft padTop padRight padBottom

42

39

43instance Show (Pad padLeft padTop padRight padBottom) where

40instance Show (Pad padLeft padTop padRight padBottom) where

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

52 put _ = return ()

49 put _ = return ()

53 get = return Pad

50 get = return Pad

54

51

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

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

56instance ( KnownNat padLeft

53instance ( KnownNat padLeft

57 , KnownNat padTop

54 , KnownNat padTop

58 , KnownNat padRight

55 , KnownNat padRight

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

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

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

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

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

84

81

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

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

86instance ( KnownNat padLeft

83instance ( KnownNat padLeft

87 , KnownNat padTop

84 , KnownNat padTop

88 , KnownNat padRight

85 , KnownNat padRight

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE StandaloneDeriving #-}

3{-# LANGUAGE StandaloneDeriving #-}

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

7{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE UndecidableInstances #-}

11{-|

9{-|

12Module : Grenade.Core.Pooling

10Module : Grenade.Core.Pooling

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

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

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

22import Data.Maybe

20import Data.Maybe

23import Data.Proxy

21import Data.Proxy

24import Data.Serialize

22import Data.Serialize

25−

23+import Data.Singletons.TypeLits

26import GHC.TypeLits

24import GHC.TypeLits

27−import Data.Kind (Type)

28

25

29import Grenade.Core

26import Grenade.Core

30import Grenade.Layers.Internal.Pooling

27import Grenade.Layers.Internal.Pooling

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

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

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

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

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

41--

38--

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

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

43 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

40 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

44

41

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

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

46 show Pooling = "Pooling"

43 show Pooling = "Pooling"

47

44

48instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

45instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

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

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

50 runUpdate _ Pooling _ = Pooling

47 runUpdate _ Pooling _ = Pooling

51 createRandom = return Pooling

48 createRandom = return Pooling

52

49

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

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

3{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE UndecidableInstances #-}

7{-|

6{-|

8Module : Grenade.Layers.Reshape

7Module : Grenade.Layers.Reshape

9Description : Multipurpose reshaping layer

8Description : Multipurpose reshaping layer

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

17

16

18import Data.Serialize

17import Data.Serialize

19

18

19+import Data.Singletons.TypeLits

20import GHC.TypeLits

21

22import Numeric.LinearAlgebra.Static

src/Grenade/Layers/Sinusoid.hsdeleted−39

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

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

1{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE TypeOperators #-}

6{-|

7Module : Grenade.Layers.Tanh

8Description : Hyperbolic tangent nonlinear layer

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

20import Grenade.Core

21

22-- | A Tanh layer.

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

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

24data Tanh = Tanh

25 deriving Show

26

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

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

9 , RecurrentUpdateLayer (..)

8 , RecurrentUpdateLayer (..)

10 ) where

9 ) where

11

10

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

13−import Data.Kind (Type)

11+import Data.Singletons ( SingI )

14−#endif

15

12

16import Grenade.Core

13import Grenade.Core

17

14

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

20-- of an extra recurrent data shape.

17-- of an extra recurrent data shape.

21class UpdateLayer x => RecurrentUpdateLayer x where

18class UpdateLayer x => RecurrentUpdateLayer x where

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

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

23− type RecurrentShape x :: Type

20+ type RecurrentShape x :: Shape

24

21

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

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

26 -- | Wengert Tape

23 -- | Wengert Tape

27− type RecTape x i o :: Type

24+ type RecTape x i o :: *

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

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

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

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

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

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

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

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

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

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

33 -- the layer above.

30 -- the layer above.

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

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

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

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

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

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

18

17

19 , RecurrentNetwork (..)

18 , RecurrentNetwork (..)

20 , RecurrentInputs (..)

19 , RecurrentInputs (..)

21− , RecurrentTape (..)

20+ , RecurrentTapes (..)

22− , RecurrentGradient (..)

21+ , RecurrentGradients (..)

23

22

24 , randomRecurrent

23 , randomRecurrent

25− , runRecurrent

24+ , runRecurrentNetwork

26− , runRecurrent'

25+ , runRecurrentGradient

27 , applyRecurrentUpdate

26 , applyRecurrentUpdate

28 ) where

27 ) where

29

28

30

29

31import Control.Monad.Random ( MonadRandom )

30import Control.Monad.Random ( MonadRandom )

31+import Data.Singletons ( SingI )

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

32import Data.Serialize

33import Data.Serialize

33−

34+import qualified Data.Vector.Storable as V

34−import Data.Kind (Type)

35

36import Grenade.Core

37import Grenade.Recurrent.Core.Layer

38−import Prelude.Singletons

38+

39+import qualified Numeric.LinearAlgebra as LA

40+import qualified Numeric.LinearAlgebra.Static as LAS

39

41

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

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

41-- forward layer.

43-- forward layer.

42−data FeedForward :: Type -> Type

44+data FeedForward :: * -> *

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

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

44−data Recurrent :: Type -> Type

46+data Recurrent :: * -> *

45

47

46-- | Type of a recurrent neural network.

48-- | Type of a recurrent neural network.

47--

49--

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

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

49--

51--

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

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

51--

53--

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

54--

56--

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

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

56-- for these empty data types.

58-- for these empty data types.

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

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

58 RNil :: SingI i

60 RNil :: SingI i

59 => RecurrentNetwork '[] '[i]

61 => RecurrentNetwork '[] '[i]

60

62

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

73-- | Gradient of a network.

75-- | Gradient of a network.

74--

76--

75-- Parameterised on the layers of the network.

77-- Parameterised on the layers of the network.

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

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

77− RGNil :: RecurrentGradient '[]

79+ RGNil :: RecurrentGradients '[]

78

80

79 (://>) :: UpdateLayer x

81 (://>) :: UpdateLayer x

80− => Gradient x

82+ => [Gradient x]

81− -> RecurrentGradient xs

83+ -> RecurrentGradients xs

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

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

83

85

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

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

85-- Parameterised on the layers of a Network.

87-- Parameterised on the layers of a Network.

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

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

87 RINil :: RecurrentInputs '[]

89 RINil :: RecurrentInputs '[]

88

90

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

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

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

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

91

93

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

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

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

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

94

96

95-- | All the information required to backpropogate

97-- | All the information required to backpropogate

96-- through time safely.

98-- through time safely.

97--

99--

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

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

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

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

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

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

101 TRNil :: SingI i

103 TRNil :: SingI i

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

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

105+

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

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

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

103

109

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

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

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

107

110

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

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

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

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

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

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

111

114

112

115

113−runRecurrent :: forall shapes layers.

116+runRecurrentNetwork :: forall shapes layers.

114− RecurrentNetwork layers shapes

117+ RecurrentNetwork layers shapes

115− -> RecurrentInputs layers

118+ -> RecurrentInputs layers

116− -> S (Head shapes)

119+ -> [S (Head shapes)]

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

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

118−runRecurrent =

121+runRecurrentNetwork =

119 go

122 go

120 where

123 where

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

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

122 => RecurrentNetwork sublayers js

125 => RecurrentNetwork sublayers js

123 -> RecurrentInputs sublayers

126 -> RecurrentInputs sublayers

124− -> S (Head js)

127+ -> [S (Head js)]

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

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

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

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

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

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

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

128−

132+ feedForwardTapes = fst <$> tys

133+ forwards = snd <$> tys

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

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

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

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

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

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

132

137

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

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

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

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

135− go (layer :~@> n) (recIn :~@+> nIn) !x

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

136− = let (tape, shape, forwards) = runRecurrentForwards layer recIn x

141+ = let (recOut, tys) = goR layer recIn xs

142+ recurrentTapes = fst <$> tys

143+ forwards = snd <$> tys

144+

137 (newFN, ig, answer) = go n nIn forwards

145 (newFN, ig, answer) = go n nIn forwards

138− in (tape :\@> newFN, shape :~@+> ig, answer)

146+ in (recurrentTapes :\@> newFN, recOut :~@+> ig, answer)

139

147

140 -- Handle the output layer, bouncing the derivatives back down.

148 -- Handle the output layer, bouncing the derivatives back down.

141 -- We may not have a target for each example, so when we don't use 0 gradient.

149 -- We may not have a target for each example, so when we don't use 0 gradient.

142 go RNil RINil !x

150 go RNil RINil !x

143 = (TRNil, RINil, x)

151 = (TRNil, RINil, x)

144

152

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+

145−runRecurrent' :: forall layers shapes.

161+runRecurrentGradient :: forall layers shapes.

146− RecurrentNetwork layers shapes

162+ RecurrentNetwork layers shapes

147− -> RecurrentTape layers shapes

163+ -> RecurrentTapes layers shapes

148− -> RecurrentInputs layers

164+ -> RecurrentInputs layers

149− -> S (Last shapes)

165+ -> [S (Last shapes)]

150− -> (RecurrentGradient layers, RecurrentInputs layers, S (Head shapes))

166+ -> (RecurrentGradients layers, RecurrentInputs layers, [S (Head shapes)])

151−runRecurrent' net tapes r o =

167+runRecurrentGradient net tapes r o =

152 go net tapes r

168 go net tapes r

153 where

169 where

154 -- We have to be careful regarding the direction of the lists

170 -- We have to be careful regarding the direction of the lists

@@ -156,41 +172,51 @@ runRecurrent' net tapes r o =

156 -- through time.

172 -- through time.

157 go :: forall js ss. (Last js ~ Last shapes)

173 go :: forall js ss. (Last js ~ Last shapes)

158 => RecurrentNetwork ss js

174 => RecurrentNetwork ss js

159− -> RecurrentTape ss js

175+ -> RecurrentTapes ss js

160 -> RecurrentInputs ss

176 -> RecurrentInputs ss

161− -> (RecurrentGradient ss, RecurrentInputs ss, S (Head js))

177+ -> (RecurrentGradients ss, RecurrentInputs ss, [S (Head js)])

162 -- This is a simple non-recurrent layer

178 -- This is a simple non-recurrent layer

163− -- Run the rest of the network, update with the tapes and gradients

179+ -- Run the rest of the network, then fmap the tapes and gradients

164− go (!layer :~~> n) (!tape :\~> nTapes) (() :~~+> nRecs) =

180+ go (layer :~~> n) (feedForwardTapes :\~> nTapes) (() :~~+> nRecs) =

165− let (!gradients, !rins, !feed) = go n nTapes nRecs

181+ let (gradients, rins, feed) = go n nTapes nRecs

166− (!grad, !back) = runBackwards layer tape feed

182+ backs = uncurry (runBackwards layer) <$> zip (reverse feedForwardTapes) feed

167− in (grad ://> gradients, () :~~+> rins, back)

183+ in ((fst <$> backs) ://> gradients, () :~~+> rins, snd <$> backs)

168

184

169 -- This is a recurrent layer

185 -- This is a recurrent layer

170 -- Run the rest of the network, scan over the tapes in reverse

186 -- Run the rest of the network, scan over the tapes in reverse

171− go (!layer :~@> n) (!tape :\@> nTapes) (!recGrad :~@+> nRecs) =

187+ go (layer :~@> n) (recurrentTapes :\@> nTapes) (recGrad :~@+> nRecs) =

172− let (!gradients, !rins, !feed) = go n nTapes nRecs

188+ let (gradients, rins, feed) = go n nTapes nRecs

173− (!grad, !sidegrad, !back) = runRecurrentBackwards layer tape recGrad feed

189+ backExamples = zip (reverse recurrentTapes) feed

190+ (rg, backs) = goX layer recGrad backExamples

174− in (grad ://> gradients, sidegrad :~@+> rins, back)

191+ in ((fst <$> backs) ://> gradients, rg :~@+> rins, snd <$> backs)

175

192

176 -- End of the road, so we reflect the given gradients backwards.

193 -- End of the road, so we reflect the given gradients backwards.

177 -- Crucially, we reverse the list, so it's backwards in time as

194 -- Crucially, we reverse the list, so it's backwards in time as

178 -- well.

195 -- well.

179− go !RNil !TRNil !RINil

196+ go RNil TRNil RINil

180− = (RGNil, RINil, o)

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, [])

181

207

182-- | Apply a batch of gradients to the network

208-- | Apply a batch of gradients to the network

183-- Uses runUpdates which can be specialised for

209-- Uses runUpdates which can be specialised for

184-- a layer.

210-- a layer.

185applyRecurrentUpdate :: LearningParameters

211applyRecurrentUpdate :: LearningParameters

186 -> RecurrentNetwork layers shapes

212 -> RecurrentNetwork layers shapes

187− -> RecurrentGradient layers

213+ -> RecurrentGradients layers

188 -> RecurrentNetwork layers shapes

214 -> RecurrentNetwork layers shapes

189applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)

215applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)

190− = runUpdate rate layer gradient :~~> applyRecurrentUpdate rate rest grest

216+ = runUpdates rate layer gradient :~~> applyRecurrentUpdate rate rest grest

191

217

192applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)

218applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)

193− = runUpdate rate layer gradient :~@> applyRecurrentUpdate rate rest grest

219+ = runUpdates rate layer gradient :~@> applyRecurrentUpdate rate rest grest

194

220

195applyRecurrentUpdate _ RNil RGNil

221applyRecurrentUpdate _ RNil RGNil

196 = RNil

222 = RNil

@@ -206,25 +232,26 @@ instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recu

206

232

207-- | A network can easily be created by hand with (:~~>) and (:~@>), but an easy way to initialise a random

233-- | A network can easily be created by hand with (:~~>) and (:~@>), but an easy way to initialise a random

208-- recurrent network and a set of random inputs for it is with the randomRecurrent.

234-- recurrent network and a set of random inputs for it is with the randomRecurrent.

209−class CreatableRecurrent (xs :: [Type]) (ss :: [Shape]) where

235+class CreatableRecurrent (xs :: [*]) (ss :: [Shape]) where

210 -- | Create a network of the types requested

236 -- | Create a network of the types requested

211− randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss)

237+ randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss, RecurrentInputs xs)

212

238

213instance SingI i => CreatableRecurrent '[] '[i] where

239instance SingI i => CreatableRecurrent '[] '[i] where

214 randomRecurrent =

240 randomRecurrent =

215− return RNil

241+ return (RNil, RINil)

216

242

217instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where

243instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where

218 randomRecurrent = do

244 randomRecurrent = do

219 thisLayer <- createRandom

245 thisLayer <- createRandom

220− rest <- randomRecurrent

246+ (rest, resti) <- randomRecurrent

221− return (thisLayer :~~> rest)

247+ return (thisLayer :~~> rest, () :~~+> resti)

222

248

223instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where

249instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where

224 randomRecurrent = do

250 randomRecurrent = do

225 thisLayer <- createRandom

251 thisLayer <- createRandom

252+ thisShape <- randomOfShape

226− rest <- randomRecurrent

253+ (rest, resti) <- randomRecurrent

227− return (thisLayer :~@> rest)

254+ return (thisLayer :~@> rest, thisShape :~@+> resti)

228

255

229-- | Add very simple serialisation to the recurrent network

256-- | Add very simple serialisation to the recurrent network

230instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where

257instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where

@@ -243,13 +270,23 @@ instance (Serialize (RecurrentInputs '[])) where

243 put _ = return ()

270 put _ = return ()

244 get = return RINil

271 get = return RINil

245

272

246−instance (UpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

273+instance (UpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

247 put ( () :~~+> rest) = put rest

274 put ( () :~~+> rest) = put rest

248 get = ( () :~~+> ) <$> get

275 get = ( () :~~+> ) <$> get

249

276

250−instance (Serialize (RecurrentShape x), Fractional (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

277+instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

251− put ( i :~@+> rest ) = put i >> put rest

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+

252− get = (:~@+>) <$> get <*> get

286+ get = do

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

288+ rest <- get

289+ return ( i :~@+> rest)

253

290

254

291

255-- Num instance for `RecurrentInputs layers`

292-- Num instance for `RecurrentInputs layers`

@@ -270,7 +307,7 @@ instance (Num (RecurrentInputs '[])) where

270 signum _ = RINil

307 signum _ = RINil

271 fromInteger _ = RINil

308 fromInteger _ = RINil

272

309

273−instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where

310+instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where

274 (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)

311 (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)

275 (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)

312 (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)

276 (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)

313 (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)

@@ -278,51 +315,10 @@ instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInpu

278 signum (() :~~+> x) = () :~~+> signum x

315 signum (() :~~+> x) = () :~~+> signum x

279 fromInteger x = () :~~+> fromInteger x

316 fromInteger x = () :~~+> fromInteger x

280

317

281−instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where

318+instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where

282 (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')

319 (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')

283 (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')

320 (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')

284 (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')

321 (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')

285 abs (x :~@+> x') = abs x :~@+> abs x'

322 abs (x :~@+> x') = abs x :~@+> abs x'

286 signum (x :~@+> x') = signum x :~@+> signum x'

323 signum (x :~@+> x') = signum x :~@+> signum x'

287 fromInteger x = fromInteger x :~@+> fromInteger x

324 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+34−54

@@ -6,67 +6,33 @@

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE RecordWildCards #-}

9

10

10module Grenade.Recurrent.Core.Runner (

11module Grenade.Recurrent.Core.Runner (

11− runRecurrentExamples

12+ trainRecurrent

12− , runRecurrentBackprop

13+ , runRecurrent

13 , backPropagateRecurrent

14 , backPropagateRecurrent

14− , trainRecurrent

15−

16− , RecurrentGradients

17 ) where

15 ) where

18

16

19−import Data.List ( foldl' )

17+import Data.Singletons.Prelude

20import Grenade.Core

18import Grenade.Core

21

19

20+import Grenade.Recurrent.Core.Layer

22import Grenade.Recurrent.Core.Network

21import 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−

55

22

56-- | Drive and network and collect its back propogated gradients.

23-- | Drive and network and collect its back propogated gradients.

57−backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

24+backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))

58 => RecurrentNetwork layers shapes

25 => RecurrentNetwork layers shapes

59 -> RecurrentInputs layers

26 -> RecurrentInputs layers

60 -> [(S (Head shapes), Maybe (S (Last shapes)))]

27 -> [(S (Head shapes), Maybe (S (Last shapes)))]

61 -> (RecurrentGradients layers, RecurrentInputs layers)

28 -> (RecurrentGradients layers, RecurrentInputs layers)

62backPropagateRecurrent network recinputs examples =

29backPropagateRecurrent network recinputs examples =

63− let (outForwards, _) = runRecurrentExamples network recinputs inputs

30+ let (tapes, _, guesses) = runRecurrentNetwork network recinputs inputs

64

31

65− backPropagations = zipWith makeError outForwards targets

32+ backPropagations = zipWith makeError guesses targets

66

33

67− (outBackwards, input') = runRecurrentBackprop network 0 backPropagations

34+ (gradients, input', _) = runRecurrentGradient network tapes 0 backPropagations

68

35

69− gradients = fmap fst outBackwards

70 in (gradients, input')

36 in (gradients, input')

71

37

72 where

38 where

@@ -74,12 +40,12 @@ backPropagateRecurrent network recinputs examples =

74 inputs = fst <$> examples

40 inputs = fst <$> examples

75 targets = snd <$> examples

41 targets = snd <$> examples

76

42

77− makeError :: (x, S (Last shapes)) -> Maybe (S (Last shapes)) -> (x, S (Last shapes))

43+ makeError :: S (Last shapes) -> Maybe (S (Last shapes)) -> S (Last shapes)

78− makeError (x, _) Nothing = (x, 0)

44+ makeError _ Nothing = 0

79− makeError (x, y) (Just t) = (x, y - t)

45+ makeError y (Just t) = y - t

80

46

81

47

82−trainRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

48+trainRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))

83 => LearningParameters

49 => LearningParameters

84 -> RecurrentNetwork layers shapes

50 -> RecurrentNetwork layers shapes

85 -> RecurrentInputs layers

51 -> RecurrentInputs layers

@@ -90,21 +56,35 @@ trainRecurrent rate network recinputs examples =

90

56

91 newInputs = updateRecInputs rate recinputs recinputs'

57 newInputs = updateRecInputs rate recinputs recinputs'

92

58

93− newNetwork = foldl' (applyRecurrentUpdate rate) network gradients

59+ newNetwork = applyRecurrentUpdate rate network gradients

94

60

95 in (newNetwork, newInputs)

61 in (newNetwork, newInputs)

96

62

97−updateRecInputs :: Fractional (RecurrentInputs sublayers)

98− => LearningParameters

63+updateRecInputs :: LearningParameters

99 -> RecurrentInputs sublayers

64 -> RecurrentInputs sublayers

100 -> RecurrentInputs sublayers

65 -> RecurrentInputs sublayers

101 -> RecurrentInputs sublayers

66 -> RecurrentInputs sublayers

102

67

103−updateRecInputs lp (() :~~+> xs) (() :~~+> ys)

68+updateRecInputs l@LearningParameters {..} (() :~~+> xs) (() :~~+> ys)

104− = () :~~+> updateRecInputs lp xs ys

69+ = () :~~+> updateRecInputs l xs ys

105

70

106−updateRecInputs lp (x :~@+> xs) (y :~@+> ys)

71+updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)

107− = (realToFrac (1 - learningRate lp * learningRegulariser lp) * x - realToFrac (learningRate lp) * y) :~@+> updateRecInputs lp xs ys

72+ = (realToFrac (1 - learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys

108

73

109updateRecInputs _ RINil RINil

74updateRecInputs _ RINil RINil

110 = RINil

75 = 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,9 +1,7 @@

1module Grenade.Recurrent.Layers (

2 module Grenade.Recurrent.Layers.BasicRecurrent

3− , module Grenade.Recurrent.Layers.ConcatRecurrent

4 , module Grenade.Recurrent.Layers.LSTM

3 , module Grenade.Recurrent.Layers.LSTM

5 ) where

4 ) where

6

5

7import Grenade.Recurrent.Layers.BasicRecurrent

6import Grenade.Recurrent.Layers.BasicRecurrent

8−import Grenade.Recurrent.Layers.ConcatRecurrent

9import Grenade.Recurrent.Layers.LSTM

7import Grenade.Recurrent.Layers.LSTM

src/Grenade/Recurrent/Layers/BasicRecurrent.hs+9−10

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

@@ -16,8 +16,7 @@ module Grenade.Recurrent.Layers.BasicRecurrent (

16

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

18

19−

20−import Data.Kind (Type)

19+import Data.Singletons.TypeLits

21

20

22import Numeric.LinearAlgebra.Static

21import Numeric.LinearAlgebra.Static

23

22

@@ -28,7 +27,7 @@ import Grenade.Recurrent.Core

28

27

29data BasicRecurrent :: Nat -- Input layer size

28data BasicRecurrent :: Nat -- Input layer size

30 -> Nat -- Output layer size

29 -> Nat -- Output layer size

31− -> Type where

30+ -> * where

32 BasicRecurrent :: ( KnownNat input

31 BasicRecurrent :: ( KnownNat input

33 , KnownNat output

32 , KnownNat output

34 , KnownNat matrixCols

33 , KnownNat matrixCols

@@ -41,7 +40,7 @@ data BasicRecurrent :: Nat -- Input layer size

41

40

42data BasicRecurrent' :: Nat -- Input layer size

41data BasicRecurrent' :: Nat -- Input layer size

43 -> Nat -- Output layer size

42 -> Nat -- Output layer size

44− -> Type where

43+ -> * where

45 BasicRecurrent' :: ( KnownNat input

44 BasicRecurrent' :: ( KnownNat input

46 , KnownNat output

45 , KnownNat output

47 , KnownNat matrixCols

46 , KnownNat matrixCols

@@ -56,18 +55,18 @@ instance Show (BasicRecurrent i o) where

56instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

55instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

57 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

56 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

58

57

59− runUpdate lp (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

58+ runUpdate LearningParameters {..} (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

60− let newBiasMomentum = konst (learningMomentum lp) * oldBiasMomentum - konst (learningRate lp) * biasGradient

59+ let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient

61 newBias = oldBias + newBiasMomentum

60 newBias = oldBias + newBiasMomentum

62− newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient

61+ newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient

63− regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations

62+ regulariser = konst (learningRegulariser * learningRate) * oldActivations

64 newActivations = oldActivations + newMomentum - regulariser

63 newActivations = oldActivations + newMomentum - regulariser

65 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

64 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

66

65

67 createRandom = randomBasicRecurrent

66 createRandom = randomBasicRecurrent

68

67

69instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where

68instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where

70− type RecurrentShape (BasicRecurrent i o) = S ('D1 o)

69+ type RecurrentShape (BasicRecurrent i o) = 'D1 o

71

70

72instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

71instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

73

72

src/Grenade/Recurrent/Layers/ConcatRecurrent.hsdeleted−180

@@ -1,180 +0,0 @@

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+80−57

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

5{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

@@ -21,7 +21,7 @@ import Control.Monad.Random ( MonadRandom, getRandom )

21-- import Data.List ( foldl1' )

22import Data.Proxy

23import Data.Serialize

24−import Data.Kind (Type)

24+import Data.Singletons.TypeLits

25

26import qualified Numeric.LinearAlgebra as LA

27import Numeric.LinearAlgebra.Static

@@ -29,7 +29,6 @@ import Numeric.LinearAlgebra.Static

29import Grenade.Core

30import Grenade.Recurrent.Core

31import Grenade.Layers.Internal.Update

32−import GHC.TypeLits

33

32

34

33

35-- | Long Short Term Memory Recurrent unit

34-- | Long Short Term Memory Recurrent unit

@@ -37,14 +36,14 @@ import GHC.TypeLits

37-- This is a Peephole formulation, so the recurrent shape is

36-- This is a Peephole formulation, so the recurrent shape is

38-- just the cell state, the previous output is not held or used

37-- just the cell state, the previous output is not held or used

39-- at all.

38-- at all.

40−data LSTM :: Nat -> Nat -> Type where

39+data LSTM :: Nat -> Nat -> * where

41 LSTM :: ( KnownNat input

40 LSTM :: ( KnownNat input

42 , KnownNat output

41 , KnownNat output

43 ) => !(LSTMWeights input output) -- Weights

42 ) => !(LSTMWeights input output) -- Weights

44 -> !(LSTMWeights input output) -- Momentums

43 -> !(LSTMWeights input output) -- Momentums

45 -> LSTM input output

44 -> LSTM input output

46

45

47−data LSTMWeights :: Nat -> Nat -> Type where

46+data LSTMWeights :: Nat -> Nat -> * where

48 LSTMWeights :: ( KnownNat input

47 LSTMWeights :: ( KnownNat input

49 , KnownNat output

48 , KnownNat output

50 ) => {

49 ) => {

@@ -71,7 +70,7 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

71

70

72 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

71 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

73 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

72 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

74− runUpdate lp (LSTM w m) g =

73+ runUpdate LearningParameters {..} (LSTM w m) g =

75 let (wf, wf') = u lstmWf w m g

74 let (wf, wf') = u lstmWf w m g

76 (uf, uf') = u lstmUf w m g

75 (uf, uf') = u lstmUf w m g

77 (bf, bf') = v lstmBf w m g

76 (bf, bf') = v lstmBf w m g

@@ -88,11 +87,11 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

88 -- Utility function for updating with the momentum, gradients, and weights.

87 -- Utility function for updating with the momentum, gradients, and weights.

89 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

88 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

90 u e (e -> weights) (e -> momentum) (e -> gradient) =

89 u e (e -> weights) (e -> momentum) (e -> gradient) =

91− descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

90+ decendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum

92

91

93 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

92 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

94 v e (e -> weights) (e -> momentum) (e -> gradient) =

93 v e (e -> weights) (e -> momentum) (e -> gradient) =

95− descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

94+ decendVector learningRate learningMomentum learningRegulariser weights gradient momentum

96

95

97 -- There's a lot of updates here, so to try and minimise the number of data copies

96 -- There's a lot of updates here, so to try and minimise the number of data copies

98 -- we'll create a mutable bucket for each.

97 -- we'll create a mutable bucket for each.

@@ -124,33 +123,27 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

124instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

123instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

125 -- The recurrent shape is the same size as the output.

124 -- The recurrent shape is the same size as the output.

126 -- It's actually the cell state however, as this is a peephole variety LSTM.

125 -- It's actually the cell state however, as this is a peephole variety LSTM.

127− type RecurrentShape (LSTM i o) = S ('D1 o)

126+ type RecurrentShape (LSTM i o) = 'D1 o

128

127

129instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

128instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

130

129

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)

130+ type RecTape (LSTM i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))

134 -- Forward propagation for the LSTM layer.

131 -- Forward propagation for the LSTM layer.

135 -- The size of the cell state is also the size of the output.

132 -- The size of the cell state is also the size of the output.

136− runRecurrentForwards (LSTM lw _) (S1D cell) (S1D input) =

133+ runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =

137 let -- Forget state vector

134 let -- Forget state vector

138− f_s = lstmBf lw + lstmWf lw #> input + lstmUf lw #> cell

135+ f_t = sigmoid $ lstmBf + lstmWf #> input + lstmUf #> cell

139− f_t = sigmoid f_s

140 -- Input state vector

136 -- Input state vector

141− i_s = lstmBi lw + lstmWi lw #> input + lstmUi lw #> cell

137+ i_t = sigmoid $ lstmBi + lstmWi #> input + lstmUi #> cell

142− i_t = sigmoid i_s

143 -- Output state vector

138 -- Output state vector

144− o_s = lstmBo lw + lstmWo lw #> input + lstmUo lw #> cell

139+ o_t = sigmoid $ lstmBo + lstmWo #> input + lstmUo #> cell

145− o_t = sigmoid o_s

146 -- Cell input state vector

140 -- Cell input state vector

147− c_s = lstmBc lw + lstmWc lw #> input

141+ c_x = tanh $ lstmBc + lstmWc #> input

148− c_x = tanh c_s

149 -- Cell state

142 -- Cell state

150 c_t = f_t * cell + i_t * c_x

143 c_t = f_t * cell + i_t * c_x

151 -- Output (it's sometimes recommended to use tanh c_t)

144 -- Output (it's sometimes recommended to use tanh c_t)

152 h_t = o_t * c_t

145 h_t = o_t * c_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)

146+ in ((S1D cell, S1D input), S1D c_t, S1D h_t)

154

147

155 -- Run a backpropogation step for an LSTM layer.

148 -- Run a backpropogation step for an LSTM layer.

156 -- We're doing all the derivatives by hand here, so one should

149 -- We're doing all the derivatives by hand here, so one should

@@ -158,8 +151,29 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

158 --

151 --

159 -- There's a test version using the AD library without hmatrix in the test

152 -- There's a test version using the AD library without hmatrix in the test

160 -- suite. These should match always.

153 -- suite. These should match always.

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

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+

162− let -- Reverse Mode AD Derivitives

176+ -- Reverse Mode AD Derivitives

163 c_t' = h_t' * o_t + cellGrad

177 c_t' = h_t' * o_t + cellGrad

164

178

165 f_t' = c_t' * cell

179 f_t' = c_t' * cell

@@ -175,8 +189,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

175 c_s' = tanh' c_s * c_x'

189 c_s' = tanh' c_s * c_x'

176

190

177 -- The derivatives to pass sideways (recurrent) and downwards

191 -- The derivatives to pass sideways (recurrent) and downwards

178− cell' = tr (lstmUf lw) #> f_s' + tr (lstmUo lw) #> o_s' + tr (lstmUi lw) #> i_s' + c_t' * f_t

192+ cell' = tr lstmUf #> f_s' + tr lstmUo #> o_s' + tr lstmUi #> 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'

193+ input' = tr lstmWf #> f_s' + tr lstmWo #> o_s' + tr lstmWi #> i_s' + tr lstmWc #> c_s'

180

194

181 -- Calculate the gradient Matricies for the input

195 -- Calculate the gradient Matricies for the input

182 lstmWf' = f_s' `outer` input

196 lstmWf' = f_s' `outer` input

@@ -221,8 +235,7 @@ randomLSTM = do

221

235

222-- | Maths

236-- | Maths

223--

237--

224−-- TODO: Move to not here

238+-- TODO: move to not here

225−-- Optimise backwards derivative

226sigmoid :: Floating a => a -> a

239sigmoid :: Floating a => a -> a

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

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

228

241

@@ -235,34 +248,44 @@ tanh' :: (Floating a) => a -> a

235tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

248tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

236

249

237instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

250instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

238− put (LSTM lw _) = do

251+ put (LSTM LSTMWeights {..} _) = do

239− u (lstmWf lw)

252+ u lstmWf

240− u (lstmUf lw)

253+ u lstmUf

241− v (lstmBf lw)

254+ v lstmBf

242− u (lstmWi lw)

255+ u lstmWi

243− u (lstmUi lw)

256+ u lstmUi

244− v (lstmBi lw)

257+ v lstmBi

245− u (lstmWo lw)

258+ u lstmWo

246− u (lstmUo lw)

259+ u lstmUo

247− v (lstmBo lw)

260+ v lstmBo

248− u (lstmWc lw)

261+ u lstmWc

249− v (lstmBc lw)

262+ v lstmBc

250− where

263+ where

251− u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

264+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

252− u = putListOf put . LA.toList . LA.flatten . extract

265+ u = putListOf put . LA.toList . LA.flatten . extract

253− v :: forall a. (KnownNat a) => Putter (R a)

266+ v :: forall a. (KnownNat a) => Putter (R a)

254− v = putListOf put . LA.toList . extract

267+ v = putListOf put . LA.toList . extract

255

268

256 get = do

269 get = do

257− w <- LSTMWeights <$> u <*> u <*> v <*> u <*> u <*> v <*> u <*> u <*> v <*> u <*> v

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

258− return $ LSTM w (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

281+ return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

259− where

282+ where

260− u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

283+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

261− u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

284+ 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

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

286+ v :: forall a. (KnownNat a) => Get (R a)

264− v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

287+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

265−

288+

266− w0 = konst 0

289+ w0 = konst 0

267− u0 = konst 0

290+ u0 = konst 0

268− v0 = konst 0

291+ v0 = konst 0

src/Grenade/Utils/OneHot.hs+5−6

@@ -22,6 +22,7 @@ import Data.Map ( Map )

22import qualified Data.Map as M

23

24import Data.Proxy

25+import Data.Singletons.TypeLits

25

26

26import Data.Vector ( Vector )

27import Data.Vector ( Vector )

27import qualified Data.Vector as V

28import qualified Data.Vector as V

@@ -30,7 +31,6 @@ import qualified Data.Vector.Storable as VS

30import Numeric.LinearAlgebra ( maxIndex )

31import Numeric.LinearAlgebra ( maxIndex )

31import Numeric.LinearAlgebra.Devel

32import Numeric.LinearAlgebra.Devel

32import Numeric.LinearAlgebra.Static

33import Numeric.LinearAlgebra.Static

33−import GHC.TypeLits

34

35import Grenade.Core.Shape

36

@@ -52,16 +52,15 @@ oneHot hot =

52

53-- | Create a one hot map from any enumerable.

54-- Returns a map, and the ordered list for the reverse transformation

55−hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Either String (Map a Int, Vector a)

55+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Maybe (Map a Int, Vector a)

56hotMap n as =

57 let len = fromIntegral $ natVal n

58 uniq = [ c | (c:_) <- group $ sort as]

59 hotl = length uniq

60− in if hotl == len

60+ in if hotl <= len

61 then

62− Right (M.fromList $ zip uniq [0..], V.fromList uniq)

62+ Just (M.fromList $ zip uniq [0..], V.fromList uniq)

63− else

63+ else Nothing

64− Left ("Couldn't create hotMap of size " ++ show len ++ " from vector with " ++ show hotl ++ " unique characters")

65

64

66-- | From a map and value, create a 1D Shape

65-- | From a map and value, create a 1D Shape

67-- with one index hot (1) with the rest 0.

66-- with one index hot (1) with the rest 0.

stack.yamldeleted−78

@@ -1,78 +0,0 @@

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.lockdeleted−19

@@ -1,19 +0,0 @@

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+6−10

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE TemplateHaskell #-}

1{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

@@ -16,10 +15,6 @@ import Data.Singletons ()

16import GHC.TypeLits

15import GHC.TypeLits

17import GHC.TypeLits.Witnesses

16import GHC.TypeLits.Witnesses

18

17

19−#if MIN_VERSION_base(4,9,0)

20−import Data.Kind (Type)

21−#endif

22−

23import Grenade.Core

18import Grenade.Core

24import Grenade.Layers.Convolution

19import Grenade.Layers.Convolution

25

20

@@ -30,7 +25,7 @@ import Test.Hedgehog.Hmatrix

30import Test.Hedgehog.TypeLits

25import Test.Hedgehog.TypeLits

31import Test.Hedgehog.Compat

26import Test.Hedgehog.Compat

32

27

33−data OpaqueConvolution :: Type where

28+data OpaqueConvolution :: * where

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

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

35

30

36instance Show OpaqueConvolution where

31instance Show OpaqueConvolution where

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

44 , KnownNat strideColumns

39 , KnownNat strideColumns

45 , KnownNat kernelFlattened

40 , KnownNat kernelFlattened

46 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

41 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

42+ , Monad m

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

43+ ) => Gen.Gen m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

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

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

49

45

50−genOpaqueOpaqueConvolution :: Gen OpaqueConvolution

46+genOpaqueOpaqueConvolution :: Monad m => Gen m OpaqueConvolution

51genOpaqueOpaqueConvolution = do

47genOpaqueOpaqueConvolution = do

52 channels <- genNat

48 channels <- genNat

53 filters <- genNat

49 filters <- genNat

@@ -63,7 +59,7 @@ genOpaqueOpaqueConvolution = do

63 p2 = natDict pkc

59 p2 = natDict pkc

64 p3 = natDict pch

60 p3 = natDict pch

65 in case p1 %* p2 %* p3 of

61 in case p1 %* p2 %* p3 of

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

62+ Dict -> OpaqueConvolution <$> (genConvolution :: Monad n => Gen n (Convolution ch fl kr kc sr sc))

67

63

68prop_conv_net_witness = property $

64prop_conv_net_witness = property $

69 blindForAll genOpaqueOpaqueConvolution >>= \onet ->

65 blindForAll genOpaqueOpaqueConvolution >>= \onet ->

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

105

101

106

102

107tests :: IO Bool

103tests :: IO Bool

108−tests = checkParallel $$(discover)

104+tests = $$(checkConcurrent)

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

4{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

@@ -13,10 +12,6 @@ import Data.Singletons ()

13

12

14import GHC.TypeLits

13import GHC.TypeLits

15

14

16−#if MIN_VERSION_base(4,9,0)

17−import Data.Kind (Type)

18−#endif

19−

20import Grenade.Core

15import Grenade.Core

21import Grenade.Layers.FullyConnected

16import Grenade.Layers.FullyConnected

22

17

@@ -25,13 +20,13 @@ import Hedgehog

25import Test.Hedgehog.Compat

20import Test.Hedgehog.Compat

26import Test.Hedgehog.Hmatrix

21import Test.Hedgehog.Hmatrix

27

22

28−data OpaqueFullyConnected :: Type where

23+data OpaqueFullyConnected :: * where

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

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

30

25

31instance Show OpaqueFullyConnected where

26instance Show OpaqueFullyConnected where

32 show (OpaqueFullyConnected n) = show n

27 show (OpaqueFullyConnected n) = show n

33

28

34−genOpaqueFullyConnected :: Gen OpaqueFullyConnected

29+genOpaqueFullyConnected :: Monad m => Gen m OpaqueFullyConnected

35genOpaqueFullyConnected = do

30genOpaqueFullyConnected = do

36 input :: Integer <- choose 2 100

31 input :: Integer <- choose 2 100

37 output :: Integer <- choose 1 100

32 output :: Integer <- choose 1 100

@@ -55,4 +50,4 @@ prop_fully_connected_forwards = property $ do

55 backed `seq` success

50 backed `seq` success

56

51

57tests :: IO Bool

52tests :: IO Bool

58−tests = checkParallel $$(discover)

53+tests = $$(checkConcurrent)

test/Test/Grenade/Layers/Internal/Convolution.hs+2−1

@@ -53,5 +53,6 @@ prop_im2col_col2im_behaves_as_reference =

53 outFast === outReference

54 retFast === retReference

55

56+return []

56tests :: IO Bool

57tests :: IO Bool

57−tests = checkParallel $$(discover)

58+tests = $$(checkConcurrent)

test/Test/Grenade/Layers/Internal/Pooling.hs+1−1

@@ -42,4 +42,4 @@ prop_poolForwards_poolBackwards_behaves_as_reference =

42

43

44tests :: IO Bool

45−tests = checkParallel $$(discover)

45+tests = $$(checkConcurrent)

test/Test/Grenade/Layers/Nonlinear.hs+4−3

@@ -22,7 +22,7 @@ import Numeric.LinearAlgebra.Static ( norm_Inf )

22

23prop_sigmoid_grad :: Property

24prop_sigmoid_grad = property $

25− forAllWith rss genShape >>= \case

25+ blindForAll genShape >>= \case

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

27 withSingI r $

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

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

37

38prop_tanh_grad :: Property

39prop_tanh_grad = property $

40− forAllWith rss genShape >>= \case

40+ blindForAll genShape >>= \case

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

42 withSingI r $

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

@@ -51,4 +51,5 @@ prop_tanh_grad = property $

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

52

53tests :: IO Bool

54−tests = checkParallel $$(discover)

54+tests = $$(checkConcurrent)

55+

test/Test/Grenade/Layers/PadCrop.hs+5−1

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

7{-# LANGUAGE ScopedTypeVariables #-}

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

9

10+#if __GLASGOW_HASKELL__ < 800

11+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

12+#endif

13+

10module Test.Grenade.Layers.PadCrop where

14module Test.Grenade.Layers.PadCrop where

11

15

12import Grenade

16import Grenade

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

46

50

47

51

48tests :: IO Bool

52tests :: IO Bool

49−tests = checkParallel $$(discover)

53+tests = $$(checkConcurrent)

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE TemplateHaskell #-}

1{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE KindSignatures #-}

3{-# LANGUAGE KindSignatures #-}

@@ -10,29 +9,26 @@ module Test.Grenade.Layers.Pooling where

10import Data.Proxy

9import Data.Proxy

11import Data.Singletons ()

10import Data.Singletons ()

12

11

13−#if MIN_VERSION_base(4,9,0)

14−import Data.Kind (Type)

15−#endif

16−

17import GHC.TypeLits

12import GHC.TypeLits

18import Grenade.Layers.Pooling

13import Grenade.Layers.Pooling

19

14

20import Hedgehog

15import Hedgehog

16+import qualified Hedgehog.Gen as Gen

21

17

22import Test.Hedgehog.Compat

18import Test.Hedgehog.Compat

23

19

24−data OpaquePooling :: Type where

20+data OpaquePooling :: * where

25 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

21 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

26

22

27instance Show OpaquePooling where

23instance Show OpaquePooling where

28 show (OpaquePooling n) = show n

24 show (OpaquePooling n) = show n

29

25

30−genOpaquePooling :: Gen OpaquePooling

26+genOpaquePooling :: Monad m => Gen.Gen m OpaquePooling

31genOpaquePooling = do

27genOpaquePooling = do

32− ~(Just kernelHeight) <- someNatVal <$> choose 2 15

28+ Just kernelHeight <- someNatVal <$> choose 2 15

33− ~(Just kernelWidth ) <- someNatVal <$> choose 2 15

29+ Just kernelWidth <- someNatVal <$> choose 2 15

34− ~(Just strideHeight) <- someNatVal <$> choose 2 15

30+ Just strideHeight <- someNatVal <$> choose 2 15

35− ~(Just strideWidth ) <- someNatVal <$> choose 2 15

31+ Just strideWidth <- someNatVal <$> choose 2 15

36

32

37 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

33 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

38 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

34 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

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

46 assert True

42 assert True

47

43

48tests :: IO Bool

44tests :: IO Bool

49−tests = checkParallel $$(discover)

45+tests = $$(checkConcurrent)

test/Test/Grenade/Network.hs+29−227

@@ -14,12 +14,17 @@ import Control.Monad ( guard )

14import Control.Monad.ST ( runST )

15

16import Data.Constraint

17+#if __GLASGOW_HASKELL__ < 800

18+import Data.Proxy

19+#endif

17import qualified Data.Vector.Storable as VS

20import qualified Data.Vector.Storable as VS

18import qualified Data.Vector.Storable.Mutable as VS ( write )

21import qualified Data.Vector.Storable.Mutable as VS ( write )

19import Data.Singletons

22import Data.Singletons

20import Data.Singletons.Prelude.List

23import Data.Singletons.Prelude.List

21import Data.Singletons.TypeLits

24import Data.Singletons.TypeLits

22

25

26+-- import Data.Type.Equality

27+

23import Hedgehog

28import Hedgehog

24import qualified Hedgehog.Gen as Gen

29import qualified Hedgehog.Gen as Gen

25import Hedgehog.Internal.Source

30import Hedgehog.Internal.Source

@@ -27,15 +32,7 @@ import Hedgehog.Internal.Property ( failWith )

27

32

28import Grenade

33import Grenade

29

34

30−#if MIN_VERSION_base(4,11,0)

31−import GHC.TypeLits hiding (natVal)

32−#else

33import GHC.TypeLits

35import GHC.TypeLits

34−#endif

35−#if MIN_VERSION_base(4,9,0)

36−import Data.Kind (Type)

37−#endif

38−

39import GHC.TypeLits.Witnesses

36import GHC.TypeLits.Witnesses

40import Test.Hedgehog.Compat

37import Test.Hedgehog.Compat

41import Test.Hedgehog.TypeLits

38import Test.Hedgehog.TypeLits

@@ -46,7 +43,7 @@ import Numeric.LinearAlgebra ( flatten )

46import Numeric.LinearAlgebra.Static ( extract, norm_Inf )

43import Numeric.LinearAlgebra.Static ( extract, norm_Inf )

47import Unsafe.Coerce

44import Unsafe.Coerce

48

45

49−data SomeNetwork :: Type where

46+data SomeNetwork :: * where

50 SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork

47 SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork

51

48

52instance Show SomeNetwork where

49instance Show SomeNetwork where

@@ -56,7 +53,7 @@ instance Show SomeNetwork where

56--

53--

57-- This is slightly insane for a few reasons. Everything must be wrapped up

54-- This is slightly insane for a few reasons. Everything must be wrapped up

58-- in a SomeNetwork.

55-- in a SomeNetwork.

59−genNetwork :: Gen SomeNetwork

56+genNetwork :: Monad m => Gen.Gen m SomeNetwork

60genNetwork =

57genNetwork =

61 Gen.recursive Gen.choice [

58 Gen.recursive Gen.choice [

62 do SomeSing ( r :: Sing final ) <- genShape

59 do SomeSing ( r :: Sing final ) <- genShape

@@ -65,7 +62,7 @@ genNetwork =

65 ] [

62 ] [

66 do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork

63 do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork

67 case ( sing :: Sing shapes ) of

64 case ( sing :: Sing shapes ) of

68− SNil -> Gen.discard -- Can't occur

65+ SNil -> Gen.discard

69 SCons ( h :: Sing h ) ( _ :: Sing hs ) ->

66 SCons ( h :: Sing h ) ( _ :: Sing hs ) ->

70 withSingI h $

67 withSingI h $

71 case h of

68 case h of

@@ -77,9 +74,8 @@ genNetwork =

77 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

74 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

78 , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))

75 , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))

79 , do -- Reshape to two dimensions

76 , do -- Reshape to two dimensions

80− let divisors :: Integer -> [Integer]

81− divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]

77+ let divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]

82− let len = fromIntegral $ natVal l

78+ let len = natVal l

83 rs <- Gen.element $ divisors len

79 rs <- Gen.element $ divisors len

84 let cs = len `quot` rs

80 let cs = len `quot` rs

85 case ( someNatVal rs, someNatVal cs, someNatVal len ) of

81 case ( someNatVal rs, someNatVal cs, someNatVal len ) of

@@ -100,8 +96,8 @@ genNetwork =

100 , do -- Build a convolution layer with one filter output

96 , do -- Build a convolution layer with one filter output

101 -- Figure out some kernel sizes which work for this layer

97 -- Figure out some kernel sizes which work for this layer

102 -- There must be a better way than this...

98 -- There must be a better way than this...

103− let output_r = fromIntegral $ natVal r

99+ let output_r = natVal r

104− let output_c = fromIntegral $ natVal c

100+ let output_c = natVal c

105

101

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

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

107

103

@@ -140,8 +136,8 @@ genNetwork =

140 , do -- Build a convolution layer with one filter output

136 , do -- Build a convolution layer with one filter output

141 -- Figure out some kernel sizes which work for this layer

137 -- Figure out some kernel sizes which work for this layer

142 -- There must be a better way than this...

138 -- There must be a better way than this...

143− let output_r = fromIntegral $ natVal r

139+ let output_r = natVal r

144− let output_c = fromIntegral $ natVal c

140+ let output_c = natVal c

145

141

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

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

147

143

@@ -182,8 +178,8 @@ genNetwork =

182 pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

178 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

179 _ -> Gen.discard -- Can't occur

184 , do -- Build a Pooling layer

180 , do -- Build a Pooling layer

185− let output_r = fromIntegral $ natVal r

181+ let output_r = natVal r

186− let output_c = fromIntegral $ natVal c

182+ let output_c = natVal c

187

183

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

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

189

185

@@ -218,219 +214,25 @@ genNetwork =

218 (Dict, Dict, Dict, Dict) ->

214 (Dict, Dict, Dict, Dict) ->

219 pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

215 pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

220 _ -> Gen.discard -- Can't occur

216 _ -> 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 ]

217 ]

273− D3Sing r@SNat c@SNat f@SNat ->

218+ D3Sing SNat SNat SNat ->

274 Gen.choice [

219 Gen.choice [

275 pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

220 pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

276 , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

221 , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

277 , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

222 , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

278 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

223 , 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− ]

224+ ]

423 ]

225 ]

424

226

425-- | Test a partial derivative numerically for a random network and input

227-- | Test a partial derivative numerically for a random network and input

426--

228--

427-- This is the most important test.

229-- This is the most important test.

428prop_auto_diff :: Property

230prop_auto_diff :: Property

429−prop_auto_diff = withDiscards 1000 . withTests 10000 . property $ do

231+prop_auto_diff = withTests 10000 . property $ do

430 SomeNetwork (network :: Network layers shapes) <- forAll genNetwork

232 SomeNetwork (network :: Network layers shapes) <- forAll genNetwork

431− (input :: S (Head shapes)) <- forAllWith nice genOfShape

233+ (input :: S (Head shapes)) <- forAllRender nice genOfShape

432− (target :: S (Last shapes)) <- forAllWith nice oneUp

234+ (target :: S (Last shapes)) <- forAllRender nice oneUp

433− (tested :: S (Head shapes)) <- forAllWith nice oneUp

235+ (tested :: S (Head shapes)) <- forAllRender nice oneUp

434

236

435 let (!tapes, !output) = runNetwork network input

237 let (!tapes, !output) = runNetwork network input

436 let (_, !backgrad) = runGradient network tapes target

238 let (_, !backgrad) = runGradient network tapes target

@@ -442,13 +244,13 @@ prop_auto_diff = withDiscards 1000 . withTests 10000 . property $ do

442 result ~~~ expected

244 result ~~~ expected

443

245

444-- Make a shape where all are 0 except for 1 value, which is 1.

246-- Make a shape where all are 0 except for 1 value, which is 1.

445−oneUp :: forall shape. ( SingI shape ) => Gen (S shape)

247+oneUp :: forall shape m. ( Monad m, SingI shape ) => Gen.Gen m (S shape)

446oneUp =

248oneUp =

447 case ( sing :: Sing shape ) of

249 case ( sing :: Sing shape ) of

448 D1Sing SNat ->

250 D1Sing SNat ->

449 let x = 0 :: S ( shape )

251 let x = 0 :: S ( shape )

450 in case x of

252 in case x of

451− ( S1D x' ) -> do

253+ ( S1D x' ) -> do

452 let ex = extract x'

254 let ex = extract x'

453 let len = VS.length ex

255 let len = VS.length ex

454 ix <- choose 0 (len - 1)

256 ix <- choose 0 (len - 1)

@@ -460,7 +262,7 @@ oneUp =

460 D2Sing SNat SNat ->

262 D2Sing SNat SNat ->

461 let x = 0 :: S ( shape )

263 let x = 0 :: S ( shape )

462 in case x of

264 in case x of

463− ( S2D x' ) -> do

265+ ( S2D x' ) -> do

464 let ex = flatten ( extract x' )

266 let ex = flatten ( extract x' )

465 let len = VS.length ex

267 let len = VS.length ex

466 ix <- choose 0 (len - 1)

268 ix <- choose 0 (len - 1)

@@ -472,7 +274,7 @@ oneUp =

472 D3Sing SNat SNat SNat ->

274 D3Sing SNat SNat SNat ->

473 let x = 0 :: S ( shape )

275 let x = 0 :: S ( shape )

474 in case x of

276 in case x of

475− ( S3D x' ) -> do

277+ ( S3D x' ) -> do

476 let ex = flatten ( extract x' )

278 let ex = flatten ( extract x' )

477 let len = VS.length ex

279 let len = VS.length ex

478 ix <- choose 0 (len - 1)

280 ix <- choose 0 (len - 1)

@@ -486,9 +288,9 @@ maxVal ( S1D x ) = norm_Inf x

486maxVal ( S2D x ) = norm_Inf x

288maxVal ( S2D x ) = norm_Inf x

487maxVal ( S3D x ) = norm_Inf x

289maxVal ( S3D x ) = norm_Inf x

488

290

489−(~~~) :: (Monad m, HasCallStack) => Double -> Double -> PropertyT m ()

291+(~~~) :: (Monad m, HasCallStack) => Double -> Double -> Test m ()

490(~~~) x y =

292(~~~) x y =

491− if abs (x - y) < 2e-5 then

293+ if abs (x - y) < 1e-5 then

492 success

294 success

493 else

295 else

494 withFrozenCallStack $

296 withFrozenCallStack $

@@ -501,4 +303,4 @@ infix 4 ~~~

501

303

502

304

503tests :: IO Bool

305tests :: IO Bool

504−tests = checkParallel $$(discover)

306+tests = $$(checkConcurrent)

test/Test/Grenade/Recurrent/Layers/LSTM.hs+9−14

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

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

12

13import Hedgehog

14+import qualified Hedgehog.Gen as Gen

14import Hedgehog.Internal.Source

15import Hedgehog.Internal.Source

15import Hedgehog.Internal.Show

16import Hedgehog.Internal.Show

16import Hedgehog.Internal.Property ( failWith, Diff (..) )

17import Hedgehog.Internal.Property ( failWith, Diff (..) )

@@ -28,7 +29,7 @@ import qualified Numeric.LinearAlgebra.Static as S

28import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

29import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

29import Test.Hedgehog.Hmatrix

30import Test.Hedgehog.Hmatrix

30

31

31−genLSTM :: forall i o. (KnownNat i, KnownNat o) => Gen (LSTM i o)

32+genLSTM :: forall i o m. (KnownNat i, KnownNat o, Monad m) => Gen.Gen m (LSTM i o)

32genLSTM = do

33genLSTM = do

33 let w = uniformSample

34 let w = uniformSample

34 u = uniformSample

35 u = uniformSample

@@ -65,9 +66,7 @@ prop_lstm_reference_backwards =

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

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

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

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

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

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

68− let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

69− = runRecurrentForwards net (S1D cell) (S1D input)

70− actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

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

71 case actualBacks of

70 case actualBacks of

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

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

73 let refNet = Reference.lstmToReference lstmWeights

72 let refNet = Reference.lstmToReference lstmWeights

@@ -81,9 +80,7 @@ prop_lstm_reference_backwards_input =

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

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

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

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

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

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

84− let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

85− = runRecurrentForwards net (S1D cell) (S1D input)

86− actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

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

87 case actualBacks of

84 case actualBacks of

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

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

89 let refNet = Reference.lstmToReference lstmWeights

86 let refNet = Reference.lstmToReference lstmWeights

@@ -97,9 +94,7 @@ prop_lstm_reference_backwards_cell =

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

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

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

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

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

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

100− let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

101− = runRecurrentForwards net (S1D cell) (S1D input)

102− actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

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

103 case actualBacks of

98 case actualBacks of

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

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

105 let refNet = Reference.lstmToReference lstmWeights

100 let refNet = Reference.lstmToReference lstmWeights

@@ -108,7 +103,7 @@ prop_lstm_reference_backwards_cell =

108 refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

103 refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

109 in toList refGradients ~~~ H.toList (S.extract actualGradients)

104 in toList refGradients ~~~ H.toList (S.extract actualGradients)

110

105

111−(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> PropertyT m ()

106+(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> Test m ()

112(~~~) x y =

107(~~~) x y =

113 if all (< 1e-8) (zipWith (-) x y) then

108 if all (< 1e-8) (zipWith (-) x y) then

114 success

109 success

@@ -121,10 +116,10 @@ prop_lstm_reference_backwards_cell =

121 , showPretty x

116 , showPretty x

122 , showPretty y

117 , showPretty y

123 ]

118 ]

124− Just differ ->

119+ Just diff ->

125 withFrozenCallStack $

120 withFrozenCallStack $

126− failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" differ) ""

121+ failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" diff) ""

127infix 4 ~~~

122infix 4 ~~~

128

123

129tests :: IO Bool

124tests :: IO Bool

130−tests = checkParallel $$(discover)

125+tests = $$(checkConcurrent)

test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+21−25

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

6{-# LANGUAGE DeriveFunctor #-}

7{-# LANGUAGE DeriveFoldable #-}

8{-# LANGUAGE DeriveTraversable #-}

9+{-# LANGUAGE RecordWildCards #-}

9{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE RankNTypes #-}

11

12

@@ -14,13 +15,9 @@ module Test.Grenade.Recurrent.Layers.LSTM.Reference where

14

15

15import Data.Reflection

16import Data.Reflection

16import Numeric.AD.Mode.Reverse

17import Numeric.AD.Mode.Reverse

17−import Numeric.AD.Internal.Reverse (Tape)

18+import Numeric.AD.Internal.Reverse ( Tape )

18

19

19−import GHC.TypeLits (KnownNat)

20−

21−import Grenade.Recurrent.Layers.LSTM (LSTMWeights (..))

22import qualified Grenade.Recurrent.Layers.LSTM as LSTM

20import qualified Grenade.Recurrent.Layers.LSTM as LSTM

23−

24import qualified Numeric.LinearAlgebra.Static as S

21import qualified Numeric.LinearAlgebra.Static as S

25import qualified Numeric.LinearAlgebra as H

22import qualified Numeric.LinearAlgebra as H

26

23

@@ -57,32 +54,31 @@ data RefLSTM a = RefLSTM

57 , refLstmBc :: Vector a -- Bias Cell (b_c)

54 , refLstmBc :: Vector a -- Bias Cell (b_c)

58 } deriving (Functor, Foldable, Traversable, Eq, Show)

55 } deriving (Functor, Foldable, Traversable, Eq, Show)

59

56

60−lstmToReference :: (KnownNat a, KnownNat b) => LSTM.LSTMWeights a b -> RefLSTM Double

57+lstmToReference :: LSTM.LSTMWeights a b -> RefLSTM Double

61−lstmToReference lw =

58+lstmToReference LSTM.LSTMWeights {..} =

62− RefLSTM

63− { refLstmWf = Matrix . H.toLists . S.extract $ lstmWf lw -- Weight Forget (W_f)

59+ let refLstmWf = Matrix . H.toLists . S.extract $ lstmWf -- Weight Forget (W_f)

64− , refLstmUf = Matrix . H.toLists . S.extract $ lstmUf lw -- Cell State Forget (U_f)

60+ refLstmUf = Matrix . H.toLists . S.extract $ lstmUf -- Cell State Forget (U_f)

65− , refLstmBf = Vector . H.toList . S.extract $ lstmBf lw -- Bias Forget (b_f)

61+ refLstmBf = Vector . H.toList . S.extract $ lstmBf -- Bias Forget (b_f)

66− , refLstmWi = Matrix . H.toLists . S.extract $ lstmWi lw -- Weight Input (W_i)

62+ refLstmWi = Matrix . H.toLists . S.extract $ lstmWi -- Weight Input (W_i)

67− , refLstmUi = Matrix . H.toLists . S.extract $ lstmUi lw -- Cell State Input (U_i)

63+ refLstmUi = Matrix . H.toLists . S.extract $ lstmUi -- Cell State Input (U_i)

68− , refLstmBi = Vector . H.toList . S.extract $ lstmBi lw -- Bias Input (b_i)

64+ refLstmBi = Vector . H.toList . S.extract $ lstmBi -- Bias Input (b_i)

69− , refLstmWo = Matrix . H.toLists . S.extract $ lstmWo lw -- Weight Output (W_o)

65+ refLstmWo = Matrix . H.toLists . S.extract $ lstmWo -- Weight Output (W_o)

70− , refLstmUo = Matrix . H.toLists . S.extract $ lstmUo lw -- Cell State Output (U_o)

66+ refLstmUo = Matrix . H.toLists . S.extract $ lstmUo -- Cell State Output (U_o)

71− , refLstmBo = Vector . H.toList . S.extract $ lstmBo lw -- Bias Output (b_o)

67+ refLstmBo = Vector . H.toList . S.extract $ lstmBo -- Bias Output (b_o)

72− , refLstmWc = Matrix . H.toLists . S.extract $ lstmWc lw -- Weight Cell (W_c)

68+ refLstmWc = Matrix . H.toLists . S.extract $ lstmWc -- Weight Cell (W_c)

73− , refLstmBc = Vector . H.toList . S.extract $ lstmBc lw -- Bias Cell (b_c)

69+ refLstmBc = Vector . H.toList . S.extract $ lstmBc -- Bias Cell (b_c)

74− }

70+ in RefLSTM {..}

75

71

76runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

72runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

77−runLSTM rl cell input =

73+runLSTM RefLSTM {..} cell input =

78 let -- Forget state vector

74 let -- Forget state vector

79− f_t = sigmoid $ refLstmBf rl #+ refLstmWf rl #> input #+ refLstmUf rl #> cell

75+ f_t = sigmoid $ refLstmBf #+ refLstmWf #> input #+ refLstmUf #> cell

80 -- Input state vector

76 -- Input state vector

81− i_t = sigmoid $ refLstmBi rl #+ refLstmWi rl #> input #+ refLstmUi rl #> cell

77+ i_t = sigmoid $ refLstmBi #+ refLstmWi #> input #+ refLstmUi #> cell

82 -- Output state vector

78 -- Output state vector

83− o_t = sigmoid $ refLstmBo rl #+ refLstmWo rl #> input #+ refLstmUo rl #> cell

79+ o_t = sigmoid $ refLstmBo #+ refLstmWo #> input #+ refLstmUo #> cell

84 -- Cell input state vector

80 -- Cell input state vector

85− c_x = fmap tanh $ refLstmBc rl #+ refLstmWc rl #> input

81+ c_x = fmap tanh $ refLstmBc #+ refLstmWc #> input

86 -- Cell state

82 -- Cell state

87 c_t = f_t #* cell #+ i_t #* c_x

83 c_t = f_t #* cell #+ i_t #* c_x

88 -- Output (it's sometimes recommended to use tanh c_t)

84 -- Output (it's sometimes recommended to use tanh c_t)

test/Test/Hedgehog/Compat.hs+23−4

@@ -3,19 +3,38 @@ module Test.Hedgehog.Compat (

3 (...)

4 , choose

5 , blindForAll

6+ , semiBlindForAll

7+ , forAllRender

6 )where

8 )where

7

9

8−import Hedgehog (Gen)

10+import Control.Monad.Trans.Class (MonadTrans(..))

11+

12+import Data.Typeable ( typeOf )

13+

9import qualified Hedgehog.Gen as Gen

14import qualified Hedgehog.Gen as Gen

10import qualified Hedgehog.Range as Range

15import qualified Hedgehog.Range as Range

11import Hedgehog.Internal.Property

16import Hedgehog.Internal.Property

17+import Hedgehog.Internal.Source

18+import Hedgehog.Internal.Show

12

19

13(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

20(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

14(...) = (.) . (.)

21(...) = (.) . (.)

15{-# INLINE (...) #-}

22{-# INLINE (...) #-}

16

23

17−choose :: Integral a => a -> a -> Gen a

24+choose :: ( Monad m, Integral a ) => a -> a -> Gen.Gen m a

18choose = Gen.integral ... Range.constant

25choose = Gen.integral ... Range.constant

19

26

20−blindForAll :: Monad m => Gen a -> PropertyT m a

27+blindForAll :: Monad m => Gen.Gen m a -> Test m a

21−blindForAll = forAllWith (const "blind")

28+blindForAll = Test . lift . lift

29+

30+semiBlindForAll :: (Monad m, Show a, HasCallStack) => Gen.Gen m a -> Test m a

31+semiBlindForAll gen = do

32+ x <- Test . lift $ lift gen

33+ writeLog $ Input (getCaller callStack) (typeOf ()) (showPretty x)

34+ return x

35+

36+forAllRender :: (Monad m, HasCallStack) => ( a -> String ) -> Gen.Gen m a -> Test m a

37+forAllRender render gen = do

38+ x <- Test . lift $ lift gen

39+ writeLog $ Input (getCaller callStack) (typeOf ()) (render x)

40+ return x

test/Test/Hedgehog/Hmatrix.hs+5−7

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE KindSignatures #-}

3−{-# LANGUAGE GADTs #-}

4{-# LANGUAGE RankNTypes #-}

1{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE GADTs #-}

6

5

7module Test.Hedgehog.Hmatrix where

6module Test.Hedgehog.Hmatrix where

8

7

@@ -10,20 +9,19 @@ import Grenade

10import Data.Singletons

9import Data.Singletons

11import Data.Singletons.TypeLits

10import Data.Singletons.TypeLits

12

11

13−import Hedgehog (Gen)

14import qualified Hedgehog.Gen as Gen

12import qualified Hedgehog.Gen as Gen

15import qualified Hedgehog.Range as Range

13import qualified Hedgehog.Range as Range

16

14

17import qualified Numeric.LinearAlgebra.Static as HStatic

15import qualified Numeric.LinearAlgebra.Static as HStatic

18

16

19−randomVector :: forall n. ( KnownNat n ) => Gen (HStatic.R n)

17+randomVector :: forall m n. ( Monad m, KnownNat n ) => Gen.Gen m (HStatic.R n)

20randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded

18randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded

21

19

22−uniformSample :: forall m n. ( KnownNat m, KnownNat n ) => Gen (HStatic.L m n)

20+uniformSample :: forall mm m n. ( Monad mm, KnownNat m, KnownNat n ) => Gen.Gen mm (HStatic.L m n)

23uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded

21uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded

24

22

25-- | Generate random data of the desired shape

23-- | Generate random data of the desired shape

26−genOfShape :: forall x. ( SingI x ) => Gen (S x)

24+genOfShape :: forall m x. ( Monad m, SingI x ) => Gen.Gen m (S x)

27genOfShape =

25genOfShape =

28 case (sing :: Sing x) of

26 case (sing :: Sing x) of

29 D1Sing l ->

27 D1Sing l ->

test/Test/Hedgehog/TypeLits.hs+19−20

@@ -7,27 +7,32 @@

7{-# LANGUAGE GADTs #-}

8module Test.Hedgehog.TypeLits where

9

10−import Data.Constraint (Dict (..))

10+import Data.Constraint

11−import Data.Singletons (Proxy (..), Sing (..), SomeSing (..), sing)

11+#if __GLASGOW_HASKELL__ < 800

12−#if MIN_VERSION_singletons(2,6,0)

13−import Data.Singletons.TypeLits (SNat (..))

12+import Data.Proxy

14#endif

13#endif

14+import Data.Singletons

15

16−import Hedgehog (Gen)

17import qualified Hedgehog.Gen as Gen

16import qualified Hedgehog.Gen as Gen

18

17

19import Grenade

18import Grenade

20

19

21−import GHC.TypeLits (SomeNat (..), natVal, someNatVal)

20+import GHC.TypeLits

22−import GHC.TypeLits.Witnesses ((%*), natDict)

21+import GHC.TypeLits.Witnesses

23−import Test.Hedgehog.Compat (choose)

22+import Test.Hedgehog.Compat

24

23

25−genNat :: Gen SomeNat

24+genNat :: Monad m => Gen.Gen m SomeNat

26genNat = do

25genNat = do

27− ~(Just n) <- someNatVal <$> choose 1 10

26+ Just n <- someNatVal <$> choose 1 10

28 return n

27 return n

29

28

29+#if __GLASGOW_HASKELL__ < 800

30+type Shape' = ('KProxy :: KProxy Shape)

31+#else

32+type Shape' = Shape

33+#endif

34+

30−genShape :: Gen (SomeSing Shape)

35+genShape :: Monad m => Gen.Gen m (SomeSing Shape')

31genShape

36genShape

32 = Gen.choice [

37 = Gen.choice [

33 genD1

38 genD1

@@ -35,20 +40,20 @@ genShape

35 , genD3

40 , genD3

36 ]

41 ]

37

42

38−genD1 :: Gen (SomeSing Shape)

43+genD1 :: Monad m => Gen.Gen m (SomeSing Shape')

39genD1 = do

44genD1 = do

40 n <- genNat

45 n <- genNat

41 return $ case n of

46 return $ case n of

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

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

43

48

44−genD2 :: Gen (SomeSing Shape)

49+genD2 :: Monad m => Gen.Gen m (SomeSing Shape')

45genD2 = do

50genD2 = do

46 n <- genNat

51 n <- genNat

47 m <- genNat

52 m <- genNat

48 return $ case (n, m) of

53 return $ case (n, m) of

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

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

50

55

51−genD3 :: Gen (SomeSing Shape)

56+genD3 :: Monad m => Gen.Gen m (SomeSing Shape')

52genD3 = do

57genD3 = do

53 n <- genNat

58 n <- genNat

54 m <- genNat

59 m <- genNat

@@ -57,9 +62,3 @@ genD3 = do

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

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

58 case natDict px %* natDict pz of

63 case natDict px %* natDict pz of

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

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