ce51927...master · grenade

.gitignore+3−1

since splitsnapshots

unifiedsplit

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

1+cabal.project.local

1.cabal-sandbox/

2.cabal-sandbox/

2cabal.sandbox.config

3cabal.sandbox.config

3dist/

4dist/

4−

5+dist-newstyle/

6+.stack-work/

.travis.yml+12−10

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

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+ - GHCVER=8.0.2

5− - CABALVER=1.22 GHCVER=7.10.3

6+ - GHCVER=8.2.2

6− - CABALVER=1.24 GHCVER=8.0.1

7+ - GHCVER=8.4.4

8+ - GHCVER=8.6.5

9+ - GHCVER=8.8.3

10+ - GHCVER=8.10.1

7

11

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

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

9before_install:

13before_install:

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

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

11 - travis_retry sudo apt-get update

15 - travis_retry sudo apt-get update

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

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

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

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

14

18

15install:

19install:

16− - cabal --version

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

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

18− - travis_retry cabal update

21+ - travis_retry cabal-3.2 update

19− - cabal sandbox init

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

21

22

22notifications:

23notifications:

23 email: false

24 email: false

24

25

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.

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.

26script:

27script:

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

27− - cabal build

29+ - cabal-3.2 build all

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

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

29

31

README.md+5−3

@@ -3,6 +3,7 @@ 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]

6

7

8

8```

9```

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

23type MNIST

24type MNIST

24 = Network

25 = Network

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

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

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

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

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

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

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

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

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

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

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

158./mafia test

159./mafia test

159```

160```

160

161

161−Grenade builds with ghc 7.10 and 8.0.

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

162

163

163Thanks

164Thanks

164------

165------

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

187

188

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

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

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

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

190−

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

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

bench/bench-lstm.hs+4−45

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

5

6import Grenade

7import Grenade.Recurrent

8−import Grenade.Layers.Internal.Update

9−

10−import qualified Numeric.LinearAlgebra.Static as H

11

8

12main :: IO ()

9main :: IO ()

13main = do

10main = do

14− layer60 :: LSTM 40 60 <- createRandom

15− layer512 :: LSTM 40 512 <- createRandom

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

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

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

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

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

12+ lstm :: RecNet <- randomRecurrent

20−

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

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

23

13

24 defaultMain [

14 defaultMain [

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

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

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

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

29− ]

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

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

32− ]

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

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

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

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

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

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

36 ]

18 ]

37 ]

19 ]

38

20

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

40−testRun60 = runRecurrentForwards

41−

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

43−testRun60' = curry . runRecurrentBackwards

44−

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

46−testRun512 = runRecurrentForwards

47−

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

49−testRun512' = curry . runRecurrentBackwards

50−

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

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

53−

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

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

56−

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

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

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

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

59

23

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

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

62−

63

24

64type R = Recurrent

25type R = Recurrent

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

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

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

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

67

28

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

69−

70lp :: LearningParameters

29lp :: LearningParameters

71lp = LearningParameters 0.1 0 0

30lp = LearningParameters 0.1 0 0

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

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

1−#include "gradient_decent.h"

1+#include "gradient_descent.h"

2

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

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

4 const double* weights,

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_decent.h → cbits/gradient_descent.hrenamed+1−1

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

1#include <stdio.h>

2#include <stdint.h>

3

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

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

5 const double* weights,

6 const double* gradient,

7 const double* last,

examples/grenade-examples.cabal+10−9

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

26 , bytestring

27 , cereal

28 , either

29− , optparse-applicative == 0.13.*

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

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.*

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

46 , text == 1.2.*

47 , mtl >= 2.2.1 && < 2.3

48− , hmatrix >= 0.18 && < 0.19

48+ , hmatrix >= 0.18 && < 0.21

49 , transformers

50 , semigroups

51 , singletons

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

61 , bytestring

62 , cereal

63 , either

64− , optparse-applicative == 0.13.*

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

65 , text == 1.2.*

66 , mtl >= 2.2.1 && < 2.3

67− , hmatrix >= 0.18 && < 0.19

67+ , hmatrix >= 0.18 && < 0.21

68 , transformers

69 , semigroups

70 , singletons

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

78 , grenade

79 , attoparsec

80 , either

81− , optparse-applicative == 0.13.*

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

82 , text == 1.2.*

83 , mtl >= 2.2.1 && < 2.3

84− , hmatrix >= 0.18 && < 0.19

84+ , hmatrix >= 0.18 && < 0.21

85 , transformers

86 , semigroups

87 , singletons

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

96 , bytestring

97 , cereal

98 , either

99− , optparse-applicative == 0.13.*

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

100 , text == 1.2.*

101 , mtl >= 2.2.1 && < 2.3

102− , hmatrix >= 0.18 && < 0.19

102+ , hmatrix >= 0.18 && < 0.21

103 , transformers

104 , semigroups

105 , singletons

106+ , singletons-base

106 , vector

107 , vector

107 , MonadRandom

108 , MonadRandom

108 , containers

109 , containers

examples/mafianew file+62

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

1+#!/bin/sh -eu

2+

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

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

5+

6+latest_version () {

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

8+}

9+

10+build_version() {

11+ MAFIA_VERSION="$1"

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

13+ MAFIA_FILE=mafia-$MAFIA_VERSION

14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE

15+ mkdir -p $MAFIA_VERSIONS

16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

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

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

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

20+ exit 1

21+ }

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

23+ got=$?

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

25+ exit "$got"

26+ }

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

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

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

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

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

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

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

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

35+ exit 0

36+ }

37+}

38+

39+enable_version() {

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

41+ MAFIA_VERSION="$(latest_version)"

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

43+ else

44+ MAFIA_VERSION="$1"

45+ fi

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

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

48+}

49+

50+exec_mafia () {

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

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

53+}

54+

55+#

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

57+#

58+

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

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

61+*) exec_mafia "$@"

62+esac

examples/main/feedforward.hs+3−1

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

