master..9509719 · grenade

.gitignore+1−3

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

1−cabal.project.local

21.cabal-sandbox/

32cabal.sandbox.config

43dist/

5−dist-newstyle/

6−.stack-work/

4+

.travis.yml+10−12

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

22

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

44env:

5− - GHCVER=8.0.2

6− - GHCVER=8.2.2

7− - GHCVER=8.4.4

8− - GHCVER=8.6.5

9− - GHCVER=8.8.3

10− - GHCVER=8.10.1

5+ - CABALVER=1.22 GHCVER=7.10.3

6+ - CABALVER=1.24 GHCVER=8.0.1

117

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

139before_install:

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

1511 - travis_retry sudo apt-get update

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

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

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

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

1814

1915install:

16+ - cabal --version

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

21− - travis_retry cabal-3.2 update

18+ - travis_retry cabal update

19+ - cabal sandbox init

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

2221

2322notifications:

2423 email: false

2524

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

2726script:

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

29− - cabal-3.2 build all

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

27+ - cabal build

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

3129

README.md+4−6

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

33

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

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

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

76

87

98```

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

2423type MNIST

2524 = Network

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

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

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

2827 , FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]

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

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

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

8988```

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

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

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

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

9392have no learnable parameters.

9493

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

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

159158./mafia test

