ca4b0fe · grenade · git.iko.soy

main/feedforward.hs+7−10

compare with master

unifiedsplit

@@ -1,6 +1,5 @@

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE KindSignatures #-}

4{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TupleSections #-}

5{-# LANGUAGE TupleSections #-}

@@ -8,7 +7,6 @@

8{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

9

8

10import Control.Monad

9import Control.Monad

11−import Control.Monad.Identity

12import Control.Monad.Random

10import Control.Monad.Random

13

11

14import GHC.TypeLits

12import GHC.TypeLits

@@ -28,7 +26,7 @@ import Grenade

28-- between the shapes, so inference can't do it all for us.

26-- between the shapes, so inference can't do it all for us.

29

27

30-- With around 100000 examples, this should show two clear circles which have been learned by the network.

28-- With around 100000 examples, this should show two clear circles which have been learned by the network.

31−randomNet :: (MonadRandom m) => m (Network Identity '[('D1 2), ('D1 40), ('D1 40), ('D1 10), ('D1 10), ('D1 1), ('D1 1)])

29+randomNet :: (MonadRandom m) => m (Network '[('D1 2), ('D1 40), ('D1 40), ('D1 10), ('D1 10), ('D1 1), ('D1 1)])

32randomNet = do

30randomNet = do

33 a :: FullyConnected 2 40 <- randomFullyConnected

31 a :: FullyConnected 2 40 <- randomFullyConnected

34 b :: FullyConnected 40 10 <- randomFullyConnected

32 b :: FullyConnected 40 10 <- randomFullyConnected

@@ -46,13 +44,12 @@ netTest rate n = do

46 else S1D' $ fromRational 0

44 else S1D' $ fromRational 0

47 net0 <- randomNet

45 net0 <- randomNet

48

46

49− return . runIdentity $ do

50− trained <- foldM trainEach net0 (zip inps outs)

47+ let trained = foldl trainEach net0 (zip inps outs)

51− let testIns = [ [ (x,y) | x <- [0..50] ]

48+ let testIns = [ [ (x,y) | x <- [0..50] ]

52− | y <- [0..20] ]

49+ | y <- [0..20] ]

53

50

