master..f19da0f · grenade

examples/grenade-examples.cabal+5−6

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

2626 , bytestring

2727 , cereal

2828 , either

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

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

3030 , text == 1.2.*

3131 , mtl >= 2.2.1 && < 2.3

3232 , hmatrix

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

4242 , grenade

4343 , attoparsec

4444 , either

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

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

4646 , text == 1.2.*

4747 , mtl >= 2.2.1 && < 2.3

4848 , hmatrix >= 0.18 && < 0.21

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

6161 , bytestring

6262 , cereal

6363 , either

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

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

6565 , text == 1.2.*

6666 , mtl >= 2.2.1 && < 2.3

6767 , hmatrix >= 0.18 && < 0.21

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

7878 , grenade

7979 , attoparsec

8080 , either

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

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

8282 , text == 1.2.*

8383 , mtl >= 2.2.1 && < 2.3

8484 , hmatrix >= 0.18 && < 0.21

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

9696 , bytestring

9797 , cereal

9898 , either

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

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

100100 , text == 1.2.*

101101 , mtl >= 2.2.1 && < 2.3

102102 , hmatrix >= 0.18 && < 0.21

103103 , transformers

104104 , semigroups

105105 , singletons

106− , singletons-base

107106 , vector

108107 , MonadRandom

109108 , containers

examples/main/shakespeare.hs+20−14

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

