114dab4 · grenade · git.iko.soy

grenade.cabal+1

compare with master

unifiedsplit

@@ -14,6 +14,7 @@ library

14 build-depends:

15 base >= 4.8 && < 5

16 , bytestring == 0.10.*

17+ , async

17 , either == 4.4.*

18 , either == 4.4.*

18 , exceptions == 0.8.*

19 , exceptions == 0.8.*

19 , hmatrix

20 , hmatrix

main/feedforward.hs+11−7

@@ -35,14 +35,13 @@ randomNet = do

35 c :: FullyConnected 10 1 <- randomFullyConnected

36 return $ a :~> Tanh :~> b :~> Relu :~> c :~> O Logit

37

38−netTest :: MonadRandom m => Double -> Int -> m String

38+netTest :: MonadRandom m => LearningParameters -> Int -> m String

39netTest rate n = do

40 inps <- replicateM n $ do

41− s <- getRandom

41+ s <- getRandom

42 return $ S1D' $ SA.randomVector s SA.Uniform * 2 - 1

43 let outs = flip map inps $ \(S1D' v) ->

44− if v `inCircle` (fromRational 0.33, 0.33)

44+ if v `inCircle` (fromRational 0.33, 0.33) || v `inCircle` (fromRational (-0.33), 0.33)

45− || v `inCircle` (fromRational (-0.33), 0.33)

46 then S1D' $ fromRational 1

45 then S1D' $ fromRational 1

47 else S1D' $ fromRational 0

46 else S1D' $ fromRational 0

48 net0 <- randomNet

47 net0 <- randomNet

@@ -70,11 +69,16 @@ netTest rate n = do

70 normx (S1D' r) = SA.mean r

69 normx (S1D' r) = SA.mean r

71

70

72

71

73−data FeedForwardOpts = FeedForwardOpts Int Double

72+data FeedForwardOpts = FeedForwardOpts Int LearningParameters

74

73

75feedForward' :: Parser FeedForwardOpts

74feedForward' :: Parser FeedForwardOpts

75+feedForward' =

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

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

77+ <*> (LearningParameters

77− <*> option auto (long "train_rate" <> short 'r' <> value 0.01)

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

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

80+ <*> option auto (long "l2" <> value 0.0001)

81+ )

78

82

79main :: IO ()

83main :: IO ()

80main = do

84main = do

main/mnist.hs+10−6

@@ -43,7 +43,7 @@ randomMnistNet = do

43 f :: FullyConnected 80 10 <- randomFullyConnected

44 return $ pad :~> a :~> b :~> Relu :~> c :~> d :~> FlattenLayer :~> Relu :~> e :~> Logit :~> f :~> O Logit

45

46−convTest :: Int -> FilePath -> FilePath -> Double -> IO ()

46+convTest :: Int -> FilePath -> FilePath -> LearningParameters -> IO ()

47convTest iterations trainFile validateFile rate = do

48 net0 <- evalRandIO randomMnistNet

49 fT <- T.readFile trainFile

@@ -52,7 +52,7 @@ convTest iterations trainFile validateFile rate = do

52 let validateRows = traverse (A.parseOnly p) (T.lines fV)

53 case (trainRows, validateRows) of

54 (Right tr', Right vr') -> foldM_ (runIteration tr' vr') net0 [1..iterations]

55− err -> putStrLn $ show err

55+ err -> print err

56

57 where

58 trainEach !rate' !nt !(i, o) = train rate' i o nt

@@ -65,20 +65,24 @@ convTest iterations trainFile validateFile rate = do

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

66

67 runIteration trainRows validateRows net i = do

68− let trained' = runIdentity $ foldM (trainEach (rate * (0.9 ^ i))) net trainRows

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

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

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

71− putStrLn $ show trained'

71+ print trained'

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

73 return trained'

74

75−data MnistOpts = MnistOpts FilePath FilePath Int Double

75+data MnistOpts = MnistOpts FilePath FilePath Int LearningParameters

76

77mnist' :: Parser MnistOpts

78mnist' = MnistOpts <$> (argument str (metavar "TRAIN"))

79 <*> (argument str (metavar "VALIDATE"))

80 <*> option auto (long "iterations" <> short 'i' <> value 15)

81+ <*> (LearningParameters

81− <*> option auto (long "train_rate" <> short 'r' <> value 0.01)

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

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

84+ <*> option auto (long "l2" <> value 0.0001)

85+ )

82

86

83main :: IO ()

87main :: IO ()

84main = do

88main = do

src/Grenade.hs−13

@@ -1,16 +1,3 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE StandaloneDeriving #-}

7−{-# LANGUAGE TypeOperators #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE MultiParamTypeClasses #-}

11−{-# LANGUAGE FlexibleContexts #-}

12−{-# LANGUAGE FlexibleInstances #-}

13−

14module Grenade (

1module Grenade (

15 module X

2 module X

16 ) where

3 ) where

src/Grenade/Core/Network.hs+26−10

@@ -1,9 +1,7 @@

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE KindSignatures #-}

3{-# LANGUAGE KindSignatures #-}

5{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE StandaloneDeriving #-}

7{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

8{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE PolyKinds #-}

7{-# LANGUAGE PolyKinds #-}

@@ -14,31 +12,49 @@

14module Grenade.Core.Network (

12module Grenade.Core.Network (

15 Layer (..)

13 Layer (..)

16 , Network (..)

14 , Network (..)

15+ , UpdateLayer (..)

16+ , LearningParameters (..)

17 ) where

18

19+import Data.Typeable

19import Grenade.Core.Shape

20import Grenade.Core.Shape

20

21

22+data LearningParameters = LearningParameters {

23+ learningRate :: Double

24+ , learningMomentum :: Double

25+ , learningRegulariser :: Double

26+ } deriving (Eq, Show)

27+

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

29+-- shape independent.

30+class UpdateLayer (m :: * -> *) x where

31+ -- | The type for the gradient for this layer.

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

33+ type Gradient x :: *

34+ -- | Update a layer with its gradient and learning parameters

35+ runUpdate :: LearningParameters -> x -> Gradient x -> m x

36+

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

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

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

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

23−class Layer (m :: * -> *) x (i :: Shape) (o :: Shape) where

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

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

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

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

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

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

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

27− -- | Back propagate a step. Takes a learning rate (move from here?)

28− -- the current layer, the input that the layer gave from the input

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

29− -- and the back propagated derivatives from the layer above.

44+ -- layer gave from the input and the back propagated derivatives from

45+ -- the layer above.

30− -- Returns the updated layer and the derivatives to push back further.

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

31− runBackards :: Double -> x -> S' i -> S' o -> m (x, S' i)

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

32

48

33-- | Type of a network.

49-- | Type of a network.

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

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

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

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

36-- transform the data shapes of the network.

52-- transform the data shapes of the network.

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

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

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

54+ O :: (Typeable x, Show x, Layer m x i o, KnownShape o, KnownShape i)

39 => !x

55 => !x

40 -> Network m '[i, o]

56 -> Network m '[i, o]

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

57+ (:~>) :: (Typeable x, Show x, Layer m x i h, KnownShape h, KnownShape i)

42 => !x

58 => !x

43 -> !(Network m (h ': hs))

59 -> !(Network m (h ': hs))

44 -> Network m (i ': h ': hs)

60 -> Network m (i ': h ': hs)

src/Grenade/Core/Runner.hs+13−9

@@ -1,9 +1,7 @@

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE KindSignatures #-}

5{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE StandaloneDeriving #-}

7{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

8{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

9

7

@@ -18,7 +16,7 @@ import Grenade.Core.Shape

18

16

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

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

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

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

21− => Double -- ^ learning rate

19+ => LearningParameters -- ^ learning rate

22 -> S' i -- ^ input vector

20 -> S' i -- ^ input vector

23 -> S' o -- ^ target vector

21 -> S' o -- ^ target vector

24 -> Network m hs -- ^ network to train

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

@@ -35,20 +33,26 @@ train rate x0 target = fmap fst . go x0

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

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

36 (n', dWs') <- go y n

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

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

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

38− (layer', dWs) <- runBackards rate layer x dWs'

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

37+

38+ -- Update this layer using the gradient

39+ newLayer <- runUpdate rate layer layer'

40+

39− return (layer' :~> n', dWs)

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

40

42

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

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

42 go !x (O layer)

44 go !x (O layer)

43− = do y <- runForwards layer x

45+ = do y <- runForwards layer x

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

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

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

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

48+ newLayer <- runUpdate rate layer layer'

49+

46− return (O layer', dWs)

50+ return (O newLayer, dWs)

47

51

48-- | Just forwards propagation with no training.

52-- | Just forwards propagation with no training.

49runNet :: forall m hs. (Monad m)

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

50 => Network m hs

54 => Network m hs

51− -> (S' (Head hs)) -- ^ input vector

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

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

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

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

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

54 runNet n y

58 runNet n y

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

@@ -2,6 +2,7 @@

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GADTs #-}

6{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeFamilies #-}

@@ -65,6 +66,24 @@ data Convolution :: Nat -- ^ Number of channels, for the first layer this could

65 -> !(L kernelFlattened filters) -- ^ The last kernel update (or momentum)

66 -> !(L kernelFlattened filters) -- ^ The last kernel update (or momentum)

66 -> Convolution channels filters kernelRows kernelColumns strideRows strideColumns

67 -> Convolution channels filters kernelRows kernelColumns strideRows strideColumns

67

68

69+data Convolution' :: Nat -- ^ Number of channels, for the first layer this could be RGB for instance.

70+ -> Nat -- ^ Number of filters, this is the number of channels output by the layer.

71+ -> Nat -- ^ The number of rows in the kernel filter

72+ -> Nat -- ^ The number of column in the kernel filter

73+ -> Nat -- ^ The row stride of the convolution filter

74+ -> Nat -- ^ The columns stride of the convolution filter

75+ -> * where

76+ Convolution' :: ( KnownNat channels

77+ , KnownNat filters

78+ , KnownNat kernelRows

79+ , KnownNat kernelColumns

80+ , KnownNat strideRows

81+ , KnownNat strideColumns

82+ , KnownNat kernelFlattened

83+ , kernelFlattened ~ (kernelRows * kernelColumns * channels))

84+ => !(L kernelFlattened filters) -- ^ The kernel filter gradient

85+ -> Convolution' channels filters kernelRows kernelColumns strideRows strideColumns

86+

68instance Show (Convolution c f k k' s s') where

87instance Show (Convolution c f k k' s s') where

69 show (Convolution a _) = renderConv a

88 show (Convolution a _) = renderConv a

70 where

89 where

@@ -99,6 +118,22 @@ randomConvolution = do

99 mm = konst 0

118 mm = konst 0

100 return $ Convolution wN mm

119 return $ Convolution wN mm

101

120

121+instance ( Monad m

122+ , KnownNat kernelRows

123+ , KnownNat kernelCols

124+ , KnownNat channels

125+ , KnownNat filters

126+ , KnownNat strideRows

127+ , KnownNat strideCols

128+ , kernelFlattened ~ (kernelRows * kernelColumns * channels)

129+ ) => UpdateLayer m (Convolution channels filters kernelRows kernelCols strideRows strideCols) where

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

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

132+ let newMomentum = konst learningMomentum * oldMomentum - konst learningRate * kernelGradient

133+ regulariser = konst (learningRegulariser * learningRate) * oldKernel

134+ newKernel = oldKernel + newMomentum - regulariser

135+ return $ Convolution newKernel newMomentum

136+

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

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

103instance ( Monad m

138instance ( Monad m

104 , KnownNat kernelRows

139 , KnownNat kernelRows

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

127 r = col2vid 1 1 1 1 ox oy mt

162 r = col2vid 1 1 1 1 ox oy mt

128 rs = fmap (fromJust . create) r

163 rs = fmap (fromJust . create) r

129 in return . S3D' $ mkVector rs

164 in return . S3D' $ mkVector rs

130− runBackards rate (Convolution kernel momentum) (S2D' input) (S3D' dEdy) =

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

131 let ex = extract input

166 let ex = extract input

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

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

133 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

168 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

@@ -145,14 +180,10 @@ instance ( Monad m

145 vs = vid2col 1 1 1 1 ox oy eo

180 vs = vid2col 1 1 1 1 ox oy eo

146

181

147 kN = fromJust . create $ tr c LA.<> vs

182 kN = fromJust . create $ tr c LA.<> vs

148− mm = momentum * 0.9 - konst rate * kN

149− wd = konst (0.0001 * rate) * kernel

150− rM = kernel + mm - wd

151−

152 dW = vs LA.<> tr ek

183 dW = vs LA.<> tr ek

153

184

154 xW = col2im kx ky sx sy ix iy dW

185 xW = col2im kx ky sx sy ix iy dW

155− in return (Convolution rM mm, S2D' . fromJust . create $ xW)

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

156

187

157

188

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

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

@@ -187,7 +218,7 @@ instance ( Monad m

187 r = col2vid 1 1 1 1 ox oy mt

218 r = col2vid 1 1 1 1 ox oy mt

188 rs = fmap (fromJust . create) r

219 rs = fmap (fromJust . create) r

189 in return . S3D' $ mkVector rs

220 in return . S3D' $ mkVector rs

190− runBackards rate (Convolution kernel momentum) (S3D' input) (S3D' dEdy) =

221+ runBackards (Convolution kernel _) (S3D' input) (S3D' dEdy) =

191 let ex = vecToList $ fmap extract input

222 let ex = vecToList $ fmap extract input

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

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

193 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

224 iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

@@ -205,14 +236,11 @@ instance ( Monad m

205 vs = vid2col 1 1 1 1 ox oy eo

236 vs = vid2col 1 1 1 1 ox oy eo

206

237

207 kN = fromJust . create $ tr c LA.<> vs

238 kN = fromJust . create $ tr c LA.<> vs

208− mm = momentum * 0.9 - konst rate * kN

209− wd = konst (0.0005 * rate) * kernel

210− rM = kernel + mm - wd

211

239

212 dW = vs LA.<> tr ek

240 dW = vs LA.<> tr ek

213

241

214 xW = col2vid kx ky sx sy ix iy dW

242 xW = col2vid kx ky sx sy ix iy dW

215− in return (Convolution rM mm, S3D' . mkVector . fmap (fromJust . create) $ xW)

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

216

244

217im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

245im2col :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

218im2col nrows ncols srows scols m =

246im2col nrows ncols srows scols m =

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

@@ -1,7 +1,5 @@

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE StandaloneDeriving #-}

5{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

6{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

@@ -39,6 +37,10 @@ data Crop :: Nat

39instance Show (Crop cropLeft cropTop cropRight cropBottom) where

37instance Show (Crop cropLeft cropTop cropRight cropBottom) where

40 show Crop = "Crop"

38 show Crop = "Crop"

41

39

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

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

42+ runUpdate _ x _ = return x

43+

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

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

43instance ( Monad m

45instance ( Monad m

44 , KnownNat cropLeft

46 , KnownNat cropLeft

@@ -60,11 +62,11 @@ instance ( Monad m

60 m = extract input

62 m = extract input

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

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

62 in return . S2D' . fromJust . create $ r

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

63− runBackards _ crop _ (S2D' dEdy) =

65+ runBackards _ _ (S2D' dEdy) =

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

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

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

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

66 cropr = fromIntegral $ natVal (Proxy :: Proxy cropRight)

68 cropr = fromIntegral $ natVal (Proxy :: Proxy cropRight)

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

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

68 eo = extract dEdy

70 eo = extract dEdy

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

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

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

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

src/Grenade/Layers/Dropout.hs+7−7

@@ -1,7 +1,5 @@

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE StandaloneDeriving #-}

5{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

@@ -32,6 +30,10 @@ import Numeric.LinearAlgebra.Static

32data Dropout o = Dropout Double (R o)

30data Dropout o = Dropout Double (R o)

33 deriving Show

31 deriving Show

34

32

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

34+ type Gradient (Dropout i) = ()

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

36+

35randomDropout :: (MonadRandom m, KnownNat i)

37randomDropout :: (MonadRandom m, KnownNat i)

36 => Double -> m (Dropout i)

38 => Double -> m (Dropout i)

37randomDropout rate = do

39randomDropout rate = do

@@ -44,8 +46,6 @@ instance (MonadRandom m, MonadState Phase m, KnownNat i) => Layer m (Dropout i)

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

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

45 True -> return . S1D' $ x * drops

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

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

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

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

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

48− True -> do

49− newDropout <- randomDropout rate

50− return (newDropout, S1D' $ x * drops)

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

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

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

src/Grenade/Layers/Flatten.hs+8−4

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

25data FlattenLayer = FlattenLayer

26 deriving Show

27

28+instance Monad m => UpdateLayer m FlattenLayer where

29+ type Gradient FlattenLayer = ()

30+ runUpdate _ _ _ = return FlattenLayer

31+

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

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

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

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

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

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

31

35

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

41− return (FlattenLayer, S3D' ls')

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

42

46

43raiseShapeError :: Maybe a -> a

47raiseShapeError :: Maybe a -> a

44raiseShapeError (Just x) = x

48raiseShapeError (Just x) = x

src/Grenade/Layers/FullyConnected.hs+21−11

@@ -1,7 +1,6 @@

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE StandaloneDeriving #-}

3+{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

@@ -25,25 +24,36 @@ import Grenade.Core.Shape

25data FullyConnected i o = FullyConnected

24data FullyConnected i o = FullyConnected

26 !(R o) -- Bias neuron weights

25 !(R o) -- Bias neuron weights

27 !(L o i) -- Activation weights

26 !(L o i) -- Activation weights

27+ !(L o i) -- Momentum

28+

29+data FullyConnected' i o = FullyConnected'

30+ !(R o) -- Bias neuron gradient

28− !(L o i) -- Activation momentums

31+ !(L o i) -- Activation gradient

29

32

30instance Show (FullyConnected i o) where

33instance Show (FullyConnected i o) where

31− show (FullyConnected _ _ _) = "FullyConnected"

34+ show FullyConnected {} = "FullyConnected"

35+

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

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

38+

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

40+ let newBias = oldBias - konst learningRate * biasGradient

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

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

43+ newActivations = oldActivations + newMomentum - regulariser

44+ return $ FullyConnected newBias newActivations newMomentum

32

45

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

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

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

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

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

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

36

49

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

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

38− runBackards rate (FullyConnected wB wN mm) (S1D' x) (S1D' dEdy) =

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

39− let wB' = wB - konst rate * dEdy

52+ let wB' = dEdy

40− mm' = 0.9 * mm - konst rate * (dEdy `outer` x)

53+ mm' = dEdy `outer` x

41− wd' = konst (0.0001 * rate) * wN

42− wN' = wN + mm' - wd'

43− w' = FullyConnected wB' wN' mm'

44 -- calcluate derivatives for next step

54 -- calcluate derivatives for next step

45 dWs = tr wN #> dEdy

55 dWs = tr wN #> dEdy

46− in return (w', S1D' dWs)

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

47

57

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

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

49 => m (FullyConnected i o)

59 => m (FullyConnected i o)

src/Grenade/Layers/Fuse.hs+15−9

@@ -3,7 +3,6 @@

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE KindSignatures #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE StandaloneDeriving #-}

7{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeOperators #-}

8{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

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

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

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

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

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

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

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

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

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

27 (:$$) :: (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 m x i h, Layer m y h o, KnownShape h, KnownShape i, KnownShape o)

28 => !x

27 => !x

29 -> !y

28 -> !y

30− -> Fuse m i h o

29+ -> Fuse m x y i h o

31infixr 5 :$$

30infixr 5 :$$

32

31

33−instance Show (Fuse m i h o) where

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

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

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

35

34

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

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

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

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

38+ newX <- runUpdate lr x x'

39+ newY <- runUpdate lr y y'

40+ return (newX :$$ newY)

41+

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

37 runForwards (x :$$ y) input = do

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

38 yInput :: S' h <- runForwards x input

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

39 runForwards y yInput

45 runForwards y yInput

40

46

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

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

42 yInput :: S' h <- runForwards x input

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

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

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

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

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

45− return (x' :$$ y', xGrad)

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

src/Grenade/Layers/Logit.hs+8−5

@@ -1,7 +1,5 @@

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE StandaloneDeriving #-}

5{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

@@ -11,6 +9,7 @@ module Grenade.Layers.Logit (

11 Logit (..)

9 Logit (..)

12 ) where

10 ) where

13

11

12+

14import Data.Singletons.TypeLits

13import Data.Singletons.TypeLits

15import Grenade.Core.Network

14import Grenade.Core.Network

16import Grenade.Core.Vector

15import Grenade.Core.Vector

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

23data Logit = Logit

22data Logit = Logit

24 deriving Show

23 deriving Show

25

24

25+instance Monad m => UpdateLayer m Logit where

26+ type Gradient Logit = ()

27+ runUpdate _ _ _ = return Logit

28+

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

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

27 runForwards _ (S1D' y) = return $ S1D' (logistic y)

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

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

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

29

32

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

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

31 runForwards _ (S2D' y) = return $ S2D' (logistic y)

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

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

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

33

36

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

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

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

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

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

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

37

40

38

41

39logistic :: Floating a => a -> a

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

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

@@ -1,7 +1,5 @@

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE StandaloneDeriving #-}

5{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

6{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

@@ -39,6 +37,10 @@ data Pad :: Nat

39instance Show (Pad padLeft padTop padRight padBottom) where

37instance Show (Pad padLeft padTop padRight padBottom) where

40 show Pad = "Pad"

38 show Pad = "Pad"

41

39

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

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

42+ runUpdate _ x _ = return x

43+

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

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

43instance ( Monad m

45instance ( Monad m

44 , KnownNat padLeft

46 , KnownNat padLeft

@@ -60,11 +62,11 @@ instance ( Monad m

60 m = extract input

62 m = extract input

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

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

62 in return . S2D' . fromJust . create $ r

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

63− runBackards _ pad _ (S2D' dEdy) =

65+ runBackards Pad _ (S2D' dEdy) =

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

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

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

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

66 nrows = fromIntegral $ natVal (Proxy :: Proxy inputRows)

68 nrows = fromIntegral $ natVal (Proxy :: Proxy inputRows)

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

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

68 m = extract dEdy

70 m = extract dEdy

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

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

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

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

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

@@ -51,6 +51,10 @@ 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

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

56+ runUpdate _ Pooling _ = return Pooling

57+

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

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

55instance ( Monad m

59instance ( Monad m

56 , KnownNat kernelRows

60 , KnownNat kernelRows

@@ -75,7 +79,7 @@ instance ( Monad m

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

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

76 rs = fromJust . create $ r

80 rs = fromJust . create $ r

77 in return . S2D' $ rs

81 in return . S2D' $ rs

78− runBackards _ Pooling (S2D' input) (S2D' dEdy) =

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

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

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

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

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

81 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

85 sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

@@ -83,7 +87,7 @@ instance ( Monad m

83 ex = extract input

87 ex = extract input

84 eo = extract dEdy

88 eo = extract dEdy

85 vs = poolBackward kx ky sx sy ex eo

89 vs = poolBackward kx ky sx sy ex eo

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

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

87

91

88

92

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

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

@@ -112,7 +116,7 @@ instance ( Monad m

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

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

113 rs = fmap (fromJust . create) r

117 rs = fmap (fromJust . create) r

114 in return . S3D' $ rs

118 in return . S3D' $ rs

115− runBackards _ Pooling (S3D' input) (S3D' dEdy) =

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

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

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

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

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

118 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

122 kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

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

123 eo = fmap extract dEdy

127 eo = fmap extract dEdy

124 ez = vectorZip (,) ex eo

128 ez = vectorZip (,) ex eo

125 vs = poolBackwardList kx ky sx sy ix iy ez

129 vs = poolBackwardList kx ky sx sy ix iy ez

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

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

127

131

128poolForward :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

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

129poolForward nrows ncols srows scols outputRows outputCols m =

133poolForward nrows ncols srows scols outputRows outputCols m =

src/Grenade/Layers/Relu.hs+7−5

@@ -1,7 +1,5 @@

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE StandaloneDeriving #-}

5{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

@@ -24,11 +22,15 @@ import qualified Numeric.LinearAlgebra.Static as LAS

24data Relu = Relu

22data Relu = Relu

25 deriving Show

23 deriving Show

26

24

25+instance Monad m => UpdateLayer m Relu where

26+ type Gradient Relu = ()

27+ runUpdate _ _ _ = return Relu

28+

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

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

28 runForwards _ (S1D' y) = return $ S1D' (relu y)

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

29 where

31 where

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

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

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

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

32 where

34 where

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

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

34

36

@@ -36,7 +38,7 @@ instance (Monad m, KnownNat i, KnownNat j) => Layer m Relu ('D2 i j) ('D2 i j) w

36 runForwards _ (S2D' y) = return $ S2D' (relu y)

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

37 where

39 where

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

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

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

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

40 where

42 where

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

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

42

44

@@ -44,6 +46,6 @@ instance (Monad m, KnownNat i, KnownNat j, KnownNat k) => Layer m Relu ('D3 i j

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

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

45 where

47 where

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

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

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

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

48 where

50 where

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

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

src/Grenade/Layers/Tanh.hs+7−5

@@ -1,7 +1,5 @@

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE StandaloneDeriving #-}

5{-# LANGUAGE TypeOperators #-}

3{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeFamilies #-}

4{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

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

21data Tanh = Tanh

19data Tanh = Tanh

22 deriving Show

20 deriving Show

23

21

22+instance Monad m => UpdateLayer m Tanh where

23+ type Gradient Tanh = ()

24+ runUpdate _ _ _ = return Tanh

25+

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

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

25 runForwards _ (S1D' y) = return $ S1D' (tanh y)

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

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

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

27

29

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

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

29 runForwards _ (S2D' y) = return $ S2D' (tanh y)

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

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

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

31

33

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

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

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

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

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

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

35

37

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

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

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

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