a588151..master · grenade

.gitignore+3−1

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

1+cabal.project.local

12.cabal-sandbox/

23cabal.sandbox.config

34dist/

4−

5+dist-newstyle/

6+.stack-work/

.travis.yml+12−11

@@ -2,29 +2,30 @@

22

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

44env:

5− - CABALVER=1.22 GHCVER=7.10.3

6− - CABALVER=1.24 GHCVER=8.0.2

7− - CABALVER=2.0 GHCVER=8.2.1

5+ - GHCVER=8.0.2

6+ - GHCVER=8.2.2

7+ - GHCVER=8.4.4

8+ - GHCVER=8.6.5

9+ - GHCVER=8.8.3

10+ - GHCVER=8.10.1

811

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

1013before_install:

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

1215 - travis_retry sudo apt-get update

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

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

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

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

1518

1619install:

17− - cabal --version

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

19− - travis_retry cabal update

20− - cabal sandbox init

21− - cabal install --enable-tests --enable-benchmarks

21+ - travis_retry cabal-3.2 update

2222

2323notifications:

2424 email: false

2525

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

2727script:

28− - cabal build

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

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

29+ - cabal-3.2 build all

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

3031

README.md+2−2

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

2424type MNIST

2525 = Network

2626 '[ 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, FlattenLayer, Relu

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

2828 , FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]

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

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

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

159159./mafia test