1{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

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

10

11

11import qualified Data.ByteString as B

12import qualified Data.ByteString as B

12import Data.Serialize

13import Data.Serialize

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

13import Data.Semigroup ( (<>) )

15import Data.Semigroup ( (<>) )

14−

16+#endif

15import GHC.TypeLits

17import GHC.TypeLits

16

18

17import qualified Numeric.LinearAlgebra.Static as SA

19import qualified Numeric.LinearAlgebra.Static as SA

examples/main/gan-mnist.hs+3

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

1{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ScopedTypeVariables #-}

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

43import qualified Data.Attoparsec.Text as A

44import qualified Data.Attoparsec.Text as A

44import qualified Data.ByteString as B

45import qualified Data.ByteString as B

45import Data.List ( foldl' )

46import Data.List ( foldl' )

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

46import Data.Semigroup ( (<>) )

48import Data.Semigroup ( (<>) )

49+#endif

47import Data.Serialize

50import Data.Serialize

48import qualified Data.Text as T

51import qualified Data.Text as T

49import qualified Data.Text.IO as T

52import qualified Data.Text.IO as T

examples/main/mnist.hs+4

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

1{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

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

13

14

14import qualified Data.Attoparsec.Text as A

15import qualified Data.Attoparsec.Text as A

15import Data.List ( foldl' )

16import Data.List ( foldl' )

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

16import Data.Semigroup ( (<>) )

18import Data.Semigroup ( (<>) )

19+#endif

20+

17import qualified Data.Text as T

21import qualified Data.Text as T

18import qualified Data.Text.IO as T

22import qualified Data.Text.IO as T

19import qualified Data.Vector.Storable as V

23import 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 __GLASGOW_HASKELL__ < 800

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

13import Data.List ( unfoldr )

14#else

15import Data.List ( cycle, unfoldr )

16−#endif

17import Data.Semigroup ( (<>) )

16import Data.Semigroup ( (<>) )

17+#endif

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 4), R (LSTM 4 1)]

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

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

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

36

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

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

38

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

39+randomNet :: MonadRandom m => m RecNet

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, i0) <- randomNet

85+ net0 <- randomNet

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

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

87

88 let results = generateRecurrent trained bestInput (c 1)

89

examples/main/shakespeare.hs+26−23

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

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

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

14import Data.List ( foldl' )

15import Data.Maybe ( fromMaybe )

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

16+

17

18import qualified Data.Vector as V

19import Data.Vector ( Vector )

20

21import qualified Data.Map as M

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

23

22

24import qualified Data.ByteString as B

23import qualified Data.ByteString as B

25import Data.Serialize

24import Data.Serialize

26

25

27−import Data.Singletons.Prelude

28import GHC.TypeLits

26import GHC.TypeLits

29

27

30import Numeric.LinearAlgebra.Static ( konst )

28import Numeric.LinearAlgebra.Static ( konst )

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

36import Grenade.Utils.OneHot

34import Grenade.Utils.OneHot

37

35

38import System.IO.Unsafe ( unsafeInterleaveIO )

36import 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+--

44-- This is a first class recurrent net.

47-- This is a first class recurrent net.

45--

48--

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

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

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

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

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

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

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

63

66

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

67+randomNet :: MonadRandom m => m Shakespeare

65randomNet = randomRecurrent

68randomNet = randomRecurrent

66

69

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

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

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

69loadShakespeare path = do

72loadShakespeare path = do

70 contents <- lift $ readFile path

73 contents <- lift $ readFile path

71 let annotated = annotateCapitals contents

74 let annotated = annotateCapitals contents

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

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

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

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

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

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

75

78

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

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

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

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

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

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

79 in case reverse e of

82 in case reverse e of

80 (o : l : xs) ->

83 (o : l : xs) ->

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

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

82− in trainRecurrent rate net recIns examples

85+ in trainRecurrent lrate net recIns examples

83 _ -> error "Not enough input"

86 _ -> error "Not enough input"

84 where

87 where

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

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

86

89

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

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

88−runShakespeare ShakespeareOpts {..} = do

91+runShakespeare opts = do

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

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

90 (net0, i0) <- lift $

93 (net0, i0) <- lift $

91− case loadPath of

94+ case loadPath opts of

92 Just loadFile -> netLoad loadFile

95 Just loadFile -> netLoad loadFile

93− Nothing -> randomNet

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

94

97

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

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

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

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

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

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

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

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

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

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

100 putStrLn (unAnnotateCapitals results)

103 putStrLn (unAnnotateCapitals results)

101 return (trained, bestInput)

104 return (trained, bestInput)

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

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

103

106

104− case savePath of

107+ case savePath opts of

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

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

106 Nothing -> return ()

109 Nothing -> return ()

107

110

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

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

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

113 -> Vector a

116 -> Vector a

114 -> S ('D1 n)

117 -> S ('D1 n)

115 -> IO [a]

118 -> IO [a]

116−generateParagraph n s temperature hotmap hotdict =

119+generateParagraph n s temp hotmap hotdict =

117 go s

120 go s

118 where

121 where

119 go x y =

122 go x y =

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

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

121− un <- sample temperature hotdict o

124+ un <- sample temp hotdict o

122− Just re <- return $ makeHot hotmap un

125+ Just re <- return $ makeHot hotmap un

123− rest <- unsafeInterleaveIO $ go ns re

126+ rest <- unsafeInterleaveIO $ go ns re

124 return (un : rest)

127 return (un : rest)

125

128

126data ShakespeareOpts = ShakespeareOpts {

129data ShakespeareOpts = ShakespeareOpts {

framework/mafianew file+62

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

1+#!/bin/sh -eu

2+

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

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

5+

6+latest_version () {

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

8+}

9+

10+build_version() {

11+ MAFIA_VERSION="$1"

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

13+ MAFIA_FILE=mafia-$MAFIA_VERSION

14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE

15+ mkdir -p $MAFIA_VERSIONS

16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

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

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

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

20+ exit 1

21+ }

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

23+ got=$?

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

25+ exit "$got"

26+ }

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

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

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

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

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

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

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

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

35+ exit 0

36+ }

37+}

38+

39+enable_version() {

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

41+ MAFIA_VERSION="$(latest_version)"

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

43+ else

44+ MAFIA_VERSION="$1"

45+ fi

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

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

48+}

49+

50+exec_mafia () {

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

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

53+}

54+

55+#

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

57+#

58+

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

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

61+*) exec_mafia "$@"

62+esac

grenade.cabal+39−23

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

10+cabal-version: >= 1.10

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 decent for learning.

20+ gradients; and applying gradient descent 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_decent.h

29+ cbits/gradient_descent.h

30− cbits/gradient_decent.c

30+ cbits/gradient_descent.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.*

41+ , bytestring >= 0.10.0

42− , containers >= 0.5 && < 0.6

42+ , containers >= 0.5 && < 0.7

43 , cereal >= 0.5 && < 0.6

44 , deepseq >= 1.4 && < 1.5

45− , exceptions == 0.8.*

46− , hmatrix == 0.18.*

45+ , hmatrix >= 0.18 && < 0.21

47 , MonadRandom >= 0.4 && < 0.6

46 , MonadRandom >= 0.4 && < 0.6

48− , mtl >= 2.2.1 && < 2.3

49− , primitive >= 0.6 && < 0.7

47+ , primitive >= 0.6 && < 0.8

50− , text == 1.2.*

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

51− , singletons >= 2.1 && < 2.3

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

50+ , singletons

51+ , singletons-base

52 , vector >= 0.11 && < 0.13

53

54 ghc-options:

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

56 hs-source-dirs:

57 src

58

59+ default-language: Haskell2010

60+

59 if impl(ghc < 8.0)

61 if impl(ghc < 8.0)

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

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

63+ cpp-options: -DType=*

61

64

65+ if impl(ghc >= 8.6)

66+ default-extensions: NoStarIsType

62

67

63 exposed-modules:

68 exposed-modules:

64 Grenade

69 Grenade

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

84 Grenade.Layers.Pooling

89 Grenade.Layers.Pooling

85 Grenade.Layers.Relu

90 Grenade.Layers.Relu

86 Grenade.Layers.Reshape

91 Grenade.Layers.Reshape

92+ Grenade.Layers.Sinusoid

87 Grenade.Layers.Softmax

93 Grenade.Layers.Softmax

88 Grenade.Layers.Tanh

94 Grenade.Layers.Tanh

89 Grenade.Layers.Trivial

95 Grenade.Layers.Trivial

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

102

108

103 Grenade.Recurrent.Layers

109 Grenade.Recurrent.Layers

104 Grenade.Recurrent.Layers.BasicRecurrent

110 Grenade.Recurrent.Layers.BasicRecurrent

111+ Grenade.Recurrent.Layers.ConcatRecurrent

105 Grenade.Recurrent.Layers.LSTM

112 Grenade.Recurrent.Layers.LSTM

106

113

107 Grenade.Utils.OneHot

114 Grenade.Utils.OneHot

108

115

109 includes: cbits/im2col.h

116 includes: cbits/im2col.h

110− cbits/gradient_decent.h

117+ cbits/gradient_descent.h

111 cbits/pad.h

118 cbits/pad.h

112 c-sources: cbits/im2col.c

119 c-sources: cbits/im2col.c

113− cbits/gradient_decent.c

120+ cbits/gradient_descent.c

114 cbits/pad.c

121 cbits/pad.c

115

122

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

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

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

125 hs-source-dirs:

132 hs-source-dirs:

126 test

133 test

127

134

135+ default-language: Haskell2010

128

136

129 other-modules: Test.Hedgehog.Compat

137 other-modules: Test.Hedgehog.Compat

130 Test.Hedgehog.Hmatrix

138 Test.Hedgehog.Hmatrix

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

145

153

146 if impl(ghc < 8.0)

154 if impl(ghc < 8.0)

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

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

156+ cpp-options: -DType=*

157+

158+ if impl(ghc >= 8.6)

159+ default-extensions: NoStarIsType

148

160

149 build-depends:

161 build-depends:

150− base >= 4.8 && < 5

162+ base

151 , grenade

163 , grenade

152− , hedgehog >= 0.4 && < 0.5

164+ , hedgehog >= 1.0 && < 1.1

153 , hmatrix

165 , hmatrix

154 , mtl

166 , mtl

155 , singletons

167 , singletons

156 , text == 1.2.*

168 , text == 1.2.*

157− , typelits-witnesses

169+ , typelits-witnesses < 0.4

158 , transformers

170 , transformers

159 , constraints

171 , constraints

160 , MonadRandom

172 , MonadRandom

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

174 hs-source-dirs:

186 hs-source-dirs:

175 bench

187 bench

176

188

189+ default-language: Haskell2010

190+

177 build-depends:

191 build-depends:

178− base >= 3 && < 5

192+ base

179− , bytestring == 0.10.*

193+ , bytestring

180− , criterion == 1.1.*

194+ , criterion >= 1.1 && < 1.6

181 , grenade

195 , grenade

182 , hmatrix

196 , hmatrix

183

197

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

191 hs-source-dirs:

205 hs-source-dirs:

192 bench

206 bench

193

207

208+ default-language: Haskell2010

209+

194 build-depends:

210 build-depends:

195− base >= 3 && < 5

211+ base

196− , bytestring == 0.10.*

212+ , bytestring

197− , criterion == 1.1.*

213+ , criterion

198 , grenade

214 , grenade

199 , hmatrix

215 , hmatrix

mafiamode 100755 → 120000+1−123

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

1−#!/bin/sh -eu

2−

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

4−

5−fetch_latest () {

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

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

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

9− else

10− cat ../script/mafia

11− fi

12−}

13−

14−latest_version () {

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

16−}

17−

18−local_version () {

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

20−}

21−

22−run_upgrade () {

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

24−

25− clean_up () {

26− rm -f "$MAFIA_TEMP"

27− }

28−

29− trap clean_up EXIT

30−

31− MAFIA_CUR="$0"

32−

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

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

35− exit 1

36− fi

37−

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

39− fetch_latest > $MAFIA_TEMP

40−

41− LATEST_VERSION=$(latest_version)

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

43−

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

45− mv $MAFIA_TEMP $MAFIA_CUR

46− chmod +x $MAFIA_CUR

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

48− else

49− echo "You have latest mafia."

50− fi

51−}

52−

53−exec_mafia () {

54− MAFIA_VERSION=$(local_version)

55−

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

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

58− run_upgrade

59− else

60− MAFIA_BIN=$MAFIA_HOME/bin

61− MAFIA_FILE=mafia-$MAFIA_VERSION

62− MAFIA_PATH=$MAFIA_BIN/$MAFIA_FILE

63−

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

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

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

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

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

69−

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

71− mkdir -p $MAFIA_BIN

72−

73− clean_up () {

74− rm -rf "$MAFIA_TEMP"

75− }

76−

77− trap clean_up EXIT

78−

79− echo "Building $MAFIA_FILE in $MAFIA_TEMP"

80−

81− ( cd "$MAFIA_TEMP"

82−

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

84− cd mafia

85−

86− git reset --hard $MAFIA_VERSION

87−

88− bin/bootstrap ) || exit $?

89−

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

91−

92− clean_up_temp () {

93− clean_up

94− rm -f "$MAFIA_PATH_TEMP"

95− }

96− trap clean_up_temp EXIT

97−

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

99− chmod 755 "$MAFIA_PATH_TEMP"

100− mv "$MAFIA_PATH_TEMP" "$MAFIA_PATH"

101−

102− clean_up_temp

103− }

104−

105− exec $MAFIA_PATH "$@"

106− fi

107−}

108−

109−#

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

111−#

112−

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

114− MODE="$1"

115−else

116− MODE=""

117−fi

118−

119−case "$MODE" in

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

121−*) exec_mafia "$@"

122−esac

123−# Version: 360716306a06db842ec022a7b9f161d2208483f0

@@ -0,0 +1 @@

1+framework/mafia

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

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

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

20

21

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

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

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

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

23to the input and output data of the layer.

24to the input and output data of the layer.

24

25

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

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

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

41

42

42import Data.List ( foldl' )

43import Data.List ( foldl' )

43

44

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

46+import Data.Kind (Type)

47+#endif

48+

44import Grenade.Core.Shape

49import Grenade.Core.Shape

45import Grenade.Core.LearningParameters

50import Grenade.Core.LearningParameters

46

51

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

50class UpdateLayer x where

55class UpdateLayer x where

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

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

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

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

53− type Gradient x :: *

58+ type Gradient x :: Type

54

59

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

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

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

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

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

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

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

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

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

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

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

75− type Tape x i o :: *

80+ type Tape x i o :: Type

76

81

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

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

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

83 -- 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 consifered

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

11 -- unstable, due to issue #26.

12

13 LearningParameters (..)

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

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

33import Control.Monad.Random ( MonadRandom )

34import Control.Monad.Random ( MonadRandom )

34

35

35import Data.Singletons

36import 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+

39import Grenade.Core.Layer

43import Grenade.Core.Layer

40import Grenade.Core.LearningParameters

44import Grenade.Core.LearningParameters

41import Grenade.Core.Shape

45import Grenade.Core.Shape

46+import Prelude.Singletons

42

47

43-- | Type of a network.

48-- | Type of a network.

44--

49--

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

48--

53--

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

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

50-- transform the data shapes of the network.

55-- transform the data shapes of the network.

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

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

52 NNil :: SingI i

57 NNil :: SingI i

53 => Network '[] '[i]

58 => Network '[] '[i]

54

59

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

66-- | Gradient of a network.

71-- | Gradient of a network.

67--

72--

68-- Parameterised on the layers of the network.

73-- Parameterised on the layers of the network.

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

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

70 GNil :: Gradients '[]

75 GNil :: Gradients '[]

71

76

72 (:/>) :: UpdateLayer x

77 (:/>) :: UpdateLayer x

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

77-- | Wegnert Tape of a network.

82-- | Wegnert Tape of a network.

78--

83--

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

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

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

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

81 TNil :: SingI i

86 TNil :: SingI i

82 => Tapes '[] '[i]

87 => Tapes '[] '[i]

83

88

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

139 = (GNil, o)

144 = (GNil, o)

140

145

141

146

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

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

143applyUpdate :: LearningParameters

148applyUpdate :: LearningParameters

144 -> Network layers shapes

149 -> Network layers shapes

145 -> Gradients layers

150 -> Gradients layers

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

152

157

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

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

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

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

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

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

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

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

157 --

162 --

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

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

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

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

13 , runNet

14 ) where

15

16−import Data.Singletons.Prelude

17

16

18import Grenade.Core.LearningParameters

17import Grenade.Core.LearningParameters

19import Grenade.Core.Network

18import Grenade.Core.Network

20import Grenade.Core.Shape

19import Grenade.Core.Shape

20+import Data.Singletons

21+import Prelude.Singletons

21

22

22-- | Perform reverse automatic differentiation on the network

23-- | Perform reverse automatic differentiation on the network

23-- for the current input and expected output.

24-- for the current input and expected output.

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE KindSignatures #-}

4{-# LANGUAGE KindSignatures #-}

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

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE UndecidableInstances #-}

10{-|

12{-|

11Module : Grenade.Core.Shape

13Module : Grenade.Core.Shape

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

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

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

17

19

18-}

20-}

19module Grenade.Core.Shape (

21module Grenade.Core.Shape (

22+ S (..)

20− Shape (..)

23+ , Shape (..)

21− , S (..)

24+ , SShape (..)

22− , Sing (..)

23−

24 , randomOfShape

25 , randomOfShape

25 , fromStorable

26 , fromStorable

26 ) where

27 ) where

27

28

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

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

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

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

30−

31+import Data.Kind (Type)

31import Data.Proxy

32import Data.Proxy

33+import Data.Serialize

32import Data.Singletons

34import Data.Singletons

33−import Data.Singletons.TypeLits

34import Data.Vector.Storable ( Vector )

35import Data.Vector.Storable ( Vector )

35import qualified Data.Vector.Storable as V

36import qualified Data.Vector.Storable as V

36−

37import GHC.TypeLits

38−

39import qualified Numeric.LinearAlgebra.Static as H

38import qualified Numeric.LinearAlgebra.Static as H

40import Numeric.LinearAlgebra.Static

39import Numeric.LinearAlgebra.Static

41import qualified Numeric.LinearAlgebra as NLA

40import qualified Numeric.LinearAlgebra as NLA

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

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

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

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

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

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

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

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

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

84+type instance Sing = SShape

85+

86+data SShape :: Shape -> Type where

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

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

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

90+#else

83data instance Sing (n :: Shape) where

91data instance Sing (n :: Shape) where

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

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

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

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

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

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

95+#endif

87

96

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

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

89− sing = D1Sing sing

98+ sing = D1Sing

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

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

91− sing = D2Sing sing sing

100+ sing = D2Sing

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

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

93− sing = D3Sing sing sing sing

102+ sing = D3Sing

94

103

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

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

96 (+) = n2 (+)

105 (+) = n2 (+)

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

139randomOfShape = do

148randomOfShape = do

140 seed :: Int <- getRandom

149 seed :: Int <- getRandom

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

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

142− D1Sing SNat ->

151+ D1Sing ->

143 S1D (randomVector seed Uniform * 2 - 1)

152 S1D (randomVector seed Uniform * 2 - 1)

144

153

145− D2Sing SNat SNat ->

154+ D2Sing ->

146 S2D (uniformSample seed (-1) 1)

155 S2D (uniformSample seed (-1) 1)

147

156

148− D3Sing SNat SNat SNat ->

157+ D3Sing ->

149 S3D (uniformSample seed (-1) 1)

158 S3D (uniformSample seed (-1) 1)

150

159

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

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

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

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

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

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

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

155fromStorable xs = case sing :: Sing x of

164fromStorable xs = case sing :: Sing x of

156− D1Sing SNat ->

165+ D1Sing ->

157 S1D <$> H.create xs

166 S1D <$> H.create xs

158

167

159− D2Sing SNat SNat ->

168+ D2Sing ->

160 S2D <$> mkL xs

169 S2D <$> mkL xs

161

170

162− D3Sing SNat SNat SNat ->

171+ D3Sing ->

163 S3D <$> mkL xs

172 S3D <$> mkL xs

164 where

173 where

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

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

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

171 then H.create $ NLA.reshape columns v

180 then H.create $ NLA.reshape columns v

172 else Nothing

181 else Nothing

173

182

183+

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

185+ put i = (case i of

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

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

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

189+ ) :: PutM ()

190+

191+ get = do

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

193+ return i

194+

174-- Helper function for creating the number instances

195-- Helper function for creating the number instances

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

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

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

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

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

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

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

185

206

186-- Helper function for creating the number instances

207-- Helper function for creating the number instances

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

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

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

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

189− D1Sing SNat ->

210+ D1Sing ->

190 S1D (konst x)

211 S1D (konst x)

191

212

192− D2Sing SNat SNat ->

213+ D2Sing ->

193 S2D (konst x)

214 S2D (konst x)

194

215

195− D3Sing SNat SNat SNat ->

216+ D3Sing ->

196 S3D (konst x)

217 S3D (konst x)

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

8{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE StandaloneDeriving #-}

11{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE UndecidableInstances #-}

11{-|

13{-|

12Module : Grenade.Layers.Concat

14Module : Grenade.Layers.Concat

13Description : Concatenation layer

15Description : Concatenation layer

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

26import Data.Singletons

28import Data.Singletons

27import GHC.TypeLits

29import GHC.TypeLits

28

30

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

32+import Data.Kind (Type)

33+#endif

34+

29import Grenade.Core

35import Grenade.Core

30

36

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

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

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

43--

49--

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

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

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

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

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

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

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

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

48

54

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

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

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE ScopedTypeVariables #-}

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

10{-|

11{-|

11Module : Grenade.Layers.Convolution

12Module : Grenade.Layers.Convolution

12Description : Convolution layer

13Description : Convolution layer

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

27import Data.Maybe

28import Data.Maybe

28import Data.Proxy

29import Data.Proxy

29import Data.Serialize

30import Data.Serialize

30−import Data.Singletons.TypeLits

31

32import GHC.TypeLits

33+import Data.Kind (Type)

33

34

34import Numeric.LinearAlgebra hiding ( uniformSample, konst )

35import Numeric.LinearAlgebra hiding ( uniformSample, konst )

35import qualified Numeric.LinearAlgebra as LA

36import qualified Numeric.LinearAlgebra as LA

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

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

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

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

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

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

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

59− -> * where

60+ -> Type where

60 Convolution :: ( KnownNat channels

61 Convolution :: ( KnownNat channels

61 , KnownNat filters

62 , KnownNat filters

62 , KnownNat kernelRows

63 , KnownNat kernelRows

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

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

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

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

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

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

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

78− -> * where

79+ -> Type where

79 Convolution' :: ( KnownNat channels

80 Convolution' :: ( KnownNat channels

80 , KnownNat filters

81 , KnownNat filters

81 , KnownNat kernelRows

82 , KnownNat kernelRows

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

129 , KnownNat strideColumns

130 , KnownNat strideColumns

130 , KnownNat (kernelRows * kernelColumns * channels)

131 , KnownNat (kernelRows * kernelColumns * channels)

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

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

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

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

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

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

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

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

135 in Convolution newKernel newMomentum

136 in Convolution newKernel newMomentum

136

137

137 createRandom = randomConvolution

138 createRandom = randomConvolution

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

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

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE UndecidableInstances #-}

8{-|

10{-|

9Module : Grenade.Layers.Crop

11Module : Grenade.Layers.Crop

10Description : Cropping layer

12Description : Cropping layer

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

18

20

19import Data.Maybe

21import Data.Maybe

20import Data.Proxy

22import Data.Proxy

21−import Data.Singletons.TypeLits

23+import Data.Serialize

24+

22import GHC.TypeLits

25import GHC.TypeLits

26+import Data.Kind (Type)

23

27

24import Grenade.Core

28import Grenade.Core

25import Grenade.Layers.Internal.Pad

29import Grenade.Layers.Internal.Pad

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

31data Crop :: Nat

35data Crop :: Nat

32 -> Nat

36 -> Nat

33 -> Nat

37 -> Nat

34− -> Nat -> * where

38+ -> Nat -> Type where

35 Crop :: Crop cropLeft cropTop cropRight cropBottom

39 Crop :: Crop cropLeft cropTop cropRight cropBottom

36

40

37instance Show (Crop cropLeft cropTop cropRight cropBottom) where

41instance Show (Crop cropLeft cropTop cropRight cropBottom) where

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

42 runUpdate _ x _ = x

46 runUpdate _ x _ = x

43 createRandom = return Crop

47 createRandom = return Crop

44

48

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

50+ put _ = return ()

51+ get = return Crop

52+

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

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

46instance ( KnownNat cropLeft

54instance ( KnownNat cropLeft

47 , KnownNat cropTop

55 , KnownNat cropTop

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

51 , KnownNat inputColumns

59 , KnownNat inputColumns

52 , KnownNat outputRows

60 , KnownNat outputRows

53 , KnownNat outputColumns

61 , KnownNat outputColumns

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

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

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

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

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

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

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

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

58 runForwards Crop (S2D input) =

66 runForwards Crop (S2D input) =

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE ScopedTypeVariables #-}

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

10{-|

11{-|

11Module : Grenade.Layers.Deconvolution

12Module : Grenade.Layers.Deconvolution

12Description : Deconvolution layer

13Description : Deconvolution layer

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

31import Data.Maybe

32import Data.Maybe

32import Data.Proxy

33import Data.Proxy

33import Data.Serialize

34import Data.Serialize

34−import Data.Singletons.TypeLits

35

36import GHC.TypeLits

37+import Data.Kind (Type)

37

38

38import Numeric.LinearAlgebra hiding ( uniformSample, konst )

39import Numeric.LinearAlgebra hiding ( uniformSample, konst )

39import qualified Numeric.LinearAlgebra as LA

40import qualified Numeric.LinearAlgebra as LA

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

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

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

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

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

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

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

58− -> * where

59+ -> Type where

59 Deconvolution :: ( KnownNat channels

60 Deconvolution :: ( KnownNat channels

60 , KnownNat filters

61 , KnownNat filters

61 , KnownNat kernelRows

62 , KnownNat kernelRows

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

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

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

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

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

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

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

77− -> * where

78+ -> Type where

78 Deconvolution' :: ( KnownNat channels

79 Deconvolution' :: ( KnownNat channels

79 , KnownNat filters

80 , KnownNat filters

80 , KnownNat kernelRows

81 , KnownNat kernelRows

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

128 , KnownNat strideColumns

129 , KnownNat strideColumns

129 , KnownNat (kernelRows * kernelColumns * filters)

130 , KnownNat (kernelRows * kernelColumns * filters)

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

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

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

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

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

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

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

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

134 in Deconvolution newKernel newMomentum

135 in Deconvolution newKernel newMomentum

135

136

136 createRandom = randomDeconvolution

137 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) = S ('D1 i)

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

40

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

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

42 where

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

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

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

45 where

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

47

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

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

1{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE TypeOperators #-}

2{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeFamilies #-}

3{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

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

14

13

15import Data.Proxy

14import Data.Proxy

16import Data.Serialize

15import Data.Serialize

17−import Data.Singletons.TypeLits

18

16

19import qualified Numeric.LinearAlgebra as LA

17import qualified Numeric.LinearAlgebra as LA

20import Numeric.LinearAlgebra.Static

18import Numeric.LinearAlgebra.Static

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

22import Grenade.Core

20import Grenade.Core

23

21

24import Grenade.Layers.Internal.Update

22import Grenade.Layers.Internal.Update

23+import GHC.TypeLits

25

24

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

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

27data FullyConnected i o = FullyConnected

26data FullyConnected i o = FullyConnected

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

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

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

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

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

40

39

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

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

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

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

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

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

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

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

45

44

46 createRandom = randomFullyConnected

45 createRandom = randomFullyConnected

47

46

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

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

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

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

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

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

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

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

52

51

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

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

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

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

55 let wB' = dEdy

54 let wB' = dEdy

56 mm' = dEdy `outer` x

55 mm' = dEdy `outer` x

57 -- calcluate derivatives for next step

56 -- calcluate derivatives for next step

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

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

1{-# LANGUAGE ForeignFunctionInterface #-}

2module Grenade.Layers.Internal.Update (

3− decendMatrix

3+ descendMatrix

4− , decendVector

4+ , descendVector

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−decendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)

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

21−decendMatrix rate momentum regulariser weights gradient lastUpdate =

21+descendMatrix rate momentum regulariser weights gradient lastUpdate =

22 let (rows, cols) = size weights

23 len = rows * cols

24 -- Most gradients come in in ColumnMajor,

@@ -29,7 +29,7 @@ decendMatrix 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) = decendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'

32+ (vw, vm) = descendUnsafe 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 @@ decendMatrix 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−decendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)

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

41−decendVector rate momentum regulariser weights gradient lastUpdate =

41+descendVector rate momentum regulariser weights gradient lastUpdate =

42 let len = size weights

43 weights' = extract weights

44 gradient' = extract gradient

45 lastUpdate' = extract lastUpdate

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

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

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

48

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

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

50−decendUnsafe len rate momentum regulariser weights gradient lastUpdate =

50+descendUnsafe len rate momentum regulariser weights gradient lastUpdate =

51 unsafePerformIO $ do

52 outWPtr <- mallocForeignPtrArray len

53 outMPtr <- mallocForeignPtrArray len

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

60 withForeignPtr lPtr $ \lPtr' ->

61 withForeignPtr outWPtr $ \outWPtr' ->

62 withForeignPtr outMPtr $ \outMPtr' ->

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

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

64

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

66

67foreign import ccall unsafe

68− decend_cpu

68+ descend_cpu

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

70

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

@@ -34,18 +34,24 @@ 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.

37 type Tape Logit a b = S a

44 type Tape Logit a b = S a

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

45+ runForwards _ a =

46+ let l = sigmoid a

47+ in (l, l)

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

48+ runBackwards _ l g =

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

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

40

51

41instance Serialize Logit where

52instance Serialize Logit where

42 put _ = return ()

53 put _ = return ()

43 get = return Logit

54 get = return Logit

44

55

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

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

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

57+sigmoid 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+6−1

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

23

24

24import Data.Singletons

25import Data.Singletons

25

26

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

28+import Data.Kind (Type)

29+#endif

30+

26import Grenade.Core

31import Grenade.Core

27

32

28-- | A Merging layer.

33-- | A Merging layer.

29--

34--

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

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

31-- shape.

36-- shape.

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

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

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

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

34

39

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

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

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

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

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE FlexibleContexts #-}

9+{-# LANGUAGE UndecidableInstances #-}

8{-|

10{-|

9Module : Grenade.Core.Pad

11Module : Grenade.Core.Pad

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

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

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

19import Data.Maybe

21import Data.Maybe

20import Data.Proxy

22import Data.Proxy

21import Data.Serialize

23import Data.Serialize

22−import Data.Singletons.TypeLits

24+

23import GHC.TypeLits

25import GHC.TypeLits

26+import Data.Kind (Type)

24

27

25import Grenade.Core

28import Grenade.Core

26import Grenade.Layers.Internal.Pad

29import Grenade.Layers.Internal.Pad

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

34data Pad :: Nat

37data Pad :: Nat

35 -> Nat

38 -> Nat

36 -> Nat

39 -> Nat

37− -> Nat -> * where

40+ -> Nat -> Type where

38 Pad :: Pad padLeft padTop padRight padBottom

41 Pad :: Pad padLeft padTop padRight padBottom

39

42

40instance Show (Pad padLeft padTop padRight padBottom) where

43instance Show (Pad padLeft padTop padRight padBottom) where

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

49 put _ = return ()

52 put _ = return ()

50 get = return Pad

53 get = return Pad

51

54

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

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

53instance ( KnownNat padLeft

56instance ( KnownNat padLeft

54 , KnownNat padTop

57 , KnownNat padTop

55 , KnownNat padRight

58 , KnownNat padRight

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

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

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

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

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

81

84

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

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

83instance ( KnownNat padLeft

86instance ( KnownNat padLeft

84 , KnownNat padTop

87 , KnownNat padTop

85 , KnownNat padRight

88 , KnownNat padRight

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE StandaloneDeriving #-}

4{-# LANGUAGE StandaloneDeriving #-}

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

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

9{-|

11{-|

10Module : Grenade.Core.Pooling

12Module : Grenade.Core.Pooling

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

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

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

20import Data.Maybe

22import Data.Maybe

21import Data.Proxy

23import Data.Proxy

22import Data.Serialize

24import Data.Serialize

23−import Data.Singletons.TypeLits

25+

24import GHC.TypeLits

26import GHC.TypeLits

27+import Data.Kind (Type)

25

28

26import Grenade.Core

29import Grenade.Core

27import Grenade.Layers.Internal.Pooling

30import Grenade.Layers.Internal.Pooling

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

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

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

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

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

38--

41--

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

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

40 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

43 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

41

44

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

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

43 show Pooling = "Pooling"

46 show Pooling = "Pooling"

44

47

45instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

48instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

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

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

47 runUpdate _ Pooling _ = Pooling

50 runUpdate _ Pooling _ = Pooling

48 createRandom = return Pooling

51 createRandom = return Pooling

49

52

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

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

3{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE UndecidableInstances #-}

6{-|

7{-|

7Module : Grenade.Layers.Reshape

8Module : Grenade.Layers.Reshape

8Description : Multipurpose reshaping layer

9Description : Multipurpose reshaping layer

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

16

17

17import Data.Serialize

18import Data.Serialize

18

19

19−import Data.Singletons.TypeLits

20import GHC.TypeLits

21

22import Numeric.LinearAlgebra.Static

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

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-|

7+Module : Grenade.Layers.Sinusoid

8+Description : Sinusoid nonlinear layer

9+Copyright : (c) Manuel Schneckenreither, 2018

10+License : BSD2

11+Stability : experimental

12+-}

13+module Grenade.Layers.Sinusoid (

14+ Sinusoid (..)

15+ ) where

16+

17+import Data.Serialize

18+import Data.Singletons

19+

20+import Grenade.Core

21+

22+-- | A Sinusoid layer.

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

24+data Sinusoid = Sinusoid

25+ deriving Show

26+

27+instance UpdateLayer Sinusoid where

28+ type Gradient Sinusoid = ()

29+ runUpdate _ _ _ = Sinusoid

30+ createRandom = return Sinusoid

31+

32+instance Serialize Sinusoid where

33+ put _ = return ()

34+ get = return Sinusoid

35+

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

37+ type Tape Sinusoid a b = S a

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

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

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

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

1{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeOperators #-}

3−{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeOperators #-}

6{-|

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, perfoming a tanh function.

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

24data Tanh = Tanh

25 deriving Show

26

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE TypeFamilies #-}

3{-# LANGUAGE TypeFamilies #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

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

8 , RecurrentUpdateLayer (..)

9 , RecurrentUpdateLayer (..)

9 ) where

10 ) where

10

11

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

11−import Data.Singletons ( SingI )

13+import Data.Kind (Type)

14+#endif

12

15

13import Grenade.Core

16import Grenade.Core

14

17

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

17-- of an extra recurrent data shape.

20-- of an extra recurrent data shape.

18class UpdateLayer x => RecurrentUpdateLayer x where

21class UpdateLayer x => RecurrentUpdateLayer x where

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

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

20− type RecurrentShape x :: Shape

23+ type RecurrentShape x :: Type

21

24

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

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

23 -- | Wengert Tape

26 -- | Wengert Tape

24− type RecTape x i o :: *

27+ type RecTape x i o :: Type

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

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

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

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

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

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

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

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

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

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

30 -- the layer above.

33 -- the layer above.

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

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

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

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

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

17

18

18 , RecurrentNetwork (..)

19 , RecurrentNetwork (..)

19 , RecurrentInputs (..)

20 , RecurrentInputs (..)

20− , RecurrentTapes (..)

21+ , RecurrentTape (..)

21− , RecurrentGradients (..)

22+ , RecurrentGradient (..)

22

23

23 , randomRecurrent

24 , randomRecurrent

24− , runRecurrentNetwork

25+ , runRecurrent

25− , runRecurrentGradient

26+ , runRecurrent'

26 , applyRecurrentUpdate

27 , applyRecurrentUpdate

27 ) where

28 ) where

28

29

30

30import Control.Monad.Random ( MonadRandom )

31import Control.Monad.Random ( MonadRandom )

31−import Data.Singletons ( SingI )

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

33import Data.Serialize

32import Data.Serialize

34−import qualified Data.Vector.Storable as V

33+

34+import Data.Kind (Type)

35

36import Grenade.Core

37import Grenade.Recurrent.Core.Layer

38−

38+import Prelude.Singletons

39−import qualified Numeric.LinearAlgebra as LA

40−import qualified Numeric.LinearAlgebra.Static as LAS

41

39

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

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

43-- forward layer.

41-- forward layer.

44−data FeedForward :: * -> *

42+data FeedForward :: Type -> Type

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

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

46−data Recurrent :: * -> *

44+data Recurrent :: Type -> Type

47

45

48-- | Type of a recurrent neural network.

46-- | Type of a recurrent neural network.

49--

47--

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

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

51--

49--

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

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

53--

51--

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

56--

54--

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

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

58-- for these empty data types.

56-- for these empty data types.

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

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

60 RNil :: SingI i

58 RNil :: SingI i

61 => RecurrentNetwork '[] '[i]

59 => RecurrentNetwork '[] '[i]

62

60

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

75-- | Gradient of a network.

73-- | Gradient of a network.

76--

74--

77-- Parameterised on the layers of the network.

75-- Parameterised on the layers of the network.

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

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

79− RGNil :: RecurrentGradients '[]

77+ RGNil :: RecurrentGradient '[]

80

78

81 (://>) :: UpdateLayer x

79 (://>) :: UpdateLayer x

82− => [Gradient x]

80+ => Gradient x

83− -> RecurrentGradients xs

81+ -> RecurrentGradient xs

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

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

85

83

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

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

87-- Parameterised on the layers of a Network.

85-- Parameterised on the layers of a Network.

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

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

89 RINil :: RecurrentInputs '[]

87 RINil :: RecurrentInputs '[]

90

88

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

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

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

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

93

91

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

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

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

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

96

94

97-- | All the information required to backpropogate

95-- | All the information required to backpropogate

98-- through time safely.

96-- through time safely.

99--

97--

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

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

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

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

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

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

103 TRNil :: SingI i

101 TRNil :: SingI i

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

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

105−

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

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

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

109

103

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

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

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

110

107

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

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

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

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

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

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

114

111

115

112

116−runRecurrentNetwork :: forall shapes layers.

113+runRecurrent :: forall shapes layers.

117− RecurrentNetwork layers shapes

114+ RecurrentNetwork layers shapes

118− -> RecurrentInputs layers

115+ -> RecurrentInputs layers

119− -> [S (Head shapes)]

116+ -> S (Head shapes)

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

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

121−runRecurrentNetwork =

118+runRecurrent =

122 go

119 go

123 where

120 where

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

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

125 => RecurrentNetwork sublayers js

122 => RecurrentNetwork sublayers js

126 -> RecurrentInputs sublayers

123 -> RecurrentInputs sublayers

127− -> [S (Head js)]

124+ -> S (Head js)

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

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

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

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

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

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

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

132− feedForwardTapes = fst <$> tys

128+

133− forwards = snd <$> tys

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

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

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

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

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

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

137

132

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

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

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

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

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

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

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

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

142− recurrentTapes = fst <$> tys

143− forwards = snd <$> tys

144−

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

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

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

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

147

139

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

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

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

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

150 go RNil RINil !x

142 go RNil RINil !x

151 = (TRNil, RINil, x)

143 = (TRNil, RINil, x)

152

144

153− -- Helper function for recurrent layers

154− -- Scans over the recurrent direction of the graph.

155− goR !layer !recShape (x:xs) =

156− let (tape, lerec, lepush) = runRecurrentForwards layer recShape x

157− (rems, push) = goR layer lerec xs

158− in (rems, (tape, lepush) : push)

159− goR _ rin [] = (rin, [])

160−

161−runRecurrentGradient :: forall layers shapes.

145+runRecurrent' :: forall layers shapes.

162− RecurrentNetwork layers shapes

146+ RecurrentNetwork layers shapes

163− -> RecurrentTapes layers shapes

147+ -> RecurrentTape layers shapes

164− -> RecurrentInputs layers

148+ -> RecurrentInputs layers

165− -> [S (Last shapes)]

149+ -> S (Last shapes)

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

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

167−runRecurrentGradient net tapes r o =

151+runRecurrent' net tapes r o =

168 go net tapes r

152 go net tapes r

169 where

153 where

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

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

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

172 -- through time.

156 -- through time.

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

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

174 => RecurrentNetwork ss js

158 => RecurrentNetwork ss js

175− -> RecurrentTapes ss js

159+ -> RecurrentTape ss js

176 -> RecurrentInputs ss

160 -> RecurrentInputs ss

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

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

178 -- This is a simple non-recurrent layer

162 -- This is a simple non-recurrent layer

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

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

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

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

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

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

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

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

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

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

184

168

185 -- This is a recurrent layer

169 -- This is a recurrent layer

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

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

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

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

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

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

189− backExamples = zip (reverse recurrentTapes) feed

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

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

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

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

192

175

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

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

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

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

195 -- well.

178 -- well.

196− go RNil TRNil RINil

179+ go !RNil !TRNil !RINil

197− = (RGNil, RINil, reverse o)

180+ = (RGNil, RINil, 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, [])

207

181

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

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

209-- Uses runUpdates which can be specialised for

183-- Uses runUpdates which can be specialised for

210-- a layer.

184-- a layer.

211applyRecurrentUpdate :: LearningParameters

185applyRecurrentUpdate :: LearningParameters

212 -> RecurrentNetwork layers shapes

186 -> RecurrentNetwork layers shapes

213− -> RecurrentGradients layers

187+ -> RecurrentGradient layers

214 -> RecurrentNetwork layers shapes

188 -> RecurrentNetwork layers shapes

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

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

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

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

217

191

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

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

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

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

220

194

221applyRecurrentUpdate _ RNil RGNil

195applyRecurrentUpdate _ RNil RGNil

222 = RNil

196 = RNil

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

232

206

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

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

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

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

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

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

236 -- | Create a network of the types requested

210 -- | Create a network of the types requested

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

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

238

212

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

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

240 randomRecurrent =

214 randomRecurrent =

241− return (RNil, RINil)

215+ return RNil

242

216

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

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

244 randomRecurrent = do

218 randomRecurrent = do

245 thisLayer <- createRandom

219 thisLayer <- createRandom

246− (rest, resti) <- randomRecurrent

220+ rest <- randomRecurrent

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

221+ return (thisLayer :~~> rest)

248

222

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

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

250 randomRecurrent = do

224 randomRecurrent = do

251 thisLayer <- createRandom

225 thisLayer <- createRandom

252− thisShape <- randomOfShape

253− (rest, resti) <- randomRecurrent

226+ rest <- randomRecurrent

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

227+ return (thisLayer :~@> rest)

255

228

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

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

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

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

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

270 put _ = return ()

243 put _ = return ()

271 get = return RINil

244 get = return RINil

272

245

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

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

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

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

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

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

276

249

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

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

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

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

279− _ <- (case i of

280− (S1D x) -> putListOf put . LA.toList . LAS.extract $ x

281− (S2D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

282− (S3D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

283− ) :: PutM ()

284− put rest

285−

286− get = do

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

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

288− rest <- get

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

290

253

291

254

292-- Num instance for `RecurrentInputs layers`

255-- Num instance for `RecurrentInputs layers`

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

307 signum _ = RINil

270 signum _ = RINil

308 fromInteger _ = RINil

271 fromInteger _ = RINil

309

272

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

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

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

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

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

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

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

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

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

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

278 signum (() :~~+> x) = () :~~+> signum x

316 fromInteger x = () :~~+> fromInteger x

279 fromInteger x = () :~~+> fromInteger x

317

280

318−instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where

281+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where

319 (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')

282 (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')

320 (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')

283 (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')

321 (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')

284 (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')

322 abs (x :~@+> x') = abs x :~@+> abs x'

285 abs (x :~@+> x') = abs x :~@+> abs x'

323 signum (x :~@+> x') = signum x :~@+> signum x'

286 signum (x :~@+> x') = signum x :~@+> signum x'

324 fromInteger x = fromInteger x :~@+> fromInteger x

287 fromInteger x = fromInteger x :~@+> fromInteger x

288+

289+instance (Fractional (RecurrentInputs '[])) where

290+ (/) _ _ = RINil

291+ recip _ = RINil

292+ fromRational _ = RINil

293+

294+instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (FeedForward x ': ys))) where

295+ (/) (() :~~+> x) (() :~~+> y) = () :~~+> (x / y)

296+ recip (() :~~+> x) = () :~~+> recip x

297+ fromRational x = () :~~+> fromRational x

298+

299+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (Recurrent x ': ys))) where

300+ (/) (x :~@+> x') (y :~@+> y') = (x / y) :~@+> (x' / y')

301+ recip (x :~@+> x') = recip x :~@+> recip x'

302+ fromRational x = fromRational x :~@+> fromRational x

303+

304+

305+-- | Ultimate composition.

306+--

307+-- This allows a complete network to be treated as a layer in a larger network.

308+instance CreatableRecurrent sublayers subshapes => UpdateLayer (RecurrentNetwork sublayers subshapes) where

309+ type Gradient (RecurrentNetwork sublayers subshapes) = RecurrentGradient sublayers

310+ runUpdate = applyRecurrentUpdate

311+ createRandom = randomRecurrent

312+

313+-- | Ultimate composition.

314+--

315+-- This allows a complete network to be treated as a layer in a larger network.

316+instance CreatableRecurrent sublayers subshapes => RecurrentUpdateLayer (RecurrentNetwork sublayers subshapes) where

317+ type RecurrentShape (RecurrentNetwork sublayers subshapes) = RecurrentInputs sublayers

318+

319+-- | Ultimate composition.

320+--

321+-- This allows a complete network to be treated as a layer in a larger network.

322+instance ( CreatableRecurrent sublayers subshapes

323+ , i ~ (Head subshapes), o ~ (Last subshapes)

324+ , Num (RecurrentShape (RecurrentNetwork sublayers subshapes))

325+ ) => RecurrentLayer (RecurrentNetwork sublayers subshapes) i o where

326+ type RecTape (RecurrentNetwork sublayers subshapes) i o = RecurrentTape sublayers subshapes

327+ runRecurrentForwards = runRecurrent

328+ runRecurrentBackwards = runRecurrent'

src/Grenade/Recurrent/Core/Runner.hs+54−34

@@ -6,33 +6,67 @@

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE RecordWildCards #-}

10

9

11module Grenade.Recurrent.Core.Runner (

10module Grenade.Recurrent.Core.Runner (

12− trainRecurrent

11+ runRecurrentExamples

13− , runRecurrent

12+ , runRecurrentBackprop

14 , backPropagateRecurrent

13 , backPropagateRecurrent

14+ , trainRecurrent

15+

16+ , RecurrentGradients

15 ) where

17 ) where

16

18

17−import Data.Singletons.Prelude

19+import Data.List ( foldl' )

18import Grenade.Core

20import Grenade.Core

19

21

20−import Grenade.Recurrent.Core.Layer

21import Grenade.Recurrent.Core.Network

22import Grenade.Recurrent.Core.Network

23+import Prelude.Singletons

24+

25+type RecurrentGradients layers = [RecurrentGradient layers]

26+

27+runRecurrentExamples :: forall shapes layers.

28+ RecurrentNetwork layers shapes

29+ -> RecurrentInputs layers

30+ -> [S (Head shapes)]

31+ -> ([(RecurrentTape layers shapes, S (Last shapes))], RecurrentInputs layers)

32+runRecurrentExamples net =

33+ go

34+ where

35+ go !side [] = ([], side)

36+ go !side (!x : xs) =

37+ let (!tape, !side', !o) = runRecurrent net side x

38+ (!res, !finalSide) = go side' xs

39+ in (( tape, o ) : res, finalSide)

40+

41+runRecurrentBackprop :: forall layers shapes.

42+ RecurrentNetwork layers shapes

43+ -> RecurrentInputs layers

44+ -> [(RecurrentTape layers shapes, S (Last shapes))]

45+ -> ([(RecurrentGradient layers, S (Head shapes))], RecurrentInputs layers)

46+runRecurrentBackprop net =

47+ go

48+ where

49+ go !side [] = ([], side)

50+ go !side ((!tape,!x):xs) =

51+ let (res, !side') = go side xs

52+ (!grad, !finalSide, !o) = runRecurrent' net tape side' x

53+ in (( grad, o ) : res, finalSide)

54+

22

55

23-- | Drive and network and collect its back propogated gradients.

56-- | Drive and network and collect its back propogated gradients.

24−backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))

57+backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

25 => RecurrentNetwork layers shapes

58 => RecurrentNetwork layers shapes

26 -> RecurrentInputs layers

59 -> RecurrentInputs layers

27 -> [(S (Head shapes), Maybe (S (Last shapes)))]

60 -> [(S (Head shapes), Maybe (S (Last shapes)))]

28 -> (RecurrentGradients layers, RecurrentInputs layers)

61 -> (RecurrentGradients layers, RecurrentInputs layers)

29backPropagateRecurrent network recinputs examples =

62backPropagateRecurrent network recinputs examples =

30− let (tapes, _, guesses) = runRecurrentNetwork network recinputs inputs

63+ let (outForwards, _) = runRecurrentExamples network recinputs inputs

31

64

32− backPropagations = zipWith makeError guesses targets

65+ backPropagations = zipWith makeError outForwards targets

33

66

34− (gradients, input', _) = runRecurrentGradient network tapes 0 backPropagations

67+ (outBackwards, input') = runRecurrentBackprop network 0 backPropagations

35

68

69+ gradients = fmap fst outBackwards

36 in (gradients, input')

70 in (gradients, input')

37

71

38 where

72 where

@@ -40,12 +74,12 @@ backPropagateRecurrent network recinputs examples =

40 inputs = fst <$> examples

74 inputs = fst <$> examples

41 targets = snd <$> examples

75 targets = snd <$> examples

42

76

43− makeError :: S (Last shapes) -> Maybe (S (Last shapes)) -> S (Last shapes)

77+ makeError :: (x, S (Last shapes)) -> Maybe (S (Last shapes)) -> (x, S (Last shapes))

44− makeError _ Nothing = 0

78+ makeError (x, _) Nothing = (x, 0)

45− makeError y (Just t) = y - t

79+ makeError (x, y) (Just t) = (x, y - t)

46

80

47

81

48−trainRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))

82+trainRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

49 => LearningParameters

83 => LearningParameters

50 -> RecurrentNetwork layers shapes

84 -> RecurrentNetwork layers shapes

51 -> RecurrentInputs layers

85 -> RecurrentInputs layers

@@ -56,35 +90,21 @@ trainRecurrent rate network recinputs examples =

56

90

57 newInputs = updateRecInputs rate recinputs recinputs'

91 newInputs = updateRecInputs rate recinputs recinputs'

58

92

59− newNetwork = applyRecurrentUpdate rate network gradients

93+ newNetwork = foldl' (applyRecurrentUpdate rate) network gradients

60

94

61 in (newNetwork, newInputs)

95 in (newNetwork, newInputs)

62

96

97+updateRecInputs :: Fractional (RecurrentInputs sublayers)

63−updateRecInputs :: LearningParameters

98+ => LearningParameters

64 -> RecurrentInputs sublayers

99 -> RecurrentInputs sublayers

65 -> RecurrentInputs sublayers

100 -> RecurrentInputs sublayers

66 -> RecurrentInputs sublayers

101 -> RecurrentInputs sublayers

67

102

68−updateRecInputs l@LearningParameters {..} (() :~~+> xs) (() :~~+> ys)

103+updateRecInputs lp (() :~~+> xs) (() :~~+> ys)

69− = () :~~+> updateRecInputs l xs ys

104+ = () :~~+> updateRecInputs lp xs ys

70

105

71−updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)

106+updateRecInputs lp (x :~@+> xs) (y :~@+> ys)

72− = (realToFrac (1 - learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys

107+ = (realToFrac (1 - learningRate lp * learningRegulariser lp) * x - realToFrac (learningRate lp) * y) :~@+> updateRecInputs lp xs ys

73

108

74updateRecInputs _ RINil RINil

109updateRecInputs _ RINil RINil

75 = RINil

110 = RINil

76−

77−-- | Just forwards propagation with no training.

78−runRecurrent :: RecurrentNetwork layers shapes

79− -> RecurrentInputs layers -> S (Head shapes)

80− -> (RecurrentInputs layers, S (Last shapes))

81−runRecurrent (layer :~~> n) (() :~~+> nr) !x

82− = let (_, ys) = runForwards layer x

83− (nr', o) = runRecurrent n nr ys

84− in (() :~~+> nr', o)

85−runRecurrent (layer :~@> n) (recin :~@+> nr) !x

86− = let (_, recin', y) = runRecurrentForwards layer recin x

87− (nr', o) = runRecurrent n nr y

88− in (recin' :~@+> nr', o)

89−runRecurrent RNil RINil !x

90− = (RINil, x)

src/Grenade/Recurrent/Layers.hs+2

@@ -1,7 +1,9 @@

1module Grenade.Recurrent.Layers (

2 module Grenade.Recurrent.Layers.BasicRecurrent

3+ , module Grenade.Recurrent.Layers.ConcatRecurrent

3 , module Grenade.Recurrent.Layers.LSTM

4 , module Grenade.Recurrent.Layers.LSTM

4 ) where

5 ) where

5

6

6import Grenade.Recurrent.Layers.BasicRecurrent

7import Grenade.Recurrent.Layers.BasicRecurrent

8+import Grenade.Recurrent.Layers.ConcatRecurrent

7import Grenade.Recurrent.Layers.LSTM

9import Grenade.Recurrent.Layers.LSTM

src/Grenade/Recurrent/Layers/BasicRecurrent.hs+10−9

@@ -1,6 +1,6 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

@@ -16,7 +16,8 @@ module Grenade.Recurrent.Layers.BasicRecurrent (

16

17import Control.Monad.Random ( MonadRandom, getRandom )

18

19+

19−import Data.Singletons.TypeLits

20+import Data.Kind (Type)

20

21

21import Numeric.LinearAlgebra.Static

22import Numeric.LinearAlgebra.Static

22

23

@@ -27,7 +28,7 @@ import Grenade.Recurrent.Core

27

28

28data BasicRecurrent :: Nat -- Input layer size

29data BasicRecurrent :: Nat -- Input layer size

29 -> Nat -- Output layer size

30 -> Nat -- Output layer size

30− -> * where

31+ -> Type where

31 BasicRecurrent :: ( KnownNat input

32 BasicRecurrent :: ( KnownNat input

32 , KnownNat output

33 , KnownNat output

33 , KnownNat matrixCols

34 , KnownNat matrixCols

@@ -40,7 +41,7 @@ data BasicRecurrent :: Nat -- Input layer size

40

41

41data BasicRecurrent' :: Nat -- Input layer size

42data BasicRecurrent' :: Nat -- Input layer size

42 -> Nat -- Output layer size

43 -> Nat -- Output layer size

43− -> * where

44+ -> Type where

44 BasicRecurrent' :: ( KnownNat input

45 BasicRecurrent' :: ( KnownNat input

45 , KnownNat output

46 , KnownNat output

46 , KnownNat matrixCols

47 , KnownNat matrixCols

@@ -55,18 +56,18 @@ instance Show (BasicRecurrent i o) where

55instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

56instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

56 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

57 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

57

58

58− runUpdate LearningParameters {..} (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

59+ runUpdate lp (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

59− let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient

60+ let newBiasMomentum = konst (learningMomentum lp) * oldBiasMomentum - konst (learningRate lp) * biasGradient

60 newBias = oldBias + newBiasMomentum

61 newBias = oldBias + newBiasMomentum

61− newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient

62+ newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient

62− regulariser = konst (learningRegulariser * learningRate) * oldActivations

63+ regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations

63 newActivations = oldActivations + newMomentum - regulariser

64 newActivations = oldActivations + newMomentum - regulariser

64 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

65 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

65

66

66 createRandom = randomBasicRecurrent

67 createRandom = randomBasicRecurrent

67

68

68instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where

69instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where

69− type RecurrentShape (BasicRecurrent i o) = 'D1 o

70+ type RecurrentShape (BasicRecurrent i o) = S ('D1 o)

70

71

71instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

72instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

72

73

src/Grenade/Recurrent/Layers/ConcatRecurrent.hsnew file+180

@@ -0,0 +1,180 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE FlexibleInstances #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+{-|

14+Module : Grenade.Layers.Concat

15+Description : Concatenation layer

16+Copyright : (c) Huw Campbell, 2016-2017

17+License : BSD2

18+Stability : experimental

19+

20+This module provides the concatenation layer, which runs two chilld layers in parallel and combines their outputs.

21+-}

22+module Grenade.Recurrent.Layers.ConcatRecurrent (

23+ ConcatRecurrent (..)

24+ ) where

25+

26+import Data.Serialize

27+

28+import Data.Singletons

29+import GHC.TypeLits

30+

31+#if MIN_VERSION_base(4,9,0)

32+import Data.Kind (Type)

33+#endif

34+

35+import Grenade.Core

36+import Grenade.Recurrent.Core

37+

38+import Numeric.LinearAlgebra.Static ( (#), split, R )

39+

40+-- | A Concatentating Layer.

41+--

42+-- This layer shares it's input state between two sublayers, and concatenates their output.

43+--

44+-- With Networks able to be Layers, this allows for very expressive composition of complex Networks.

45+--

46+-- The Concat layer has a few instances, which allow one to flexibly "bash" together the outputs.

47+--

48+-- Two 1D vectors, can go to a 2D shape with 2 rows if their lengths are identical.

49+-- Any 2 1D vectors can also become a longer 1D Vector.

50+--

51+-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad

52+-- and Crop layers to ensure this is the case.

53+data ConcatRecurrent :: Shape -> Type -> Shape -> Type -> Type where

54+ ConcatRecLeft :: x -> y -> ConcatRecurrent m (Recurrent x) n (FeedForward y)

55+ ConcatRecRight :: x -> y -> ConcatRecurrent m (FeedForward x) n (Recurrent y)

56+ ConcatRecBoth :: x -> y -> ConcatRecurrent m (Recurrent x) n (Recurrent y)

57+

58+instance (Show x, Show y) => Show (ConcatRecurrent m (p x) n (q y)) where

59+ show (ConcatRecLeft x y) = "ConcatRecLeft\n" ++ show x ++ "\n" ++ show y

60+ show (ConcatRecRight x y) = "ConcatRecRight\n" ++ show x ++ "\n" ++ show y

61+ show (ConcatRecBoth x y) = "ConcatRecBoth\n" ++ show x ++ "\n" ++ show y

62+

63+instance (RecurrentUpdateLayer x, UpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where

64+ type Gradient (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = (Gradient x, Gradient y)

65+ runUpdate lr (ConcatRecLeft x y) (x', y')

66+ = ConcatRecLeft (runUpdate lr x x') (runUpdate lr y y')

67+ createRandom

68+ = ConcatRecLeft <$> createRandom <*> createRandom

69+

70+instance (UpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where

71+ type Gradient (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = (Gradient x, Gradient y)

72+ runUpdate lr (ConcatRecRight x y) (x', y')

73+ = ConcatRecRight (runUpdate lr x x') (runUpdate lr y y')

74+ createRandom

75+ = ConcatRecRight <$> createRandom <*> createRandom

76+

77+instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where

78+ type Gradient (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = (Gradient x, Gradient y)

79+ runUpdate lr (ConcatRecBoth x y) (x', y')

80+ = ConcatRecBoth (runUpdate lr x x') (runUpdate lr y y')

81+ createRandom

82+ = ConcatRecBoth <$> createRandom <*> createRandom

83+

84+instance (RecurrentUpdateLayer x, UpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where

85+ type RecurrentShape (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = RecurrentShape x

86+

87+instance (UpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where

88+ type RecurrentShape (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = RecurrentShape y

89+

90+instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where

91+ type RecurrentShape (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = RecurrentInputs '[ Recurrent x, Recurrent y ]

92+

93+instance ( SingI i

94+ , Layer x i ('D1 m)

95+ , RecurrentLayer y i ('D1 n)

96+ , KnownNat o

97+ , KnownNat m

98+ , KnownNat n

99+ , o ~ (m + n)

100+ , n ~ (o - m)

101+ , (m <=? o) ~ 'True

102+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) where

103+ type RecTape (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) = (Tape x i ('D1 m), RecTape y i ('D1 n))

104+

105+ runRecurrentForwards (ConcatRecRight x y) s input =

106+ let (xT, xOut :: S ('D1 m)) = runForwards x input

107+ (yT, side, yOut :: S ('D1 n)) = runRecurrentForwards y s input

108+ in case (xOut, yOut) of

109+ (S1D xOut', S1D yOut') ->

110+ ((xT, yT), side, S1D (xOut' # yOut'))

111+

112+ runRecurrentBackwards (ConcatRecRight x y) (xTape, yTape) s (S1D o) =

113+ let (ox :: R m , oy :: R n) = split o

114+ (x', xB :: S i) = runBackwards x xTape (S1D ox)

115+ (y', side, yB :: S i) = runRecurrentBackwards y yTape s (S1D oy)

116+ in ((x', y'), side, xB + yB)

117+

118+instance ( SingI i

119+ , RecurrentLayer x i ('D1 m)

120+ , Layer y i ('D1 n)

121+ , KnownNat o

122+ , KnownNat m

123+ , KnownNat n

124+ , o ~ (m + n)

125+ , n ~ (o - m)

126+ , (m <=? o) ~ 'True

127+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) where

128+ type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) = (RecTape x i ('D1 m), Tape y i ('D1 n))

129+

130+ runRecurrentForwards (ConcatRecLeft x y) s input =

131+ let (xT, side, xOut :: S ('D1 m)) = runRecurrentForwards x s input

132+ (yT, yOut :: S ('D1 n)) = runForwards y input

133+ in case (xOut, yOut) of

134+ (S1D xOut', S1D yOut') ->

135+ ((xT, yT), side, S1D (xOut' # yOut'))

136+

137+ runRecurrentBackwards (ConcatRecLeft x y) (xTape, yTape) s (S1D o) =

138+ let (ox :: R m , oy :: R n) = split o

139+ (x', side, xB :: S i) = runRecurrentBackwards x xTape s (S1D ox)

140+ (y', yB :: S i) = runBackwards y yTape (S1D oy)

141+ in ((x', y'), side, xB + yB)

142+

143+instance ( SingI i

144+ , RecurrentLayer x i ('D1 m)

145+ , RecurrentLayer y i ('D1 n)

146+ , Fractional (RecurrentShape x)

147+ , Fractional (RecurrentShape y)

148+ , KnownNat o

149+ , KnownNat m

150+ , KnownNat n

151+ , o ~ (m + n)

152+ , n ~ (o - m)

153+ , (m <=? o) ~ 'True

154+ ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) where

155+ type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) = (RecTape x i ('D1 m), RecTape y i ('D1 n))

156+

157+ runRecurrentForwards (ConcatRecBoth x y) (sx :~@+> (sy :~@+> RINil)) input =

158+ let (xT, s'x, xOut :: S ('D1 m)) = runRecurrentForwards x sx input

159+ (yT, s'y, yOut :: S ('D1 n)) = runRecurrentForwards y sy input

160+ in case (xOut, yOut) of

161+ (S1D xOut', S1D yOut') ->

162+ ((xT, yT), (s'x :~@+> (s'y :~@+> RINil)), S1D (xOut' # yOut'))

163+

164+ runRecurrentBackwards (ConcatRecBoth x y) (xTape, yTape) (sx :~@+> (sy :~@+> RINil)) (S1D o) =

165+ let (ox :: R m , oy :: R n) = split o

166+ (x', s'x, xB :: S i) = runRecurrentBackwards x xTape sx (S1D ox)

167+ (y', s'y, yB :: S i) = runRecurrentBackwards y yTape sy (S1D oy)

168+ in ((x', y'), (s'x :~@+> (s'y :~@+> RINil)), xB + yB)

169+

170+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (FeedForward a) sb (Recurrent b)) where

171+ put (ConcatRecRight a b) = put a *> put b

172+ get = ConcatRecRight <$> get <*> get

173+

174+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (Recurrent b)) where

175+ put (ConcatRecBoth a b) = put a *> put b

176+ get = ConcatRecBoth <$> get <*> get

177+

178+instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (FeedForward b)) where

179+ put (ConcatRecLeft a b) = put a *> put b

180+ get = ConcatRecLeft <$> get <*> get

src/Grenade/Recurrent/Layers/LSTM.hs+57−80

@@ -1,8 +1,8 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

4{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE TypeOperators #-}

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.Singletons.TypeLits

24+import Data.Kind (Type)

25

26import qualified Numeric.LinearAlgebra as LA

27import Numeric.LinearAlgebra.Static

@@ -29,6 +29,7 @@ import Numeric.LinearAlgebra.Static

29import Grenade.Core

30import Grenade.Recurrent.Core

31import Grenade.Layers.Internal.Update

32+import GHC.TypeLits

32

33

34

34-- | Long Short Term Memory Recurrent unit

35-- | Long Short Term Memory Recurrent unit

@@ -36,14 +37,14 @@ import Grenade.Layers.Internal.Update

36-- This is a Peephole formulation, so the recurrent shape is

37-- This is a Peephole formulation, so the recurrent shape is

37-- just the cell state, the previous output is not held or used

38-- just the cell state, the previous output is not held or used

38-- at all.

39-- at all.

39−data LSTM :: Nat -> Nat -> * where

40+data LSTM :: Nat -> Nat -> Type where

40 LSTM :: ( KnownNat input

41 LSTM :: ( KnownNat input

41 , KnownNat output

42 , KnownNat output

42 ) => !(LSTMWeights input output) -- Weights

43 ) => !(LSTMWeights input output) -- Weights

43 -> !(LSTMWeights input output) -- Momentums

44 -> !(LSTMWeights input output) -- Momentums

44 -> LSTM input output

45 -> LSTM input output

45

46

46−data LSTMWeights :: Nat -> Nat -> * where

47+data LSTMWeights :: Nat -> Nat -> Type where

47 LSTMWeights :: ( KnownNat input

48 LSTMWeights :: ( KnownNat input

48 , KnownNat output

49 , KnownNat output

49 ) => {

50 ) => {

@@ -70,7 +71,7 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

70

71

71 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

72 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

72 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

73 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

73− runUpdate LearningParameters {..} (LSTM w m) g =

74+ runUpdate lp (LSTM w m) g =

74 let (wf, wf') = u lstmWf w m g

75 let (wf, wf') = u lstmWf w m g

75 (uf, uf') = u lstmUf w m g

76 (uf, uf') = u lstmUf w m g

76 (bf, bf') = v lstmBf w m g

77 (bf, bf') = v lstmBf w m g

@@ -87,11 +88,11 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

87 -- Utility function for updating with the momentum, gradients, and weights.

88 -- Utility function for updating with the momentum, gradients, and weights.

88 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

89 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

89 u e (e -> weights) (e -> momentum) (e -> gradient) =

90 u e (e -> weights) (e -> momentum) (e -> gradient) =

90− decendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum

91+ descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

91

92

92 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

93 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

93 v e (e -> weights) (e -> momentum) (e -> gradient) =

94 v e (e -> weights) (e -> momentum) (e -> gradient) =

94− decendVector learningRate learningMomentum learningRegulariser weights gradient momentum

95+ descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

95

96

96 -- There's a lot of updates here, so to try and minimise the number of data copies

97 -- There's a lot of updates here, so to try and minimise the number of data copies

97 -- we'll create a mutable bucket for each.

98 -- we'll create a mutable bucket for each.

@@ -123,27 +124,33 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

123instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

124instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

124 -- The recurrent shape is the same size as the output.

125 -- The recurrent shape is the same size as the output.

125 -- It's actually the cell state however, as this is a peephole variety LSTM.

126 -- It's actually the cell state however, as this is a peephole variety LSTM.

126− type RecurrentShape (LSTM i o) = 'D1 o

127+ type RecurrentShape (LSTM i o) = S ('D1 o)

127

128

128instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

129instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

129

130

131+ -- The tape stores essentially every variable we calculate,

132+ -- so we don't have to run any forwards component again.

130− type RecTape (LSTM i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))

133+ type RecTape (LSTM i o) ('D1 i) ('D1 o) = (R o, R i, R o, R o, R o, R o, R o, R o, R o, R o, R o)

131 -- Forward propagation for the LSTM layer.

134 -- Forward propagation for the LSTM layer.

132 -- The size of the cell state is also the size of the output.

135 -- The size of the cell state is also the size of the output.

133− runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =

136+ runRecurrentForwards (LSTM lw _) (S1D cell) (S1D input) =

134 let -- Forget state vector

137 let -- Forget state vector

135− f_t = sigmoid $ lstmBf + lstmWf #> input + lstmUf #> cell

138+ f_s = lstmBf lw + lstmWf lw #> input + lstmUf lw #> cell

139+ f_t = sigmoid f_s

136 -- Input state vector

140 -- Input state vector

137− i_t = sigmoid $ lstmBi + lstmWi #> input + lstmUi #> cell

141+ i_s = lstmBi lw + lstmWi lw #> input + lstmUi lw #> cell

142+ i_t = sigmoid i_s

138 -- Output state vector

143 -- Output state vector

139− o_t = sigmoid $ lstmBo + lstmWo #> input + lstmUo #> cell

144+ o_s = lstmBo lw + lstmWo lw #> input + lstmUo lw #> cell

145+ o_t = sigmoid o_s

140 -- Cell input state vector

146 -- Cell input state vector

141− c_x = tanh $ lstmBc + lstmWc #> input

147+ c_s = lstmBc lw + lstmWc lw #> input

148+ c_x = tanh c_s

142 -- Cell state

149 -- Cell state

143 c_t = f_t * cell + i_t * c_x

150 c_t = f_t * cell + i_t * c_x

144 -- Output (it's sometimes recommended to use tanh c_t)

151 -- Output (it's sometimes recommended to use tanh c_t)

145 h_t = o_t * c_t

152 h_t = o_t * c_t

146− in ((S1D cell, S1D input), S1D c_t, S1D h_t)

153+ in ((cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t), S1D c_t, S1D h_t)

147

154

148 -- Run a backpropogation step for an LSTM layer.

155 -- Run a backpropogation step for an LSTM layer.

149 -- We're doing all the derivatives by hand here, so one should

156 -- We're doing all the derivatives by hand here, so one should

@@ -151,29 +158,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

151 --

158 --

152 -- There's a test version using the AD library without hmatrix in the test

159 -- There's a test version using the AD library without hmatrix in the test

153 -- suite. These should match always.

160 -- suite. These should match always.

154− runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (S1D cell, S1D input) (S1D cellGrad) (S1D h_t') =

161+ runRecurrentBackwards (LSTM lw _) (cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t) (S1D cellGrad) (S1D h_t') =

155− -- We're not keeping the Wengert tape during the forward pass,

156− -- so we're duplicating some work here.

157− --

158− -- If I was being generous, I'd call it checkpointing.

159− --

160− -- Maybe think about better ways to store some intermediate states.

161− let -- Forget state vector

162− f_s = lstmBf + lstmWf #> input + lstmUf #> cell

163− f_t = sigmoid f_s

164− -- Input state vector

165− i_s = lstmBi + lstmWi #> input + lstmUi #> cell

166− i_t = sigmoid i_s

167− -- Output state vector

168− o_s = lstmBo + lstmWo #> input + lstmUo #> cell

169− o_t = sigmoid o_s

170− -- Cell input state vector

171− c_s = lstmBc + lstmWc #> input

172− c_x = tanh c_s

173− -- Cell state

174− c_t = f_t * cell + i_t * c_x

175−

176− -- Reverse Mode AD Derivitives

162+ let -- Reverse Mode AD Derivitives

177 c_t' = h_t' * o_t + cellGrad

163 c_t' = h_t' * o_t + cellGrad

178

164

179 f_t' = c_t' * cell

165 f_t' = c_t' * cell

@@ -189,8 +175,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

189 c_s' = tanh' c_s * c_x'

175 c_s' = tanh' c_s * c_x'

190

176

191 -- The derivatives to pass sideways (recurrent) and downwards

177 -- The derivatives to pass sideways (recurrent) and downwards

192− cell' = tr lstmUf #> f_s' + tr lstmUo #> o_s' + tr lstmUi #> i_s' + c_t' * f_t

178+ cell' = tr (lstmUf lw) #> f_s' + tr (lstmUo lw) #> o_s' + tr (lstmUi lw) #> i_s' + c_t' * f_t

193− input' = tr lstmWf #> f_s' + tr lstmWo #> o_s' + tr lstmWi #> i_s' + tr lstmWc #> c_s'

179+ input' = tr (lstmWf lw) #> f_s' + tr (lstmWo lw) #> o_s' + tr (lstmWi lw) #> i_s' + tr (lstmWc lw) #> c_s'

194

180

195 -- Calculate the gradient Matricies for the input

181 -- Calculate the gradient Matricies for the input

196 lstmWf' = f_s' `outer` input

182 lstmWf' = f_s' `outer` input

@@ -235,7 +221,8 @@ randomLSTM = do

235

221

236-- | Maths

222-- | Maths

237--

223--

238−-- TODO: move to not here

224+-- TODO: Move to not here

225+-- Optimise backwards derivative

239sigmoid :: Floating a => a -> a

226sigmoid :: Floating a => a -> a

240sigmoid x = 1 / (1 + exp (-x))

227sigmoid x = 1 / (1 + exp (-x))

241

228

@@ -248,44 +235,34 @@ tanh' :: (Floating a) => a -> a

248tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

235tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

249

236

250instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

237instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

251− put (LSTM LSTMWeights {..} _) = do

238+ put (LSTM lw _) = do

252− u lstmWf

239+ u (lstmWf lw)

253− u lstmUf

240+ u (lstmUf lw)

254− v lstmBf

241+ v (lstmBf lw)

255− u lstmWi

242+ u (lstmWi lw)

256− u lstmUi

243+ u (lstmUi lw)

257− v lstmBi

244+ v (lstmBi lw)

258− u lstmWo

245+ u (lstmWo lw)

259− u lstmUo

246+ u (lstmUo lw)

260− v lstmBo

247+ v (lstmBo lw)

261− u lstmWc

248+ u (lstmWc lw)

262− v lstmBc

249+ v (lstmBc lw)

263− where

250+ where

264− u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

251+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

265− u = putListOf put . LA.toList . LA.flatten . extract

252+ u = putListOf put . LA.toList . LA.flatten . extract

266− v :: forall a. (KnownNat a) => Putter (R a)

253+ v :: forall a. (KnownNat a) => Putter (R a)

267− v = putListOf put . LA.toList . extract

254+ v = putListOf put . LA.toList . extract

268

255

269 get = do

256 get = do

270− lstmWf <- u

257+ w <- LSTMWeights <$> u <*> u <*> v <*> u <*> u <*> v <*> u <*> u <*> v <*> u <*> v

271− lstmUf <- u

272− lstmBf <- v

273− lstmWi <- u

274− lstmUi <- u

275− lstmBi <- v

276− lstmWo <- u

277− lstmUo <- u

278− lstmBo <- v

279− lstmWc <- u

280− lstmBc <- v

281− return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

258+ return $ LSTM w (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

282− where

259+ where

283− u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

260+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

284− u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

261+ u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

285− in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

262+ in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

286− v :: forall a. (KnownNat a) => Get (R a)

263+ v :: forall a. (KnownNat a) => Get (R a)

287− v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

264+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

288−

265+

289− w0 = konst 0

266+ w0 = konst 0

290− u0 = konst 0

267+ u0 = konst 0

291− v0 = konst 0

268+ v0 = konst 0

src/Grenade/Utils/OneHot.hs+6−5

@@ -22,7 +22,6 @@ import Data.Map ( Map )

22import qualified Data.Map as M

23

24import Data.Proxy

25−import Data.Singletons.TypeLits

26

25

27import Data.Vector ( Vector )

26import Data.Vector ( Vector )

28import qualified Data.Vector as V

27import qualified Data.Vector as V

@@ -31,6 +30,7 @@ import qualified Data.Vector.Storable as VS

31import Numeric.LinearAlgebra ( maxIndex )

30import Numeric.LinearAlgebra ( maxIndex )

32import Numeric.LinearAlgebra.Devel

31import Numeric.LinearAlgebra.Devel

33import Numeric.LinearAlgebra.Static

32import Numeric.LinearAlgebra.Static

33+import GHC.TypeLits

34

35import Grenade.Core.Shape

36

@@ -52,15 +52,16 @@ 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] -> Maybe (Map a Int, Vector a)

55+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Either String (Map a Int, Vector a)

56hotMap n as =

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− Just (M.fromList $ zip uniq [0..], V.fromList uniq)

62+ Right (M.fromList $ zip uniq [0..], V.fromList uniq)

63− else Nothing

63+ else

64+ Left ("Couldn't create hotMap of size " ++ show len ++ " from vector with " ++ show hotl ++ " unique characters")

64

65

65-- | From a map and value, create a 1D Shape

66-- | From a map and value, create a 1D Shape

66-- with one index hot (1) with the rest 0.

67-- with one index hot (1) with the rest 0.

stack.yamlnew file+78

@@ -0,0 +1,78 @@

1+# This file was automatically generated by 'stack init'

2+#

3+# Some commonly used options have been documented as comments in this file.

4+# For advanced use and comprehensive documentation of the format, please see:

5+# https://docs.haskellstack.org/en/stable/yaml_configuration/

6+

7+# A warning or info to be displayed to the user on config load.

8+# user-message: |

9+

10+# Resolver to choose a 'specific' stackage snapshot or a compiler version.

11+# A snapshot resolver dictates the compiler version and the set of packages

12+# to be used for project dependencies. For example:

13+#

14+# resolver: lts-3.5

15+# resolver: nightly-2015-09-21

16+# resolver: ghc-7.10.2

17+#

18+# The location of a snapshot can be provided as a file or url. Stack assumes

19+# a snapshot provided as a file might change, whereas a url resource does not.

20+#

21+# resolver: ./custom-snapshot.yaml

22+# resolver: https://example.com/snapshots/2018-01-01.yaml

23+resolver: lts-20.18

24+

25+# User packages to be built.

26+# Various formats can be used as shown in the example below.

27+#

28+# packages:

29+# - some-directory

30+# - https://example.com/foo/bar/baz-0.0.2.tar.gz

31+# subdirs:

32+# - auto-update

33+# - wai

34+packages:

35+ - .

36+ - examples

37+

38+# Dependency packages to be pulled from upstream that are not in the resolver.

39+# These entries can reference officially published versions as well as

40+# forks / in-progress versions pinned to a git hash. For example:

41+#

42+# extra-deps:

43+# - acme-missiles-0.3

44+# - git: https://github.com/commercialhaskell/stack.git

45+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

46+#

47+extra-deps:

48+ - typelits-witnesses-0.3.0.3

49+

50+# Override default flag values for local packages and extra-deps

51+# flags: {}

52+

53+# Extra package databases containing global packages

54+# extra-package-dbs: []

55+

56+# Control whether we use the GHC we find on the path

57+# system-ghc: true

58+#

59+# Require a specific version of stack, using version ranges

60+# require-stack-version: -any # Default

61+# require-stack-version: ">=2.1"

62+#

63+# Override the architecture used by stack, especially useful on Windows

64+# arch: i386

65+# arch: x86_64

66+#

67+# Extra directories used by stack for building

68+# extra-include-dirs: [/path/to/dir]

69+# extra-lib-dirs: [/path/to/dir]

70+#

71+# Allow a newer minor version of GHC than the snapshot specifies

72+# compiler-check: newer-minor

73+

74+nix:

75+ enable: true

76+ packages:

77+ - blas

78+ - lapack

stack.yaml.locknew file+19

@@ -0,0 +1,19 @@

1+# This file was autogenerated by Stack.

2+# You should not edit this file by hand.

3+# For more information, please see the documentation at:

4+# https://docs.haskellstack.org/en/stable/lock_files

5+

6+packages:

7+- completed:

8+ hackage: typelits-witnesses-0.3.0.3@sha256:2d9df4ac6ff3077bfd2bf659e4b495e157723ac5b45c519762853f55df5c16db,2738

9+ pantry-tree:

10+ sha256: 6a42a462f98e94933b6e9721acd912c6c6b6a4743635efd15cc5871908c816a0

11+ size: 469

12+ original:

13+ hackage: typelits-witnesses-0.3.0.3

14+snapshots:

15+- completed:

16+ sha256: 9fa4bece7acfac1fc7930c5d6e24606004b09e80aa0e52e9f68b148201008db9

17+ size: 649606

18+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/18.yaml

19+ original: lts-20.18

test/Test/Grenade/Layers/Convolution.hs+9−5

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

@@ -15,6 +16,10 @@ import Data.Singletons ()

15import GHC.TypeLits

16import GHC.TypeLits

16import GHC.TypeLits.Witnesses

17import GHC.TypeLits.Witnesses

17

18

19+#if MIN_VERSION_base(4,9,0)

20+import Data.Kind (Type)

21+#endif

22+

18import Grenade.Core

23import Grenade.Core

19import Grenade.Layers.Convolution

24import Grenade.Layers.Convolution

20

25

@@ -25,7 +30,7 @@ import Test.Hedgehog.Hmatrix

25import Test.Hedgehog.TypeLits

30import Test.Hedgehog.TypeLits

26import Test.Hedgehog.Compat

31import Test.Hedgehog.Compat

27

32

28−data OpaqueConvolution :: * where

33+data OpaqueConvolution :: Type where

29 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution

34 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution

30

35

31instance Show OpaqueConvolution where

36instance Show OpaqueConvolution where

@@ -39,11 +44,10 @@ genConvolution :: ( KnownNat channels

39 , KnownNat strideColumns

44 , KnownNat strideColumns

40 , KnownNat kernelFlattened

45 , KnownNat kernelFlattened

41 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

46 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

42− , Monad m

43− ) => Gen.Gen m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

47+ ) => Gen (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

44genConvolution = Convolution <$> uniformSample <*> uniformSample

48genConvolution = Convolution <$> uniformSample <*> uniformSample

45

49

46−genOpaqueOpaqueConvolution :: Monad m => Gen m OpaqueConvolution

50+genOpaqueOpaqueConvolution :: Gen OpaqueConvolution

47genOpaqueOpaqueConvolution = do

51genOpaqueOpaqueConvolution = do

48 channels <- genNat

52 channels <- genNat

49 filters <- genNat

53 filters <- genNat

@@ -59,7 +63,7 @@ genOpaqueOpaqueConvolution = do

59 p2 = natDict pkc

63 p2 = natDict pkc

60 p3 = natDict pch

64 p3 = natDict pch

61 in case p1 %* p2 %* p3 of

65 in case p1 %* p2 %* p3 of

62− Dict -> OpaqueConvolution <$> (genConvolution :: Monad n => Gen n (Convolution ch fl kr kc sr sc))

66+ Dict -> OpaqueConvolution <$> (genConvolution :: Gen (Convolution ch fl kr kc sr sc))

63

67

64prop_conv_net_witness = property $

68prop_conv_net_witness = property $

65 blindForAll genOpaqueOpaqueConvolution >>= \onet ->

69 blindForAll genOpaqueOpaqueConvolution >>= \onet ->

test/Test/Grenade/Layers/FullyConnected.hs+7−2

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

@@ -12,6 +13,10 @@ import Data.Singletons ()

12

13

13import GHC.TypeLits

14import GHC.TypeLits

14

15

16+#if MIN_VERSION_base(4,9,0)

17+import Data.Kind (Type)

18+#endif

19+

15import Grenade.Core

20import Grenade.Core

16import Grenade.Layers.FullyConnected

21import Grenade.Layers.FullyConnected

17

22

@@ -20,13 +25,13 @@ import Hedgehog

20import Test.Hedgehog.Compat

25import Test.Hedgehog.Compat

21import Test.Hedgehog.Hmatrix

26import Test.Hedgehog.Hmatrix

22

27

23−data OpaqueFullyConnected :: * where

28+data OpaqueFullyConnected :: Type where

24 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected

29 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected

25

30

26instance Show OpaqueFullyConnected where

31instance Show OpaqueFullyConnected where

27 show (OpaqueFullyConnected n) = show n

32 show (OpaqueFullyConnected n) = show n

28

33

29−genOpaqueFullyConnected :: Monad m => Gen m OpaqueFullyConnected

34+genOpaqueFullyConnected :: Gen OpaqueFullyConnected

30genOpaqueFullyConnected = do

35genOpaqueFullyConnected = do

31 input :: Integer <- choose 2 100

36 input :: Integer <- choose 2 100

32 output :: Integer <- choose 1 100

37 output :: Integer <- choose 1 100

test/Test/Grenade/Layers/PadCrop.hs−4

@@ -7,10 +7,6 @@

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−

14module Test.Grenade.Layers.PadCrop where

10module Test.Grenade.Layers.PadCrop where

15

11

16import Grenade

12import Grenade

test/Test/Grenade/Layers/Pooling.hs+11−7

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE KindSignatures #-}

4{-# LANGUAGE KindSignatures #-}

@@ -9,26 +10,29 @@ module Test.Grenade.Layers.Pooling where

9import Data.Proxy

10import Data.Proxy

10import Data.Singletons ()

11import Data.Singletons ()

11

12

13+#if MIN_VERSION_base(4,9,0)

14+import Data.Kind (Type)

15+#endif

16+

12import GHC.TypeLits

17import GHC.TypeLits

13import Grenade.Layers.Pooling

18import Grenade.Layers.Pooling

14

19

15import Hedgehog

20import Hedgehog

16−import qualified Hedgehog.Gen as Gen

17

21

18import Test.Hedgehog.Compat

22import Test.Hedgehog.Compat

19

23

20−data OpaquePooling :: * where

24+data OpaquePooling :: Type where

21 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

25 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

22

26

23instance Show OpaquePooling where

27instance Show OpaquePooling where

24 show (OpaquePooling n) = show n

28 show (OpaquePooling n) = show n

25

29

26−genOpaquePooling :: Monad m => Gen.Gen m OpaquePooling

30+genOpaquePooling :: Gen OpaquePooling

27genOpaquePooling = do

31genOpaquePooling = do

28− Just kernelHeight <- someNatVal <$> choose 2 15

32+ ~(Just kernelHeight) <- someNatVal <$> choose 2 15

29− Just kernelWidth <- someNatVal <$> choose 2 15

33+ ~(Just kernelWidth ) <- someNatVal <$> choose 2 15

30− Just strideHeight <- someNatVal <$> choose 2 15

34+ ~(Just strideHeight) <- someNatVal <$> choose 2 15

31− Just strideWidth <- someNatVal <$> choose 2 15

35+ ~(Just strideWidth ) <- someNatVal <$> choose 2 15

32

36

33 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

37 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

34 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

38 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

test/Test/Grenade/Network.hs+226−28

@@ -14,17 +14,12 @@ import Control.Monad ( guard )

14import Control.Monad.ST ( runST )

15

16import Data.Constraint

17−#if __GLASGOW_HASKELL__ < 800

18−import Data.Proxy

19−#endif

20import qualified Data.Vector.Storable as VS

17import qualified Data.Vector.Storable as VS

21import qualified Data.Vector.Storable.Mutable as VS ( write )

18import qualified Data.Vector.Storable.Mutable as VS ( write )

22import Data.Singletons

19import Data.Singletons

23import Data.Singletons.Prelude.List

20import Data.Singletons.Prelude.List

24import Data.Singletons.TypeLits

21import Data.Singletons.TypeLits

25

22

26−-- import Data.Type.Equality

27−

28import Hedgehog

23import Hedgehog

29import qualified Hedgehog.Gen as Gen

24import qualified Hedgehog.Gen as Gen

30import Hedgehog.Internal.Source

25import Hedgehog.Internal.Source

@@ -32,7 +27,15 @@ import Hedgehog.Internal.Property ( failWith )

32

27

33import Grenade

28import Grenade

34

29

30+#if MIN_VERSION_base(4,11,0)

31+import GHC.TypeLits hiding (natVal)

32+#else

35import GHC.TypeLits

33import GHC.TypeLits

34+#endif

35+#if MIN_VERSION_base(4,9,0)

36+import Data.Kind (Type)

37+#endif

38+

36import GHC.TypeLits.Witnesses

39import GHC.TypeLits.Witnesses

37import Test.Hedgehog.Compat

40import Test.Hedgehog.Compat

38import Test.Hedgehog.TypeLits

41import Test.Hedgehog.TypeLits

@@ -43,7 +46,7 @@ import Numeric.LinearAlgebra ( flatten )

43import Numeric.LinearAlgebra.Static ( extract, norm_Inf )

46import Numeric.LinearAlgebra.Static ( extract, norm_Inf )

44import Unsafe.Coerce

47import Unsafe.Coerce

45

48

46−data SomeNetwork :: * where

49+data SomeNetwork :: Type where

47 SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork

50 SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork

48

51

49instance Show SomeNetwork where

52instance Show SomeNetwork where

@@ -53,7 +56,7 @@ instance Show SomeNetwork where

53--

56--

54-- This is slightly insane for a few reasons. Everything must be wrapped up

57-- This is slightly insane for a few reasons. Everything must be wrapped up

55-- in a SomeNetwork.

58-- in a SomeNetwork.

56−genNetwork :: Monad m => Gen.Gen m SomeNetwork

59+genNetwork :: Gen SomeNetwork

57genNetwork =

60genNetwork =

58 Gen.recursive Gen.choice [

61 Gen.recursive Gen.choice [

59 do SomeSing ( r :: Sing final ) <- genShape

62 do SomeSing ( r :: Sing final ) <- genShape

@@ -62,7 +65,7 @@ genNetwork =

62 ] [

65 ] [

63 do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork

66 do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork

64 case ( sing :: Sing shapes ) of

67 case ( sing :: Sing shapes ) of

65− SNil -> Gen.discard

68+ SNil -> Gen.discard -- Can't occur

66 SCons ( h :: Sing h ) ( _ :: Sing hs ) ->

69 SCons ( h :: Sing h ) ( _ :: Sing hs ) ->

67 withSingI h $

70 withSingI h $

68 case h of

71 case h of

@@ -74,8 +77,9 @@ genNetwork =

74 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

77 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

75 , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))

78 , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))

76 , do -- Reshape to two dimensions

79 , do -- Reshape to two dimensions

80+ let divisors :: Integer -> [Integer]

77− let divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]

81+ divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]

78− let len = natVal l

82+ let len = fromIntegral $ natVal l

79 rs <- Gen.element $ divisors len

83 rs <- Gen.element $ divisors len

80 let cs = len `quot` rs

84 let cs = len `quot` rs

81 case ( someNatVal rs, someNatVal cs, someNatVal len ) of

85 case ( someNatVal rs, someNatVal cs, someNatVal len ) of

@@ -96,8 +100,8 @@ genNetwork =

96 , do -- Build a convolution layer with one filter output

100 , do -- Build a convolution layer with one filter output

97 -- Figure out some kernel sizes which work for this layer

101 -- Figure out some kernel sizes which work for this layer

98 -- There must be a better way than this...

102 -- There must be a better way than this...

99− let output_r = natVal r

103+ let output_r = fromIntegral $ natVal r

100− let output_c = natVal c

104+ let output_c = fromIntegral $ natVal c

101

105

102 let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

106 let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

103

107

@@ -136,8 +140,8 @@ genNetwork =

136 , do -- Build a convolution layer with one filter output

140 , do -- Build a convolution layer with one filter output

137 -- Figure out some kernel sizes which work for this layer

141 -- Figure out some kernel sizes which work for this layer

138 -- There must be a better way than this...

142 -- There must be a better way than this...

139− let output_r = natVal r

143+ let output_r = fromIntegral $ natVal r

140− let output_c = natVal c

144+ let output_c = fromIntegral $ natVal c

141

145

142 let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

146 let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

143

147

@@ -178,8 +182,8 @@ genNetwork =

178 pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

182 pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

179 _ -> Gen.discard -- Can't occur

183 _ -> Gen.discard -- Can't occur

180 , do -- Build a Pooling layer

184 , do -- Build a Pooling layer

181− let output_r = natVal r

185+ let output_r = fromIntegral $ natVal r

182− let output_c = natVal c

186+ let output_c = fromIntegral $ natVal c

183

187

184 let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

188 let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

185

189

@@ -214,25 +218,219 @@ genNetwork =

214 (Dict, Dict, Dict, Dict) ->

218 (Dict, Dict, Dict, Dict) ->

215 pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

219 pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

216 _ -> Gen.discard -- Can't occur

220 _ -> Gen.discard -- Can't occur

221+ , do -- Build a Pad layer

222+ let output_r = fromIntegral $ natVal r

223+ let output_c = fromIntegral $ natVal c

224+

225+ pad_left <- choose 0 (output_r - 1)

226+ pad_right <- choose 0 (output_r - 1 - pad_left)

227+ pad_top <- choose 0 (output_c - 1)

228+ pad_bottom <- choose 0 (output_c - 1 - pad_top)

229+

230+ let input_r = output_r - pad_top - pad_bottom

231+ let input_c = output_c - pad_left - pad_right

232+

233+ guard (input_r > 1)

234+ guard (input_c > 1)

235+

236+ -- Remake types for input

237+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal pad_left, someNatVal pad_right, someNatVal pad_top, someNatVal pad_bottom ) of

238+ ( Just (SomeNat (_ :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

239+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

240+ Just (SomeNat (_ :: Proxy padLeft)), Just (SomeNat (_ :: Proxy padRight)),

241+ Just (SomeNat (_ :: Proxy padTop)), Just (SomeNat (_ :: Proxy padBottom))) ->

242+ case ( (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outputRows outputColumns) ~ h ))

243+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputRows + padTop + padBottom) ~ outputRows) )

244+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputColumns + padLeft + padRight) ~ outputColumns ))) of

245+ ( Dict, Dict, Dict ) ->

246+ pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D2 inputRows inputColumns) ': h ': hs )))

247+ _ -> Gen.discard -- Can't occur

248+ , do -- Build a Crop layer

249+ let output_r = fromIntegral $ natVal r

250+ let output_c = fromIntegral $ natVal c

251+

252+ crop_left <- choose 0 10

253+ crop_right <- choose 0 10

254+ crop_top <- choose 0 10

255+ crop_bottom <- choose 0 10

256+

257+ let input_r = output_r + crop_top + crop_bottom

258+ let input_c = output_c + crop_left + crop_right

259+

260+ -- Remake types for input

261+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal crop_left, someNatVal crop_right, someNatVal crop_top, someNatVal crop_bottom ) of

262+ ( Just (SomeNat (_ :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

263+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

264+ Just (SomeNat (_ :: Proxy cropLeft)), Just (SomeNat (_ :: Proxy cropRight)),

265+ Just (SomeNat (_ :: Proxy cropTop)), Just (SomeNat (_ :: Proxy cropBottom))) ->

266+ case ( (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outputRows outputColumns) ~ h ))

267+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputRows + cropTop + cropBottom) ~ inputRows ) )

268+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputColumns + cropLeft + cropRight) ~ inputColumns ))) of

269+ (Dict, Dict, Dict) ->

270+ pure (SomeNetwork (Crop :~> rest :: Network ( Crop cropLeft cropTop cropRight cropBottom ': layers ) ( ('D2 inputRows inputColumns) ': h ': hs )))

271+ _ -> Gen.discard -- Can't occur

217 ]

272 ]

218− D3Sing SNat SNat SNat ->

273+ D3Sing r@SNat c@SNat f@SNat ->

219 Gen.choice [

274 Gen.choice [

220 pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

275 pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

221 , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

276 , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

222 , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

277 , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

223 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

278 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

279+ , do -- Build a convolution layer with one filter output

280+ -- Figure out some kernel sizes which work for this layer

281+ -- There must be a better way than this...

282+ let output_r = fromIntegral $ natVal r

283+ let output_c = fromIntegral $ natVal c

284+ let output_f = fromIntegral $ natVal f

285+

286+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

287+

288+ -- Get some kernels which will fit

289+ kernel_r <- choose 1 output_r

290+ kernel_c <- choose 1 output_c

291+ channels <- choose 1 10

292+

293+ -- Build up some strides which also fit

294+ stride_r <- Gen.element $ ok output_r kernel_r

295+ stride_c <- Gen.element $ ok output_c kernel_c

296+

297+ -- Determine the input size

298+ let input_r = (output_r - 1) * stride_r + kernel_r

299+ let input_c = (output_c - 1) * stride_c + kernel_c

300+

301+ guard (input_r < 100)

302+ guard (input_c < 100)

303+

304+ -- Remake types for input

305+ case ( someNatVal channels, someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

306+ ( Just (SomeNat (chan :: Proxy channels)), Just (SomeNat (_ :: Proxy filters)),

307+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

308+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

309+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

310+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

311+ let p1 = natDict pkr

312+ p2 = natDict pkc

313+ p3 = natDict chan

314+ in case ( p1 %* p2 %* p3

315+ , natDict pinr %* natDict chan

316+ -- Fake it till you make it.

317+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outRows outCols filters) ~ h ))

318+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

319+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

320+ (Dict, Dict, Dict, Dict, Dict) -> do

321+ conv <- genConvolution

322+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels filters kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

323+ _ -> Gen.discard -- Can't occur

324+ , do -- Build a Pooling layer

325+ let output_r = fromIntegral $ natVal r

326+ let output_c = fromIntegral $ natVal c

327+ let output_f = fromIntegral $ natVal f

328+

329+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

330+

331+ -- Get some kernels which will fit

332+ kernel_r <- choose 1 output_r

333+ kernel_c <- choose 1 output_c

334+

335+ -- Build up some strides which also fit

336+ stride_r <- Gen.element $ ok output_r kernel_r

337+ stride_c <- Gen.element $ ok output_c kernel_c

338+

339+ -- Determine the input size

340+ let input_r = (output_r - 1) * stride_r + kernel_r

341+ let input_c = (output_c - 1) * stride_c + kernel_c

342+

343+ guard (input_r < 100)

344+ guard (input_c < 100)

345+

346+ -- Remake types for input

347+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

348+ ( Just (SomeNat (chan :: Proxy filters)),

349+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

350+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

351+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

352+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

353+ let p1 = natDict pkr

354+ p2 = natDict pkc

355+ p3 = natDict chan

356+ in case ( p1 %* p2 %* p3

357+ , natDict pinr %* natDict chan

358+ -- Fake it till you make it.

359+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outRows outCols filters) ~ h ))

360+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

361+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

362+ (Dict, Dict, Dict, Dict, Dict) ->

363+ pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols filters) ': h ': hs )))

364+ _ -> Gen.discard -- Can't occur

365+ , do -- Build a Pad layer

366+ let output_r = fromIntegral $ natVal r

367+ let output_c = fromIntegral $ natVal c

368+ let output_f = fromIntegral $ natVal f

369+

370+ pad_left <- choose 0 (output_r - 1)

371+ pad_right <- choose 0 (output_r - 1 - pad_left)

372+ pad_top <- choose 0 (output_c - 1)

373+ pad_bottom <- choose 0 (output_c - 1 - pad_top)

374+

375+ let input_r = output_r - pad_top - pad_bottom

376+ let input_c = output_c - pad_left - pad_right

377+

378+ guard (input_r > 1)

379+ guard (input_c > 1)

380+

381+ -- Remake types for input

382+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal pad_left, someNatVal pad_right, someNatVal pad_top, someNatVal pad_bottom ) of

383+ ( Just (SomeNat (chan :: Proxy filters)),

384+ Just (SomeNat (pinr :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

385+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

386+ Just (SomeNat (_ :: Proxy padLeft)), Just (SomeNat (_ :: Proxy padRight)),

387+ Just (SomeNat (_ :: Proxy padTop)), Just (SomeNat (_ :: Proxy padBottom))) ->

388+ case ( natDict pinr %* natDict chan

389+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outputRows outputColumns filters) ~ h ))

390+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputRows + padTop + padBottom) ~ outputRows) )

391+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputColumns + padLeft + padRight) ~ outputColumns ))) of

392+ (Dict, Dict, Dict, Dict) ->

393+ pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))

394+ _ -> Gen.discard -- Can't occur

395+ , do -- Build a Crop layer

396+ let output_r = fromIntegral $ natVal r

397+ let output_c = fromIntegral $ natVal c

398+ let output_f = fromIntegral $ natVal f

399+

400+ crop_left <- choose 0 10

401+ crop_right <- choose 0 10

402+ crop_top <- choose 0 10

403+ crop_bottom <- choose 0 10

404+

405+ let input_r = output_r + crop_top + crop_bottom

406+ let input_c = output_c + crop_left + crop_right

407+

408+ -- Remake types for input

409+ case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal crop_left, someNatVal crop_right, someNatVal crop_top, someNatVal crop_bottom ) of

410+ ( Just (SomeNat (chan :: Proxy filters)),

411+ Just (SomeNat (pinr :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

412+ Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

413+ Just (SomeNat (_ :: Proxy cropLeft)), Just (SomeNat (_ :: Proxy cropRight)),

414+ Just (SomeNat (_ :: Proxy cropTop)), Just (SomeNat (_ :: Proxy cropBottom))) ->

415+ case ( natDict pinr %* natDict chan

416+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outputRows outputColumns filters) ~ h ))

417+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputRows + cropTop + cropBottom) ~ inputRows ) )

418+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputColumns + cropLeft + cropRight) ~ inputColumns ))) of

419+ (Dict, Dict, Dict, Dict) ->

420+ pure (SomeNetwork (Crop :~> rest :: Network ( Crop cropLeft cropTop cropRight cropBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))

421+ _ -> Gen.discard -- Can't occur

224− ]

422+ ]

225 ]

423 ]

226

424

227-- | Test a partial derivative numerically for a random network and input

425-- | Test a partial derivative numerically for a random network and input

228--

426--

229-- This is the most important test.

427-- This is the most important test.

230prop_auto_diff :: Property

428prop_auto_diff :: Property

231−prop_auto_diff = withTests 10000 . property $ do

429+prop_auto_diff = withDiscards 1000 . withTests 10000 . property $ do

232 SomeNetwork (network :: Network layers shapes) <- forAll genNetwork

430 SomeNetwork (network :: Network layers shapes) <- forAll genNetwork

233− (input :: S (Head shapes)) <- forAllRender nice genOfShape

431+ (input :: S (Head shapes)) <- forAllWith nice genOfShape

234− (target :: S (Last shapes)) <- forAllRender nice oneUp

432+ (target :: S (Last shapes)) <- forAllWith nice oneUp

235− (tested :: S (Head shapes)) <- forAllRender nice oneUp

433+ (tested :: S (Head shapes)) <- forAllWith nice oneUp

236

434

237 let (!tapes, !output) = runNetwork network input

435 let (!tapes, !output) = runNetwork network input

238 let (_, !backgrad) = runGradient network tapes target

436 let (_, !backgrad) = runGradient network tapes target

@@ -244,13 +442,13 @@ prop_auto_diff = withTests 10000 . property $ do

244 result ~~~ expected

442 result ~~~ expected

245

443

246-- Make a shape where all are 0 except for 1 value, which is 1.

444-- Make a shape where all are 0 except for 1 value, which is 1.

247−oneUp :: forall shape m. ( Monad m, SingI shape ) => Gen.Gen m (S shape)

445+oneUp :: forall shape. ( SingI shape ) => Gen (S shape)

248oneUp =

446oneUp =

249 case ( sing :: Sing shape ) of

447 case ( sing :: Sing shape ) of

250 D1Sing SNat ->

448 D1Sing SNat ->

251 let x = 0 :: S ( shape )

449 let x = 0 :: S ( shape )

252 in case x of

450 in case x of

253− ( S1D x' ) -> do

451+ ( S1D x' ) -> do

254 let ex = extract x'

452 let ex = extract x'

255 let len = VS.length ex

453 let len = VS.length ex

256 ix <- choose 0 (len - 1)

454 ix <- choose 0 (len - 1)

@@ -262,7 +460,7 @@ oneUp =

262 D2Sing SNat SNat ->

460 D2Sing SNat SNat ->

263 let x = 0 :: S ( shape )

461 let x = 0 :: S ( shape )

264 in case x of

462 in case x of

265− ( S2D x' ) -> do

463+ ( S2D x' ) -> do

266 let ex = flatten ( extract x' )

464 let ex = flatten ( extract x' )

267 let len = VS.length ex

465 let len = VS.length ex

268 ix <- choose 0 (len - 1)

466 ix <- choose 0 (len - 1)

@@ -274,7 +472,7 @@ oneUp =

274 D3Sing SNat SNat SNat ->

472 D3Sing SNat SNat SNat ->

275 let x = 0 :: S ( shape )

473 let x = 0 :: S ( shape )

276 in case x of

474 in case x of

277− ( S3D x' ) -> do

475+ ( S3D x' ) -> do

278 let ex = flatten ( extract x' )

476 let ex = flatten ( extract x' )

279 let len = VS.length ex

477 let len = VS.length ex

280 ix <- choose 0 (len - 1)

478 ix <- choose 0 (len - 1)

@@ -288,9 +486,9 @@ maxVal ( S1D x ) = norm_Inf x

288maxVal ( S2D x ) = norm_Inf x

486maxVal ( S2D x ) = norm_Inf x

289maxVal ( S3D x ) = norm_Inf x

487maxVal ( S3D x ) = norm_Inf x

290

488

291−(~~~) :: (Monad m, HasCallStack) => Double -> Double -> Test m ()

489+(~~~) :: (Monad m, HasCallStack) => Double -> Double -> PropertyT m ()

292(~~~) x y =

490(~~~) x y =

293− if abs (x - y) < 1e-5 then

491+ if abs (x - y) < 2e-5 then

294 success

492 success

295 else

493 else

296 withFrozenCallStack $

494 withFrozenCallStack $

test/Test/Grenade/Recurrent/Layers/LSTM.hs+13−8

@@ -11,7 +11,6 @@

11module Test.Grenade.Recurrent.Layers.LSTM where

12

13import Hedgehog

14−import qualified Hedgehog.Gen as Gen

15import Hedgehog.Internal.Source

14import Hedgehog.Internal.Source

16import Hedgehog.Internal.Show

15import Hedgehog.Internal.Show

17import Hedgehog.Internal.Property ( failWith, Diff (..) )

16import Hedgehog.Internal.Property ( failWith, Diff (..) )

@@ -29,7 +28,7 @@ import qualified Numeric.LinearAlgebra.Static as S

29import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

28import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

30import Test.Hedgehog.Hmatrix

29import Test.Hedgehog.Hmatrix

31

30

32−genLSTM :: forall i o m. (KnownNat i, KnownNat o, Monad m) => Gen.Gen m (LSTM i o)

31+genLSTM :: forall i o. (KnownNat i, KnownNat o) => Gen (LSTM i o)

33genLSTM = do

32genLSTM = do

34 let w = uniformSample

33 let w = uniformSample

35 u = uniformSample

34 u = uniformSample

@@ -66,7 +65,9 @@ prop_lstm_reference_backwards =

66 input :: S.R 3 <- forAll randomVector

65 input :: S.R 3 <- forAll randomVector

67 cell :: S.R 2 <- forAll randomVector

66 cell :: S.R 2 <- forAll randomVector

68 net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

67 net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

69− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

68+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

69+ = runRecurrentForwards net (S1D cell) (S1D input)

70+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

70 case actualBacks of

71 case actualBacks of

71 (actualGradients, _, _ :: S ('D1 3)) ->

72 (actualGradients, _, _ :: S ('D1 3)) ->

72 let refNet = Reference.lstmToReference lstmWeights

73 let refNet = Reference.lstmToReference lstmWeights

@@ -80,7 +81,9 @@ prop_lstm_reference_backwards_input =

80 input :: S.R 3 <- forAll randomVector

81 input :: S.R 3 <- forAll randomVector

81 cell :: S.R 2 <- forAll randomVector

82 cell :: S.R 2 <- forAll randomVector

82 net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

83 net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

83− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

84+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

85+ = runRecurrentForwards net (S1D cell) (S1D input)

86+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

84 case actualBacks of

87 case actualBacks of

85 (_, _, S1D actualGradients :: S ('D1 3)) ->

88 (_, _, S1D actualGradients :: S ('D1 3)) ->

86 let refNet = Reference.lstmToReference lstmWeights

89 let refNet = Reference.lstmToReference lstmWeights

@@ -94,7 +97,9 @@ prop_lstm_reference_backwards_cell =

94 input :: S.R 3 <- forAll randomVector

97 input :: S.R 3 <- forAll randomVector

95 cell :: S.R 2 <- forAll randomVector

98 cell :: S.R 2 <- forAll randomVector

96 net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

99 net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM

97− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

100+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

101+ = runRecurrentForwards net (S1D cell) (S1D input)

102+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

98 case actualBacks of

103 case actualBacks of

99 (_, S1D actualGradients, _ :: S ('D1 3)) ->

104 (_, S1D actualGradients, _ :: S ('D1 3)) ->

100 let refNet = Reference.lstmToReference lstmWeights

105 let refNet = Reference.lstmToReference lstmWeights

@@ -103,7 +108,7 @@ prop_lstm_reference_backwards_cell =

103 refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

108 refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

104 in toList refGradients ~~~ H.toList (S.extract actualGradients)

109 in toList refGradients ~~~ H.toList (S.extract actualGradients)

105

110

106−(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> Test m ()

111+(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> PropertyT m ()

107(~~~) x y =

112(~~~) x y =

108 if all (< 1e-8) (zipWith (-) x y) then

113 if all (< 1e-8) (zipWith (-) x y) then

109 success

114 success

@@ -116,9 +121,9 @@ prop_lstm_reference_backwards_cell =

116 , showPretty x

121 , showPretty x

117 , showPretty y

122 , showPretty y

118 ]

123 ]

119− Just diff ->

124+ Just differ ->

120 withFrozenCallStack $

125 withFrozenCallStack $

121− failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" diff) ""

126+ failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" differ) ""

122infix 4 ~~~

127infix 4 ~~~

123

128

124tests :: IO Bool

129tests :: IO Bool

test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+25−21

@@ -6,7 +6,6 @@

6{-# LANGUAGE DeriveFunctor #-}

7{-# LANGUAGE DeriveFoldable #-}

8{-# LANGUAGE DeriveTraversable #-}

9−{-# LANGUAGE RecordWildCards #-}

10{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE FlexibleContexts #-}

11{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RankNTypes #-}

12

11

@@ -15,9 +14,13 @@ module Test.Grenade.Recurrent.Layers.LSTM.Reference where

15

14

16import Data.Reflection

15import Data.Reflection

17import Numeric.AD.Mode.Reverse

16import Numeric.AD.Mode.Reverse

18−import Numeric.AD.Internal.Reverse ( Tape )

17+import Numeric.AD.Internal.Reverse (Tape)

19

18

19+import GHC.TypeLits (KnownNat)

20+

21+import Grenade.Recurrent.Layers.LSTM (LSTMWeights (..))

20import qualified Grenade.Recurrent.Layers.LSTM as LSTM

22import qualified Grenade.Recurrent.Layers.LSTM as LSTM

23+

21import qualified Numeric.LinearAlgebra.Static as S

24import qualified Numeric.LinearAlgebra.Static as S

22import qualified Numeric.LinearAlgebra as H

25import qualified Numeric.LinearAlgebra as H

23

26

@@ -54,31 +57,32 @@ data RefLSTM a = RefLSTM

54 , refLstmBc :: Vector a -- Bias Cell (b_c)

57 , refLstmBc :: Vector a -- Bias Cell (b_c)

55 } deriving (Functor, Foldable, Traversable, Eq, Show)

58 } deriving (Functor, Foldable, Traversable, Eq, Show)

56

59

57−lstmToReference :: LSTM.LSTMWeights a b -> RefLSTM Double

60+lstmToReference :: (KnownNat a, KnownNat b) => LSTM.LSTMWeights a b -> RefLSTM Double

58−lstmToReference LSTM.LSTMWeights {..} =

61+lstmToReference lw =

62+ RefLSTM

59− let refLstmWf = Matrix . H.toLists . S.extract $ lstmWf -- Weight Forget (W_f)

63+ { refLstmWf = Matrix . H.toLists . S.extract $ lstmWf lw -- Weight Forget (W_f)

60− refLstmUf = Matrix . H.toLists . S.extract $ lstmUf -- Cell State Forget (U_f)

64+ , refLstmUf = Matrix . H.toLists . S.extract $ lstmUf lw -- Cell State Forget (U_f)

61− refLstmBf = Vector . H.toList . S.extract $ lstmBf -- Bias Forget (b_f)

65+ , refLstmBf = Vector . H.toList . S.extract $ lstmBf lw -- Bias Forget (b_f)

62− refLstmWi = Matrix . H.toLists . S.extract $ lstmWi -- Weight Input (W_i)

66+ , refLstmWi = Matrix . H.toLists . S.extract $ lstmWi lw -- Weight Input (W_i)

63− refLstmUi = Matrix . H.toLists . S.extract $ lstmUi -- Cell State Input (U_i)

67+ , refLstmUi = Matrix . H.toLists . S.extract $ lstmUi lw -- Cell State Input (U_i)

64− refLstmBi = Vector . H.toList . S.extract $ lstmBi -- Bias Input (b_i)

68+ , refLstmBi = Vector . H.toList . S.extract $ lstmBi lw -- Bias Input (b_i)

65− refLstmWo = Matrix . H.toLists . S.extract $ lstmWo -- Weight Output (W_o)

69+ , refLstmWo = Matrix . H.toLists . S.extract $ lstmWo lw -- Weight Output (W_o)

66− refLstmUo = Matrix . H.toLists . S.extract $ lstmUo -- Cell State Output (U_o)

70+ , refLstmUo = Matrix . H.toLists . S.extract $ lstmUo lw -- Cell State Output (U_o)

67− refLstmBo = Vector . H.toList . S.extract $ lstmBo -- Bias Output (b_o)

71+ , refLstmBo = Vector . H.toList . S.extract $ lstmBo lw -- Bias Output (b_o)

68− refLstmWc = Matrix . H.toLists . S.extract $ lstmWc -- Weight Cell (W_c)

72+ , refLstmWc = Matrix . H.toLists . S.extract $ lstmWc lw -- Weight Cell (W_c)

69− refLstmBc = Vector . H.toList . S.extract $ lstmBc -- Bias Cell (b_c)

73+ , refLstmBc = Vector . H.toList . S.extract $ lstmBc lw -- Bias Cell (b_c)

70− in RefLSTM {..}

74+ }

71

75

72runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

76runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

73−runLSTM RefLSTM {..} cell input =

77+runLSTM rl cell input =

74 let -- Forget state vector

78 let -- Forget state vector

75− f_t = sigmoid $ refLstmBf #+ refLstmWf #> input #+ refLstmUf #> cell

79+ f_t = sigmoid $ refLstmBf rl #+ refLstmWf rl #> input #+ refLstmUf rl #> cell

76 -- Input state vector

80 -- Input state vector

77− i_t = sigmoid $ refLstmBi #+ refLstmWi #> input #+ refLstmUi #> cell

81+ i_t = sigmoid $ refLstmBi rl #+ refLstmWi rl #> input #+ refLstmUi rl #> cell

78 -- Output state vector

82 -- Output state vector

79− o_t = sigmoid $ refLstmBo #+ refLstmWo #> input #+ refLstmUo #> cell

83+ o_t = sigmoid $ refLstmBo rl #+ refLstmWo rl #> input #+ refLstmUo rl #> cell

80 -- Cell input state vector

84 -- Cell input state vector

81− c_x = fmap tanh $ refLstmBc #+ refLstmWc #> input

85+ c_x = fmap tanh $ refLstmBc rl #+ refLstmWc rl #> input

82 -- Cell state

86 -- Cell state

83 c_t = f_t #* cell #+ i_t #* c_x

87 c_t = f_t #* cell #+ i_t #* c_x

84 -- Output (it's sometimes recommended to use tanh c_t)

88 -- Output (it's sometimes recommended to use tanh c_t)

test/Test/Hedgehog/Compat.hs+4−21

@@ -3,36 +3,19 @@ module Test.Hedgehog.Compat (

3 (...)

4 , choose

5 , blindForAll

6− , semiBlindForAll

7− , forAllRender

8 )where

6 )where

9

7

10−import Control.Monad.Trans.Class (MonadTrans(..))

8+import Hedgehog (Gen)

11−

12import qualified Hedgehog.Gen as Gen

9import qualified Hedgehog.Gen as Gen

13import qualified Hedgehog.Range as Range

10import qualified Hedgehog.Range as Range

14import Hedgehog.Internal.Property

11import Hedgehog.Internal.Property

15−import Hedgehog.Internal.Source

16−import Hedgehog.Internal.Show

17

12

18(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

13(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

19(...) = (.) . (.)

14(...) = (.) . (.)

20{-# INLINE (...) #-}

15{-# INLINE (...) #-}

21

16

22−choose :: ( Monad m, Integral a ) => a -> a -> Gen.Gen m a

17+choose :: Integral a => a -> a -> Gen a

23choose = Gen.integral ... Range.constant

18choose = Gen.integral ... Range.constant

24

19

25−blindForAll :: Monad m => Gen.Gen m a -> Test m a

20+blindForAll :: Monad m => Gen a -> PropertyT m a

26−blindForAll = Test . lift . lift

21+blindForAll = forAllWith (const "blind")

27−

28−semiBlindForAll :: (Monad m, Show a, HasCallStack) => Gen.Gen m a -> Test m a

29−semiBlindForAll gen = do

30− x <- Test . lift $ lift gen

31− annotate (showPretty x)

32− return x

33−

34−forAllRender :: (Monad m, HasCallStack) => ( a -> String ) -> Gen.Gen m a -> Test m a

35−forAllRender render gen = do

36− x <- Test . lift $ lift gen

37− footnote (render x)

38− return x

test/Test/Hedgehog/Hmatrix.hs+7−5

@@ -1,7 +1,8 @@

1−{-# LANGUAGE RankNTypes #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE KindSignatures #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

5

6

6module Test.Hedgehog.Hmatrix where

7module Test.Hedgehog.Hmatrix where

7

8

@@ -9,19 +10,20 @@ import Grenade

9import Data.Singletons

10import Data.Singletons

10import Data.Singletons.TypeLits

11import Data.Singletons.TypeLits

11

12

13+import Hedgehog (Gen)

12import qualified Hedgehog.Gen as Gen

14import qualified Hedgehog.Gen as Gen

13import qualified Hedgehog.Range as Range

15import qualified Hedgehog.Range as Range

14

16

15import qualified Numeric.LinearAlgebra.Static as HStatic

17import qualified Numeric.LinearAlgebra.Static as HStatic

16

18

17−randomVector :: forall m n. ( Monad m, KnownNat n ) => Gen.Gen m (HStatic.R n)

19+randomVector :: forall n. ( KnownNat n ) => Gen (HStatic.R n)

18randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded

20randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded

19

21

20−uniformSample :: forall mm m n. ( Monad mm, KnownNat m, KnownNat n ) => Gen.Gen mm (HStatic.L m n)

22+uniformSample :: forall m n. ( KnownNat m, KnownNat n ) => Gen (HStatic.L m n)

21uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded

23uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded

22

24

23-- | Generate random data of the desired shape

25-- | Generate random data of the desired shape

24−genOfShape :: forall m x. ( Monad m, SingI x ) => Gen.Gen m (S x)

26+genOfShape :: forall x. ( SingI x ) => Gen (S x)

25genOfShape =

27genOfShape =

26 case (sing :: Sing x) of

28 case (sing :: Sing x) of

27 D1Sing l ->

29 D1Sing l ->

test/Test/Hedgehog/TypeLits.hs+15−20

@@ -7,32 +7,27 @@

7{-# LANGUAGE GADTs #-}

8module Test.Hedgehog.TypeLits where

9

10−import Data.Constraint

10+import Data.Constraint (Dict (..))

11−#if __GLASGOW_HASKELL__ < 800

11+import Data.Singletons (Proxy (..), Sing (..), SomeSing (..), sing)

12+#if MIN_VERSION_singletons(2,6,0)

12−import Data.Proxy

13+import Data.Singletons.TypeLits (SNat (..))

13#endif

14#endif

14−import Data.Singletons

15

16+import Hedgehog (Gen)

16import qualified Hedgehog.Gen as Gen

17import qualified Hedgehog.Gen as Gen

17

18

18import Grenade

19import Grenade

19

20

20−import GHC.TypeLits

21+import GHC.TypeLits (SomeNat (..), natVal, someNatVal)

21−import GHC.TypeLits.Witnesses

22+import GHC.TypeLits.Witnesses ((%*), natDict)

22−import Test.Hedgehog.Compat

23+import Test.Hedgehog.Compat (choose)

23

24

24−genNat :: Monad m => Gen.Gen m SomeNat

25+genNat :: Gen SomeNat

25genNat = do

26genNat = do

26− Just n <- someNatVal <$> choose 1 10

27+ ~(Just n) <- someNatVal <$> choose 1 10

27 return n

28 return n

28

29

29−#if __GLASGOW_HASKELL__ < 800

30−type Shape' = ('KProxy :: KProxy Shape)

31−#else

32−type Shape' = Shape

33−#endif

34−

35−genShape :: Monad m => Gen.Gen m (SomeSing Shape')

30+genShape :: Gen (SomeSing Shape)

36genShape

31genShape

37 = Gen.choice [

32 = Gen.choice [

38 genD1

33 genD1

@@ -40,20 +35,20 @@ genShape

40 , genD3

35 , genD3

41 ]

36 ]

42

37

43−genD1 :: Monad m => Gen.Gen m (SomeSing Shape')

38+genD1 :: Gen (SomeSing Shape)

44genD1 = do

39genD1 = do

45 n <- genNat

40 n <- genNat

46 return $ case n of

41 return $ case n of

47 SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

42 SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

48

43

49−genD2 :: Monad m => Gen.Gen m (SomeSing Shape')

44+genD2 :: Gen (SomeSing Shape)

50genD2 = do

45genD2 = do

51 n <- genNat

46 n <- genNat

52 m <- genNat

47 m <- genNat

53 return $ case (n, m) of

48 return $ case (n, m) of

54 (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

49 (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

55

50

56−genD3 :: Monad m => Gen.Gen m (SomeSing Shape')

51+genD3 :: Gen (SomeSing Shape)

57genD3 = do

52genD3 = do

58 n <- genNat

53 n <- genNat

59 m <- genNat

54 m <- genNat

@@ -63,7 +58,7 @@ genD3 = do

63 case natDict px %* natDict pz of

58 case natDict px %* natDict pz of

64 Dict -> SomeSing (sing :: Sing ('D3 x y z))

59 Dict -> SomeSing (sing :: Sing ('D3 x y z))

65

60

66−rss :: SomeSing Shape' -> String

61+rss :: SomeSing Shape -> String

67rss (SomeSing (r :: Sing s)) = case r of

62rss (SomeSing (r :: Sing s)) = case r of

68 (D1Sing a@SNat) -> "D1 " ++ show (natVal a)

63 (D1Sing a@SNat) -> "D1 " ++ show (natVal a)

69 (D2Sing a@SNat b@SNat) -> "D2 " ++ show (natVal a) ++ " " ++ show (natVal b)

64 (D2Sing a@SNat b@SNat) -> "D2 " ++ show (natVal a) ++ " " ++ show (natVal b)