1d93071...master · grenade

.gitignore+3−1

since splitsnapshots

unifiedsplit

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

1+cabal.project.local

1.cabal-sandbox/

2.cabal-sandbox/

2cabal.sandbox.config

3cabal.sandbox.config

3dist/

4dist/

4−

5+dist-newstyle/

6+.stack-work/

.travis.yml+12−11

@@ -2,29 +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− - CABALVER=1.24 GHCVER=8.0.2

5+ - GHCVER=8.0.2

6− - CABALVER=2.0 GHCVER=8.2.2

6+ - GHCVER=8.2.2

7− - CABALVER=2.0 GHCVER=8.4.4

7+ - GHCVER=8.4.4

8+ - GHCVER=8.6.5

9+ - GHCVER=8.8.3

10+ - GHCVER=8.10.1

8

11

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

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

10before_install:

13before_install:

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

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

12 - travis_retry sudo apt-get update

15 - travis_retry sudo apt-get update

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

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

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

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

15

18

16install:

19install:

17− - cabal --version

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

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

19− - travis_retry cabal update

21+ - travis_retry cabal-3.2 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

28− - cabal build

29+ - cabal-3.2 build all

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

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

30

31

examples/grenade-examples.cabal+10−9

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

26 , bytestring

27 , cereal

28 , either

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

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

30 , text == 1.2.*

31 , mtl >= 2.2.1 && < 2.3

32 , hmatrix

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

42 , grenade

43 , attoparsec

44 , either

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

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

46 , text == 1.2.*

47 , mtl >= 2.2.1 && < 2.3

48− , hmatrix >= 0.18 && < 0.19

48+ , hmatrix >= 0.18 && < 0.21

49 , transformers

50 , semigroups

51 , singletons

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

61 , bytestring

62 , cereal

63 , either

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

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

65 , text == 1.2.*

66 , mtl >= 2.2.1 && < 2.3

67− , hmatrix >= 0.18 && < 0.19

67+ , hmatrix >= 0.18 && < 0.21

68 , transformers

69 , semigroups

70 , singletons

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

78 , grenade

79 , attoparsec

80 , either

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

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

82 , text == 1.2.*

83 , mtl >= 2.2.1 && < 2.3

84− , hmatrix >= 0.18 && < 0.19

84+ , hmatrix >= 0.18 && < 0.21

85 , transformers

86 , semigroups

87 , singletons

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

96 , bytestring

97 , cereal

98 , either

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

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

100 , text == 1.2.*

101 , mtl >= 2.2.1 && < 2.3

102− , hmatrix >= 0.18 && < 0.19

102+ , hmatrix >= 0.18 && < 0.21

103 , transformers

104 , semigroups

105 , singletons

106+ , singletons-base

106 , vector

107 , vector

107 , MonadRandom

108 , MonadRandom

108 , containers

109 , containers

examples/main/feedforward.hs+3−1

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

