1ff8986 · grenade · git.iko.soy

git.iko.soy/grenade

on master help sign in

Allow a recurrent net to be a recurrent layer

1ff8986Huw Campbell9 years ago

bench/bench-lstm.hs+4−6

compare with master

unifiedsplit

@@ -16,7 +16,7 @@ main = do

16 input40 :: S ('D1 40) <- randomOfShape

17 rec60 :: S ('D1 60) <- randomOfShape

18 rec512 :: S ('D1 512) <- randomOfShape

19− (lstm, lstm') :: (RecNet, RecInput) <- randomRecurrent

19+ lstm :: RecNet <- randomRecurrent

21 let upIn60 :: H.R 3600 = H.randomVector 1 H.Uniform * 2 - 1

22 let upIn512 :: H.R 262144 = H.randomVector 1 H.Uniform * 2 - 1

@@ -30,9 +30,9 @@ main = do

30 , bgroup "update" [ bench "matrix-60x60" $ nf (uncurry3 (decendVector 1 1 1)) (upIn60, upIn60, upIn60)

31 , bench "matrix-512x512" $ nf (uncurry3 (decendVector 1 1 1)) (upIn512, upIn512, upIn512)

32 ]

33− , bgroup "train" [ bench "one-time-step" $ whnf (nfT2 . trainRecurrent lp lstm lstm') [(input40, Just input40)]

33+ , bgroup "train" [ bench "one-time-step" $ whnf (nfT2 . trainRecurrent lp lstm 0) [(input40, Just input40)]

34− , bench "ten-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm lstm') $ replicate 10 (input40, Just input40)

34+ , bench "ten-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm 0) $ replicate 10 (input40, Just input40)

35− , bench "fifty-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm lstm') $ replicate 50 (input40, Just input40)

35+ , bench "fifty-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm 0) $ replicate 50 (input40, Just input40)

36 ]

37 ]

@@ -65,7 +65,5 @@ type R = Recurrent

65type RecNet = RecurrentNetwork '[ R (LSTM 40 512), R (LSTM 512 40) ]

66 '[ 'D1 40, 'D1 512, 'D1 40 ]

68−type RecInput = RecurrentInputs '[ R (LSTM 40 512), R (LSTM 512 40) ]

69−

70lp :: LearningParameters

68lp :: LearningParameters

71lp = LearningParameters 0.1 0 0

69lp = LearningParameters 0.1 0 0

examples/main/recurrent.hs+5−5

@@ -36,7 +36,7 @@ type RecNet = RecurrentNetwork '[ R (LSTM 1 4), R (LSTM 4 1)]

37type RecInput = RecurrentInputs '[ R (LSTM 1 4), R (LSTM 4 1)]

39−randomNet :: MonadRandom m => m (RecNet, RecInput)

39+randomNet :: MonadRandom m => m RecNet

40randomNet = randomRecurrent

42netTest :: MonadRandom m => RecNet -> RecInput -> LearningParameters -> Int -> m (RecNet, RecInput)

@@ -69,8 +69,8 @@ generateRecurrent n s i =

69 unfoldr go (s, i)

70 where

71 go (x, y) =

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

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

73− o' = heat o

73+ o' = heat o

74 Just (o', (ns, fromIntegral o'))

76 heat :: S ('D1 1) -> Int

@@ -82,8 +82,8 @@ main = do

82 FeedForwardOpts examples rate <- execParser (info (feedForward' <**> helper) idm)

83 putStrLn "Training network..."

85− (net0, i0) <- randomNet

85+ net0 <- randomNet

86− (trained, bestInput) <- netTest net0 i0 rate examples

86+ (trained, bestInput) <- netTest net0 0 rate examples

88 let results = generateRecurrent trained bestInput (c 1)

examples/main/shakespeare.hs+7−7

@@ -61,7 +61,7 @@ type Shakespeare = RecurrentNetwork '[ R (LSTM 40 80), R (LSTM 80 40), F (FullyC

61-- The definition of the "sideways" input, which the network is fed recurrently.

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

64−randomNet :: MonadRandom m => m (Shakespeare, Shakespearian)

64+randomNet :: MonadRandom m => m Shakespeare

65randomNet = randomRecurrent

67-- | Load the data files and prepare a map of characters to a compressed int representation.

@@ -90,7 +90,7 @@ runShakespeare ShakespeareOpts {..} = do

90 (net0, i0) <- lift $

91 case loadPath of

92 Just loadFile -> netLoad loadFile

93− Nothing -> randomNet

93+ Nothing -> (,0) <$> randomNet

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

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

@@ -102,7 +102,7 @@ runShakespeare ShakespeareOpts {..} = do

102 ) (net0, i0) $ replicate 10 sequenceSize

103

104 case savePath of

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

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

106 Nothing -> return ()

107

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

@@ -117,10 +117,10 @@ generateParagraph n s temperature hotmap hotdict =

117 go s

118 where

119 go x y =

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

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

121− un <- sample temperature hotdict o

121+ un <- sample temperature hotdict o

122− Just re <- return $ makeHot hotmap un

122+ Just re <- return $ makeHot hotmap un

123− rest <- unsafeInterleaveIO $ go ns re

123+ rest <- unsafeInterleaveIO $ go ns re

124 return (un : rest)

125

126data ShakespeareOpts = ShakespeareOpts {

grenade.cabal+2−1

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

48 , mtl >= 2.2.1 && < 2.3

49 , primitive >= 0.6 && < 0.7

50 , text == 1.2.*

51− , singletons >= 2.1 && < 2.3

51+ , singletons >= 2.1 && < 2.4

52 , vector >= 0.11 && < 0.13

54 ghc-options:

@@ -102,6 +102,7 @@ library

102

103 Grenade.Recurrent.Layers

104 Grenade.Recurrent.Layers.BasicRecurrent

105+ Grenade.Recurrent.Layers.ConcatRecurrent

105 Grenade.Recurrent.Layers.LSTM

106 Grenade.Recurrent.Layers.LSTM

106

107

107 Grenade.Utils.OneHot

108 Grenade.Utils.OneHot

src/Grenade/Core/Shape.hs+13

@@ -29,6 +29,7 @@ import Control.DeepSeq (NFData (..))

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

31import Data.Proxy

32+import Data.Serialize

32import Data.Singletons

33import Data.Singletons

33import Data.Singletons.TypeLits

34import Data.Singletons.TypeLits

34import Data.Vector.Storable ( Vector )

35import Data.Vector.Storable ( Vector )

@@ -171,6 +172,18 @@ fromStorable xs = case sing :: Sing x of

171 then H.create $ NLA.reshape columns v

172 then H.create $ NLA.reshape columns v

172 else Nothing

173 else Nothing

173

174

175+

176+instance SingI x => Serialize (S x) where

177+ put i = (case i of

178+ (S1D x) -> putListOf put . NLA.toList . H.extract $ x

179+ (S2D x) -> putListOf put . NLA.toList . NLA.flatten . H.extract $ x

180+ (S3D x) -> putListOf put . NLA.toList . NLA.flatten . H.extract $ x

181+ ) :: PutM ()

182+

183+ get = do

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

185+ return i

186+

174-- Helper function for creating the number instances

187-- Helper function for creating the number instances

175n1 :: ( forall a. Floating a => a -> a ) -> S x -> S x

188n1 :: ( forall a. Floating a => a -> a ) -> S x -> S x

176n1 f (S1D x) = S1D (f x)

189n1 f (S1D x) = S1D (f x)

src/Grenade/Recurrent/Core/Layer.hs+4−6

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

8 , RecurrentUpdateLayer (..)

9 ) where

11−import Data.Singletons ( SingI )

12−

13import Grenade.Core

11import Grenade.Core

15-- | Class for a recurrent layer.

13-- | Class for a recurrent layer.

@@ -17,16 +15,16 @@ import Grenade.Core

17-- of an extra recurrent data shape.

15-- of an extra recurrent data shape.

18class UpdateLayer x => RecurrentUpdateLayer x where

16class UpdateLayer x => RecurrentUpdateLayer x where

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

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

20− type RecurrentShape x :: Shape

18+ type RecurrentShape x :: *

22−class (RecurrentUpdateLayer x, SingI (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where

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

23 -- | Wengert Tape

21 -- | Wengert Tape

24 type RecTape x i o :: *

22 type RecTape x i o :: *

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

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

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

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

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

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

28 -- | Back propagate a step. Takes the current layer, the input that the

26 -- | Back propagate a step. Takes the current layer, the input that the

29 -- layer gave from the input and the back propagated derivatives from

27 -- layer gave from the input and the back propagated derivatives from

30 -- the layer above.

28 -- the layer above.

31 -- Returns the gradient layer and the derivatives to push back further.

29 -- Returns the gradient layer and the derivatives to push back further.

32− runRecurrentBackwards :: x -> RecTape x i o -> S (RecurrentShape x) -> S o -> (Gradient x, S (RecurrentShape x), S i)

30+ runRecurrentBackwards :: x -> RecTape x i o -> RecurrentShape x -> S o -> (Gradient x, RecurrentShape x, S i)

src/Grenade/Recurrent/Core/Network.hs+112−110

@@ -17,12 +17,12 @@ module Grenade.Recurrent.Core.Network (

18 , RecurrentNetwork (..)

19 , RecurrentInputs (..)

20− , RecurrentTapes (..)

20+ , RecurrentTape (..)

21− , RecurrentGradients (..)

21+ , RecurrentGradient (..)

23 , randomRecurrent

24− , runRecurrentNetwork

24+ , runRecurrent

25− , runRecurrentGradient

25+ , runRecurrent'

26 , applyRecurrentUpdate

27 ) where

@@ -31,14 +31,10 @@ import Control.Monad.Random ( MonadRandom )

31import Data.Singletons ( SingI )

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

33import Data.Serialize

34−import qualified Data.Vector.Storable as V

36import Grenade.Core

35import Grenade.Core

37import Grenade.Recurrent.Core.Layer

36import Grenade.Recurrent.Core.Layer

39−import qualified Numeric.LinearAlgebra as LA

40−import qualified Numeric.LinearAlgebra.Static as LAS

41−

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

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

43-- forward layer.

39-- forward layer.

44data FeedForward :: * -> *

40data FeedForward :: * -> *

@@ -75,96 +71,82 @@ infixr 5 :~@>

75-- | Gradient of a network.

71-- | Gradient of a network.

76--

72--

77-- Parameterised on the layers of the network.

73-- Parameterised on the layers of the network.

78−data RecurrentGradients :: [*] -> * where

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

79− RGNil :: RecurrentGradients '[]

75+ RGNil :: RecurrentGradient '[]

81 (://>) :: UpdateLayer x

77 (://>) :: UpdateLayer x

82− => [Gradient x]

78+ => Gradient x

83− -> RecurrentGradients xs

79+ -> RecurrentGradient xs

84− -> RecurrentGradients (phantom x ': xs)

80+ -> RecurrentGradient (phantom x ': xs)

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

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

87-- Parameterised on the layers of a Network.

83-- Parameterised on the layers of a Network.

88data RecurrentInputs :: [*] -> * where

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

89 RINil :: RecurrentInputs '[]

85 RINil :: RecurrentInputs '[]

91− (:~~+>) :: UpdateLayer x

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

92 => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)

88 => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)

94− (:~@+>) :: (SingI (RecurrentShape x), RecurrentUpdateLayer x)

90+ (:~@+>) :: (Fractional (RecurrentShape x), Fractional (RecurrentInputs xs), RecurrentUpdateLayer x)

95− => !(S (RecurrentShape x)) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)

91+ => !(RecurrentShape x) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)

97-- | All the information required to backpropogate

93-- | All the information required to backpropogate

98-- through time safely.

94-- through time safely.

99--

95--

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

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

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

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

102−data RecurrentTapes :: [*] -> [Shape] -> * where

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

103 TRNil :: SingI i

99 TRNil :: SingI i

104− => RecurrentTapes '[] '[i]

100+ => RecurrentTape '[] '[i]

105−

106− (:\~>) :: [Tape x i h]

107− -> !(RecurrentTapes xs (h ': hs))

108− -> RecurrentTapes (FeedForward x ': xs) (i ': h ': hs)

109

101

102+ (:\~>) :: Tape x i h

103+ -> !(RecurrentTape xs (h ': hs))

104+ -> RecurrentTape (FeedForward x ': xs) (i ': h ': hs)

110

105

111− (:\@>) :: [RecTape x i h]

106+ (:\@>) :: RecTape x i h

112− -> !(RecurrentTapes xs (h ': hs))

107+ -> !(RecurrentTape xs (h ': hs))

113− -> RecurrentTapes (Recurrent x ': xs) (i ': h ': hs)

108+ -> RecurrentTape (Recurrent x ': xs) (i ': h ': hs)

114

109

115

110

116−runRecurrentNetwork :: forall shapes layers.

111+runRecurrent :: forall shapes layers.

117− RecurrentNetwork layers shapes

112+ RecurrentNetwork layers shapes

118− -> RecurrentInputs layers

113+ -> RecurrentInputs layers

119− -> [S (Head shapes)]

114+ -> S (Head shapes)

120− -> (RecurrentTapes layers shapes, RecurrentInputs layers, [S (Last shapes)])

115+ -> (RecurrentTape layers shapes, RecurrentInputs layers, S (Last shapes))

121−runRecurrentNetwork =

116+runRecurrent =

122 go

117 go

123 where

118 where

124 go :: forall js sublayers. (Last js ~ Last shapes)

119 go :: forall js sublayers. (Last js ~ Last shapes)

125 => RecurrentNetwork sublayers js

120 => RecurrentNetwork sublayers js

126 -> RecurrentInputs sublayers

121 -> RecurrentInputs sublayers

127− -> [S (Head js)]

122+ -> S (Head js)

128− -> (RecurrentTapes sublayers js, RecurrentInputs sublayers, [S (Last js)])

123+ -> (RecurrentTape sublayers js, RecurrentInputs sublayers, S (Last js))

129− -- This is a simple non-recurrent layer, just map it forwards

130− go (layer :~~> n) (() :~~+> nIn) !xs

124+ go (!layer :~~> n) (() :~~+> nIn) !x

131− = let tys = runForwards layer <$> xs

125+ = let (!tape, !forwards) = runForwards layer x

132− feedForwardTapes = fst <$> tys

126+

133− forwards = snd <$> tys

134 -- recursively run the rest of the network, and get the gradients from above.

127 -- recursively run the rest of the network, and get the gradients from above.

135− (newFN, ig, answer) = go n nIn forwards

128+ (!newFN, !ig, !answer) = go n nIn forwards

136− in (feedForwardTapes :\~> newFN, () :~~+> ig, answer)

129+ in (tape :\~> newFN, () :~~+> ig, answer)

137

130

138 -- This is a recurrent layer, so we need to do a scan, first input to last, providing

131 -- This is a recurrent layer, so we need to do a scan, first input to last, providing

139 -- the recurrent shape output to the next layer.

132 -- the recurrent shape output to the next layer.

140− go (layer :~@> n) (recIn :~@+> nIn) !xs

133+ go (layer :~@> n) (recIn :~@+> nIn) !x

141− = let (recOut, tys) = goR layer recIn xs

134+ = let (tape, shape, forwards) = runRecurrentForwards layer recIn x

142− recurrentTapes = fst <$> tys

143− forwards = snd <$> tys

144−

145 (newFN, ig, answer) = go n nIn forwards

135 (newFN, ig, answer) = go n nIn forwards

146− in (recurrentTapes :\@> newFN, recOut :~@+> ig, answer)

136+ in (tape :\@> newFN, shape :~@+> ig, answer)

147

137

148 -- Handle the output layer, bouncing the derivatives back down.

138 -- Handle the output layer, bouncing the derivatives back down.

149 -- We may not have a target for each example, so when we don't use 0 gradient.

139 -- We may not have a target for each example, so when we don't use 0 gradient.

150 go RNil RINil !x

140 go RNil RINil !x

151 = (TRNil, RINil, x)

141 = (TRNil, RINil, x)

152

142

153− -- Helper function for recurrent layers

154− -- Scans over the recurrent direction of the graph.

155− goR !layer !recShape (x:xs) =

156− let (tape, lerec, lepush) = runRecurrentForwards layer recShape x

157− (rems, push) = goR layer lerec xs

158− in (rems, (tape, lepush) : push)

159− goR _ rin [] = (rin, [])

160−

161−runRecurrentGradient :: forall layers shapes.

143+runRecurrent' :: forall layers shapes.

162− RecurrentNetwork layers shapes

144+ RecurrentNetwork layers shapes

163− -> RecurrentTapes layers shapes

145+ -> RecurrentTape layers shapes

164− -> RecurrentInputs layers

146+ -> RecurrentInputs layers

165− -> [S (Last shapes)]

147+ -> S (Last shapes)

166− -> (RecurrentGradients layers, RecurrentInputs layers, [S (Head shapes)])

148+ -> (RecurrentGradient layers, RecurrentInputs layers, S (Head shapes))

167−runRecurrentGradient net tapes r o =

149+runRecurrent' net tapes r o =

168 go net tapes r

150 go net tapes r

169 where

151 where

170 -- We have to be careful regarding the direction of the lists

152 -- We have to be careful regarding the direction of the lists

@@ -172,51 +154,41 @@ runRecurrentGradient net tapes r o =

172 -- through time.

154 -- through time.

173 go :: forall js ss. (Last js ~ Last shapes)

155 go :: forall js ss. (Last js ~ Last shapes)

174 => RecurrentNetwork ss js

156 => RecurrentNetwork ss js

175− -> RecurrentTapes ss js

157+ -> RecurrentTape ss js

176 -> RecurrentInputs ss

158 -> RecurrentInputs ss

177− -> (RecurrentGradients ss, RecurrentInputs ss, [S (Head js)])

159+ -> (RecurrentGradient ss, RecurrentInputs ss, S (Head js))

178 -- This is a simple non-recurrent layer

160 -- This is a simple non-recurrent layer

179− -- Run the rest of the network, then fmap the tapes and gradients

161+ -- Run the rest of the network, update with the tapes and gradients

180− go (layer :~~> n) (feedForwardTapes :\~> nTapes) (() :~~+> nRecs) =

162+ go (!layer :~~> n) (!tape :\~> nTapes) (() :~~+> nRecs) =

181− let (gradients, rins, feed) = go n nTapes nRecs

163+ let (!gradients, !rins, !feed) = go n nTapes nRecs

182− backs = uncurry (runBackwards layer) <$> zip (reverse feedForwardTapes) feed

164+ (!grad, !back) = runBackwards layer tape feed

183− in ((fst <$> backs) ://> gradients, () :~~+> rins, snd <$> backs)

165+ in (grad ://> gradients, () :~~+> rins, back)

184

166

185 -- This is a recurrent layer

167 -- This is a recurrent layer

186 -- Run the rest of the network, scan over the tapes in reverse

168 -- Run the rest of the network, scan over the tapes in reverse

187− go (layer :~@> n) (recurrentTapes :\@> nTapes) (recGrad :~@+> nRecs) =

169+ go (!layer :~@> n) (!tape :\@> nTapes) (!recGrad :~@+> nRecs) =

188− let (gradients, rins, feed) = go n nTapes nRecs

170+ let (!gradients, !rins, !feed) = go n nTapes nRecs

189− backExamples = zip (reverse recurrentTapes) feed

171+ (!grad, !sidegrad, !back) = runRecurrentBackwards layer tape recGrad feed

190− (rg, backs) = goX layer recGrad backExamples

191− in ((fst <$> backs) ://> gradients, rg :~@+> rins, snd <$> backs)

172+ in (grad ://> gradients, sidegrad :~@+> rins, back)

192

173

193 -- End of the road, so we reflect the given gradients backwards.

174 -- End of the road, so we reflect the given gradients backwards.

194 -- Crucially, we reverse the list, so it's backwards in time as

175 -- Crucially, we reverse the list, so it's backwards in time as

195 -- well.

176 -- well.

196− go RNil TRNil RINil

177+ go !RNil !TRNil !RINil

197− = (RGNil, RINil, reverse o)

178+ = (RGNil, RINil, o)

198−

199− -- Helper function for recurrent layers

200− -- Scans over the recurrent direction of the graph.

201− goX :: RecurrentLayer x i o => x -> S (RecurrentShape x) -> [(RecTape x i o, S o)] -> (S (RecurrentShape x), [(Gradient x, S i)])

202− goX layer !lastback ((recTape, backgrad):xs) =

203− let (layergrad, recgrad, ingrad) = runRecurrentBackwards layer recTape lastback backgrad

204− (pushedback, ll) = goX layer recgrad xs

205− in (pushedback, (layergrad, ingrad) : ll)

206− goX _ !lastback [] = (lastback, [])

207

179

208-- | Apply a batch of gradients to the network

180-- | Apply a batch of gradients to the network

209-- Uses runUpdates which can be specialised for

181-- Uses runUpdates which can be specialised for

210-- a layer.

182-- a layer.

211applyRecurrentUpdate :: LearningParameters

183applyRecurrentUpdate :: LearningParameters

212 -> RecurrentNetwork layers shapes

184 -> RecurrentNetwork layers shapes

213− -> RecurrentGradients layers

185+ -> RecurrentGradient layers

214 -> RecurrentNetwork layers shapes

186 -> RecurrentNetwork layers shapes

215applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)

187applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)

216− = runUpdates rate layer gradient :~~> applyRecurrentUpdate rate rest grest

188+ = runUpdate rate layer gradient :~~> applyRecurrentUpdate rate rest grest

217

189

218applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)

190applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)

219− = runUpdates rate layer gradient :~@> applyRecurrentUpdate rate rest grest

191+ = runUpdate rate layer gradient :~@> applyRecurrentUpdate rate rest grest

220

192

221applyRecurrentUpdate _ RNil RGNil

193applyRecurrentUpdate _ RNil RGNil

222 = RNil

194 = RNil

@@ -234,24 +206,23 @@ instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recu

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

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

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

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

236 -- | Create a network of the types requested

208 -- | Create a network of the types requested

237− randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss, RecurrentInputs xs)

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

238

210

239instance SingI i => CreatableRecurrent '[] '[i] where

211instance SingI i => CreatableRecurrent '[] '[i] where

240 randomRecurrent =

212 randomRecurrent =

241− return (RNil, RINil)

213+ return RNil

242

214

243instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where

215instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where

244 randomRecurrent = do

216 randomRecurrent = do

245 thisLayer <- createRandom

217 thisLayer <- createRandom

246− (rest, resti) <- randomRecurrent

218+ rest <- randomRecurrent

247− return (thisLayer :~~> rest, () :~~+> resti)

219+ return (thisLayer :~~> rest)

248

220

249instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where

221instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where

250 randomRecurrent = do

222 randomRecurrent = do

251 thisLayer <- createRandom

223 thisLayer <- createRandom

252− thisShape <- randomOfShape

253− (rest, resti) <- randomRecurrent

224+ rest <- randomRecurrent

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

225+ return (thisLayer :~@> rest)

255

226

256-- | Add very simple serialisation to the recurrent network

227-- | Add very simple serialisation to the recurrent network

257instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where

228instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where

@@ -270,23 +241,13 @@ instance (Serialize (RecurrentInputs '[])) where

270 put _ = return ()

241 put _ = return ()

271 get = return RINil

242 get = return RINil

272

243

273−instance (UpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where

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

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

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

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

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

276

247

277−instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

248+instance (Serialize (RecurrentShape x), Fractional (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where

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

249+ put ( i :~@+> rest ) = put i >> put rest

279− _ <- (case i of

280− (S1D x) -> putListOf put . LA.toList . LAS.extract $ x

281− (S2D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

282− (S3D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

283− ) :: PutM ()

284− put rest

285−

286− get = do

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

287− Just i <- fromStorable . V.fromList <$> getListOf get

288− rest <- get

289− return ( i :~@+> rest)

290

251

291

252

292-- Num instance for `RecurrentInputs layers`

253-- Num instance for `RecurrentInputs layers`

@@ -307,7 +268,7 @@ instance (Num (RecurrentInputs '[])) where

307 signum _ = RINil

268 signum _ = RINil

308 fromInteger _ = RINil

269 fromInteger _ = RINil

309

270

310−instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where

271+instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where

311 (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)

272 (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)

312 (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)

273 (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)

313 (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)

274 (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)

@@ -315,10 +276,51 @@ instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Fee

315 signum (() :~~+> x) = () :~~+> signum x

276 signum (() :~~+> x) = () :~~+> signum x

316 fromInteger x = () :~~+> fromInteger x

277 fromInteger x = () :~~+> fromInteger x

317

278

318−instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where

279+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where

319 (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')

280 (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')

320 (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')

281 (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')

321 (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')

282 (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')

322 abs (x :~@+> x') = abs x :~@+> abs x'

283 abs (x :~@+> x') = abs x :~@+> abs x'

323 signum (x :~@+> x') = signum x :~@+> signum x'

284 signum (x :~@+> x') = signum x :~@+> signum x'

324 fromInteger x = fromInteger x :~@+> fromInteger x

285 fromInteger x = fromInteger x :~@+> fromInteger x

286+

287+instance (Fractional (RecurrentInputs '[])) where

288+ (/) _ _ = RINil

289+ recip _ = RINil

290+ fromRational _ = RINil

291+

292+instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (FeedForward x ': ys))) where

293+ (/) (() :~~+> x) (() :~~+> y) = () :~~+> (x / y)

294+ recip (() :~~+> x) = () :~~+> recip x

295+ fromRational x = () :~~+> fromRational x

296+

297+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (Recurrent x ': ys))) where

298+ (/) (x :~@+> x') (y :~@+> y') = (x / y) :~@+> (x' / y')

299+ recip (x :~@+> x') = recip x :~@+> recip x'

300+ fromRational x = fromRational x :~@+> fromRational x

301+

302+

303+-- | Ultimate composition.

304+--

305+-- This allows a complete network to be treated as a layer in a larger network.

306+instance CreatableRecurrent sublayers subshapes => UpdateLayer (RecurrentNetwork sublayers subshapes) where

307+ type Gradient (RecurrentNetwork sublayers subshapes) = RecurrentGradient sublayers

308+ runUpdate = applyRecurrentUpdate

309+ createRandom = randomRecurrent

310+

311+-- | Ultimate composition.

312+--

313+-- This allows a complete network to be treated as a layer in a larger network.

314+instance CreatableRecurrent sublayers subshapes => RecurrentUpdateLayer (RecurrentNetwork sublayers subshapes) where

315+ type RecurrentShape (RecurrentNetwork sublayers subshapes) = RecurrentInputs sublayers

316+

317+-- | Ultimate composition.

318+--

319+-- This allows a complete network to be treated as a layer in a larger network.

320+instance ( CreatableRecurrent sublayers subshapes

321+ , i ~ (Head subshapes), o ~ (Last subshapes)

322+ , Num (RecurrentShape (RecurrentNetwork sublayers subshapes))

323+ ) => RecurrentLayer (RecurrentNetwork sublayers subshapes) i o where

324+ type RecTape (RecurrentNetwork sublayers subshapes) i o = RecurrentTape sublayers subshapes

325+ runRecurrentForwards = runRecurrent

326+ runRecurrentBackwards = runRecurrent'

src/Grenade/Recurrent/Core/Runner.hs+49−28

@@ -9,30 +9,65 @@

9{-# LANGUAGE RecordWildCards #-}

11module Grenade.Recurrent.Core.Runner (

12− trainRecurrent

12+ runRecurrentExamples

13− , runRecurrent

13+ , runRecurrentBackprop

14 , backPropagateRecurrent

15+ , trainRecurrent

16+

17+ , RecurrentGradients

15 ) where

18 ) where

20+import Data.List ( foldl' )

17import Data.Singletons.Prelude

21import Data.Singletons.Prelude

18import Grenade.Core

22import Grenade.Core

20−import Grenade.Recurrent.Core.Layer

21import Grenade.Recurrent.Core.Network

24import Grenade.Recurrent.Core.Network

26+type RecurrentGradients layers = [RecurrentGradient layers]

27+

28+runRecurrentExamples :: forall shapes layers.

29+ RecurrentNetwork layers shapes

30+ -> RecurrentInputs layers

31+ -> [S (Head shapes)]

32+ -> ([(RecurrentTape layers shapes, S (Last shapes))], RecurrentInputs layers)

33+runRecurrentExamples net =

34+ go

35+ where

36+ go !side [] = ([], side)

37+ go !side (!x : xs) =

38+ let (!tape, !side', !o) = runRecurrent net side x

39+ (!res, !finalSide) = go side' xs

40+ in (( tape, o ) : res, finalSide)

41+

42+runRecurrentBackprop :: forall layers shapes.

43+ RecurrentNetwork layers shapes

44+ -> RecurrentInputs layers

45+ -> [(RecurrentTape layers shapes, S (Last shapes))]

46+ -> ([(RecurrentGradient layers, S (Head shapes))], RecurrentInputs layers)

47+runRecurrentBackprop net =

48+ go

49+ where

50+ go !side [] = ([], side)

51+ go !side ((!tape,!x):xs) =

52+ let (res, !side') = go side xs

53+ (!grad, !finalSide, !o) = runRecurrent' net tape side' x

54+ in (( grad, o ) : res, finalSide)

55+

56+

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

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

24−backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))

58+backPropagateRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

25 => RecurrentNetwork layers shapes

59 => RecurrentNetwork layers shapes

26 -> RecurrentInputs layers

60 -> RecurrentInputs layers

27 -> [(S (Head shapes), Maybe (S (Last shapes)))]

61 -> [(S (Head shapes), Maybe (S (Last shapes)))]

28 -> (RecurrentGradients layers, RecurrentInputs layers)

62 -> (RecurrentGradients layers, RecurrentInputs layers)

29backPropagateRecurrent network recinputs examples =

63backPropagateRecurrent network recinputs examples =

30− let (tapes, _, guesses) = runRecurrentNetwork network recinputs inputs

64+ let (outForwards, _) = runRecurrentExamples network recinputs inputs

32− backPropagations = zipWith makeError guesses targets

66+ backPropagations = zipWith makeError outForwards targets

34− (gradients, input', _) = runRecurrentGradient network tapes 0 backPropagations

68+ (outBackwards, input') = runRecurrentBackprop network 0 backPropagations

70+ gradients = fmap fst outBackwards

36 in (gradients, input')

71 in (gradients, input')

38 where

73 where

@@ -40,12 +75,12 @@ backPropagateRecurrent network recinputs examples =

40 inputs = fst <$> examples

75 inputs = fst <$> examples

41 targets = snd <$> examples

76 targets = snd <$> examples

43− makeError :: S (Last shapes) -> Maybe (S (Last shapes)) -> S (Last shapes)

78+ makeError :: (x, S (Last shapes)) -> Maybe (S (Last shapes)) -> (x, S (Last shapes))

44− makeError _ Nothing = 0

79+ makeError (x, _) Nothing = (x, 0)

45− makeError y (Just t) = y - t

80+ makeError (x, y) (Just t) = (x, y - t)

48−trainRecurrent :: forall shapes layers. (SingI (Last shapes), Num (RecurrentInputs layers))

83+trainRecurrent :: forall shapes layers. (SingI (Last shapes), Fractional (RecurrentInputs layers))

49 => LearningParameters

84 => LearningParameters

50 -> RecurrentNetwork layers shapes

85 -> RecurrentNetwork layers shapes

51 -> RecurrentInputs layers

86 -> RecurrentInputs layers

@@ -56,11 +91,12 @@ trainRecurrent rate network recinputs examples =

57 newInputs = updateRecInputs rate recinputs recinputs'

92 newInputs = updateRecInputs rate recinputs recinputs'

59− newNetwork = applyRecurrentUpdate rate network gradients

94+ newNetwork = foldl' (applyRecurrentUpdate rate) network gradients

61 in (newNetwork, newInputs)

96 in (newNetwork, newInputs)

98+updateRecInputs :: Fractional (RecurrentInputs sublayers)

63−updateRecInputs :: LearningParameters

99+ => LearningParameters

64 -> RecurrentInputs sublayers

100 -> RecurrentInputs sublayers

65 -> RecurrentInputs sublayers

101 -> RecurrentInputs sublayers

66 -> RecurrentInputs sublayers

102 -> RecurrentInputs sublayers

@@ -73,18 +109,3 @@ updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)

109

74updateRecInputs _ RINil RINil

110updateRecInputs _ RINil RINil

75 = RINil

111 = RINil

76−

77−-- | Just forwards propagation with no training.

78−runRecurrent :: RecurrentNetwork layers shapes

79− -> RecurrentInputs layers -> S (Head shapes)

80− -> (RecurrentInputs layers, S (Last shapes))

81−runRecurrent (layer :~~> n) (() :~~+> nr) !x

82− = let (_, ys) = runForwards layer x

83− (nr', o) = runRecurrent n nr ys

84− in (() :~~+> nr', o)

85−runRecurrent (layer :~@> n) (recin :~@+> nr) !x

86− = let (_, recin', y) = runRecurrentForwards layer recin x

87− (nr', o) = runRecurrent n nr y

88− in (recin' :~@+> nr', o)

89−runRecurrent RNil RINil !x

90− = (RINil, x)

src/Grenade/Recurrent/Layers.hs+2

@@ -1,7 +1,9 @@

1module Grenade.Recurrent.Layers (

2 module Grenade.Recurrent.Layers.BasicRecurrent

3+ , module Grenade.Recurrent.Layers.ConcatRecurrent

3 , module Grenade.Recurrent.Layers.LSTM

4 , module Grenade.Recurrent.Layers.LSTM

4 ) where

5 ) where

6import Grenade.Recurrent.Layers.BasicRecurrent

7import Grenade.Recurrent.Layers.BasicRecurrent

8+import Grenade.Recurrent.Layers.ConcatRecurrent

7import Grenade.Recurrent.Layers.LSTM

9import Grenade.Recurrent.Layers.LSTM

src/Grenade/Recurrent/Layers/BasicRecurrent.hs+1−1

@@ -66,7 +66,7 @@ instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurre

66 createRandom = randomBasicRecurrent

68instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentUpdateLayer (BasicRecurrent i o) where

69− type RecurrentShape (BasicRecurrent i o) = 'D1 o

69+ type RecurrentShape (BasicRecurrent i o) = S ('D1 o)

71instance (KnownNat i, KnownNat o, KnownNat (i + o), i <= (i + o), o ~ ((i + o) - i)) => RecurrentLayer (BasicRecurrent i o) ('D1 i) ('D1 o) where

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

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

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

124 -- The recurrent shape is the same size as the output.

125 -- It's actually the cell state however, as this is a peephole variety LSTM.

126− type RecurrentShape (LSTM i o) = 'D1 o

126+ type RecurrentShape (LSTM i o) = S ('D1 o)

127

128instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where

129