@@ -1,5 +1,7 @@
11{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE BangPatterns #-}
23{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
35{-# LANGUAGE TypeOperators #-}
46{-# LANGUAGE TypeFamilies #-}
57{-# LANGUAGE MultiParamTypeClasses #-}
@@ -17,63 +19,24 @@ Neural network we support.
1719
1820-}
1921module Grenade.Core.Network (
20− Layer (..)
21− , Network (..)
22− , UpdateLayer (..)
23− , LearningParameters (..)
22+ Network (..)
2423 , Gradients (..)
2524 , Tapes (..)
2625 , CreatableNetwork (..)
26+
27+ , applyUpdate
2728 ) where
2829
29−import Control.Monad.Random (MonadRandom)
30−import Data.List ( foldl' )
31−import Data.Singletons
30+import Control.Monad.Random ( MonadRandom )
3231
32+import Data.Singletons
33+import Data.Singletons.Prelude
3334import Data.Serialize
3435
36+import Grenade.Core.Layer
37+import Grenade.Core.LearningParameters
3538import Grenade.Core.Shape
3639
37−-- | Learning parameters for stochastic gradient descent.
38−data LearningParameters = LearningParameters {
39− learningRate :: Double
40− , learningMomentum :: Double
41− , learningRegulariser :: Double
42− } deriving (Eq, Show)
43−
44−-- | Class for updating a layer. All layers implement this, and it is
45−-- shape independent.
46−class UpdateLayer x where
47− {-# MINIMAL runUpdate, createRandom #-}
48− -- | The type for the gradient for this layer.
49− -- Unit if there isn't a gradient to pass back.
50− type Gradient x :: *
51− -- | Update a layer with its gradient and learning parameters
52− runUpdate :: LearningParameters -> x -> Gradient x -> x
53−
54− -- | Create a random layer, many layers will use pure
55− createRandom :: MonadRandom m => m x
56−
57− -- | Update a layer with many Gradients
58− runUpdates :: LearningParameters -> x -> [Gradient x] -> x
59− runUpdates rate = foldl' (runUpdate rate)
60−
61−-- | Class for a layer. All layers implement this, however, they don't
62−-- need to implement it for all shapes, only ones which are appropriate.
63−class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where
64− -- | The Wengert tape for this layer. Includes all that is required
65− -- to generate the back propagated gradients efficiently. As a
66− -- default, `S i` is fine.
67− type Tape x i o :: *
68− -- | Used in training and scoring. Take the input from the previous
69− -- layer, and give the output from this layer.
70− runForwards :: x -> S i -> (Tape x i o, S o)
71− -- | Back propagate a step. Takes the current layer, the input that the
72− -- layer gave from the input and the back propagated derivatives from
73− -- the layer above.
74− -- Returns the gradient layer and the derivatives to push back further.
75− runBackwards :: x -> Tape x i o -> S o -> (Gradient x, S i)
76−
7740-- | Type of a network.
7841--
7942-- The [*] type specifies the types of the layers.
@@ -92,6 +55,16 @@ instance Show (Network '[] '[i]) where
9255instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) where
9356 show (x :~> xs) = show x ++ "\n~>\n" ++ show xs
9457
58+
59+-- | Apply one step of stochastic gradient decent across the network.
60+applyUpdate :: LearningParameters -> Network ls ss -> Gradients ls -> Network ls ss
61+applyUpdate _ NNil GNil
62+ = NNil
63+applyUpdate rate (layer :~> rest) (gradient :/> grest)
64+ = runUpdate rate layer gradient :~> applyUpdate rate rest grest
65+
66+
67+
9568-- | Gradients of a network.
9669-- Parameterised on the layers of a Network.
9770data Gradients :: [*] -> * where
@@ -116,7 +89,6 @@ instance SingI i => CreatableNetwork '[] '[i] where
11689instance (SingI i, SingI o, Layer x i o, CreatableNetwork xs (o ': rs)) => CreatableNetwork (x ': xs) (i ': o ': rs) where
11790 randomNetwork = (:~>) <$> createRandom <*> randomNetwork
11891
119−
12092-- | Add very simple serialisation to the network
12193instance SingI i => Serialize (Network '[] '[i]) where
12294 put NNil = pure ()
@@ -125,3 +97,43 @@ instance SingI i => Serialize (Network '[] '[i]) where
12597instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o ': rs))) => Serialize (Network (x ': xs) (i ': o ': rs)) where
12698 put (x :~> r) = put x >> put r
12799 get = (:~>) <$> get <*> get
100+
101+
102+-- | Ultimate composition.
103+--
104+-- This allows a complete network to be treated as a layer in a bigger network.
105+instance CreatableNetwork sublayers subshapes => UpdateLayer (Network sublayers subshapes) where
106+ type Gradient (Network sublayers subshapes) = Gradients sublayers
107+ runUpdate = applyUpdate
108+ createRandom = randomNetwork
109+
110+instance (CreatableNetwork sublayers subshapes, i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (Network sublayers subshapes) i o where
111+ type Tape (Network sublayers subshapes) i o = Tapes sublayers subshapes
112+
113+ runForwards net i =
114+ go i net
115+ where
116+ go :: forall js ss. (Last js ~ Last subshapes)
117+ => S (Head js) -- ^ input vector
118+ -> Network ss js -- ^ network to train
119+ -> (Tapes ss js, S (Last js))
120+ go !x (layer :~> n) =
121+ let (tape, forward) = runForwards layer x
122+ (tapes, answer) = go forward n
123+ in (tape :\> tapes, answer)
124+ go !x NNil
125+ = (TNil, x)
126+
127+ runBackwards net tapes o =
128+ go net tapes
129+ where
130+ go :: forall js ss. (Last js ~ Last subshapes)
131+ => Network ss js -- ^ network to train
132+ -> Tapes ss js -- ^ network to train
133+ -> (Gradients ss, S (Head js))
134+ go (layer :~> n) (tape :\> nt) =
135+ let (gradients, feed) = go n nt
136+ (layer', backGrad) = runBackwards layer tape feed
137+ in (layer' :/> gradients, backGrad)
138+ go NNil TNil
139+ = (GNil, o)