6ad9803 · grenade · git.iko.soy

src/Grenade/Core/Network.hs+6−2

compare with master

unifiedsplit

@@ -60,14 +60,18 @@ class Show x => UpdateLayer x where

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.

62class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where

63+ -- | The Wengert tape for this layer. Includes all that is required

64+ -- to generate the back propagated gradients efficiently. As a

65+ -- default, `S i` is fine.

66+ type Tape x i o :: *

63 -- | Used in training and scoring. Take the input from the previous

67 -- | Used in training and scoring. Take the input from the previous

64 -- layer, and give the output from this layer.

68 -- layer, and give the output from this layer.

65− runForwards :: x -> S i -> S o

69+ runForwards :: x -> S i -> (Tape x i o, S o)

66 -- | Back propagate a step. Takes the current layer, the input that the

70 -- | Back propagate a step. Takes the current layer, the input that the

67 -- layer gave from the input and the back propagated derivatives from

71 -- layer gave from the input and the back propagated derivatives from

68 -- the layer above.

72 -- the layer above.

69 -- Returns the gradient layer and the derivatives to push back further.

73 -- Returns the gradient layer and the derivatives to push back further.

70− runBackwards :: x -> S i -> S o -> (Gradient x, S i)

74+ runBackwards :: x -> Tape x i o -> S o -> (Gradient x, S i)

71

75

72-- | Type of a network.

76-- | Type of a network.

73--

77--

src/Grenade/Core/Runner.hs+6−6

@@ -43,19 +43,19 @@ backPropagate network input target =

43 -> (Gradients sublayers, S (Head js))

44 -- handle input from the beginning, feeding upwards.

45 go !x (layer :~> n)

46− = let y = runForwards layer x

46+ = let (tape, y) = runForwards layer x

47 -- recursively run the rest of the network, and get the gradients from above.

48 (n', dWs') = go y n

49 -- calculate the gradient for this layer to pass down,

