master..bf6ddad · grenade

.gitignore−1

since splitsnapshots

unifiedsplit

@@ -3,4 +3,3 @@ cabal.project.local

3cabal.sandbox.config

4dist/

5dist-newstyle/

6−.stack-work/

.travis.yml+12−12

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

2

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

4env:

5− - GHCVER=8.0.2

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

8+ - CABALVER=2.0 GHCVER=8.6.5

9− - GHCVER=8.8.3

10− - GHCVER=8.10.1

11

9

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

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

13before_install:

11before_install:

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

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

15 - travis_retry sudo apt-get update

13 - travis_retry sudo apt-get update

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

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

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

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

18

16

19install:

17install:

18+ - cabal --version

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

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

21− - travis_retry cabal-3.2 update

20+ - travis_retry cabal update

21+ - cabal sandbox init

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

22

23

23notifications:

24notifications:

24 email: false

25 email: false

25

26

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

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

27script:

28script:

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

29− - cabal-3.2 build all

29+ - cabal build

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

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

31

examples/grenade-examples.cabal+5−6

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

30 , text == 1.2.*

31 , mtl >= 2.2.1 && < 2.3

32 , hmatrix

@@ -42,7 +42,7 @@ executable mnist

42 , grenade

43 , attoparsec

44 , either

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

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

46 , text == 1.2.*

47 , mtl >= 2.2.1 && < 2.3

48 , hmatrix >= 0.18 && < 0.21

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

61 , bytestring

62 , cereal

63 , either

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

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

65 , text == 1.2.*

66 , mtl >= 2.2.1 && < 2.3

67 , hmatrix >= 0.18 && < 0.21

@@ -78,7 +78,7 @@ executable recurrent

78 , grenade

79 , attoparsec

80 , either

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

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

82 , text == 1.2.*

83 , mtl >= 2.2.1 && < 2.3

84 , hmatrix >= 0.18 && < 0.21

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

100 , text == 1.2.*

101 , mtl >= 2.2.1 && < 2.3

102 , hmatrix >= 0.18 && < 0.21

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

@@ -38,7 +38,7 @@ 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

43 , cereal >= 0.5 && < 0.6

44 , deepseq >= 1.4 && < 1.5

@@ -48,7 +48,6 @@ library

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:

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

@@ -34,6 +34,7 @@ module Grenade.Core.Network (

34import Control.Monad.Random ( MonadRandom )

35

36import Data.Singletons

37+import Data.Singletons.Prelude

37import Data.Serialize

38import Data.Serialize

38

39

39#if MIN_VERSION_base(4,9,0)

40#if MIN_VERSION_base(4,9,0)

@@ -43,7 +44,6 @@ import Data.Kind (Type)

43import Grenade.Core.Layer

44import Grenade.Core.Layer

44import Grenade.Core.LearningParameters

45import Grenade.Core.LearningParameters

45import Grenade.Core.Shape

46import Grenade.Core.Shape

46−import Prelude.Singletons

47

48-- | Type of a network.

49--

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−27

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

19

20-}

21module Grenade.Core.Shape (

22+ Shape (..)

22− S (..)

23+ , S (..)

23− , Shape (..)

24+ , Sing (..)

24− , SShape (..)

25+

25 , randomOfShape

26 , randomOfShape

26 , fromStorable

27 , fromStorable

27 ) where

28 ) where

28

29

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

30import Control.DeepSeq (NFData (..))

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

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

31−import Data.Kind (Type)

32+

32import Data.Proxy

33import Data.Proxy

33import Data.Serialize

34import Data.Serialize

34import Data.Singletons

35import Data.Singletons

36+import Data.Singletons.TypeLits

35import Data.Vector.Storable ( Vector )

37import Data.Vector.Storable ( Vector )

36import qualified Data.Vector.Storable as V

38import qualified Data.Vector.Storable as V

39+

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

41+import GHC.TypeLits hiding (natVal)

42+#else

37import GHC.TypeLits

43import GHC.TypeLits

44+#endif

45+

38import qualified Numeric.LinearAlgebra.Static as H

