@@ -17,12 +17,12 @@ module Grenade.Recurrent.Core.Network (
1717
1818 , RecurrentNetwork (..)
1919 , RecurrentInputs (..)
20− , RecurrentTapes (..)
21− , RecurrentGradients (..)
20+ , RecurrentTape (..)
21+ , RecurrentGradient (..)
2222
2323 , randomRecurrent
24− , runRecurrentNetwork
25− , runRecurrentGradient
24+ , runRecurrent
25+ , runRecurrent'
2626 , applyRecurrentUpdate
2727 ) where
2828
@@ -31,14 +31,10 @@ import Control.Monad.Random ( MonadRandom )
3131import Data.Singletons ( SingI )
3232import Data.Singletons.Prelude ( Head, Last )
3333import Data.Serialize
34−import qualified Data.Vector.Storable as V
3534
3635import Grenade.Core
3736import Grenade.Recurrent.Core.Layer
3837
39−import qualified Numeric.LinearAlgebra as LA
40−import qualified Numeric.LinearAlgebra.Static as LAS
41−
4238-- | Witness type to say indicate we're building up with a normal feed
4339-- forward layer.
4440data FeedForward :: * -> *
@@ -75,96 +71,82 @@ infixr 5 :~@>
7571-- | Gradient of a network.
7672--
7773-- Parameterised on the layers of the network.
78−data RecurrentGradients :: [*] -> * where
79− RGNil :: RecurrentGradients '[]
74+data RecurrentGradient :: [*] -> * where
75+ RGNil :: RecurrentGradient '[]
8076
8177 (://>) :: UpdateLayer x
82− => [Gradient x]
83− -> RecurrentGradients xs
84− -> RecurrentGradients (phantom x ': xs)
78+ => Gradient x
79+ -> RecurrentGradient xs
80+ -> RecurrentGradient (phantom x ': xs)
8581
8682-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)
8783-- Parameterised on the layers of a Network.
8884data RecurrentInputs :: [*] -> * where
8985 RINil :: RecurrentInputs '[]
9086
91− (:~~+>) :: UpdateLayer x
87+ (:~~+>) :: (UpdateLayer x, Fractional (RecurrentInputs xs))
9288 => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)
9389
94− (:~@+>) :: (SingI (RecurrentShape x), RecurrentUpdateLayer x)
95− => !(S (RecurrentShape x)) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)
90+ (:~@+>) :: (Fractional (RecurrentShape x), Fractional (RecurrentInputs xs), RecurrentUpdateLayer x)
91+ => !(RecurrentShape x) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)
9692
9793-- | All the information required to backpropogate
9894-- through time safely.
9995--
10096-- We index on the time step length as well, to ensure
10197-- that that all Tape lengths are the same.
102−data RecurrentTapes :: [*] -> [Shape] -> * where
98+data RecurrentTape :: [*] -> [Shape] -> * where
10399 TRNil :: SingI i
104− => RecurrentTapes '[] '[i]
105−
106− (:\~>) :: [Tape x i h]
107− -> !(RecurrentTapes xs (h ': hs))
108− -> RecurrentTapes (FeedForward x ': xs) (i ': h ': hs)
100+ => RecurrentTape '[] '[i]
109101
102+ (:\~>) :: Tape x i h
103+ -> !(RecurrentTape xs (h ': hs))
104+ -> RecurrentTape (FeedForward x ': xs) (i ': h ': hs)
110105
111− (:\@>) :: [RecTape x i h]
112− -> !(RecurrentTapes xs (h ': hs))
113− -> RecurrentTapes (Recurrent x ': xs) (i ': h ': hs)
106+ (:\@>) :: RecTape x i h
107+ -> !(RecurrentTape xs (h ': hs))
108+ -> RecurrentTape (Recurrent x ': xs) (i ': h ': hs)
114109
115110
116−runRecurrentNetwork :: forall shapes layers.
117− RecurrentNetwork layers shapes
118− -> RecurrentInputs layers
119− -> [S (Head shapes)]
120− -> (RecurrentTapes layers shapes, RecurrentInputs layers, [S (Last shapes)])
121−runRecurrentNetwork =
111+runRecurrent :: forall shapes layers.
112+ RecurrentNetwork layers shapes
113+ -> RecurrentInputs layers
114+ -> S (Head shapes)
115+ -> (RecurrentTape layers shapes, RecurrentInputs layers, S (Last shapes))
116+runRecurrent =
122117 go
123118 where
124119 go :: forall js sublayers. (Last js ~ Last shapes)
125120 => RecurrentNetwork sublayers js
126121 -> RecurrentInputs sublayers
127− -> [S (Head js)]
128− -> (RecurrentTapes 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
131− = let tys = runForwards layer <$> xs
132− feedForwardTapes = fst <$> tys
133− forwards = snd <$> tys
122+ -> S (Head js)
123+ -> (RecurrentTape sublayers js, RecurrentInputs sublayers, S (Last js))
124+ go (!layer :~~> n) (() :~~+> nIn) !x
125+ = let (!tape, !forwards) = runForwards layer x
126+
134127 -- recursively run the rest of the network, and get the gradients from above.
135− (newFN, ig, answer) = go n nIn forwards
136− in (feedForwardTapes :\~> newFN, () :~~+> ig, answer)
128+ (!newFN, !ig, !answer) = go n nIn forwards
129+ in (tape :\~> newFN, () :~~+> ig, answer)
137130
138131 -- This is a recurrent layer, so we need to do a scan, first input to last, providing
139132 -- the recurrent shape output to the next layer.
140− go (layer :~@> n) (recIn :~@+> nIn) !xs
141− = let (recOut, tys) = goR layer recIn xs
142− recurrentTapes = fst <$> tys
143− forwards = snd <$> tys
144−
133+ go (layer :~@> n) (recIn :~@+> nIn) !x
134+ = let (tape, shape, forwards) = runRecurrentForwards layer recIn x
145135 (newFN, ig, answer) = go n nIn forwards
146− in (recurrentTapes :\@> newFN, recOut :~@+> ig, answer)
136+ in (tape :\@> newFN, shape :~@+> ig, answer)
147137
148138 -- Handle the output layer, bouncing the derivatives back down.
149139 -- We may not have a target for each example, so when we don't use 0 gradient.
150140 go RNil RINil !x
151141 = (TRNil, RINil, x)
152142
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.
162− RecurrentNetwork layers shapes
163− -> RecurrentTapes layers shapes
164− -> RecurrentInputs layers
165− -> [S (Last shapes)]
166− -> (RecurrentGradients layers, RecurrentInputs layers, [S (Head shapes)])
167−runRecurrentGradient net tapes r o =
143+runRecurrent' :: forall layers shapes.
144+ RecurrentNetwork layers shapes
145+ -> RecurrentTape layers shapes
146+ -> RecurrentInputs layers
147+ -> S (Last shapes)
148+ -> (RecurrentGradient layers, RecurrentInputs layers, S (Head shapes))
149+runRecurrent' net tapes r o =
168150 go net tapes r
169151 where
170152 -- We have to be careful regarding the direction of the lists
@@ -172,51 +154,41 @@ runRecurrentGradient net tapes r o =
172154 -- through time.
173155 go :: forall js ss. (Last js ~ Last shapes)
174156 => RecurrentNetwork ss js
175− -> RecurrentTapes ss js
157+ -> RecurrentTape ss js
176158 -> RecurrentInputs ss
177− -> (RecurrentGradients ss, RecurrentInputs ss, [S (Head js)])
159+ -> (RecurrentGradient ss, RecurrentInputs ss, S (Head js))
178160 -- This is a simple non-recurrent layer
179− -- Run the rest of the network, then fmap the tapes and gradients
180− go (layer :~~> n) (feedForwardTapes :\~> nTapes) (() :~~+> nRecs) =
181− let (gradients, rins, feed) = go n nTapes nRecs
182− backs = uncurry (runBackwards layer) <$> zip (reverse feedForwardTapes) feed
183− in ((fst <$> backs) ://> gradients, () :~~+> rins, snd <$> backs)
161+ -- Run the rest of the network, update with the tapes and gradients
162+ go (!layer :~~> n) (!tape :\~> nTapes) (() :~~+> nRecs) =
163+ let (!gradients, !rins, !feed) = go n nTapes nRecs
164+ (!grad, !back) = runBackwards layer tape feed
165+ in (grad ://> gradients, () :~~+> rins, back)
184166
185167 -- This is a recurrent layer
186168 -- Run the rest of the network, scan over the tapes in reverse
187− go (layer :~@> n) (recurrentTapes :\@> nTapes) (recGrad :~@+> nRecs) =
188− let (gradients, rins, feed) = go n nTapes nRecs
189− backExamples = zip (reverse recurrentTapes) feed
190− (rg, backs) = goX layer recGrad backExamples
191− in ((fst <$> backs) ://> gradients, rg :~@+> rins, snd <$> backs)
169+ go (!layer :~@> n) (!tape :\@> nTapes) (!recGrad :~@+> nRecs) =
170+ let (!gradients, !rins, !feed) = go n nTapes nRecs
171+ (!grad, !sidegrad, !back) = runRecurrentBackwards layer tape recGrad feed
172+ in (grad ://> gradients, sidegrad :~@+> rins, back)
192173
193174 -- End of the road, so we reflect the given gradients backwards.
194175 -- Crucially, we reverse the list, so it's backwards in time as
195176 -- well.
196− go RNil TRNil RINil
197− = (RGNil, RINil, reverse 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, [])
177+ go !RNil !TRNil !RINil
178+ = (RGNil, RINil, o)
207179
208180-- | Apply a batch of gradients to the network
209181-- Uses runUpdates which can be specialised for
210182-- a layer.
211183applyRecurrentUpdate :: LearningParameters
212184 -> RecurrentNetwork layers shapes
213− -> RecurrentGradients layers
185+ -> RecurrentGradient layers
214186 -> RecurrentNetwork layers shapes
215187applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)
216− = runUpdates rate layer gradient :~~> applyRecurrentUpdate rate rest grest
188+ = runUpdate rate layer gradient :~~> applyRecurrentUpdate rate rest grest
217189
218190applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)
219− = runUpdates rate layer gradient :~@> applyRecurrentUpdate rate rest grest
191+ = runUpdate rate layer gradient :~@> applyRecurrentUpdate rate rest grest
220192
221193applyRecurrentUpdate _ RNil RGNil
222194 = RNil
@@ -234,24 +206,23 @@ instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recu
234206-- recurrent network and a set of random inputs for it is with the randomRecurrent.
235207class CreatableRecurrent (xs :: [*]) (ss :: [Shape]) where
236208 -- | 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)
238210
239211instance SingI i => CreatableRecurrent '[] '[i] where
240212 randomRecurrent =
241− return (RNil, RINil)
213+ return RNil
242214
243215instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where
244216 randomRecurrent = do
245217 thisLayer <- createRandom
246− (rest, resti) <- randomRecurrent
247− return (thisLayer :~~> rest, () :~~+> resti)
218+ rest <- randomRecurrent
219+ return (thisLayer :~~> rest)
248220
249221instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where
250222 randomRecurrent = do
251223 thisLayer <- createRandom
252− thisShape <- randomOfShape
253− (rest, resti) <- randomRecurrent
254− return (thisLayer :~@> rest, thisShape :~@+> resti)
224+ rest <- randomRecurrent
225+ return (thisLayer :~@> rest)
255226
256227-- | Add very simple serialisation to the recurrent network
257228instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where
@@ -270,23 +241,13 @@ instance (Serialize (RecurrentInputs '[])) where
270241 put _ = return ()
271242 get = return RINil
272243
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
274245 put ( () :~~+> rest) = put rest
275246 get = ( () :~~+> ) <$> get
276247
277−instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where
278− put ( i :~@+> rest ) = do
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
287− Just i <- fromStorable . V.fromList <$> getListOf get
288− rest <- get
289− return ( i :~@+> rest)
248+instance (Serialize (RecurrentShape x), Fractional (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where
249+ put ( i :~@+> rest ) = put i >> put rest
250+ get = (:~@+>) <$> get <*> get
290251
291252
292253-- Num instance for `RecurrentInputs layers`
@@ -307,7 +268,7 @@ instance (Num (RecurrentInputs '[])) where
307268 signum _ = RINil
308269 fromInteger _ = RINil
309270
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
311272 (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)
312273 (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)
313274 (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)
@@ -315,10 +276,51 @@ instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Fee
315276 signum (() :~~+> x) = () :~~+> signum x
316277 fromInteger x = () :~~+> fromInteger x
317278
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
319280 (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')
320281 (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')
321282 (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')
322283 abs (x :~@+> x') = abs x :~@+> abs x'
323284 signum (x :~@+> x') = signum x :~@+> signum x'
324285 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'