1{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

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

10

11

11import qualified Data.ByteString as B

12import qualified Data.ByteString as B

12import Data.Serialize

13import Data.Serialize

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

13import Data.Semigroup ( (<>) )

15import Data.Semigroup ( (<>) )

14−

16+#endif

15import GHC.TypeLits

17import GHC.TypeLits

16

18

17import qualified Numeric.LinearAlgebra.Static as SA

19import qualified Numeric.LinearAlgebra.Static as SA

examples/main/gan-mnist.hs+3

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

1{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ScopedTypeVariables #-}

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

43import qualified Data.Attoparsec.Text as A

44import qualified Data.Attoparsec.Text as A

44import qualified Data.ByteString as B

45import qualified Data.ByteString as B

45import Data.List ( foldl' )

46import Data.List ( foldl' )

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

46import Data.Semigroup ( (<>) )

48import Data.Semigroup ( (<>) )

49+#endif

47import Data.Serialize

50import Data.Serialize

48import qualified Data.Text as T

51import qualified Data.Text as T

49import qualified Data.Text.IO as T

52import qualified Data.Text.IO as T

examples/main/mnist.hs+4

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

1{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

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

13

14

14import qualified Data.Attoparsec.Text as A

15import qualified Data.Attoparsec.Text as A

15import Data.List ( foldl' )

16import Data.List ( foldl' )

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

16import Data.Semigroup ( (<>) )

18import Data.Semigroup ( (<>) )

19+#endif

20+

17import qualified Data.Text as T

21import qualified Data.Text as T

18import qualified Data.Text.IO as T

22import qualified Data.Text.IO as T

19import qualified Data.Vector.Storable as V

23import qualified Data.Vector.Storable as V

examples/main/recurrent.hs+2−2

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

9import Control.Monad ( foldM )

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

11

12−#if __GLASGOW_HASKELL__ < 800

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

13import Data.List ( unfoldr )

14#else

15import Data.List ( cycle, unfoldr )

16−#endif

17import Data.Semigroup ( (<>) )

16import Data.Semigroup ( (<>) )

17+#endif

18

19import qualified Numeric.LinearAlgebra.Static as SA

20

examples/main/shakespeare.hs+16−16

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

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

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

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

14import Data.List ( foldl' )

15import Data.Maybe ( fromMaybe )

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

16+

17

18import qualified Data.Vector as V

19import Data.Vector ( Vector )

20

21import qualified Data.Map as M

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

23

22

24import qualified Data.ByteString as B

23import qualified Data.ByteString as B

25import Data.Serialize

24import Data.Serialize

26

25

27−import Data.Singletons.Prelude

28import GHC.TypeLits

26import GHC.TypeLits

29

27

30import Numeric.LinearAlgebra.Static ( konst )

28import Numeric.LinearAlgebra.Static ( konst )

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

36import Grenade.Utils.OneHot

34import Grenade.Utils.OneHot

37

35

38import System.IO.Unsafe ( unsafeInterleaveIO )

36import System.IO.Unsafe ( unsafeInterleaveIO )

37+import Data.Proxy

38+import Prelude.Singletons

39

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

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

@@ -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 !rate !net !recIns input offset size =

80+trainSlice !lrate !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 rate net recIns examples

85+ in trainRecurrent lrate 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 ShakespeareOpts {..} = do

91+runShakespeare opts = do

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

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

93 (net0, i0) <- lift $

94− case loadPath of

94+ case loadPath opts of

95 Just loadFile -> netLoad loadFile

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

97

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

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

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

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

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

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

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

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

103 putStrLn (unAnnotateCapitals results)

104 return (trained, bestInput)

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

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

106

107− case savePath of

107+ case savePath opts 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 temperature hotmap hotdict =

119+generateParagraph n s temp hotmap hotdict =

120 go s

121 where

122 go x y =

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

124− un <- sample temperature hotdict o

124+ un <- sample temp hotdict o

125 Just re <- return $ makeHot hotmap un

126 rest <- unsafeInterleaveIO $ go ns re

127 return (un : rest)

grenade.cabal+23−8

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

8synopsis: Practical Deep Learning in Haskell

9category: AI, Machine Learning

10−cabal-version: >= 1.8

10+cabal-version: >= 1.10

11build-type: Simple

12description:

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

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

38library

39 build-depends:

40 base >= 4.8 && < 5

41− , bytestring == 0.10.*

41+ , bytestring >= 0.10.0

42− , containers >= 0.5 && < 0.6

42+ , containers >= 0.5 && < 0.7

43 , cereal >= 0.5 && < 0.6

44 , deepseq >= 1.4 && < 1.5

45− , hmatrix == 0.18.*

45+ , hmatrix >= 0.18 && < 0.21

46 , MonadRandom >= 0.4 && < 0.6

47− , primitive >= 0.6 && < 0.7

47+ , primitive >= 0.6 && < 0.8

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

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

50 , singletons

51+ , singletons-base

51 , vector >= 0.11 && < 0.13

52 , vector >= 0.11 && < 0.13

52

53

53 ghc-options:

54 ghc-options:

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

55 hs-source-dirs:

56 hs-source-dirs:

56 src

57 src

57

58

59+ default-language: Haskell2010

60+

58 if impl(ghc < 8.0)

61 if impl(ghc < 8.0)

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

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

63+ cpp-options: -DType=*

60

64

65+ if impl(ghc >= 8.6)

66+ default-extensions: NoStarIsType

61

67

62 exposed-modules:

68 exposed-modules:

63 Grenade

69 Grenade

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

126 hs-source-dirs:

132 hs-source-dirs:

127 test

133 test

128

134

135+ default-language: Haskell2010

129

136

130 other-modules: Test.Hedgehog.Compat

137 other-modules: Test.Hedgehog.Compat

131 Test.Hedgehog.Hmatrix

138 Test.Hedgehog.Hmatrix

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

146

153

147 if impl(ghc < 8.0)

154 if impl(ghc < 8.0)

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

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

156+ cpp-options: -DType=*

157+

158+ if impl(ghc >= 8.6)

159+ default-extensions: NoStarIsType

149

160

150 build-depends:

161 build-depends:

151 base

162 base

152 , grenade

163 , grenade

153− , hedgehog >= 0.5 && < 0.7

164+ , hedgehog >= 1.0 && < 1.1

154 , hmatrix

165 , hmatrix

155 , mtl

166 , mtl

156 , singletons

167 , singletons

157 , text == 1.2.*

168 , text == 1.2.*

158− , typelits-witnesses

169+ , typelits-witnesses < 0.4

159 , transformers

170 , transformers

160 , constraints

171 , constraints

161 , MonadRandom

172 , MonadRandom

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

175 hs-source-dirs:

186 hs-source-dirs:

176 bench

187 bench

177

188

189+ default-language: Haskell2010

190+

178 build-depends:

191 build-depends:

179 base

192 base

180 , bytestring

193 , bytestring

181− , criterion >= 1.1 && < 1.5

194+ , criterion >= 1.1 && < 1.6

182 , grenade

195 , grenade

183 , hmatrix

196 , hmatrix

184

197

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

192 hs-source-dirs:

205 hs-source-dirs:

193 bench

206 bench

194

207

208+ default-language: Haskell2010

209+

195 build-depends:

210 build-depends:

196 base

211 base

197 , bytestring

212 , bytestring

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

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

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

20

21

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

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

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

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

23to the input and output data of the layer.

24to the input and output data of the layer.

24

25

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

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

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

41

42

42import Data.List ( foldl' )

43import Data.List ( foldl' )

43

44

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

46+import Data.Kind (Type)

47+#endif

48+

44import Grenade.Core.Shape

49import Grenade.Core.Shape

45import Grenade.Core.LearningParameters

50import Grenade.Core.LearningParameters

46

51

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

50class UpdateLayer x where

55class UpdateLayer x where

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

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

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

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

53− type Gradient x :: *

58+ type Gradient x :: Type

54

59

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

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

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

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

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

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

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

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

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

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

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

75− type Tape x i o :: *

80+ type Tape x i o :: Type

76

81

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

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

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

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

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

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

33import Control.Monad.Random ( MonadRandom )

34import Control.Monad.Random ( MonadRandom )

34

35

35import Data.Singletons

36import Data.Singletons

36−import Data.Singletons.Prelude

37import Data.Serialize

38

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

40+import Data.Kind (Type)

41+#endif

42+

39import Grenade.Core.Layer

43import Grenade.Core.Layer

40import Grenade.Core.LearningParameters

44import Grenade.Core.LearningParameters

41import Grenade.Core.Shape

45import Grenade.Core.Shape

46+import Prelude.Singletons

42

47

43-- | Type of a network.

48-- | Type of a network.

44--

49--

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

48--

53--

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

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

50-- transform the data shapes of the network.

55-- transform the data shapes of the network.

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

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

52 NNil :: SingI i

57 NNil :: SingI i

53 => Network '[] '[i]

58 => Network '[] '[i]

54

59

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

66-- | Gradient of a network.

71-- | Gradient of a network.

67--

72--

68-- Parameterised on the layers of the network.

73-- Parameterised on the layers of the network.

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

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

70 GNil :: Gradients '[]

75 GNil :: Gradients '[]

71

76

72 (:/>) :: UpdateLayer x

77 (:/>) :: UpdateLayer x

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

77-- | Wegnert Tape of a network.

82-- | Wegnert Tape of a network.

78--

83--

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

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

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

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

81 TNil :: SingI i

86 TNil :: SingI i

82 => Tapes '[] '[i]

87 => Tapes '[] '[i]

83

88

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

152

157

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

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

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

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

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

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

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

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

157 --

162 --

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

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

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

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

13 , runNet

14 ) where

15

16−import Data.Singletons.Prelude

17

16

18import Grenade.Core.LearningParameters

17import Grenade.Core.LearningParameters

19import Grenade.Core.Network

18import Grenade.Core.Network

20import Grenade.Core.Shape

19import Grenade.Core.Shape

20+import Data.Singletons

21+import Prelude.Singletons

21

22

22-- | Perform reverse automatic differentiation on the network

23-- | Perform reverse automatic differentiation on the network

23-- for the current input and expected output.

24-- for the current input and expected output.

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

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

8{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE UndecidableInstances #-}

11{-|

12{-|

12Module : Grenade.Core.Shape

13Module : Grenade.Core.Shape

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

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

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

18

19

19-}

20-}

20module Grenade.Core.Shape (

21module Grenade.Core.Shape (

22+ S (..)

21− Shape (..)

23+ , Shape (..)

22− , S (..)

24+ , SShape (..)

23− , Sing (..)

24−

25 , randomOfShape

26 , fromStorable

27 ) where

28

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

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

31−

31+import Data.Kind (Type)

32import Data.Proxy

33import Data.Serialize

34import Data.Singletons

35−import Data.Singletons.TypeLits

36import Data.Vector.Storable ( Vector )

35import Data.Vector.Storable ( Vector )

37import qualified Data.Vector.Storable as V

36import qualified Data.Vector.Storable as V

38−

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

40−import GHC.TypeLits hiding (natVal)

41−#else

42import GHC.TypeLits

37import GHC.TypeLits

43−#endif

44−

45import qualified Numeric.LinearAlgebra.Static as H

38import qualified Numeric.LinearAlgebra.Static as H

46import Numeric.LinearAlgebra.Static

39import Numeric.LinearAlgebra.Static

47import qualified Numeric.LinearAlgebra as NLA

40import qualified Numeric.LinearAlgebra as NLA

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

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

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

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

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

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

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

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

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

84+type instance Sing = SShape

85+

86+data SShape :: Shape -> Type where

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

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

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

90+#else

89data instance Sing (n :: Shape) where

91data instance Sing (n :: Shape) where

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

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

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

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

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

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

95+#endif

93

96

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

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

95− sing = D1Sing sing

98+ sing = D1Sing

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

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

97− sing = D2Sing sing sing

100+ sing = D2Sing

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

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

99− sing = D3Sing sing sing sing

102+ sing = D3Sing

100

103

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

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

102 (+) = n2 (+)

105 (+) = n2 (+)

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

145randomOfShape = do

148randomOfShape = do

146 seed :: Int <- getRandom

149 seed :: Int <- getRandom

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

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

148− D1Sing SNat ->

151+ D1Sing ->

149 S1D (randomVector seed Uniform * 2 - 1)

152 S1D (randomVector seed Uniform * 2 - 1)

150

153

151− D2Sing SNat SNat ->

154+ D2Sing ->

152 S2D (uniformSample seed (-1) 1)

155 S2D (uniformSample seed (-1) 1)

153

156

154− D3Sing SNat SNat SNat ->

157+ D3Sing ->

155 S3D (uniformSample seed (-1) 1)

158 S3D (uniformSample seed (-1) 1)

156

159

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

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

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

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

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

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

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

161fromStorable xs = case sing :: Sing x of

164fromStorable xs = case sing :: Sing x of

162− D1Sing SNat ->

165+ D1Sing ->

163 S1D <$> H.create xs

166 S1D <$> H.create xs

164

167

165− D2Sing SNat SNat ->

168+ D2Sing ->

166 S2D <$> mkL xs

169 S2D <$> mkL xs

167

170

168− D3Sing SNat SNat SNat ->

171+ D3Sing ->

169 S3D <$> mkL xs

172 S3D <$> mkL xs

170 where

173 where

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

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

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

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

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

203

206

204-- Helper function for creating the number instances

207-- Helper function for creating the number instances

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

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

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

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

207− D1Sing SNat ->

210+ D1Sing ->

208 S1D (konst x)

211 S1D (konst x)

209

212

210− D2Sing SNat SNat ->

213+ D2Sing ->

211 S2D (konst x)

214 S2D (konst x)

212

215

213− D3Sing SNat SNat SNat ->

216+ D3Sing ->

214 S3D (konst x)

217 S3D (konst x)

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

8{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE StandaloneDeriving #-}

11{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE UndecidableInstances #-}

11{-|

13{-|

12Module : Grenade.Layers.Concat

14Module : Grenade.Layers.Concat

13Description : Concatenation layer

15Description : Concatenation layer

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

26import Data.Singletons

28import Data.Singletons

27import GHC.TypeLits

29import GHC.TypeLits

28

30

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

32+import Data.Kind (Type)

33+#endif

34+

29import Grenade.Core

35import Grenade.Core

30

36

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

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

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

43--

49--

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

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

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

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

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

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

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

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

48

54

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

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

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

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

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

6{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FlexibleInstances #-}

10{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

11{-|

12Module : Grenade.Layers.Convolution

13Description : Convolution layer

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

28import Data.Maybe

29import Data.Proxy

30import Data.Serialize

31−import Data.Singletons.TypeLits

32

31

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

34−import GHC.TypeLits hiding (natVal)

35−#else

36import GHC.TypeLits

32import GHC.TypeLits

37−#endif

33+import Data.Kind (Type)

38

34

39import Numeric.LinearAlgebra hiding ( uniformSample, konst )

35import Numeric.LinearAlgebra hiding ( uniformSample, konst )

40import qualified Numeric.LinearAlgebra as LA

36import qualified Numeric.LinearAlgebra as LA

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

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

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

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

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

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

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

64− -> * where

60+ -> Type where

65 Convolution :: ( KnownNat channels

61 Convolution :: ( KnownNat channels

66 , KnownNat filters

62 , KnownNat filters

67 , KnownNat kernelRows

63 , KnownNat kernelRows

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

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

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

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

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

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

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

83− -> * where

79+ -> Type where

84 Convolution' :: ( KnownNat channels

80 Convolution' :: ( KnownNat channels

85 , KnownNat filters

81 , KnownNat filters

86 , KnownNat kernelRows

82 , KnownNat kernelRows

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

135 , KnownNat (kernelRows * kernelColumns * channels)

131 , KnownNat (kernelRows * kernelColumns * channels)

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

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

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

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

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

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

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

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

140 in Convolution newKernel newMomentum

136 in Convolution newKernel newMomentum

141

137

142 createRandom = randomConvolution

138 createRandom = randomConvolution

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

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

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE UndecidableInstances #-}

9{-|

10{-|

10Module : Grenade.Layers.Crop

11Module : Grenade.Layers.Crop

11Description : Cropping layer

12Description : Cropping layer

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

20import Data.Maybe

21import Data.Maybe

21import Data.Proxy

22import Data.Proxy

22import Data.Serialize

23import Data.Serialize

23−import Data.Singletons.TypeLits

24

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

26−import GHC.TypeLits hiding (natVal)

27−#else

28import GHC.TypeLits

25import GHC.TypeLits

29−#endif

26+import Data.Kind (Type)

30

27

31import Grenade.Core

28import Grenade.Core

32import Grenade.Layers.Internal.Pad

29import Grenade.Layers.Internal.Pad

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

38data Crop :: Nat

35data Crop :: Nat

39 -> Nat

36 -> Nat

40 -> Nat

37 -> Nat

41− -> Nat -> * where

38+ -> Nat -> Type where

42 Crop :: Crop cropLeft cropTop cropRight cropBottom

39 Crop :: Crop cropLeft cropTop cropRight cropBottom

43

40

44instance Show (Crop cropLeft cropTop cropRight cropBottom) where

41instance Show (Crop cropLeft cropTop cropRight cropBottom) where

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

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

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

6{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FlexibleInstances #-}

10{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

11{-|

12Module : Grenade.Layers.Deconvolution

13Description : Deconvolution layer

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

32import Data.Maybe

33import Data.Proxy

34import Data.Serialize

35−import Data.Singletons.TypeLits

36

35

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

38−import GHC.TypeLits hiding (natVal)

39−#else

40import GHC.TypeLits

36import GHC.TypeLits

41−#endif

37+import Data.Kind (Type)

42

38

43import Numeric.LinearAlgebra hiding ( uniformSample, konst )

39import Numeric.LinearAlgebra hiding ( uniformSample, konst )

44import qualified Numeric.LinearAlgebra as LA

40import qualified Numeric.LinearAlgebra as LA

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

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

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

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

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

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

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

63− -> * where

59+ -> Type where

64 Deconvolution :: ( KnownNat channels

60 Deconvolution :: ( KnownNat channels

65 , KnownNat filters

61 , KnownNat filters

66 , KnownNat kernelRows

62 , KnownNat kernelRows

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

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

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

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

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

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

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

82− -> * where

78+ -> Type where

83 Deconvolution' :: ( KnownNat channels

79 Deconvolution' :: ( KnownNat channels

84 , KnownNat filters

80 , KnownNat filters

85 , KnownNat kernelRows

81 , KnownNat kernelRows

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

134 , KnownNat (kernelRows * kernelColumns * filters)

130 , KnownNat (kernelRows * kernelColumns * filters)

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

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

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

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

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

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

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

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

139 in Deconvolution newKernel newMomentum

135 in Deconvolution newKernel newMomentum

140

136

141 createRandom = randomDeconvolution

137 createRandom = randomDeconvolution

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

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

1{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE TypeOperators #-}

2{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeFamilies #-}

3{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

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

14

13

15import Data.Proxy

14import Data.Proxy

16import Data.Serialize

15import Data.Serialize

17−import Data.Singletons.TypeLits

18

16

19import qualified Numeric.LinearAlgebra as LA

17import qualified Numeric.LinearAlgebra as LA

20import Numeric.LinearAlgebra.Static

18import Numeric.LinearAlgebra.Static

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

22import Grenade.Core

20import Grenade.Core

23

21

24import Grenade.Layers.Internal.Update

22import Grenade.Layers.Internal.Update

23+import GHC.TypeLits

25

24

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

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

27data FullyConnected i o = FullyConnected

26data FullyConnected i o = FullyConnected

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

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

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

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

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

40

39

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

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

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

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

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

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

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

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

45

44

46 createRandom = randomFullyConnected

45 createRandom = randomFullyConnected

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

23

24

24import Data.Singletons

25import Data.Singletons

25

26

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

28+import Data.Kind (Type)

29+#endif

30+

26import Grenade.Core

31import Grenade.Core

27

32

28-- | A Merging layer.

33-- | A Merging layer.

29--

34--

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

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

31-- shape.

36-- shape.

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

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

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

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

34

39

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

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

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

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

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE FlexibleContexts #-}

9+{-# LANGUAGE UndecidableInstances #-}

9{-|

10{-|

10Module : Grenade.Core.Pad

11Module : Grenade.Core.Pad

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

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

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

20import Data.Maybe

21import Data.Maybe

21import Data.Proxy

22import Data.Proxy

22import Data.Serialize

23import Data.Serialize

23−import Data.Singletons.TypeLits

24

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

26−import GHC.TypeLits hiding (natVal)

27−#else

28import GHC.TypeLits

25import GHC.TypeLits

29−#endif

26+import Data.Kind (Type)

30

27

31import Grenade.Core

28import Grenade.Core

32import Grenade.Layers.Internal.Pad

29import Grenade.Layers.Internal.Pad

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

40data Pad :: Nat

37data Pad :: Nat

41 -> Nat

38 -> Nat

42 -> Nat

39 -> Nat

43− -> Nat -> * where

40+ -> Nat -> Type where

44 Pad :: Pad padLeft padTop padRight padBottom

41 Pad :: Pad padLeft padTop padRight padBottom

45

42

46instance Show (Pad padLeft padTop padRight padBottom) where

43instance Show (Pad padLeft padTop padRight padBottom) where

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

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

7{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE FlexibleContexts #-}

10+{-# LANGUAGE UndecidableInstances #-}

10{-|

11{-|

11Module : Grenade.Core.Pooling

12Module : Grenade.Core.Pooling

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

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

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

21import Data.Maybe

22import Data.Maybe

22import Data.Proxy

23import Data.Proxy

23import Data.Serialize

24import Data.Serialize

24−import Data.Singletons.TypeLits

25

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

27−import GHC.TypeLits hiding (natVal)

28−#else

29import GHC.TypeLits

26import GHC.TypeLits

30−#endif

27+import Data.Kind (Type)

31

28

32import Grenade.Core

29import Grenade.Core

33import Grenade.Layers.Internal.Pooling

30import Grenade.Layers.Internal.Pooling

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

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

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

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

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

44--

41--

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

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

46 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

43 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns

47

44

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

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

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

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

3{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE UndecidableInstances #-}

6{-|

7{-|

7Module : Grenade.Layers.Reshape

8Module : Grenade.Layers.Reshape

8Description : Multipurpose reshaping layer

9Description : Multipurpose reshaping layer

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

16

17

17import Data.Serialize

18import Data.Serialize

18

19

19−import Data.Singletons.TypeLits

20import GHC.TypeLits

21

22import Numeric.LinearAlgebra.Static

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE TypeFamilies #-}

3{-# LANGUAGE TypeFamilies #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

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

8 , RecurrentUpdateLayer (..)

9 , RecurrentUpdateLayer (..)

9 ) where

10 ) where

10

11

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

13+import Data.Kind (Type)

14+#endif

15+

11import Grenade.Core

16import Grenade.Core

12

17

13-- | Class for a recurrent layer.

18-- | Class for a recurrent layer.

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

15-- of an extra recurrent data shape.

20-- of an extra recurrent data shape.

16class UpdateLayer x => RecurrentUpdateLayer x where

21class UpdateLayer x => RecurrentUpdateLayer x where

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

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

18− type RecurrentShape x :: *

23+ type RecurrentShape x :: Type

19

24

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

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

21 -- | Wengert Tape

26 -- | Wengert Tape

22− type RecTape x i o :: *

27+ type RecTape x i o :: Type

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

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

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

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

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

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

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

28

29

30

30import Control.Monad.Random ( MonadRandom )

31import Control.Monad.Random ( MonadRandom )

31−import Data.Singletons ( SingI )

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

33import Data.Serialize

32import Data.Serialize

34

33

34+import Data.Kind (Type)

35+

35import Grenade.Core

36import Grenade.Core

36import Grenade.Recurrent.Core.Layer

37import Grenade.Recurrent.Core.Layer

38+import Prelude.Singletons

37

39

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

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

39-- forward layer.

41-- forward layer.

40−data FeedForward :: * -> *

42+data FeedForward :: Type -> Type

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

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

42−data Recurrent :: * -> *

44+data Recurrent :: Type -> Type

43

45

44-- | Type of a recurrent neural network.

46-- | Type of a recurrent neural network.

45--

47--

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

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

47--

49--

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

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

49--

51--

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

52--

54--

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

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

54-- for these empty data types.

56-- for these empty data types.

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

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

56 RNil :: SingI i

58 RNil :: SingI i

57 => RecurrentNetwork '[] '[i]

59 => RecurrentNetwork '[] '[i]

58

60

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

71-- | Gradient of a network.

73-- | Gradient of a network.

72--

74--

73-- Parameterised on the layers of the network.

75-- Parameterised on the layers of the network.

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

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

75 RGNil :: RecurrentGradient '[]

77 RGNil :: RecurrentGradient '[]

76

78

77 (://>) :: UpdateLayer x

79 (://>) :: UpdateLayer x

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

81

83

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

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

83-- Parameterised on the layers of a Network.

85-- Parameterised on the layers of a Network.

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

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

85 RINil :: RecurrentInputs '[]

87 RINil :: RecurrentInputs '[]

86

88

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

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

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

95--

97--

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

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

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

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

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

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

99 TRNil :: SingI i

101 TRNil :: SingI i

100 => RecurrentTape '[] '[i]

102 => RecurrentTape '[] '[i]

101

103

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

204

206

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

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

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

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

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

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

208 -- | Create a network of the types requested

210 -- | Create a network of the types requested

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

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

210

212

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

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

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE RecordWildCards #-}

10

9

11module Grenade.Recurrent.Core.Runner (

10module Grenade.Recurrent.Core.Runner (

12 runRecurrentExamples

11 runRecurrentExamples

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

18 ) where

17 ) where

19

18

20import Data.List ( foldl' )

19import Data.List ( foldl' )

21−import Data.Singletons.Prelude

22import Grenade.Core

20import Grenade.Core

23

21

24import Grenade.Recurrent.Core.Network

22import Grenade.Recurrent.Core.Network

23+import Prelude.Singletons

25

24

26type RecurrentGradients layers = [RecurrentGradient layers]

25type RecurrentGradients layers = [RecurrentGradient layers]

27

26

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

101 -> RecurrentInputs sublayers

100 -> RecurrentInputs sublayers

102 -> RecurrentInputs sublayers

101 -> RecurrentInputs sublayers

103

102

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

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

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

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

106

105

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

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

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

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

109

108

110updateRecInputs _ RINil RINil

109updateRecInputs _ RINil RINil

111 = RINil

110 = RINil

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

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

16

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

18

19+

19−import Data.Singletons.TypeLits

20+import Data.Kind (Type)

20

21

21import Numeric.LinearAlgebra.Static

22import Numeric.LinearAlgebra.Static

22

23

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

27

28

28data BasicRecurrent :: Nat -- Input layer size

29data BasicRecurrent :: Nat -- Input layer size

29 -> Nat -- Output layer size

30 -> Nat -- Output layer size

30− -> * where

31+ -> Type where

31 BasicRecurrent :: ( KnownNat input

32 BasicRecurrent :: ( KnownNat input

32 , KnownNat output

33 , KnownNat output

33 , KnownNat matrixCols

34 , KnownNat matrixCols

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

40

41

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

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

42 -> Nat -- Output layer size

43 -> Nat -- Output layer size

43− -> * where

44+ -> Type where

44 BasicRecurrent' :: ( KnownNat input

45 BasicRecurrent' :: ( KnownNat input

45 , KnownNat output

46 , KnownNat output

46 , KnownNat matrixCols

47 , KnownNat matrixCols

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

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

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

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

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

57

58

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

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

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

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

60 newBias = oldBias + newBiasMomentum

61 newBias = oldBias + newBiasMomentum

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

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

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

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

63 newActivations = oldActivations + newMomentum - regulariser

64 newActivations = oldActivations + newMomentum - regulariser

64 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

65 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

65

66

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

8{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE StandaloneDeriving #-}

11{-# LANGUAGE StandaloneDeriving #-}

12+{-# LANGUAGE UndecidableInstances #-}

11{-|

13{-|

12Module : Grenade.Layers.Concat

14Module : Grenade.Layers.Concat

13Description : Concatenation layer

15Description : Concatenation layer

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

26import Data.Singletons

28import Data.Singletons

27import GHC.TypeLits

29import GHC.TypeLits

28

30

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

32+import Data.Kind (Type)

33+#endif

34+

29import Grenade.Core

35import Grenade.Core

30import Grenade.Recurrent.Core

36import Grenade.Recurrent.Core

31

37

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

44--

50--

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

4{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

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

21-- import Data.List ( foldl1' )

22import Data.Proxy

23import Data.Serialize

24−import Data.Singletons.TypeLits

24+import Data.Kind (Type)

25

26import qualified Numeric.LinearAlgebra as LA

27import Numeric.LinearAlgebra.Static

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

29import Grenade.Core

30import Grenade.Recurrent.Core

31import Grenade.Layers.Internal.Update

32+import GHC.TypeLits

32

33

34

34-- | Long Short Term Memory Recurrent unit

35-- | Long Short Term Memory Recurrent unit

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

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

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

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

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

38-- at all.

39-- at all.

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

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

40 LSTM :: ( KnownNat input

41 LSTM :: ( KnownNat input

41 , KnownNat output

42 , KnownNat output

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

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

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

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

44 -> LSTM input output

45 -> LSTM input output

45

46

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

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

47 LSTMWeights :: ( KnownNat input

48 LSTMWeights :: ( KnownNat input

48 , KnownNat output

49 , KnownNat output

49 ) => {

50 ) => {

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

70

71

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

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

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

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

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

74+ runUpdate lp (LSTM w m) g =

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

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

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

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

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

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

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

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

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

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

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

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

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

90− descendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum

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

91

92

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

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

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

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

94− descendVector learningRate learningMomentum learningRegulariser weights gradient momentum

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

95

96

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

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

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

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

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

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)

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)

133 -- Forward propagation for the LSTM layer.

134 -- Forward propagation for the LSTM layer.

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

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

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

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

136 let -- Forget state vector

137 let -- Forget state vector

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

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

138 f_t = sigmoid f_s

139 f_t = sigmoid f_s

139 -- Input state vector

140 -- Input state vector

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

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

141 i_t = sigmoid i_s

142 i_t = sigmoid i_s

142 -- Output state vector

143 -- Output state vector

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

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

144 o_t = sigmoid o_s

145 o_t = sigmoid o_s

145 -- Cell input state vector

146 -- Cell input state vector

146− c_s = lstmBc + lstmWc #> input

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

147 c_x = tanh c_s

148 c_x = tanh c_s

148 -- Cell state

149 -- Cell state

149 c_t = f_t * cell + i_t * c_x

150 c_t = f_t * cell + i_t * c_x

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

157 --

158 --

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

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

159 -- suite. These should match always.

160 -- suite. These should match always.

160− runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t) (S1D cellGrad) (S1D h_t') =

161+ runRecurrentBackwards (LSTM lw _) (cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t) (S1D cellGrad) (S1D h_t') =

161 let -- Reverse Mode AD Derivitives

162 let -- Reverse Mode AD Derivitives

162 c_t' = h_t' * o_t + cellGrad

163 c_t' = h_t' * o_t + cellGrad

163

164

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

174 c_s' = tanh' c_s * c_x'

175 c_s' = tanh' c_s * c_x'

175

176

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

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

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

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

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

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

179

180

180 -- Calculate the gradient Matricies for the input

181 -- Calculate the gradient Matricies for the input

181 lstmWf' = f_s' `outer` input

182 lstmWf' = f_s' `outer` input

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

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

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

235

236

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

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

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

238+ put (LSTM lw _) = do

238− u lstmWf

239+ u (lstmWf lw)

239− u lstmUf

240+ u (lstmUf lw)

240− v lstmBf

241+ v (lstmBf lw)

241− u lstmWi

242+ u (lstmWi lw)

242− u lstmUi

243+ u (lstmUi lw)

243− v lstmBi

244+ v (lstmBi lw)

244− u lstmWo

245+ u (lstmWo lw)

245− u lstmUo

246+ u (lstmUo lw)

246− v lstmBo

247+ v (lstmBo lw)

247− u lstmWc

248+ u (lstmWc lw)

248− v lstmBc

249+ v (lstmBc lw)

249− where

250+ where

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

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

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

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

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

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

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

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

254

255

255 get = do

256 get = do

256− lstmWf <- u

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

257− lstmUf <- u

258− lstmBf <- v

259− lstmWi <- u

260− lstmUi <- u

261− lstmBi <- v

262− lstmWo <- u

263− lstmUo <- u

264− lstmBo <- v

265− lstmWc <- u

266− lstmBc <- v

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

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

268− where

259+ where

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

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

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

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

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

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

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

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

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

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

274−

265+

275− w0 = konst 0

266+ w0 = konst 0

276− u0 = konst 0

267+ u0 = konst 0

277− v0 = konst 0

268+ v0 = konst 0

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

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

22import qualified Data.Map as M

23

24import Data.Proxy

25−import Data.Singletons.TypeLits

26

25

27import Data.Vector ( Vector )

26import Data.Vector ( Vector )

28import qualified Data.Vector as V

27import qualified Data.Vector as V

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

31import Numeric.LinearAlgebra ( maxIndex )

30import Numeric.LinearAlgebra ( maxIndex )

32import Numeric.LinearAlgebra.Devel

31import Numeric.LinearAlgebra.Devel

33import Numeric.LinearAlgebra.Static

32import Numeric.LinearAlgebra.Static

33+import GHC.TypeLits

34

35import Grenade.Core.Shape

36

stack.yamlnew file+78

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

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

2+#

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

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

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

6+

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

8+# user-message: |

9+

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

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

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

13+#

14+# resolver: lts-3.5

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

16+# resolver: ghc-7.10.2

17+#

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

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

20+#

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

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

23+resolver: lts-20.18

24+

25+# User packages to be built.

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

27+#

28+# packages:

29+# - some-directory

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

31+# subdirs:

32+# - auto-update

33+# - wai

34+packages:

35+ - .

36+ - examples

37+

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

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

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

41+#

42+# extra-deps:

43+# - acme-missiles-0.3

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

45+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

46+#

47+extra-deps:

48+ - typelits-witnesses-0.3.0.3

49+

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

51+# flags: {}

52+

53+# Extra package databases containing global packages

54+# extra-package-dbs: []

55+

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

57+# system-ghc: true

58+#

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

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

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

62+#

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

64+# arch: i386

65+# arch: x86_64

66+#

67+# Extra directories used by stack for building

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

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

70+#

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

72+# compiler-check: newer-minor

73+

74+nix:

75+ enable: true

76+ packages:

77+ - blas

78+ - lapack

stack.yaml.locknew file+19

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

1+# This file was autogenerated by Stack.

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

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

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

5+

6+packages:

7+- completed:

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

9+ pantry-tree:

10+ sha256: 6a42a462f98e94933b6e9721acd912c6c6b6a4743635efd15cc5871908c816a0

11+ size: 469

12+ original:

13+ hackage: typelits-witnesses-0.3.0.3

14+snapshots:

15+- completed:

16+ sha256: 9fa4bece7acfac1fc7930c5d6e24606004b09e80aa0e52e9f68b148201008db9

17+ size: 649606

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

19+ original: lts-20.18

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

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

15import GHC.TypeLits

16import GHC.TypeLits

16import GHC.TypeLits.Witnesses

17import GHC.TypeLits.Witnesses

17

18

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

20+import Data.Kind (Type)

21+#endif

22+

18import Grenade.Core

23import Grenade.Core

19import Grenade.Layers.Convolution

24import Grenade.Layers.Convolution

20

25

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

25import Test.Hedgehog.TypeLits

30import Test.Hedgehog.TypeLits

26import Test.Hedgehog.Compat

31import Test.Hedgehog.Compat

27

32

28−data OpaqueConvolution :: * where

33+data OpaqueConvolution :: Type where

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

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

30

35

31instance Show OpaqueConvolution where

36instance Show OpaqueConvolution where

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

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

12

13

13import GHC.TypeLits

14import GHC.TypeLits

14

15

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

17+import Data.Kind (Type)

18+#endif

19+

15import Grenade.Core

20import Grenade.Core

16import Grenade.Layers.FullyConnected

21import Grenade.Layers.FullyConnected

17

22

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

20import Test.Hedgehog.Compat

25import Test.Hedgehog.Compat

21import Test.Hedgehog.Hmatrix

26import Test.Hedgehog.Hmatrix

22

27

23−data OpaqueFullyConnected :: * where

28+data OpaqueFullyConnected :: Type where

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

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

25

30

26instance Show OpaqueFullyConnected where

31instance Show OpaqueFullyConnected where

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

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

7{-# LANGUAGE ScopedTypeVariables #-}

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

9

10−#if __GLASGOW_HASKELL__ < 800

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

12−#endif

13−

14module Test.Grenade.Layers.PadCrop where

10module Test.Grenade.Layers.PadCrop where

15

11

16import Grenade

12import Grenade

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE KindSignatures #-}

4{-# LANGUAGE KindSignatures #-}

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

9import Data.Proxy

10import Data.Proxy

10import Data.Singletons ()

11import Data.Singletons ()

11

12

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

14+import Data.Kind (Type)

15+#endif

16+

12import GHC.TypeLits

17import GHC.TypeLits

13import Grenade.Layers.Pooling

18import Grenade.Layers.Pooling

14

19

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

16

21

17import Test.Hedgehog.Compat

22import Test.Hedgehog.Compat

18

23

19−data OpaquePooling :: * where

24+data OpaquePooling :: Type where

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

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

21

26

22instance Show OpaquePooling where

27instance Show OpaquePooling where

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

24

29

25genOpaquePooling :: Gen OpaquePooling

30genOpaquePooling :: Gen OpaquePooling

26genOpaquePooling = do

31genOpaquePooling = do

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

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

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

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

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

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

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

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

31

36

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

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

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

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

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

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

14import Control.Monad.ST ( runST )

15

16import Data.Constraint

17−#if __GLASGOW_HASKELL__ < 800

18−import Data.Proxy

19−#endif

20import qualified Data.Vector.Storable as VS

17import qualified Data.Vector.Storable as VS

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

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

22import Data.Singletons

19import Data.Singletons

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

35#else

32#else

36import GHC.TypeLits

33import GHC.TypeLits

37#endif

34#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 :: * where

49+data SomeNetwork :: Type 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 diff ->

124+ Just differ ->

125 withFrozenCallStack $

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

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

127infix 4 ~~~

128

129tests :: IO Bool

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

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

6{-# LANGUAGE DeriveFunctor #-}

7{-# LANGUAGE DeriveFoldable #-}

8{-# LANGUAGE DeriveTraversable #-}

9−{-# LANGUAGE RecordWildCards #-}

10{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE FlexibleContexts #-}

11{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RankNTypes #-}

12

11

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

15

14

16import Data.Reflection

15import Data.Reflection

17import Numeric.AD.Mode.Reverse

16import Numeric.AD.Mode.Reverse

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

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

19

18

19+import GHC.TypeLits (KnownNat)

20+

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

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

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

23+

21import qualified Numeric.LinearAlgebra.Static as S

24import qualified Numeric.LinearAlgebra.Static as S

22import qualified Numeric.LinearAlgebra as H

25import qualified Numeric.LinearAlgebra as H

23

26

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

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

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

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

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

56

59

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

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

58−lstmToReference LSTM.LSTMWeights {..} =

61+lstmToReference lw =

62+ RefLSTM

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

70− in RefLSTM {..}

74+ }

71

75

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

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

73−runLSTM RefLSTM {..} cell input =

77+runLSTM rl cell input =

74 let -- Forget state vector

78 let -- Forget state vector

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

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

76 -- Input state vector

80 -- Input state vector

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

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

78 -- Output state vector

82 -- Output state vector

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

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

80 -- Cell input state vector

84 -- Cell input state vector

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

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

82 -- Cell state

86 -- Cell state

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

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

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

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

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

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

1−{-# LANGUAGE RankNTypes #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE KindSignatures #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

5

6

6module Test.Hedgehog.Hmatrix where

7module Test.Hedgehog.Hmatrix where

7

8

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

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

7{-# LANGUAGE GADTs #-}

8module Test.Hedgehog.TypeLits where

9

10−import Data.Constraint

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

11−#if __GLASGOW_HASKELL__ < 800

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

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

12−import Data.Proxy

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

13#endif

14#endif

14−import Data.Singletons

15

16import Hedgehog (Gen)

17import qualified Hedgehog.Gen as Gen

18

19import Grenade

20

21−import GHC.TypeLits

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

22−import GHC.TypeLits.Witnesses

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

23−import Test.Hedgehog.Compat

23+import Test.Hedgehog.Compat (choose)

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−

36−genShape :: Gen (SomeSing Shape')

30+genShape :: Gen (SomeSing Shape)

37genShape

31genShape

38 = Gen.choice [

32 = Gen.choice [

39 genD1

33 genD1

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

41 , genD3

35 , genD3

42 ]

36 ]

43

37

44−genD1 :: Gen (SomeSing Shape')

38+genD1 :: Gen (SomeSing Shape)

45genD1 = do

39genD1 = do

46 n <- genNat

40 n <- genNat

47 return $ case n of

41 return $ case n of

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

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

49

43

50−genD2 :: Gen (SomeSing Shape')

44+genD2 :: Gen (SomeSing Shape)

51genD2 = do

45genD2 = do

52 n <- genNat

46 n <- genNat

53 m <- genNat

47 m <- genNat

54 return $ case (n, m) of

48 return $ case (n, m) of

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

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

56

50

57−genD3 :: Gen (SomeSing Shape')

51+genD3 :: Gen (SomeSing Shape)

58genD3 = do

52genD3 = do

59 n <- genNat

53 n <- genNat

60 m <- genNat

54 m <- genNat

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

64 case natDict px %* natDict pz of

58 case natDict px %* natDict pz of

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

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

66

60

67−rss :: SomeSing Shape' -> String

61+rss :: SomeSing Shape -> String

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

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

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

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

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

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