160159```

161160

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

161+Grenade builds with ghc 7.10 and 8.0.

163162

164163Thanks

165164------

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

188187

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

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

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

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

190+

bench/bench-lstm.hs+45−4

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

55

66import Grenade

77import Grenade.Recurrent

8+import Grenade.Layers.Internal.Update

9+

10+import qualified Numeric.LinearAlgebra.Static as H

811

912main :: IO ()

1013main = do

14+ layer60 :: LSTM 40 60 <- createRandom

15+ layer512 :: LSTM 40 512 <- createRandom

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

12− lstm :: RecNet <- randomRecurrent

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

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

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

20+

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

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

1323

1424 defaultMain [

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

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

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

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

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

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

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

29+ ]

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

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

32+ ]

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

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

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

1836 ]

1937 ]

2038

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+

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

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

2359

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

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

62+

2463

2564type R = Recurrent

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

2766 '[ 'D1 40, 'D1 512, 'D1 40 ]

2867

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

69+

2970lp :: LearningParameters

3071lp = LearningParameters 0.1 0 0

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

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

1−#include "gradient_descent.h"

1+#include "gradient_decent.h"

22

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

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

44 const double* weights,

55 const double* gradient,

66 const double* last,

77 double* outputWeights, double* outputMomentum) {

88

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

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

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

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

1212 }

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

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

11#include <stdio.h>

22#include <stdint.h>

33

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

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

55 const double* weights,

66 const double* gradient,

77 const double* last,

examples/grenade-examples.cabal+9−10

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

2626 , bytestring

2727 , cereal

2828 , either

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

29+ , optparse-applicative == 0.13.*

3030 , text == 1.2.*

3131 , mtl >= 2.2.1 && < 2.3

3232 , hmatrix

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

4242 , grenade

4343 , attoparsec

4444 , either

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

45+ , optparse-applicative == 0.13.*

4646 , text == 1.2.*

4747 , mtl >= 2.2.1 && < 2.3

48− , hmatrix >= 0.18 && < 0.21

48+ , hmatrix >= 0.18 && < 0.19

4949 , transformers

5050 , semigroups

5151 , singletons

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

6161 , bytestring

6262 , cereal

6363 , either

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

64+ , optparse-applicative == 0.13.*

6565 , text == 1.2.*

6666 , mtl >= 2.2.1 && < 2.3

67− , hmatrix >= 0.18 && < 0.21

67+ , hmatrix >= 0.18 && < 0.19

6868 , transformers

6969 , semigroups

7070 , singletons

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

7878 , grenade

7979 , attoparsec

8080 , either

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

81+ , optparse-applicative == 0.13.*

8282 , text == 1.2.*

8383 , mtl >= 2.2.1 && < 2.3

84− , hmatrix >= 0.18 && < 0.21

84+ , hmatrix >= 0.18 && < 0.19

8585 , transformers

8686 , semigroups

8787 , singletons

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

9696 , bytestring

9797 , cereal

9898 , either

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

99+ , optparse-applicative == 0.13.*

100100 , text == 1.2.*

101101 , mtl >= 2.2.1 && < 2.3

102− , hmatrix >= 0.18 && < 0.21

102+ , hmatrix >= 0.18 && < 0.19

103103 , transformers

104104 , semigroups

105105 , singletons

106− , singletons-base

107106 , vector

108107 , MonadRandom

109108 , containers

examples/mafiadeleted−62

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

1−#!/bin/sh -eu

2−

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

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

5−

6−latest_version () {

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

8−}

9−

10−build_version() {

11− MAFIA_VERSION="$1"

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

13− MAFIA_FILE=mafia-$MAFIA_VERSION

14− MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE

15− mkdir -p $MAFIA_VERSIONS

16− echo "Building $MAFIA_FILE in $MAFIA_TEMP"

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

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

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

20− exit 1

21− }

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

23− got=$?

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

25− exit "$got"

26− }

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

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

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

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

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

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

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

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

35− exit 0

36− }

37−}

38−

39−enable_version() {

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

41− MAFIA_VERSION="$(latest_version)"

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

43− else

44− MAFIA_VERSION="$1"

45− fi

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

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

48−}

49−

50−exec_mafia () {

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

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

53−}

54−

55−#

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

57−#

58−

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

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

61−*) exec_mafia "$@"

62−esac

examples/main/feedforward.hs+1−3

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE ScopedTypeVariables #-}

54{-# LANGUAGE TypeOperators #-}

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

1110

1211import qualified Data.ByteString as B

1312import Data.Serialize

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

1513import Data.Semigroup ( (<>) )

16−#endif

14+

1715import GHC.TypeLits

1816

1917import qualified Numeric.LinearAlgebra.Static as SA

examples/main/gan-mnist.hs−3

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE GADTs #-}

54{-# LANGUAGE ScopedTypeVariables #-}

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

4443import qualified Data.Attoparsec.Text as A

4544import qualified Data.ByteString as B

4645import Data.List ( foldl' )

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

4846import Data.Semigroup ( (<>) )

49−#endif

5047import Data.Serialize

5148import qualified Data.Text as T

5249import qualified Data.Text.IO as T

examples/main/mnist.hs−4

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE ScopedTypeVariables #-}

54{-# LANGUAGE TypeOperators #-}

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

1413

1514import qualified Data.Attoparsec.Text as A

1615import Data.List ( foldl' )

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

1816import Data.Semigroup ( (<>) )

19−#endif

20−

2117import qualified Data.Text as T

2218import qualified Data.Text.IO as T

2319import qualified Data.Vector.Storable as V

examples/main/recurrent.hs+10−10

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

99import Control.Monad ( foldM )

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

1111

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

12+#if __GLASGOW_HASKELL__ < 800

1313import Data.List ( unfoldr )

1414#else

1515import Data.List ( cycle, unfoldr )

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

1716#endif

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

1818

1919import qualified Numeric.LinearAlgebra.Static as SA

2020

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

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

3232type R = Recurrent

3333

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

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

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

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

3636

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

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

3838

39−randomNet :: MonadRandom m => m RecNet

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

4040randomNet = randomRecurrent

4141

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

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

6969 unfoldr go (s, i)

7070 where

7171 go (x, y) =

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

73− o' = heat o

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

73+ o' = heat o

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

7575

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

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

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

8383 putStrLn "Training network..."

8484

85− net0 <- randomNet

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

85+ (net0, i0) <- randomNet

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

8787

8888 let results = generateRecurrent trained bestInput (c 1)

8989

examples/main/shakespeare.hs+23−26

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

2+{-# LANGUAGE RecordWildCards #-}

33{-# LANGUAGE DataKinds #-}

44{-# LANGUAGE ScopedTypeVariables #-}

55{-# LANGUAGE TypeOperators #-}

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

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

1414import Data.List ( foldl' )

1515import Data.Maybe ( fromMaybe )

16−

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

1717

1818import qualified Data.Vector as V

1919import Data.Vector ( Vector )

2020

2121import qualified Data.Map as M

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

2223

2324import qualified Data.ByteString as B

2425import Data.Serialize

2526

27+import Data.Singletons.Prelude

2628import GHC.TypeLits

2729

2830import Numeric.LinearAlgebra.Static ( konst )

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

3436import Grenade.Utils.OneHot

3537

3638import System.IO.Unsafe ( unsafeInterleaveIO )

37−import Data.Proxy

38−import Prelude.Singletons

3939

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

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

4242-- about an hour.

4343--

44−-- Grab the input from

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

46−--

4744-- This is a first class recurrent net.

4845--

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

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

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

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

6663

67−randomNet :: MonadRandom m => m Shakespeare

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

6865randomNet = randomRecurrent

6966

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

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

7269loadShakespeare path = do

7370 contents <- lift $ readFile path

7471 let annotated = annotateCapitals contents

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

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

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

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

7875

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

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

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

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

8279 in case reverse e of

8380 (o : l : xs) ->

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

85− in trainRecurrent lrate net recIns examples

82+ in trainRecurrent rate net recIns examples

8683 _ -> error "Not enough input"

8784 where

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

8986

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

91−runShakespeare opts = do

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

88+runShakespeare ShakespeareOpts {..} = do

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

9390 (net0, i0) <- lift $

94− case loadPath opts of

91+ case loadPath of

9592 Just loadFile -> netLoad loadFile

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

93+ Nothing -> randomNet

9794

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

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

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

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

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

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

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

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

103100 putStrLn (unAnnotateCapitals results)

104101 return (trained, bestInput)

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

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

106103

107− case savePath opts of

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

104+ case savePath of

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

109106 Nothing -> return ()

110107

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

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

116113 -> Vector a

117114 -> S ('D1 n)

118115 -> IO [a]

119−generateParagraph n s temp hotmap hotdict =

116+generateParagraph n s temperature hotmap hotdict =

120117 go s

121118 where

122119 go x y =

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

124− un <- sample temp hotdict o

125− Just re <- return $ makeHot hotmap un

126− rest <- unsafeInterleaveIO $ go ns re

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

121+ un <- sample temperature hotdict o

122+ Just re <- return $ makeHot hotmap un

123+ rest <- unsafeInterleaveIO $ go ns re

127124 return (un : rest)

128125

129126data ShakespeareOpts = ShakespeareOpts {

framework/mafiadeleted−62

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

1−#!/bin/sh -eu

2−

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

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

5−

6−latest_version () {

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

8−}

9−

10−build_version() {

11− MAFIA_VERSION="$1"

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

13− MAFIA_FILE=mafia-$MAFIA_VERSION

14− MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE

15− mkdir -p $MAFIA_VERSIONS

16− echo "Building $MAFIA_FILE in $MAFIA_TEMP"

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

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

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

20− exit 1

21− }

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

23− got=$?

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

25− exit "$got"

26− }

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

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

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

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

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

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

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

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

35− exit 0

36− }

37−}

38−

39−enable_version() {

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

41− MAFIA_VERSION="$(latest_version)"

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

43− else

44− MAFIA_VERSION="$1"

45− fi

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

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

48−}

49−

50−exec_mafia () {

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

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

53−}

54−

55−#

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

57−#

58−

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

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

61−*) exec_mafia "$@"

62−esac

grenade.cabal+23−39

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

88synopsis: Practical Deep Learning in Haskell

99category: AI, Machine Learning

10−cabal-version: >= 1.10

10+cabal-version: >= 1.8

1111build-type: Simple

1212description:

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

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

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

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

1919 networks with reverse automatic differentiation to calculate their

20− gradients; and applying gradient descent for learning.

20+ gradients; and applying gradient decent for learning.

2121 .

2222 Documentation and examples are available on github

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

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

2626 README.md

2727 cbits/im2col.h

2828 cbits/im2col.c

29− cbits/gradient_descent.h

30− cbits/gradient_descent.c

29+ cbits/gradient_decent.h

30+ cbits/gradient_decent.c

3131 cbits/pad.h

3232 cbits/pad.c

3333

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

3838library

3939 build-depends:

4040 base >= 4.8 && < 5

41− , bytestring >= 0.10.0

42− , containers >= 0.5 && < 0.7

41+ , bytestring == 0.10.*

42+ , containers >= 0.5 && < 0.6

4343 , cereal >= 0.5 && < 0.6

4444 , deepseq >= 1.4 && < 1.5

45− , hmatrix >= 0.18 && < 0.21

45+ , exceptions == 0.8.*

46+ , hmatrix == 0.18.*

4647 , MonadRandom >= 0.4 && < 0.6

47− , primitive >= 0.6 && < 0.8

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

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

50− , singletons

51− , singletons-base

48+ , mtl >= 2.2.1 && < 2.3

49+ , primitive >= 0.6 && < 0.7

50+ , text == 1.2.*

51+ , singletons >= 2.1 && < 2.3

5252 , vector >= 0.11 && < 0.13

5353

5454 ghc-options:

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

5656 hs-source-dirs:

5757 src

5858

59− default-language: Haskell2010

60−

6159 if impl(ghc < 8.0)

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

63− cpp-options: -DType=*

6461

65− if impl(ghc >= 8.6)

66− default-extensions: NoStarIsType

6762

6863 exposed-modules:

6964 Grenade

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

8984 Grenade.Layers.Pooling

9085 Grenade.Layers.Relu

9186 Grenade.Layers.Reshape

92− Grenade.Layers.Sinusoid

9387 Grenade.Layers.Softmax

9488 Grenade.Layers.Tanh

9589 Grenade.Layers.Trivial

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

108102

109103 Grenade.Recurrent.Layers

110104 Grenade.Recurrent.Layers.BasicRecurrent

111− Grenade.Recurrent.Layers.ConcatRecurrent

112105 Grenade.Recurrent.Layers.LSTM

113106

114107 Grenade.Utils.OneHot

115108

116109 includes: cbits/im2col.h

117− cbits/gradient_descent.h

110+ cbits/gradient_decent.h

118111 cbits/pad.h

119112 c-sources: cbits/im2col.c

120− cbits/gradient_descent.c

113+ cbits/gradient_decent.c

121114 cbits/pad.c

122115

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

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

132125 hs-source-dirs:

133126 test

134127

135− default-language: Haskell2010

136128

137129 other-modules: Test.Hedgehog.Compat

138130 Test.Hedgehog.Hmatrix

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

153145

154146 if impl(ghc < 8.0)

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

156− cpp-options: -DType=*

157−

158− if impl(ghc >= 8.6)

159− default-extensions: NoStarIsType

160148

161149 build-depends:

162− base

150+ base >= 4.8 && < 5

163151 , grenade

164− , hedgehog >= 1.0 && < 1.1

152+ , hedgehog >= 0.1 && < 0.2

165153 , hmatrix

166154 , mtl

167155 , singletons

168156 , text == 1.2.*

169− , typelits-witnesses < 0.4

157+ , typelits-witnesses

170158 , transformers

171159 , constraints

172160 , MonadRandom

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

186174 hs-source-dirs:

187175 bench

188176

189− default-language: Haskell2010

190−

191177 build-depends:

192− base

193− , bytestring

194− , criterion >= 1.1 && < 1.6

178+ base >= 3 && < 5

179+ , bytestring == 0.10.*

180+ , criterion == 1.1.*

195181 , grenade

196182 , hmatrix

197183

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

205191 hs-source-dirs:

206192 bench

207193

208− default-language: Haskell2010

209−

210194 build-depends:

211− base

212− , bytestring

213− , criterion

195+ base >= 3 && < 5

196+ , bytestring == 0.10.*

197+ , criterion == 1.1.*

214198 , grenade

215199 , hmatrix

mafiamode 120000 → 100755+123−1

@@ -1 +0,0 @@

1−framework/mafia

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

1+#!/bin/sh -eu

2+

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

4+

5+fetch_latest () {

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

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

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

9+ else

10+ cat ../script/mafia

11+ fi

12+}

13+

14+latest_version () {

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

16+}

17+

18+local_version () {

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

20+}

21+

22+run_upgrade () {

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

24+

25+ clean_up () {

26+ rm -f "$MAFIA_TEMP"

27+ }

28+

29+ trap clean_up EXIT

30+

31+ MAFIA_CUR="$0"

32+

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

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

35+ exit 1

36+ fi

37+

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

39+ fetch_latest > $MAFIA_TEMP

40+

41+ LATEST_VERSION=$(latest_version)

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

43+

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

45+ mv $MAFIA_TEMP $MAFIA_CUR

46+ chmod +x $MAFIA_CUR

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

48+ else

49+ echo "You have latest mafia."

50+ fi

51+}

52+

53+exec_mafia () {

54+ MAFIA_VERSION=$(local_version)

55+

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

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

58+ run_upgrade

59+ else

60+ MAFIA_BIN=$MAFIA_HOME/bin

61+ MAFIA_FILE=mafia-$MAFIA_VERSION

62+ MAFIA_PATH=$MAFIA_BIN/$MAFIA_FILE

63+

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

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

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

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

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

69+

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

71+ mkdir -p $MAFIA_BIN

72+

73+ clean_up () {

74+ rm -rf "$MAFIA_TEMP"

75+ }

76+

77+ trap clean_up EXIT

78+

79+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

80+

81+ ( cd "$MAFIA_TEMP"

82+

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

84+ cd mafia

85+

86+ git reset --hard $MAFIA_VERSION

87+

88+ bin/bootstrap ) || exit $?

89+

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

91+

92+ clean_up_temp () {

93+ clean_up

94+ rm -f "$MAFIA_PATH_TEMP"

95+ }

96+ trap clean_up_temp EXIT

97+

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

99+ chmod 755 "$MAFIA_PATH_TEMP"

100+ mv "$MAFIA_PATH_TEMP" "$MAFIA_PATH"

101+

102+ clean_up_temp

103+ }

104+

105+ exec $MAFIA_PATH "$@"

106+ fi

107+}

108+

109+#

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

111+#

112+

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

114+ MODE="$1"

115+else

116+ MODE=""

117+fi

118+

119+case "$MODE" in

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

121+*) exec_mafia "$@"

122+esac

123+# Version: 360716306a06db842ec022a7b9f161d2208483f0

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE GADTs #-}

43{-# LANGUAGE TypeOperators #-}

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

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

2120

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

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

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

2423to the input and output data of the layer.

2524

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

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

4241

4342import Data.List ( foldl' )

4443

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

46−import Data.Kind (Type)

47−#endif

48−

4944import Grenade.Core.Shape

5045import Grenade.Core.LearningParameters

5146

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

5550class UpdateLayer x where

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

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

58− type Gradient x :: Type

53+ type Gradient x :: *

5954

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

6156 runUpdate :: LearningParameters -> x -> Gradient x -> x

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

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

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

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

80− type Tape x i o :: Type

75+ type Tape x i o :: *

8176

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

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

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

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

77-}

88module Grenade.Core.LearningParameters (

99 -- | This module contains learning algorithm specific

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

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

1111 -- unstable, due to issue #26.

1212

1313 LearningParameters (..)

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE BangPatterns #-}

43{-# LANGUAGE GADTs #-}

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

3433import Control.Monad.Random ( MonadRandom )

3534

3635import Data.Singletons

36+import Data.Singletons.Prelude

3737import Data.Serialize

3838

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

40−import Data.Kind (Type)

41−#endif

42−

4339import Grenade.Core.Layer

4440import Grenade.Core.LearningParameters

4541import Grenade.Core.Shape

46−import Prelude.Singletons

4742

4843-- | Type of a network.

4944--

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

5348--

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

5550-- transform the data shapes of the network.

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

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

5752 NNil :: SingI i

5853 => Network '[] '[i]

5954

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

7166-- | Gradient of a network.

7267--

7368-- Parameterised on the layers of the network.

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

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

7570 GNil :: Gradients '[]

7671

7772 (:/>) :: UpdateLayer x

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

8277-- | Wegnert Tape of a network.

8378--

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

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

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

8681 TNil :: SingI i

8782 => Tapes '[] '[i]

8883

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

144139 = (GNil, o)

145140

146141

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

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

148143applyUpdate :: LearningParameters

149144 -> Network layers shapes

150145 -> Gradients layers

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

157152

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

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

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

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

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

162157 --

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

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

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

1313 , runNet

1414 ) where

1515

16+import Data.Singletons.Prelude

1617

1718import Grenade.Core.LearningParameters

1819import Grenade.Core.Network

1920import Grenade.Core.Shape

20−import Data.Singletons

21−import Prelude.Singletons

2221

2322-- | Perform reverse automatic differentiation on the network

2423-- for the current input and expected output.

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE GADTs #-}

43{-# LANGUAGE KindSignatures #-}

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

87{-# LANGUAGE FlexibleContexts #-}

98{-# LANGUAGE ScopedTypeVariables #-}

109{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE UndecidableInstances #-}

1210{-|

1311Module : Grenade.Core.Shape

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

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

1917

2018-}

2119module Grenade.Core.Shape (

22− S (..)

23− , Shape (..)

24− , SShape (..)

20+ Shape (..)

21+ , S (..)

22+ , Sing (..)

23+

2524 , randomOfShape

2625 , fromStorable

2726 ) where

2827

2928import Control.DeepSeq (NFData (..))

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

31−import Data.Kind (Type)

30+

3231import Data.Proxy

33−import Data.Serialize

3432import Data.Singletons

33+import Data.Singletons.TypeLits

3534import Data.Vector.Storable ( Vector )

3635import qualified Data.Vector.Storable as V

36+

3737import GHC.TypeLits

38+

3839import qualified Numeric.LinearAlgebra.Static as H

3940import Numeric.LinearAlgebra.Static

4041import qualified Numeric.LinearAlgebra as NLA

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

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

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

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

9183data instance Sing (n :: Shape) where

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

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

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

95−#endif

9687

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

98− sing = D1Sing

89+ sing = D1Sing sing

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

100− sing = D2Sing

91+ sing = D2Sing sing sing

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

102− sing = D3Sing

93+ sing = D3Sing sing sing sing

10394

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

10596 (+) = n2 (+)

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

148139randomOfShape = do

149140 seed :: Int <- getRandom

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

151− D1Sing ->

142+ D1Sing SNat ->

152143 S1D (randomVector seed Uniform * 2 - 1)

153144

154− D2Sing ->

145+ D2Sing SNat SNat ->

155146 S2D (uniformSample seed (-1) 1)

156147

157− D3Sing ->

148+ D3Sing SNat SNat SNat ->

158149 S3D (uniformSample seed (-1) 1)

159150

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

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

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

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

164155fromStorable xs = case sing :: Sing x of

165− D1Sing ->

156+ D1Sing SNat ->

166157 S1D <$> H.create xs

167158

168− D2Sing ->

159+ D2Sing SNat SNat ->

169160 S2D <$> mkL xs

170161

171− D3Sing ->

162+ D3Sing SNat SNat SNat ->

172163 S3D <$> mkL xs

173164 where

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

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

180171 then H.create $ NLA.reshape columns v

181172 else Nothing

182173

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−

195174-- Helper function for creating the number instances

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

197176n1 f (S1D x) = S1D (f x)

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

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

206185

207186-- Helper function for creating the number instances

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

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

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

210− D1Sing ->

189+ D1Sing SNat ->

211190 S1D (konst x)

212191

213− D2Sing ->

192+ D2Sing SNat SNat ->

214193 S2D (konst x)

215194

216− D3Sing ->

195+ D3Sing SNat SNat SNat ->

217196 S3D (konst x)

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE GADTs #-}

43{-# LANGUAGE TypeOperators #-}

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

98{-# LANGUAGE FlexibleInstances #-}

109{-# LANGUAGE ScopedTypeVariables #-}

1110{-# LANGUAGE StandaloneDeriving #-}

12−{-# LANGUAGE UndecidableInstances #-}

1311{-|

1412Module : Grenade.Layers.Concat

1513Description : Concatenation layer

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

2826import Data.Singletons

2927import GHC.TypeLits

3028

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

32−import Data.Kind (Type)

33−#endif

34−

3529import Grenade.Core

3630

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

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

4943--

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

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

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

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

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

5448

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

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE TypeOperators #-}

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE MultiParamTypeClasses #-}

88{-# LANGUAGE FlexibleInstances #-}

99{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE UndecidableInstances #-}

1110{-|

1211Module : Grenade.Layers.Convolution

1312Description : Convolution layer

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

2827import Data.Maybe

2928import Data.Proxy

3029import Data.Serialize

30+import Data.Singletons.TypeLits

3131

3232import GHC.TypeLits

33−import Data.Kind (Type)

3433

3534import Numeric.LinearAlgebra hiding ( uniformSample, konst )

3635import qualified Numeric.LinearAlgebra as LA

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

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

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

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

60− -> Type where

59+ -> * where

6160 Convolution :: ( KnownNat channels

6261 , KnownNat filters

6362 , KnownNat kernelRows

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

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

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

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

79− -> Type where

78+ -> * where

8079 Convolution' :: ( KnownNat channels

8180 , KnownNat filters

8281 , KnownNat kernelRows

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

130129 , KnownNat strideColumns

131130 , KnownNat (kernelRows * kernelColumns * channels)

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

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

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

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

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

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

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

136135 in Convolution newKernel newMomentum

137136

138137 createRandom = randomConvolution

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE ScopedTypeVariables #-}

43{-# LANGUAGE GADTs #-}

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

65{-# LANGUAGE TypeFamilies #-}

76{-# LANGUAGE FlexibleContexts #-}

87{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE UndecidableInstances #-}

108{-|

119Module : Grenade.Layers.Crop

1210Description : Cropping layer

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

2018

2119import Data.Maybe

2220import Data.Proxy

23−import Data.Serialize

24−

21+import Data.Singletons.TypeLits

2522import GHC.TypeLits

26−import Data.Kind (Type)

2723

2824import Grenade.Core

2925import Grenade.Layers.Internal.Pad

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

3531data Crop :: Nat

3632 -> Nat

3733 -> Nat

38− -> Nat -> Type where

34+ -> Nat -> * where

3935 Crop :: Crop cropLeft cropTop cropRight cropBottom

4036

4137instance Show (Crop cropLeft cropTop cropRight cropBottom) where

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

4642 runUpdate _ x _ = x

4743 createRandom = return Crop

4844

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

50− put _ = return ()

51− get = return Crop

52−

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

5446instance ( KnownNat cropLeft

5547 , KnownNat cropTop

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

5951 , KnownNat inputColumns

6052 , KnownNat outputRows

6153 , KnownNat outputColumns

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

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

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

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

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

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

6658 runForwards Crop (S2D input) =

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE TypeOperators #-}

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE MultiParamTypeClasses #-}

88{-# LANGUAGE FlexibleInstances #-}

99{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE UndecidableInstances #-}

1110{-|

1211Module : Grenade.Layers.Deconvolution

1312Description : Deconvolution layer

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

3231import Data.Maybe

3332import Data.Proxy

3433import Data.Serialize

34+import Data.Singletons.TypeLits

3535

3636import GHC.TypeLits

37−import Data.Kind (Type)

3837

3938import Numeric.LinearAlgebra hiding ( uniformSample, konst )

4039import qualified Numeric.LinearAlgebra as LA

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

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

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

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

59− -> Type where

58+ -> * where

6059 Deconvolution :: ( KnownNat channels

6160 , KnownNat filters

6261 , KnownNat kernelRows

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

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

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

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

78− -> Type where

77+ -> * where

7978 Deconvolution' :: ( KnownNat channels

8079 , KnownNat filters

8180 , KnownNat kernelRows

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

129128 , KnownNat strideColumns

130129 , KnownNat (kernelRows * kernelColumns * filters)

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

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

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

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

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

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

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

135134 in Deconvolution newKernel newMomentum

136135

137136 createRandom = randomDeconvolution

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

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

3636 get = return Elu

3737

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

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

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

4040

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

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

4242 where

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

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

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

4545 where

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

4747

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

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

11{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE RecordWildCards #-}

23{-# LANGUAGE TypeOperators #-}

34{-# LANGUAGE TypeFamilies #-}

45{-# LANGUAGE MultiParamTypeClasses #-}

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

1314

1415import Data.Proxy

1516import Data.Serialize

17+import Data.Singletons.TypeLits

1618

1719import qualified Numeric.LinearAlgebra as LA

1820import Numeric.LinearAlgebra.Static

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

2022import Grenade.Core

2123

2224import Grenade.Layers.Internal.Update

23−import GHC.TypeLits

2425

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

2627data FullyConnected i o = FullyConnected

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

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

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

3940

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

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

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

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

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

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

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

4445

4546 createRandom = randomFullyConnected

4647

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

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

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

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

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

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

5152

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

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

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

5455 let wB' = dEdy

5556 mm' = dEdy `outer` x

5657 -- calcluate derivatives for next step

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

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

11{-# LANGUAGE ForeignFunctionInterface #-}

22module Grenade.Layers.Internal.Update (

3− descendMatrix

4− , descendVector

3+ decendMatrix

4+ , decendVector

55 ) where

66

77import Data.Maybe ( fromJust )

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

1717

1818import System.IO.Unsafe ( unsafePerformIO )

1919

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

21−descendMatrix rate momentum regulariser weights gradient lastUpdate =

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

21+decendMatrix rate momentum regulariser weights gradient lastUpdate =

2222 let (rows, cols) = size weights

2323 len = rows * cols

2424 -- Most gradients come in in ColumnMajor,

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

2929 weights' = flatten . tr . extract $ weights

3030 gradient' = flatten . tr . extract $ gradient

3131 lastUpdate' = flatten . tr . extract $ lastUpdate

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

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

3333

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

3535 -- using the internal vectors.

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

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

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

3939

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

41−descendVector rate momentum regulariser weights gradient lastUpdate =

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

41+decendVector rate momentum regulariser weights gradient lastUpdate =

4242 let len = size weights

4343 weights' = extract weights

4444 gradient' = extract gradient

4545 lastUpdate' = extract lastUpdate

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

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

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

4848

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

50−descendUnsafe len rate momentum regulariser weights gradient lastUpdate =

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

50+decendUnsafe len rate momentum regulariser weights gradient lastUpdate =

5151 unsafePerformIO $ do

5252 outWPtr <- mallocForeignPtrArray len

5353 outMPtr <- mallocForeignPtrArray len

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

6060 withForeignPtr lPtr $ \lPtr' ->

6161 withForeignPtr outWPtr $ \outWPtr' ->

6262 withForeignPtr outMPtr $ \outMPtr' ->

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

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

6464

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

6666

6767foreign import ccall unsafe

68− descend_cpu

68+ decend_cpu

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

7070

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

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

3434 createRandom = return Logit

3535

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

37− -- Wengert tape optimisation:

38− --

39− -- Derivative of the sigmoid function is

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

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

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

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

4437 type Tape Logit a b = S a

45− runForwards _ a =

46− let l = sigmoid a

47− in (l, l)

48− runBackwards _ l g =

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

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

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

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

5140

5241instance Serialize Logit where

5342 put _ = return ()

5443 get = return Logit

5544

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

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

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

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

47+

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

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

50+ where

51+ logix = logistic x

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE GADTs #-}

43{-# LANGUAGE TypeOperators #-}

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

2423

2524import Data.Singletons

2625

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

28−import Data.Kind (Type)

29−#endif

30−

3126import Grenade.Core

3227

3328-- | A Merging layer.

3429--

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

3631-- shape.

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

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

3833 Merge :: x -> y -> Merge x y

3934

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

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE ScopedTypeVariables #-}

43{-# LANGUAGE GADTs #-}

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

65{-# LANGUAGE TypeFamilies #-}

76{-# LANGUAGE MultiParamTypeClasses #-}

87{-# LANGUAGE FlexibleContexts #-}

9−{-# LANGUAGE UndecidableInstances #-}

108{-|

119Module : Grenade.Core.Pad

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

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

2119import Data.Maybe

2220import Data.Proxy

2321import Data.Serialize

24−

22+import Data.Singletons.TypeLits

2523import GHC.TypeLits

26−import Data.Kind (Type)

2724

2825import Grenade.Core

2926import Grenade.Layers.Internal.Pad

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

3734data Pad :: Nat

3835 -> Nat

3936 -> Nat

40− -> Nat -> Type where

37+ -> Nat -> * where

4138 Pad :: Pad padLeft padTop padRight padBottom

4239

4340instance Show (Pad padLeft padTop padRight padBottom) where

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

5249 put _ = return ()

5350 get = return Pad

5451

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

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

5653instance ( KnownNat padLeft

5754 , KnownNat padTop

5855 , KnownNat padRight

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

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

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

8481

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

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

8683instance ( KnownNat padLeft

8784 , KnownNat padTop

8885 , KnownNat padRight

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE ScopedTypeVariables #-}

43{-# LANGUAGE StandaloneDeriving #-}

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

76{-# LANGUAGE TypeFamilies #-}

87{-# LANGUAGE MultiParamTypeClasses #-}

98{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE UndecidableInstances #-}

119{-|

1210Module : Grenade.Core.Pooling

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

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

2220import Data.Maybe

2321import Data.Proxy

2422import Data.Serialize

25−

23+import Data.Singletons.TypeLits

2624import GHC.TypeLits

27−import Data.Kind (Type)

2825

2926import Grenade.Core

3027import Grenade.Layers.Internal.Pooling

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

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

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

4138--

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

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

4340 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

4441

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

4643 show Pooling = "Pooling"

4744

4845instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

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

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

5047 runUpdate _ Pooling _ = Pooling

5148 createRandom = return Pooling

5249

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

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

33{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

55{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE UndecidableInstances #-}

76{-|

87Module : Grenade.Layers.Reshape

98Description : Multipurpose reshaping layer

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

1716

1817import Data.Serialize

1918

19+import Data.Singletons.TypeLits

2020import GHC.TypeLits

2121

2222import Numeric.LinearAlgebra.Static

src/Grenade/Layers/Sinusoid.hsdeleted−39

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE TypeOperators #-}

6−{-|

7−Module : Grenade.Layers.Sinusoid

8−Description : Sinusoid nonlinear layer

9−Copyright : (c) Manuel Schneckenreither, 2018

10−License : BSD2

11−Stability : experimental

12−-}

13−module Grenade.Layers.Sinusoid (

14− Sinusoid (..)

15− ) where

16−

17−import Data.Serialize

18−import Data.Singletons

19−

20−import Grenade.Core

21−

22−-- | A Sinusoid layer.

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

24−data Sinusoid = Sinusoid

25− deriving Show

26−

27−instance UpdateLayer Sinusoid where

28− type Gradient Sinusoid = ()

29− runUpdate _ _ _ = Sinusoid

30− createRandom = return Sinusoid

31−

32−instance Serialize Sinusoid where

33− put _ = return ()

34− get = return Sinusoid

35−

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

37− type Tape Sinusoid a b = S a

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

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

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

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

11{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE TypeFamilies #-}

24{-# LANGUAGE FlexibleInstances #-}

35{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE TypeOperators #-}

66{-|

77Module : Grenade.Layers.Tanh

88Description : Hyperbolic tangent nonlinear layer

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

2020import Grenade.Core

2121

2222-- | A Tanh layer.

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

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

2424data Tanh = Tanh

2525 deriving Show

2626

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE TypeFamilies #-}

43{-# LANGUAGE MultiParamTypeClasses #-}

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

98 , RecurrentUpdateLayer (..)

109 ) where

1110

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

13−import Data.Kind (Type)

14−#endif

11+import Data.Singletons ( SingI )

1512

1613import Grenade.Core

1714

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

2017-- of an extra recurrent data shape.

2118class UpdateLayer x => RecurrentUpdateLayer x where

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

23− type RecurrentShape x :: Type

20+ type RecurrentShape x :: Shape

2421

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

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

2623 -- | Wengert Tape

27− type RecTape x i o :: Type

24+ type RecTape x i o :: *

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

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

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

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

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

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

3330 -- the layer above.

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

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

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

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE GADTs #-}

43{-# LANGUAGE TypeOperators #-}

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

1817

1918 , RecurrentNetwork (..)

2019 , RecurrentInputs (..)

21− , RecurrentTape (..)

22− , RecurrentGradient (..)

20+ , RecurrentTapes (..)

21+ , RecurrentGradients (..)

2322

2423 , randomRecurrent

25− , runRecurrent

26− , runRecurrent'

24+ , runRecurrentNetwork

25+ , runRecurrentGradient

2726 , applyRecurrentUpdate

2827 ) where

2928

3029

3130import Control.Monad.Random ( MonadRandom )

31+import Data.Singletons ( SingI )

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

3233import Data.Serialize

33−

34−import Data.Kind (Type)

34+import qualified Data.Vector.Storable as V

3535

3636import Grenade.Core

3737import Grenade.Recurrent.Core.Layer

38−import Prelude.Singletons

38+

39+import qualified Numeric.LinearAlgebra as LA

40+import qualified Numeric.LinearAlgebra.Static as LAS

3941

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

4143-- forward layer.

42−data FeedForward :: Type -> Type

44+data FeedForward :: * -> *

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

44−data Recurrent :: Type -> Type

46+data Recurrent :: * -> *

4547

4648-- | Type of a recurrent neural network.

4749--

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

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

4951--

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

5153--

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

5456--

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

5658-- for these empty data types.

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

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

5860 RNil :: SingI i

5961 => RecurrentNetwork '[] '[i]

6062

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

7375-- | Gradient of a network.

7476--

7577-- Parameterised on the layers of the network.

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

77− RGNil :: RecurrentGradient '[]

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

79+ RGNil :: RecurrentGradients '[]

7880

7981 (://>) :: UpdateLayer x

80− => Gradient x

81− -> RecurrentGradient xs

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

82+ => [Gradient x]

83+ -> RecurrentGradients xs

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

8385

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

8587-- Parameterised on the layers of a Network.

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

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

8789 RINil :: RecurrentInputs '[]

8890

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

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

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

9193

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

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

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

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

9496

9597-- | All the information required to backpropogate

9698-- through time safely.

9799--

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

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

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

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

101103 TRNil :: SingI i

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

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

105+

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

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

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

103109

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

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

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

107110

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

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

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

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

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

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

111114

112115

113−runRecurrent :: forall shapes layers.

114− RecurrentNetwork layers shapes

115− -> RecurrentInputs layers

116− -> S (Head shapes)

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

118−runRecurrent =

116+runRecurrentNetwork :: forall shapes layers.

117+ RecurrentNetwork layers shapes

118+ -> RecurrentInputs layers

119+ -> [S (Head shapes)]

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

121+runRecurrentNetwork =

119122 go

120123 where

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

122125 => RecurrentNetwork sublayers js

123126 -> RecurrentInputs sublayers

124− -> S (Head js)

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

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

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

128−

127+ -> [S (Head js)]

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

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

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

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

132+ feedForwardTapes = fst <$> tys

133+ forwards = snd <$> tys

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

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

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

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

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

132137

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

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

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

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

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

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

142+ recurrentTapes = fst <$> tys

143+ forwards = snd <$> tys

144+

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

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

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

139147

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

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

142150 go RNil RINil !x

143151 = (TRNil, RINil, x)

144152

145−runRecurrent' :: forall layers shapes.

146− RecurrentNetwork layers shapes

147− -> RecurrentTape layers shapes

148− -> RecurrentInputs layers

149− -> S (Last shapes)

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

151−runRecurrent' net tapes r o =

153+ -- Helper function for recurrent layers

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

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

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

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

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

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

160+

161+runRecurrentGradient :: forall layers shapes.

162+ RecurrentNetwork layers shapes

163+ -> RecurrentTapes layers shapes

164+ -> RecurrentInputs layers

165+ -> [S (Last shapes)]

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

167+runRecurrentGradient net tapes r o =

152168 go net tapes r

153169 where

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

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

156172 -- through time.

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

158174 => RecurrentNetwork ss js

159− -> RecurrentTape ss js

175+ -> RecurrentTapes ss js

160176 -> RecurrentInputs ss

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

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

162178 -- This is a simple non-recurrent layer

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

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

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

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

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

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

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

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

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

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

168184

169185 -- This is a recurrent layer

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

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

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

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

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

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

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

189+ backExamples = zip (reverse recurrentTapes) feed

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

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

175192

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

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

178195 -- well.

179− go !RNil !TRNil !RINil

180− = (RGNil, RINil, o)

196+ go RNil TRNil RINil

197+ = (RGNil, RINil, reverse o)

198+

199+ -- Helper function for recurrent layers

200+ -- Scans over the recurrent direction of the graph.

201+ goX :: RecurrentLayer x i o => x -> S (RecurrentShape x) -> [(RecTape x i o, S o)] -> (S (RecurrentShape x), [(Gradient x, S i)])

202+ goX layer !lastback ((recTape, backgrad):xs) =

203+ let (layergrad, recgrad, ingrad) = runRecurrentBackwards layer recTape lastback backgrad

204+ (pushedback, ll) = goX layer recgrad xs

205+ in (pushedback, (layergrad, ingrad) : ll)

206+ goX _ !lastback [] = (lastback, [])

181207

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

183209-- Uses runUpdates which can be specialised for

184210-- a layer.

185211applyRecurrentUpdate :: LearningParameters

186212 -> RecurrentNetwork layers shapes

187− -> RecurrentGradient layers

213+ -> RecurrentGradients layers

188214 -> RecurrentNetwork layers shapes

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

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

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

191217

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

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

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

194220

195221applyRecurrentUpdate _ RNil RGNil

196222 = RNil

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

206232

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

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

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

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

210236 -- | Create a network of the types requested

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

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

212238

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

214240 randomRecurrent =

215− return RNil

241+ return (RNil, RINil)

216242

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

218244 randomRecurrent = do

219245 thisLayer <- createRandom

220− rest <- randomRecurrent

221− return (thisLayer :~~> rest)

246+ (rest, resti) <- randomRecurrent

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

222248

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

224250 randomRecurrent = do

225251 thisLayer <- createRandom

226− rest <- randomRecurrent

227− return (thisLayer :~@> rest)

252+ thisShape <- randomOfShape

253+ (rest, resti) <- randomRecurrent

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

228255

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

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

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

243270 put _ = return ()

244271 get = return RINil

245272

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

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

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

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

249276

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

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

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

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

278+ put ( i :~@+> rest ) = do

279+ _ <- (case i of

280+ (S1D x) -> putListOf put . LA.toList . LAS.extract $ x

281+ (S2D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

282+ (S3D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

283+ ) :: PutM ()

284+ put rest

285+

286+ get = do

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

288+ rest <- get

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

253290

254291

255292-- Num instance for `RecurrentInputs layers`

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

270307 signum _ = RINil

271308 fromInteger _ = RINil

272309

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

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

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

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

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

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

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

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

280317

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

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

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

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

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

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

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

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

288−

289−instance (Fractional (RecurrentInputs '[])) where

290− (/) _ _ = RINil

291− recip _ = RINil

292− fromRational _ = RINil

293−

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

295− (/) (() :~~+> x) (() :~~+> y) = () :~~+> (x / y)

296− recip (() :~~+> x) = () :~~+> recip x

297− fromRational x = () :~~+> fromRational x

298−

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

300− (/) (x :~@+> x') (y :~@+> y') = (x / y) :~@+> (x' / y')

301− recip (x :~@+> x') = recip x :~@+> recip x'

302− fromRational x = fromRational x :~@+> fromRational x

303−

304−

305−-- | Ultimate composition.

306−--

307−-- This allows a complete network to be treated as a layer in a larger network.

308−instance CreatableRecurrent sublayers subshapes => UpdateLayer (RecurrentNetwork sublayers subshapes) where

309− type Gradient (RecurrentNetwork sublayers subshapes) = RecurrentGradient sublayers

310− runUpdate = applyRecurrentUpdate

311− createRandom = randomRecurrent

312−

313−-- | Ultimate composition.

314−--

315−-- This allows a complete network to be treated as a layer in a larger network.

316−instance CreatableRecurrent sublayers subshapes => RecurrentUpdateLayer (RecurrentNetwork sublayers subshapes) where

317− type RecurrentShape (RecurrentNetwork sublayers subshapes) = RecurrentInputs sublayers

318−

319−-- | Ultimate composition.

320−--

321−-- This allows a complete network to be treated as a layer in a larger network.

322−instance ( CreatableRecurrent sublayers subshapes

323− , i ~ (Head subshapes), o ~ (Last subshapes)

324− , Num (RecurrentShape (RecurrentNetwork sublayers subshapes))

325− ) => RecurrentLayer (RecurrentNetwork sublayers subshapes) i o where

326− type RecTape (RecurrentNetwork sublayers subshapes) i o = RecurrentTape sublayers subshapes

327− runRecurrentForwards = runRecurrent

328− runRecurrentBackwards = runRecurrent'

src/Grenade/Recurrent/Core/Runner.hs+34−54

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

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE FlexibleContexts #-}

88{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE RecordWildCards #-}

910

1011module Grenade.Recurrent.Core.Runner (

11− runRecurrentExamples

12− , runRecurrentBackprop

12+ trainRecurrent

13+ , runRecurrent

1314 , backPropagateRecurrent

14− , trainRecurrent

15−

16− , RecurrentGradients

1715 ) where

1816

19−import Data.List ( foldl' )

17+import Data.Singletons.Prelude

2018import Grenade.Core

2119

20+import Grenade.Recurrent.Core.Layer

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

5522

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

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

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

5825 => RecurrentNetwork layers shapes

5926 -> RecurrentInputs layers

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

6128 -> (RecurrentGradients layers, RecurrentInputs layers)

6229backPropagateRecurrent network recinputs examples =

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

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

6431

65− backPropagations = zipWith makeError outForwards targets

32+ backPropagations = zipWith makeError guesses targets

6633

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

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

6835

69− gradients = fmap fst outBackwards

7036 in (gradients, input')

7137

7238 where

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

7440 inputs = fst <$> examples

7541 targets = snd <$> examples

7642

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

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

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

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

44+ makeError _ Nothing = 0

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

8046

8147

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

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

8349 => LearningParameters

8450 -> RecurrentNetwork layers shapes

8551 -> RecurrentInputs layers

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

9056

9157 newInputs = updateRecInputs rate recinputs recinputs'

9258

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

59+ newNetwork = applyRecurrentUpdate rate network gradients

9460

9561 in (newNetwork, newInputs)

9662

97−updateRecInputs :: Fractional (RecurrentInputs sublayers)

98− => LearningParameters

63+updateRecInputs :: LearningParameters

9964 -> RecurrentInputs sublayers

10065 -> RecurrentInputs sublayers

10166 -> RecurrentInputs sublayers

10267

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

104− = () :~~+> updateRecInputs lp xs ys

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

69+ = () :~~+> updateRecInputs l xs ys

10570

106−updateRecInputs lp (x :~@+> xs) (y :~@+> ys)

107− = (realToFrac (1 - learningRate lp * learningRegulariser lp) * x - realToFrac (learningRate lp) * y) :~@+> updateRecInputs lp xs ys

71+updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)

72+ = (realToFrac (1 - learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys

10873

10974updateRecInputs _ RINil RINil

11075 = RINil

76+

77+-- | Just forwards propagation with no training.

78+runRecurrent :: RecurrentNetwork layers shapes

79+ -> RecurrentInputs layers -> S (Head shapes)

80+ -> (RecurrentInputs layers, S (Last shapes))

81+runRecurrent (layer :~~> n) (() :~~+> nr) !x

82+ = let (_, ys) = runForwards layer x

83+ (nr', o) = runRecurrent n nr ys

84+ in (() :~~+> nr', o)

85+runRecurrent (layer :~@> n) (recin :~@+> nr) !x

86+ = let (_, recin', y) = runRecurrentForwards layer recin x

87+ (nr', o) = runRecurrent n nr y

88+ in (recin' :~@+> nr', o)

89+runRecurrent RNil RINil !x

90+ = (RINil, x)

src/Grenade/Recurrent/Layers.hs−2

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

11module Grenade.Recurrent.Layers (

22 module Grenade.Recurrent.Layers.BasicRecurrent

3− , module Grenade.Recurrent.Layers.ConcatRecurrent

43 , module Grenade.Recurrent.Layers.LSTM

54 ) where

65

76import Grenade.Recurrent.Layers.BasicRecurrent

8−import Grenade.Recurrent.Layers.ConcatRecurrent

97import Grenade.Recurrent.Layers.LSTM

src/Grenade/Recurrent/Layers/BasicRecurrent.hs+9−10

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE TypeOperators #-}

55{-# LANGUAGE TypeFamilies #-}

66{-# LANGUAGE MultiParamTypeClasses #-}

@@ -16,8 +16,7 @@ module Grenade.Recurrent.Layers.BasicRecurrent (

1616

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

1818

19−

20−import Data.Kind (Type)

19+import Data.Singletons.TypeLits

2120

2221import Numeric.LinearAlgebra.Static

2322

@@ -28,7 +27,7 @@ import Grenade.Recurrent.Core

2827

2928data BasicRecurrent :: Nat -- Input layer size

3029 -> Nat -- Output layer size

31− -> Type where

30+ -> * where

3231 BasicRecurrent :: ( KnownNat input

3332 , KnownNat output

3433 , KnownNat matrixCols

@@ -41,7 +40,7 @@ data BasicRecurrent :: Nat -- Input layer size

4140

4241data BasicRecurrent' :: Nat -- Input layer size

4342 -> Nat -- Output layer size

44− -> Type where

43+ -> * where

4544 BasicRecurrent' :: ( KnownNat input

4645 , KnownNat output

4746 , KnownNat matrixCols

@@ -56,18 +55,18 @@ instance Show (BasicRecurrent i o) where

5655instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

5756 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

5857

59− runUpdate lp (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

60− let newBiasMomentum = konst (learningMomentum lp) * oldBiasMomentum - konst (learningRate lp) * biasGradient

58+ runUpdate LearningParameters {..} (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

59+ let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient

6160 newBias = oldBias + newBiasMomentum

62− newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient

63− regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations

61+ newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient

62+ regulariser = konst (learningRegulariser * learningRate) * oldActivations

6463 newActivations = oldActivations + newMomentum - regulariser

6564 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

6665

6766 createRandom = randomBasicRecurrent

6867

6968instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where

70− type RecurrentShape (BasicRecurrent i o) = S ('D1 o)

69+ type RecurrentShape (BasicRecurrent i o) = 'D1 o

7170

7271instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

7372

src/Grenade/Recurrent/Layers/ConcatRecurrent.hsdeleted−180

@@ -1,180 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE TypeOperators #-}

5−{-# LANGUAGE TypeFamilies #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE FlexibleContexts #-}

8−{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE FlexibleInstances #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE StandaloneDeriving #-}

12−{-# LANGUAGE UndecidableInstances #-}

13−{-|

14−Module : Grenade.Layers.Concat

15−Description : Concatenation layer

16−Copyright : (c) Huw Campbell, 2016-2017

17−License : BSD2

18−Stability : experimental

19−

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

21−-}

22−module Grenade.Recurrent.Layers.ConcatRecurrent (

23− ConcatRecurrent (..)

24− ) where

25−

26−import Data.Serialize

27−

28−import Data.Singletons

29−import GHC.TypeLits

30−

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

32−import Data.Kind (Type)

33−#endif

34−

35−import Grenade.Core

36−import Grenade.Recurrent.Core

37−

38−import Numeric.LinearAlgebra.Static ( (#), split, R )

39−

40−-- | A Concatentating Layer.

41−--

42−-- This layer shares it's input state between two sublayers, and concatenates their output.

43−--

44−-- With Networks able to be Layers, this allows for very expressive composition of complex Networks.

45−--

46−-- The Concat layer has a few instances, which allow one to flexibly "bash" together the outputs.

47−--

48−-- Two 1D vectors, can go to a 2D shape with 2 rows if their lengths are identical.

49−-- Any 2 1D vectors can also become a longer 1D Vector.

50−--

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

52−-- and Crop layers to ensure this is the case.

53−data ConcatRecurrent :: Shape -> Type -> Shape -> Type -> Type where

54− ConcatRecLeft :: x -> y -> ConcatRecurrent m (Recurrent x) n (FeedForward y)

55− ConcatRecRight :: x -> y -> ConcatRecurrent m (FeedForward x) n (Recurrent y)

56− ConcatRecBoth :: x -> y -> ConcatRecurrent m (Recurrent x) n (Recurrent y)

57−

58−instance (Show x, Show y) => Show (ConcatRecurrent m (p x) n (q y)) where

59− show (ConcatRecLeft x y) = "ConcatRecLeft\n" ++ show x ++ "\n" ++ show y

60− show (ConcatRecRight x y) = "ConcatRecRight\n" ++ show x ++ "\n" ++ show y

61− show (ConcatRecBoth x y) = "ConcatRecBoth\n" ++ show x ++ "\n" ++ show y

62−

63−instance (RecurrentUpdateLayer x, UpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where

64− type Gradient (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = (Gradient x, Gradient y)

65− runUpdate lr (ConcatRecLeft x y) (x', y')

66− = ConcatRecLeft (runUpdate lr x x') (runUpdate lr y y')

67− createRandom

68− = ConcatRecLeft <$> createRandom <*> createRandom

69−

70−instance (UpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where

71− type Gradient (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = (Gradient x, Gradient y)

72− runUpdate lr (ConcatRecRight x y) (x', y')

73− = ConcatRecRight (runUpdate lr x x') (runUpdate lr y y')

74− createRandom

75− = ConcatRecRight <$> createRandom <*> createRandom

76−

77−instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => UpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where

78− type Gradient (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = (Gradient x, Gradient y)

79− runUpdate lr (ConcatRecBoth x y) (x', y')

80− = ConcatRecBoth (runUpdate lr x x') (runUpdate lr y y')

81− createRandom

82− = ConcatRecBoth <$> createRandom <*> createRandom

83−

84−instance (RecurrentUpdateLayer x, UpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (FeedForward y)) where

85− type RecurrentShape (ConcatRecurrent m (Recurrent x) n (FeedForward y)) = RecurrentShape x

86−

87−instance (UpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (FeedForward x) n (Recurrent y)) where

88− type RecurrentShape (ConcatRecurrent m (FeedForward x) n (Recurrent y)) = RecurrentShape y

89−

90−instance (RecurrentUpdateLayer x, RecurrentUpdateLayer y) => RecurrentUpdateLayer (ConcatRecurrent m (Recurrent x) n (Recurrent y)) where

91− type RecurrentShape (ConcatRecurrent m (Recurrent x) n (Recurrent y)) = RecurrentInputs '[ Recurrent x, Recurrent y ]

92−

93−instance ( SingI i

94− , Layer x i ('D1 m)

95− , RecurrentLayer y i ('D1 n)

96− , KnownNat o

97− , KnownNat m

98− , KnownNat n

99− , o ~ (m + n)

100− , n ~ (o - m)

101− , (m <=? o) ~ 'True

102− ) => RecurrentLayer (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) where

103− type RecTape (ConcatRecurrent ('D1 m) (FeedForward x) ('D1 n) (Recurrent y)) i ('D1 o) = (Tape x i ('D1 m), RecTape y i ('D1 n))

104−

105− runRecurrentForwards (ConcatRecRight x y) s input =

106− let (xT, xOut :: S ('D1 m)) = runForwards x input

107− (yT, side, yOut :: S ('D1 n)) = runRecurrentForwards y s input

108− in case (xOut, yOut) of

109− (S1D xOut', S1D yOut') ->

110− ((xT, yT), side, S1D (xOut' # yOut'))

111−

112− runRecurrentBackwards (ConcatRecRight x y) (xTape, yTape) s (S1D o) =

113− let (ox :: R m , oy :: R n) = split o

114− (x', xB :: S i) = runBackwards x xTape (S1D ox)

115− (y', side, yB :: S i) = runRecurrentBackwards y yTape s (S1D oy)

116− in ((x', y'), side, xB + yB)

117−

118−instance ( SingI i

119− , RecurrentLayer x i ('D1 m)

120− , Layer y i ('D1 n)

121− , KnownNat o

122− , KnownNat m

123− , KnownNat n

124− , o ~ (m + n)

125− , n ~ (o - m)

126− , (m <=? o) ~ 'True

127− ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) where

128− type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (FeedForward y)) i ('D1 o) = (RecTape x i ('D1 m), Tape y i ('D1 n))

129−

130− runRecurrentForwards (ConcatRecLeft x y) s input =

131− let (xT, side, xOut :: S ('D1 m)) = runRecurrentForwards x s input

132− (yT, yOut :: S ('D1 n)) = runForwards y input

133− in case (xOut, yOut) of

134− (S1D xOut', S1D yOut') ->

135− ((xT, yT), side, S1D (xOut' # yOut'))

136−

137− runRecurrentBackwards (ConcatRecLeft x y) (xTape, yTape) s (S1D o) =

138− let (ox :: R m , oy :: R n) = split o

139− (x', side, xB :: S i) = runRecurrentBackwards x xTape s (S1D ox)

140− (y', yB :: S i) = runBackwards y yTape (S1D oy)

141− in ((x', y'), side, xB + yB)

142−

143−instance ( SingI i

144− , RecurrentLayer x i ('D1 m)

145− , RecurrentLayer y i ('D1 n)

146− , Fractional (RecurrentShape x)

147− , Fractional (RecurrentShape y)

148− , KnownNat o

149− , KnownNat m

150− , KnownNat n

151− , o ~ (m + n)

152− , n ~ (o - m)

153− , (m <=? o) ~ 'True

154− ) => RecurrentLayer (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) where

155− type RecTape (ConcatRecurrent ('D1 m) (Recurrent x) ('D1 n) (Recurrent y)) i ('D1 o) = (RecTape x i ('D1 m), RecTape y i ('D1 n))

156−

157− runRecurrentForwards (ConcatRecBoth x y) (sx :~@+> (sy :~@+> RINil)) input =

158− let (xT, s'x, xOut :: S ('D1 m)) = runRecurrentForwards x sx input

159− (yT, s'y, yOut :: S ('D1 n)) = runRecurrentForwards y sy input

160− in case (xOut, yOut) of

161− (S1D xOut', S1D yOut') ->

162− ((xT, yT), (s'x :~@+> (s'y :~@+> RINil)), S1D (xOut' # yOut'))

163−

164− runRecurrentBackwards (ConcatRecBoth x y) (xTape, yTape) (sx :~@+> (sy :~@+> RINil)) (S1D o) =

165− let (ox :: R m , oy :: R n) = split o

166− (x', s'x, xB :: S i) = runRecurrentBackwards x xTape sx (S1D ox)

167− (y', s'y, yB :: S i) = runRecurrentBackwards y yTape sy (S1D oy)

168− in ((x', y'), (s'x :~@+> (s'y :~@+> RINil)), xB + yB)

169−

170−instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (FeedForward a) sb (Recurrent b)) where

171− put (ConcatRecRight a b) = put a *> put b

172− get = ConcatRecRight <$> get <*> get

173−

174−instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (Recurrent b)) where

175− put (ConcatRecBoth a b) = put a *> put b

176− get = ConcatRecBoth <$> get <*> get

177−

178−instance (Serialize a, Serialize b) => Serialize (ConcatRecurrent sa (Recurrent a) sb (FeedForward b)) where

179− put (ConcatRecLeft a b) = put a *> put b

180− get = ConcatRecLeft <$> get <*> get

src/Grenade/Recurrent/Layers/LSTM.hs+80−57

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE BangPatterns #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE GADTs #-}

54{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE RecordWildCards #-}

66{-# LANGUAGE TypeOperators #-}

77{-# LANGUAGE TypeFamilies #-}

88{-# LANGUAGE MultiParamTypeClasses #-}

@@ -21,7 +21,7 @@ import Control.Monad.Random ( MonadRandom, getRandom )

2121-- import Data.List ( foldl1' )

2222import Data.Proxy

2323import Data.Serialize

24−import Data.Kind (Type)

24+import Data.Singletons.TypeLits

2525

2626import qualified Numeric.LinearAlgebra as LA

2727import Numeric.LinearAlgebra.Static

@@ -29,7 +29,6 @@ import Numeric.LinearAlgebra.Static

2929import Grenade.Core

3030import Grenade.Recurrent.Core

3131import Grenade.Layers.Internal.Update

32−import GHC.TypeLits

3332

3433

3534-- | Long Short Term Memory Recurrent unit

@@ -37,14 +36,14 @@ import GHC.TypeLits

3736-- This is a Peephole formulation, so the recurrent shape is

3837-- just the cell state, the previous output is not held or used

3938-- at all.

40−data LSTM :: Nat -> Nat -> Type where

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

4140 LSTM :: ( KnownNat input

4241 , KnownNat output

4342 ) => !(LSTMWeights input output) -- Weights

4443 -> !(LSTMWeights input output) -- Momentums

4544 -> LSTM input output

4645

47−data LSTMWeights :: Nat -> Nat -> Type where

46+data LSTMWeights :: Nat -> Nat -> * where

4847 LSTMWeights :: ( KnownNat input

4948 , KnownNat output

5049 ) => {

@@ -71,7 +70,7 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

7170

7271 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

7372 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

74− runUpdate lp (LSTM w m) g =

73+ runUpdate LearningParameters {..} (LSTM w m) g =

7574 let (wf, wf') = u lstmWf w m g

7675 (uf, uf') = u lstmUf w m g

7776 (bf, bf') = v lstmBf w m g

@@ -88,11 +87,11 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

8887 -- Utility function for updating with the momentum, gradients, and weights.

8988 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

9089 u e (e -> weights) (e -> momentum) (e -> gradient) =

91− descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

90+ decendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum

9291

9392 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

9493 v e (e -> weights) (e -> momentum) (e -> gradient) =

95− descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

94+ decendVector learningRate learningMomentum learningRegulariser weights gradient momentum

9695

9796 -- There's a lot of updates here, so to try and minimise the number of data copies

9897 -- we'll create a mutable bucket for each.

@@ -124,33 +123,27 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

124123instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

125124 -- The recurrent shape is the same size as the output.

126125 -- It's actually the cell state however, as this is a peephole variety LSTM.

127− type RecurrentShape (LSTM i o) = S ('D1 o)

126+ type RecurrentShape (LSTM i o) = 'D1 o

128127

129128instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

130129

131− -- The tape stores essentially every variable we calculate,

132− -- so we don't have to run any forwards component again.

133− type RecTape (LSTM i o) ('D1 i) ('D1 o) = (R o, R i, R o, R o, R o, R o, R o, R o, R o, R o, R o)

130+ type RecTape (LSTM i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))

134131 -- Forward propagation for the LSTM layer.

135132 -- The size of the cell state is also the size of the output.

136− runRecurrentForwards (LSTM lw _) (S1D cell) (S1D input) =

133+ runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =

137134 let -- Forget state vector

138− f_s = lstmBf lw + lstmWf lw #> input + lstmUf lw #> cell

139− f_t = sigmoid f_s

135+ f_t = sigmoid $ lstmBf + lstmWf #> input + lstmUf #> cell

140136 -- Input state vector

141− i_s = lstmBi lw + lstmWi lw #> input + lstmUi lw #> cell

142− i_t = sigmoid i_s

137+ i_t = sigmoid $ lstmBi + lstmWi #> input + lstmUi #> cell

143138 -- Output state vector

144− o_s = lstmBo lw + lstmWo lw #> input + lstmUo lw #> cell

145− o_t = sigmoid o_s

139+ o_t = sigmoid $ lstmBo + lstmWo #> input + lstmUo #> cell

146140 -- Cell input state vector

147− c_s = lstmBc lw + lstmWc lw #> input

148− c_x = tanh c_s

141+ c_x = tanh $ lstmBc + lstmWc #> input

149142 -- Cell state

150143 c_t = f_t * cell + i_t * c_x

151144 -- Output (it's sometimes recommended to use tanh c_t)

152145 h_t = o_t * c_t

153− in ((cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t), S1D c_t, S1D h_t)

146+ in ((S1D cell, S1D input), S1D c_t, S1D h_t)

154147

155148 -- Run a backpropogation step for an LSTM layer.

156149 -- We're doing all the derivatives by hand here, so one should

@@ -158,8 +151,29 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

158151 --

159152 -- There's a test version using the AD library without hmatrix in the test

160153 -- suite. These should match always.

161− runRecurrentBackwards (LSTM lw _) (cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t) (S1D cellGrad) (S1D h_t') =

162− let -- Reverse Mode AD Derivitives

154+ runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (S1D cell, S1D input) (S1D cellGrad) (S1D h_t') =

155+ -- We're not keeping the Wengert tape during the forward pass,

156+ -- so we're duplicating some work here.

157+ --

158+ -- If I was being generous, I'd call it checkpointing.

159+ --

160+ -- Maybe think about better ways to store some intermediate states.

161+ let -- Forget state vector

162+ f_s = lstmBf + lstmWf #> input + lstmUf #> cell

163+ f_t = sigmoid f_s

164+ -- Input state vector

165+ i_s = lstmBi + lstmWi #> input + lstmUi #> cell

166+ i_t = sigmoid i_s

167+ -- Output state vector

168+ o_s = lstmBo + lstmWo #> input + lstmUo #> cell

169+ o_t = sigmoid o_s

170+ -- Cell input state vector

171+ c_s = lstmBc + lstmWc #> input

172+ c_x = tanh c_s

173+ -- Cell state

174+ c_t = f_t * cell + i_t * c_x

175+

176+ -- Reverse Mode AD Derivitives

163177 c_t' = h_t' * o_t + cellGrad

164178

165179 f_t' = c_t' * cell

@@ -175,8 +189,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

175189 c_s' = tanh' c_s * c_x'

176190

177191 -- The derivatives to pass sideways (recurrent) and downwards

178− cell' = tr (lstmUf lw) #> f_s' + tr (lstmUo lw) #> o_s' + tr (lstmUi lw) #> i_s' + c_t' * f_t

179− input' = tr (lstmWf lw) #> f_s' + tr (lstmWo lw) #> o_s' + tr (lstmWi lw) #> i_s' + tr (lstmWc lw) #> c_s'

192+ cell' = tr lstmUf #> f_s' + tr lstmUo #> o_s' + tr lstmUi #> i_s' + c_t' * f_t

193+ input' = tr lstmWf #> f_s' + tr lstmWo #> o_s' + tr lstmWi #> i_s' + tr lstmWc #> c_s'

180194

181195 -- Calculate the gradient Matricies for the input

182196 lstmWf' = f_s' `outer` input

@@ -221,8 +235,7 @@ randomLSTM = do

221235

222236-- | Maths

223237--

224−-- TODO: Move to not here

225−-- Optimise backwards derivative

238+-- TODO: move to not here

226239sigmoid :: Floating a => a -> a

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

228241

@@ -235,34 +248,44 @@ tanh' :: (Floating a) => a -> a

235248tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

236249

237250instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

238− put (LSTM lw _) = do

239− u (lstmWf lw)

240− u (lstmUf lw)

241− v (lstmBf lw)

242− u (lstmWi lw)

243− u (lstmUi lw)

244− v (lstmBi lw)

245− u (lstmWo lw)

246− u (lstmUo lw)

247− v (lstmBo lw)

248− u (lstmWc lw)

249− v (lstmBc lw)

250− where

251− u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

252− u = putListOf put . LA.toList . LA.flatten . extract

253− v :: forall a. (KnownNat a) => Putter (R a)

254− v = putListOf put . LA.toList . extract

251+ put (LSTM LSTMWeights {..} _) = do

252+ u lstmWf

253+ u lstmUf

254+ v lstmBf

255+ u lstmWi

256+ u lstmUi

257+ v lstmBi

258+ u lstmWo

259+ u lstmUo

260+ v lstmBo

261+ u lstmWc

262+ v lstmBc

263+ where

264+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

265+ u = putListOf put . LA.toList . LA.flatten . extract

266+ v :: forall a. (KnownNat a) => Putter (R a)

267+ v = putListOf put . LA.toList . extract

255268

256269 get = do

257− w <- LSTMWeights <$> u <*> u <*> v <*> u <*> u <*> v <*> u <*> u <*> v <*> u <*> v

258− return $ LSTM w (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

259− where

260− u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

261− u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

262− in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

263− v :: forall a. (KnownNat a) => Get (R a)

264− v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

265−

266− w0 = konst 0

267− u0 = konst 0

268− v0 = konst 0

270+ lstmWf <- u

271+ lstmUf <- u

272+ lstmBf <- v

273+ lstmWi <- u

274+ lstmUi <- u

275+ lstmBi <- v

276+ lstmWo <- u

277+ lstmUo <- u

278+ lstmBo <- v

279+ lstmWc <- u

280+ lstmBc <- v

281+ return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

282+ where

283+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

284+ u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

285+ in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

286+ v :: forall a. (KnownNat a) => Get (R a)

287+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

288+

289+ w0 = konst 0

290+ u0 = konst 0

291+ v0 = konst 0

src/Grenade/Utils/OneHot.hs+5−6

@@ -22,6 +22,7 @@ import Data.Map ( Map )

2222import qualified Data.Map as M

2323

2424import Data.Proxy

25+import Data.Singletons.TypeLits

2526

2627import Data.Vector ( Vector )

2728import qualified Data.Vector as V

@@ -30,7 +31,6 @@ import qualified Data.Vector.Storable as VS

3031import Numeric.LinearAlgebra ( maxIndex )

3132import Numeric.LinearAlgebra.Devel

3233import Numeric.LinearAlgebra.Static

33−import GHC.TypeLits

3434

3535import Grenade.Core.Shape

3636

@@ -52,16 +52,15 @@ oneHot hot =

5252

5353-- | Create a one hot map from any enumerable.

5454-- Returns a map, and the ordered list for the reverse transformation

55−hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Either String (Map a Int, Vector a)

55+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Maybe (Map a Int, Vector a)

5656hotMap n as =

5757 let len = fromIntegral $ natVal n

5858 uniq = [ c | (c:_) <- group $ sort as]

5959 hotl = length uniq

60− in if hotl == len

60+ in if hotl <= len

6161 then

62− Right (M.fromList $ zip uniq [0..], V.fromList uniq)

63− else

64− Left ("Couldn't create hotMap of size " ++ show len ++ " from vector with " ++ show hotl ++ " unique characters")

62+ Just (M.fromList $ zip uniq [0..], V.fromList uniq)

63+ else Nothing

6564

6665-- | From a map and value, create a 1D Shape

6766-- with one index hot (1) with the rest 0.

stack.yamldeleted−78

@@ -1,78 +0,0 @@

1−# This file was automatically generated by 'stack init'

2−#

3−# Some commonly used options have been documented as comments in this file.

4−# For advanced use and comprehensive documentation of the format, please see:

5−# https://docs.haskellstack.org/en/stable/yaml_configuration/

6−

7−# A warning or info to be displayed to the user on config load.

8−# user-message: |

9−

10−# Resolver to choose a 'specific' stackage snapshot or a compiler version.

11−# A snapshot resolver dictates the compiler version and the set of packages

12−# to be used for project dependencies. For example:

13−#

14−# resolver: lts-3.5

15−# resolver: nightly-2015-09-21

16−# resolver: ghc-7.10.2

17−#

18−# The location of a snapshot can be provided as a file or url. Stack assumes

19−# a snapshot provided as a file might change, whereas a url resource does not.

20−#

21−# resolver: ./custom-snapshot.yaml

22−# resolver: https://example.com/snapshots/2018-01-01.yaml

23−resolver: lts-20.18

24−

25−# User packages to be built.

26−# Various formats can be used as shown in the example below.

27−#

28−# packages:

29−# - some-directory

30−# - https://example.com/foo/bar/baz-0.0.2.tar.gz

31−# subdirs:

32−# - auto-update

33−# - wai

34−packages:

35− - .

36− - examples

37−

38−# Dependency packages to be pulled from upstream that are not in the resolver.

39−# These entries can reference officially published versions as well as

40−# forks / in-progress versions pinned to a git hash. For example:

41−#

42−# extra-deps:

43−# - acme-missiles-0.3

44−# - git: https://github.com/commercialhaskell/stack.git

45−# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

46−#

47−extra-deps:

48− - typelits-witnesses-0.3.0.3

49−

50−# Override default flag values for local packages and extra-deps

51−# flags: {}

52−

53−# Extra package databases containing global packages

54−# extra-package-dbs: []

55−

56−# Control whether we use the GHC we find on the path

57−# system-ghc: true

58−#

59−# Require a specific version of stack, using version ranges

60−# require-stack-version: -any # Default

61−# require-stack-version: ">=2.1"

62−#

63−# Override the architecture used by stack, especially useful on Windows

64−# arch: i386

65−# arch: x86_64

66−#

67−# Extra directories used by stack for building

68−# extra-include-dirs: [/path/to/dir]

69−# extra-lib-dirs: [/path/to/dir]

70−#

71−# Allow a newer minor version of GHC than the snapshot specifies

72−# compiler-check: newer-minor

73−

74−nix:

75− enable: true

76− packages:

77− - blas

78− - lapack

stack.yaml.lockdeleted−19

@@ -1,19 +0,0 @@

1−# This file was autogenerated by Stack.

2−# You should not edit this file by hand.

3−# For more information, please see the documentation at:

4−# https://docs.haskellstack.org/en/stable/lock_files

5−

6−packages:

7−- completed:

8− hackage: typelits-witnesses-0.3.0.3@sha256:2d9df4ac6ff3077bfd2bf659e4b495e157723ac5b45c519762853f55df5c16db,2738

9− pantry-tree:

10− sha256: 6a42a462f98e94933b6e9721acd912c6c6b6a4743635efd15cc5871908c816a0

11− size: 469

12− original:

13− hackage: typelits-witnesses-0.3.0.3

14−snapshots:

15−- completed:

16− sha256: 9fa4bece7acfac1fc7930c5d6e24606004b09e80aa0e52e9f68b148201008db9

17− size: 649606

18− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/18.yaml

19− original: lts-20.18

test/Test/Grenade/Layers/Convolution.hs+6−10

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE TemplateHaskell #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE GADTs #-}

@@ -16,10 +15,6 @@ import Data.Singletons ()

1615import GHC.TypeLits

1716import GHC.TypeLits.Witnesses

1817

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

20−import Data.Kind (Type)

21−#endif

22−

2318import Grenade.Core

2419import Grenade.Layers.Convolution

2520

@@ -30,7 +25,7 @@ import Test.Hedgehog.Hmatrix

3025import Test.Hedgehog.TypeLits

3126import Test.Hedgehog.Compat

3227

33−data OpaqueConvolution :: Type where

28+data OpaqueConvolution :: * where

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

3530

3631instance Show OpaqueConvolution where

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

4439 , KnownNat strideColumns

4540 , KnownNat kernelFlattened

4641 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

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

42+ , Monad m

43+ ) => Gen.Gen m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

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

4945

50−genOpaqueOpaqueConvolution :: Gen OpaqueConvolution

46+genOpaqueOpaqueConvolution :: Monad m => Gen m OpaqueConvolution

5147genOpaqueOpaqueConvolution = do

5248 channels <- genNat

5349 filters <- genNat

@@ -63,7 +59,7 @@ genOpaqueOpaqueConvolution = do

6359 p2 = natDict pkc

6460 p3 = natDict pch

6561 in case p1 %* p2 %* p3 of

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

62+ Dict -> OpaqueConvolution <$> (genConvolution :: Monad n => Gen n (Convolution ch fl kr kc sr sc))

6763

6864prop_conv_net_witness = property $

6965 blindForAll genOpaqueOpaqueConvolution >>= \onet ->

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

105101

106102

107103tests :: IO Bool

108−tests = checkParallel $$(discover)

104+tests = $$(checkConcurrent)

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE BangPatterns #-}

32{-# LANGUAGE TemplateHaskell #-}

43{-# LANGUAGE DataKinds #-}

@@ -13,10 +12,6 @@ import Data.Singletons ()

1312

1413import GHC.TypeLits

1514

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

17−import Data.Kind (Type)

18−#endif

19−

2015import Grenade.Core

2116import Grenade.Layers.FullyConnected

2217

@@ -25,13 +20,13 @@ import Hedgehog

2520import Test.Hedgehog.Compat

2621import Test.Hedgehog.Hmatrix

2722

28−data OpaqueFullyConnected :: Type where

23+data OpaqueFullyConnected :: * where

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

3025

3126instance Show OpaqueFullyConnected where

3227 show (OpaqueFullyConnected n) = show n

3328

34−genOpaqueFullyConnected :: Gen OpaqueFullyConnected

29+genOpaqueFullyConnected :: Monad m => Gen m OpaqueFullyConnected

3530genOpaqueFullyConnected = do

3631 input :: Integer <- choose 2 100

3732 output :: Integer <- choose 1 100

@@ -55,4 +50,4 @@ prop_fully_connected_forwards = property $ do

5550 backed `seq` success

5651

5752tests :: IO Bool

58−tests = checkParallel $$(discover)

53+tests = $$(checkConcurrent)

test/Test/Grenade/Layers/Internal/Convolution.hs+2−1

@@ -53,5 +53,6 @@ prop_im2col_col2im_behaves_as_reference =

5353 outFast === outReference

5454 retFast === retReference

5555

56+return []

5657tests :: IO Bool

57−tests = checkParallel $$(discover)

58+tests = $$(checkConcurrent)

test/Test/Grenade/Layers/Internal/Pooling.hs+1−1

@@ -42,4 +42,4 @@ prop_poolForwards_poolBackwards_behaves_as_reference =

4242

4343

4444tests :: IO Bool

45−tests = checkParallel $$(discover)

45+tests = $$(checkConcurrent)

test/Test/Grenade/Layers/Nonlinear.hs+4−3

@@ -22,7 +22,7 @@ import Numeric.LinearAlgebra.Static ( norm_Inf )

2222

2323prop_sigmoid_grad :: Property

2424prop_sigmoid_grad = property $

25− forAllWith rss genShape >>= \case

25+ blindForAll genShape >>= \case

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

2727 withSingI r $

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

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

3737

3838prop_tanh_grad :: Property

3939prop_tanh_grad = property $

40− forAllWith rss genShape >>= \case

40+ blindForAll genShape >>= \case

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

4242 withSingI r $

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

@@ -51,4 +51,5 @@ prop_tanh_grad = property $

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

5252

5353tests :: IO Bool

54−tests = checkParallel $$(discover)

54+tests = $$(checkConcurrent)

55+

test/Test/Grenade/Layers/PadCrop.hs+5−1

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

77{-# LANGUAGE ScopedTypeVariables #-}

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

99

10+#if __GLASGOW_HASKELL__ < 800

11+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

12+#endif

13+

1014module Test.Grenade.Layers.PadCrop where

1115

1216import Grenade

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

4650

4751

4852tests :: IO Bool

49−tests = checkParallel $$(discover)

53+tests = $$(checkConcurrent)

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

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE TemplateHaskell #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE KindSignatures #-}

@@ -10,29 +9,26 @@ module Test.Grenade.Layers.Pooling where

109import Data.Proxy

1110import Data.Singletons ()

1211

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

14−import Data.Kind (Type)

15−#endif

16−

1712import GHC.TypeLits

1813import Grenade.Layers.Pooling

1914

2015import Hedgehog

16+import qualified Hedgehog.Gen as Gen

2117

2218import Test.Hedgehog.Compat

2319

24−data OpaquePooling :: Type where

20+data OpaquePooling :: * where

2521 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

2622

2723instance Show OpaquePooling where

2824 show (OpaquePooling n) = show n

2925

30−genOpaquePooling :: Gen OpaquePooling

26+genOpaquePooling :: Monad m => Gen.Gen m OpaquePooling

3127genOpaquePooling = do

32− ~(Just kernelHeight) <- someNatVal <$> choose 2 15

33− ~(Just kernelWidth ) <- someNatVal <$> choose 2 15

34− ~(Just strideHeight) <- someNatVal <$> choose 2 15

35− ~(Just strideWidth ) <- someNatVal <$> choose 2 15

28+ Just kernelHeight <- someNatVal <$> choose 2 15

29+ Just kernelWidth <- someNatVal <$> choose 2 15

30+ Just strideHeight <- someNatVal <$> choose 2 15

31+ Just strideWidth <- someNatVal <$> choose 2 15

3632

3733 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

3834 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

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

4642 assert True

4743

4844tests :: IO Bool

49−tests = checkParallel $$(discover)

45+tests = $$(checkConcurrent)

test/Test/Grenade/Network.hs+29−227

@@ -14,12 +14,17 @@ import Control.Monad ( guard )

1414import Control.Monad.ST ( runST )

1515

1616import Data.Constraint

17+#if __GLASGOW_HASKELL__ < 800

18+import Data.Proxy

19+#endif

1720import qualified Data.Vector.Storable as VS

1821import qualified Data.Vector.Storable.Mutable as VS ( write )

1922import Data.Singletons

2023import Data.Singletons.Prelude.List

2124import Data.Singletons.TypeLits

2225

26+-- import Data.Type.Equality

27+

2328import Hedgehog

2429import qualified Hedgehog.Gen as Gen

2530import Hedgehog.Internal.Source

@@ -27,15 +32,7 @@ import Hedgehog.Internal.Property ( failWith )

2732

2833import Grenade

2934

30−#if MIN_VERSION_base(4,11,0)

31−import GHC.TypeLits hiding (natVal)

32−#else

3335import GHC.TypeLits

34−#endif

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

36−import Data.Kind (Type)

37−#endif

38−

3936import GHC.TypeLits.Witnesses

4037import Test.Hedgehog.Compat

4138import Test.Hedgehog.TypeLits

@@ -46,7 +43,7 @@ import Numeric.LinearAlgebra ( flatten )

4643import Numeric.LinearAlgebra.Static ( extract, norm_Inf )

4744import Unsafe.Coerce

4845

49−data SomeNetwork :: Type where

46+data SomeNetwork :: * where

5047 SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork

5148

5249instance Show SomeNetwork where

@@ -56,7 +53,7 @@ instance Show SomeNetwork where

5653--

5754-- This is slightly insane for a few reasons. Everything must be wrapped up

5855-- in a SomeNetwork.

59−genNetwork :: Gen SomeNetwork

56+genNetwork :: Monad m => Gen.Gen m SomeNetwork

6057genNetwork =

6158 Gen.recursive Gen.choice [

6259 do SomeSing ( r :: Sing final ) <- genShape

@@ -65,7 +62,7 @@ genNetwork =

6562 ] [

6663 do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork

6764 case ( sing :: Sing shapes ) of

68− SNil -> Gen.discard -- Can't occur

65+ SNil -> Gen.discard

6966 SCons ( h :: Sing h ) ( _ :: Sing hs ) ->

7067 withSingI h $

7168 case h of

@@ -77,9 +74,8 @@ genNetwork =

7774 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

7875 , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))

7976 , do -- Reshape to two dimensions

80− let divisors :: Integer -> [Integer]

81− divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]

82− let len = fromIntegral $ natVal l

77+ let divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]

78+ let len = natVal l

8379 rs <- Gen.element $ divisors len

8480 let cs = len `quot` rs

8581 case ( someNatVal rs, someNatVal cs, someNatVal len ) of

@@ -100,8 +96,8 @@ genNetwork =

10096 , do -- Build a convolution layer with one filter output

10197 -- Figure out some kernel sizes which work for this layer

10298 -- There must be a better way than this...

103− let output_r = fromIntegral $ natVal r

104− let output_c = fromIntegral $ natVal c

99+ let output_r = natVal r

100+ let output_c = natVal c

105101

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

107103

@@ -140,8 +136,8 @@ genNetwork =

140136 , do -- Build a convolution layer with one filter output

141137 -- Figure out some kernel sizes which work for this layer

142138 -- There must be a better way than this...

143− let output_r = fromIntegral $ natVal r

144− let output_c = fromIntegral $ natVal c

139+ let output_r = natVal r

140+ let output_c = natVal c

145141

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

147143

@@ -182,8 +178,8 @@ genNetwork =

182178 pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

183179 _ -> Gen.discard -- Can't occur

184180 , do -- Build a Pooling layer

185− let output_r = fromIntegral $ natVal r

186− let output_c = fromIntegral $ natVal c

181+ let output_r = natVal r

182+ let output_c = natVal c

187183

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

189185

@@ -218,219 +214,25 @@ genNetwork =

218214 (Dict, Dict, Dict, Dict) ->

219215 pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

220216 _ -> 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

272217 ]

273− D3Sing r@SNat c@SNat f@SNat ->

218+ D3Sing SNat SNat SNat ->

274219 Gen.choice [

275220 pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

276221 , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

277222 , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

278223 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

279− , do -- Build a convolution layer with one filter output

280− -- Figure out some kernel sizes which work for this layer

281− -- There must be a better way than this...

282− let output_r = fromIntegral $ natVal r

283− let output_c = fromIntegral $ natVal c

284− let output_f = fromIntegral $ natVal f

285−

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

287−

288− -- Get some kernels which will fit

289− kernel_r <- choose 1 output_r

290− kernel_c <- choose 1 output_c

291− channels <- choose 1 10

292−

293− -- Build up some strides which also fit

294− stride_r <- Gen.element $ ok output_r kernel_r

295− stride_c <- Gen.element $ ok output_c kernel_c

296−

297− -- Determine the input size

298− let input_r = (output_r - 1) * stride_r + kernel_r

299− let input_c = (output_c - 1) * stride_c + kernel_c

300−

301− guard (input_r < 100)

302− guard (input_c < 100)

303−

304− -- Remake types for input

305− case ( someNatVal channels, someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

306− ( Just (SomeNat (chan :: Proxy channels)), Just (SomeNat (_ :: Proxy filters)),

307− Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

308− Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

309− Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

310− Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

311− let p1 = natDict pkr

312− p2 = natDict pkc

313− p3 = natDict chan

314− in case ( p1 %* p2 %* p3

315− , natDict pinr %* natDict chan

316− -- Fake it till you make it.

317− , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outRows outCols filters) ~ h ))

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

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

320− (Dict, Dict, Dict, Dict, Dict) -> do

321− conv <- genConvolution

322− pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels filters kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

323− _ -> Gen.discard -- Can't occur

324− , do -- Build a Pooling layer

325− let output_r = fromIntegral $ natVal r

326− let output_c = fromIntegral $ natVal c

327− let output_f = fromIntegral $ natVal f

328−

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

330−

331− -- Get some kernels which will fit

332− kernel_r <- choose 1 output_r

333− kernel_c <- choose 1 output_c

334−

335− -- Build up some strides which also fit

336− stride_r <- Gen.element $ ok output_r kernel_r

337− stride_c <- Gen.element $ ok output_c kernel_c

338−

339− -- Determine the input size

340− let input_r = (output_r - 1) * stride_r + kernel_r

341− let input_c = (output_c - 1) * stride_c + kernel_c

342−

343− guard (input_r < 100)

344− guard (input_c < 100)

345−

346− -- Remake types for input

347− case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of

348− ( Just (SomeNat (chan :: Proxy filters)),

349− Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

350− Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

351− Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

352− Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

353− let p1 = natDict pkr

354− p2 = natDict pkc

355− p3 = natDict chan

356− in case ( p1 %* p2 %* p3

357− , natDict pinr %* natDict chan

358− -- Fake it till you make it.

359− , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outRows outCols filters) ~ h ))

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

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

362− (Dict, Dict, Dict, Dict, Dict) ->

363− pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols filters) ': h ': hs )))

364− _ -> Gen.discard -- Can't occur

365− , do -- Build a Pad layer

366− let output_r = fromIntegral $ natVal r

367− let output_c = fromIntegral $ natVal c

368− let output_f = fromIntegral $ natVal f

369−

370− pad_left <- choose 0 (output_r - 1)

371− pad_right <- choose 0 (output_r - 1 - pad_left)

372− pad_top <- choose 0 (output_c - 1)

373− pad_bottom <- choose 0 (output_c - 1 - pad_top)

374−

375− let input_r = output_r - pad_top - pad_bottom

376− let input_c = output_c - pad_left - pad_right

377−

378− guard (input_r > 1)

379− guard (input_c > 1)

380−

381− -- Remake types for input

382− case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal pad_left, someNatVal pad_right, someNatVal pad_top, someNatVal pad_bottom ) of

383− ( Just (SomeNat (chan :: Proxy filters)),

384− Just (SomeNat (pinr :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

385− Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

386− Just (SomeNat (_ :: Proxy padLeft)), Just (SomeNat (_ :: Proxy padRight)),

387− Just (SomeNat (_ :: Proxy padTop)), Just (SomeNat (_ :: Proxy padBottom))) ->

388− case ( natDict pinr %* natDict chan

389− , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outputRows outputColumns filters) ~ h ))

390− , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputRows + padTop + padBottom) ~ outputRows) )

391− , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (inputColumns + padLeft + padRight) ~ outputColumns ))) of

392− (Dict, Dict, Dict, Dict) ->

393− pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))

394− _ -> Gen.discard -- Can't occur

395− , do -- Build a Crop layer

396− let output_r = fromIntegral $ natVal r

397− let output_c = fromIntegral $ natVal c

398− let output_f = fromIntegral $ natVal f

399−

400− crop_left <- choose 0 10

401− crop_right <- choose 0 10

402− crop_top <- choose 0 10

403− crop_bottom <- choose 0 10

404−

405− let input_r = output_r + crop_top + crop_bottom

406− let input_c = output_c + crop_left + crop_right

407−

408− -- Remake types for input

409− case ( someNatVal output_f, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal crop_left, someNatVal crop_right, someNatVal crop_top, someNatVal crop_bottom ) of

410− ( Just (SomeNat (chan :: Proxy filters)),

411− Just (SomeNat (pinr :: Proxy inputRows)), Just (SomeNat (_ :: Proxy inputColumns)),

412− Just (SomeNat (_ :: Proxy outputRows)), Just (SomeNat (_ :: Proxy outputColumns)),

413− Just (SomeNat (_ :: Proxy cropLeft)), Just (SomeNat (_ :: Proxy cropRight)),

414− Just (SomeNat (_ :: Proxy cropTop)), Just (SomeNat (_ :: Proxy cropBottom))) ->

415− case ( natDict pinr %* natDict chan

416− , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D3 outputRows outputColumns filters) ~ h ))

417− , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputRows + cropTop + cropBottom) ~ inputRows ) )

418− , (unsafeCoerce (Dict :: Dict ()) :: Dict ( (outputColumns + cropLeft + cropRight) ~ inputColumns ))) of

419− (Dict, Dict, Dict, Dict) ->

420− pure (SomeNetwork (Crop :~> rest :: Network ( Crop cropLeft cropTop cropRight cropBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))

421− _ -> Gen.discard -- Can't occur

422− ]

224+ ]

423225 ]

424226

425227-- | Test a partial derivative numerically for a random network and input

426228--

427229-- This is the most important test.

428230prop_auto_diff :: Property

429−prop_auto_diff = withDiscards 1000 . withTests 10000 . property $ do

231+prop_auto_diff = withTests 10000 . property $ do

430232 SomeNetwork (network :: Network layers shapes) <- forAll genNetwork

431− (input :: S (Head shapes)) <- forAllWith nice genOfShape

432− (target :: S (Last shapes)) <- forAllWith nice oneUp

433− (tested :: S (Head shapes)) <- forAllWith nice oneUp

233+ (input :: S (Head shapes)) <- forAllRender nice genOfShape

234+ (target :: S (Last shapes)) <- forAllRender nice oneUp

235+ (tested :: S (Head shapes)) <- forAllRender nice oneUp

434236

435237 let (!tapes, !output) = runNetwork network input

436238 let (_, !backgrad) = runGradient network tapes target

@@ -442,13 +244,13 @@ prop_auto_diff = withDiscards 1000 . withTests 10000 . property $ do

442244 result ~~~ expected

443245

444246-- Make a shape where all are 0 except for 1 value, which is 1.

445−oneUp :: forall shape. ( SingI shape ) => Gen (S shape)

247+oneUp :: forall shape m. ( Monad m, SingI shape ) => Gen.Gen m (S shape)

446248oneUp =

447249 case ( sing :: Sing shape ) of

448250 D1Sing SNat ->

449251 let x = 0 :: S ( shape )

450252 in case x of

451− ( S1D x' ) -> do

253+ ( S1D x' ) -> do

452254 let ex = extract x'

453255 let len = VS.length ex

454256 ix <- choose 0 (len - 1)

@@ -460,7 +262,7 @@ oneUp =

460262 D2Sing SNat SNat ->

461263 let x = 0 :: S ( shape )

462264 in case x of

463− ( S2D x' ) -> do

265+ ( S2D x' ) -> do

464266 let ex = flatten ( extract x' )

465267 let len = VS.length ex

466268 ix <- choose 0 (len - 1)

@@ -472,7 +274,7 @@ oneUp =

472274 D3Sing SNat SNat SNat ->

473275 let x = 0 :: S ( shape )

474276 in case x of

475− ( S3D x' ) -> do

277+ ( S3D x' ) -> do

476278 let ex = flatten ( extract x' )

477279 let len = VS.length ex

478280 ix <- choose 0 (len - 1)

@@ -486,9 +288,9 @@ maxVal ( S1D x ) = norm_Inf x

486288maxVal ( S2D x ) = norm_Inf x

487289maxVal ( S3D x ) = norm_Inf x

488290

489−(~~~) :: (Monad m, HasCallStack) => Double -> Double -> PropertyT m ()

291+(~~~) :: (Monad m, HasCallStack) => Double -> Double -> Test m ()

490292(~~~) x y =

491− if abs (x - y) < 2e-5 then

293+ if abs (x - y) < 1e-5 then

492294 success

493295 else

494296 withFrozenCallStack $

@@ -501,4 +303,4 @@ infix 4 ~~~

501303

502304

503305tests :: IO Bool

504−tests = checkParallel $$(discover)

306+tests = $$(checkConcurrent)

test/Test/Grenade/Recurrent/Layers/LSTM.hs+9−14

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

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

1212

1313import Hedgehog

14+import qualified Hedgehog.Gen as Gen

1415import Hedgehog.Internal.Source

1516import Hedgehog.Internal.Show

1617import Hedgehog.Internal.Property ( failWith, Diff (..) )

@@ -28,7 +29,7 @@ import qualified Numeric.LinearAlgebra.Static as S

2829import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

2930import Test.Hedgehog.Hmatrix

3031

31−genLSTM :: forall i o. (KnownNat i, KnownNat o) => Gen (LSTM i o)

32+genLSTM :: forall i o m. (KnownNat i, KnownNat o, Monad m) => Gen.Gen m (LSTM i o)

3233genLSTM = do

3334 let w = uniformSample

3435 u = uniformSample

@@ -65,9 +66,7 @@ prop_lstm_reference_backwards =

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

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

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

68− let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

69− = runRecurrentForwards net (S1D cell) (S1D input)

70− actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

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

7170 case actualBacks of

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

7372 let refNet = Reference.lstmToReference lstmWeights

@@ -81,9 +80,7 @@ prop_lstm_reference_backwards_input =

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

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

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

84− let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

85− = runRecurrentForwards net (S1D cell) (S1D input)

86− actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

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

8784 case actualBacks of

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

8986 let refNet = Reference.lstmToReference lstmWeights

@@ -97,9 +94,7 @@ prop_lstm_reference_backwards_cell =

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

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

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

100− let (tape, _ :: S ('D1 2), _ :: S ('D1 2))

101− = runRecurrentForwards net (S1D cell) (S1D input)

102− actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))

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

10398 case actualBacks of

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

105100 let refNet = Reference.lstmToReference lstmWeights

@@ -108,7 +103,7 @@ prop_lstm_reference_backwards_cell =

108103 refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

109104 in toList refGradients ~~~ H.toList (S.extract actualGradients)

110105

111−(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> PropertyT m ()

106+(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> Test m ()

112107(~~~) x y =

113108 if all (< 1e-8) (zipWith (-) x y) then

114109 success

@@ -121,10 +116,10 @@ prop_lstm_reference_backwards_cell =

121116 , showPretty x

122117 , showPretty y

123118 ]

124− Just differ ->

119+ Just diff ->

125120 withFrozenCallStack $

126− failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" differ) ""

121+ failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" diff) ""

127122infix 4 ~~~

128123

129124tests :: IO Bool

130−tests = checkParallel $$(discover)

125+tests = $$(checkConcurrent)

test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+21−25

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

66{-# LANGUAGE DeriveFunctor #-}

77{-# LANGUAGE DeriveFoldable #-}

88{-# LANGUAGE DeriveTraversable #-}

9+{-# LANGUAGE RecordWildCards #-}

910{-# LANGUAGE FlexibleContexts #-}

1011{-# LANGUAGE RankNTypes #-}

1112

@@ -14,13 +15,9 @@ module Test.Grenade.Recurrent.Layers.LSTM.Reference where

1415

1516import Data.Reflection

1617import Numeric.AD.Mode.Reverse

17−import Numeric.AD.Internal.Reverse (Tape)

18+import Numeric.AD.Internal.Reverse ( Tape )

1819

19−import GHC.TypeLits (KnownNat)

20−

21−import Grenade.Recurrent.Layers.LSTM (LSTMWeights (..))

2220import qualified Grenade.Recurrent.Layers.LSTM as LSTM

23−

2421import qualified Numeric.LinearAlgebra.Static as S

2522import qualified Numeric.LinearAlgebra as H

2623

@@ -57,32 +54,31 @@ data RefLSTM a = RefLSTM

5754 , refLstmBc :: Vector a -- Bias Cell (b_c)

5855 } deriving (Functor, Foldable, Traversable, Eq, Show)

5956

60−lstmToReference :: (KnownNat a, KnownNat b) => LSTM.LSTMWeights a b -> RefLSTM Double

61−lstmToReference lw =

62− RefLSTM

63− { refLstmWf = Matrix . H.toLists . S.extract $ lstmWf lw -- Weight Forget (W_f)

64− , refLstmUf = Matrix . H.toLists . S.extract $ lstmUf lw -- Cell State Forget (U_f)

65− , refLstmBf = Vector . H.toList . S.extract $ lstmBf lw -- Bias Forget (b_f)

66− , refLstmWi = Matrix . H.toLists . S.extract $ lstmWi lw -- Weight Input (W_i)

67− , refLstmUi = Matrix . H.toLists . S.extract $ lstmUi lw -- Cell State Input (U_i)

68− , refLstmBi = Vector . H.toList . S.extract $ lstmBi lw -- Bias Input (b_i)

69− , refLstmWo = Matrix . H.toLists . S.extract $ lstmWo lw -- Weight Output (W_o)

70− , refLstmUo = Matrix . H.toLists . S.extract $ lstmUo lw -- Cell State Output (U_o)

71− , refLstmBo = Vector . H.toList . S.extract $ lstmBo lw -- Bias Output (b_o)

72− , refLstmWc = Matrix . H.toLists . S.extract $ lstmWc lw -- Weight Cell (W_c)

73− , refLstmBc = Vector . H.toList . S.extract $ lstmBc lw -- Bias Cell (b_c)

74− }

57+lstmToReference :: LSTM.LSTMWeights a b -> RefLSTM Double

58+lstmToReference LSTM.LSTMWeights {..} =

59+ let refLstmWf = Matrix . H.toLists . S.extract $ lstmWf -- Weight Forget (W_f)

60+ refLstmUf = Matrix . H.toLists . S.extract $ lstmUf -- Cell State Forget (U_f)

61+ refLstmBf = Vector . H.toList . S.extract $ lstmBf -- Bias Forget (b_f)

62+ refLstmWi = Matrix . H.toLists . S.extract $ lstmWi -- Weight Input (W_i)

63+ refLstmUi = Matrix . H.toLists . S.extract $ lstmUi -- Cell State Input (U_i)

64+ refLstmBi = Vector . H.toList . S.extract $ lstmBi -- Bias Input (b_i)

65+ refLstmWo = Matrix . H.toLists . S.extract $ lstmWo -- Weight Output (W_o)

66+ refLstmUo = Matrix . H.toLists . S.extract $ lstmUo -- Cell State Output (U_o)

67+ refLstmBo = Vector . H.toList . S.extract $ lstmBo -- Bias Output (b_o)

68+ refLstmWc = Matrix . H.toLists . S.extract $ lstmWc -- Weight Cell (W_c)

69+ refLstmBc = Vector . H.toList . S.extract $ lstmBc -- Bias Cell (b_c)

70+ in RefLSTM {..}

7571

7672runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

77−runLSTM rl cell input =

73+runLSTM RefLSTM {..} cell input =

7874 let -- Forget state vector

79− f_t = sigmoid $ refLstmBf rl #+ refLstmWf rl #> input #+ refLstmUf rl #> cell

75+ f_t = sigmoid $ refLstmBf #+ refLstmWf #> input #+ refLstmUf #> cell

8076 -- Input state vector

81− i_t = sigmoid $ refLstmBi rl #+ refLstmWi rl #> input #+ refLstmUi rl #> cell

77+ i_t = sigmoid $ refLstmBi #+ refLstmWi #> input #+ refLstmUi #> cell

8278 -- Output state vector

83− o_t = sigmoid $ refLstmBo rl #+ refLstmWo rl #> input #+ refLstmUo rl #> cell

79+ o_t = sigmoid $ refLstmBo #+ refLstmWo #> input #+ refLstmUo #> cell

8480 -- Cell input state vector

85− c_x = fmap tanh $ refLstmBc rl #+ refLstmWc rl #> input

81+ c_x = fmap tanh $ refLstmBc #+ refLstmWc #> input

8682 -- Cell state

8783 c_t = f_t #* cell #+ i_t #* c_x

8884 -- Output (it's sometimes recommended to use tanh c_t)

test/Test/Hedgehog/Compat.hs+23−4

@@ -3,19 +3,38 @@ module Test.Hedgehog.Compat (

33 (...)

44 , choose

55 , blindForAll

6+ , semiBlindForAll

7+ , forAllRender

68 )where

79

8−import Hedgehog (Gen)

10+import Control.Monad.Trans.Class (MonadTrans(..))

11+

12+import Data.Typeable ( typeOf )

13+

914import qualified Hedgehog.Gen as Gen

1015import qualified Hedgehog.Range as Range

1116import Hedgehog.Internal.Property

17+import Hedgehog.Internal.Source

18+import Hedgehog.Internal.Show

1219

1320(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

1421(...) = (.) . (.)

1522{-# INLINE (...) #-}

1623

17−choose :: Integral a => a -> a -> Gen a

24+choose :: ( Monad m, Integral a ) => a -> a -> Gen.Gen m a

1825choose = Gen.integral ... Range.constant

1926

20−blindForAll :: Monad m => Gen a -> PropertyT m a

21−blindForAll = forAllWith (const "blind")

27+blindForAll :: Monad m => Gen.Gen m a -> Test m a

28+blindForAll = Test . lift . lift

29+

30+semiBlindForAll :: (Monad m, Show a, HasCallStack) => Gen.Gen m a -> Test m a

31+semiBlindForAll gen = do

32+ x <- Test . lift $ lift gen

33+ writeLog $ Input (getCaller callStack) (typeOf ()) (showPretty x)

34+ return x

35+

36+forAllRender :: (Monad m, HasCallStack) => ( a -> String ) -> Gen.Gen m a -> Test m a

37+forAllRender render gen = do

38+ x <- Test . lift $ lift gen

39+ writeLog $ Input (getCaller callStack) (typeOf ()) (render x)

40+ return x

test/Test/Hedgehog/Hmatrix.hs+5−7

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE KindSignatures #-}

3−{-# LANGUAGE GADTs #-}

41{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE DataKinds #-}

53{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE GADTs #-}

65

76module Test.Hedgehog.Hmatrix where

87

@@ -10,20 +9,19 @@ import Grenade

109import Data.Singletons

1110import Data.Singletons.TypeLits

1211

13−import Hedgehog (Gen)

1412import qualified Hedgehog.Gen as Gen

1513import qualified Hedgehog.Range as Range

1614

1715import qualified Numeric.LinearAlgebra.Static as HStatic

1816

19−randomVector :: forall n. ( KnownNat n ) => Gen (HStatic.R n)

17+randomVector :: forall m n. ( Monad m, KnownNat n ) => Gen.Gen m (HStatic.R n)

2018randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded

2119

22−uniformSample :: forall m n. ( KnownNat m, KnownNat n ) => Gen (HStatic.L m n)

20+uniformSample :: forall mm m n. ( Monad mm, KnownNat m, KnownNat n ) => Gen.Gen mm (HStatic.L m n)

2321uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded

2422

2523-- | Generate random data of the desired shape

26−genOfShape :: forall x. ( SingI x ) => Gen (S x)

24+genOfShape :: forall m x. ( Monad m, SingI x ) => Gen.Gen m (S x)

2725genOfShape =

2826 case (sing :: Sing x) of

2927 D1Sing l ->

test/Test/Hedgehog/TypeLits.hs+19−20

@@ -7,27 +7,32 @@

77{-# LANGUAGE GADTs #-}

88module Test.Hedgehog.TypeLits where

99

10−import Data.Constraint (Dict (..))

11−import Data.Singletons (Proxy (..), Sing (..), SomeSing (..), sing)

12−#if MIN_VERSION_singletons(2,6,0)

13−import Data.Singletons.TypeLits (SNat (..))

10+import Data.Constraint

11+#if __GLASGOW_HASKELL__ < 800

12+import Data.Proxy

1413#endif

14+import Data.Singletons

1515

16−import Hedgehog (Gen)

1716import qualified Hedgehog.Gen as Gen

1817

1918import Grenade

2019

21−import GHC.TypeLits (SomeNat (..), natVal, someNatVal)

22−import GHC.TypeLits.Witnesses ((%*), natDict)

23−import Test.Hedgehog.Compat (choose)

20+import GHC.TypeLits

21+import GHC.TypeLits.Witnesses

22+import Test.Hedgehog.Compat

2423

25−genNat :: Gen SomeNat

24+genNat :: Monad m => Gen.Gen m SomeNat

2625genNat = do

27− ~(Just n) <- someNatVal <$> choose 1 10

26+ Just n <- someNatVal <$> choose 1 10

2827 return n

2928

30−genShape :: Gen (SomeSing Shape)

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

3136genShape

3237 = Gen.choice [

3338 genD1

@@ -35,20 +40,20 @@ genShape

3540 , genD3

3641 ]

3742

38−genD1 :: Gen (SomeSing Shape)

43+genD1 :: Monad m => Gen.Gen m (SomeSing Shape')

3944genD1 = do

4045 n <- genNat

4146 return $ case n of

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

4348

44−genD2 :: Gen (SomeSing Shape)

49+genD2 :: Monad m => Gen.Gen m (SomeSing Shape')

4550genD2 = do

4651 n <- genNat

4752 m <- genNat

4853 return $ case (n, m) of

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

5055

51−genD3 :: Gen (SomeSing Shape)

56+genD3 :: Monad m => Gen.Gen m (SomeSing Shape')

5257genD3 = do

5358 n <- genNat

5459 m <- genNat

@@ -57,9 +62,3 @@ genD3 = do

5762 (SomeNat (px :: Proxy x), SomeNat (_ :: Proxy y), SomeNat (pz :: Proxy z)) ->

5863 case natDict px %* natDict pz of

5964 Dict -> SomeSing (sing :: Sing ('D3 x y z))

60−

61−rss :: SomeSing Shape -> String

62−rss (SomeSing (r :: Sing s)) = case r of

63− (D1Sing a@SNat) -> "D1 " ++ show (natVal a)

64− (D2Sing a@SNat b@SNat) -> "D2 " ++ show (natVal a) ++ " " ++ show (natVal b)

65− (D3Sing a@SNat b@SNat c@SNat) -> "D3 " ++ show (natVal a) ++ " " ++ show (natVal b) ++ " " ++ show (natVal c)