master..d84113c · 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+11−12

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

2

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

4env:

5− - GHCVER=8.0.2

5+ - CABALVER=1.24 GHCVER=8.0.2

6− - GHCVER=8.2.2

6+ - CABALVER=2.0 GHCVER=8.2.2

7− - GHCVER=8.4.4

7+ - CABALVER=2.0 GHCVER=8.4.4

8− - GHCVER=8.6.5

9− - GHCVER=8.8.3

10− - GHCVER=8.10.1

11

8

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

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

13before_install:

10before_install:

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

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

15 - travis_retry sudo apt-get update

12 - travis_retry sudo apt-get update

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

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

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

18

15

19install:

16install:

17+ - cabal --version

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

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

21− - travis_retry cabal-3.2 update

19+ - travis_retry cabal update

20+ - cabal sandbox init

21+ - cabal install --enable-tests --enable-benchmarks

22

23notifications:

24 email: false

25

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.

27script:

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

29− - cabal-3.2 build all

28+ - cabal build

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

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

31

30

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+2−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 #-}

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