50− (layer', dWs) = runBackwards layer x dWs'

50+ (layer', dWs) = runBackwards layer tape dWs'

51

52 in (layer' :/> n', dWs)

53

54 -- handle the output layer, bouncing the derivatives back down.

55 go !x (O layer)

56− = let y = runForwards layer x

56+ = let (tape, y) = runForwards layer x

57 -- the gradient (how much y affects the error)

58− (layer', dWs) = runBackwards layer x (y - target)

58+ (layer', dWs) = runBackwards layer tape (y - target)

59

60 in (OG layer', dWs)

61

@@ -76,5 +76,5 @@ train rate network input output =

76

77-- | Run the network with input and return the given output.

78runNet :: Network layers shapes -> S (Head shapes) -> S (Last shapes)

79−runNet (layer :~> n) !x = let y = runForwards layer x in runNet n y

79+runNet (layer :~> n) !x = let (_, y) = runForwards layer x in runNet n y

80−runNet (O layer) !x = runForwards layer x

80+runNet (O layer) !x = snd (runForwards layer x)

src/Grenade/Layers/Convolution.hs+6−2

@@ -157,6 +157,7 @@ instance ( KnownNat kernelRows

157 , KnownNat (kernelRows * kernelCols * 1)

158 , KnownNat (outputRows * filters)

159 ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where

160+ type Tape (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D2 inputRows inputCols)

160 runForwards (Convolution kernel _) (S2D input) =

161 runForwards (Convolution kernel _) (S2D input) =

161 let ex = extract input

162 let ex = extract input

162 ek = extract kernel

163 ek = extract kernel

@@ -170,7 +171,7 @@ instance ( KnownNat kernelRows

170 mt = c LA.<> ek

171 mt = c LA.<> ek

171 r = col2vid 1 1 1 1 ox oy mt

172 r = col2vid 1 1 1 1 ox oy mt

172 rs = fromJust . create $ r

173 rs = fromJust . create $ r

173− in S3D rs

174+ in (S2D input, S3D rs)

174

175

175 runBackwards (Convolution kernel _) (S2D input) (S3D dEdy) =

176 runBackwards (Convolution kernel _) (S2D input) (S3D dEdy) =

176 let ex = extract input

177 let ex = extract input

@@ -214,6 +215,9 @@ instance ( KnownNat kernelRows

214 , KnownNat (kernelRows * kernelCols * channels)

215 , KnownNat (kernelRows * kernelCols * channels)

215 , KnownNat (outputRows * filters)

216 , KnownNat (outputRows * filters)

216 ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where

217 ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where

218+

219+ type Tape (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)

220+

217 runForwards (Convolution kernel _) (S3D input) =

221 runForwards (Convolution kernel _) (S3D input) =

218 let ex = extract input

222 let ex = extract input

219 ek = extract kernel

223 ek = extract kernel

@@ -230,7 +234,7 @@ instance ( KnownNat kernelRows

230 mt = c LA.<> ek

234 mt = c LA.<> ek

231 r = col2vid 1 1 1 1 ox oy mt

235 r = col2vid 1 1 1 1 ox oy mt

232 rs = fromJust . create $ r

236 rs = fromJust . create $ r

233− in S3D rs

237+ in (S3D input, S3D rs)

234 runBackwards (Convolution kernel _) (S3D input) (S3D dEdy) =

238 runBackwards (Convolution kernel _) (S3D input) (S3D dEdy) =

235 let ex = extract input

239 let ex = extract input

236 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

240 ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

src/Grenade/Layers/Crop.hs+2−1

@@ -46,6 +46,7 @@ instance ( KnownNat cropLeft

46 , (inputRows - cropTop - cropBottom) ~ outputRows

47 , (inputColumns - cropLeft - cropRight) ~ outputColumns

48 ) => Layer (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where

49+ type Tape (Crop cropLeft cropTop cropRight cropBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = ()

49 runForwards Crop (S2D input) =

50 runForwards Crop (S2D input) =

50 let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)

51 let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)

51 cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)

52 cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)

@@ -53,7 +54,7 @@ instance ( KnownNat cropLeft

53 ncols = fromIntegral $ natVal (Proxy :: Proxy outputColumns)

54 ncols = fromIntegral $ natVal (Proxy :: Proxy outputColumns)

54 m = extract input

55 m = extract input

55 r = subMatrix (cropt, cropl) (nrows, ncols) m

56 r = subMatrix (cropt, cropl) (nrows, ncols) m

56− in S2D . fromJust . create $ r

57+ in ((), S2D . fromJust . create $ r)

57 runBackwards _ _ (S2D dEdy) =

58 runBackwards _ _ (S2D dEdy) =

58 let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)

59 let cropl = fromIntegral $ natVal (Proxy :: Proxy cropLeft)

59 cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)

60 cropt = fromIntegral $ natVal (Proxy :: Proxy cropTop)

src/Grenade/Layers/Dropout.hs+2−4

@@ -23,7 +23,6 @@ import Numeric.LinearAlgebra.Static

23-- reasonable).

24data Dropout o =

25 Dropout (R o)

26− | Pass Double

27 deriving Show

26 deriving Show

28

27

29instance (KnownNat i) => UpdateLayer (Dropout i) where

28instance (KnownNat i) => UpdateLayer (Dropout i) where

@@ -40,7 +39,6 @@ randomDropout rate = do

40 return $ Dropout xs

39 return $ Dropout xs

41

40

42instance (KnownNat i) => Layer (Dropout i) ('D1 i) ('D1 i) where

41instance (KnownNat i) => Layer (Dropout i) ('D1 i) ('D1 i) where

43− runForwards (Dropout drops) (S1D x) = S1D $ x * drops

42+ type Tape (Dropout i) ('D1 i) ('D1 i) = ()

44− runForwards (Pass rate) (S1D x)= S1D $ dvmap (* (1 - rate)) x

43+ runForwards (Dropout drops) (S1D x) = ((), S1D $ x * drops)

45 runBackwards (Dropout drops) _ (S1D x) = ((), S1D $ x * drops)

44 runBackwards (Dropout drops) _ (S1D x) = ((), S1D $ x * drops)

46− runBackwards (Pass rate) _ (S1D x) = ((), S1D $ dvmap (* (1 - rate)) x)

src/Grenade/Layers/Flatten.hs+6−3

@@ -32,15 +32,18 @@ instance UpdateLayer FlattenLayer where

32 createRandom = return FlattenLayer

33

34instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * z)) => Layer FlattenLayer ('D2 x y) ('D1 a) where

35+ type Tape FlattenLayer ('D2 x y) ('D1 a) = ()

35− runForwards _ (S2D y) = fromJust' . fromStorable . flatten . extract $ y

36+ runForwards _ (S2D y) = ((), fromJust' . fromStorable . flatten . extract $ y)

36 runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)

37 runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)

37

38

38instance (KnownNat a, KnownNat x, KnownNat y, KnownNat (x * z), KnownNat z, a ~ (x * y * z)) => Layer FlattenLayer ('D3 x y z) ('D1 a) where

39instance (KnownNat a, KnownNat x, KnownNat y, KnownNat (x * z), KnownNat z, a ~ (x * y * z)) => Layer FlattenLayer ('D3 x y z) ('D1 a) where

40+ type Tape FlattenLayer ('D3 x y z) ('D1 a) = ()

39− runForwards _ (S3D y) = fromJust' . fromStorable . flatten . extract $ y

41+ runForwards _ (S3D y) = ((), fromJust' . fromStorable . flatten . extract $ y)

40 runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)

42 runBackwards _ _ (S1D y) = ((), fromJust' . fromStorable . extract $ y)

41

43

42instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer FlattenLayer ('D3 x y z) ('D2 x y) where

44instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer FlattenLayer ('D3 x y z) ('D2 x y) where

45+ type Tape FlattenLayer ('D3 x y z) ('D2 x y) = ()

43− runForwards _ (S3D y) = S2D y

46+ runForwards _ (S3D y) = ((), S2D y)

44 runBackwards _ _ (S2D y) = ((), S3D y)

47 runBackwards _ _ (S2D y) = ((), S3D y)

45

48

46instance Serialize FlattenLayer where

49instance Serialize FlattenLayer where

src/Grenade/Layers/FullyConnected.hs+12−13

@@ -25,14 +25,12 @@ import Grenade.Layers.Internal.Update

25

26-- | A basic fully connected (or inner product) neural network layer.

27data FullyConnected i o = FullyConnected

28− !(R o) -- Bias neuron weights

28+ !(FullyConnected' i o) -- Weuron weights

29− !(R o) -- Bias neuron momentum

29+ !(FullyConnected' i o) -- Neuron momentum

30− !(L o i) -- Activation weights

31− !(L o i) -- Momentum

32

30

33data FullyConnected' i o = FullyConnected'

31data FullyConnected' i o = FullyConnected'

34− !(R o) -- Bias neuron gradient

32+ !(R o) -- Bias

35− !(L o i) -- Activation gradient

33+ !(L o i) -- Activations

36

34

37instance Show (FullyConnected i o) where

35instance Show (FullyConnected i o) where

38 show FullyConnected {} = "FullyConnected"

36 show FullyConnected {} = "FullyConnected"

@@ -40,19 +38,20 @@ instance Show (FullyConnected i o) where

40instance (KnownNat i, KnownNat o) => UpdateLayer (FullyConnected i o) where

38instance (KnownNat i, KnownNat o) => UpdateLayer (FullyConnected i o) where

41 type Gradient (FullyConnected i o) = (FullyConnected' i o)

39 type Gradient (FullyConnected i o) = (FullyConnected' i o)

42

40

43− runUpdate LearningParameters {..} (FullyConnected oldBias oldBiasMomentum oldActivations oldMomentum) (FullyConnected' biasGradient activationGradient) =

41+ runUpdate LearningParameters {..} (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =

44 let (newBias, newBiasMomentum) = decendVector learningRate learningMomentum learningRegulariser oldBias biasGradient oldBiasMomentum

42 let (newBias, newBiasMomentum) = decendVector learningRate learningMomentum learningRegulariser oldBias biasGradient oldBiasMomentum

45 (newActivations, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldActivations activationGradient oldMomentum

43 (newActivations, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldActivations activationGradient oldMomentum

46− in FullyConnected newBias newBiasMomentum newActivations newMomentum

44+ in FullyConnected (FullyConnected' newBias newActivations) (FullyConnected' newBiasMomentum newMomentum)

47

45

48 createRandom = randomFullyConnected

46 createRandom = randomFullyConnected

49

47

50instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o) where

48instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o) where

49+ type Tape (FullyConnected i o) ('D1 i) ('D1 o) = S ('D1 i)

51 -- Do a matrix vector multiplication and return the result.

50 -- Do a matrix vector multiplication and return the result.

52− runForwards (FullyConnected wB _ wN _) (S1D v) = S1D (wB + wN #> v)

51+ runForwards (FullyConnected (FullyConnected' wB wN) _) (S1D v) = (S1D v, S1D (wB + wN #> v))

53

52

54 -- Run a backpropogation step for a full connected layer.

53 -- Run a backpropogation step for a full connected layer.

55− runBackwards (FullyConnected _ _ wN _) (S1D x) (S1D dEdy) =

54+ runBackwards (FullyConnected (FullyConnected' _ wN) _) (S1D x) (S1D dEdy) =

56 let wB' = dEdy

55 let wB' = dEdy

57 mm' = dEdy `outer` x

56 mm' = dEdy `outer` x

58 -- calcluate derivatives for next step

57 -- calcluate derivatives for next step

@@ -60,7 +59,7 @@ instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o)

60 in (FullyConnected' wB' mm', S1D dWs)

59 in (FullyConnected' wB' mm', S1D dWs)

61

60

62instance (KnownNat i, KnownNat o) => Serialize (FullyConnected i o) where

61instance (KnownNat i, KnownNat o) => Serialize (FullyConnected i o) where

63− put (FullyConnected b _ w _) = do

62+ put (FullyConnected (FullyConnected' b w) _) = do

64 putListOf put . LA.toList . extract $ b

63 putListOf put . LA.toList . extract $ b

65 putListOf put . LA.toList . LA.flatten . extract $ w

64 putListOf put . LA.toList . LA.flatten . extract $ w

66

65

@@ -70,7 +69,7 @@ instance (KnownNat i, KnownNat o) => Serialize (FullyConnected i o) where

70 k <- maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

69 k <- maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

71 let bm = konst 0

70 let bm = konst 0

72 let mm = konst 0

71 let mm = konst 0

73− return $ FullyConnected b bm k mm

72+ return $ FullyConnected (FullyConnected' b k) (FullyConnected' bm mm)

74

73

75randomFullyConnected :: (MonadRandom m, KnownNat i, KnownNat o)

74randomFullyConnected :: (MonadRandom m, KnownNat i, KnownNat o)

76 => m (FullyConnected i o)

75 => m (FullyConnected i o)

@@ -81,4 +80,4 @@ randomFullyConnected = do

81 wN = uniformSample s2 (-1) 1

80 wN = uniformSample s2 (-1) 1

82 bm = konst 0

81 bm = konst 0

83 mm = konst 0

82 mm = konst 0

84− return $ FullyConnected wB bm wN mm

83+ return $ FullyConnected (FullyConnected' wB wN) (FullyConnected' bm mm)

src/Grenade/Layers/Fuse.hs+7−8

@@ -15,8 +15,6 @@ import Grenade.Core.Shape

15

16-- | Fuse two layers into one layer.

17-- This can be used to simplify a network if a complicated repeated structure is used.

18−-- This does however have a trade off, internal incremental states in the Wengert tape are

19−-- not retained during reverse accumulation. So less RAM is used, but more compute is required.

20data Fuse :: * -> * -> Shape -> Shape -> Shape -> * where

18data Fuse :: * -> * -> Shape -> Shape -> Shape -> * where

21 (:$$) :: (Layer x i h, Layer y h o)

19 (:$$) :: (Layer x i h, Layer y h o)

22 => !x

20 => !x

@@ -36,12 +34,13 @@ instance (Layer x i h, Layer y h o) => UpdateLayer (Fuse x y i h o) where

36 createRandom = (:$$) <$> createRandom <*> createRandom

34 createRandom = (:$$) <$> createRandom <*> createRandom

37

35

38instance (Layer x i h, Layer y h o) => Layer (Fuse x y i h o) i o where

36instance (Layer x i h, Layer y h o) => Layer (Fuse x y i h o) i o where

37+ type Tape (Fuse x y i h o) i o = (Tape x i h, Tape y h o)

39 runForwards (x :$$ y) input =

38 runForwards (x :$$ y) input =

40− let yInput :: S h = runForwards x input

39+ let (xTape, yInput :: S h) = runForwards x input

41− in runForwards y yInput

40+ (yTape, output :: S o) = runForwards y yInput

41+ in ((xTape, yTape), output)

42

43− runBackwards (x :$$ y) input backGradient =

43+ runBackwards (x :$$ y) (xTape, yTape) backGradient =

44− let yInput :: S h = runForwards x input

45− (y', yGrad) = runBackwards y yInput backGradient

44+ let (y', yGrad :: S h) = runBackwards y yTape backGradient

46− (x', xGrad) = runBackwards x input yGrad

45+ (x', xGrad) = runBackwards x xTape yGrad

47 in ((x', y'), xGrad)

46 in ((x', y'), xGrad)

src/Grenade/Layers/Logit.hs+6−3

@@ -26,15 +26,18 @@ instance UpdateLayer Logit where

26 createRandom = return Logit

27

28instance (KnownNat i) => Layer Logit ('D1 i) ('D1 i) where

29+ type Tape Logit ('D1 i) ('D1 i) = S ('D1 i)

29− runForwards _ (S1D y) = S1D (logistic y)

30+ runForwards _ (S1D y) = (S1D y, S1D (logistic y))

30 runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (logistic' y * dEdy))

31 runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (logistic' y * dEdy))

31

32

32instance (KnownNat i, KnownNat j) => Layer Logit ('D2 i j) ('D2 i j) where

33instance (KnownNat i, KnownNat j) => Layer Logit ('D2 i j) ('D2 i j) where

34+ type Tape Logit ('D2 i j) ('D2 i j) = S ('D2 i j)

33− runForwards _ (S2D y) = S2D (logistic y)

35+ runForwards _ (S2D y) = (S2D y, S2D (logistic y))

34 runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (logistic' y * dEdy))

36 runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (logistic' y * dEdy))

35

37

36instance (KnownNat i, KnownNat j, KnownNat k) => Layer Logit ('D3 i j k) ('D3 i j k) where

38instance (KnownNat i, KnownNat j, KnownNat k) => Layer Logit ('D3 i j k) ('D3 i j k) where

39+ type Tape Logit ('D3 i j k) ('D3 i j k) = S ('D3 i j k)

37− runForwards _ (S3D y) = S3D (logistic y)

40+ runForwards _ (S3D y) = (S3D y, S3D (logistic y))

38 runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (logistic' y * dEdy))

41 runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (logistic' y * dEdy))

39

42

40instance Serialize Logit where

43instance Serialize Logit where

src/Grenade/Layers/Pad.hs+2−1

@@ -51,6 +51,7 @@ instance ( KnownNat padLeft

51 , (inputRows + padTop + padBottom) ~ outputRows

52 , (inputColumns + padLeft + padRight) ~ outputColumns

53 ) => Layer (Pad padLeft padTop padRight padBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where

54+ type Tape (Pad padLeft padTop padRight padBottom) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = ()

54 runForwards Pad (S2D input) =

55 runForwards Pad (S2D input) =

55 let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)

56 let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)

56 padt = fromIntegral $ natVal (Proxy :: Proxy padTop)

57 padt = fromIntegral $ natVal (Proxy :: Proxy padTop)

@@ -58,7 +59,7 @@ instance ( KnownNat padLeft

58 padb = fromIntegral $ natVal (Proxy :: Proxy padBottom)

59 padb = fromIntegral $ natVal (Proxy :: Proxy padBottom)

59 m = extract input

60 m = extract input

60 r = diagBlock [konst 0 (padt,padl), m, konst 0 (padb,padr)]

61 r = diagBlock [konst 0 (padt,padl), m, konst 0 (padb,padr)]

61− in S2D . fromJust . create $ r

62+ in ((), S2D . fromJust . create $ r)

62 runBackwards Pad _ (S2D dEdy) =

63 runBackwards Pad _ (S2D dEdy) =

63 let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)

64 let padl = fromIntegral $ natVal (Proxy :: Proxy padLeft)

64 padt = fromIntegral $ natVal (Proxy :: Proxy padTop)

65 padt = fromIntegral $ natVal (Proxy :: Proxy padTop)

src/Grenade/Layers/Pooling.hs+4−2

@@ -56,6 +56,7 @@ instance ( KnownNat kernelRows

56 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)

57 , ((outputColumns - 1) * strideColumns) ~ (inputColumns - kernelColumns)

58 ) => Layer (Pooling kernelRows kernelColumns strideRows strideColumns) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where

59+ type Tape (Pooling kernelRows kernelColumns strideRows strideColumns) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) = S ('D2 inputRows inputColumns)

59 runForwards Pooling (S2D input) =

60 runForwards Pooling (S2D input) =

60 let height = fromIntegral $ natVal (Proxy :: Proxy inputRows)

61 let height = fromIntegral $ natVal (Proxy :: Proxy inputRows)

61 width = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

62 width = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

@@ -66,7 +67,7 @@ instance ( KnownNat kernelRows

66 ex = extract input

67 ex = extract input

67 r = poolForward 1 height width kx ky sx sy ex

68 r = poolForward 1 height width kx ky sx sy ex

68 rs = fromJust . create $ r

69 rs = fromJust . create $ r

69− in S2D $ rs

70+ in (S2D input, S2D rs)

70 runBackwards Pooling (S2D input) (S2D dEdy) =

71 runBackwards Pooling (S2D input) (S2D dEdy) =

71 let height = fromIntegral $ natVal (Proxy :: Proxy inputRows)

72 let height = fromIntegral $ natVal (Proxy :: Proxy inputRows)

72 width = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

73 width = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

@@ -94,6 +95,7 @@ instance ( KnownNat kernelRows

94 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)

95 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)

95 , ((outputColumns - 1) * strideColumns) ~ (inputColumns - kernelColumns)

96 , ((outputColumns - 1) * strideColumns) ~ (inputColumns - kernelColumns)

96 ) => Layer (Pooling kernelRows kernelColumns strideRows strideColumns) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where

97 ) => Layer (Pooling kernelRows kernelColumns strideRows strideColumns) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where

98+ type Tape (Pooling kernelRows kernelColumns strideRows strideColumns) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) = S ('D3 inputRows inputColumns channels)

97 runForwards Pooling (S3D input) =

99 runForwards Pooling (S3D input) =

98 let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

100 let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

99 iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

101 iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

@@ -105,7 +107,7 @@ instance ( KnownNat kernelRows

105 ex = extract input

107 ex = extract input

106 r = poolForward ch ix iy kx ky sx sy ex

108 r = poolForward ch ix iy kx ky sx sy ex

107 rs = fromJust . create $ r

109 rs = fromJust . create $ r

108− in S3D rs

110+ in (S3D input, S3D rs)

109 runBackwards Pooling (S3D input) (S3D dEdy) =

111 runBackwards Pooling (S3D input) (S3D dEdy) =

110 let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

112 let ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

111 iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

113 iy = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

src/Grenade/Layers/Relu.hs+10−3

@@ -30,7 +30,9 @@ instance Serialize Relu where

30 get = return Relu

31

32instance ( KnownNat i) => Layer Relu ('D1 i) ('D1 i) where

33+ type Tape Relu ('D1 i) ('D1 i) = S ('D1 i)

34+

33− runForwards _ (S1D y) = S1D (relu y)

35+ runForwards _ (S1D y) = (S1D y, S1D (relu y))

34 where

36 where

35 relu = LAS.dvmap (\a -> if a <= 0 then 0 else a)

37 relu = LAS.dvmap (\a -> if a <= 0 then 0 else a)

36 runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (relu' y * dEdy))

38 runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (relu' y * dEdy))

@@ -38,7 +40,9 @@ instance ( KnownNat i) => Layer Relu ('D1 i) ('D1 i) where

38 relu' = LAS.dvmap (\a -> if a <= 0 then 0 else 1)

40 relu' = LAS.dvmap (\a -> if a <= 0 then 0 else 1)

39

41

40instance (KnownNat i, KnownNat j) => Layer Relu ('D2 i j) ('D2 i j) where

42instance (KnownNat i, KnownNat j) => Layer Relu ('D2 i j) ('D2 i j) where

43+ type Tape Relu ('D2 i j) ('D2 i j) = S ('D2 i j)

44+

41− runForwards _ (S2D y) = S2D (relu y)

45+ runForwards _ (S2D y) = (S2D y, S2D (relu y))

42 where

46 where

43 relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)

47 relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)

44 runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (relu' y * dEdy))

48 runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (relu' y * dEdy))

@@ -46,7 +50,10 @@ instance (KnownNat i, KnownNat j) => Layer Relu ('D2 i j) ('D2 i j) where

46 relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)

50 relu' = LAS.dmmap (\a -> if a <= 0 then 0 else 1)

47

51

48instance (KnownNat i, KnownNat j, KnownNat k) => Layer Relu ('D3 i j k) ('D3 i j k) where

52instance (KnownNat i, KnownNat j, KnownNat k) => Layer Relu ('D3 i j k) ('D3 i j k) where

53+

54+ type Tape Relu ('D3 i j k) ('D3 i j k) = S ('D3 i j k)

55+

49− runForwards _ (S3D y) = S3D (relu y)

56+ runForwards _ (S3D y) = (S3D y, S3D (relu y))

50 where

57 where

51 relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)

58 relu = LAS.dmmap (\a -> if a <= 0 then 0 else a)

52 runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (relu' y * dEdy))

59 runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (relu' y * dEdy))

src/Grenade/Layers/Tanh.hs+6−12

@@ -1,14 +1,15 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

5module Grenade.Layers.Tanh (

6module Grenade.Layers.Tanh (

6 Tanh (..)

7 Tanh (..)

7 ) where

8 ) where

8

9

9import Data.Serialize

10import Data.Serialize

11+import Data.Singletons

10

12

11−import GHC.TypeLits

12import Grenade.Core.Network

13import Grenade.Core.Network

13import Grenade.Core.Shape

14import Grenade.Core.Shape

14

15

@@ -26,17 +27,10 @@ instance Serialize Tanh where

26 put _ = return ()

27 put _ = return ()

27 get = return Tanh

28 get = return Tanh

28

29

29−instance KnownNat i => Layer Tanh ('D1 i) ('D1 i) where

30+instance (a ~ b, SingI a, SingI b) => Layer Tanh a b where

30− runForwards _ (S1D y) = S1D (tanh y)

31+ type Tape Tanh a b = S a

31− runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (tanh' y * dEdy))

32−

33−instance (KnownNat i, KnownNat j) => Layer Tanh ('D2 i j) ('D2 i j) where

34− runForwards _ (S2D y) = S2D (tanh y)

35− runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (tanh' y * dEdy))

36−

37−instance (KnownNat i, KnownNat j, KnownNat k) => Layer Tanh ('D3 i j k) ('D3 i j k) where

38− runForwards _ (S3D y) = S3D (tanh y)

32+ runForwards _ a = (a, tanh a)

39− runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (tanh' y * dEdy))

33+ runBackwards _ a g = ((), tanh' a * g)

40

34

41tanh' :: (Floating a) => a -> a

35tanh' :: (Floating a) => a -> a

42tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

36tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

src/Grenade/Recurrent/Core/Runner.hs+11−7

@@ -48,11 +48,13 @@ trainRecurrent rate network recinputs examples =

48 -- Note we're doing training here, we could just return a list of gradients

49 -- (and probably will in future).

50 go !xs (layer :~~> n) (() :~~+> nIn)

51− = let ys = runForwards layer <$> xs

51+ = let tys = runForwards layer <$> xs

52+ tapes = fst <$> tys

53+ ys = snd <$> tys

52 -- recursively run the rest of the network, and get the gradients from above.

54 -- recursively run the rest of the network, and get the gradients from above.

53 (newFN, ig, grads) = go ys n nIn

55 (newFN, ig, grads) = go ys n nIn

54 -- calculate the gradient for this layer to pass down,

56 -- calculate the gradient for this layer to pass down,

55− back = uncurry (runBackwards layer) <$> zip (reverse xs) grads

57+ back = uncurry (runBackwards layer) <$> zip (reverse tapes) grads

56 -- the new trained layer.

58 -- the new trained layer.

57 newlayer = runUpdates rate layer (fst <$> back)

59 newlayer = runUpdates rate layer (fst <$> back)

58

60

@@ -75,11 +77,13 @@ trainRecurrent rate network recinputs examples =

75 -- Handle the output layer, bouncing the derivatives back down.

77 -- Handle the output layer, bouncing the derivatives back down.

76 -- We may not have a target for each example, so when we don't use 0 gradient.

78 -- We may not have a target for each example, so when we don't use 0 gradient.

77 go !xs (OR layer) (ORS ())

79 go !xs (OR layer) (ORS ())

78− = let ys = runForwards layer <$> xs

80+ = let tys = runForwards layer <$> xs

81+ tapes = fst <$> tys

82+ ys = snd <$> tys

79 -- recursively run the rest of the network, and get the gradients from above.

83 -- recursively run the rest of the network, and get the gradients from above.

80− back = uncurry (runBackwards layer) <$> zip xs (zipWith makeError ys targets)

84+ back = uncurry (runBackwards layer) <$> zip tapes (zipWith makeError ys targets)

81 -- the new trained layer.

85 -- the new trained layer.

82− newlayer = runUpdates rate layer (reverse $ fst <$> back)

86+ newlayer = runUpdates rate layer (reverse $ fst <$> back)

83 in (OR newlayer, ORS (), reverse (snd <$> back))

87 in (OR newlayer, ORS (), reverse (snd <$> back))

84

88

85 go _ _ _ =

89 go _ _ _ =

@@ -136,7 +140,7 @@ runRecurrent :: RecurrentNetwork layers shapes

136 -> RecurrentInputs layers -> S (Head shapes)

140 -> RecurrentInputs layers -> S (Head shapes)

137 -> (RecurrentInputs layers, S (Last shapes))

141 -> (RecurrentInputs layers, S (Last shapes))

138runRecurrent (layer :~~> n) (() :~~+> nr) !x

142runRecurrent (layer :~~> n) (() :~~+> nr) !x

139− = let ys = runForwards layer x

143+ = let (_, ys) = runForwards layer x

140 (nr', o) = runRecurrent n nr ys

144 (nr', o) = runRecurrent n nr ys

141 in (() :~~+> nr', o)

145 in (() :~~+> nr', o)

142runRecurrent (layer :~@> n) (recin :~@+> nr) !x

146runRecurrent (layer :~@> n) (recin :~@+> nr) !x

@@ -144,7 +148,7 @@ runRecurrent (layer :~@> n) (recin :~@+> nr) !x

144 (nr', o) = runRecurrent n nr y

148 (nr', o) = runRecurrent n nr y

145 in (recin' :~@+> nr', o)

149 in (recin' :~@+> nr', o)

146runRecurrent (OR layer) (ORS ()) !x

150runRecurrent (OR layer) (ORS ()) !x

147− = (ORS (), runForwards layer x)

151+ = (ORS (), snd $ runForwards layer x)

148

152

149runRecurrent _ _ _

153runRecurrent _ _ _

150 = error "Impossible for the gradients of a network to have a different length or shape to the network"

154 = error "Impossible for the gradients of a network to have a different length or shape to the network"

src/Grenade/Recurrent/Layers/Trivial.hs+2−1

@@ -25,5 +25,6 @@ instance UpdateLayer Trivial where

25 createRandom = return Trivial

26

27instance (a ~ b) => Layer Trivial a b where

28+ type Tape Trivial a b = ()

28− runForwards _ = id

29+ runForwards _ x = ((), x)

29 runBackwards _ _ y = ((), y)

30 runBackwards _ _ y = ((), y)