@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE TypeOperators #-}
@@ -6,53 +7,59 @@
67{-# LANGUAGE FlexibleContexts #-}
78{-# LANGUAGE FlexibleInstances #-}
89{-# LANGUAGE EmptyDataDecls #-}
10+{-# LANGUAGE RankNTypes #-}
11+{-# LANGUAGE BangPatterns #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+
14+#if __GLASGOW_HASKELL__ < 800
15+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
16+#endif
17+
918module Grenade.Recurrent.Core.Network (
1019 Recurrent
1120 , FeedForward
12− , RecurrentLayer (..)
13− , RecurrentUpdateLayer (..)
21+
1422 , RecurrentNetwork (..)
1523 , RecurrentInputs (..)
16− , CreatableRecurrent (..)
24+ , RecurrentTapes (..)
25+ , RecurrentGradients (..)
26+
27+ , randomRecurrent
28+ , runRecurrentNetwork
29+ , runRecurrentGradient
30+ , applyRecurrentUpdate
1731 ) where
1832
1933
2034import Control.Monad.Random ( MonadRandom )
2135import Data.Singletons ( SingI )
36+import Data.Singletons.Prelude ( Head, Last )
2237import Data.Serialize
2338import qualified Data.Vector.Storable as V
2439
2540import Grenade.Core
41+import Grenade.Recurrent.Core.Layer
2642
2743import qualified Numeric.LinearAlgebra as LA
2844import qualified Numeric.LinearAlgebra.Static as LAS
2945
30−
3146-- | Witness type to say indicate we're building up with a normal feed
3247-- forward layer.
3348data FeedForward :: * -> *
3449-- | Witness type to say indicate we're building up with a recurrent layer.
3550data Recurrent :: * -> *
3651
37−-- | Class for a recurrent layer.
38−-- It's quite similar to a normal layer but for the input and output
39−-- of an extra recurrent data shape.
40−class UpdateLayer x => RecurrentUpdateLayer x where
41− -- | Shape of data that is passed between each subsequent run of the layer
42− type RecurrentShape x :: Shape
43−
44−class (RecurrentUpdateLayer x, SingI (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where
45− -- | Wengert Tape
46− type RecTape x i o :: *
47− -- | Used in training and scoring. Take the input from the previous
48− -- layer, and give the output from this layer.
49− runRecurrentForwards :: x -> S (RecurrentShape x) -> S i -> (RecTape x i o, S (RecurrentShape x), S o)
50− -- | Back propagate a step. Takes the current layer, the input that the
51− -- layer gave from the input and the back propagated derivatives from
52− -- the layer above.
53− -- Returns the gradient layer and the derivatives to push back further.
54− runRecurrentBackwards :: x -> RecTape x i o -> S (RecurrentShape x) -> S o -> (Gradient x, S (RecurrentShape x), S i)
55−
52+-- | Type of a recurrent neural network.
53+--
54+-- The [*] type specifies the types of the layers.
55+--
56+-- The [Shape] type specifies the shapes of data passed between the layers.
57+--
58+-- The definition is similar to a Network, but every layer in the
59+-- type is tagged by whether it's a FeedForward Layer of a Recurrent layer.
60+--
61+-- Often, to make the definitions more concise, one will use a type alias
62+-- for these empty data types.
5663data RecurrentNetwork :: [*] -> [Shape] -> * where
5764 RNil :: SingI i
5865 => RecurrentNetwork '[] '[i]
@@ -69,23 +76,163 @@ data RecurrentNetwork :: [*] -> [Shape] -> * where
6976infixr 5 :~~>
7077infixr 5 :~@>
7178
72−instance Show (RecurrentNetwork '[] '[i]) where
73− show RNil = "NNil"
74−instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (FeedForward x ': xs) (i ': rs)) where
75− show (x :~~> xs) = show x ++ "\n~~>\n" ++ show xs
76−instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recurrent x ': xs) (i ': rs)) where
77− show (x :~@> xs) = show x ++ "\n~~>\n" ++ show xs
79+-- | Gradient of a network.
80+--
81+-- Parameterised on the layers of the network.
82+data RecurrentGradients :: [*] -> * where
83+ RGNil :: RecurrentGradients '[]
84+
85+ (://>) :: UpdateLayer x
86+ => [Gradient x]
87+ -> RecurrentGradients xs
88+ -> RecurrentGradients (phantom x ': xs)
7889
7990-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)
8091-- Parameterised on the layers of a Network.
8192data RecurrentInputs :: [*] -> * where
8293 RINil :: RecurrentInputs '[]
94+
8395 (:~~+>) :: UpdateLayer x
84− => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)
96+ => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)
97+
8598 (:~@+>) :: (SingI (RecurrentShape x), RecurrentUpdateLayer x)
8699 => !(S (RecurrentShape x)) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)
87−infixr 5 :~~+>
88−infixr 5 :~@+>
100+
101+-- | All the information required to backpropogate
102+-- through time safely.
103+--
104+-- We index on the time step length as well, to ensure
105+-- that that all Tape lengths are the same.
106+data RecurrentTapes :: [*] -> [Shape] -> * where
107+ TRNil :: SingI i
108+ => RecurrentTapes '[] '[i]
109+
110+ (:\~>) :: [Tape x i h]
111+ -> !(RecurrentTapes xs (h ': hs))
112+ -> RecurrentTapes (FeedForward x ': xs) (i ': h ': hs)
113+
114+
115+ (:\@>) :: [RecTape x i h]
116+ -> !(RecurrentTapes xs (h ': hs))
117+ -> RecurrentTapes (Recurrent x ': xs) (i ': h ': hs)
118+
119+
120+runRecurrentNetwork :: forall shapes layers.
121+ RecurrentNetwork layers shapes
122+ -> RecurrentInputs layers
123+ -> [S (Head shapes)]
124+ -> (RecurrentTapes layers shapes, RecurrentInputs layers, [S (Last shapes)])
125+runRecurrentNetwork =
126+ go
127+ where
128+ go :: forall js sublayers. (Last js ~ Last shapes)
129+ => RecurrentNetwork sublayers js
130+ -> RecurrentInputs sublayers
131+ -> [S (Head js)]
132+ -> (RecurrentTapes sublayers js, RecurrentInputs sublayers, [S (Last js)])
133+ -- This is a simple non-recurrent layer, just map it forwards
134+ go (layer :~~> n) (() :~~+> nIn) !xs
135+ = let tys = runForwards layer <$> xs
136+ feedForwardTapes = fst <$> tys
137+ forwards = snd <$> tys
138+ -- recursively run the rest of the network, and get the gradients from above.
139+ (newFN, ig, answer) = go n nIn forwards
140+ in (feedForwardTapes :\~> newFN, () :~~+> ig, answer)
141+
142+ -- This is a recurrent layer, so we need to do a scan, first input to last, providing
143+ -- the recurrent shape output to the next layer.
144+ go (layer :~@> n) (recIn :~@+> nIn) !xs
145+ = let (recOut, tys) = goR layer recIn xs
146+ recurrentTapes = fst <$> tys
147+ forwards = snd <$> tys
148+
149+ (newFN, ig, answer) = go n nIn forwards
150+ in (recurrentTapes :\@> newFN, recOut :~@+> ig, answer)
151+
152+ -- Handle the output layer, bouncing the derivatives back down.
153+ -- We may not have a target for each example, so when we don't use 0 gradient.
154+ go RNil RINil !x
155+ = (TRNil, RINil, x)
156+
157+ -- Helper function for recurrent layers
158+ -- Scans over the recurrent direction of the graph.
159+ goR !layer !recShape (x:xs) =
160+ let (tape, lerec, lepush) = runRecurrentForwards layer recShape x
161+ (rems, push) = goR layer lerec xs
162+ in (rems, (tape, lepush) : push)
163+ goR _ rin [] = (rin, [])
164+
165+runRecurrentGradient :: forall layers shapes.
166+ RecurrentNetwork layers shapes
167+ -> RecurrentTapes layers shapes
168+ -> RecurrentInputs layers
169+ -> [S (Last shapes)]
170+ -> (RecurrentGradients layers, RecurrentInputs layers, [S (Head shapes)])
171+runRecurrentGradient net tapes r o =
172+ go net tapes r
173+ where
174+ -- We have to be careful regarding the direction of the lists
175+ -- Inputs come in forwards, but our return value is backwards
176+ -- through time.
177+ go :: forall js ss. (Last js ~ Last shapes)
178+ => RecurrentNetwork ss js
179+ -> RecurrentTapes ss js
180+ -> RecurrentInputs ss
181+ -> (RecurrentGradients ss, RecurrentInputs ss, [S (Head js)])
182+ -- This is a simple non-recurrent layer
183+ -- Run the rest of the network, then fmap the tapes and gradients
184+ go (layer :~~> n) (feedForwardTapes :\~> nTapes) (() :~~+> nRecs) =
185+ let (gradients, rins, feed) = go n nTapes nRecs
186+ backs = uncurry (runBackwards layer) <$> zip (reverse feedForwardTapes) feed
187+ in ((fst <$> backs) ://> gradients, () :~~+> rins, snd <$> backs)
188+
189+ -- This is a recurrent layer
190+ -- Run the rest of the network, scan over the tapes in reverse
191+ go (layer :~@> n) (recurrentTapes :\@> nTapes) (recGrad :~@+> nRecs) =
192+ let (gradients, rins, feed) = go n nTapes nRecs
193+ backExamples = zip (reverse recurrentTapes) feed
194+ (rg, backs) = goX layer recGrad backExamples
195+ in ((fst <$> backs) ://> gradients, rg :~@+> rins, snd <$> backs)
196+
197+ -- End of the road, so we reflect the given gradients backwards.
198+ -- Crucially, we reverse the list, so it's backwards in time as
199+ -- well.
200+ go RNil TRNil RINil
201+ = (RGNil, RINil, reverse o)
202+
203+ -- Helper function for recurrent layers
204+ -- Scans over the recurrent direction of the graph.
205+ goX :: RecurrentLayer x i o => x -> S (RecurrentShape x) -> [(RecTape x i o, S o)] -> (S (RecurrentShape x), [(Gradient x, S i)])
206+ goX layer !lastback ((recTape, backgrad):xs) =
207+ let (layergrad, recgrad, ingrad) = runRecurrentBackwards layer recTape lastback backgrad
208+ (pushedback, ll) = goX layer recgrad xs
209+ in (pushedback, (layergrad, ingrad) : ll)
210+ goX _ !lastback [] = (lastback, [])
211+
212+-- | Apply a batch of gradients to the network
213+-- Uses runUpdates which can be specialised for
214+-- a layer.
215+applyRecurrentUpdate :: LearningParameters
216+ -> RecurrentNetwork layers shapes
217+ -> RecurrentGradients layers
218+ -> RecurrentNetwork layers shapes
219+applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)
220+ = runUpdates rate layer gradient :~~> applyRecurrentUpdate rate rest grest
221+
222+applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)
223+ = runUpdates rate layer gradient :~@> applyRecurrentUpdate rate rest grest
224+
225+applyRecurrentUpdate _ RNil RGNil
226+ = RNil
227+
228+
229+instance Show (RecurrentNetwork '[] '[i]) where
230+ show RNil = "NNil"
231+instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (FeedForward x ': xs) (i ': rs)) where
232+ show (x :~~> xs) = show x ++ "\n~~>\n" ++ show xs
233+instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recurrent x ': xs) (i ': rs)) where
234+ show (x :~@> xs) = show x ++ "\n~~>\n" ++ show xs
235+
89236
90237-- | A network can easily be created by hand with (:~~>) and (:~@>), but an easy way to initialise a random
91238-- recurrent network and a set of random inputs for it is with the randomRecurrent.
@@ -144,3 +291,38 @@ instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (Recurrent
144291 Just i <- fromStorable . V.fromList <$> getListOf get
145292 rest <- get
146293 return ( i :~@+> rest)
294+
295+
296+-- Num instance for `RecurrentInputs layers`
297+-- Not sure if this is really needed, as I only need a `fromInteger 0` at
298+-- the moment for training, to create a null gradient on the recurrent
299+-- edge.
300+--
301+-- It does raise an interesting question though? Is a 0 gradient actually
302+-- the best?
303+--
304+-- I could imaging that weakly push back towards the optimum input could
305+-- help make a more stable generator.
306+instance (Num (RecurrentInputs '[])) where
307+ (+) _ _ = RINil
308+ (-) _ _ = RINil
309+ (*) _ _ = RINil
310+ abs _ = RINil
311+ signum _ = RINil
312+ fromInteger _ = RINil
313+
314+instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where
315+ (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)
316+ (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)
317+ (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)
318+ abs (() :~~+> x) = () :~~+> abs x
319+ signum (() :~~+> x) = () :~~+> signum x
320+ fromInteger x = () :~~+> fromInteger x
321+
322+instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where
323+ (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')
324+ (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')
325+ (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')
326+ abs (x :~@+> x') = abs x :~@+> abs x'
327+ signum (x :~@+> x') = signum x :~@+> signum x'
328+ fromInteger x = fromInteger x :~@+> fromInteger x