@@ -1,5 +1,8 @@
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
4{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
@@ -12,63 +15,36 @@ Copyright : (c) Huw Campbell, 2016-2017
12License : BSD2
15License : BSD2
13Stability : experimental
16Stability : experimental
15−This module defines the core data type for the simplest
18+This module defines the core data types and functions
16−Neural network we support.
19+for non-recurrent neural networks.
22+#if __GLASGOW_HASKELL__ < 800
23+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
19module Grenade.Core.Network (
26module Grenade.Core.Network (
21− , Network (..)
27+ Network (..)
23− , LearningParameters (..)
24 , Gradients (..)
28 , Gradients (..)
25− , CreatableNetwork (..)
29+ , Tapes (..)
28−import Control.Monad.Random (MonadRandom)
38+import Control.Monad.Random ( MonadRandom )
29−import Data.List ( foldl' )
30−import Data.Singletons
40+import Data.Singletons
41+import Data.Singletons.Prelude
32import Data.Serialize
42import Data.Serialize
44+import Grenade.Core.Layer
45+import Grenade.Core.LearningParameters
34import Grenade.Core.Shape
46import Grenade.Core.Shape
36−-- | Learning parameters for stochastic gradient descent.
37−data LearningParameters = LearningParameters {
38− learningRate :: Double
39− , learningMomentum :: Double
40− , learningRegulariser :: Double
41− } deriving (Eq, Show)
43−-- | Class for updating a layer. All layers implement this, and it is
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.
50− -- | Update a layer with its gradient and learning parameters
51− runUpdate :: LearningParameters -> x -> Gradient x -> x
53− -- | Create a random layer, many layers will use pure
54− createRandom :: MonadRandom m => m x
56− -- | Update a layer with many Gradients
57− runUpdates :: LearningParameters -> x -> [Gradient x] -> x
58− runUpdates rate = foldl' (runUpdate rate)
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
69− -- Returns the gradient layer and the derivatives to push back further.
70− runBackwards :: x -> S i -> S o -> (Gradient x, S i)
72-- | Type of a network.
48-- | Type of a network.
74-- The [*] type specifies the types of the layers.
50-- The [*] type specifies the types of the layers.
@@ -78,39 +54,144 @@ class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where
78-- Can be considered to be a heterogeneous list of layers which are able to
54-- Can be considered to be a heterogeneous list of layers which are able to
79-- transform the data shapes of the network.
55-- transform the data shapes of the network.
80data Network :: [*] -> [Shape] -> * where
56data Network :: [*] -> [Shape] -> * where
81− O :: (SingI i, SingI o, Layer x i o) => !x -> Network '[x] '[i, o]
58+ => Network '[] '[i]
82− (:~>) :: (SingI i, SingI h, Layer x i h) => !x -> !(Network xs (h ': hs)) -> Network (x ': xs) (i ': h ': hs)
60+ (:~>) :: (SingI i, SingI h, Layer x i h)
62+ -> !(Network xs (h ': hs))
63+ -> Network (x ': xs) (i ': h ': hs)
83infixr 5 :~>
64infixr 5 :~>
85−instance Show (Network l h) where
66+instance Show (Network '[] '[i]) where
86− show (O a) = "O " ++ show a
67+ show NNil = "NNil"
68+instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) where
87− show (i :~> o) = show i ++ "\n:~>\n" ++ show o
69+ show (x :~> xs) = show x ++ "\n~>\n" ++ show xs
89−-- | Gradients of a network.
71+-- | Gradient of a network.
90−-- Parameterised on the layers of a Network.
73+-- Parameterised on the layers of the network.
91data Gradients :: [*] -> * where
74data Gradients :: [*] -> * where
92− OG :: UpdateLayer x => Gradient x -> Gradients '[x]
75+ GNil :: Gradients '[]
93− (:/>) :: UpdateLayer x => Gradient x -> Gradients xs -> Gradients (x ': xs)
77+ (:/>) :: UpdateLayer x
80+ -> Gradients (x ': xs)
82+-- | Wegnert Tape of a network.
84+-- Parameterised on the layers and shapes of the network.
85+data Tapes :: [*] -> [Shape] -> * where
89+ (:\>) :: (SingI i, SingI h, Layer x i h)
91+ -> !(Tapes xs (h ': hs))
92+ -> Tapes (x ': xs) (i ': h ': hs)
95+-- | Running a network forwards with some input data.
97+-- This gives the output, and the Wengert tape required for back
100+runNetwork :: forall layers shapes.
101+ Network layers shapes
103+ -> (Tapes layers shapes, S (Last shapes))
107+ go :: forall js ss. (Last js ~ Last shapes)
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)
120+-- | Running a loss gradient back through the network.
122+-- This requires a Wengert tape, generated with the appropriate input
125+-- Gives the gradients for the layer, and the gradient across the
126+-- input (which may not be required).
128+runGradient :: forall layers shapes.
129+ Network layers shapes
130+ -> Tapes layers shapes
132+ -> (Gradients layers, S (Head shapes))
133+runGradient net tapes o =
136+ go :: forall js ss. (Last js ~ Last shapes)
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)
149+-- | Apply one step of stochastic gradient decent across the network.
150+applyUpdate :: LearningParameters
151+ -> Network layers shapes
153+ -> Network layers shapes
154+applyUpdate rate (layer :~> rest) (gradient :/> grest)
155+ = runUpdate rate layer gradient :~> applyUpdate rate rest grest
157+applyUpdate _ NNil GNil
95−-- | A network can easily be created by hand with (:~>), but an easy way to initialise a random
161+-- | A network can easily be created by hand with (:~>), but an easy way to
96−-- network is with the randomNetwork.
162+-- initialise a random network is with the randomNetwork.
97class CreatableNetwork (xs :: [*]) (ss :: [Shape]) where
163class CreatableNetwork (xs :: [*]) (ss :: [Shape]) where
98− -- | Create a network of the types requested
164+ -- | Create a network with randomly initialised weights.
166+ -- Calls to this function will not compile if the type of the neural
167+ -- network is not sound.
99 randomNetwork :: MonadRandom m => m (Network xs ss)
168 randomNetwork :: MonadRandom m => m (Network xs ss)
101−instance (SingI i, SingI o, Layer x i o) => CreatableNetwork (x ': '[]) (i ': o ': '[]) where
170+instance SingI i => CreatableNetwork '[] '[i] where
102− randomNetwork = O <$> createRandom
171+ randomNetwork = return NNil
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
105 randomNetwork = (:~>) <$> createRandom <*> randomNetwork
174 randomNetwork = (:~>) <$> createRandom <*> randomNetwork
108-- | Add very simple serialisation to the network
176-- | 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
177+instance SingI i => Serialize (Network '[] '[i]) where
110− put (O x) = put x
178+ put NNil = pure ()
111− put _ = error "impossible"
179+ get = return NNil
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
115 put (x :~> r) = put x >> put r
182 put (x :~> r) = put x >> put r
116 get = (:~>) <$> get <*> get
183 get = (:~>) <$> get <*> get
186+-- | Ultimate composition.
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
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