master..f3fbebf · grenade

.gitignore+1−3

since splitsnapshots

unifiedsplit

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

1−cabal.project.local

2.cabal-sandbox/

1.cabal-sandbox/

3cabal.sandbox.config

2cabal.sandbox.config

4dist/

3dist/

5−dist-newstyle/

4+

6−.stack-work/

.travis.yml+12−12

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

2

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

4env:

5− - GHCVER=8.0.2

6− - GHCVER=8.2.2

7− - GHCVER=8.4.4

8− - GHCVER=8.6.5

9− - GHCVER=8.8.3

5+ - CABALVER=1.22 GHCVER=7.10.3

10− - GHCVER=8.10.1

6+ - CABALVER=1.24 GHCVER=8.0.2

7+ - CABALVER=2.0 GHCVER=8.2.2

8+ - CABALVER=2.0 GHCVER=8.4.3

11

9

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

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

13before_install:

11before_install:

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

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

15 - travis_retry sudo apt-get update

13 - travis_retry sudo apt-get update

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

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

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

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

18

16

19install:

17install:

18+ - cabal --version

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

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

21− - travis_retry cabal-3.2 update

20+ - travis_retry cabal update

21+ - cabal sandbox init

22+ - cabal install --enable-tests --enable-benchmarks

22

23

23notifications:

24notifications:

24 email: false

25 email: false

25

26

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

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

27script:

28script:

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

29− - cabal-3.2 build all

29+ - cabal build

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

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

31

examples/grenade-examples.cabal+9−10

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

26 , bytestring

27 , cereal

28 , either

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

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

30 , text == 1.2.*

31 , mtl >= 2.2.1 && < 2.3

32 , hmatrix

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

42 , grenade

43 , attoparsec

44 , either

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

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

46 , text == 1.2.*

47 , mtl >= 2.2.1 && < 2.3

48− , hmatrix >= 0.18 && < 0.21

48+ , hmatrix >= 0.18 && < 0.19

49 , transformers

50 , semigroups

51 , singletons

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

61 , bytestring

62 , cereal

63 , either

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

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

65 , text == 1.2.*

66 , mtl >= 2.2.1 && < 2.3

67− , hmatrix >= 0.18 && < 0.21

67+ , hmatrix >= 0.18 && < 0.19

68 , transformers

69 , semigroups

70 , singletons

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

78 , grenade

79 , attoparsec

80 , either

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

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

82 , text == 1.2.*

83 , mtl >= 2.2.1 && < 2.3

84− , hmatrix >= 0.18 && < 0.21

84+ , hmatrix >= 0.18 && < 0.19

85 , transformers

86 , semigroups

87 , singletons

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

96 , bytestring

97 , cereal

98 , either

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

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

100 , text == 1.2.*

101 , mtl >= 2.2.1 && < 2.3

102− , hmatrix >= 0.18 && < 0.21

102+ , hmatrix >= 0.18 && < 0.19

103 , transformers

104 , semigroups

105 , singletons

106− , singletons-base

107 , vector

106 , vector

108 , MonadRandom

107 , MonadRandom

109 , containers

108 , containers

examples/main/feedforward.hs+1−3

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

11

10

12import qualified Data.ByteString as B

11import qualified Data.ByteString as B

13import Data.Serialize

12import Data.Serialize

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

15import Data.Semigroup ( (<>) )

13import Data.Semigroup ( (<>) )

16−#endif

14+

17import GHC.TypeLits

15import GHC.TypeLits

18

16

19import qualified Numeric.LinearAlgebra.Static as SA

17import qualified Numeric.LinearAlgebra.Static as SA

examples/main/gan-mnist.hs−3

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

