@@ -15,9 +15,8 @@ Copyright : (c) Huw Campbell, 2016-2017
1515License : BSD2
1616Stability : experimental
1717
18−This module defines the core data type for the simplest
19−Neural network we support.
20−
18+This module defines the core data types and functions
19+for non-recurrent neural networks.
2120-}
2221
2322#if __GLASGOW_HASKELL__ < 800
@@ -28,9 +27,12 @@ module Grenade.Core.Network (
2827 Network (..)
2928 , Gradients (..)
3029 , Tapes (..)
31− , CreatableNetwork (..)
3230
31+ , runNetwork
32+ , runGradient
3333 , applyUpdate
34+
35+ , randomNetwork
3436 ) where
3537
3638import Control.Monad.Random ( MonadRandom )
@@ -66,27 +68,94 @@ instance Show (Network '[] '[i]) where
6668instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) where
6769 show (x :~> xs) = show x ++ "\n~>\n" ++ show xs
6870
69−
70−-- | Apply one step of stochastic gradient decent across the network.
71−applyUpdate :: LearningParameters -> Network ls ss -> Gradients ls -> Network ls ss
72−applyUpdate _ NNil GNil
73− = NNil
74−applyUpdate rate (layer :~> rest) (gradient :/> grest)
75− = runUpdate rate layer gradient :~> applyUpdate rate rest grest
76−
77−
78−
79−-- | Gradients of a network.
71+-- | Gradient of a network.
72+--
8073-- Parameterised on the layers of the network.
8174data Gradients :: [*] -> * where
8275 GNil :: Gradients '[]
83− (:/>) :: UpdateLayer x => Gradient x -> Gradients xs -> Gradients (x ': xs)
8476
85−-- | Wegnert Tapes of a network.
77+ (:/>) :: UpdateLayer x
78+ => Gradient x
79+ -> Gradients xs
80+ -> Gradients (x ': xs)
81+
82+-- | Wegnert Tape of a network.
83+--
8684-- Parameterised on the layers and shapes of the network.
8785data Tapes :: [*] -> [Shape] -> * where
88− TNil :: SingI i => Tapes '[] '[i]
89− (:\>) :: (SingI i, SingI h, Layer x i h) => !(Tape x i h) -> !(Tapes xs (h ': hs)) -> Tapes (x ': xs) (i ': h ': hs)
86+ TNil :: SingI i
87+ => Tapes '[] '[i]
88+
89+ (:\>) :: (SingI i, SingI h, Layer x i h)
90+ => !(Tape x i h)
91+ -> !(Tapes xs (h ': hs))
92+ -> Tapes (x ': xs) (i ': h ': hs)
93+
94+
95+-- | Running a network forwards with some input data.
96+--
97+-- This gives the output, and the Wengert tape required for back
98+-- propagation.
99+--
100+runNetwork :: forall layers shapes.
101+ Network layers shapes
102+ -> S (Head shapes)
103+ -> (Tapes layers shapes, S (Last shapes))
104+runNetwork =
105+ go
106+ where
107+ go :: forall js ss. (Last js ~ Last shapes)
108+ => Network ss js
109+ -> S (Head js)
110+ -> (Tapes ss js, S (Last js))
111+ go (layer :~> n) !x =
112+ let (tape, forward) = runForwards layer x
113+ (tapes, answer) = go n forward
114+ in (tape :\> tapes, answer)
115+
116+ go NNil !x
117+ = (TNil, x)
118+
119+
120+-- | Running a loss gradient back through the network.
121+--
122+-- This requires a Wengert tape, generated with the appropriate input
123+-- for the loss.
124+--
125+-- Gives the gradients for the layer, and the gradient across the
126+-- input (which may not be required).
127+--
128+runGradient :: forall layers shapes. Network layers shapes
129+ -> Tapes layers shapes
130+ -> S (Last shapes)
131+ -> (Gradients layers, S (Head shapes))
132+runGradient net tapes o =
133+ go net tapes
134+ where
135+ go :: forall js ss. (Last js ~ Last shapes)
136+ => Network ss js
137+ -> Tapes ss js
138+ -> (Gradients ss, S (Head js))
139+ go (layer :~> n) (tape :\> nt) =
140+ let (gradients, feed) = go n nt
141+ (layer', backGrad) = runBackwards layer tape feed
142+ in (layer' :/> gradients, backGrad)
143+
144+ go NNil TNil
145+ = (GNil, o)
146+
147+
148+-- | Apply one step of stochastic gradient decent across the network.
149+applyUpdate :: LearningParameters
150+ -> Network layers shapes
151+ -> Gradients layers
152+ -> Network layers shapes
153+applyUpdate rate (layer :~> rest) (gradient :/> grest)
154+ = runUpdate rate layer gradient :~> applyUpdate rate rest grest
155+
156+applyUpdate _ NNil GNil
157+ = NNil
158+
90159
91160-- | A network can easily be created by hand with (:~>), but an easy way to initialise a random
92161-- network is with the randomNetwork.
@@ -115,36 +184,10 @@ instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o '
115184-- This allows a complete network to be treated as a layer in a bigger network.
116185instance CreatableNetwork sublayers subshapes => UpdateLayer (Network sublayers subshapes) where
117186 type Gradient (Network sublayers subshapes) = Gradients sublayers
118− runUpdate = applyUpdate
187+ runUpdate = applyUpdate
119188 createRandom = randomNetwork
120189
121190instance (CreatableNetwork sublayers subshapes, i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (Network sublayers subshapes) i o where
122191 type Tape (Network sublayers subshapes) i o = Tapes sublayers subshapes
123−
124− runForwards net i =
125− go i net
126− where
127− go :: forall js ss. (Last js ~ Last subshapes)
128− => S (Head js) -- ^ input vector
129− -> Network ss js -- ^ network to train
130− -> (Tapes ss js, S (Last js))
131− go !x (layer :~> n) =
132− let (tape, forward) = runForwards layer x
133− (tapes, answer) = go forward n
134− in (tape :\> tapes, answer)
135− go !x NNil
136− = (TNil, x)
137−
138− runBackwards net tapes o =
139− go net tapes
140− where
141− go :: forall js ss. (Last js ~ Last subshapes)
142− => Network ss js -- ^ network to train
143− -> Tapes ss js -- ^ network to train
144− -> (Gradients ss, S (Head js))
145− go (layer :~> n) (tape :\> nt) =
146− let (gradients, feed) = go n nt
147− (layer', backGrad) = runBackwards layer tape feed
148− in (layer' :/> gradients, backGrad)
149− go NNil TNil
150− = (GNil, o)
192+ runForwards = runNetwork
193+ runBackwards = runGradient