46import qualified Numeric.LinearAlgebra.Static as H

39import Numeric.LinearAlgebra.Static

47import Numeric.LinearAlgebra.Static

40import qualified Numeric.LinearAlgebra as NLA

48import qualified Numeric.LinearAlgebra as NLA

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

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

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

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

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

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

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

90data instance Sing (n :: Shape) where

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

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

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

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

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

95−#endif

96

94

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

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

98− sing = D1Sing

96+ sing = D1Sing sing

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

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

100− sing = D2Sing

98+ sing = D2Sing sing sing

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

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

102− sing = D3Sing

100+ sing = D3Sing sing sing sing

103

101

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

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

105 (+) = n2 (+)

103 (+) = n2 (+)

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

148randomOfShape = do

146randomOfShape = do

149 seed :: Int <- getRandom

147 seed :: Int <- getRandom

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

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

151− D1Sing ->

149+ D1Sing SNat ->

152 S1D (randomVector seed Uniform * 2 - 1)

150 S1D (randomVector seed Uniform * 2 - 1)

153

151

154− D2Sing ->

152+ D2Sing SNat SNat ->

155 S2D (uniformSample seed (-1) 1)

153 S2D (uniformSample seed (-1) 1)

156

154

157− D3Sing ->

155+ D3Sing SNat SNat SNat ->

158 S3D (uniformSample seed (-1) 1)

156 S3D (uniformSample seed (-1) 1)

159

157

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

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

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

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

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

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

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

164fromStorable xs = case sing :: Sing x of

162fromStorable xs = case sing :: Sing x of

165− D1Sing ->

163+ D1Sing SNat ->

166 S1D <$> H.create xs

164 S1D <$> H.create xs

167

165

168− D2Sing ->

166+ D2Sing SNat SNat ->

169 S2D <$> mkL xs

167 S2D <$> mkL xs

170

168

171− D3Sing ->

169+ D3Sing SNat SNat SNat ->

172 S3D <$> mkL xs

170 S3D <$> mkL xs

173 where

171 where

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

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

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

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

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

206

204

207-- Helper function for creating the number instances

205-- Helper function for creating the number instances

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

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

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

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

210− D1Sing ->

208+ D1Sing SNat ->

211 S1D (konst x)

209 S1D (konst x)

212

210

213− D2Sing ->

211+ D2Sing SNat SNat ->

214 S2D (konst x)

212 S2D (konst x)

215

213

216− D3Sing ->

214+ D3Sing SNat SNat SNat ->

217 S3D (konst x)

215 S3D (konst x)

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

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

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 #-}

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

28import Data.Maybe

29import Data.Maybe

29import Data.Proxy

30import Data.Proxy

30import Data.Serialize

31import Data.Serialize

32+import Data.Singletons.TypeLits

31

33

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

35+import GHC.TypeLits hiding (natVal)

36+#else

32import GHC.TypeLits

37import GHC.TypeLits

38+#endif

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

33import Data.Kind (Type)

40import Data.Kind (Type)

41+#endif

34

42

35import Numeric.LinearAlgebra hiding ( uniformSample, konst )

43import Numeric.LinearAlgebra hiding ( uniformSample, konst )

36import qualified Numeric.LinearAlgebra as LA

44import qualified Numeric.LinearAlgebra as LA

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

131 , KnownNat (kernelRows * kernelColumns * channels)

139 , KnownNat (kernelRows * kernelColumns * channels)

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

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

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

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

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

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

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

136 in Convolution newKernel newMomentum

144 in Convolution newKernel newMomentum

137

145

138 createRandom = randomConvolution

146 createRandom = randomConvolution

src/Grenade/Layers/Crop.hs+7

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

21import Data.Maybe

22import Data.Proxy

23import Data.Serialize

24+import Data.Singletons.TypeLits

24

25

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

27+import GHC.TypeLits hiding (natVal)

28+#else

25import GHC.TypeLits

29import GHC.TypeLits

30+#endif

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

26import Data.Kind (Type)

32import Data.Kind (Type)

33+#endif

27

34

28import Grenade.Core

35import Grenade.Core

