70fbac3 · grenade · git.iko.soy

.gitmodules+1−1

compare with master

unifiedsplit

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

6 url = https://github.com/ambiata/x.git

7[submodule "lib/p"]

8 path = lib/p

9− url = https://github.com/ambiata/p.git

9+ url = https://github.com/ambiata/p

10[submodule "lib/disorder.hs"]

11 path = lib/disorder.hs

12 url = https://github.com/ambiata/disorder.hs.git

README.md+2−2

@@ -13,10 +13,10 @@ Five is right out.

13Grenade is a dependently typed, practical, and pretty quick neural network library for concise and precise

14specifications of complex networks in Haskell.

15

16−As an example, a network which can achieve less than 1.5% error on mnist can be specified and

16+As an example, a network which can achieve less than 1.5% error on MNIST can be specified and

17initialised with random weights in under 10 lines of code with

18```haskell

19−randomMnistNet :: MonadRandom m => m (Network Identity '[('D2 28 28), ('D3 24 24 10), ('D3 12 12 10), ('D3 12 12 10), ('D3 8 8 16), ('D3 4 4 16), ('D1 256), ('D1 256), ('D1 80), ('D1 80), ('D1 10), ('D1 10)])

19+randomMnistNet :: MonadRandom m => m (Network '[ 'D2 28 28, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10, 'D3 8 8 16, 'D3 4 4 16, 'D1 256, 'D1 256, 'D1 80, 'D1 80, 'D1 10, 'D1 10])

20randomMnistNet = do

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

22 let b :: Pooling 2 2 2 2 = Pooling

grenade.cabal+1

@@ -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

lib/pnew file+1

Submodule changed.

main/feedforward.hs+17−16

@@ -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,32 +26,30 @@ 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

35 c :: FullyConnected 10 1 <- randomFullyConnected

33 c :: FullyConnected 10 1 <- randomFullyConnected

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

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

37

35

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

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

39netTest rate n = do

37netTest rate n = do

40 inps <- replicateM n $ do

38 inps <- replicateM n $ do

41− s <- getRandom

39+ s <- getRandom

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

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

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

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

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

42+ 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

43 then S1D' $ fromRational 1

47 else S1D' $ fromRational 0

44 else S1D' $ fromRational 0

48 net0 <- randomNet

45 net0 <- randomNet

49

46

50− return . runIdentity $ do

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

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

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

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

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

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

54

50

55− 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

56− return $ unlines outMat

52+ return $ unlines outMat

57

53

58 where

54 where

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

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

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

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

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

71

67

72

68

73−data FeedForwardOpts = FeedForwardOpts Int Double

69+data FeedForwardOpts = FeedForwardOpts Int LearningParameters

74

70

75feedForward' :: Parser FeedForwardOpts

71feedForward' :: Parser FeedForwardOpts

72+feedForward' =

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

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

74+ <*> (LearningParameters

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

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

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

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

78+ )

78

79

79main :: IO ()

80main :: IO ()

80main = do

81main = do

main/mnist.hs+16−15

@@ -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,18 +30,17 @@ 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, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10, 'D3 8 8 16, 'D3 4 4 16, 'D1 256, 'D1 256, 'D1 80, 'D1 80, 'D1 10, 'D1 10])

36randomMnistNet = do

34randomMnistNet = do

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

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

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

39 let b :: Pooling 2 2 2 2 = Pooling

36 let b :: Pooling 2 2 2 2 = Pooling

40 c :: Convolution 10 16 5 5 1 1 <- randomConvolution

37 c :: Convolution 10 16 5 5 1 1 <- randomConvolution

41 let d :: Pooling 2 2 2 2 = Pooling

38 let d :: Pooling 2 2 2 2 = Pooling

42− e :: FullyConnected 400 80 <- randomFullyConnected

39+ e :: FullyConnected 256 80 <- randomFullyConnected

43 f :: FullyConnected 80 10 <- randomFullyConnected

40 f :: FullyConnected 80 10 <- randomFullyConnected

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

41+ return $ a :~> b :~> Relu :~> c :~> d :~> FlattenLayer :~> Relu :~> e :~> Logit :~> f :~> O Logit

45

42

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

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

47convTest iterations trainFile validateFile rate = do

44convTest iterations trainFile validateFile rate = do

48 net0 <- evalRandIO randomMnistNet

45 net0 <- evalRandIO randomMnistNet

49 fT <- T.readFile trainFile

46 fT <- T.readFile trainFile

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

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

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

53 case (trainRows, validateRows) of

50 case (trainRows, validateRows) of

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

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

55− err -> putStrLn $ show err

52+ err -> print err

56

53

57 where

54 where

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

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

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

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

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

66

63

67 runIteration trainRows validateRows net i = do

64 runIteration trainRows validateRows net i = do

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

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

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

66+ 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

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

71− putStrLn $ show trained'

68+ print trained'

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

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

73 return trained'

70 return trained'

74

71

75−data MnistOpts = MnistOpts FilePath FilePath Int Double

72+data MnistOpts = MnistOpts FilePath FilePath Int LearningParameters

76

73

77mnist' :: Parser MnistOpts

74mnist' :: Parser MnistOpts

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

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

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

76+ <*> argument str (metavar "VALIDATE")

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

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

78+ <*> (LearningParameters

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

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

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

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

82+ )

82

83

83main :: IO ()

84main :: IO ()

84main = do

85main = 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+31−16

@@ -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,36 +12,53 @@

14module Grenade.Core.Network (

12module Grenade.Core.Network (

15 Layer (..)

13 Layer (..)

16 , Network (..)

14 , Network (..)

15+ , UpdateLayer (..)

16+ , LearningParameters (..)

17 ) where

18

19import Grenade.Core.Shape

20

21+data LearningParameters = LearningParameters {

22+ learningRate :: Double

23+ , learningMomentum :: Double

24+ , learningRegulariser :: Double

25+ } deriving (Eq, Show)

26+

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

28+-- shape independent.

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 -> x

35+

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

36-- | 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.

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

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

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

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

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

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

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

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

41+ runForwards :: x -> S' i -> 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

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

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

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

44+ -- the layer above.

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

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

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

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

32

47

33-- | Type of a network.

48-- | Type of a network.

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

49-- 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

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

36-- transform the data shapes of the network.

51-- transform the data shapes of the network.

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

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

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

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

39 => !x

54 => !x

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

55+ -> Network '[i, o]

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

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

42 => !x

57 => !x

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

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

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

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

45infixr 5 :~>

60infixr 5 :~>

46

61

47−instance Show (Network m h) where

62+instance Show (Network h) where

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

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

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

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

src/Grenade/Core/Runner.hs+26−23

@@ -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

@@ -17,39 +15,44 @@ import Grenade.Core.Network

17import Grenade.Core.Shape

15import 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.

20−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)

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 hs -- ^ network to train

25− -> m (Network m hs)

23+ -> Network hs

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

24+train rate x0 target = fst . go x0

27 where

25 where

28− 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)

29 => S' j -- ^ input vector

27 => S' j -- ^ input vector

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

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

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

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

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

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

33 go !x (layer :~> n)

31 go !x (layer :~> n)

34− = do y <- runForwards layer x

32+ = let y = runForwards layer x

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'

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

37+

38+ -- Update this layer using the gradient

39+ newLayer = runUpdate rate layer layer'

40+

41+ in (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+ = let 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)

46− return (O layer', dWs)

48+ newLayer = runUpdate rate layer layer'

49+

50+ in (O newLayer, dWs)

47

51

48-- | Just forwards propagation with no training.

52-- | Just forwards propagation with no training.

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

50− => Network m hs

53+runNet :: Network hs

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

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

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

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

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

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

54− runNet n y

57+ in runNet n y

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

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

src/Grenade/Core/Shape.hs+3−3

@@ -39,17 +39,17 @@ data Shape =

39instance KnownShape x => Num (S' x) where

40 (+) (S1D' x) (S1D' y) = S1D' (x + y)

41 (+) (S2D' x) (S2D' y) = S2D' (x + y)

42− (+) (S3D' x) (S3D' y) = S3D' (vectorZip (\x' y' -> x' + y') x y)

42+ (+) (S3D' x) (S3D' y) = S3D' (vectorZip (+) x y)

43 (+) _ _ = error "Impossible to have different constructors for the same shaped network"

44

45 (-) (S1D' x) (S1D' y) = S1D' (x - y)

46 (-) (S2D' x) (S2D' y) = S2D' (x - y)

47− (-) (S3D' x) (S3D' y) = S3D' (vectorZip (\x' y' -> x' - y') x y)

47+ (-) (S3D' x) (S3D' y) = S3D' (vectorZip (-) x y)

48 (-) _ _ = error "Impossible to have different constructors for the same shaped network"

49

50 (*) (S1D' x) (S1D' y) = S1D' (x * y)

51 (*) (S2D' x) (S2D' y) = S2D' (x * y)

52− (*) (S3D' x) (S3D' y) = S3D' (vectorZip (\x' y' -> x' * y') x y)

52+ (*) (S3D' x) (S3D' y) = S3D' (vectorZip (*) x y)

53 (*) _ _ = error "Impossible to have different constructors for the same shaped network"

54

55 abs (S1D' x) = S1D' (abs x)

src/Grenade/Core/Vector.hs+2−2

@@ -26,7 +26,7 @@ instance Foldable (Vector n) where

26 foldr f b (Vector as) = foldr f b as

27

28instance KnownNat n => Traversable (Vector n) where

29− traverse f (Vector as) = fmap mkVector $ traverse f as

29+ traverse f (Vector as) = mkVector <$> traverse f as

30

31instance Functor (Vector n) where

32 fmap f (Vector as) = Vector (fmap f as)

@@ -41,7 +41,7 @@ mkVector :: forall n a. KnownNat n => [a] -> Vector n a

41mkVector as

42 = let du = fromIntegral . natVal $ (undefined :: Proxy n)

43 la = length as

44− in if (du == la)

44+ in if du == la

45 then Vector as

46 else error $ "Error creating staticly sized Vector of length: " ++

47 show du ++ " list is of length:" ++ show la

src/Grenade/Layers/Convolution.hs+38−19

@@ -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 #-}

@@ -13,6 +14,7 @@

13

14

14module Grenade.Layers.Convolution (

15module Grenade.Layers.Convolution (

15 Convolution (..)

16 Convolution (..)

17+ , Convolution' (..)

16 , randomConvolution

18 , randomConvolution

17 , im2col

19 , im2col

18 , vid2col

20 , vid2col

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

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

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

66 -> Convolution channels filters kernelRows kernelColumns strideRows strideColumns

68 -> Convolution channels filters kernelRows kernelColumns strideRows strideColumns

67

69

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

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

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

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

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

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

76+ -> * where

77+ Convolution' :: ( KnownNat channels

78+ , KnownNat filters

79+ , KnownNat kernelRows

80+ , KnownNat kernelColumns

81+ , KnownNat strideRows

82+ , KnownNat strideColumns

83+ , KnownNat kernelFlattened

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

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

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

87+

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

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

69 show (Convolution a _) = renderConv a

89 show (Convolution a _) = renderConv a

70 where

90 where

@@ -99,9 +119,16 @@ randomConvolution = do

99 mm = konst 0

119 mm = konst 0

100 return $ Convolution wN mm

120 return $ Convolution wN mm

101

121

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) =

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

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

127+ newKernel = oldKernel + newMomentum - regulariser

128+ in Convolution newKernel newMomentum

129+

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

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

103−instance ( Monad m

104− , KnownNat kernelRows

131+instance ( KnownNat kernelRows

105 , KnownNat kernelCols

132 , KnownNat kernelCols

106 , KnownNat filters

133 , KnownNat filters

107 , KnownNat strideRows

134 , KnownNat strideRows

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

112 , KnownNat outputCols

139 , KnownNat outputCols

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

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

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

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

115− ) => 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

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

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

117 let ex = extract input

144 let ex = extract input

118 ek = extract kernel

145 ek = extract kernel

@@ -126,8 +153,8 @@ instance ( Monad m

126 mt = c LA.<> ek

153 mt = c LA.<> ek

127 r = col2vid 1 1 1 1 ox oy mt

154 r = col2vid 1 1 1 1 ox oy mt

128 rs = fmap (fromJust . create) r

155 rs = fmap (fromJust . create) r

129− in return . S3D' $ mkVector rs

156+ in S3D' $ mkVector rs

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

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

131 let ex = extract input

158 let ex = extract input

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

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

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

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

@@ -145,20 +172,15 @@ instance ( Monad m

145 vs = vid2col 1 1 1 1 ox oy eo

172 vs = vid2col 1 1 1 1 ox oy eo

146

173

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

174 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

175 dW = vs LA.<> tr ek

153

176

154 xW = col2im kx ky sx sy ix iy dW

177 xW = col2im kx ky sx sy ix iy dW

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

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

156

179

157

180

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

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

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

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

160−instance ( Monad m

161− , KnownNat kernelRows

183+instance ( KnownNat kernelRows

162 , KnownNat kernelCols

184 , KnownNat kernelCols

163 , KnownNat filters

185 , KnownNat filters

164 , KnownNat strideRows

186 , KnownNat strideRows

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

170 , KnownNat channels

192 , KnownNat channels

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

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

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

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

173− ) => 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

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

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

175 let ex = vecToList $ fmap extract input

197 let ex = vecToList $ fmap extract input

176 ek = extract kernel

198 ek = extract kernel

@@ -186,8 +208,8 @@ instance ( Monad m

186 mt = c LA.<> ek

208 mt = c LA.<> ek

187 r = col2vid 1 1 1 1 ox oy mt

209 r = col2vid 1 1 1 1 ox oy mt

188 rs = fmap (fromJust . create) r

210 rs = fmap (fromJust . create) r

189− in return . S3D' $ mkVector rs

211+ in S3D' $ mkVector rs

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

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

191 let ex = vecToList $ fmap extract input

213 let ex = vecToList $ fmap extract input

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

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

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

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

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

205 vs = vid2col 1 1 1 1 ox oy eo

227 vs = vid2col 1 1 1 1 ox oy eo

206

228

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

229 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

230

212 dW = vs LA.<> tr ek

231 dW = vs LA.<> tr ek

213

232

214 xW = col2vid kx ky sx sy ix iy dW

233 xW = col2vid kx ky sx sy ix iy dW

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

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

216

235

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

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

218im2col nrows ncols srows scols m =

237im2col nrows ncols srows scols m =

src/Grenade/Layers/Crop.hs+9−8

@@ -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,9 +37,12 @@ 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 UpdateLayer (Crop l t r b) where

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

42+ runUpdate _ x _ = x

43+

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

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

43−instance ( Monad m

44− , KnownNat cropLeft

45+instance ( KnownNat cropLeft

45 , KnownNat cropTop

46 , KnownNat cropTop

46 , KnownNat cropRight

47 , KnownNat cropRight

47 , KnownNat cropBottom

48 , KnownNat cropBottom

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

51 , KnownNat outputColumns

52 , KnownNat outputColumns

52 , (inputRows - cropTop - cropBottom) ~ outputRows

53 , (inputRows - cropTop - cropBottom) ~ outputRows

53 , (inputColumns - cropLeft - cropRight) ~ outputColumns

54 , (inputColumns - cropLeft - cropRight) ~ outputColumns

54− ) => 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

55 runForwards Crop (S2D' input) =

56 runForwards Crop (S2D' input) =

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

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

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

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

@@ -59,12 +60,12 @@ instance ( Monad m

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

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

60 m = extract input

61 m = extract input

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

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

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

63+ in S2D' . fromJust . create $ r

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

64+ runBackards _ _ (S2D' dEdy) =

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

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

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

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

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

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

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

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

68 eo = extract dEdy

69 eo = extract dEdy

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

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

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

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

src/Grenade/Layers/Dropout.hs+15−16

@@ -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,15 +9,14 @@

11

9

12module Grenade.Layers.Dropout (

10module Grenade.Layers.Dropout (

13 Dropout (..)

11 Dropout (..)

12+ , randomDropout

14 ) where

13 ) where

15

14

16import Control.Monad.Random hiding (fromList)

15import Control.Monad.Random hiding (fromList)

17−import Control.Monad.State

18

16

19import GHC.TypeLits

17import GHC.TypeLits

20import Grenade.Core.Shape

18import Grenade.Core.Shape

21import Grenade.Core.Network

19import Grenade.Core.Network

22−import Grenade.Core.Phase

23

20

24import Numeric.LinearAlgebra.Static

21import Numeric.LinearAlgebra.Static

25

22

@@ -29,23 +26,25 @@ import Numeric.LinearAlgebra.Static

29-- 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.

30-- 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

31-- reasonable).

28-- reasonable).

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

29+data Dropout o =

30+ Dropout (R o)

31+ | Pass Double

33 deriving Show

32 deriving Show

34

33

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

35+ type Gradient (Dropout i) = ()

36+ runUpdate _ x _ = x

37+

35randomDropout :: (MonadRandom m, KnownNat i)

38randomDropout :: (MonadRandom m, KnownNat i)

36 => Double -> m (Dropout i)

39 => Double -> m (Dropout i)

37randomDropout rate = do

40randomDropout rate = do

38 seed <- getRandom

41 seed <- getRandom

39 let wN = randomVector seed Uniform

42 let wN = randomVector seed Uniform

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

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

41− return $ Dropout rate xs

44+ return $ Dropout xs

42−

45+

43−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

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

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

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

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

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

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

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

48− True -> do

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

49− newDropout <- randomDropout rate

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

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

src/Grenade/Layers/Flatten.hs+11−7

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

25data FlattenLayer = FlattenLayer

26 deriving Show

27

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

28+instance UpdateLayer FlattenLayer where

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

29+ type Gradient FlattenLayer = ()

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

30+ runUpdate _ _ _ = FlattenLayer

31

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

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

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

35+

32−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

33− 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

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

38+ runBackards _ _ (S1D' o) =

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+ in ((), 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+27−14

@@ -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 #-}

@@ -24,26 +23,39 @@ import Grenade.Core.Shape

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

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

25data FullyConnected i o = FullyConnected

24data FullyConnected i o = FullyConnected

26 !(R o) -- Bias neuron weights

25 !(R o) -- Bias neuron weights

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

27 !(L o i) -- Activation weights

28+ !(L o i) -- Momentum

29+

30+data FullyConnected' i o = FullyConnected'

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

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

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

29

33

30instance Show (FullyConnected i o) where

34instance Show (FullyConnected i o) where

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

35+ show FullyConnected {} = "FullyConnected"

36+

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

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

39+

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

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

42+ newBias = oldBias + newBiasMomentum

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

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

45+ newActivations = oldActivations + newMomentum - regulariser

46+ in FullyConnected newBias newBiasMomentum newActivations newMomentum

32

47

33−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

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

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

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

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

36

51

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

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

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

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

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

54+ let wB' = dEdy

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

55+ 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

56 -- calcluate derivatives for next step

45 dWs = tr wN #> dEdy

57 dWs = tr wN #> dEdy

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

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

47

59

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

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

49 => m (FullyConnected i o)

61 => m (FullyConnected i o)

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

52 s2 :: Int <- getRandom

64 s2 :: Int <- getRandom

53 let wB = randomVector s1 Uniform * 2 - 1

65 let wB = randomVector s1 Uniform * 2 - 1

54 wN = uniformSample s2 (-1) 1

66 wN = uniformSample s2 (-1) 1

67+ bm = konst 0

55 mm = konst 0

68 mm = konst 0

56− return $ FullyConnected wB wN mm

69+ return $ FullyConnected wB bm wN mm

src/Grenade/Layers/Fuse.hs+20−14

@@ -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 x i h, Layer 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 x y i h o

31infixr 5 :$$

30infixr 5 :$$

32

31

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

32+instance Show (Fuse 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 (KnownShape i, KnownShape h, KnownShape o) => UpdateLayer (Fuse x y i h o) where

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

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

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

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

39− runForwards y yInput

38+ let newX = runUpdate lr x x'

39+ newY = runUpdate lr y y'

40+ in (newX :$$ newY)

40

41

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

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

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

45+ in runForwards y yInput

46+

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

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

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

48+ let 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+ in ((x', y'), xGrad)

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

@@ -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 UpdateLayer Logit where

26+ type Gradient Logit = ()

27+ runUpdate _ _ _ = Logit

28+

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

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

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

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

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

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

29

32

30−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

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

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

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

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

33

36

34−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

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

38+ runForwards _ (S3D' y) = 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) = ((), 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+9−8

@@ -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,9 +37,12 @@ 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 UpdateLayer (Pad l t r b) where

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

42+ runUpdate _ x _ = x

43+

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

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

43−instance ( Monad m

44− , KnownNat padLeft

45+instance ( KnownNat padLeft

45 , KnownNat padTop

46 , KnownNat padTop

46 , KnownNat padRight

47 , KnownNat padRight

47 , KnownNat padBottom

48 , KnownNat padBottom

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

51 , KnownNat outputColumns

52 , KnownNat outputColumns

52 , (inputRows + padTop + padBottom) ~ outputRows

53 , (inputRows + padTop + padBottom) ~ outputRows

53 , (inputColumns + padLeft + padRight) ~ outputColumns

54 , (inputColumns + padLeft + padRight) ~ outputColumns

54− ) => 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

55 runForwards Pad (S2D' input) =

56 runForwards Pad (S2D' input) =

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

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

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

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

@@ -59,12 +60,12 @@ instance ( Monad m

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

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

60 m = extract input

61 m = extract input

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

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

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

63+ in S2D' . fromJust . create $ r

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

64+ runBackards Pad _ (S2D' dEdy) =

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

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

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

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

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

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

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

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

68 m = extract dEdy

69 m = extract dEdy

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

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

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

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

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

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

51 show Pooling = "Pooling"

52

53

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

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

56+ runUpdate _ Pooling _ = Pooling

57+

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

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

55−instance ( Monad m

56− , KnownNat kernelRows

59+instance ( KnownNat kernelRows

57 , KnownNat kernelColumns

60 , KnownNat kernelColumns

58 , KnownNat strideRows

61 , KnownNat strideRows

59 , KnownNat strideColumns

62 , KnownNat strideColumns

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

63 , KnownNat outputColumns

66 , KnownNat outputColumns

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

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

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

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

66− ) => 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

67 runForwards Pooling (S2D' input) =

70 runForwards Pooling (S2D' input) =

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

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

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

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

@@ -74,8 +77,8 @@ instance ( Monad m

74 ex = extract input

77 ex = extract input

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

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

76 rs = fromJust . create $ r

79 rs = fromJust . create $ r

77− in return . S2D' $ rs

80+ in S2D' $ rs

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

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

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

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

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

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

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

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

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

83 ex = extract input

86 ex = extract input

84 eo = extract dEdy

87 eo = extract dEdy

85 vs = poolBackward kx ky sx sy ex eo

88 vs = poolBackward kx ky sx sy ex eo

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

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

87

90

88

91

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

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

90−instance ( Monad m

91− , KnownNat kernelRows

93+instance ( KnownNat kernelRows

92 , KnownNat kernelColumns

94 , KnownNat kernelColumns

93 , KnownNat strideRows

95 , KnownNat strideRows

94 , KnownNat strideColumns

96 , KnownNat strideColumns

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

98 , KnownNat outputColumns

100 , KnownNat outputColumns

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

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

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

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

101− ) => 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

102 runForwards Pooling (S3D' input) =

104 runForwards Pooling (S3D' input) =

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

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

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

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

@@ -111,8 +113,8 @@ instance ( Monad m

111 ex = fmap extract input

113 ex = fmap extract input

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

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

113 rs = fmap (fromJust . create) r

115 rs = fmap (fromJust . create) r

114− in return . S3D' $ rs

116+ in S3D' rs

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

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

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

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

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

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

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

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

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

123 eo = fmap extract dEdy

125 eo = fmap extract dEdy

124 ez = vectorZip (,) ex eo

126 ez = vectorZip (,) ex eo

125 vs = poolBackwardList kx ky sx sy ix iy ez

127 vs = poolBackwardList kx ky sx sy ix iy ez

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

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

127

129

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

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

129poolForward nrows ncols srows scols outputRows outputCols m =

131poolForward nrows ncols srows scols outputRows outputCols m =

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

@@ -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,26 +22,30 @@ import qualified Numeric.LinearAlgebra.Static as LAS

24data Relu = Relu

22data Relu = Relu

25 deriving Show

23 deriving Show

26

24

25+instance UpdateLayer Relu where

26+ type Gradient Relu = ()

27+ runUpdate _ _ _ = Relu

28+

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

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

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

30+ runForwards _ (S1D' y) = 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) = ((), 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

35−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

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

38+ runForwards _ (S2D' y) = 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) = ((), 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

43−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

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

46+ runForwards _ (S3D' y) = 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) = ((), 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+13−11

@@ -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

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

22+instance UpdateLayer Tanh where

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

23+ type Gradient Tanh = ()

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

24+ runUpdate _ _ _ = Tanh

27

25

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

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

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

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

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

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

31

29

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

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

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

33+

32−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

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

35+ runForwards _ (S3D' y) = 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) = ((), 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

test/Test/Grenade/Layers/Convolution.hs+20−19

@@ -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

@@ -93,11 +91,12 @@ prop_simple_conv_forwards = once $

93 , 0.0, 0.0, 0.0, 0.0

91 , 0.0, 0.0, 0.0, 0.0

94 , 0.0, 0.0, 0.0, 0.0

92 , 0.0, 0.0, 0.0, 0.0

95 , 0.0, 0.0, 0.0, 0.0 ] :: HStatic.L 4 4)

93 , 0.0, 0.0, 0.0, 0.0 ] :: HStatic.L 4 4)

94+

96− --expectedKernel = (HStatic.matrix

95+ expectedGradient = (HStatic.matrix

97− -- [ 0.0, 0.0, 0.0, -2.0

96+ [ 1.0, 0.0, 0.0, 2.0

98− -- ,-2.0, 1.0, 1.0, -5.0

97+ , 2.0, 0.0, 0.0, 5.0

99− -- ,-3.0, -1.0, 1.0, -5.0

98+ , 3.0, 0.0, 0.0, 4.0

100− -- ,-5.0, 0.0, 0.0, -7.0 ] :: HStatic.L 4 4)

99+ , 4.0, 0.0, 0.0, 6.0 ] :: HStatic.L 4 4)

101

100

102 convLayer = Convolution myKernel zeroKernel :: Convolution 1 4 2 2 1 1

101 convLayer = Convolution myKernel zeroKernel :: Convolution 1 4 2 2 1 1

103

102

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

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

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

114 ,(HStatic.matrix

113 ,(HStatic.matrix

115 [ -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]

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

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

117

116

118 grad = S3D' ( mkVector

117 grad = S3D' ( mkVector

119 [(HStatic.matrix

118 [(HStatic.matrix

@@ -128,12 +127,13 @@ prop_simple_conv_forwards = once $

128 expectBack = (HStatic.matrix

127 expectBack = (HStatic.matrix

129 [ 1.0, 0.0, 0.0

128 [ 1.0, 0.0, 0.0

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

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

131− (nc, inX) = runIdentity $ runBackards 1 convLayer input grad :: ( Convolution 1 4 2 2 1 1 , S' ('D2 2 3))

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

132

131

133 in case (out, inX, nc) of

132 in case (out, inX, nc) of

134− (S3D' out' , S2D' inX', Convolution _ _)

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

135 -> ((HStatic.extract <$> expect) === (HStatic.extract <$> vecToList out'))

134 -> ((HStatic.extract <$> expect) === (HStatic.extract <$> vecToList out'))

136 .&&. ((HStatic.extract expectBack) === (HStatic.extract inX'))

135 .&&. ((HStatic.extract expectBack) === (HStatic.extract inX'))

136+ .&&. ((HStatic.extract expectedGradient) === (HStatic.extract backGrad))

137 -- Temporarily disabled, as l2 adjustment puts in off 5%

138 -- .&&. HStatic.extract expectedKernel === HStatic.extract kernel'

139

@@ -203,11 +203,12 @@ prop_single_conv_forwards = once $

203 , 0.0, 0.0, 0.0, 0.0

204 , 0.0, 0.0, 0.0, 0.0

205 , 0.0, 0.0, 0.0, 0.0 ] :: HStatic.L 4 4)

206+

206− --expectedKernel = (HStatic.matrix

207+ expectedGradient = (HStatic.matrix

207− -- [ 0.0, 0.0, 0.0, -2.0

208+ [ 1.0, 0.0, 0.0, 2.0

208− -- ,-2.0, 1.0, 1.0, -5.0

209+ , 2.0, 0.0, 0.0, 5.0

209− -- ,-3.0, -1.0, 1.0, -5.0

210+ , 3.0, 0.0, 0.0, 4.0

210− -- ,-5.0, 0.0, 0.0, -7.0 ] :: HStatic.L 4 4)

211+ , 4.0, 0.0, 0.0, 6.0 ] :: HStatic.L 4 4)

211

212

212 convLayer = Convolution myKernel zeroKernel :: Convolution 1 4 2 2 1 1

213 convLayer = Convolution myKernel zeroKernel :: Convolution 1 4 2 2 1 1

213

214

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

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

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

224 ,(HStatic.matrix

225 ,(HStatic.matrix

225 [ -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]

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

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

227

228

228 grad = S3D' ( mkVector

229 grad = S3D' ( mkVector

229 [(HStatic.matrix

230 [(HStatic.matrix

@@ -238,13 +239,13 @@ prop_single_conv_forwards = once $

238 expectBack = (HStatic.matrix

239 expectBack = (HStatic.matrix

239 [ 1.0, 0.0, 0.0

240 [ 1.0, 0.0, 0.0

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

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

241− (nc, inX) = runIdentity $ runBackards 1 convLayer input grad :: ( Convolution 1 4 2 2 1 1 , S' ('D3 2 3 1))

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

242

243

243 in case (out, inX, nc) of

244 in case (out, inX, nc) of

244− (S3D' out' , S3D' inX', Convolution _ _)

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

245 -> ((HStatic.extract <$> expect) === (HStatic.extract <$> vecToList out'))

246 -> ((HStatic.extract <$> expect) === (HStatic.extract <$> vecToList out'))

246 .&&. ([HStatic.extract expectBack] === (HStatic.extract <$> vecToList inX'))

247 .&&. ([HStatic.extract expectBack] === (HStatic.extract <$> vecToList inX'))

247− -- .&&. HStatic.extract expectedKernel === HStatic.extract kernel'

248+ .&&. ((HStatic.extract expectedGradient) === (HStatic.extract backGrad))

248

249

249return []

250return []

250tests :: IO Bool

251tests :: IO Bool