54− outMat <- traverse (traverse (\(x,y) -> (render . normx) <$> runNet trained (S1D' $ SA.vector [x / 25 - 1,y / 10 - 1]))) testIns

51+ let outMat = fmap (fmap (\(x,y) -> (render . normx) $ runNet trained (S1D' $ SA.vector [x / 25 - 1,y / 10 - 1]))) testIns

55− return $ unlines outMat

52+ return $ unlines outMat

56

53

57 where

54 where

58 inCircle :: KnownNat n => SA.R n -> (SA.R n, Double) -> Bool

55 inCircle :: KnownNat n => SA.R n -> (SA.R n, Double) -> Bool

@@ -73,7 +70,7 @@ data FeedForwardOpts = FeedForwardOpts Int LearningParameters

73

70

74feedForward' :: Parser FeedForwardOpts

71feedForward' :: Parser FeedForwardOpts

75feedForward' =

72feedForward' =

76− FeedForwardOpts <$> option auto (long "examples" <> short 'e' <> value 1000000)

73+ FeedForwardOpts <$> option auto (long "examples" <> short 'e' <> value 100000)

77 <*> (LearningParameters

74 <*> (LearningParameters

78 <$> option auto (long "train_rate" <> short 'r' <> value 0.01)

75 <$> option auto (long "train_rate" <> short 'r' <> value 0.01)

79 <*> option auto (long "momentum" <> value 0.9)

76 <*> option auto (long "momentum" <> value 0.9)

main/mnist.hs+3−5

@@ -1,6 +1,5 @@

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE KindSignatures #-}

4{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TupleSections #-}

5{-# LANGUAGE TupleSections #-}

@@ -9,7 +8,6 @@

9

8

10import Control.Applicative

9import Control.Applicative

11import Control.Monad

10import Control.Monad

12−import Control.Monad.Identity

13import Control.Monad.Random

11import Control.Monad.Random

14

12

15import qualified Data.Attoparsec.Text as A

13import qualified Data.Attoparsec.Text as A

@@ -32,7 +30,7 @@ import Grenade

32

30

33-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,

31-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,

34-- this network should get down to about a 1.3% error rate.

32-- this network should get down to about a 1.3% error rate.

35−randomMnistNet :: (MonadRandom m) => m (Network Identity '[('D2 28 28), ('D2 32 32), ('D3 28 28 10), ('D3 14 14 10), ('D3 14 14 10), ('D3 10 10 16), ('D3 5 5 16), ('D1 400), ('D1 400), ('D1 80), ('D1 80), ('D1 10), ('D1 10)])

33+randomMnistNet :: (MonadRandom m) => m (Network '[('D2 28 28), ('D2 32 32), ('D3 28 28 10), ('D3 14 14 10), ('D3 14 14 10), ('D3 10 10 16), ('D3 5 5 16), ('D1 400), ('D1 400), ('D1 80), ('D1 80), ('D1 10), ('D1 10)])

36randomMnistNet = do

34randomMnistNet = do

37 let pad :: Pad 2 2 2 2 = Pad

35 let pad :: Pad 2 2 2 2 = Pad

38 a :: Convolution 1 10 5 5 1 1 <- randomConvolution

36 a :: Convolution 1 10 5 5 1 1 <- randomConvolution

@@ -65,8 +63,8 @@ convTest iterations trainFile validateFile rate = do

65 return (S2D' $ SA.fromList pixels, S1D' $ SA.fromList lab')

63 return (S2D' $ SA.fromList pixels, S1D' $ SA.fromList lab')

66

64

67 runIteration trainRows validateRows net i = do

65 runIteration trainRows validateRows net i = do

68− let trained' = runIdentity $ foldM (trainEach rate) net trainRows

66+ let trained' = foldl (trainEach rate) net trainRows

69− let res = runIdentity $ traverse (\(rowP,rowL) -> (rowL,) <$> runNet trained' rowP) validateRows

67+ let res = fmap (\(rowP,rowL) -> (rowL,) $ runNet trained' rowP) validateRows

70 let res' = fmap (\(S1D' label, S1D' prediction) -> (maxIndex (SA.extract label), maxIndex (SA.extract prediction))) res

68 let res' = fmap (\(S1D' label, S1D' prediction) -> (maxIndex (SA.extract label), maxIndex (SA.extract prediction))) res

71 print trained'

69 print trained'

72 putStrLn $ "Iteration " ++ show i ++ ": " ++ show (length (filter ((==) <$> fst <*> snd) res')) ++ " of " ++ show (length res')

70 putStrLn $ "Iteration " ++ show i ++ ": " ++ show (length (filter ((==) <$> fst <*> snd) res')) ++ " of " ++ show (length res')

src/Grenade/Core/Network.hs+12−12

@@ -26,39 +26,39 @@ data LearningParameters = LearningParameters {

26

27-- | Class for updating a layer. All layers implement this, and it is

28-- shape independent.

29−class UpdateLayer (m :: * -> *) x where

29+class UpdateLayer x where

30 -- | The type for the gradient for this layer.

31 -- Unit if there isn't a gradient to pass back.

32 type Gradient x :: *

33 -- | Update a layer with its gradient and learning parameters

34− runUpdate :: LearningParameters -> x -> Gradient x -> m x

34+ runUpdate :: LearningParameters -> x -> Gradient x -> x

35

36-- | Class for a layer. All layers implement this, however, they don't

37-- need to implement it for all shapes, only ones which are appropriate.

38−class UpdateLayer m x => Layer (m :: * -> *) x (i :: Shape) (o :: Shape) where

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

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

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

41− runForwards :: x -> S' i -> m (S' o)

41+ runForwards :: x -> S' i -> S' o

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

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

44 -- the layer above.

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

46− runBackards :: x -> S' i -> S' o -> m (Gradient x, S' i)

46+ runBackards :: x -> S' i -> S' o -> (Gradient x, S' i)

47

48-- | Type of a network.

49-- The [Shape] type specifies the shapes of data passed between the layers.

50-- Could be considered to be a heterogeneous list of layers which are able to

51-- transform the data shapes of the network.

52−data Network :: (* -> *) -> [Shape] -> * where

52+data Network :: [Shape] -> * where

53− O :: (Show x, Layer m x i o, KnownShape o, KnownShape i)

53+ O :: (Show x, Layer x i o, KnownShape o, KnownShape i)

54 => !x

55− -> Network m '[i, o]

55+ -> Network '[i, o]

56− (:~>) :: (Show x, Layer m x i h, KnownShape h, KnownShape i)

56+ (:~>) :: (Show x, Layer x i h, KnownShape h, KnownShape i)

57 => !x

58− -> !(Network m (h ': hs))

58+ -> !(Network (h ': hs))

59− -> Network m (i ': h ': hs)

59+ -> Network (i ': h ': hs)

60infixr 5 :~>

61

62−instance Show (Network m h) where

62+instance Show (Network h) where

63 show (O a) = "O " ++ show a

64 show (i :~> o) = show i ++ "\n:~>\n" ++ show o

src/Grenade/Core/Runner.hs+21−22

@@ -15,45 +15,44 @@ import Grenade.Core.Network

15import Grenade.Core.Shape

16

17-- | Update a network with new weights after training with an instance.

18−train :: forall m i o hs. (Monad m, Head hs ~ i, Last hs ~ o, KnownShape i, KnownShape o)

18+train :: forall i o hs. (Head hs ~ i, Last hs ~ o, KnownShape i, KnownShape o)

19 => LearningParameters -- ^ learning rate

20 -> S' i -- ^ input vector

21 -> S' o -- ^ target vector

22− -> Network m hs -- ^ network to train

22+ -> Network hs -- ^ network to train

23− -> m (Network m hs)

23+ -> Network hs

24−train rate x0 target = fmap fst . go x0

24+train rate x0 target = fst . go x0

25 where

26− go :: forall m' j js. (Monad m', Head js ~ j, Last js ~ o, KnownShape j)

26+ go :: forall j js. (Head js ~ j, Last js ~ o, KnownShape j)

27 => S' j -- ^ input vector

28− -> Network m' js -- ^ network to train

28+ -> Network js -- ^ network to train

29− -> m' (Network m' js, S' j)

29+ -> (Network js, S' j)

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

31 go !x (layer :~> n)

32− = do y <- runForwards layer x

32+ = let y = runForwards layer x

33 -- run the rest of the network, and get the layer from above.

34− (n', dWs') <- go y n

34+ (n', dWs') = go y n

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

36− (layer', dWs) <- runBackards layer x dWs'

36+ (layer', dWs) = runBackards layer x dWs'

37

38− -- Update this layer using the gradient

38+ -- Update this layer using the gradient

39− newLayer <- runUpdate rate layer layer'

39+ newLayer = runUpdate rate layer layer'

40

41− return (newLayer :~> n', dWs)

41+ in (newLayer :~> n', dWs)

42

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

44 go !x (O layer)

45− = do y <- runForwards layer x

45+ = let y = runForwards layer x

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

47− (layer', dWs) <- runBackards layer x (y - target)

47+ (layer', dWs) = runBackards layer x (y - target)

48− newLayer <- runUpdate rate layer layer'

48+ newLayer = runUpdate rate layer layer'

49

50− return (O newLayer, dWs)

50+ in (O newLayer, dWs)

51

52-- | Just forwards propagation with no training.

53−runNet :: forall m hs. (Monad m)

54− => Network m hs

53+runNet :: Network hs

55 -> S' (Head hs) -- ^ input vector

54 -> S' (Head hs) -- ^ input vector

56− -> m (S' (Last hs)) -- ^ target vector

55+ -> S' (Last hs) -- ^ target vector

57−runNet (layer :~> n) !x = do y <- runForwards layer x

56+runNet (layer :~> n) !x = let y = runForwards layer x

58− runNet n y

57+ in runNet n y

59runNet (O layer) !x = runForwards layer x

58runNet (O layer) !x = runForwards layer x

src/Grenade/Layers/Convolution.hs+11−13

@@ -119,17 +119,16 @@ randomConvolution = do

119 mm = konst 0

120 return $ Convolution wN mm

121

122−instance ( Monad m ) => UpdateLayer m (Convolution channels filters kernelRows kernelCols strideRows strideCols) where

122+instance UpdateLayer (Convolution channels filters kernelRows kernelCols strideRows strideCols) where

123 type Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols) = (Convolution' channels filters kernelRows kernelCols strideRows strideCols)

124− runUpdate LearningParameters {..} (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) = do

124+ runUpdate LearningParameters {..} (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =

125 let newMomentum = konst learningMomentum * oldMomentum - konst learningRate * kernelGradient

126 regulariser = konst (learningRegulariser * learningRate) * oldKernel

127 newKernel = oldKernel + newMomentum - regulariser

128− return $ Convolution newKernel newMomentum

128+ in Convolution newKernel newMomentum

129

130-- | A two dimentional image may have a convolution filter applied to it

131−instance ( Monad m

132− , KnownNat kernelRows

131+instance ( KnownNat kernelRows

133 , KnownNat kernelCols

132 , KnownNat kernelCols

134 , KnownNat filters

133 , KnownNat filters

135 , KnownNat strideRows

134 , KnownNat strideRows

@@ -140,7 +139,7 @@ instance ( Monad m

140 , KnownNat outputCols

139 , KnownNat outputCols

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

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

142 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)

141 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)

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

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

144 runForwards (Convolution kernel _) (S2D' input) =

143 runForwards (Convolution kernel _) (S2D' input) =

145 let ex = extract input

144 let ex = extract input

146 ek = extract kernel

145 ek = extract kernel

@@ -154,7 +153,7 @@ instance ( Monad m

154 mt = c LA.<> ek

153 mt = c LA.<> ek

155 r = col2vid 1 1 1 1 ox oy mt

154 r = col2vid 1 1 1 1 ox oy mt

156 rs = fmap (fromJust . create) r

155 rs = fmap (fromJust . create) r

157− in return . S3D' $ mkVector rs

156+ in S3D' $ mkVector rs

158 runBackards (Convolution kernel _) (S2D' input) (S3D' dEdy) =

157 runBackards (Convolution kernel _) (S2D' input) (S3D' dEdy) =

159 let ex = extract input

158 let ex = extract input

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

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

@@ -176,13 +175,12 @@ instance ( Monad m

176 dW = vs LA.<> tr ek

175 dW = vs LA.<> tr ek

177

176

178 xW = col2im kx ky sx sy ix iy dW

177 xW = col2im kx ky sx sy ix iy dW

179− in return (Convolution' kN, S2D' . fromJust . create $ xW)

178+ in (Convolution' kN, S2D' . fromJust . create $ xW)

180

179

181

180

182-- | A three dimensional image (or 2d with many channels) can have

181-- | A three dimensional image (or 2d with many channels) can have

183-- an appropriately sized convolution filter run across it.

182-- an appropriately sized convolution filter run across it.

184−instance ( Monad m

185− , KnownNat kernelRows

183+instance ( KnownNat kernelRows

186 , KnownNat kernelCols

184 , KnownNat kernelCols

187 , KnownNat filters

185 , KnownNat filters

188 , KnownNat strideRows

186 , KnownNat strideRows

@@ -194,7 +192,7 @@ instance ( Monad m

194 , KnownNat channels

192 , KnownNat channels

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

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

196 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)

194 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)

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

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

198 runForwards (Convolution kernel _) (S3D' input) =

196 runForwards (Convolution kernel _) (S3D' input) =

199 let ex = vecToList $ fmap extract input

197 let ex = vecToList $ fmap extract input

200 ek = extract kernel

198 ek = extract kernel

@@ -210,7 +208,7 @@ instance ( Monad m

210 mt = c LA.<> ek

208 mt = c LA.<> ek

211 r = col2vid 1 1 1 1 ox oy mt

209 r = col2vid 1 1 1 1 ox oy mt

212 rs = fmap (fromJust . create) r

210 rs = fmap (fromJust . create) r

213− in return . S3D' $ mkVector rs

211+ in S3D' $ mkVector rs

214 runBackards (Convolution kernel _) (S3D' input) (S3D' dEdy) =

212 runBackards (Convolution kernel _) (S3D' input) (S3D' dEdy) =

215 let ex = vecToList $ fmap extract input

213 let ex = vecToList $ fmap extract input

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

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

@@ -233,7 +231,7 @@ instance ( Monad m

233 dW = vs LA.<> tr ek

231 dW = vs LA.<> tr ek

234

232

235 xW = col2vid kx ky sx sy ix iy dW

233 xW = col2vid kx ky sx sy ix iy dW

236− in return (Convolution' kN, S3D' . mkVector . fmap (fromJust . create) $ xW)

234+ in (Convolution' kN, S3D' . mkVector . fmap (fromJust . create) $ xW)

237

235

238im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

236im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

239im2col nrows ncols srows scols m =

237im2col nrows ncols srows scols m =

src/Grenade/Layers/Crop.hs+6−7

@@ -37,13 +37,12 @@ data Crop :: Nat

37instance Show (Crop cropLeft cropTop cropRight cropBottom) where

38 show Crop = "Crop"

39

40−instance Monad m => UpdateLayer m (Crop l t r b) where

40+instance UpdateLayer (Crop l t r b) where

41 type Gradient (Crop l t r b) = ()

42− runUpdate _ x _ = return x

42+ runUpdate _ x _ = x

43

44-- | A two dimentional image can be cropped.

45−instance ( Monad m

46− , KnownNat cropLeft

45+instance ( KnownNat cropLeft

47 , KnownNat cropTop

46 , KnownNat cropTop

48 , KnownNat cropRight

47 , KnownNat cropRight

49 , KnownNat cropBottom

48 , KnownNat cropBottom

@@ -53,7 +52,7 @@ instance ( Monad m

53 , KnownNat outputColumns

52 , KnownNat outputColumns

54 , (inputRows - cropTop - cropBottom) ~ outputRows

53 , (inputRows - cropTop - cropBottom) ~ outputRows

55 , (inputColumns - cropLeft - cropRight) ~ outputColumns

54 , (inputColumns - cropLeft - cropRight) ~ outputColumns

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

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

57 runForwards Crop (S2D' input) =

56 runForwards Crop (S2D' input) =

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

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

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

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

@@ -61,7 +60,7 @@ instance ( Monad m

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

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

62 m = extract input

61 m = extract input

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

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

64− in return . S2D' . fromJust . create $ r

63+ in S2D' . fromJust . create $ r

65 runBackards _ _ (S2D' dEdy) =

64 runBackards _ _ (S2D' dEdy) =

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

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

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

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

@@ -69,4 +68,4 @@ instance ( Monad m

69 cropb = fromIntegral $ natVal (Proxy :: Proxy cropBottom)

68 cropb = fromIntegral $ natVal (Proxy :: Proxy cropBottom)

70 eo = extract dEdy

69 eo = extract dEdy

71 vs = diagBlock [konst 0 (cropt,cropl), eo, konst 0 (cropb,cropr)]

70 vs = diagBlock [konst 0 (cropt,cropl), eo, konst 0 (cropb,cropr)]

72− in return ((), S2D' . fromJust . create $ vs)

71+ in ((), S2D' . fromJust . create $ vs)

src/Grenade/Layers/Dropout.hs+13−14

@@ -9,15 +9,14 @@

9

10module Grenade.Layers.Dropout (

11 Dropout (..)

12+ , randomDropout

12 ) where

13 ) where

13

14

14import Control.Monad.Random hiding (fromList)

15import Control.Monad.Random hiding (fromList)

15−import Control.Monad.State

16

17import GHC.TypeLits

18import Grenade.Core.Shape

19import Grenade.Core.Network

20−import Grenade.Core.Phase

21

20

22import Numeric.LinearAlgebra.Static

21import Numeric.LinearAlgebra.Static

23

22

@@ -27,12 +26,14 @@ import Numeric.LinearAlgebra.Static

27-- After backpropogation, we return a new matrix/vector, with different bits dropped out.

26-- After backpropogation, we return a new matrix/vector, with different bits dropped out.

28-- Double is the proportion to drop in each training iteration (like 1% or 5% would be

27-- Double is the proportion to drop in each training iteration (like 1% or 5% would be

29-- reasonable).

28-- reasonable).

30−data Dropout o = Dropout Double (R o)

29+data Dropout o =

30+ Dropout (R o)

31+ | Pass Double

31 deriving Show

32 deriving Show

32

33

33−instance (MonadRandom m, KnownNat i) => UpdateLayer m (Dropout i) where

34+instance (KnownNat i) => UpdateLayer (Dropout i) where

34 type Gradient (Dropout i) = ()

35 type Gradient (Dropout i) = ()

35− runUpdate _ (Dropout rate _) _ = randomDropout rate

36+ runUpdate _ x _ = x

36

37

37randomDropout :: (MonadRandom m, KnownNat i)

38randomDropout :: (MonadRandom m, KnownNat i)

38 => Double -> m (Dropout i)

39 => Double -> m (Dropout i)

@@ -40,12 +41,10 @@ randomDropout rate = do

40 seed <- getRandom

41 seed <- getRandom

41 let wN = randomVector seed Uniform

42 let wN = randomVector seed Uniform

42 xs = dvmap (\a -> if a <= rate then 0 else 1) wN

43 xs = dvmap (\a -> if a <= rate then 0 else 1) wN

43− return $ Dropout rate xs

44+ return $ Dropout xs

44−

45+

45−instance (MonadRandom m, MonadState Phase m, KnownNat i) => Layer m (Dropout i) ('D1 i) ('D1 i) where

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

46− runForwards (Dropout rate drops) (S1D' x) = isTrainingPhase >>= \case

47+ runForwards (Dropout drops) (S1D' x) = S1D' $ x * drops

47− True -> return . S1D' $ x * drops

48− False -> return . S1D' $ dvmap (* (1 - rate)) x

48+ runForwards (Pass rate) (S1D' x)= S1D' $ dvmap (* (1 - rate)) x

49− runBackards (Dropout rate drops) _ (S1D' x) = isTrainingPhase >>= \case

49+ runBackards (Dropout drops) _ (S1D' x) = ((), S1D' $ x * drops)

50− True -> return ((), S1D' $ x * drops)

51− False -> return ((), S1D' $ dvmap (* (1 - rate)) x)

50+ runBackards (Pass rate) _ (S1D' x) = ((), S1D' $ dvmap (* (1 - rate)) x)

src/Grenade/Layers/Flatten.hs+9−9

@@ -25,24 +25,24 @@ import Grenade.Core.Network

25data FlattenLayer = FlattenLayer

26 deriving Show

27

28−instance Monad m => UpdateLayer m FlattenLayer where

28+instance UpdateLayer FlattenLayer where

29 type Gradient FlattenLayer = ()

30− runUpdate _ _ _ = return FlattenLayer

30+ runUpdate _ _ _ = FlattenLayer

31

32−instance (Monad m, KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer m FlattenLayer ('D2 x y) ('D1 a) where

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

33− runForwards _ (S2D' y) = return $ S1D' . fromList . toList . flatten . extract $ y

33+ runForwards _ (S2D' y) = S1D' . fromList . toList . flatten . extract $ y

34− runBackards _ _ (S1D' y) = return ((), S2D' . fromList . toList . unwrap $ y)

34+ runBackards _ _ (S1D' y) = ((), S2D' . fromList . toList . unwrap $ y)

35

36−instance (Monad m, KnownNat a, KnownNat x, KnownNat y, KnownNat z, a ~ (x * y * z)) => Layer m FlattenLayer ('D3 x y z) ('D1 a) where

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

37− runForwards _ (S3D' y) = return $ S1D' . raiseShapeError . create . vjoin . vecToList . fmap (flatten . extract) $ y

37+ runForwards _ (S3D' y) = S1D' . raiseShapeError . create . vjoin . vecToList . fmap (flatten . extract) $ y

38− runBackards _ _ (S1D' o) = do

38+ runBackards _ _ (S1D' o) =

39 let x' = fromIntegral $ natVal (Proxy :: Proxy x)

40 y' = fromIntegral $ natVal (Proxy :: Proxy y)

41 z' = fromIntegral $ natVal (Proxy :: Proxy z)

42 vecs = takesV (replicate z' (x' * y')) (extract o)

43 ls = fmap (raiseShapeError . create . reshape y') vecs

44 ls' = mkVector ls :: Vector z (L x y)

45− return ((), S3D' ls')

45+ in ((), S3D' ls')

46

47raiseShapeError :: Maybe a -> a

48raiseShapeError (Just x) = x

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

@@ -23,6 +23,7 @@ import Grenade.Core.Shape

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

24data FullyConnected i o = FullyConnected

25 !(R o) -- Bias neuron weights

26+ !(R o) -- Bias neuron momentum

26 !(L o i) -- Activation weights

27 !(L o i) -- Activation weights

27 !(L o i) -- Momentum

28 !(L o i) -- Momentum

28

29

@@ -33,27 +34,28 @@ data FullyConnected' i o = FullyConnected'

33instance Show (FullyConnected i o) where

34instance Show (FullyConnected i o) where

34 show FullyConnected {} = "FullyConnected"

35 show FullyConnected {} = "FullyConnected"

35

36

36−instance (Monad m, KnownNat i, KnownNat o) => UpdateLayer m (FullyConnected i o) where

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

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

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

38

39

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

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

40− let newBias = oldBias - konst learningRate * biasGradient

41+ let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient

42+ newBias = oldBias + newBiasMomentum

41− newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient

43+ newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient

42− regulariser = konst (learningRegulariser * learningRate) * oldActivations

44+ regulariser = konst (learningRegulariser * learningRate) * oldActivations

43− newActivations = oldActivations + newMomentum - regulariser

45+ newActivations = oldActivations + newMomentum - regulariser

44− return $ FullyConnected newBias newActivations newMomentum

46+ in FullyConnected newBias newBiasMomentum newActivations newMomentum

45

47

46−instance (Monad m, KnownNat i, KnownNat o) => Layer m (FullyConnected i o) ('D1 i) ('D1 o) where

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

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

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

48− runForwards (FullyConnected wB wN _) (S1D' v) = return $ S1D' (wB + wN #> v)

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

49

51

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

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

51− runBackards (FullyConnected _ wN _) (S1D' x) (S1D' dEdy) =

53+ runBackards (FullyConnected _ _ wN _) (S1D' x) (S1D' dEdy) =

52 let wB' = dEdy

54 let wB' = dEdy

53 mm' = dEdy `outer` x

55 mm' = dEdy `outer` x

54 -- calcluate derivatives for next step

56 -- calcluate derivatives for next step

55 dWs = tr wN #> dEdy

57 dWs = tr wN #> dEdy

56− in return (FullyConnected' wB' mm', S1D' dWs)

58+ in (FullyConnected' wB' mm', S1D' dWs)

57

59

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

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

59 => m (FullyConnected i o)

61 => m (FullyConnected i o)

@@ -62,5 +64,6 @@ randomFullyConnected = do

62 s2 :: Int <- getRandom

64 s2 :: Int <- getRandom

63 let wB = randomVector s1 Uniform * 2 - 1

65 let wB = randomVector s1 Uniform * 2 - 1

64 wN = uniformSample s2 (-1) 1

66 wN = uniformSample s2 (-1) 1

67+ bm = konst 0

65 mm = konst 0

68 mm = konst 0

66− return $ FullyConnected wB wN mm

69+ return $ FullyConnected wB bm wN mm

src/Grenade/Layers/Fuse.hs+21−21

@@ -22,30 +22,30 @@ import Grenade.Core.Shape

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

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

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

25−data Fuse :: (* -> *) -> * -> * -> Shape -> Shape -> Shape -> * where

25+data Fuse :: * -> * -> Shape -> Shape -> Shape -> * where

26− (:$$) :: (Show x, Show y, Layer m x i h, Layer m y h o, KnownShape h, KnownShape i, KnownShape o)

26+ (:$$) :: (Show x, Show y, Layer x i h, Layer y h o, KnownShape h, KnownShape i, KnownShape o)

27 => !x

28 -> !y

29− -> Fuse m x y i h o

29+ -> Fuse x y i h o

30infixr 5 :$$

31

32−instance Show (Fuse m x y i h o) where

32+instance Show (Fuse x y i h o) where

33 show (x :$$ y) = "(" ++ show x ++ " :$$ " ++ show y ++ ")"

34

35−instance (Monad m, KnownShape i, KnownShape h, KnownShape o) => UpdateLayer m (Fuse m x y i h o) where

35+instance (KnownShape i, KnownShape h, KnownShape o) => UpdateLayer (Fuse x y i h o) where

36− type Gradient (Fuse m x y i h o) = (Gradient x, Gradient y)

36+ type Gradient (Fuse x y i h o) = (Gradient x, Gradient y)

37− runUpdate lr (x :$$ y) (x', y') = do

37+ runUpdate lr (x :$$ y) (x', y') =

38− newX <- runUpdate lr x x'

38+ let newX = runUpdate lr x x'

39− newY <- runUpdate lr y y'

39+ newY = runUpdate lr y y'

40− return (newX :$$ newY)

40+ in (newX :$$ newY)

41−

41+

42−instance (Monad m, KnownShape i, KnownShape h, KnownShape o) => Layer m (Fuse m x y i h o) i o where

42+instance (KnownShape i, KnownShape h, KnownShape o) => Layer (Fuse x y i h o) i o where

43− runForwards (x :$$ y) input = do

43+ runForwards (x :$$ y) input =

44− yInput :: S' h <- runForwards x input

44+ let yInput :: S' h = runForwards x input

45− runForwards y yInput

45+ in runForwards y yInput

46−

46+

47− runBackards (x :$$ y) input backGradient = do

47+ runBackards (x :$$ y) input backGradient =

48− yInput :: S' h <- runForwards x input

48+ let yInput :: S' h = runForwards x input

49− (y', yGrad) <- runBackards y yInput backGradient

49+ (y', yGrad) = runBackards y yInput backGradient

50− (x', xGrad) <- runBackards x input yGrad

50+ (x', xGrad) = runBackards x input yGrad

51− return ((x', y'), xGrad)

51+ in ((x', y'), xGrad)

src/Grenade/Layers/Logit.hs+11−11

@@ -22,21 +22,21 @@ import Grenade.Core.Shape

22data Logit = Logit

23 deriving Show

24

25−instance Monad m => UpdateLayer m Logit where

25+instance UpdateLayer Logit where

26 type Gradient Logit = ()

27− runUpdate _ _ _ = return Logit

27+ runUpdate _ _ _ = Logit

28

29−instance (Monad m, KnownNat i) => Layer m Logit ('D1 i) ('D1 i) where

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

30− runForwards _ (S1D' y) = return $ S1D' (logistic y)

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

31− runBackards _ (S1D' y) (S1D' dEdy) = return ((), S1D' (logistic' y * dEdy))

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

32

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

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

34− runForwards _ (S2D' y) = return $ S2D' (logistic y)

34+ runForwards _ (S2D' y) = S2D' (logistic y)

35− runBackards _ (S2D' y) (S2D' dEdy) = return ((), S2D' (logistic' y * dEdy))

35+ runBackards _ (S2D' y) (S2D' dEdy) = ((), S2D' (logistic' y * dEdy))

36

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

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

38− runForwards _ (S3D' y) = return $ S3D' (fmap logistic y)

38+ runForwards _ (S3D' y) = S3D' (fmap logistic y)

39− runBackards _ (S3D' y) (S3D' dEdy) = return ((), S3D' (vectorZip (\y' dEdy' -> logistic' y' * dEdy') y dEdy))

39+ runBackards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> logistic' y' * dEdy') y dEdy))

40

41

42logistic :: Floating a => a -> a

src/Grenade/Layers/Pad.hs+6−7

@@ -37,13 +37,12 @@ data Pad :: Nat

37instance Show (Pad padLeft padTop padRight padBottom) where

38 show Pad = "Pad"

39

40−instance Monad m => UpdateLayer m (Pad l t r b) where

40+instance UpdateLayer (Pad l t r b) where

41 type Gradient (Pad l t r b) = ()

42− runUpdate _ x _ = return x

42+ runUpdate _ x _ = x

43

44-- | A two dimentional image can be padped.

45−instance ( Monad m

46− , KnownNat padLeft

45+instance ( KnownNat padLeft

47 , KnownNat padTop

46 , KnownNat padTop

48 , KnownNat padRight

47 , KnownNat padRight

49 , KnownNat padBottom

48 , KnownNat padBottom

@@ -53,7 +52,7 @@ instance ( Monad m

53 , KnownNat outputColumns

52 , KnownNat outputColumns

54 , (inputRows + padTop + padBottom) ~ outputRows

53 , (inputRows + padTop + padBottom) ~ outputRows

55 , (inputColumns + padLeft + padRight) ~ outputColumns

54 , (inputColumns + padLeft + padRight) ~ outputColumns

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

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

57 runForwards Pad (S2D' input) =

56 runForwards Pad (S2D' input) =

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

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

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

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

@@ -61,7 +60,7 @@ instance ( Monad m

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

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

62 m = extract input

61 m = extract input

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

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

64− in return . S2D' . fromJust . create $ r

63+ in S2D' . fromJust . create $ r

65 runBackards Pad _ (S2D' dEdy) =

64 runBackards Pad _ (S2D' dEdy) =

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

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

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

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

@@ -69,4 +68,4 @@ instance ( Monad m

69 ncols = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

68 ncols = fromIntegral $ natVal (Proxy :: Proxy inputColumns)

70 m = extract dEdy

69 m = extract dEdy

71 vs = subMatrix (padt, padl) (nrows, ncols) m

70 vs = subMatrix (padt, padl) (nrows, ncols) m

72− in return ((), S2D' . fromJust . create $ vs)

71+ in ((), S2D' . fromJust . create $ vs)

src/Grenade/Layers/Pooling.hs+10−12

@@ -51,13 +51,12 @@ instance Show (Pooling k k' s s') where

51 show Pooling = "Pooling"

52

53

54−instance Monad m => UpdateLayer m (Pooling kernelRows kernelColumns strideRows strideColumns) where

54+instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where

55 type Gradient (Pooling kr kc sr sc) = ()

56− runUpdate _ Pooling _ = return Pooling

56+ runUpdate _ Pooling _ = Pooling

57

58-- | A two dimentional image can be pooled.

59−instance ( Monad m

60− , KnownNat kernelRows

59+instance ( KnownNat kernelRows

61 , KnownNat kernelColumns

60 , KnownNat kernelColumns

62 , KnownNat strideRows

61 , KnownNat strideRows

63 , KnownNat strideColumns

62 , KnownNat strideColumns

@@ -67,7 +66,7 @@ instance ( Monad m

67 , KnownNat outputColumns

66 , KnownNat outputColumns

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

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

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

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

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

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

71 runForwards Pooling (S2D' input) =

70 runForwards Pooling (S2D' input) =

72 let kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

71 let kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

73 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)

72 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)

@@ -78,7 +77,7 @@ instance ( Monad m

78 ex = extract input

77 ex = extract input

79 r = poolForward kx ky sx sy ox oy $ ex

78 r = poolForward kx ky sx sy ox oy $ ex

80 rs = fromJust . create $ r

79 rs = fromJust . create $ r

81− in return . S2D' $ rs

80+ in S2D' $ rs

82 runBackards Pooling (S2D' input) (S2D' dEdy) =

81 runBackards Pooling (S2D' input) (S2D' dEdy) =

83 let kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

82 let kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

84 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)

83 ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)

@@ -87,12 +86,11 @@ instance ( Monad m

87 ex = extract input

86 ex = extract input

88 eo = extract dEdy

87 eo = extract dEdy

89 vs = poolBackward kx ky sx sy ex eo

88 vs = poolBackward kx ky sx sy ex eo

90− in return ((), S2D' . fromJust . create $ vs)

89+ in ((), S2D' . fromJust . create $ vs)

91

90

92

91

93-- | A three dimensional image can be pooled on each layer.

92-- | A three dimensional image can be pooled on each layer.

94−instance ( Monad m

95− , KnownNat kernelRows

93+instance ( KnownNat kernelRows

96 , KnownNat kernelColumns

94 , KnownNat kernelColumns

97 , KnownNat strideRows

95 , KnownNat strideRows

98 , KnownNat strideColumns

96 , KnownNat strideColumns

@@ -102,7 +100,7 @@ instance ( Monad m

102 , KnownNat outputColumns

100 , KnownNat outputColumns

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

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

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

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

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

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

106 runForwards Pooling (S3D' input) =

104 runForwards Pooling (S3D' input) =

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

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

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

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

@@ -115,7 +113,7 @@ instance ( Monad m

115 ex = fmap extract input

113 ex = fmap extract input

116 r = poolForwardList kx ky sx sy ix iy ox oy ex

114 r = poolForwardList kx ky sx sy ix iy ox oy ex

117 rs = fmap (fromJust . create) r

115 rs = fmap (fromJust . create) r

118− in return . S3D' $ rs

116+ in S3D' rs

119 runBackards Pooling (S3D' input) (S3D' dEdy) =

117 runBackards Pooling (S3D' input) (S3D' dEdy) =

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

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

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

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

@@ -127,7 +125,7 @@ instance ( Monad m

127 eo = fmap extract dEdy

125 eo = fmap extract dEdy

128 ez = vectorZip (,) ex eo

126 ez = vectorZip (,) ex eo

129 vs = poolBackwardList kx ky sx sy ix iy ez

127 vs = poolBackwardList kx ky sx sy ix iy ez

130− in return ((), S3D' . fmap (fromJust . create) $ vs)

128+ in ((), S3D' . fmap (fromJust . create) $ vs)

131

129

132poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

130poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

133poolForward nrows ncols srows scols outputRows outputCols m =

131poolForward nrows ncols srows scols outputRows outputCols m =

src/Grenade/Layers/Relu.hs+11−11

@@ -22,30 +22,30 @@ import qualified Numeric.LinearAlgebra.Static as LAS

22data Relu = Relu

23 deriving Show

24

25−instance Monad m => UpdateLayer m Relu where

25+instance UpdateLayer Relu where

26 type Gradient Relu = ()

27− runUpdate _ _ _ = return Relu

27+ runUpdate _ _ _ = Relu

28

29−instance (Monad m, KnownNat i) => Layer m Relu ('D1 i) ('D1 i) where

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

30− runForwards _ (S1D' y) = return $ S1D' (relu y)

30+ runForwards _ (S1D' y) = S1D' (relu y)

31 where

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

33− runBackards _ (S1D' y) (S1D' dEdy) = return ((), S1D' (relu' y * dEdy))

33+ runBackards _ (S1D' y) (S1D' dEdy) = ((), S1D' (relu' y * dEdy))

34 where

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

36

37−instance (Monad m, KnownNat i, KnownNat j) => Layer m Relu ('D2 i j) ('D2 i j) where

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

38− runForwards _ (S2D' y) = return $ S2D' (relu y)

38+ runForwards _ (S2D' y) = S2D' (relu y)

39 where

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

41− runBackards _ (S2D' y) (S2D' dEdy) = return ((), S2D' (relu' y * dEdy))

41+ runBackards _ (S2D' y) (S2D' dEdy) = ((), S2D' (relu' y * dEdy))

42 where

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

44

45−instance (Monad m, KnownNat i, KnownNat j, KnownNat k) => Layer m Relu ('D3 i j k) ('D3 i j k) where

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

46− runForwards _ (S3D' y) = return $ S3D' (fmap relu y)

46+ runForwards _ (S3D' y) = S3D' (fmap relu y)

47 where

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

49− runBackards _ (S3D' y) (S3D' dEdy) = return ((), S3D' (vectorZip (\y' dEdy' -> relu' y' * dEdy') y dEdy))

49+ runBackards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> relu' y' * dEdy') y dEdy))

50 where

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

src/Grenade/Layers/Tanh.hs+11−11

@@ -19,21 +19,21 @@ import Grenade.Core.Shape

19data Tanh = Tanh

20 deriving Show

21

22−instance Monad m => UpdateLayer m Tanh where

22+instance UpdateLayer Tanh where

23 type Gradient Tanh = ()

24− runUpdate _ _ _ = return Tanh

24+ runUpdate _ _ _ = Tanh

25

26−instance (Monad m, KnownNat i) => Layer m Tanh ('D1 i) ('D1 i) where

26+instance KnownNat i => Layer Tanh ('D1 i) ('D1 i) where

27− runForwards _ (S1D' y) = return $ S1D' (tanh y)

27+ runForwards _ (S1D' y) = S1D' (tanh y)

28− runBackards _ (S1D' y) (S1D' dEdy) = return ((), S1D' (tanh' y * dEdy))

28+ runBackards _ (S1D' y) (S1D' dEdy) = ((), S1D' (tanh' y * dEdy))

29

30−instance (Monad m, KnownNat i, KnownNat j) => Layer m Tanh ('D2 i j) ('D2 i j) where

30+instance (KnownNat i, KnownNat j) => Layer Tanh ('D2 i j) ('D2 i j) where

31− runForwards _ (S2D' y) = return $ S2D' (tanh y)

31+ runForwards _ (S2D' y) = S2D' (tanh y)

32− runBackards _ (S2D' y) (S2D' dEdy) = return ((), S2D' (tanh' y * dEdy))

32+ runBackards _ (S2D' y) (S2D' dEdy) = ((), S2D' (tanh' y * dEdy))

33

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

34+instance (KnownNat i, KnownNat j, KnownNat k) => Layer Tanh ('D3 i j k) ('D3 i j k) where

35− runForwards _ (S3D' y) = return $ S3D' (fmap tanh y)

35+ runForwards _ (S3D' y) = S3D' (fmap tanh y)

36− runBackards _ (S3D' y) (S3D' dEdy) = return ((), S3D' (vectorZip (\y' dEdy' -> tanh' y' * dEdy') y dEdy))

36+ runBackards _ (S3D' y) (S3D' dEdy) = ((), S3D' (vectorZip (\y' dEdy' -> tanh' y' * dEdy') y dEdy))

37

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

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

test/Test/Grenade/Layers/Convolution.hs+4−6

@@ -4,8 +4,6 @@

4{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

5module Test.Grenade.Layers.Convolution where

6

7−import Control.Monad.Identity

8−

9import Grenade.Core.Shape

7import Grenade.Core.Shape

10import Grenade.Core.Vector as Grenade

8import Grenade.Core.Vector as Grenade

11import Grenade.Core.Network

9import Grenade.Core.Network

@@ -114,7 +112,7 @@ prop_simple_conv_forwards = once $

114 [ 5.0 , 9.0 ] :: HStatic.L 1 2)

112 [ 5.0 , 9.0 ] :: HStatic.L 1 2)

115 ,(HStatic.matrix

113 ,(HStatic.matrix

116 [ -7.0 , -10.0 ] :: HStatic.L 1 2)]) :: [HStatic.L 1 2]

114 [ -7.0 , -10.0 ] :: HStatic.L 1 2)]) :: [HStatic.L 1 2]

117− out = runIdentity $ runForwards convLayer input :: S' ('D3 1 2 4)

115+ out = runForwards convLayer input :: S' ('D3 1 2 4)

118

116

119 grad = S3D' ( mkVector

117 grad = S3D' ( mkVector

120 [(HStatic.matrix

118 [(HStatic.matrix

@@ -129,7 +127,7 @@ prop_simple_conv_forwards = once $

129 expectBack = (HStatic.matrix

127 expectBack = (HStatic.matrix

130 [ 1.0, 0.0, 0.0

128 [ 1.0, 0.0, 0.0

131 , 0.0, -2.0,-1.0] :: HStatic.L 2 3)

129 , 0.0, -2.0,-1.0] :: HStatic.L 2 3)

132− (nc, inX) = runIdentity $ runBackards convLayer input grad

130+ (nc, inX) = runBackards convLayer input grad

133

131

134 in case (out, inX, nc) of

132 in case (out, inX, nc) of

135 (S3D' out' , S2D' inX', Convolution' backGrad)

133 (S3D' out' , S2D' inX', Convolution' backGrad)

@@ -226,7 +224,7 @@ prop_single_conv_forwards = once $

226 [ 5.0 , 9.0 ] :: HStatic.L 1 2)

224 [ 5.0 , 9.0 ] :: HStatic.L 1 2)

227 ,(HStatic.matrix

225 ,(HStatic.matrix

228 [ -7.0 , -10.0 ] :: HStatic.L 1 2)]) :: [HStatic.L 1 2]

226 [ -7.0 , -10.0 ] :: HStatic.L 1 2)]) :: [HStatic.L 1 2]

229− out = runIdentity $ runForwards convLayer input :: S' ('D3 1 2 4)

227+ out = runForwards convLayer input :: S' ('D3 1 2 4)

230

228

231 grad = S3D' ( mkVector

229 grad = S3D' ( mkVector

232 [(HStatic.matrix

230 [(HStatic.matrix

@@ -241,7 +239,7 @@ prop_single_conv_forwards = once $

241 expectBack = (HStatic.matrix

239 expectBack = (HStatic.matrix

242 [ 1.0, 0.0, 0.0

240 [ 1.0, 0.0, 0.0

243 , 0.0, -2.0,-1.0] :: HStatic.L 2 3)

241 , 0.0, -2.0,-1.0] :: HStatic.L 2 3)

244− (nc, inX) = runIdentity $ runBackards convLayer input grad

242+ (nc, inX) = runBackards convLayer input grad

245

243

246 in case (out, inX, nc) of

244 in case (out, inX, nc) of

247 (S3D' out' , S3D' inX', Convolution' backGrad)

245 (S3D' out' , S3D' inX', Convolution' backGrad)