11{-# LANGUAGE BangPatterns #-}

22{-# LANGUAGE CPP #-}

3+{-# LANGUAGE RecordWildCards #-}

34{-# LANGUAGE DataKinds #-}

45{-# LANGUAGE ScopedTypeVariables #-}

56{-# LANGUAGE TypeOperators #-}

@@ -14,15 +15,22 @@ import Data.Char ( isUpper, toUpper, toLower )

1415import Data.List ( foldl' )

1516import Data.Maybe ( fromMaybe )

1617

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

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

20+#endif

1721

1822import qualified Data.Vector as V

1923import Data.Vector ( Vector )

2024

2125import qualified Data.Map as M

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

27+import Data.Proxy ( Proxy (..) )

28+#endif

2229

2330import qualified Data.ByteString as B

2431import Data.Serialize

2532

33+import Data.Singletons.Prelude

2634import GHC.TypeLits

2735

2836import Numeric.LinearAlgebra.Static ( konst )

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

3442import Grenade.Utils.OneHot

3543

3644import System.IO.Unsafe ( unsafeInterleaveIO )

37−import Data.Proxy

38−import Prelude.Singletons

3945

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

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

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

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

7884

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

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

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

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

8288 in case reverse e of

8389 (o : l : xs) ->

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

85− in trainRecurrent lrate net recIns examples

91+ in trainRecurrent rate net recIns examples

8692 _ -> error "Not enough input"

8793 where

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

8995

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

91−runShakespeare opts = do

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

97+runShakespeare ShakespeareOpts {..} = do

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

9399 (net0, i0) <- lift $

94− case loadPath opts of

100+ case loadPath of

95101 Just loadFile -> netLoad loadFile

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

97103

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

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

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

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

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

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

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

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

103109 putStrLn (unAnnotateCapitals results)

104110 return (trained, bestInput)

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

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

106112

107− case savePath opts of

113+ case savePath of

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

109115 Nothing -> return ()

110116

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

116122 -> Vector a

117123 -> S ('D1 n)

118124 -> IO [a]

119−generateParagraph n s temp hotmap hotdict =

125+generateParagraph n s temperature hotmap hotdict =

120126 go s

121127 where

122128 go x y =

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

124− un <- sample temp hotdict o

130+ un <- sample temperature hotdict o

125131 Just re <- return $ makeHot hotmap un

126132 rest <- unsafeInterleaveIO $ go ns re

127133 return (un : rest)

grenade.cabal+1−2

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

3838library

3939 build-depends:

4040 base >= 4.8 && < 5

41− , bytestring >= 0.10.0

41+ , bytestring == 0.10.*

4242 , containers >= 0.5 && < 0.7

4343 , cereal >= 0.5 && < 0.6

4444 , deepseq >= 1.4 && < 1.5

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

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

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

5050 , singletons

51− , singletons-base

5251 , vector >= 0.11 && < 0.13

5352

5453 ghc-options:

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

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

3434import Control.Monad.Random ( MonadRandom )

3535

3636import Data.Singletons

37+import Data.Singletons.Prelude

3738import Data.Serialize

3839

3940#if MIN_VERSION_base(4,9,0)

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

4344import Grenade.Core.Layer

4445import Grenade.Core.LearningParameters

4546import Grenade.Core.Shape

46−import Prelude.Singletons

4747

4848-- | Type of a network.

4949--

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

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

1313 , runNet

1414 ) where

1515

16+import Data.Singletons.Prelude

1617

1718import Grenade.Core.LearningParameters

1819import Grenade.Core.Network

1920import Grenade.Core.Shape

20−import Data.Singletons

21−import Prelude.Singletons

2221

2322-- | Perform reverse automatic differentiation on the network

2423-- for the current input and expected output.

src/Grenade/Core/Shape.hs+31−16

@@ -21,20 +21,35 @@ Stability : experimental

2121module Grenade.Core.Shape (

2222 S (..)

2323 , Shape (..)

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

2425 , SShape (..)

26+#else

27+ , Sing (..)

28+#endif

29+

2530 , randomOfShape

2631 , fromStorable

2732 ) where

2833

2934import Control.DeepSeq (NFData (..))

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

36+

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

3138import Data.Kind (Type)

39+#endif

3240import Data.Proxy

3341import Data.Serialize

3442import Data.Singletons

43+import Data.Singletons.TypeLits

3544import Data.Vector.Storable ( Vector )

3645import qualified Data.Vector.Storable as V

46+

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

48+import GHC.TypeLits hiding (natVal)

49+#else

3750import GHC.TypeLits

51+#endif

52+

3853import qualified Numeric.LinearAlgebra.Static as H

3954import Numeric.LinearAlgebra.Static

4055import qualified Numeric.LinearAlgebra as NLA

@@ -84,9 +99,9 @@ deriving instance Show (S n)

8499type instance Sing = SShape

85100

86101data 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)

102+ D1Sing :: Sing a -> SShape ('D1 a)

103+ D2Sing :: Sing a -> Sing b -> SShape ('D2 a b)

104+ D3Sing :: KnownNat (a * c) => Sing a -> Sing b -> Sing c -> SShape ('D3 a b c)

90105#else

91106data instance Sing (n :: Shape) where

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

@@ -95,11 +110,11 @@ data instance Sing (n :: Shape) where

95110#endif

96111

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

98− sing = D1Sing

113+ sing = D1Sing sing

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

100− sing = D2Sing

115+ sing = D2Sing sing sing

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

102− sing = D3Sing

117+ sing = D3Sing sing sing sing

103118

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

105120 (+) = n2 (+)

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

148163randomOfShape = do

149164 seed :: Int <- getRandom

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

151− D1Sing ->

166+ D1Sing SNat ->

152167 S1D (randomVector seed Uniform * 2 - 1)

153168

154− D2Sing ->

169+ D2Sing SNat SNat ->

155170 S2D (uniformSample seed (-1) 1)

156171

157− D3Sing ->

172+ D3Sing SNat SNat SNat ->

158173 S3D (uniformSample seed (-1) 1)

159174

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

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

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

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

164179fromStorable xs = case sing :: Sing x of

165− D1Sing ->

180+ D1Sing SNat ->

166181 S1D <$> H.create xs

167182

168− D2Sing ->

183+ D2Sing SNat SNat ->

169184 S2D <$> mkL xs

170185

171− D3Sing ->

186+ D3Sing SNat SNat SNat ->

172187 S3D <$> mkL xs

173188 where

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

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

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

206221

207222-- Helper function for creating the number instances

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

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

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

210− D1Sing ->

225+ D1Sing SNat ->

211226 S1D (konst x)

212227

213− D2Sing ->

228+ D2Sing SNat SNat ->

214229 S2D (konst x)

215230

216− D3Sing ->

231+ D3Sing SNat SNat SNat ->

217232 S3D (konst x)

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

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

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DataKinds #-}

33{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE RecordWildCards #-}

45{-# LANGUAGE GADTs #-}

56{-# LANGUAGE TypeOperators #-}

67{-# LANGUAGE TypeFamilies #-}

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

2829import Data.Maybe

2930import Data.Proxy

3031import Data.Serialize

32+import Data.Singletons.TypeLits

3133

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

35+import GHC.TypeLits hiding (natVal)

36+#else

3237import GHC.TypeLits

38+#endif

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

3340import Data.Kind (Type)

41+#endif

3442

3543import Numeric.LinearAlgebra hiding ( uniformSample, konst )

3644import qualified Numeric.LinearAlgebra as LA

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

131139 , KnownNat (kernelRows * kernelColumns * channels)

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

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

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

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

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

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

136144 in Convolution newKernel newMomentum

137145

138146 createRandom = randomConvolution

src/Grenade/Layers/Crop.hs+7

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

2121import Data.Maybe

2222import Data.Proxy

2323import Data.Serialize

24+import Data.Singletons.TypeLits

2425

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

27+import GHC.TypeLits hiding (natVal)

28+#else

2529import GHC.TypeLits

30+#endif

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

2632import Data.Kind (Type)

33+#endif

2734

2835import Grenade.Core

2936import Grenade.Layers.Internal.Pad

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

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

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DataKinds #-}

33{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE RecordWildCards #-}

45{-# LANGUAGE GADTs #-}

56{-# LANGUAGE TypeOperators #-}

67{-# LANGUAGE TypeFamilies #-}

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

3233import Data.Maybe

3334import Data.Proxy

3435import Data.Serialize

36+import Data.Singletons.TypeLits

3537

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

39+import GHC.TypeLits hiding (natVal)

40+#else

3641import GHC.TypeLits

42+#endif

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

3744import Data.Kind (Type)

45+#endif

3846

3947import Numeric.LinearAlgebra hiding ( uniformSample, konst )

4048import qualified Numeric.LinearAlgebra as LA

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

130138 , KnownNat (kernelRows * kernelColumns * filters)

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

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

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

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

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

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

135143 in Deconvolution newKernel newMomentum

136144

137145 createRandom = randomDeconvolution

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

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

11{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE RecordWildCards #-}

23{-# LANGUAGE TypeOperators #-}

34{-# LANGUAGE TypeFamilies #-}

45{-# LANGUAGE MultiParamTypeClasses #-}

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

1314

1415import Data.Proxy

1516import Data.Serialize

17+import Data.Singletons.TypeLits

1618

1719import qualified Numeric.LinearAlgebra as LA

1820import Numeric.LinearAlgebra.Static

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

2022import Grenade.Core

2123

2224import Grenade.Layers.Internal.Update

23−import GHC.TypeLits

2425

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

2627data FullyConnected i o = FullyConnected

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

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

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

3940

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

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

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

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

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

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

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

4445

4546 createRandom = randomFullyConnected

src/Grenade/Layers/Pad.hs+7

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

2121import Data.Maybe

2222import Data.Proxy

2323import Data.Serialize

24+import Data.Singletons.TypeLits

2425

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

27+import GHC.TypeLits hiding (natVal)

28+#else

2529import GHC.TypeLits

30+#endif

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

2632import Data.Kind (Type)

33+#endif

2734

2835import Grenade.Core

2936import Grenade.Layers.Internal.Pad

src/Grenade/Layers/Pooling.hs+7

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

2222import Data.Maybe

2323import Data.Proxy

2424import Data.Serialize

25+import Data.Singletons.TypeLits

2526

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

28+import GHC.TypeLits hiding (natVal)

29+#else

2630import GHC.TypeLits

31+#endif

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

2733import Data.Kind (Type)

34+#endif

2835

2936import Grenade.Core

3037import Grenade.Layers.Internal.Pooling

src/Grenade/Layers/Reshape.hs+1

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

1717

1818import Data.Serialize

1919

20+import Data.Singletons.TypeLits

2021import GHC.TypeLits

2122

2223import Numeric.LinearAlgebra.Static

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

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

2929

3030

3131import Control.Monad.Random ( MonadRandom )

32+import Data.Singletons ( SingI )

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

3234import Data.Serialize

3335

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

3437import Data.Kind (Type)

38+#endif

3539

3640import Grenade.Core

3741import Grenade.Recurrent.Core.Layer

38−import Prelude.Singletons

3942

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

4144-- forward layer.

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

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

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE FlexibleContexts #-}

88{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE RecordWildCards #-}

910

1011module Grenade.Recurrent.Core.Runner (

1112 runRecurrentExamples

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

1718 ) where

1819

1920import Data.List ( foldl' )

21+import Data.Singletons.Prelude

2022import Grenade.Core

2123

2224import Grenade.Recurrent.Core.Network

23−import Prelude.Singletons

2425

2526type RecurrentGradients layers = [RecurrentGradient layers]

2627

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

100101 -> RecurrentInputs sublayers

101102 -> RecurrentInputs sublayers

102103

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

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

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

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

105106

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

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

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

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

108109

109110updateRecInputs _ RINil RINil

110111 = RINil

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

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

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DataKinds #-}

33{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE RecordWildCards #-}

45{-# LANGUAGE TypeOperators #-}

56{-# LANGUAGE TypeFamilies #-}

67{-# LANGUAGE MultiParamTypeClasses #-}

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

1617

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

1819

20+import Data.Singletons.TypeLits

1921

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

2023import Data.Kind (Type)

24+#endif

2125

2226import Numeric.LinearAlgebra.Static

2327

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

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

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

5862

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

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

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

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

6165 newBias = oldBias + newBiasMomentum

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

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

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

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

6468 newActivations = oldActivations + newMomentum - regulariser

6569 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

6670

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

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

33{-# LANGUAGE DataKinds #-}

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE RecordWildCards #-}

67{-# LANGUAGE TypeOperators #-}

78{-# LANGUAGE TypeFamilies #-}

89{-# LANGUAGE MultiParamTypeClasses #-}

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

2122-- import Data.List ( foldl1' )

2223import Data.Proxy

2324import Data.Serialize

25+import Data.Singletons.TypeLits

26+

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

2428import Data.Kind (Type)

29+#endif

2530

2631import qualified Numeric.LinearAlgebra as LA

2732import Numeric.LinearAlgebra.Static

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

2934import Grenade.Core

3035import Grenade.Recurrent.Core

3136import Grenade.Layers.Internal.Update

32−import GHC.TypeLits

3337

3438

3539-- | Long Short Term Memory Recurrent unit

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

7175

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

7377 -- 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 =

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

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

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

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

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

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

9094 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

9296

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

9498 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

96100

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

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

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

134138 -- Forward propagation for the LSTM layer.

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

137141 let -- Forget state vector

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

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

139143 f_t = sigmoid f_s

140144 -- Input state vector

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

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

142146 i_t = sigmoid i_s

143147 -- Output state vector

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

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

145149 o_t = sigmoid o_s

146150 -- Cell input state vector

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

151+ c_s = lstmBc + lstmWc #> input

148152 c_x = tanh c_s

149153 -- Cell state

150154 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

158162 --

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

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

162166 let -- Reverse Mode AD Derivitives

163167 c_t' = h_t' * o_t + cellGrad

164168

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

175179 c_s' = tanh' c_s * c_x'

176180

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

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

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

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

180184

181185 -- Calculate the gradient Matricies for the input

182186 lstmWf' = f_s' `outer` input

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

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

236240

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

238− put (LSTM lw _) = do

239− u (lstmWf lw)

240− u (lstmUf lw)

241− v (lstmBf lw)

242− u (lstmWi lw)

243− u (lstmUi lw)

244− v (lstmBi lw)

245− u (lstmWo lw)

246− u (lstmUo lw)

247− v (lstmBo lw)

248− u (lstmWc lw)

249− v (lstmBc lw)

250− where

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

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

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

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

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

243+ u lstmWf

244+ u lstmUf

245+ v lstmBf

246+ u lstmWi

247+ u lstmUi

248+ v lstmBi

249+ u lstmWo

250+ u lstmUo

251+ v lstmBo

252+ u lstmWc

253+ v lstmBc

254+ where

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

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

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

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

255259

256260 get = do

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

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

259− where

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

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

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

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

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

265−

266− w0 = konst 0

267− u0 = konst 0

268− v0 = konst 0

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

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

273+ where

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

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

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

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

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

279+

280+ w0 = konst 0

281+ u0 = konst 0

282+ v0 = konst 0

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

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

2222import qualified Data.Map as M

2323

2424import Data.Proxy

25+import Data.Singletons.TypeLits

2526

2627import Data.Vector ( Vector )

2728import qualified Data.Vector as V

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

3031import Numeric.LinearAlgebra ( maxIndex )

3132import Numeric.LinearAlgebra.Devel

3233import Numeric.LinearAlgebra.Static

33−import GHC.TypeLits

3434

3535import Grenade.Core.Shape

3636

stack.yaml+1−7

@@ -20,7 +20,7 @@

2020#

2121# resolver: ./custom-snapshot.yaml

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

23−resolver: lts-20.18

23+resolver: lts-15.5

2424

2525# User packages to be built.

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

@@ -70,9 +70,3 @@ extra-deps:

7070#

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

7272# compiler-check: newer-minor

73−

74−nix:

75− enable: true

76− packages:

77− - blas

78− - lapack

stack.yaml.lock+5−5

@@ -7,13 +7,13 @@ packages:

77- completed:

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

99 pantry-tree:

10− sha256: 6a42a462f98e94933b6e9721acd912c6c6b6a4743635efd15cc5871908c816a0

1110 size: 469

11+ sha256: 6a42a462f98e94933b6e9721acd912c6c6b6a4743635efd15cc5871908c816a0

1212 original:

1313 hackage: typelits-witnesses-0.3.0.3

1414snapshots:

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

16+ size: 491372

17+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/5.yaml

18+ sha256: 1b549cfff328040c382a70a84a2087aac8dab6d778bf92f32a93a771a1980dfc

19+ original: lts-15.5

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

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

66{-# LANGUAGE DeriveFunctor #-}

77{-# LANGUAGE DeriveFoldable #-}

88{-# LANGUAGE DeriveTraversable #-}

9+{-# LANGUAGE RecordWildCards #-}

910{-# LANGUAGE FlexibleContexts #-}

1011{-# LANGUAGE RankNTypes #-}

1112

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

1415

1516import Data.Reflection

1617import Numeric.AD.Mode.Reverse

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

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

1819

19−import GHC.TypeLits (KnownNat)

20−

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

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

23−

2421import qualified Numeric.LinearAlgebra.Static as S

2522import qualified Numeric.LinearAlgebra as H

2623

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

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

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

5956

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

61−lstmToReference lw =

62− RefLSTM

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

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

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

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

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

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

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

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

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

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

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

74− }

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

58+lstmToReference LSTM.LSTMWeights {..} =

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

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

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

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

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

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

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

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

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

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

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

70+ in RefLSTM {..}

7571

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

77−runLSTM rl cell input =

73+runLSTM RefLSTM {..} cell input =

7874 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

8076 -- Input state vector

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

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

8278 -- Output state vector

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

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

8480 -- Cell input state vector

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

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

8682 -- Cell state

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

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