bcd1856 · grenade · git.iko.soy

git.iko.soy/grenade

on master help sign in

Update LSTM

bcd1856Huw Campbell10 years ago

README.md+12−8

compare with master

unifiedsplit

@@ -23,9 +23,18 @@ randomMnist :: MonadRandom m => m MNIST

23randomMnist = randomNetwork

24```

26−And that's it. Because the types are rich, there's no specific term level code

26+And that's it. Because the types are so rich, there's no specific term level code

27−required; although it is of course possible and easy to construct one explicitly

27+required to construct this network; although it is of course possible and

28−oneself.

28+easy to construct and deconstruct the networks and layers explicitly oneself.

29+

30+If recurrent neural networks are more your style, you can try defining something

31+["unreasonably effective"](http://karpathy.github.io/2015/05/21/rnn-effectiveness/)

32+with

33+```haskell

34+type Shakespeare = RecurrentNetwork '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyConnected 40 40), F Logit]

35+ '[ 'D1 40, 'D1 80, 'D1 40, 'D1 40, 'D1 40 ]

36+```

37+

30The network can be thought of as a heterogeneous list of layers, where its type

39The network can be thought of as a heterogeneous list of layers, where its type

31includes not only the layers of the network, but also the shapes of data that

40includes not only the layers of the network, but also the shapes of data that

@@ -107,13 +116,8 @@ Being purely functional, it should also be easy to run batches in parallel, whic

107would be appropriate for larger networks, my current examples however are single

116would be appropriate for larger networks, my current examples however are single

108threaded.

117threaded.

109

118

110−<<<<<<< 20e7e483d75613f16580baa71b44fa9864c940fd

111Training 15 generations over Kaggle's 41000 sample MNIST training set on a single

119Training 15 generations over Kaggle's 41000 sample MNIST training set on a single

112core took around 12 minutes, achieving 1.5% error rate on a 1000 sample holdout set.

120core took around 12 minutes, achieving 1.5% error rate on a 1000 sample holdout set.

113−=======

114−Training 15 generations over Kaggle's 42000 sample MNIST training set took under

115−an hour on my laptop, achieving 0.5% error rate on a 1000 sample holdout set.

116−>>>>>>> Add very basic model saving and loading

117

121

118Contributing

122Contributing

119------------

123------------

grenade.cabal+2

@@ -135,6 +135,8 @@ executable shakespeare

135 build-depends: base

136 , grenade

137 , attoparsec

138+ , bytestring

139+ , cereal

138 , either

140 , either

139 , optparse-applicative == 0.12.*

141 , optparse-applicative == 0.12.*

140 , text == 1.2.*

142 , text == 1.2.*

main/shakespeare.hs+41−19

@@ -11,7 +11,7 @@ import Control.Monad.Random

11import Control.Monad.Trans.Except

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

14−import Data.List ( unfoldr, foldl' )

14+import Data.List ( foldl' )

15import Data.Maybe ( fromMaybe )

17import qualified Data.Vector as V

@@ -20,6 +20,8 @@ import Data.Vector ( Vector )

20import qualified Data.Map as M

21import Data.Proxy ( Proxy (..) )

23+import qualified Data.ByteString as B

24+import Data.Serialize

24import Data.Singletons.Prelude

26import Data.Singletons.Prelude

25import GHC.TypeLits

27import GHC.TypeLits

@@ -32,29 +34,31 @@ import Grenade

32import Grenade.Recurrent

34import Grenade.Recurrent

33import Grenade.Utils.OneHot

35import Grenade.Utils.OneHot

37+import System.IO.Unsafe ( unsafeInterleaveIO )

38+

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

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

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

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

37-- about an hour.

41-- about an hour.

38--

42--

39−-- This is a first class recurrent net, although it's similar to

43+-- This is a first class recurrent net.

40−-- an unrolled graph.

41--

44--

42-- The F and R types are tagging types to ensure that the runner and

45-- The F and R types are tagging types to ensure that the runner and

43-- creation function know how to treat the layers.

46-- creation function know how to treat the layers.

44--

47--

45-- As an example, here's a short sequence generated.

48-- As an example, here's a short sequence generated.

46--

49--

47−-- > the see and and the sir, and and the make and the make and go the make and go the make and the

50+-- > KING RICHARD III:

48−--

51+-- > And as the heaven her his words, we the son, I show sand stape but the lament to shall were the sons with a strend

52+

49type F = FeedForward

53type F = FeedForward

50type R = Recurrent

54type R = Recurrent

52-- The definition of our network

56-- The definition of our network

53−type Shakespeare = RecurrentNetwork '[ R (LSTM 40 50), R (LSTM 50 40), F (FullyConnected 40 40), F Logit]

57+type Shakespeare = RecurrentNetwork '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyConnected 40 40), F Logit]

54− '[ 'D1 40, 'D1 50, 'D1 40, 'D1 40, 'D1 40 ]

58+ '[ 'D1 40, 'D1 80, 'D1 40, 'D1 40, 'D1 40 ]

56-- The definition of the "sideways" input, which the network if fed recurrently.

60-- The definition of the "sideways" input, which the network if fed recurrently.

57−type Shakespearian = RecurrentInputs '[ R (LSTM 40 50), R (LSTM 50 40), F (FullyConnected 40 40), F Logit]

61+type Shakespearian = RecurrentInputs '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyConnected 40 40), F Logit]

59randomNet :: MonadRandom m => m (Shakespeare, Shakespearian)

63randomNet :: MonadRandom m => m (Shakespeare, Shakespearian)

60randomNet = randomRecurrent

64randomNet = randomRecurrent

@@ -82,15 +86,23 @@ trainSlice !rate !net !recIns input offset size =

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

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

83runShakespeare ShakespeareOpts {..} = do

87runShakespeare ShakespeareOpts {..} = do

84 (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare trainingFile

88 (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare trainingFile

85− (net0, i0) <- lift randomNet

89+ (net0, i0) <- lift $

90+ case loadPath of

91+ Just loadFile -> netLoad loadFile

92+ Nothing -> randomNet

93+

86− lift $ foldM_ (\(!net, !io) size -> do

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

87 xs <- take (iterations `div` 15) <$> getRandomRs (0, length shakespeare - size - 1)

95 xs <- take (iterations `div` 15) <$> getRandomRs (0, length shakespeare - size - 1)

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

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

89− let results = take 100 $ generateParagraph trained bestInput oneHotMap oneHotDictionary ( S1D $ konst 0)

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

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

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

91 putStrLn (unAnnotateCapitals results)

99 putStrLn (unAnnotateCapitals results)

92 return (trained, bestInput)

100 return (trained, bestInput)

93− ) (net0, i0) [10,10,15,15,20,20,25,25,30,30,35,35,40,40,50 :: Int]

101+ ) (net0, i0) [50,50,50,50,50,50,50,50,50,50,50,50,50,50,50 :: Int]

102+

103+ case savePath of

104+ Just saveFile -> lift . B.writeFile saveFile $ runPut (put (trained, bestInput))

105+ Nothing -> return ()

106

95generateParagraph :: forall layers shapes n a. (Last shapes ~ 'D1 n, Head shapes ~ 'D1 n, KnownNat n, Ord a)

107generateParagraph :: forall layers shapes n a. (Last shapes ~ 'D1 n, Head shapes ~ 'D1 n, KnownNat n, Ord a)

96 => RecurrentNetwork layers shapes

108 => RecurrentNetwork layers shapes

@@ -98,20 +110,23 @@ generateParagraph :: forall layers shapes n a. (Last shapes ~ 'D1 n, Head shapes

98 -> M.Map a Int

110 -> M.Map a Int

99 -> Vector a

111 -> Vector a

100 -> S ('D1 n)

112 -> S ('D1 n)

101− -> [a]

113+ -> IO [a]

102−generateParagraph n s hotmap hotdict i =

114+generateParagraph n s hotmap hotdict =

103− unfoldr go (s, i)

115+ go s

104 where

116 where

105− go (x, y) =

117+ go x y =

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

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

107− un <- unHot hotdict o

119+ un <- sample 0.4 hotdict o

108− re <- makeHot hotmap un

120+ Just re <- return $ makeHot hotmap un

109− Just (un, (ns, re))

121+ rest <- unsafeInterleaveIO $ go ns re

122+ return (un : rest)

110

123

111data ShakespeareOpts = ShakespeareOpts {

124data ShakespeareOpts = ShakespeareOpts {

112 trainingFile :: FilePath

125 trainingFile :: FilePath

113 , iterations :: Int

126 , iterations :: Int

114 , rate :: LearningParameters

127 , rate :: LearningParameters

128+ , loadPath :: Maybe FilePath

129+ , savePath :: Maybe FilePath

115 }

130 }

116

131

117shakespeare' :: Parser ShakespeareOpts

132shakespeare' :: Parser ShakespeareOpts

@@ -122,6 +137,8 @@ shakespeare' = ShakespeareOpts <$> argument str (metavar "TRAIN")

122 <*> option auto (long "momentum" <> value 0.95)

137 <*> option auto (long "momentum" <> value 0.95)

123 <*> option auto (long "l2" <> value 0.000001)

138 <*> option auto (long "l2" <> value 0.000001)

124 )

139 )

140+ <*> optional (strOption (long "load"))

141+ <*> optional (strOption (long "save"))

125

142

126main :: IO ()

143main :: IO ()

127main = do

144main = do

@@ -132,6 +149,11 @@ main = do

132 Left err -> putStrLn err

149 Left err -> putStrLn err

133

150

134

151

152+netLoad :: FilePath -> IO (Shakespeare, Shakespearian)

153+netLoad modelPath = do

154+ modelData <- B.readFile modelPath

155+ either fail return $ runGet get modelData

156+

135-- Replace capitals with an annotation and the lower case letter

157-- Replace capitals with an annotation and the lower case letter

136-- http://fastml.com/one-weird-trick-for-training-char-rnns/

158-- http://fastml.com/one-weird-trick-for-training-char-rnns/

137annotateCapitals :: String -> String

159annotateCapitals :: String -> String

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

@@ -65,30 +65,36 @@ data S (n :: Shape) where

66deriving instance Show (S n)

68+-- Singletons

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

70+-- clear and makes adding the KnownNat constraints simple.

71+data instance Sing (n :: Shape) where

72+ D1Sing :: KnownNat a => Sing ('D1 a)

73+ D2Sing :: (KnownNat a, KnownNat b) => Sing ('D2 a b)

74+ D3Sing :: (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => Sing ('D3 a b c)

75+

76+instance KnownNat a => SingI ('D1 a) where

77+ sing = D1Sing

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

79+ sing = D2Sing

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

81+ sing = D3Sing

82+

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

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

69 (+) = n2 (+)

84 (+) = n2 (+)

70 (-) = n2 (-)

85 (-) = n2 (-)

71 (*) = n2 (*)

86 (*) = n2 (*)

72 abs = n1 abs

87 abs = n1 abs

73 signum = n1 signum

88 signum = n1 signum

74− fromInteger x = case (sing :: Sing x) of

75− D1Sing -> S1D (konst $ fromInteger x)

76− D2Sing -> S2D (konst $ fromInteger x)

77− D3Sing -> S3D (konst $ fromInteger x)

89+ fromInteger x = nk (fromInteger x)

79instance SingI x => Fractional (S x) where

91instance SingI x => Fractional (S x) where

80 (/) = n2 (/)

92 (/) = n2 (/)

81 recip = n1 recip

93 recip = n1 recip

82− fromRational x = case (sing :: Sing x) of

83− D1Sing -> S1D (konst $ fromRational x)

84− D2Sing -> S2D (konst $ fromRational x)

85− D3Sing -> S3D (konst $ fromRational x)

94+ fromRational x = nk (fromRational x)

87instance SingI x => Floating (S x) where

96instance SingI x => Floating (S x) where

88− pi = case (sing :: Sing x) of

97+ pi = nk pi

89− D1Sing -> S1D (konst pi)

90− D2Sing -> S2D (konst pi)

91− D3Sing -> S3D (konst pi)

92 exp = n1 exp

98 exp = n1 exp

93 log = n1 log

99 log = n1 log

94 sqrt = n1 sqrt

100 sqrt = n1 sqrt

@@ -107,21 +113,6 @@ instance SingI x => Floating (S x) where

107 acosh = n1 acosh

113 acosh = n1 acosh

108 atanh = n1 atanh

114 atanh = n1 atanh

109

115

110−-- Singletons

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

112−-- clear and makes adding the KnownNat constraints simple.

113−data instance Sing (n :: Shape) where

114− D1Sing :: KnownNat a => Sing ('D1 a)

115− D2Sing :: (KnownNat a, KnownNat b) => Sing ('D2 a b)

116− D3Sing :: (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => Sing ('D3 a b c)

117−

118−instance KnownNat a => SingI ('D1 a) where

119− sing = D1Sing

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

121− sing = D2Sing

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

123− sing = D3Sing

124−

125--

116--

126-- I haven't made shapes strict, as sometimes they're not needed

117-- I haven't made shapes strict, as sometimes they're not needed

127-- (the last input gradient back for instance)

118-- (the last input gradient back for instance)

@@ -170,3 +161,10 @@ n2 f (S1D x) (S1D y) = S1D (f x y)

170n2 f (S2D x) (S2D y) = S2D (f x y)

161n2 f (S2D x) (S2D y) = S2D (f x y)

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

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

172n2 _ _ _ = error "Impossible to have different constructors for the same shaped network"

163n2 _ _ _ = error "Impossible to have different constructors for the same shaped network"

164+

165+-- Helper function for creating the number instances

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

167+nk x = case (sing :: Sing x) of

168+ D1Sing -> S1D (konst x)

169+ D2Sing -> S2D (konst x)

170+ D3Sing -> S3D (konst x)

src/Grenade/Recurrent/Core/Network.hs+40

@@ -19,10 +19,15 @@ module Grenade.Recurrent.Core.Network (

20import Control.Monad.Random ( MonadRandom )

21import Data.Singletons ( SingI )

22+import Data.Serialize

23+import qualified Data.Vector.Storable as V

23import Grenade.Core.Shape

25import Grenade.Core.Shape

24import Grenade.Core.Network

26import Grenade.Core.Network

28+import qualified Numeric.LinearAlgebra as LA

29+import qualified Numeric.LinearAlgebra.Static as LAS

30+

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

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

28-- forward layer.

33-- forward layer.

@@ -96,3 +101,38 @@ instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': r ': rs)) =

96 (rest, resti) <- randomRecurrent

101 (rest, resti) <- randomRecurrent

97 return (thisLayer :~@> rest, thisShape :~@+> resti)

102 return (thisLayer :~@> rest, thisShape :~@+> resti)

103

104+-- | Add very simple serialisation to the recurrent network

105+instance (SingI i, SingI o, Layer x i o, Serialize x) => Serialize (RecurrentNetwork '[FeedForward x] '[i, o]) where

106+ put (OR x) = put x

107+ put _ = error "impossible"

108+ get = OR <$> get

109+

110+instance (SingI i, Layer x i o, Serialize x, Serialize (RecurrentNetwork xs (o ': r ': rs))) => Serialize (RecurrentNetwork (FeedForward x ': xs) (i ': o ': r ': rs)) where

111+ put (x :~~> r) = put x >> put r

112+ get = (:~~>) <$> get <*> get

113+

114+instance (SingI i, RecurrentLayer x i o, Serialize x, Serialize (RecurrentNetwork xs (o ': r ': rs))) => Serialize (RecurrentNetwork (Recurrent x ': xs) (i ': o ': r ': rs)) where

115+ put (x :~@> r) = put x >> put r

116+ get = (:~@>) <$> get <*> get

117+

118+instance (UpdateLayer x) => (Serialize (RecurrentInputs '[FeedForward x])) where

119+ put _ = return ()

120+ get = return (ORS ())

121+

122+instance (UpdateLayer x, Serialize (RecurrentInputs (y ': ys))) => (Serialize (RecurrentInputs (FeedForward x ': y ': ys))) where

123+ put ( () :~~+> rest) = put rest

124+ get = ( () :~~+> ) <$> get

125+

126+instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs (y ': ys))) => (Serialize (RecurrentInputs (Recurrent x ': y ': ys))) where

127+ put ( i :~@+> rest ) = do

128+ _ <- (case i of

129+ (S1D x) -> putListOf put . LA.toList . LAS.extract $ x

130+ (S2D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

131+ (S3D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

132+ ) :: PutM ()

133+ put rest

134+

135+ get = do

136+ Just i <- fromStorable . V.fromList <$> getListOf get

137+ rest <- get

138+ return ( i :~@+> rest)

src/Grenade/Recurrent/Core/Runner.hs+7−1

@@ -19,6 +19,12 @@ import Grenade.Core.Shape

19import Grenade.Recurrent.Core.Network

21-- | Drive and network and collect its back propogated gradients.

22+--

23+-- TODO: split this nicely into backpropagate and update.

24+--

25+-- QUESTION: Should we return a list of gradients or the sum of

26+-- the gradients? It's different taking into account

27+-- momentum and L2.

22trainRecurrent :: forall shapes layers. SingI (Last shapes)

28trainRecurrent :: forall shapes layers. SingI (Last shapes)

23 => LearningParameters

29 => LearningParameters

24 -> RecurrentNetwork layers shapes

30 -> RecurrentNetwork layers shapes

@@ -94,7 +100,7 @@ trainRecurrent rate network recinputs examples =

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

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

101

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

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

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

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

104

99 updateRecInputs _ (ORS ()) (ORS ())

105 updateRecInputs _ (ORS ()) (ORS ())

100 = ORS ()

106 = ORS ()

src/Grenade/Recurrent/Layers/LSTM.hs+48−1

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

8{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE ViewPatterns #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12-- GHC 7.10 doesn't see recurrent run functions as total.

13-- GHC 7.10 doesn't see recurrent run functions as total.

13{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

14{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

@@ -19,9 +20,13 @@ module Grenade.Recurrent.Layers.LSTM (

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

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

23+

22-- import Data.List ( foldl1' )

24-- import Data.List ( foldl1' )

25+import Data.Proxy

26+import Data.Serialize

23import Data.Singletons.TypeLits

27import Data.Singletons.TypeLits

29+import qualified Numeric.LinearAlgebra as LA

25import Numeric.LinearAlgebra.Static

30import Numeric.LinearAlgebra.Static

27import Grenade.Core.Network

32import Grenade.Core.Network

@@ -118,7 +123,6 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

118

123

119 -- v :: forall x ix. (x -> (R ix)) -> x -> x -> R ix

124 -- v :: forall x ix. (x -> (R ix)) -> x -> x -> R ix

120 -- v e (e -> a) (e -> b) = a + b

125 -- v e (e -> a) (e -> b) = a + b

121−

122 createRandom = randomLSTM

126 createRandom = randomLSTM

123

127

124instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

128instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

@@ -245,3 +249,46 @@ sigmoid' x = logix * (1 - logix)

245

249

246tanh' :: (Floating a) => a -> a

250tanh' :: (Floating a) => a -> a

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

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

252+

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

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

255+ u lstmWf

256+ u lstmUf

257+ v lstmBf

258+ u lstmWi

259+ u lstmUi

260+ v lstmBi

261+ u lstmWo

262+ u lstmUo

263+ v lstmBo

264+ u lstmWc

265+ v lstmBc

266+ where

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

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

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

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

271+

272+ get = do

273+ lstmWf <- u

274+ lstmUf <- u

275+ lstmBf <- v

276+ lstmWi <- u

277+ lstmUi <- u

278+ lstmBi <- v

279+ lstmWo <- u

280+ lstmUo <- u

281+ lstmBo <- v

282+ lstmWc <- u

283+ lstmBc <- v

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

285+ where

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

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

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

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

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

291+

292+ w0 = konst 0

293+ u0 = konst 0

294+ v0 = konst 0

src/Grenade/Recurrent/Layers/Trivial.hs+6

@@ -7,12 +7,18 @@ module Grenade.Recurrent.Layers.Trivial (

7 Trivial (..)

8 ) where

10+import Data.Serialize

11+

10import Grenade.Core.Network

12import Grenade.Core.Network

12-- | A trivial layer.

14-- | A trivial layer.

13data Trivial = Trivial

15data Trivial = Trivial

14 deriving Show

16 deriving Show

18+instance Serialize Trivial where

19+ put _ = return ()

20+ get = return Trivial

21+

16instance UpdateLayer Trivial where

22instance UpdateLayer Trivial where

17 type Gradient Trivial = ()

23 type Gradient Trivial = ()

18 runUpdate _ _ _ = Trivial

24 runUpdate _ _ _ = Trivial

src/Grenade/Utils/OneHot.hs+11−2

@@ -11,8 +11,11 @@ module Grenade.Utils.OneHot (

11 , hotMap

12 , makeHot

13 , unHot

14+ , sample

14 ) where

15 ) where

17+import qualified Control.Monad.Random as MR

18+

16import Data.List ( group, sort )

19import Data.List ( group, sort )

18import Data.Map ( Map )

21import Data.Map ( Map )

@@ -23,6 +26,7 @@ import Data.Singletons.TypeLits

24import Data.Vector ( Vector )

27import Data.Vector ( Vector )

25import qualified Data.Vector as V

28import qualified Data.Vector as V

29+import qualified Data.Vector.Storable as VS

27import Numeric.LinearAlgebra ( maxIndex )

31import Numeric.LinearAlgebra ( maxIndex )

28import Numeric.LinearAlgebra.Devel

32import Numeric.LinearAlgebra.Devel

@@ -76,9 +80,14 @@ makeHot m x = do

76 return vec

80 return vec

77 else Nothing

81 else Nothing

79−unHot :: forall a n. (KnownNat n)

83+unHot :: forall a n. KnownNat n

80− => Vector a -> (S ('D1 n)) -> Maybe a

84+ => Vector a -> S ('D1 n) -> Maybe a

81unHot v (S1D xs)

85unHot v (S1D xs)

82 = (V.!?) v

86 = (V.!?) v

83 $ maxIndex (extract xs)

87 $ maxIndex (extract xs)

89+sample :: forall a n m. (KnownNat n, MR.MonadRandom m)

90+ => Double -> Vector a -> S ('D1 n) -> m a

91+sample temperature v (S1D xs) = do

92+ ix <- MR.fromList . zip [0..] . fmap (toRational . exp . (/ temperature) . log) . VS.toList . extract $ xs

93+ return $ v V.! ix

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

@@ -22,6 +22,7 @@ import Grenade.Layers.Convolution

22import Disorder.Jack

24import Test.Jack.Hmatrix

25+import Test.Jack.TypeLits

26data OpaqueConvolution :: * where

27data OpaqueConvolution :: * where

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

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

@@ -42,12 +43,12 @@ genConvolution = Convolution <$> uniformSample <*> uniformSample

43genOpaqueOpaqueConvolution :: Jack OpaqueConvolution

44genOpaqueOpaqueConvolution :: Jack OpaqueConvolution

44genOpaqueOpaqueConvolution = do

45genOpaqueOpaqueConvolution = do

45− Just channels <- someNatVal <$> choose (1, 10)

46+ channels <- genNat

46− Just filters <- someNatVal <$> choose (1, 10)

47+ filters <- genNat

47− Just kernel_h <- someNatVal <$> choose (2, 20)

48+ kernel_h <- genNat

48− Just kernel_w <- someNatVal <$> choose (2, 20)

49+ kernel_w <- genNat

49− Just stride_h <- someNatVal <$> choose (1, 10)

50+ stride_h <- genNat

50− Just stride_w <- someNatVal <$> choose (1, 10)

51+ stride_w <- genNat

51 case (channels, filters, kernel_h, kernel_w, stride_h, stride_w) of

52 case (channels, filters, kernel_h, kernel_w, stride_h, stride_w) of

52 ( SomeNat (pch :: Proxy ch), SomeNat (_ :: Proxy fl),

53 ( SomeNat (pch :: Proxy ch), SomeNat (_ :: Proxy fl),

53 SomeNat (pkr :: Proxy kr), SomeNat (pkc :: Proxy kc),

54 SomeNat (pkr :: Proxy kr), SomeNat (pkc :: Proxy kc),

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

@@ -90,7 +90,7 @@ prop_lstm_reference_backwards_cell =

90 refCell = Reference.Vector . H.toList . S.extract $ cell

91 refInput = Reference.Vector . H.toList . S.extract $ input

92 refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

93− in toList refGradients ~~~ (H.toList . S.extract $ actualGradients)

93+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

96(~~~) as bs = all (< 1e-8) (zipWith (-) as bs)