@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE TypeOperators #-}
@@ -17,37 +18,34 @@ module Grenade.Recurrent.Core.Network (
1718
1819 , RecurrentNetwork (..)
1920 , RecurrentInputs (..)
20− , RecurrentTapes (..)
21− , RecurrentGradients (..)
21+ , RecurrentTape (..)
22+ , RecurrentGradient (..)
2223
2324 , randomRecurrent
24− , runRecurrentNetwork
25− , runRecurrentGradient
25+ , runRecurrent
26+ , runRecurrent'
2627 , applyRecurrentUpdate
2728 ) where
2829
2930
3031import Control.Monad.Random ( MonadRandom )
31−import Data.Singletons ( SingI )
32−import Data.Singletons.Prelude ( Head, Last )
3332import Data.Serialize
34−import qualified Data.Vector.Storable as V
33+
34+import Data.Kind (Type)
3535
3636import Grenade.Core
3737import Grenade.Recurrent.Core.Layer
38−
39−import qualified Numeric.LinearAlgebra as LA
40−import qualified Numeric.LinearAlgebra.Static as LAS
38+import Prelude.Singletons
4139
4240-- | Witness type to say indicate we're building up with a normal feed
4341-- forward layer.
44−data FeedForward :: * -> *
42+data FeedForward :: Type -> Type
4543-- | Witness type to say indicate we're building up with a recurrent layer.
46−data Recurrent :: * -> *
44+data Recurrent :: Type -> Type
4745
4846-- | Type of a recurrent neural network.
4947--
50−-- The [*] type specifies the types of the layers.
48+-- The [Type] type specifies the types of the layers.
5149--
5250-- The [Shape] type specifies the shapes of data passed between the layers.
5351--
@@ -56,7 +54,7 @@ data Recurrent :: * -> *
5654--
5755-- Often, to make the definitions more concise, one will use a type alias
5856-- for these empty data types.
59−data RecurrentNetwork :: [*] -> [Shape] -> * where
57+data RecurrentNetwork :: [Type] -> [Shape] -> Type where
6058 RNil :: SingI i
6159 => RecurrentNetwork '[] '[i]
6260
@@ -75,96 +73,82 @@ infixr 5 :~@>
7573-- | Gradient of a network.
7674--
7775-- Parameterised on the layers of the network.
78−data RecurrentGradients :: [*] -> * where
79− RGNil :: RecurrentGradients '[]
76+data RecurrentGradient :: [Type] -> Type where
77+ RGNil :: RecurrentGradient '[]
8078
8179 (://>) :: UpdateLayer x
82− => [Gradient x]
83− -> RecurrentGradients xs
84− -> RecurrentGradients (phantom x ': xs)
80+ => Gradient x
81+ -> RecurrentGradient xs
82+ -> RecurrentGradient (phantom x ': xs)
8583
8684-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)
8785-- Parameterised on the layers of a Network.
88−data RecurrentInputs :: [*] -> * where
86+data RecurrentInputs :: [Type] -> Type where
8987 RINil :: RecurrentInputs '[]
9088
91− (:~~+>) :: UpdateLayer x
89+ (:~~+>) :: (UpdateLayer x, Fractional (RecurrentInputs xs))
9290 => () -> !(RecurrentInputs xs) -> RecurrentInputs (FeedForward x ': xs)
9391
94− (:~@+>) :: (SingI (RecurrentShape x), RecurrentUpdateLayer x)
95− => !(S (RecurrentShape x)) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)
92+ (:~@+>) :: (Fractional (RecurrentShape x), Fractional (RecurrentInputs xs), RecurrentUpdateLayer x)
93+ => !(RecurrentShape x) -> !(RecurrentInputs xs) -> RecurrentInputs (Recurrent x ': xs)
9694
9795-- | All the information required to backpropogate
9896-- through time safely.
9997--
10098-- We index on the time step length as well, to ensure
10199-- that that all Tape lengths are the same.
102−data RecurrentTapes :: [*] -> [Shape] -> * where
100+data RecurrentTape :: [Type] -> [Shape] -> Type where
103101 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)
102+ => RecurrentTape '[] '[i]
109103
104+ (:\~>) :: Tape x i h
105+ -> !(RecurrentTape xs (h ': hs))
106+ -> RecurrentTape (FeedForward x ': xs) (i ': h ': hs)
110107
111− (:\@>) :: [RecTape x i h]
112− -> !(RecurrentTapes xs (h ': hs))
113− -> RecurrentTapes (Recurrent x ': xs) (i ': h ': hs)
108+ (:\@>) :: RecTape x i h
109+ -> !(RecurrentTape xs (h ': hs))
110+ -> RecurrentTape (Recurrent x ': xs) (i ': h ': hs)
114111
115112
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 =
113+runRecurrent :: forall shapes layers.
114+ RecurrentNetwork layers shapes
115+ -> RecurrentInputs layers
116+ -> S (Head shapes)
117+ -> (RecurrentTape layers shapes, RecurrentInputs layers, S (Last shapes))
118+runRecurrent =
122119 go
123120 where
124121 go :: forall js sublayers. (Last js ~ Last shapes)
125122 => RecurrentNetwork sublayers js
126123 -> 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
124+ -> S (Head js)
125+ -> (RecurrentTape sublayers js, RecurrentInputs sublayers, S (Last js))
126+ go (!layer :~~> n) (() :~~+> nIn) !x
127+ = let (!tape, !forwards) = runForwards layer x
128+
134129 -- 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)
130+ (!newFN, !ig, !answer) = go n nIn forwards
131+ in (tape :\~> newFN, () :~~+> ig, answer)
137132
138133 -- This is a recurrent layer, so we need to do a scan, first input to last, providing
139134 -- 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−
135+ go (layer :~@> n) (recIn :~@+> nIn) !x
136+ = let (tape, shape, forwards) = runRecurrentForwards layer recIn x
145137 (newFN, ig, answer) = go n nIn forwards
146− in (recurrentTapes :\@> newFN, recOut :~@+> ig, answer)
138+ in (tape :\@> newFN, shape :~@+> ig, answer)
147139
148140 -- Handle the output layer, bouncing the derivatives back down.
149141 -- We may not have a target for each example, so when we don't use 0 gradient.
150142 go RNil RINil !x
151143 = (TRNil, RINil, x)
152144
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 =
145+runRecurrent' :: forall layers shapes.
146+ RecurrentNetwork layers shapes
147+ -> RecurrentTape layers shapes
148+ -> RecurrentInputs layers
149+ -> S (Last shapes)
150+ -> (RecurrentGradient layers, RecurrentInputs layers, S (Head shapes))
151+runRecurrent' net tapes r o =
168152 go net tapes r
169153 where
170154 -- We have to be careful regarding the direction of the lists
@@ -172,51 +156,41 @@ runRecurrentGradient net tapes r o =
172156 -- through time.
173157 go :: forall js ss. (Last js ~ Last shapes)
174158 => RecurrentNetwork ss js
175− -> RecurrentTapes ss js
159+ -> RecurrentTape ss js
176160 -> RecurrentInputs ss
177− -> (RecurrentGradients ss, RecurrentInputs ss, [S (Head js)])
161+ -> (RecurrentGradient ss, RecurrentInputs ss, S (Head js))
178162 -- 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)
163+ -- Run the rest of the network, update with the tapes and gradients
164+ go (!layer :~~> n) (!tape :\~> nTapes) (() :~~+> nRecs) =
165+ let (!gradients, !rins, !feed) = go n nTapes nRecs
166+ (!grad, !back) = runBackwards layer tape feed
167+ in (grad ://> gradients, () :~~+> rins, back)
184168
185169 -- This is a recurrent layer
186170 -- 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)
171+ go (!layer :~@> n) (!tape :\@> nTapes) (!recGrad :~@+> nRecs) =
172+ let (!gradients, !rins, !feed) = go n nTapes nRecs
173+ (!grad, !sidegrad, !back) = runRecurrentBackwards layer tape recGrad feed
174+ in (grad ://> gradients, sidegrad :~@+> rins, back)
192175
193176 -- End of the road, so we reflect the given gradients backwards.
194177 -- Crucially, we reverse the list, so it's backwards in time as
195178 -- 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, [])
179+ go !RNil !TRNil !RINil
180+ = (RGNil, RINil, o)
207181
208182-- | Apply a batch of gradients to the network
209183-- Uses runUpdates which can be specialised for
210184-- a layer.
211185applyRecurrentUpdate :: LearningParameters
212186 -> RecurrentNetwork layers shapes
213− -> RecurrentGradients layers
187+ -> RecurrentGradient layers
214188 -> RecurrentNetwork layers shapes
215189applyRecurrentUpdate rate (layer :~~> rest) (gradient ://> grest)
216− = runUpdates rate layer gradient :~~> applyRecurrentUpdate rate rest grest
190+ = runUpdate rate layer gradient :~~> applyRecurrentUpdate rate rest grest
217191
218192applyRecurrentUpdate rate (layer :~@> rest) (gradient ://> grest)
219− = runUpdates rate layer gradient :~@> applyRecurrentUpdate rate rest grest
193+ = runUpdate rate layer gradient :~@> applyRecurrentUpdate rate rest grest
220194
221195applyRecurrentUpdate _ RNil RGNil
222196 = RNil
@@ -232,26 +206,25 @@ instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recu
232206
233207-- | A network can easily be created by hand with (:~~>) and (:~@>), but an easy way to initialise a random
234208-- recurrent network and a set of random inputs for it is with the randomRecurrent.
235−class CreatableRecurrent (xs :: [*]) (ss :: [Shape]) where
209+class CreatableRecurrent (xs :: [Type]) (ss :: [Shape]) where
236210 -- | Create a network of the types requested
237− randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss, RecurrentInputs xs)
211+ randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss)
238212
239213instance SingI i => CreatableRecurrent '[] '[i] where
240214 randomRecurrent =
241− return (RNil, RINil)
215+ return RNil
242216
243217instance (SingI i, Layer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (FeedForward x ': xs) (i ': o ': rs) where
244218 randomRecurrent = do
245219 thisLayer <- createRandom
246− (rest, resti) <- randomRecurrent
247− return (thisLayer :~~> rest, () :~~+> resti)
220+ rest <- randomRecurrent
221+ return (thisLayer :~~> rest)
248222
249223instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': rs)) => CreatableRecurrent (Recurrent x ': xs) (i ': o ': rs) where
250224 randomRecurrent = do
251225 thisLayer <- createRandom
252− thisShape <- randomOfShape
253− (rest, resti) <- randomRecurrent
254− return (thisLayer :~@> rest, thisShape :~@+> resti)
226+ rest <- randomRecurrent
227+ return (thisLayer :~@> rest)
255228
256229-- | Add very simple serialisation to the recurrent network
257230instance SingI i => Serialize (RecurrentNetwork '[] '[i]) where
@@ -270,23 +243,13 @@ instance (Serialize (RecurrentInputs '[])) where
270243 put _ = return ()
271244 get = return RINil
272245
273−instance (UpdateLayer x, Serialize (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where
246+instance (UpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (FeedForward x ': ys))) where
274247 put ( () :~~+> rest) = put rest
275248 get = ( () :~~+> ) <$> get
276249
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)
250+instance (Serialize (RecurrentShape x), Fractional (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs ys), Fractional (RecurrentInputs ys)) => (Serialize (RecurrentInputs (Recurrent x ': ys))) where
251+ put ( i :~@+> rest ) = put i >> put rest
252+ get = (:~@+>) <$> get <*> get
290253
291254
292255-- Num instance for `RecurrentInputs layers`
@@ -307,7 +270,7 @@ instance (Num (RecurrentInputs '[])) where
307270 signum _ = RINil
308271 fromInteger _ = RINil
309272
310−instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where
273+instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (FeedForward x ': ys))) where
311274 (+) (() :~~+> x) (() :~~+> y) = () :~~+> (x + y)
312275 (-) (() :~~+> x) (() :~~+> y) = () :~~+> (x - y)
313276 (*) (() :~~+> x) (() :~~+> y) = () :~~+> (x * y)
@@ -315,10 +278,51 @@ instance (UpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Fee
315278 signum (() :~~+> x) = () :~~+> signum x
316279 fromInteger x = () :~~+> fromInteger x
317280
318−instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Num (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where
281+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Num (RecurrentInputs (Recurrent x ': ys))) where
319282 (+) (x :~@+> x') (y :~@+> y') = (x + y) :~@+> (x' + y')
320283 (-) (x :~@+> x') (y :~@+> y') = (x - y) :~@+> (x' - y')
321284 (*) (x :~@+> x') (y :~@+> y') = (x * y) :~@+> (x' * y')
322285 abs (x :~@+> x') = abs x :~@+> abs x'
323286 signum (x :~@+> x') = signum x :~@+> signum x'
324287 fromInteger x = fromInteger x :~@+> fromInteger x
288+
289+instance (Fractional (RecurrentInputs '[])) where
290+ (/) _ _ = RINil
291+ recip _ = RINil
292+ fromRational _ = RINil
293+
294+instance (UpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (FeedForward x ': ys))) where
295+ (/) (() :~~+> x) (() :~~+> y) = () :~~+> (x / y)
296+ recip (() :~~+> x) = () :~~+> recip x
297+ fromRational x = () :~~+> fromRational x
298+
299+instance (Fractional (RecurrentShape x), RecurrentUpdateLayer x, Fractional (RecurrentInputs ys)) => (Fractional (RecurrentInputs (Recurrent x ': ys))) where
300+ (/) (x :~@+> x') (y :~@+> y') = (x / y) :~@+> (x' / y')
301+ recip (x :~@+> x') = recip x :~@+> recip x'
302+ fromRational x = fromRational x :~@+> fromRational x
303+
304+
305+-- | Ultimate composition.
306+--
307+-- This allows a complete network to be treated as a layer in a larger network.
308+instance CreatableRecurrent sublayers subshapes => UpdateLayer (RecurrentNetwork sublayers subshapes) where
309+ type Gradient (RecurrentNetwork sublayers subshapes) = RecurrentGradient sublayers
310+ runUpdate = applyRecurrentUpdate
311+ createRandom = randomRecurrent
312+
313+-- | Ultimate composition.
314+--
315+-- This allows a complete network to be treated as a layer in a larger network.
316+instance CreatableRecurrent sublayers subshapes => RecurrentUpdateLayer (RecurrentNetwork sublayers subshapes) where
317+ type RecurrentShape (RecurrentNetwork sublayers subshapes) = RecurrentInputs sublayers
318+
319+-- | Ultimate composition.
320+--
321+-- This allows a complete network to be treated as a layer in a larger network.
322+instance ( CreatableRecurrent sublayers subshapes
323+ , i ~ (Head subshapes), o ~ (Last subshapes)
324+ , Num (RecurrentShape (RecurrentNetwork sublayers subshapes))
325+ ) => RecurrentLayer (RecurrentNetwork sublayers subshapes) i o where
326+ type RecTape (RecurrentNetwork sublayers subshapes) i o = RecurrentTape sublayers subshapes
327+ runRecurrentForwards = runRecurrent
328+ runRecurrentBackwards = runRecurrent'