5{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

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

44import qualified Data.Attoparsec.Text as A

43import qualified Data.Attoparsec.Text as A

45import qualified Data.ByteString as B

44import qualified Data.ByteString as B

46import Data.List ( foldl' )

45import Data.List ( foldl' )

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

48import Data.Semigroup ( (<>) )

46import Data.Semigroup ( (<>) )

49−#endif

50import Data.Serialize

47import Data.Serialize

51import qualified Data.Text as T

48import qualified Data.Text as T

52import qualified Data.Text.IO as T

49import qualified Data.Text.IO as T

examples/main/mnist.hs−4

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

14

13

15import qualified Data.Attoparsec.Text as A

14import qualified Data.Attoparsec.Text as A

16import Data.List ( foldl' )

15import Data.List ( foldl' )

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

18import Data.Semigroup ( (<>) )

16import Data.Semigroup ( (<>) )

19−#endif

20−

21import qualified Data.Text as T

17import qualified Data.Text as T

22import qualified Data.Text.IO as T

18import qualified Data.Text.IO as T

23import qualified Data.Vector.Storable as V

19import qualified Data.Vector.Storable as V

examples/main/recurrent.hs+2−2

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

9import Control.Monad ( foldM )

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

11

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

12+#if __GLASGOW_HASKELL__ < 800

13import Data.List ( unfoldr )

14#else

15import Data.List ( cycle, unfoldr )

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

17#endif

16#endif

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

18

19import qualified Numeric.LinearAlgebra.Static as SA

20

examples/main/shakespeare.hs+16−16

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE CPP #-}

2+{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

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

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

14import Data.List ( foldl' )

15import Data.Maybe ( fromMaybe )

16−

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

17

18import qualified Data.Vector as V

19import Data.Vector ( Vector )

20

21import qualified Data.Map as M

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

22

23

23import qualified Data.ByteString as B

24import qualified Data.ByteString as B

24import Data.Serialize

25import Data.Serialize

25

26

27+import Data.Singletons.Prelude

26import GHC.TypeLits

28import GHC.TypeLits

27

29

28import Numeric.LinearAlgebra.Static ( konst )

30import Numeric.LinearAlgebra.Static ( konst )

@@ -34,8 +36,6 @@ import Grenade.Recurrent

34import Grenade.Utils.OneHot

36import Grenade.Utils.OneHot

35

37

36import System.IO.Unsafe ( unsafeInterleaveIO )

38import System.IO.Unsafe ( unsafeInterleaveIO )

37−import Data.Proxy

38−import Prelude.Singletons

39

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

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

@@ -77,34 +77,34 @@ loadShakespeare path = do

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

78

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

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

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

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

82 in case reverse e of

83 (o : l : xs) ->

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

85− in trainRecurrent lrate net recIns examples

85+ in trainRecurrent rate net recIns examples

86 _ -> error "Not enough input"

87 where

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

89

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

91−runShakespeare opts = do

91+runShakespeare ShakespeareOpts {..} = do

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

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

93 (net0, i0) <- lift $

94− case loadPath opts of

94+ case loadPath of

95 Just loadFile -> netLoad loadFile

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

97

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

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

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

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

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

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

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

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

103 putStrLn (unAnnotateCapitals results)

104 return (trained, bestInput)

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

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

106

107− case savePath opts of

107+ case savePath of

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

109 Nothing -> return ()

110

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

116 -> Vector a

117 -> S ('D1 n)

118 -> IO [a]

119−generateParagraph n s temp hotmap hotdict =

119+generateParagraph n s temperature hotmap hotdict =

120 go s

121 where

122 go x y =

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

124− un <- sample temp hotdict o

124+ un <- sample temperature hotdict o

125 Just re <- return $ makeHot hotmap un

126 rest <- unsafeInterleaveIO $ go ns re

127 return (un : rest)

grenade.cabal+8−23

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

8synopsis: Practical Deep Learning in Haskell

9category: AI, Machine Learning

10−cabal-version: >= 1.10

10+cabal-version: >= 1.8

11build-type: Simple

12description:

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

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

38library

39 build-depends:

40 base >= 4.8 && < 5

41− , bytestring >= 0.10.0

41+ , bytestring == 0.10.*

42− , containers >= 0.5 && < 0.7

42+ , containers >= 0.5 && < 0.6

43 , cereal >= 0.5 && < 0.6

44 , deepseq >= 1.4 && < 1.5

45− , hmatrix >= 0.18 && < 0.21

45+ , hmatrix == 0.18.*

46 , MonadRandom >= 0.4 && < 0.6

47− , primitive >= 0.6 && < 0.8

47+ , primitive >= 0.6 && < 0.7

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

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

50 , singletons

51− , singletons-base

52 , vector >= 0.11 && < 0.13

51 , vector >= 0.11 && < 0.13

53

52

54 ghc-options:

53 ghc-options:

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

56 hs-source-dirs:

55 hs-source-dirs:

57 src

56 src

58

57

59− default-language: Haskell2010

60−

61 if impl(ghc < 8.0)

58 if impl(ghc < 8.0)

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

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

63− cpp-options: -DType=*

64

60

65− if impl(ghc >= 8.6)

66− default-extensions: NoStarIsType

67

61

68 exposed-modules:

62 exposed-modules:

69 Grenade

63 Grenade

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

132 hs-source-dirs:

126 hs-source-dirs:

133 test

127 test

134

128

135− default-language: Haskell2010

136

129

137 other-modules: Test.Hedgehog.Compat

130 other-modules: Test.Hedgehog.Compat

138 Test.Hedgehog.Hmatrix

131 Test.Hedgehog.Hmatrix

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

153

146

154 if impl(ghc < 8.0)

147 if impl(ghc < 8.0)

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

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

156− cpp-options: -DType=*

157−

158− if impl(ghc >= 8.6)

159− default-extensions: NoStarIsType

160

149

161 build-depends:

150 build-depends:

162 base

151 base

163 , grenade

152 , grenade

164− , hedgehog >= 1.0 && < 1.1

153+ , hedgehog >= 0.5 && < 0.7

165 , hmatrix

154 , hmatrix

166 , mtl

155 , mtl

167 , singletons

156 , singletons

168 , text == 1.2.*

157 , text == 1.2.*

169− , typelits-witnesses < 0.4

158+ , typelits-witnesses

170 , transformers

159 , transformers

171 , constraints

160 , constraints

172 , MonadRandom

161 , MonadRandom

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

186 hs-source-dirs:

175 hs-source-dirs:

187 bench

176 bench

188

177

189− default-language: Haskell2010

190−

191 build-depends:

178 build-depends:

192 base

179 base

193 , bytestring

180 , bytestring

194− , criterion >= 1.1 && < 1.6

181+ , criterion >= 1.1 && < 1.5

195 , grenade

182 , grenade

196 , hmatrix

183 , hmatrix

197

184

@@ -205,8 +192,6 @@ benchmark bench-lstm

205 hs-source-dirs:

192 hs-source-dirs:

206 bench

193 bench

207

194

208− default-language: Haskell2010

209−

210 build-depends:

195 build-depends:

211 base

196 base

212 , bytestring

197 , bytestring

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

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

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

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

21

20

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

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

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

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

24to the input and output data of the layer.

23to the input and output data of the layer.

25

24

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

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

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

42

41

43import Data.List ( foldl' )

42import Data.List ( foldl' )

44

43

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

46−import Data.Kind (Type)

47−#endif

48−

49import Grenade.Core.Shape

44import Grenade.Core.Shape

50import Grenade.Core.LearningParameters

45import Grenade.Core.LearningParameters

51

46

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

55class UpdateLayer x where

50class UpdateLayer x where

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

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

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

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

58− type Gradient x :: Type

53+ type Gradient x :: *

59

54

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

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

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

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

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

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

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

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

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

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

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

80− type Tape x i o :: Type

75+ type Tape x i o :: *

81

76

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

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

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

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

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

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

34import Control.Monad.Random ( MonadRandom )

33import Control.Monad.Random ( MonadRandom )

35

34

36import Data.Singletons

35import Data.Singletons

36+import Data.Singletons.Prelude

37import Data.Serialize

38

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

40−import Data.Kind (Type)

41−#endif

42−

43import Grenade.Core.Layer

39import Grenade.Core.Layer

44import Grenade.Core.LearningParameters

40import Grenade.Core.LearningParameters

45import Grenade.Core.Shape

41import Grenade.Core.Shape

46−import Prelude.Singletons

47

42

48-- | Type of a network.

43-- | Type of a network.

49--

44--

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

53--

48--

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

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

55-- transform the data shapes of the network.

50-- transform the data shapes of the network.

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

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

57 NNil :: SingI i

52 NNil :: SingI i

58 => Network '[] '[i]

53 => Network '[] '[i]

59

54

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

71-- | Gradient of a network.

66-- | Gradient of a network.

72--

67--

73-- Parameterised on the layers of the network.

68-- Parameterised on the layers of the network.

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

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

75 GNil :: Gradients '[]

70 GNil :: Gradients '[]

76

71

77 (:/>) :: UpdateLayer x

72 (:/>) :: UpdateLayer x

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

82-- | Wegnert Tape of a network.

77-- | Wegnert Tape of a network.

83--

78--

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

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

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

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

86 TNil :: SingI i

81 TNil :: SingI i

87 => Tapes '[] '[i]

82 => Tapes '[] '[i]

88

83

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

157

152

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

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

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

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

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

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

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

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

162 --

157 --

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

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

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

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

13 , runNet

14 ) where

15

16+import Data.Singletons.Prelude

16

17

17import Grenade.Core.LearningParameters

18import Grenade.Core.LearningParameters

18import Grenade.Core.Network

19import Grenade.Core.Network

19import Grenade.Core.Shape

20import Grenade.Core.Shape

20−import Data.Singletons

21−import Prelude.Singletons

22

21

23-- | Perform reverse automatic differentiation on the network

22-- | Perform reverse automatic differentiation on the network

24-- for the current input and expected output.

23-- for the current input and expected output.

src/Grenade/Core/Shape.hs+25−28

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

8{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE UndecidableInstances #-}

12{-|

11{-|

13Module : Grenade.Core.Shape

12Module : Grenade.Core.Shape

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

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

@@ -19,22 +18,30 @@ Stability : experimental

19

18

20-}

19-}

21module Grenade.Core.Shape (

20module Grenade.Core.Shape (

21+ Shape (..)

22− S (..)

22+ , S (..)

23− , Shape (..)

23+ , Sing (..)

24− , SShape (..)

24+

25 , randomOfShape

26 , fromStorable

27 ) where

28

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

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

31−import Data.Kind (Type)

31+

32import Data.Proxy

33import Data.Serialize

34import Data.Singletons

35+import Data.Singletons.TypeLits

35import Data.Vector.Storable ( Vector )

36import Data.Vector.Storable ( Vector )

36import qualified Data.Vector.Storable as V

37import qualified Data.Vector.Storable as V

38+

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

40+import GHC.TypeLits hiding (natVal)

41+#else

37import GHC.TypeLits

42import GHC.TypeLits

43+#endif

44+

38import qualified Numeric.LinearAlgebra.Static as H

45import qualified Numeric.LinearAlgebra.Static as H

39import Numeric.LinearAlgebra.Static

46import Numeric.LinearAlgebra.Static

40import qualified Numeric.LinearAlgebra as NLA

47import qualified Numeric.LinearAlgebra as NLA

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

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

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

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

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

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

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

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

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

84−type instance Sing = SShape

85−

86−data SShape :: Shape -> Type where

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

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

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

90−#else

91data instance Sing (n :: Shape) where

89data instance Sing (n :: Shape) where

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

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

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

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

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

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

95−#endif

96

93

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

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

98− sing = D1Sing

95+ sing = D1Sing sing

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

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

100− sing = D2Sing

97+ sing = D2Sing sing sing

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

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

102− sing = D3Sing

99+ sing = D3Sing sing sing sing

103

100

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

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

105 (+) = n2 (+)

102 (+) = n2 (+)

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

148randomOfShape = do

145randomOfShape = do

149 seed :: Int <- getRandom

146 seed :: Int <- getRandom

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

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

151− D1Sing ->

148+ D1Sing SNat ->

152 S1D (randomVector seed Uniform * 2 - 1)

149 S1D (randomVector seed Uniform * 2 - 1)

153

150

154− D2Sing ->

151+ D2Sing SNat SNat ->

155 S2D (uniformSample seed (-1) 1)

152 S2D (uniformSample seed (-1) 1)

156

153

157− D3Sing ->

154+ D3Sing SNat SNat SNat ->

158 S3D (uniformSample seed (-1) 1)

155 S3D (uniformSample seed (-1) 1)

159

156

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

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

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

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

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

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

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

164fromStorable xs = case sing :: Sing x of

161fromStorable xs = case sing :: Sing x of

165− D1Sing ->

162+ D1Sing SNat ->

166 S1D <$> H.create xs

163 S1D <$> H.create xs

167

164

168− D2Sing ->

165+ D2Sing SNat SNat ->

169 S2D <$> mkL xs

166 S2D <$> mkL xs

170

167

171− D3Sing ->

168+ D3Sing SNat SNat SNat ->

172 S3D <$> mkL xs

169 S3D <$> mkL xs

173 where

170 where

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

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

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

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

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

206

203

207-- Helper function for creating the number instances

204-- Helper function for creating the number instances

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

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

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

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

210− D1Sing ->

207+ D1Sing SNat ->

211 S1D (konst x)

208 S1D (konst x)

212

209

213− D2Sing ->

210+ D2Sing SNat SNat ->

214 S2D (konst x)

211 S2D (konst x)

215

212

216− D3Sing ->

213+ D3Sing SNat SNat SNat ->

217 S3D (konst x)

214 S3D (konst x)

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

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

9{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FlexibleInstances #-}

10{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE StandaloneDeriving #-}

10{-# LANGUAGE StandaloneDeriving #-}

12−{-# LANGUAGE UndecidableInstances #-}

13{-|

11{-|

14Module : Grenade.Layers.Concat

12Module : Grenade.Layers.Concat

15Description : Concatenation layer

13Description : Concatenation layer

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

28import Data.Singletons

26import Data.Singletons

29import GHC.TypeLits

27import GHC.TypeLits

30

28

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

32−import Data.Kind (Type)

33−#endif

34−

35import Grenade.Core

29import Grenade.Core

36

30

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

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

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

49--

43--

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

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

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

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

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

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

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

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

54

48

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

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

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

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

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

5{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE UndecidableInstances #-}

11{-|

12Module : Grenade.Layers.Convolution

13Description : Convolution layer

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

28import Data.Maybe

29import Data.Proxy

30import Data.Serialize

31+import Data.Singletons.TypeLits

31

32

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

34+import GHC.TypeLits hiding (natVal)

35+#else

32import GHC.TypeLits

36import GHC.TypeLits

33−import Data.Kind (Type)

37+#endif

34

38

35import Numeric.LinearAlgebra hiding ( uniformSample, konst )

39import Numeric.LinearAlgebra hiding ( uniformSample, konst )

36import qualified Numeric.LinearAlgebra as LA

40import qualified Numeric.LinearAlgebra as LA

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

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

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

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

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

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

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

60− -> Type where

64+ -> * where

61 Convolution :: ( KnownNat channels

65 Convolution :: ( KnownNat channels

62 , KnownNat filters

66 , KnownNat filters

63 , KnownNat kernelRows

67 , KnownNat kernelRows

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

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

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

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

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

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

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

79− -> Type where

83+ -> * where

80 Convolution' :: ( KnownNat channels

84 Convolution' :: ( KnownNat channels

81 , KnownNat filters

85 , KnownNat filters

82 , KnownNat kernelRows

86 , KnownNat kernelRows

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

131 , KnownNat (kernelRows * kernelColumns * channels)

135 , KnownNat (kernelRows * kernelColumns * channels)

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

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

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

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

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

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

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

136 in Convolution newKernel newMomentum

140 in Convolution newKernel newMomentum

137

141

138 createRandom = randomConvolution

142 createRandom = randomConvolution

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

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

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE UndecidableInstances #-}

10{-|

9{-|

11Module : Grenade.Layers.Crop

10Module : Grenade.Layers.Crop

12Description : Cropping layer

11Description : Cropping layer

@@ -21,9 +20,13 @@ module Grenade.Layers.Crop (

21import Data.Maybe

20import Data.Maybe

22import Data.Proxy

21import Data.Proxy

23import Data.Serialize

22import Data.Serialize

23+import Data.Singletons.TypeLits

24

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

26+import GHC.TypeLits hiding (natVal)

27+#else

25import GHC.TypeLits

28import GHC.TypeLits

26−import Data.Kind (Type)

29+#endif

27

30

28import Grenade.Core

31import Grenade.Core

29import Grenade.Layers.Internal.Pad

32import Grenade.Layers.Internal.Pad

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

35data Crop :: Nat

38data Crop :: Nat

36 -> Nat

39 -> Nat

37 -> Nat

40 -> Nat

38− -> Nat -> Type where

41+ -> Nat -> * where

39 Crop :: Crop cropLeft cropTop cropRight cropBottom

42 Crop :: Crop cropLeft cropTop cropRight cropBottom

40

43

41instance Show (Crop cropLeft cropTop cropRight cropBottom) where

44instance Show (Crop cropLeft cropTop cropRight cropBottom) where

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

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

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

5{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE UndecidableInstances #-}

11{-|

12Module : Grenade.Layers.Deconvolution

13Description : Deconvolution layer

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

32import Data.Maybe

33import Data.Proxy

34import Data.Serialize

35+import Data.Singletons.TypeLits

35

36

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

38+import GHC.TypeLits hiding (natVal)

39+#else

36import GHC.TypeLits

40import GHC.TypeLits

37−import Data.Kind (Type)

41+#endif

38

42

39import Numeric.LinearAlgebra hiding ( uniformSample, konst )

43import Numeric.LinearAlgebra hiding ( uniformSample, konst )

40import qualified Numeric.LinearAlgebra as LA

44import qualified Numeric.LinearAlgebra as LA

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

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

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

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

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

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

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

59− -> Type where

63+ -> * where

60 Deconvolution :: ( KnownNat channels

64 Deconvolution :: ( KnownNat channels

61 , KnownNat filters

65 , KnownNat filters

62 , KnownNat kernelRows

66 , KnownNat kernelRows

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

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

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

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

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

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

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

78− -> Type where

82+ -> * where

79 Deconvolution' :: ( KnownNat channels

83 Deconvolution' :: ( KnownNat channels

80 , KnownNat filters

84 , KnownNat filters

81 , KnownNat kernelRows

85 , KnownNat kernelRows

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

130 , KnownNat (kernelRows * kernelColumns * filters)

134 , KnownNat (kernelRows * kernelColumns * filters)

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

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

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

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

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

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

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

135 in Deconvolution newKernel newMomentum

139 in Deconvolution newKernel newMomentum

136

140

137 createRandom = randomDeconvolution

141 createRandom = randomDeconvolution

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

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

1{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

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

13

14

14import Data.Proxy

15import Data.Proxy

15import Data.Serialize

16import Data.Serialize

17+import Data.Singletons.TypeLits

16

18

17import qualified Numeric.LinearAlgebra as LA

19import qualified Numeric.LinearAlgebra as LA

18import Numeric.LinearAlgebra.Static

20import Numeric.LinearAlgebra.Static

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

20import Grenade.Core

22import Grenade.Core

21

23

22import Grenade.Layers.Internal.Update

24import Grenade.Layers.Internal.Update

23−import GHC.TypeLits

24

25

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

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

26data FullyConnected i o = FullyConnected

27data FullyConnected i o = FullyConnected

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

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

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

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

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

39

40

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

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

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

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

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

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

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

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

44

45

45 createRandom = randomFullyConnected

46 createRandom = randomFullyConnected

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

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

24

23

25import Data.Singletons

24import Data.Singletons

26

25

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

28−import Data.Kind (Type)

29−#endif

30−

31import Grenade.Core

26import Grenade.Core

32

27

33-- | A Merging layer.

28-- | A Merging layer.

34--

29--

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

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

36-- shape.

31-- shape.

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

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

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

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

39

34

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

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

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

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

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE FlexibleContexts #-}

9−{-# LANGUAGE UndecidableInstances #-}

10{-|

9{-|

11Module : Grenade.Core.Pad

10Module : Grenade.Core.Pad

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

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

@@ -21,9 +20,13 @@ module Grenade.Layers.Pad (

21import Data.Maybe

20import Data.Maybe

22import Data.Proxy

21import Data.Proxy

23import Data.Serialize

22import Data.Serialize

23+import Data.Singletons.TypeLits

24

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

26+import GHC.TypeLits hiding (natVal)

27+#else

25import GHC.TypeLits

28import GHC.TypeLits

26−import Data.Kind (Type)

29+#endif

27

30

28import Grenade.Core

31import Grenade.Core

29import Grenade.Layers.Internal.Pad

32import Grenade.Layers.Internal.Pad

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

37data Pad :: Nat

40data Pad :: Nat

38 -> Nat

41 -> Nat

39 -> Nat

42 -> Nat

40− -> Nat -> Type where

43+ -> Nat -> * where

41 Pad :: Pad padLeft padTop padRight padBottom

44 Pad :: Pad padLeft padTop padRight padBottom

42

45

43instance Show (Pad padLeft padTop padRight padBottom) where

46instance Show (Pad padLeft padTop padRight padBottom) where

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

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

7{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE FlexibleContexts #-}

10−{-# LANGUAGE UndecidableInstances #-}

11{-|

10{-|

12Module : Grenade.Core.Pooling

11Module : Grenade.Core.Pooling

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

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

@@ -22,9 +21,13 @@ module Grenade.Layers.Pooling (

22import Data.Maybe

21import Data.Maybe

23import Data.Proxy

22import Data.Proxy

24import Data.Serialize

23import Data.Serialize

24+import Data.Singletons.TypeLits

25

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

27+import GHC.TypeLits hiding (natVal)

28+#else

26import GHC.TypeLits

29import GHC.TypeLits

27−import Data.Kind (Type)

30+#endif

28

31

29import Grenade.Core

32import Grenade.Core

30import Grenade.Layers.Internal.Pooling

33import Grenade.Layers.Internal.Pooling

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

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

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

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

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

41--

44--

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

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

43 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

46 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

44

47

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

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

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

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

3{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE UndecidableInstances #-}

7{-|

6{-|

8Module : Grenade.Layers.Reshape

7Module : Grenade.Layers.Reshape

9Description : Multipurpose reshaping layer

8Description : Multipurpose reshaping layer

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

17

16

18import Data.Serialize

17import Data.Serialize

19

18

19+import Data.Singletons.TypeLits

20import GHC.TypeLits

21

22import Numeric.LinearAlgebra.Static

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

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

9 , RecurrentUpdateLayer (..)

8 , RecurrentUpdateLayer (..)

10 ) where

9 ) where

11

10

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

13−import Data.Kind (Type)

14−#endif

15−

16import Grenade.Core

11import Grenade.Core

17

12

18-- | Class for a recurrent layer.

13-- | Class for a recurrent layer.

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

20-- of an extra recurrent data shape.

15-- of an extra recurrent data shape.

21class UpdateLayer x => RecurrentUpdateLayer x where

16class UpdateLayer x => RecurrentUpdateLayer x where

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

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

23− type RecurrentShape x :: Type

18+ type RecurrentShape x :: *

24

19

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

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

26 -- | Wengert Tape

21 -- | Wengert Tape

27− type RecTape x i o :: Type

22+ type RecTape x i o :: *

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

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

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

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

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

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

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

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

29

28

30

29

31import Control.Monad.Random ( MonadRandom )

30import Control.Monad.Random ( MonadRandom )

31+import Data.Singletons ( SingI )

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

32import Data.Serialize

33import Data.Serialize

33

34

34−import Data.Kind (Type)

35−

36import Grenade.Core

35import Grenade.Core

37import Grenade.Recurrent.Core.Layer

36import Grenade.Recurrent.Core.Layer

38−import Prelude.Singletons

39

37

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

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

41-- forward layer.

39-- forward layer.

42−data FeedForward :: Type -> Type

40+data FeedForward :: * -> *

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

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

44−data Recurrent :: Type -> Type

42+data Recurrent :: * -> *

45

43

46-- | Type of a recurrent neural network.

44-- | Type of a recurrent neural network.

47--

45--

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

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

49--

47--

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

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

51--

49--

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

54--

52--

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

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

56-- for these empty data types.

54-- for these empty data types.

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

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

58 RNil :: SingI i

56 RNil :: SingI i

59 => RecurrentNetwork '[] '[i]

57 => RecurrentNetwork '[] '[i]

60

58

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

73-- | Gradient of a network.

71-- | Gradient of a network.

74--

72--

75-- Parameterised on the layers of the network.

73-- Parameterised on the layers of the network.

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

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

77 RGNil :: RecurrentGradient '[]

75 RGNil :: RecurrentGradient '[]

78

76

79 (://>) :: UpdateLayer x

77 (://>) :: UpdateLayer x

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

83

81

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

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

85-- Parameterised on the layers of a Network.

83-- Parameterised on the layers of a Network.

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

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

87 RINil :: RecurrentInputs '[]

85 RINil :: RecurrentInputs '[]

88

86

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

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

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

97--

95--

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

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

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

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

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

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

101 TRNil :: SingI i

99 TRNil :: SingI i

102 => RecurrentTape '[] '[i]

100 => RecurrentTape '[] '[i]

103

101

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

206

204

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

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

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

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

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

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

210 -- | Create a network of the types requested

208 -- | Create a network of the types requested

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

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

212

210

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

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

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE RecordWildCards #-}

9

10

10module Grenade.Recurrent.Core.Runner (

11module Grenade.Recurrent.Core.Runner (

11 runRecurrentExamples

12 runRecurrentExamples

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

17 ) where

18 ) where

18

19

19import Data.List ( foldl' )

20import Data.List ( foldl' )

21+import Data.Singletons.Prelude

20import Grenade.Core

22import Grenade.Core

21

23

22import Grenade.Recurrent.Core.Network

24import Grenade.Recurrent.Core.Network

23−import Prelude.Singletons

24

25

25type RecurrentGradients layers = [RecurrentGradient layers]

26type RecurrentGradients layers = [RecurrentGradient layers]

26

27

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

100 -> RecurrentInputs sublayers

101 -> RecurrentInputs sublayers

102 -> RecurrentInputs sublayers

102

103

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

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

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

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

105

106

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

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

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

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

108

109

109updateRecInputs _ RINil RINil

110updateRecInputs _ RINil RINil

110 = RINil

111 = RINil

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

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

16

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

18

19−

20−import Data.Kind (Type)

19+import Data.Singletons.TypeLits

21

20

22import Numeric.LinearAlgebra.Static

21import Numeric.LinearAlgebra.Static

23

22

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

28

27

29data BasicRecurrent :: Nat -- Input layer size

28data BasicRecurrent :: Nat -- Input layer size

30 -> Nat -- Output layer size

29 -> Nat -- Output layer size

31− -> Type where

30+ -> * where

32 BasicRecurrent :: ( KnownNat input

31 BasicRecurrent :: ( KnownNat input

33 , KnownNat output

32 , KnownNat output

34 , KnownNat matrixCols

33 , KnownNat matrixCols

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

41

40

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

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

43 -> Nat -- Output layer size

42 -> Nat -- Output layer size

44− -> Type where

43+ -> * where

45 BasicRecurrent' :: ( KnownNat input

44 BasicRecurrent' :: ( KnownNat input

46 , KnownNat output

45 , KnownNat output

47 , KnownNat matrixCols

46 , KnownNat matrixCols

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

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

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

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

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

58

57

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

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

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

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

61 newBias = oldBias + newBiasMomentum

60 newBias = oldBias + newBiasMomentum

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

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

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

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

64 newActivations = oldActivations + newMomentum - regulariser

63 newActivations = oldActivations + newMomentum - regulariser

65 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

64 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

66

65

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

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

9{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FlexibleInstances #-}

10{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE StandaloneDeriving #-}

10{-# LANGUAGE StandaloneDeriving #-}

12−{-# LANGUAGE UndecidableInstances #-}

13{-|

11{-|

14Module : Grenade.Layers.Concat

12Module : Grenade.Layers.Concat

15Description : Concatenation layer

13Description : Concatenation layer

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

28import Data.Singletons

26import Data.Singletons

29import GHC.TypeLits

27import GHC.TypeLits

30

28

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

32−import Data.Kind (Type)

33−#endif

34−

35import Grenade.Core

29import Grenade.Core

36import Grenade.Recurrent.Core

30import Grenade.Recurrent.Core

37

31

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

50--

44--

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

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

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

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

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

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

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

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

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

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

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

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

5{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

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

21-- import Data.List ( foldl1' )

22import Data.Proxy

23import Data.Serialize

24−import Data.Kind (Type)

24+import Data.Singletons.TypeLits

25

26import qualified Numeric.LinearAlgebra as LA

27import Numeric.LinearAlgebra.Static

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

29import Grenade.Core

30import Grenade.Recurrent.Core

31import Grenade.Layers.Internal.Update

32−import GHC.TypeLits

33

32

34

33

35-- | Long Short Term Memory Recurrent unit

34-- | Long Short Term Memory Recurrent unit

@@ -37,14 +36,14 @@ import GHC.TypeLits

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

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

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

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

39-- at all.

38-- at all.

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

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

41 LSTM :: ( KnownNat input

40 LSTM :: ( KnownNat input

42 , KnownNat output

41 , KnownNat output

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

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

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

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

45 -> LSTM input output

44 -> LSTM input output

46

45

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

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

48 LSTMWeights :: ( KnownNat input

47 LSTMWeights :: ( KnownNat input

49 , KnownNat output

48 , KnownNat output

50 ) => {

49 ) => {

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

71

70

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

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

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

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

74− runUpdate lp (LSTM w m) g =

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

90+ descendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum

92

91

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

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

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

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

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

94+ descendVector learningRate learningMomentum learningRegulariser weights gradient momentum

96

95

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

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

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

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

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

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)

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

134 -- Forward propagation for the LSTM layer.

133 -- Forward propagation for the LSTM layer.

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

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

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

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

137 let -- Forget state vector

136 let -- Forget state vector

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

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

139 f_t = sigmoid f_s

138 f_t = sigmoid f_s

140 -- Input state vector

139 -- Input state vector

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

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

142 i_t = sigmoid i_s

141 i_t = sigmoid i_s

143 -- Output state vector

142 -- Output state vector

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

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

145 o_t = sigmoid o_s

144 o_t = sigmoid o_s

146 -- Cell input state vector

145 -- Cell input state vector

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

146+ c_s = lstmBc + lstmWc #> input

148 c_x = tanh c_s

147 c_x = tanh c_s

149 -- Cell state

148 -- Cell state

150 c_t = f_t * cell + i_t * c_x

149 c_t = f_t * cell + i_t * c_x

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

158 --

157 --

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

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

160 -- suite. These should match always.

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

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

162 let -- Reverse Mode AD Derivitives

161 let -- Reverse Mode AD Derivitives

163 c_t' = h_t' * o_t + cellGrad

162 c_t' = h_t' * o_t + cellGrad

164

163

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

175 c_s' = tanh' c_s * c_x'

174 c_s' = tanh' c_s * c_x'

176

175

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

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

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

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

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

180

179

181 -- Calculate the gradient Matricies for the input

180 -- Calculate the gradient Matricies for the input

182 lstmWf' = f_s' `outer` input

181 lstmWf' = f_s' `outer` input

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

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

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

236

235

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

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

238− put (LSTM lw _) = do

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

239− u (lstmWf lw)

238+ u lstmWf

240− u (lstmUf lw)

239+ u lstmUf

241− v (lstmBf lw)

240+ v lstmBf

242− u (lstmWi lw)

241+ u lstmWi

243− u (lstmUi lw)

242+ u lstmUi

244− v (lstmBi lw)

243+ v lstmBi

245− u (lstmWo lw)

244+ u lstmWo

246− u (lstmUo lw)

245+ u lstmUo

247− v (lstmBo lw)

246+ v lstmBo

248− u (lstmWc lw)

247+ u lstmWc

249− v (lstmBc lw)

248+ v lstmBc

250− where

249+ where

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

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

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

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

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

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

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

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

255

254

256 get = do

255 get = do

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

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

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

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

259− where

268+ where

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

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

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

270+ 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

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

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

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

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

265−

274+

266− w0 = konst 0

275+ w0 = konst 0

267− u0 = konst 0

276+ u0 = konst 0

268− v0 = konst 0

277+ v0 = konst 0

src/Grenade/Utils/OneHot.hs+1−1

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

22import qualified Data.Map as M

23

24import Data.Proxy

25+import Data.Singletons.TypeLits

25

26

26import Data.Vector ( Vector )

27import Data.Vector ( Vector )

27import qualified Data.Vector as V

28import qualified Data.Vector as V

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

30import Numeric.LinearAlgebra ( maxIndex )

31import Numeric.LinearAlgebra ( maxIndex )

31import Numeric.LinearAlgebra.Devel

32import Numeric.LinearAlgebra.Devel

32import Numeric.LinearAlgebra.Static

33import Numeric.LinearAlgebra.Static

33−import GHC.TypeLits

34

35import Grenade.Core.Shape

36

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE TemplateHaskell #-}

1{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

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

16import GHC.TypeLits

15import GHC.TypeLits

17import GHC.TypeLits.Witnesses

16import GHC.TypeLits.Witnesses

18

17

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

20−import Data.Kind (Type)

21−#endif

22−

23import Grenade.Core

18import Grenade.Core

24import Grenade.Layers.Convolution

19import Grenade.Layers.Convolution

25

20

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

30import Test.Hedgehog.TypeLits

25import Test.Hedgehog.TypeLits

31import Test.Hedgehog.Compat

26import Test.Hedgehog.Compat

32

27

33−data OpaqueConvolution :: Type where

28+data OpaqueConvolution :: * where

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

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

35

30

36instance Show OpaqueConvolution where

31instance Show OpaqueConvolution where

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

4{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

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

13

12

14import GHC.TypeLits

13import GHC.TypeLits

15

14

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

17−import Data.Kind (Type)

18−#endif

19−

20import Grenade.Core

15import Grenade.Core

21import Grenade.Layers.FullyConnected

16import Grenade.Layers.FullyConnected

22

17

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

25import Test.Hedgehog.Compat

20import Test.Hedgehog.Compat

26import Test.Hedgehog.Hmatrix

21import Test.Hedgehog.Hmatrix

27

22

28−data OpaqueFullyConnected :: Type where

23+data OpaqueFullyConnected :: * where

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

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

30

25

31instance Show OpaqueFullyConnected where

26instance Show OpaqueFullyConnected where

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

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

7{-# LANGUAGE ScopedTypeVariables #-}

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

9

10+#if __GLASGOW_HASKELL__ < 800

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

12+#endif

13+

10module Test.Grenade.Layers.PadCrop where

14module Test.Grenade.Layers.PadCrop where

11

15

12import Grenade

16import Grenade

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

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE TemplateHaskell #-}

1{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE KindSignatures #-}

3{-# LANGUAGE KindSignatures #-}

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

10import Data.Proxy

9import Data.Proxy

11import Data.Singletons ()

10import Data.Singletons ()

12

11

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

14−import Data.Kind (Type)

15−#endif

16−

17import GHC.TypeLits

12import GHC.TypeLits

18import Grenade.Layers.Pooling

13import Grenade.Layers.Pooling

19

14

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

21

16

22import Test.Hedgehog.Compat

17import Test.Hedgehog.Compat

23

18

24−data OpaquePooling :: Type where

19+data OpaquePooling :: * where

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

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

26

21

27instance Show OpaquePooling where

22instance Show OpaquePooling where

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

29

24

30genOpaquePooling :: Gen OpaquePooling

25genOpaquePooling :: Gen OpaquePooling

31genOpaquePooling = do

26genOpaquePooling = do

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

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

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

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

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

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

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

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

36

31

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

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

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

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

test/Test/Grenade/Network.hs+7−7

@@ -14,6 +14,9 @@ import Control.Monad ( guard )

14import Control.Monad.ST ( runST )

15

16import Data.Constraint

17+#if __GLASGOW_HASKELL__ < 800

18+import Data.Proxy

19+#endif

17import qualified Data.Vector.Storable as VS

20import qualified Data.Vector.Storable as VS

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

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

19import Data.Singletons

22import Data.Singletons

@@ -32,9 +35,6 @@ import GHC.TypeLits hiding (natVal)

32#else

35#else

33import GHC.TypeLits

36import GHC.TypeLits

34#endif

37#endif

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

36−import Data.Kind (Type)

37−#endif

38

39import GHC.TypeLits.Witnesses

40import Test.Hedgehog.Compat

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

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

47import Unsafe.Coerce

48

49−data SomeNetwork :: Type where

49+data SomeNetwork :: * where

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

51

52instance Show SomeNetwork where

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

448 D1Sing SNat ->

449 let x = 0 :: S ( shape )

450 in case x of

451− ( S1D x' ) -> do

451+ ( S1D x' ) -> do

452 let ex = extract x'

453 let len = VS.length ex

454 ix <- choose 0 (len - 1)

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

460 D2Sing SNat SNat ->

461 let x = 0 :: S ( shape )

462 in case x of

463− ( S2D x' ) -> do

463+ ( S2D x' ) -> do

464 let ex = flatten ( extract x' )

465 let len = VS.length ex

466 ix <- choose 0 (len - 1)

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

472 D3Sing SNat SNat SNat ->

473 let x = 0 :: S ( shape )

474 in case x of

475− ( S3D x' ) -> do

475+ ( S3D x' ) -> do

476 let ex = flatten ( extract x' )

477 let len = VS.length ex

478 ix <- choose 0 (len - 1)

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

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

121 , showPretty x

122 , showPretty y

123 ]

124− Just differ ->

124+ Just diff ->

125 withFrozenCallStack $

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

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

127infix 4 ~~~

128

129tests :: IO Bool

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

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

6{-# LANGUAGE DeriveFunctor #-}

7{-# LANGUAGE DeriveFoldable #-}

8{-# LANGUAGE DeriveTraversable #-}

9+{-# LANGUAGE RecordWildCards #-}

9{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE RankNTypes #-}

11

12

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

14

15

15import Data.Reflection

16import Data.Reflection

16import Numeric.AD.Mode.Reverse

17import Numeric.AD.Mode.Reverse

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

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

18

19

19−import GHC.TypeLits (KnownNat)

20−

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

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

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

23−

24import qualified Numeric.LinearAlgebra.Static as S

21import qualified Numeric.LinearAlgebra.Static as S

25import qualified Numeric.LinearAlgebra as H

22import qualified Numeric.LinearAlgebra as H

26

23

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

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

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

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

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

59

56

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

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

61−lstmToReference lw =

58+lstmToReference LSTM.LSTMWeights {..} =

62− RefLSTM

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

74− }

70+ in RefLSTM {..}

75

71

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

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

77−runLSTM rl cell input =

73+runLSTM RefLSTM {..} cell input =

78 let -- Forget state vector

74 let -- Forget state vector

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

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

80 -- Input state vector

76 -- Input state vector

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

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

82 -- Output state vector

78 -- Output state vector

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

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

84 -- Cell input state vector

80 -- Cell input state vector

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

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

86 -- Cell state

82 -- Cell state

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

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

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

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

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

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE KindSignatures #-}

3−{-# LANGUAGE GADTs #-}

4{-# LANGUAGE RankNTypes #-}

1{-# LANGUAGE RankNTypes #-}

2+{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE GADTs #-}

6

5

7module Test.Hedgehog.Hmatrix where

6module Test.Hedgehog.Hmatrix where

8

7

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

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

7{-# LANGUAGE GADTs #-}

8module Test.Hedgehog.TypeLits where

9

10−import Data.Constraint (Dict (..))

10+import Data.Constraint

11−import Data.Singletons (Proxy (..), Sing (..), SomeSing (..), sing)

11+#if __GLASGOW_HASKELL__ < 800

12−#if MIN_VERSION_singletons(2,6,0)

13−import Data.Singletons.TypeLits (SNat (..))

12+import Data.Proxy

14#endif

13#endif

14+import Data.Singletons

15

16import Hedgehog (Gen)

17import qualified Hedgehog.Gen as Gen

18

19import Grenade

20

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

21+import GHC.TypeLits

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

22+import GHC.TypeLits.Witnesses

23−import Test.Hedgehog.Compat (choose)

23+import Test.Hedgehog.Compat

24

25genNat :: Gen SomeNat

26genNat = do

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

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

28 return n

29

30+#if __GLASGOW_HASKELL__ < 800

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

32+#else

33+type Shape' = Shape

34+#endif

35+

30−genShape :: Gen (SomeSing Shape)

36+genShape :: Gen (SomeSing Shape')

31genShape

37genShape

32 = Gen.choice [

38 = Gen.choice [

33 genD1

39 genD1

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

35 , genD3

41 , genD3

36 ]

42 ]

37

43

38−genD1 :: Gen (SomeSing Shape)

44+genD1 :: Gen (SomeSing Shape')

39genD1 = do

45genD1 = do

40 n <- genNat

46 n <- genNat

41 return $ case n of

47 return $ case n of

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

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

43

49

44−genD2 :: Gen (SomeSing Shape)

50+genD2 :: Gen (SomeSing Shape')

45genD2 = do

51genD2 = do

46 n <- genNat

52 n <- genNat

47 m <- genNat

53 m <- genNat

48 return $ case (n, m) of

54 return $ case (n, m) of

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

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

50

56

51−genD3 :: Gen (SomeSing Shape)

57+genD3 :: Gen (SomeSing Shape')

52genD3 = do

58genD3 = do

53 n <- genNat

59 n <- genNat

54 m <- genNat

60 m <- genNat

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

58 case natDict px %* natDict pz of

64 case natDict px %* natDict pz of

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

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

60

66

61−rss :: SomeSing Shape -> String

67+rss :: SomeSing Shape' -> String

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

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

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

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

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

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