29import Grenade.Layers.Internal.Pad

36import Grenade.Layers.Internal.Pad

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

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

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 #-}

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

32import Data.Maybe

33import Data.Maybe

33import Data.Proxy

34import Data.Proxy

34import Data.Serialize

35import Data.Serialize

36+import Data.Singletons.TypeLits

35

37

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

39+import GHC.TypeLits hiding (natVal)

40+#else

36import GHC.TypeLits

41import GHC.TypeLits

42+#endif

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

37import Data.Kind (Type)

44import Data.Kind (Type)

45+#endif

38

46

39import Numeric.LinearAlgebra hiding ( uniformSample, konst )

47import Numeric.LinearAlgebra hiding ( uniformSample, konst )

40import qualified Numeric.LinearAlgebra as LA

48import qualified Numeric.LinearAlgebra as LA

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

130 , KnownNat (kernelRows * kernelColumns * filters)

138 , KnownNat (kernelRows * kernelColumns * filters)

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

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

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

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

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

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

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

135 in Deconvolution newKernel newMomentum

143 in Deconvolution newKernel newMomentum

136

144

137 createRandom = randomDeconvolution

145 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/Pad.hs+7

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

21import Data.Maybe

22import Data.Proxy

23import Data.Serialize

24+import Data.Singletons.TypeLits

24

25

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

27+import GHC.TypeLits hiding (natVal)

28+#else

25import GHC.TypeLits

29import GHC.TypeLits

30+#endif

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

26import Data.Kind (Type)

32import Data.Kind (Type)

33+#endif

27

34

28import Grenade.Core

35import Grenade.Core

29import Grenade.Layers.Internal.Pad

36import Grenade.Layers.Internal.Pad

src/Grenade/Layers/Pooling.hs+7

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

22import Data.Maybe

23import Data.Proxy

24import Data.Serialize

25+import Data.Singletons.TypeLits

25

26

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

28+import GHC.TypeLits hiding (natVal)

29+#else

26import GHC.TypeLits

30import GHC.TypeLits

31+#endif

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

27import Data.Kind (Type)

33import Data.Kind (Type)

34+#endif

28

35

29import Grenade.Core

36import Grenade.Core

30import Grenade.Layers.Internal.Pooling

37import Grenade.Layers.Internal.Pooling

src/Grenade/Layers/Reshape.hs+1

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

17

18import Data.Serialize

19

20+import Data.Singletons.TypeLits

20import GHC.TypeLits

21import GHC.TypeLits

21

22

22import Numeric.LinearAlgebra.Static

23import Numeric.LinearAlgebra.Static

src/Grenade/Recurrent/Core/Network.hs+4−1

