@@ -1,5 +1,8 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE BangPatterns #-}
24{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
36{-# LANGUAGE TypeOperators #-}
47{-# LANGUAGE TypeFamilies #-}
58{-# LANGUAGE MultiParamTypeClasses #-}
@@ -12,63 +15,36 @@ Copyright : (c) Huw Campbell, 2016-2017
1215License : BSD2
1316Stability : experimental
1417
15−This module defines the core data type for the simplest
16−Neural network we support.
17−
18+This module defines the core data types and functions
19+for non-recurrent neural networks.
1820-}
21+
22+#if __GLASGOW_HASKELL__ < 800
23+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
24+#endif
25+
1926module Grenade.Core.Network (
20− Layer (..)
21− , Network (..)
22− , UpdateLayer (..)
23− , LearningParameters (..)
27+ Network (..)
2428 , Gradients (..)
25− , CreatableNetwork (..)
29+ , Tapes (..)
30+
31+ , runNetwork
32+ , runGradient
33+ , applyUpdate
34+
35+ , randomNetwork
2636 ) where
2737
28−import Control.Monad.Random (MonadRandom)
29−import Data.List ( foldl' )
30−import Data.Singletons
38+import Control.Monad.Random ( MonadRandom )
3139
40+import Data.Singletons
41+import Data.Singletons.Prelude
3242import Data.Serialize
3343
44+import Grenade.Core.Layer
45+import Grenade.Core.LearningParameters
3446import Grenade.Core.Shape
3547
36−-- | Learning parameters for stochastic gradient descent.
37−data LearningParameters = LearningParameters {
38− learningRate :: Double
39− , learningMomentum :: Double
40− , learningRegulariser :: Double
41− } deriving (Eq, Show)
42−
43−-- | Class for updating a layer. All layers implement this, and it is
44−-- shape independent.
45−class Show x => UpdateLayer x where
46− {-# MINIMAL runUpdate, createRandom #-}
47− -- | The type for the gradient for this layer.
48− -- Unit if there isn't a gradient to pass back.
49− type Gradient x :: *
50− -- | Update a layer with its gradient and learning parameters
51− runUpdate :: LearningParameters -> x -> Gradient x -> x
52−
53− -- | Create a random layer, many layers will use pure
54− createRandom :: MonadRandom m => m x
55−
56− -- | Update a layer with many Gradients
57− runUpdates :: LearningParameters -> x -> [Gradient x] -> x
58− runUpdates rate = foldl' (runUpdate rate)
59−
60−-- | Class for a layer. All layers implement this, however, they don't
61−-- need to implement it for all shapes, only ones which are appropriate.
62−class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where
63− -- | Used in training and scoring. Take the input from the previous
64− -- layer, and give the output from this layer.
65− runForwards :: x -> S i -> S o
66− -- | Back propagate a step. Takes the current layer, the input that the
67− -- layer gave from the input and the back propagated derivatives from
68− -- the layer above.
69− -- Returns the gradient layer and the derivatives to push back further.
70− runBackwards :: x -> S i -> S o -> (Gradient x, S i)
71−
7248-- | Type of a network.
7349--
7450-- The [*] type specifies the types of the layers.
@@ -78,39 +54,144 @@ class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where
7854-- Can be considered to be a heterogeneous list of layers which are able to
7955-- transform the data shapes of the network.
8056data Network :: [*] -> [Shape] -> * where
81− O :: (SingI i, SingI o, Layer x i o) => !x -> Network '[x] '[i, o]
82− (:~>) :: (SingI i, SingI h, Layer x i h) => !x -> !(Network xs (h ': hs)) -> Network (x ': xs) (i ': h ': hs)
57+ NNil :: SingI i
58+ => Network '[] '[i]
59+
60+ (:~>) :: (SingI i, SingI h, Layer x i h)
61+ => !x
62+ -> !(Network xs (h ': hs))
63+ -> Network (x ': xs) (i ': h ': hs)
8364infixr 5 :~>
8465
85−instance Show (Network l h) where
86− show (O a) = "O " ++ show a
87− show (i :~> o) = show i ++ "\n:~>\n" ++ show o
66+instance Show (Network '[] '[i]) where
67+ show NNil = "NNil"
68+instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) where
69+ show (x :~> xs) = show x ++ "\n~>\n" ++ show xs
8870
89−-- | Gradients of a network.
90−-- Parameterised on the layers of a Network.
71+-- | Gradient of a network.
72+--
73+-- Parameterised on the layers of the network.
9174data Gradients :: [*] -> * where
92− OG :: UpdateLayer x => Gradient x -> Gradients '[x]
93− (:/>) :: UpdateLayer x => Gradient x -> Gradients xs -> Gradients (x ': xs)
75+ GNil :: Gradients '[]
76+
77+ (:/>) :: UpdateLayer x
78+ => Gradient x
79+ -> Gradients xs
80+ -> Gradients (x ': xs)
81+
82+-- | Wegnert Tape of a network.
83+--
84+-- Parameterised on the layers and shapes of the network.
85+data Tapes :: [*] -> [Shape] -> * where
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+
9494
95−-- | A network can easily be created by hand with (:~>), but an easy way to initialise a random
96−-- network is with the randomNetwork.
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.
129+ Network layers shapes
130+ -> Tapes layers shapes
131+ -> S (Last shapes)
132+ -> (Gradients layers, S (Head shapes))
133+runGradient net tapes o =
134+ go net tapes
135+ where
136+ go :: forall js ss. (Last js ~ Last shapes)
137+ => Network ss js
138+ -> Tapes ss js
139+ -> (Gradients ss, S (Head js))
140+ go (layer :~> n) (tape :\> nt) =
141+ let (gradients, feed) = go n nt
142+ (layer', backGrad) = runBackwards layer tape feed
143+ in (layer' :/> gradients, backGrad)
144+
145+ go NNil TNil
146+ = (GNil, o)
147+
148+
149+-- | Apply one step of stochastic gradient decent across the network.
150+applyUpdate :: LearningParameters
151+ -> Network layers shapes
152+ -> Gradients layers
153+ -> Network layers shapes
154+applyUpdate rate (layer :~> rest) (gradient :/> grest)
155+ = runUpdate rate layer gradient :~> applyUpdate rate rest grest
156+
157+applyUpdate _ NNil GNil
158+ = NNil
159+
160+
161+-- | A network can easily be created by hand with (:~>), but an easy way to
162+-- initialise a random network is with the randomNetwork.
97163class CreatableNetwork (xs :: [*]) (ss :: [Shape]) where
98− -- | Create a network of the types requested
164+ -- | Create a network with randomly initialised weights.
165+ --
166+ -- Calls to this function will not compile if the type of the neural
167+ -- network is not sound.
99168 randomNetwork :: MonadRandom m => m (Network xs ss)
100169
101−instance (SingI i, SingI o, Layer x i o) => CreatableNetwork (x ': '[]) (i ': o ': '[]) where
102− randomNetwork = O <$> createRandom
170+instance SingI i => CreatableNetwork '[] '[i] where
171+ randomNetwork = return NNil
103172
104−instance (SingI i, SingI o, Layer x i o, CreatableNetwork xs (o ': r ': rs)) => CreatableNetwork (x ': xs) (i ': o ': r ': rs) where
173+instance (SingI i, SingI o, Layer x i o, CreatableNetwork xs (o ': rs)) => CreatableNetwork (x ': xs) (i ': o ': rs) where
105174 randomNetwork = (:~>) <$> createRandom <*> randomNetwork
106175
107−
108176-- | Add very simple serialisation to the network
109−instance (SingI i, SingI o, Layer x i o, Serialize x) => Serialize (Network '[x] '[i, o]) where
110− put (O x) = put x
111− put _ = error "impossible"
112− get = O <$> get
177+instance SingI i => Serialize (Network '[] '[i]) where
178+ put NNil = pure ()
179+ get = return NNil
113180
114−instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o ': r ': rs))) => Serialize (Network (x ': xs) (i ': o ': r ': rs)) where
181+instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o ': rs))) => Serialize (Network (x ': xs) (i ': o ': rs)) where
115182 put (x :~> r) = put x >> put r
116183 get = (:~>) <$> get <*> get
184+
185+
186+-- | Ultimate composition.
187+--
188+-- This allows a complete network to be treated as a layer in a bigger network.
189+instance CreatableNetwork sublayers subshapes => UpdateLayer (Network sublayers subshapes) where
190+ type Gradient (Network sublayers subshapes) = Gradients sublayers
191+ runUpdate = applyUpdate
192+ createRandom = randomNetwork
193+
194+instance (CreatableNetwork sublayers subshapes, i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (Network sublayers subshapes) i o where
195+ type Tape (Network sublayers subshapes) i o = Tapes sublayers subshapes
196+ runForwards = runNetwork
197+ runBackwards = runGradient