160160```

161161

162−Grenade builds with ghc 7.10 and 8.0.

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

163163

164164Thanks

165165------

examples/grenade-examples.cabal+10−9

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

2626 , bytestring

2727 , cereal

2828 , either

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

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

3030 , text == 1.2.*

3131 , mtl >= 2.2.1 && < 2.3

3232 , hmatrix

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

4242 , grenade

4343 , attoparsec

4444 , either

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

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

4646 , text == 1.2.*

4747 , mtl >= 2.2.1 && < 2.3

48− , hmatrix >= 0.18 && < 0.19

48+ , hmatrix >= 0.18 && < 0.21

4949 , transformers

5050 , semigroups

5151 , singletons

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

6161 , bytestring

6262 , cereal

6363 , either

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

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

6565 , text == 1.2.*

6666 , mtl >= 2.2.1 && < 2.3

67− , hmatrix >= 0.18 && < 0.19

67+ , hmatrix >= 0.18 && < 0.21

6868 , transformers

6969 , semigroups

7070 , singletons

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

7878 , grenade

7979 , attoparsec

8080 , either

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

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

8282 , text == 1.2.*

8383 , mtl >= 2.2.1 && < 2.3

84− , hmatrix >= 0.18 && < 0.19

84+ , hmatrix >= 0.18 && < 0.21

8585 , transformers

8686 , semigroups

8787 , singletons

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

9696 , bytestring

9797 , cereal

9898 , either

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

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

100100 , text == 1.2.*

101101 , mtl >= 2.2.1 && < 2.3

102− , hmatrix >= 0.18 && < 0.19

102+ , hmatrix >= 0.18 && < 0.21

103103 , transformers

104104 , semigroups

105105 , singletons

106+ , singletons-base

106107 , vector

107108 , MonadRandom

108109 , containers

examples/mafianew file+62

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

1+#!/bin/sh -eu

2+

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

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

5+

6+latest_version () {

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

8+}

9+

10+build_version() {

11+ MAFIA_VERSION="$1"

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

13+ MAFIA_FILE=mafia-$MAFIA_VERSION

14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE

15+ mkdir -p $MAFIA_VERSIONS

16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

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

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

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

20+ exit 1

21+ }

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

23+ got=$?

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

25+ exit "$got"

26+ }

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

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

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

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

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

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

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

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

35+ exit 0

36+ }

37+}

38+

39+enable_version() {

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

41+ MAFIA_VERSION="$(latest_version)"

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

43+ else

44+ MAFIA_VERSION="$1"

45+ fi

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

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

48+}

49+

50+exec_mafia () {

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

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

53+}

54+

55+#

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

57+#

58+

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

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

61+*) exec_mafia "$@"

62+esac

examples/main/feedforward.hs+3−1

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

11{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE ScopedTypeVariables #-}

45{-# LANGUAGE TypeOperators #-}

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

1011

1112import qualified Data.ByteString as B

1213import Data.Serialize

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

1315import Data.Semigroup ( (<>) )

14−

16+#endif

1517import GHC.TypeLits

1618

1719import qualified Numeric.LinearAlgebra.Static as SA

examples/main/gan-mnist.hs+3

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

11{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE GADTs #-}

45{-# LANGUAGE ScopedTypeVariables #-}

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

4344import qualified Data.Attoparsec.Text as A

4445import qualified Data.ByteString as B

4546import Data.List ( foldl' )

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

4648import Data.Semigroup ( (<>) )

49+#endif

4750import Data.Serialize

4851import qualified Data.Text as T

4952import qualified Data.Text.IO as T

examples/main/mnist.hs+4

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

11{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE ScopedTypeVariables #-}

45{-# LANGUAGE TypeOperators #-}

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

1314

1415import qualified Data.Attoparsec.Text as A

1516import Data.List ( foldl' )

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

1618import Data.Semigroup ( (<>) )

19+#endif

20+

1721import qualified Data.Text as T

1822import qualified Data.Text.IO as T

1923import qualified Data.Vector.Storable as V

examples/main/recurrent.hs+5−5

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

99import Control.Monad ( foldM )

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

1111

12−#if __GLASGOW_HASKELL__ < 800

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

1313import Data.List ( unfoldr )

1414#else

1515import Data.List ( cycle, unfoldr )

16−#endif

1716import Data.Semigroup ( (<>) )

17+#endif

1818

1919import qualified Numeric.LinearAlgebra.Static as SA

2020

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

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

3232type R = Recurrent

3333

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

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

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

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

3636

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

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

3838

3939randomNet :: MonadRandom m => m RecNet

4040randomNet = randomRecurrent

examples/main/shakespeare.hs+20−17

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE CPP #-}

33{-# LANGUAGE DataKinds #-}

44{-# LANGUAGE ScopedTypeVariables #-}

55{-# LANGUAGE TypeOperators #-}

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

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

1414import Data.List ( foldl' )

1515import Data.Maybe ( fromMaybe )

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

16+

1717

1818import qualified Data.Vector as V

1919import Data.Vector ( Vector )

2020

2121import qualified Data.Map as M

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

2322

2423import qualified Data.ByteString as B

2524import Data.Serialize

2625

27−import Data.Singletons.Prelude

2826import GHC.TypeLits

2927

3028import Numeric.LinearAlgebra.Static ( konst )

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

3634import Grenade.Utils.OneHot

3735

3836import System.IO.Unsafe ( unsafeInterleaveIO )

37+import Data.Proxy

38+import Prelude.Singletons

3939

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

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

4242-- about an hour.

4343--

44+-- Grab the input from

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

46+--

4447-- This is a first class recurrent net.

4548--

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

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

6972loadShakespeare path = do

7073 contents <- lift $ readFile path

7174 let annotated = annotateCapitals contents

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

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

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

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

7578

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

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

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

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

7982 in case reverse e of

8083 (o : l : xs) ->

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

82− in trainRecurrent rate net recIns examples

85+ in trainRecurrent lrate net recIns examples

8386 _ -> error "Not enough input"

8487 where

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

8689

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

88−runShakespeare ShakespeareOpts {..} = do

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

91+runShakespeare opts = do

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

9093 (net0, i0) <- lift $

91− case loadPath of

94+ case loadPath opts of

9295 Just loadFile -> netLoad loadFile

9396 Nothing -> (,0) <$> randomNet

9497

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

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

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

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

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

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

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

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

100103 putStrLn (unAnnotateCapitals results)

101104 return (trained, bestInput)

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

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

103106

104− case savePath of

107+ case savePath opts of

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

106109 Nothing -> return ()

107110

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

113116 -> Vector a

114117 -> S ('D1 n)

115118 -> IO [a]

116−generateParagraph n s temperature hotmap hotdict =

119+generateParagraph n s temp hotmap hotdict =

117120 go s

118121 where

119122 go x y =

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

121− un <- sample temperature hotdict o

124+ un <- sample temp hotdict o

122125 Just re <- return $ makeHot hotmap un

123126 rest <- unsafeInterleaveIO $ go ns re

124127 return (un : rest)

framework/mafianew file+62

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

1+#!/bin/sh -eu

2+

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

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

5+

6+latest_version () {

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

8+}

9+

10+build_version() {

11+ MAFIA_VERSION="$1"

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

13+ MAFIA_FILE=mafia-$MAFIA_VERSION

14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE

15+ mkdir -p $MAFIA_VERSIONS

16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

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

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

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

20+ exit 1

21+ }

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

23+ got=$?

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

25+ exit "$got"

26+ }

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

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

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

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

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

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

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

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

35+ exit 0

36+ }

37+}

38+

39+enable_version() {

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

41+ MAFIA_VERSION="$(latest_version)"

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

43+ else

44+ MAFIA_VERSION="$1"

45+ fi

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

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

48+}

49+

50+exec_mafia () {

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

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

53+}

54+

55+#

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

57+#

58+

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

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

61+*) exec_mafia "$@"

62+esac

grenade.cabal+33−18

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

10+cabal-version: >= 1.10

1111build-type: Simple

1212description:

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

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

3838library

3939 build-depends:

4040 base >= 4.8 && < 5

41− , bytestring == 0.10.*

42− , containers >= 0.5 && < 0.6

41+ , bytestring >= 0.10.0

42+ , containers >= 0.5 && < 0.7

4343 , cereal >= 0.5 && < 0.6

4444 , deepseq >= 1.4 && < 1.5

45− , exceptions == 0.8.*

46− , hmatrix == 0.18.*

45+ , hmatrix >= 0.18 && < 0.21

4746 , MonadRandom >= 0.4 && < 0.6

48− , mtl >= 2.2.1 && < 2.3

49− , primitive >= 0.6 && < 0.7

50− , text == 1.2.*

51− , singletons >= 2.1 && < 2.4

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

5252 , vector >= 0.11 && < 0.13

5353

5454 ghc-options:

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

5656 hs-source-dirs:

5757 src

5858

59+ default-language: Haskell2010

60+

5961 if impl(ghc < 8.0)

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

63+ cpp-options: -DType=*

6164

65+ if impl(ghc >= 8.6)

66+ default-extensions: NoStarIsType

6267

6368 exposed-modules:

6469 Grenade

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

8489 Grenade.Layers.Pooling

8590 Grenade.Layers.Relu

8691 Grenade.Layers.Reshape

92+ Grenade.Layers.Sinusoid

8793 Grenade.Layers.Softmax

8894 Grenade.Layers.Tanh

8995 Grenade.Layers.Trivial

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

126132 hs-source-dirs:

127133 test

128134

135+ default-language: Haskell2010

129136

130137 other-modules: Test.Hedgehog.Compat

131138 Test.Hedgehog.Hmatrix

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

146153

147154 if impl(ghc < 8.0)

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

156+ cpp-options: -DType=*

157+

158+ if impl(ghc >= 8.6)

159+ default-extensions: NoStarIsType

149160

150161 build-depends:

151− base >= 4.8 && < 5

162+ base

152163 , grenade

153− , hedgehog >= 0.5 && < 0.6

164+ , hedgehog >= 1.0 && < 1.1

154165 , hmatrix

155166 , mtl

156167 , singletons

157168 , text == 1.2.*

158− , typelits-witnesses

169+ , typelits-witnesses < 0.4

159170 , transformers

160171 , constraints

161172 , MonadRandom

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

175186 hs-source-dirs:

176187 bench

177188

189+ default-language: Haskell2010

190+

178191 build-depends:

179− base >= 3 && < 5

180− , bytestring == 0.10.*

181− , criterion >= 1.1 && < 1.3

192+ base

193+ , bytestring

194+ , criterion >= 1.1 && < 1.6

182195 , grenade

183196 , hmatrix

184197

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

192205 hs-source-dirs:

193206 bench

194207

208+ default-language: Haskell2010

209+

195210 build-depends:

196− base >= 3 && < 5

197− , bytestring == 0.10.*

198− , criterion == 1.1.*

211+ base

212+ , bytestring

213+ , criterion

199214 , grenade

200215 , hmatrix

mafiamode 100755 → 120000+1−123

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

1−#!/bin/sh -eu

2−

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

4−

5−fetch_latest () {

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

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

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

9− else

10− cat ../script/mafia

11− fi

12−}

13−

14−latest_version () {

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

16−}

17−

18−local_version () {

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

20−}

21−

22−run_upgrade () {

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

24−

25− clean_up () {

26− rm -f "$MAFIA_TEMP"

27− }

28−

29− trap clean_up EXIT

30−

31− MAFIA_CUR="$0"

32−

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

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

35− exit 1

36− fi

37−

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

39− fetch_latest > $MAFIA_TEMP

40−

41− LATEST_VERSION=$(latest_version)

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

43−

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

45− mv $MAFIA_TEMP $MAFIA_CUR

46− chmod +x $MAFIA_CUR

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

48− else

49− echo "You have latest mafia."

50− fi

51−}

52−

53−exec_mafia () {

54− MAFIA_VERSION=$(local_version)

55−

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

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

58− run_upgrade

59− else

60− MAFIA_BIN=$MAFIA_HOME/bin

61− MAFIA_FILE=mafia-$MAFIA_VERSION

62− MAFIA_PATH=$MAFIA_BIN/$MAFIA_FILE

63−

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

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

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

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

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

69−

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

71− mkdir -p $MAFIA_BIN

72−

73− clean_up () {

74− rm -rf "$MAFIA_TEMP"

75− }

76−

77− trap clean_up EXIT

78−

79− echo "Building $MAFIA_FILE in $MAFIA_TEMP"

80−

81− ( cd "$MAFIA_TEMP"

82−

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

84− cd mafia

85−

86− git reset --hard $MAFIA_VERSION

87−

88− bin/bootstrap ) || exit $?

89−

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

91−

92− clean_up_temp () {

93− clean_up

94− rm -f "$MAFIA_PATH_TEMP"

95− }

96− trap clean_up_temp EXIT

97−

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

99− chmod 755 "$MAFIA_PATH_TEMP"

100− mv "$MAFIA_PATH_TEMP" "$MAFIA_PATH"

101−

102− clean_up_temp

103− }

104−

105− exec $MAFIA_PATH "$@"

106− fi

107−}

108−

109−#

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

111−#

112−

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

114− MODE="$1"

115−else

116− MODE=""

117−fi

118−

119−case "$MODE" in

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

121−*) exec_mafia "$@"

122−esac

123−# Version: 360716306a06db842ec022a7b9f161d2208483f0

@@ -0,0 +1 @@

1+framework/mafia

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE TypeOperators #-}

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

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

2021

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

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

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

2324to the input and output data of the layer.

2425

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

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

4142

4243import Data.List ( foldl' )

4344

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

46+import Data.Kind (Type)

47+#endif

48+

4449import Grenade.Core.Shape

4550import Grenade.Core.LearningParameters

4651

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

5055class UpdateLayer x where

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

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

53− type Gradient x :: *

58+ type Gradient x :: Type

5459

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

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

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

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

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

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

75− type Tape x i o :: *

80+ type Tape x i o :: Type

7681

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

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

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE BangPatterns #-}

34{-# LANGUAGE GADTs #-}

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

3334import Control.Monad.Random ( MonadRandom )

3435

3536import Data.Singletons

36−import Data.Singletons.Prelude

3737import Data.Serialize

3838

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

40+import Data.Kind (Type)

41+#endif

42+

3943import Grenade.Core.Layer

4044import Grenade.Core.LearningParameters

4145import Grenade.Core.Shape

46+import Prelude.Singletons

4247

4348-- | Type of a network.

4449--

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

4853--

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

5055-- transform the data shapes of the network.

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

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

5257 NNil :: SingI i

5358 => Network '[] '[i]

5459

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

6671-- | Gradient of a network.

6772--

6873-- Parameterised on the layers of the network.

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

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

7075 GNil :: Gradients '[]

7176

7277 (:/>) :: UpdateLayer x

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

7782-- | Wegnert Tape of a network.

7883--

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

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

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

8186 TNil :: SingI i

8287 => Tapes '[] '[i]

8388

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

152157

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

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

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

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

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

157162 --

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

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

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

1313 , runNet

1414 ) where

1515

16−import Data.Singletons.Prelude

1716

1817import Grenade.Core.LearningParameters

1918import Grenade.Core.Network

2019import Grenade.Core.Shape

20+import Data.Singletons

21+import Prelude.Singletons

2122

2223-- | Perform reverse automatic differentiation on the network

2324-- for the current input and expected output.

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE KindSignatures #-}

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

78{-# LANGUAGE FlexibleContexts #-}

89{-# LANGUAGE ScopedTypeVariables #-}

910{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE UndecidableInstances #-}

1012{-|

1113Module : Grenade.Core.Shape

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

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

1719

1820-}

1921module Grenade.Core.Shape (

20− Shape (..)

21− , S (..)

22− , Sing (..)

23−

22+ S (..)

23+ , Shape (..)

24+ , SShape (..)

2425 , randomOfShape

2526 , fromStorable

2627 ) where

2728

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

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

30−

31+import Data.Kind (Type)

3132import Data.Proxy

3233import Data.Serialize

3334import Data.Singletons

34−import Data.Singletons.TypeLits

3535import Data.Vector.Storable ( Vector )

3636import qualified Data.Vector.Storable as V

37−

3837import GHC.TypeLits

39−

4038import qualified Numeric.LinearAlgebra.Static as H

4139import Numeric.LinearAlgebra.Static

4240import qualified Numeric.LinearAlgebra as NLA

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

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

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

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

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

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

84+type instance Sing = SShape

85+

86+data SShape :: Shape -> Type where

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

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

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

90+#else

8491data instance Sing (n :: Shape) where

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

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

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

95+#endif

8896

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

90− sing = D1Sing sing

98+ sing = D1Sing

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

92− sing = D2Sing sing sing

100+ sing = D2Sing

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

94− sing = D3Sing sing sing sing

102+ sing = D3Sing

95103

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

97105 (+) = n2 (+)

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

140148randomOfShape = do

141149 seed :: Int <- getRandom

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

143− D1Sing SNat ->

151+ D1Sing ->

144152 S1D (randomVector seed Uniform * 2 - 1)

145153

146− D2Sing SNat SNat ->

154+ D2Sing ->

147155 S2D (uniformSample seed (-1) 1)

148156

149− D3Sing SNat SNat SNat ->

157+ D3Sing ->

150158 S3D (uniformSample seed (-1) 1)

151159

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

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

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

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

156164fromStorable xs = case sing :: Sing x of

157− D1Sing SNat ->

165+ D1Sing ->

158166 S1D <$> H.create xs

159167

160− D2Sing SNat SNat ->

168+ D2Sing ->

161169 S2D <$> mkL xs

162170

163− D3Sing SNat SNat SNat ->

171+ D3Sing ->

164172 S3D <$> mkL xs

165173 where

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

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

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

198206

199207-- Helper function for creating the number instances

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

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

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

202− D1Sing SNat ->

210+ D1Sing ->

203211 S1D (konst x)

204212

205− D2Sing SNat SNat ->

213+ D2Sing ->

206214 S2D (konst x)

207215

208− D3Sing SNat SNat SNat ->

216+ D3Sing ->

209217 S3D (konst x)

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE TypeOperators #-}

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

89{-# LANGUAGE FlexibleInstances #-}

910{-# LANGUAGE ScopedTypeVariables #-}

1011{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE UndecidableInstances #-}

1113{-|

1214Module : Grenade.Layers.Concat

1315Description : Concatenation layer

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

2628import Data.Singletons

2729import GHC.TypeLits

2830

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

32+import Data.Kind (Type)

33+#endif

34+

2935import Grenade.Core

3036

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

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

4349--

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

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

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

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

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

4854

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

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE TypeOperators #-}

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE MultiParamTypeClasses #-}

88{-# LANGUAGE FlexibleInstances #-}

99{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

1011{-|

1112Module : Grenade.Layers.Convolution

1213Description : Convolution layer

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

2728import Data.Maybe

2829import Data.Proxy

2930import Data.Serialize

30−import Data.Singletons.TypeLits

3131

3232import GHC.TypeLits

33+import Data.Kind (Type)

3334

3435import Numeric.LinearAlgebra hiding ( uniformSample, konst )

3536import qualified Numeric.LinearAlgebra as LA

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

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

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

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

59− -> * where

60+ -> Type where

6061 Convolution :: ( KnownNat channels

6162 , KnownNat filters

6263 , KnownNat kernelRows

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

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

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

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

78− -> * where

79+ -> Type where

7980 Convolution' :: ( KnownNat channels

8081 , KnownNat filters

8182 , KnownNat kernelRows

@@ -130,8 +131,8 @@ instance ( KnownNat channels

130131 , KnownNat (kernelRows * kernelColumns * channels)

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

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

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

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

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

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

135136 in Convolution newKernel newMomentum

136137

137138 createRandom = randomConvolution

src/Grenade/Layers/Crop.hs+10−2

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE GADTs #-}

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

56{-# LANGUAGE TypeFamilies #-}

67{-# LANGUAGE FlexibleContexts #-}

78{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE UndecidableInstances #-}

810{-|

911Module : Grenade.Layers.Crop

1012Description : Cropping layer

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

1820

1921import Data.Maybe

2022import Data.Proxy

21−import Data.Singletons.TypeLits

23+import Data.Serialize

24+

2225import GHC.TypeLits

26+import Data.Kind (Type)

2327

2428import Grenade.Core

2529import Grenade.Layers.Internal.Pad

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

3135data Crop :: Nat

3236 -> Nat

3337 -> Nat

34− -> Nat -> * where

38+ -> Nat -> Type where

3539 Crop :: Crop cropLeft cropTop cropRight cropBottom

3640

3741instance Show (Crop cropLeft cropTop cropRight cropBottom) where

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

4246 runUpdate _ x _ = x

4347 createRandom = return Crop

4448

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

50+ put _ = return ()

51+ get = return Crop

52+

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

4654instance ( KnownNat cropLeft

4755 , KnownNat cropTop

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE TypeOperators #-}

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE MultiParamTypeClasses #-}

88{-# LANGUAGE FlexibleInstances #-}

99{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

1011{-|

1112Module : Grenade.Layers.Deconvolution

1213Description : Deconvolution layer

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

3132import Data.Maybe

3233import Data.Proxy

3334import Data.Serialize

34−import Data.Singletons.TypeLits

3535

3636import GHC.TypeLits

37+import Data.Kind (Type)

3738

3839import Numeric.LinearAlgebra hiding ( uniformSample, konst )

3940import qualified Numeric.LinearAlgebra as LA

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

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

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

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

58− -> * where

59+ -> Type where

5960 Deconvolution :: ( KnownNat channels

6061 , KnownNat filters

6162 , KnownNat kernelRows

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

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

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

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

77− -> * where

78+ -> Type where

7879 Deconvolution' :: ( KnownNat channels

7980 , KnownNat filters

8081 , KnownNat kernelRows

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

129130 , KnownNat (kernelRows * kernelColumns * filters)

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

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

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

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

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

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

134135 in Deconvolution newKernel newMomentum

135136

136137 createRandom = randomDeconvolution

src/Grenade/Layers/FullyConnected.hs+4−5

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

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE RecordWildCards #-}

32{-# LANGUAGE TypeOperators #-}

43{-# LANGUAGE TypeFamilies #-}

54{-# LANGUAGE MultiParamTypeClasses #-}

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

1413

1514import Data.Proxy

1615import Data.Serialize

17−import Data.Singletons.TypeLits

1816

1917import qualified Numeric.LinearAlgebra as LA

2018import Numeric.LinearAlgebra.Static

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

2220import Grenade.Core

2321

2422import Grenade.Layers.Internal.Update

23+import GHC.TypeLits

2524

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

2726data FullyConnected i o = FullyConnected

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

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

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

4039

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

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

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

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

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

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

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

4544

4645 createRandom = randomFullyConnected

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE TypeOperators #-}

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

2324

2425import Data.Singletons

2526

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

28+import Data.Kind (Type)

29+#endif

30+

2631import Grenade.Core

2732

2833-- | A Merging layer.

2934--

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

3136-- shape.

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

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

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

3439

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

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE GADTs #-}

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

56{-# LANGUAGE TypeFamilies #-}

67{-# LANGUAGE MultiParamTypeClasses #-}

78{-# LANGUAGE FlexibleContexts #-}

9+{-# LANGUAGE UndecidableInstances #-}

810{-|

911Module : Grenade.Core.Pad

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

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

1921import Data.Maybe

2022import Data.Proxy

2123import Data.Serialize

22−import Data.Singletons.TypeLits

24+

2325import GHC.TypeLits

26+import Data.Kind (Type)

2427

2528import Grenade.Core

2629import Grenade.Layers.Internal.Pad

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

3437data Pad :: Nat

3538 -> Nat

3639 -> Nat

37− -> Nat -> * where

40+ -> Nat -> Type where

3841 Pad :: Pad padLeft padTop padRight padBottom

3942

4043instance Show (Pad padLeft padTop padRight padBottom) where

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

4952 put _ = return ()

5053 get = return Pad

5154

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

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

5356instance ( KnownNat padLeft

5457 , KnownNat padTop

5558 , KnownNat padRight

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

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

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

8184

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

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

8386instance ( KnownNat padLeft

8487 , KnownNat padTop

8588 , KnownNat padRight

src/Grenade/Layers/Pooling.hs+5−2

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE StandaloneDeriving #-}

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

67{-# LANGUAGE TypeFamilies #-}

78{-# LANGUAGE MultiParamTypeClasses #-}

89{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

911{-|

1012Module : Grenade.Core.Pooling

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

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

2022import Data.Maybe

2123import Data.Proxy

2224import Data.Serialize

23−import Data.Singletons.TypeLits

25+

2426import GHC.TypeLits

27+import Data.Kind (Type)

2528

2629import Grenade.Core

2730import Grenade.Layers.Internal.Pooling

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

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

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

3841--

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

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

4043 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

4144

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

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

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

33{-# LANGUAGE TypeFamilies #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

55{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE UndecidableInstances #-}

67{-|

78Module : Grenade.Layers.Reshape

89Description : Multipurpose reshaping layer

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

1617

1718import Data.Serialize

1819

19−import Data.Singletons.TypeLits

2020import GHC.TypeLits

2121

2222import Numeric.LinearAlgebra.Static

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

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-|

7+Module : Grenade.Layers.Sinusoid

8+Description : Sinusoid nonlinear layer

9+Copyright : (c) Manuel Schneckenreither, 2018

10+License : BSD2

11+Stability : experimental

12+-}

13+module Grenade.Layers.Sinusoid (

14+ Sinusoid (..)

15+ ) where

16+

17+import Data.Serialize

18+import Data.Singletons

19+

20+import Grenade.Core

21+

22+-- | A Sinusoid layer.

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

24+data Sinusoid = Sinusoid

25+ deriving Show

26+

27+instance UpdateLayer Sinusoid where

28+ type Gradient Sinusoid = ()

29+ runUpdate _ _ _ = Sinusoid

30+ createRandom = return Sinusoid

31+

32+instance Serialize Sinusoid where

33+ put _ = return ()

34+ get = return Sinusoid

35+

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

37+ type Tape Sinusoid a b = S a

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

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

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

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

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE TypeOperators #-}

3−{-# LANGUAGE TypeFamilies #-}

42{-# LANGUAGE FlexibleInstances #-}

53{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeOperators #-}

66{-|

77Module : Grenade.Layers.Tanh

88Description : Hyperbolic tangent nonlinear layer

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

2020import Grenade.Core

2121

2222-- | A Tanh layer.

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

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

2424data Tanh = Tanh

2525 deriving Show

2626

src/Grenade/Recurrent/Core/Layer.hs+7−2

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE TypeFamilies #-}

34{-# LANGUAGE MultiParamTypeClasses #-}

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

89 , RecurrentUpdateLayer (..)

910 ) where

1011

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

13+import Data.Kind (Type)

14+#endif

15+

1116import Grenade.Core

1217

1318-- | Class for a recurrent layer.

@@ -15,11 +20,11 @@ import Grenade.Core

1520-- of an extra recurrent data shape.

1621class UpdateLayer x => RecurrentUpdateLayer x where

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

18− type RecurrentShape x :: *

23+ type RecurrentShape x :: Type

1924

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

2126 -- | Wengert Tape

22− type RecTape x i o :: *

27+ type RecTape x i o :: Type

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

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

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

src/Grenade/Recurrent/Core/Network.hs+12−10

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE TypeOperators #-}

@@ -28,22 +29,23 @@ module Grenade.Recurrent.Core.Network (

2829

2930

3031import Control.Monad.Random ( MonadRandom )

31−import Data.Singletons ( SingI )

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

3332import Data.Serialize

3433

34+import Data.Kind (Type)

35+

3536import Grenade.Core

3637import Grenade.Recurrent.Core.Layer

38+import Prelude.Singletons

3739

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

3941-- forward layer.

40−data FeedForward :: * -> *

42+data FeedForward :: Type -> Type

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

42−data Recurrent :: * -> *

44+data Recurrent :: Type -> Type

4345

4446-- | Type of a recurrent neural network.

4547--

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

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

4749--

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

4951--

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

5254--

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

5456-- for these empty data types.

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

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

5658 RNil :: SingI i

5759 => RecurrentNetwork '[] '[i]

5860

@@ -71,7 +73,7 @@ infixr 5 :~@>

7173-- | Gradient of a network.

7274--

7375-- Parameterised on the layers of the network.

74−data RecurrentGradient :: [*] -> * where

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

7577 RGNil :: RecurrentGradient '[]

7678

7779 (://>) :: UpdateLayer x

@@ -81,7 +83,7 @@ data RecurrentGradient :: [*] -> * where

8183

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

8385-- Parameterised on the layers of a Network.

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

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

8587 RINil :: RecurrentInputs '[]

8688

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

@@ -95,7 +97,7 @@ data RecurrentInputs :: [*] -> * where

9597--

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

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

98−data RecurrentTape :: [*] -> [Shape] -> * where

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

99101 TRNil :: SingI i

100102 => RecurrentTape '[] '[i]

101103

@@ -204,7 +206,7 @@ instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recu

204206

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

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

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

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

208210 -- | Create a network of the types requested

209211 randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss)

210212

src/Grenade/Recurrent/Core/Runner.hs+5−6

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

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE FlexibleContexts #-}

88{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE RecordWildCards #-}

109

1110module Grenade.Recurrent.Core.Runner (

1211 runRecurrentExamples

@@ -18,10 +17,10 @@ module Grenade.Recurrent.Core.Runner (

1817 ) where

1918

2019import Data.List ( foldl' )

21−import Data.Singletons.Prelude

2220import Grenade.Core

2321

2422import Grenade.Recurrent.Core.Network

23+import Prelude.Singletons

2524

2625type RecurrentGradients layers = [RecurrentGradient layers]

2726

@@ -101,11 +100,11 @@ updateRecInputs :: Fractional (RecurrentInputs sublayers)

101100 -> RecurrentInputs sublayers

102101 -> RecurrentInputs sublayers

103102

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

105− = () :~~+> updateRecInputs l xs ys

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

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

106105

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

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

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

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

109108

110109updateRecInputs _ RINil RINil

111110 = RINil

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

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE RecordWildCards #-}

44{-# LANGUAGE TypeOperators #-}

55{-# LANGUAGE TypeFamilies #-}

66{-# LANGUAGE MultiParamTypeClasses #-}

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

1616

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

1818

19−import Data.Singletons.TypeLits

19+

20+import Data.Kind (Type)

2021

2122import Numeric.LinearAlgebra.Static

2223

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

2728

2829data BasicRecurrent :: Nat -- Input layer size

2930 -> Nat -- Output layer size

30− -> * where

31+ -> Type where

3132 BasicRecurrent :: ( KnownNat input

3233 , KnownNat output

3334 , KnownNat matrixCols

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

4041

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

4243 -> Nat -- Output layer size

43− -> * where

44+ -> Type where

4445 BasicRecurrent' :: ( KnownNat input

4546 , KnownNat output

4647 , KnownNat matrixCols

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

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

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

5758

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

59− let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient

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

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

6061 newBias = oldBias + newBiasMomentum

61− newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient

62− regulariser = konst (learningRegulariser * learningRate) * oldActivations

62+ newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient

63+ regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations

6364 newActivations = oldActivations + newMomentum - regulariser

6465 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

6566

src/Grenade/Recurrent/Layers/ConcatRecurrent.hs+7−1

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE TypeOperators #-}

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

89{-# LANGUAGE FlexibleInstances #-}

910{-# LANGUAGE ScopedTypeVariables #-}

1011{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE UndecidableInstances #-}

1113{-|

1214Module : Grenade.Layers.Concat

1315Description : Concatenation layer

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

2628import Data.Singletons

2729import GHC.TypeLits

2830

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

32+import Data.Kind (Type)

33+#endif

34+

2935import Grenade.Core

3036import Grenade.Recurrent.Core

3137

@@ -44,7 +50,7 @@ import Numeric.LinearAlgebra.Static ( (#), split, R )

4450--

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

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

47−data ConcatRecurrent :: Shape -> * -> Shape -> * -> * where

53+data ConcatRecurrent :: Shape -> Type -> Shape -> Type -> Type where

4854 ConcatRecLeft :: x -> y -> ConcatRecurrent m (Recurrent x) n (FeedForward y)

4955 ConcatRecRight :: x -> y -> ConcatRecurrent m (FeedForward x) n (Recurrent y)

5056 ConcatRecBoth :: x -> y -> ConcatRecurrent m (Recurrent x) n (Recurrent y)

src/Grenade/Recurrent/Layers/LSTM.hs+45−54

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE BangPatterns #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE GADTs #-}

45{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE RecordWildCards #-}

66{-# LANGUAGE TypeOperators #-}

77{-# LANGUAGE TypeFamilies #-}

88{-# LANGUAGE MultiParamTypeClasses #-}

@@ -21,7 +21,7 @@ import Control.Monad.Random ( MonadRandom, getRandom )

2121-- import Data.List ( foldl1' )

2222import Data.Proxy

2323import Data.Serialize

24−import Data.Singletons.TypeLits

24+import Data.Kind (Type)

2525

2626import qualified Numeric.LinearAlgebra as LA

2727import Numeric.LinearAlgebra.Static

@@ -29,6 +29,7 @@ import Numeric.LinearAlgebra.Static

2929import Grenade.Core

3030import Grenade.Recurrent.Core

3131import Grenade.Layers.Internal.Update

32+import GHC.TypeLits

3233

3334

3435-- | Long Short Term Memory Recurrent unit

@@ -36,14 +37,14 @@ import Grenade.Layers.Internal.Update

3637-- This is a Peephole formulation, so the recurrent shape is

3738-- just the cell state, the previous output is not held or used

3839-- at all.

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

40+data LSTM :: Nat -> Nat -> Type where

4041 LSTM :: ( KnownNat input

4142 , KnownNat output

4243 ) => !(LSTMWeights input output) -- Weights

4344 -> !(LSTMWeights input output) -- Momentums

4445 -> LSTM input output

4546

46−data LSTMWeights :: Nat -> Nat -> * where

47+data LSTMWeights :: Nat -> Nat -> Type where

4748 LSTMWeights :: ( KnownNat input

4849 , KnownNat output

4950 ) => {

@@ -70,7 +71,7 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

7071

7172 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

7273 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

73− runUpdate LearningParameters {..} (LSTM w m) g =

74+ runUpdate lp (LSTM w m) g =

7475 let (wf, wf') = u lstmWf w m g

7576 (uf, uf') = u lstmUf w m g

7677 (bf, bf') = v lstmBf w m g

@@ -87,11 +88,11 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

8788 -- Utility function for updating with the momentum, gradients, and weights.

8889 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

8990 u e (e -> weights) (e -> momentum) (e -> gradient) =

90− descendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum

91+ descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

9192

9293 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

9394 v e (e -> weights) (e -> momentum) (e -> gradient) =

94− descendVector learningRate learningMomentum learningRegulariser weights gradient momentum

95+ descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

9596

9697 -- There's a lot of updates here, so to try and minimise the number of data copies

9798 -- we'll create a mutable bucket for each.

@@ -132,18 +133,18 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

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

133134 -- Forward propagation for the LSTM layer.

134135 -- The size of the cell state is also the size of the output.

135− runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =

136+ runRecurrentForwards (LSTM lw _) (S1D cell) (S1D input) =

136137 let -- Forget state vector

137− f_s = lstmBf + lstmWf #> input + lstmUf #> cell

138+ f_s = lstmBf lw + lstmWf lw #> input + lstmUf lw #> cell

138139 f_t = sigmoid f_s

139140 -- Input state vector

140− i_s = lstmBi + lstmWi #> input + lstmUi #> cell

141+ i_s = lstmBi lw + lstmWi lw #> input + lstmUi lw #> cell

141142 i_t = sigmoid i_s

142143 -- Output state vector

143− o_s = lstmBo + lstmWo #> input + lstmUo #> cell

144+ o_s = lstmBo lw + lstmWo lw #> input + lstmUo lw #> cell

144145 o_t = sigmoid o_s

145146 -- Cell input state vector

146− c_s = lstmBc + lstmWc #> input

147+ c_s = lstmBc lw + lstmWc lw #> input

147148 c_x = tanh c_s

148149 -- Cell state

149150 c_t = f_t * cell + i_t * c_x

@@ -157,7 +158,7 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

157158 --

158159 -- There's a test version using the AD library without hmatrix in the test

159160 -- suite. These should match always.

160− runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (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') =

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

161162 let -- Reverse Mode AD Derivitives

162163 c_t' = h_t' * o_t + cellGrad

163164

@@ -174,8 +175,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

174175 c_s' = tanh' c_s * c_x'

175176

176177 -- The derivatives to pass sideways (recurrent) and downwards

177− cell' = tr lstmUf #> f_s' + tr lstmUo #> o_s' + tr lstmUi #> i_s' + c_t' * f_t

178− input' = tr lstmWf #> f_s' + tr lstmWo #> o_s' + tr lstmWi #> i_s' + tr lstmWc #> c_s'

178+ cell' = tr (lstmUf lw) #> f_s' + tr (lstmUo lw) #> o_s' + tr (lstmUi lw) #> i_s' + c_t' * f_t

179+ input' = tr (lstmWf lw) #> f_s' + tr (lstmWo lw) #> o_s' + tr (lstmWi lw) #> i_s' + tr (lstmWc lw) #> c_s'

179180

180181 -- Calculate the gradient Matricies for the input

181182 lstmWf' = f_s' `outer` input

@@ -234,44 +235,34 @@ tanh' :: (Floating a) => a -> a

234235tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

235236

236237instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

237− put (LSTM LSTMWeights {..} _) = do

238− u lstmWf

239− u lstmUf

240− v lstmBf

241− u lstmWi

242− u lstmUi

243− v lstmBi

244− u lstmWo

245− u lstmUo

246− v lstmBo

247− u lstmWc

248− v lstmBc

249− where

250− u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

251− u = putListOf put . LA.toList . LA.flatten . extract

252− v :: forall a. (KnownNat a) => Putter (R a)

253− v = putListOf put . LA.toList . extract

238+ put (LSTM lw _) = do

239+ u (lstmWf lw)

240+ u (lstmUf lw)

241+ v (lstmBf lw)

242+ u (lstmWi lw)

243+ u (lstmUi lw)

244+ v (lstmBi lw)

245+ u (lstmWo lw)

246+ u (lstmUo lw)

247+ v (lstmBo lw)

248+ u (lstmWc lw)

249+ v (lstmBc lw)

250+ where

251+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

252+ u = putListOf put . LA.toList . LA.flatten . extract

253+ v :: forall a. (KnownNat a) => Putter (R a)

254+ v = putListOf put . LA.toList . extract

254255

255256 get = do

256− lstmWf <- u

257− lstmUf <- u

258− lstmBf <- v

259− lstmWi <- u

260− lstmUi <- u

261− lstmBi <- v

262− lstmWo <- u

263− lstmUo <- u

264− lstmBo <- v

265− lstmWc <- u

266− lstmBc <- v

267− return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

268− where

269− u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

270− u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

271− in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

272− v :: forall a. (KnownNat a) => Get (R a)

273− v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

274−

275− w0 = konst 0

276− u0 = konst 0

277− v0 = konst 0

257+ w <- LSTMWeights <$> u <*> u <*> v <*> u <*> u <*> v <*> u <*> u <*> v <*> u <*> v

258+ return $ LSTM w (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

259+ where

260+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

261+ u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

262+ in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

263+ v :: forall a. (KnownNat a) => Get (R a)

264+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

265+

266+ w0 = konst 0

267+ u0 = konst 0

268+ v0 = konst 0

src/Grenade/Utils/OneHot.hs+6−5

@@ -22,7 +22,6 @@ import Data.Map ( Map )

2222import qualified Data.Map as M

2323

2424import Data.Proxy

25−import Data.Singletons.TypeLits

2625

2726import Data.Vector ( Vector )

2827import qualified Data.Vector as V

@@ -31,6 +30,7 @@ import qualified Data.Vector.Storable as VS

3130import Numeric.LinearAlgebra ( maxIndex )

3231import Numeric.LinearAlgebra.Devel

3332import Numeric.LinearAlgebra.Static

33+import GHC.TypeLits

3434

3535import Grenade.Core.Shape

3636

@@ -52,15 +52,16 @@ oneHot hot =

5252

5353-- | Create a one hot map from any enumerable.

5454-- Returns a map, and the ordered list for the reverse transformation

55−hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Maybe (Map a Int, Vector a)

55+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Either String (Map a Int, Vector a)

5656hotMap n as =

5757 let len = fromIntegral $ natVal n

5858 uniq = [ c | (c:_) <- group $ sort as]

5959 hotl = length uniq

60− in if hotl <= len

60+ in if hotl == len

6161 then

62− Just (M.fromList $ zip uniq [0..], V.fromList uniq)

63− else Nothing

62+ Right (M.fromList $ zip uniq [0..], V.fromList uniq)

63+ else

64+ Left ("Couldn't create hotMap of size " ++ show len ++ " from vector with " ++ show hotl ++ " unique characters")

6465

6566-- | From a map and value, create a 1D Shape

6667-- with one index hot (1) with the rest 0.

stack.yamlnew file+78

@@ -0,0 +1,78 @@

1+# This file was automatically generated by 'stack init'

2+#

3+# Some commonly used options have been documented as comments in this file.

4+# For advanced use and comprehensive documentation of the format, please see:

5+# https://docs.haskellstack.org/en/stable/yaml_configuration/

6+

7+# A warning or info to be displayed to the user on config load.

8+# user-message: |

9+

10+# Resolver to choose a 'specific' stackage snapshot or a compiler version.

11+# A snapshot resolver dictates the compiler version and the set of packages

12+# to be used for project dependencies. For example:

13+#

14+# resolver: lts-3.5

15+# resolver: nightly-2015-09-21

16+# resolver: ghc-7.10.2

17+#

18+# The location of a snapshot can be provided as a file or url. Stack assumes

19+# a snapshot provided as a file might change, whereas a url resource does not.

20+#

21+# resolver: ./custom-snapshot.yaml

22+# resolver: https://example.com/snapshots/2018-01-01.yaml

23+resolver: lts-20.18

24+

25+# User packages to be built.

26+# Various formats can be used as shown in the example below.

27+#

28+# packages:

29+# - some-directory

30+# - https://example.com/foo/bar/baz-0.0.2.tar.gz

31+# subdirs:

32+# - auto-update

33+# - wai

34+packages:

35+ - .

36+ - examples

37+

38+# Dependency packages to be pulled from upstream that are not in the resolver.

39+# These entries can reference officially published versions as well as

40+# forks / in-progress versions pinned to a git hash. For example:

41+#

42+# extra-deps:

43+# - acme-missiles-0.3

44+# - git: https://github.com/commercialhaskell/stack.git

45+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

46+#

47+extra-deps:

48+ - typelits-witnesses-0.3.0.3

49+

50+# Override default flag values for local packages and extra-deps

51+# flags: {}

52+

53+# Extra package databases containing global packages

54+# extra-package-dbs: []

55+

56+# Control whether we use the GHC we find on the path

57+# system-ghc: true

58+#

59+# Require a specific version of stack, using version ranges

60+# require-stack-version: -any # Default

61+# require-stack-version: ">=2.1"

62+#

63+# Override the architecture used by stack, especially useful on Windows

64+# arch: i386

65+# arch: x86_64

66+#

67+# Extra directories used by stack for building

68+# extra-include-dirs: [/path/to/dir]

69+# extra-lib-dirs: [/path/to/dir]

70+#

71+# Allow a newer minor version of GHC than the snapshot specifies

72+# compiler-check: newer-minor

73+

74+nix:

75+ enable: true

76+ packages:

77+ - blas

78+ - lapack

stack.yaml.locknew file+19

@@ -0,0 +1,19 @@

1+# This file was autogenerated by Stack.

2+# You should not edit this file by hand.

3+# For more information, please see the documentation at:

4+# https://docs.haskellstack.org/en/stable/lock_files

5+

6+packages:

7+- completed:

8+ hackage: typelits-witnesses-0.3.0.3@sha256:2d9df4ac6ff3077bfd2bf659e4b495e157723ac5b45c519762853f55df5c16db,2738

9+ pantry-tree:

10+ sha256: 6a42a462f98e94933b6e9721acd912c6c6b6a4743635efd15cc5871908c816a0

11+ size: 469

12+ original:

13+ hackage: typelits-witnesses-0.3.0.3

14+snapshots:

15+- completed:

16+ sha256: 9fa4bece7acfac1fc7930c5d6e24606004b09e80aa0e52e9f68b148201008db9

17+ size: 649606

18+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/18.yaml

19+ original: lts-20.18

test/Test/Grenade/Layers/Convolution.hs+6−1

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE TemplateHaskell #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE GADTs #-}

@@ -15,6 +16,10 @@ import Data.Singletons ()

1516import GHC.TypeLits

1617import GHC.TypeLits.Witnesses

1718

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

20+import Data.Kind (Type)

21+#endif

22+

1823import Grenade.Core

1924import Grenade.Layers.Convolution

2025

@@ -25,7 +30,7 @@ import Test.Hedgehog.Hmatrix

2530import Test.Hedgehog.TypeLits

2631import Test.Hedgehog.Compat

2732

28−data OpaqueConvolution :: * where

33+data OpaqueConvolution :: Type where

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

3035

3136instance Show OpaqueConvolution where

test/Test/Grenade/Layers/FullyConnected.hs+6−1

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE BangPatterns #-}

23{-# LANGUAGE TemplateHaskell #-}

34{-# LANGUAGE DataKinds #-}

@@ -12,6 +13,10 @@ import Data.Singletons ()

1213

1314import GHC.TypeLits

1415

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

17+import Data.Kind (Type)

18+#endif

19+

1520import Grenade.Core

1621import Grenade.Layers.FullyConnected

1722

@@ -20,7 +25,7 @@ import Hedgehog

2025import Test.Hedgehog.Compat

2126import Test.Hedgehog.Hmatrix

2227

23−data OpaqueFullyConnected :: * where

28+data OpaqueFullyConnected :: Type where

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

2530

2631instance Show OpaqueFullyConnected where

test/Test/Grenade/Layers/PadCrop.hs−4

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

77{-# LANGUAGE ScopedTypeVariables #-}

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

99

10−#if __GLASGOW_HASKELL__ < 800

11−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

12−#endif

13−

1410module Test.Grenade.Layers.PadCrop where

1511

1612import Grenade

test/Test/Grenade/Layers/Pooling.hs+10−5

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE TemplateHaskell #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE KindSignatures #-}

@@ -9,6 +10,10 @@ module Test.Grenade.Layers.Pooling where

910import Data.Proxy

1011import Data.Singletons ()

1112

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

14+import Data.Kind (Type)

15+#endif

16+

1217import GHC.TypeLits

1318import Grenade.Layers.Pooling

1419

@@ -16,7 +21,7 @@ import Hedgehog

1621

1722import Test.Hedgehog.Compat

1823

19−data OpaquePooling :: * where

24+data OpaquePooling :: Type where

2025 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling

2126

2227instance Show OpaquePooling where

@@ -24,10 +29,10 @@ instance Show OpaquePooling where

2429

2530genOpaquePooling :: Gen OpaquePooling

2631genOpaquePooling = do

27− Just kernelHeight <- someNatVal <$> choose 2 15

28− Just kernelWidth <- someNatVal <$> choose 2 15

29− Just strideHeight <- someNatVal <$> choose 2 15

30− Just strideWidth <- someNatVal <$> choose 2 15

32+ ~(Just kernelHeight) <- someNatVal <$> choose 2 15

33+ ~(Just kernelWidth ) <- someNatVal <$> choose 2 15

34+ ~(Just strideHeight) <- someNatVal <$> choose 2 15

35+ ~(Just strideWidth ) <- someNatVal <$> choose 2 15

3136

3237 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of

3338 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->

test/Test/Grenade/Network.hs+37−33

@@ -14,17 +14,12 @@ import Control.Monad ( guard )

1414import Control.Monad.ST ( runST )

1515

1616import Data.Constraint

17−#if __GLASGOW_HASKELL__ < 800

18−import Data.Proxy

19−#endif

2017import qualified Data.Vector.Storable as VS

2118import qualified Data.Vector.Storable.Mutable as VS ( write )

2219import Data.Singletons

2320import Data.Singletons.Prelude.List

2421import Data.Singletons.TypeLits

2522

26−-- import Data.Type.Equality

27−

2823import Hedgehog

2924import qualified Hedgehog.Gen as Gen

3025import Hedgehog.Internal.Source

@@ -32,7 +27,15 @@ import Hedgehog.Internal.Property ( failWith )

3227

3328import Grenade

3429

30+#if MIN_VERSION_base(4,11,0)

31+import GHC.TypeLits hiding (natVal)

32+#else

3533import GHC.TypeLits

34+#endif

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

36+import Data.Kind (Type)

37+#endif

38+

3639import GHC.TypeLits.Witnesses

3740import Test.Hedgehog.Compat

3841import Test.Hedgehog.TypeLits

@@ -43,7 +46,7 @@ import Numeric.LinearAlgebra ( flatten )

4346import Numeric.LinearAlgebra.Static ( extract, norm_Inf )

4447import Unsafe.Coerce

4548

46−data SomeNetwork :: * where

49+data SomeNetwork :: Type where

4750 SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork

4851

4952instance Show SomeNetwork where

@@ -74,8 +77,9 @@ genNetwork =

7477 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

7578 , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))

7679 , do -- Reshape to two dimensions

77− let divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]

78− let len = natVal l

80+ let divisors :: Integer -> [Integer]

81+ divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]

82+ let len = fromIntegral $ natVal l

7983 rs <- Gen.element $ divisors len

8084 let cs = len `quot` rs

8185 case ( someNatVal rs, someNatVal cs, someNatVal len ) of

@@ -96,8 +100,8 @@ genNetwork =

96100 , do -- Build a convolution layer with one filter output

97101 -- Figure out some kernel sizes which work for this layer

98102 -- There must be a better way than this...

99− let output_r = natVal r

100− let output_c = natVal c

103+ let output_r = fromIntegral $ natVal r

104+ let output_c = fromIntegral $ natVal c

101105

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

103107

@@ -136,8 +140,8 @@ genNetwork =

136140 , do -- Build a convolution layer with one filter output

137141 -- Figure out some kernel sizes which work for this layer

138142 -- There must be a better way than this...

139− let output_r = natVal r

140− let output_c = natVal c

143+ let output_r = fromIntegral $ natVal r

144+ let output_c = fromIntegral $ natVal c

141145

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

143147

@@ -178,8 +182,8 @@ genNetwork =

178182 pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

179183 _ -> Gen.discard -- Can't occur

180184 , do -- Build a Pooling layer

181− let output_r = natVal r

182− let output_c = natVal c

185+ let output_r = fromIntegral $ natVal r

186+ let output_c = fromIntegral $ natVal c

183187

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

185189

@@ -215,8 +219,8 @@ genNetwork =

215219 pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

216220 _ -> Gen.discard -- Can't occur

217221 , do -- Build a Pad layer

218− let output_r = natVal r

219− let output_c = natVal c

222+ let output_r = fromIntegral $ natVal r

223+ let output_c = fromIntegral $ natVal c

220224

221225 pad_left <- choose 0 (output_r - 1)

222226 pad_right <- choose 0 (output_r - 1 - pad_left)

@@ -242,8 +246,8 @@ genNetwork =

242246 pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D2 inputRows inputColumns) ': h ': hs )))

243247 _ -> Gen.discard -- Can't occur

244248 , do -- Build a Crop layer

245− let output_r = natVal r

246− let output_c = natVal c

249+ let output_r = fromIntegral $ natVal r

250+ let output_c = fromIntegral $ natVal c

247251

248252 crop_left <- choose 0 10

249253 crop_right <- choose 0 10

@@ -275,9 +279,9 @@ genNetwork =

275279 , do -- Build a convolution layer with one filter output

276280 -- Figure out some kernel sizes which work for this layer

277281 -- There must be a better way than this...

278− let output_r = natVal r

279− let output_c = natVal c

280− let output_f = natVal f

282+ let output_r = fromIntegral $ natVal r

283+ let output_c = fromIntegral $ natVal c

284+ let output_f = fromIntegral $ natVal f

281285

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

283287

@@ -318,9 +322,9 @@ genNetwork =

318322 pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels filters kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))

319323 _ -> Gen.discard -- Can't occur

320324 , do -- Build a Pooling layer

321− let output_r = natVal r

322− let output_c = natVal c

323− let output_f = natVal f

325+ let output_r = fromIntegral $ natVal r

326+ let output_c = fromIntegral $ natVal c

327+ let output_f = fromIntegral $ natVal f

324328

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

326330

@@ -359,9 +363,9 @@ genNetwork =

359363 pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols filters) ': h ': hs )))

360364 _ -> Gen.discard -- Can't occur

361365 , do -- Build a Pad layer

362− let output_r = natVal r

363− let output_c = natVal c

364− let output_f = natVal f

366+ let output_r = fromIntegral $ natVal r

367+ let output_c = fromIntegral $ natVal c

368+ let output_f = fromIntegral $ natVal f

365369

366370 pad_left <- choose 0 (output_r - 1)

367371 pad_right <- choose 0 (output_r - 1 - pad_left)

@@ -389,9 +393,9 @@ genNetwork =

389393 pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))

390394 _ -> Gen.discard -- Can't occur

391395 , do -- Build a Crop layer

392− let output_r = natVal r

393− let output_c = natVal c

394− let output_f = natVal f

396+ let output_r = fromIntegral $ natVal r

397+ let output_c = fromIntegral $ natVal c

398+ let output_f = fromIntegral $ natVal f

395399

396400 crop_left <- choose 0 10

397401 crop_right <- choose 0 10

@@ -444,7 +448,7 @@ oneUp =

444448 D1Sing SNat ->

445449 let x = 0 :: S ( shape )

446450 in case x of

447− ( S1D x' ) -> do

451+ ( S1D x' ) -> do

448452 let ex = extract x'

449453 let len = VS.length ex

450454 ix <- choose 0 (len - 1)

@@ -456,7 +460,7 @@ oneUp =

456460 D2Sing SNat SNat ->

457461 let x = 0 :: S ( shape )

458462 in case x of

459− ( S2D x' ) -> do

463+ ( S2D x' ) -> do

460464 let ex = flatten ( extract x' )

461465 let len = VS.length ex

462466 ix <- choose 0 (len - 1)

@@ -468,7 +472,7 @@ oneUp =

468472 D3Sing SNat SNat SNat ->

469473 let x = 0 :: S ( shape )

470474 in case x of

471− ( S3D x' ) -> do

475+ ( S3D x' ) -> do

472476 let ex = flatten ( extract x' )

473477 let len = VS.length ex

474478 ix <- choose 0 (len - 1)

test/Test/Grenade/Recurrent/Layers/LSTM.hs+2−2

@@ -121,9 +121,9 @@ prop_lstm_reference_backwards_cell =

121121 , showPretty x

122122 , showPretty y

123123 ]

124− Just diff ->

124+ Just differ ->

125125 withFrozenCallStack $

126− failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" diff) ""

126+ failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" differ) ""

127127infix 4 ~~~

128128

129129tests :: IO Bool

test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+25−21

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

66{-# LANGUAGE DeriveFunctor #-}

77{-# LANGUAGE DeriveFoldable #-}

88{-# LANGUAGE DeriveTraversable #-}

9−{-# LANGUAGE RecordWildCards #-}

109{-# LANGUAGE FlexibleContexts #-}

1110{-# LANGUAGE RankNTypes #-}

1211

@@ -15,9 +14,13 @@ module Test.Grenade.Recurrent.Layers.LSTM.Reference where

1514

1615import Data.Reflection

1716import Numeric.AD.Mode.Reverse

18−import Numeric.AD.Internal.Reverse ( Tape )

17+import Numeric.AD.Internal.Reverse (Tape)

1918

19+import GHC.TypeLits (KnownNat)

20+

21+import Grenade.Recurrent.Layers.LSTM (LSTMWeights (..))

2022import qualified Grenade.Recurrent.Layers.LSTM as LSTM

23+

2124import qualified Numeric.LinearAlgebra.Static as S

2225import qualified Numeric.LinearAlgebra as H

2326

@@ -54,31 +57,32 @@ data RefLSTM a = RefLSTM

5457 , refLstmBc :: Vector a -- Bias Cell (b_c)

5558 } deriving (Functor, Foldable, Traversable, Eq, Show)

5659

57−lstmToReference :: LSTM.LSTMWeights a b -> RefLSTM Double

58−lstmToReference LSTM.LSTMWeights {..} =

59− let refLstmWf = Matrix . H.toLists . S.extract $ lstmWf -- Weight Forget (W_f)

60− refLstmUf = Matrix . H.toLists . S.extract $ lstmUf -- Cell State Forget (U_f)

61− refLstmBf = Vector . H.toList . S.extract $ lstmBf -- Bias Forget (b_f)

62− refLstmWi = Matrix . H.toLists . S.extract $ lstmWi -- Weight Input (W_i)

63− refLstmUi = Matrix . H.toLists . S.extract $ lstmUi -- Cell State Input (U_i)

64− refLstmBi = Vector . H.toList . S.extract $ lstmBi -- Bias Input (b_i)

65− refLstmWo = Matrix . H.toLists . S.extract $ lstmWo -- Weight Output (W_o)

66− refLstmUo = Matrix . H.toLists . S.extract $ lstmUo -- Cell State Output (U_o)

67− refLstmBo = Vector . H.toList . S.extract $ lstmBo -- Bias Output (b_o)

68− refLstmWc = Matrix . H.toLists . S.extract $ lstmWc -- Weight Cell (W_c)

69− refLstmBc = Vector . H.toList . S.extract $ lstmBc -- Bias Cell (b_c)

70− in RefLSTM {..}

60+lstmToReference :: (KnownNat a, KnownNat b) => LSTM.LSTMWeights a b -> RefLSTM Double

61+lstmToReference lw =

62+ RefLSTM

63+ { refLstmWf = Matrix . H.toLists . S.extract $ lstmWf lw -- Weight Forget (W_f)

64+ , refLstmUf = Matrix . H.toLists . S.extract $ lstmUf lw -- Cell State Forget (U_f)

65+ , refLstmBf = Vector . H.toList . S.extract $ lstmBf lw -- Bias Forget (b_f)

66+ , refLstmWi = Matrix . H.toLists . S.extract $ lstmWi lw -- Weight Input (W_i)

67+ , refLstmUi = Matrix . H.toLists . S.extract $ lstmUi lw -- Cell State Input (U_i)

68+ , refLstmBi = Vector . H.toList . S.extract $ lstmBi lw -- Bias Input (b_i)

69+ , refLstmWo = Matrix . H.toLists . S.extract $ lstmWo lw -- Weight Output (W_o)

70+ , refLstmUo = Matrix . H.toLists . S.extract $ lstmUo lw -- Cell State Output (U_o)

71+ , refLstmBo = Vector . H.toList . S.extract $ lstmBo lw -- Bias Output (b_o)

72+ , refLstmWc = Matrix . H.toLists . S.extract $ lstmWc lw -- Weight Cell (W_c)

73+ , refLstmBc = Vector . H.toList . S.extract $ lstmBc lw -- Bias Cell (b_c)

74+ }

7175

7276runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

73−runLSTM RefLSTM {..} cell input =

77+runLSTM rl cell input =

7478 let -- Forget state vector

75− f_t = sigmoid $ refLstmBf #+ refLstmWf #> input #+ refLstmUf #> cell

79+ f_t = sigmoid $ refLstmBf rl #+ refLstmWf rl #> input #+ refLstmUf rl #> cell

7680 -- Input state vector

77− i_t = sigmoid $ refLstmBi #+ refLstmWi #> input #+ refLstmUi #> cell

81+ i_t = sigmoid $ refLstmBi rl #+ refLstmWi rl #> input #+ refLstmUi rl #> cell

7882 -- Output state vector

79− o_t = sigmoid $ refLstmBo #+ refLstmWo #> input #+ refLstmUo #> cell

83+ o_t = sigmoid $ refLstmBo rl #+ refLstmWo rl #> input #+ refLstmUo rl #> cell

8084 -- Cell input state vector

81− c_x = fmap tanh $ refLstmBc #+ refLstmWc #> input

85+ c_x = fmap tanh $ refLstmBc rl #+ refLstmWc rl #> input

8286 -- Cell state

8387 c_t = f_t #* cell #+ i_t #* c_x

8488 -- Output (it's sometimes recommended to use tanh c_t)

test/Test/Hedgehog/Hmatrix.hs+3−2

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

1−{-# LANGUAGE RankNTypes #-}

21{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE KindSignatures #-}

43{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

56

67module Test.Hedgehog.Hmatrix where

78

test/Test/Hedgehog/TypeLits.hs+13−19

@@ -7,33 +7,27 @@

77{-# LANGUAGE GADTs #-}

88module Test.Hedgehog.TypeLits where

99

10−import Data.Constraint

11−#if __GLASGOW_HASKELL__ < 800

12−import Data.Proxy

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

1314#endif

14−import Data.Singletons

1515

1616import Hedgehog (Gen)

1717import qualified Hedgehog.Gen as Gen

1818

1919import Grenade

2020

21−import GHC.TypeLits

22−import GHC.TypeLits.Witnesses

23−import Test.Hedgehog.Compat

21+import GHC.TypeLits (SomeNat (..), natVal, someNatVal)

22+import GHC.TypeLits.Witnesses ((%*), natDict)

23+import Test.Hedgehog.Compat (choose)

2424

2525genNat :: Gen SomeNat

2626genNat = do

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

27+ ~(Just n) <- someNatVal <$> choose 1 10

2828 return n

2929

30−#if __GLASGOW_HASKELL__ < 800

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

32−#else

33−type Shape' = Shape

34−#endif

35−

36−genShape :: Gen (SomeSing Shape')

30+genShape :: Gen (SomeSing Shape)

3731genShape

3832 = Gen.choice [

3933 genD1

@@ -41,20 +35,20 @@ genShape

4135 , genD3

4236 ]

4337

44−genD1 :: Gen (SomeSing Shape')

38+genD1 :: Gen (SomeSing Shape)

4539genD1 = do

4640 n <- genNat

4741 return $ case n of

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

4943

50−genD2 :: Gen (SomeSing Shape')

44+genD2 :: Gen (SomeSing Shape)

5145genD2 = do

5246 n <- genNat

5347 m <- genNat

5448 return $ case (n, m) of

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

5650

57−genD3 :: Gen (SomeSing Shape')

51+genD3 :: Gen (SomeSing Shape)

5852genD3 = do

5953 n <- genNat

6054 m <- genNat

@@ -64,7 +58,7 @@ genD3 = do

6458 case natDict px %* natDict pz of

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

6660

67−rss :: SomeSing Shape' -> String

61+rss :: SomeSing Shape -> String

6862rss (SomeSing (r :: Sing s)) = case r of

6963 (D1Sing a@SNat) -> "D1 " ++ show (natVal a)

7064 (D2Sing a@SNat b@SNat) -> "D2 " ++ show (natVal a) ++ " " ++ show (natVal b)