@@ -29,13 +29,16 @@ module Grenade.Recurrent.Core.Network (

29

30

31import Control.Monad.Random ( MonadRandom )

32+import Data.Singletons ( SingI )

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

32import Data.Serialize

34import Data.Serialize

33

35

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

34import Data.Kind (Type)

37import Data.Kind (Type)

38+#endif

35

39

36import Grenade.Core

40import Grenade.Core

37import Grenade.Recurrent.Core.Layer

41import Grenade.Recurrent.Core.Layer

38−import Prelude.Singletons

39

42

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

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

41-- forward layer.

44-- forward layer.

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−4

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

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE RecordWildCards #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

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

16

17

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

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

18

19

20+import Data.Singletons.TypeLits

19

21

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

20import Data.Kind (Type)

23import Data.Kind (Type)

24+#endif

21

25

22import Numeric.LinearAlgebra.Static

26import Numeric.LinearAlgebra.Static

23

27

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

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

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

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

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

58

62

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

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

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

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

61 newBias = oldBias + newBiasMomentum

65 newBias = oldBias + newBiasMomentum

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

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

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

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

64 newActivations = oldActivations + newMomentum - regulariser

68 newActivations = oldActivations + newMomentum - regulariser

65 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

69 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

66

70

src/Grenade/Recurrent/Layers/LSTM.hs+55−41

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

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

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

21-- import Data.List ( foldl1' )

22-- import Data.List ( foldl1' )

22import Data.Proxy

23import Data.Proxy

23import Data.Serialize

24import Data.Serialize

25+import Data.Singletons.TypeLits

26+

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

24import Data.Kind (Type)

28import Data.Kind (Type)

29+#endif

25

30

26import qualified Numeric.LinearAlgebra as LA

31import qualified Numeric.LinearAlgebra as LA

27import Numeric.LinearAlgebra.Static

32import Numeric.LinearAlgebra.Static

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

29import Grenade.Core

34import Grenade.Core

30import Grenade.Recurrent.Core

35import Grenade.Recurrent.Core

31import Grenade.Layers.Internal.Update

36import Grenade.Layers.Internal.Update

32−import GHC.TypeLits

33

37

34

38

35-- | Long Short Term Memory Recurrent unit

39-- | Long Short Term Memory Recurrent unit

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

71

75

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

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

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

74− runUpdate lp (LSTM w m) g =

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

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

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

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

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

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

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

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

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

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

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

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

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

95+ descendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum

92

96

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

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

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

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

99+ descendVector learningRate learningMomentum learningRegulariser weights gradient momentum

96

100

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

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

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

@@ -133,18 +137,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)

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

138 -- Forward propagation for the LSTM layer.

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

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

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

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

137 let -- Forget state vector

141 let -- Forget state vector

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

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

139 f_t = sigmoid f_s

143 f_t = sigmoid f_s

140 -- Input state vector

144 -- Input state vector

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

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

142 i_t = sigmoid i_s

146 i_t = sigmoid i_s

143 -- Output state vector

147 -- Output state vector

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

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

145 o_t = sigmoid o_s

149 o_t = sigmoid o_s

146 -- Cell input state vector

150 -- Cell input state vector

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

151+ c_s = lstmBc + lstmWc #> input

148 c_x = tanh c_s

152 c_x = tanh c_s

149 -- Cell state

153 -- Cell state

150 c_t = f_t * cell + i_t * c_x

154 c_t = f_t * cell + i_t * c_x

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

158 --

162 --

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

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

160 -- suite. These should match always.

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

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

166 let -- Reverse Mode AD Derivitives

163 c_t' = h_t' * o_t + cellGrad

167 c_t' = h_t' * o_t + cellGrad

164

168

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

175 c_s' = tanh' c_s * c_x'

179 c_s' = tanh' c_s * c_x'

176

180

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

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

182+ 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'

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

180

184

181 -- Calculate the gradient Matricies for the input

185 -- Calculate the gradient Matricies for the input

182 lstmWf' = f_s' `outer` input

186 lstmWf' = f_s' `outer` input

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

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

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

236

240

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

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

238− put (LSTM lw _) = do

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

239− u (lstmWf lw)

243+ u lstmWf

240− u (lstmUf lw)

244+ u lstmUf

241− v (lstmBf lw)

245+ v lstmBf

242− u (lstmWi lw)

246+ u lstmWi

243− u (lstmUi lw)

247+ u lstmUi

244− v (lstmBi lw)

248+ v lstmBi

245− u (lstmWo lw)

249+ u lstmWo

246− u (lstmUo lw)

250+ u lstmUo

247− v (lstmBo lw)

251+ v lstmBo

248− u (lstmWc lw)

252+ u lstmWc

249− v (lstmBc lw)

253+ v lstmBc

250− where

254+ where

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

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

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

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

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

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

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

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

255

259

256 get = do

260 get = do

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

261+ lstmWf <- u

262+ lstmUf <- u

263+ lstmBf <- v

264+ lstmWi <- u

265+ lstmUi <- u

266+ lstmBi <- v

267+ lstmWo <- u

268+ lstmUo <- u

269+ lstmBo <- v

270+ lstmWc <- u

271+ lstmBc <- v

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

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

259− where

273+ where

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

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

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

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

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

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

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

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

265−

279+

266− w0 = konst 0

280+ w0 = konst 0

267− u0 = konst 0

281+ u0 = konst 0

268− v0 = konst 0

282+ 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/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/Network.hs+3

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

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+18−12

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

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)