3e335a0 · grenade · git.iko.soy

git.iko.soy/grenade

Merge pull request #8 from HuwCampbell/topic/pad-and-crop-layers

Add pad and crop layers, add pad to mnist example

commit3e335a0c764b1d134959253bf8564dfd1499d223 authorHuw Campbell <huw.campbell@gmail.com> dateThu 7 Jul 2016, 17:03 (10 years ago) parenta5398f7 8b288cc

5 files changed+148−3

compare with master

unifiedsplit

grenade.cabal+2 main/mnist.hs+4−3 src/Grenade.hs+2 src/Grenade/Layers/Crop.hs+70 src/Grenade/Layers/Pad.hs+70

grenade.cabal+2

@@ -38,6 +38,7 @@ library

3838 Grenade.Core.Runner

3939 Grenade.Core.Shape

4040 Grenade.Core.Phase

41+ Grenade.Layers.Crop

4142 Grenade.Layers.Convolution

4243 Grenade.Layers.Dropout

4344 Grenade.Layers.FullyConnected

@@ -46,6 +47,7 @@ library

4647 Grenade.Layers.Logit

4748 Grenade.Layers.Relu

4849 Grenade.Layers.Tanh

50+ Grenade.Layers.Pad

4951 Grenade.Layers.Pooling

5052

5153

main/mnist.hs+4−3

@@ -32,15 +32,16 @@ import Grenade

3232

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

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

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

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

3636randomMnistNet = do

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

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

3839 let b :: Pooling 2 2 2 2 = Pooling

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

4041 let d :: Pooling 2 2 2 2 = Pooling

41− e :: FullyConnected 256 80 <- randomFullyConnected

42+ e :: FullyConnected 400 80 <- randomFullyConnected

4243 f :: FullyConnected 80 10 <- randomFullyConnected

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

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

4445

4546convTest :: Int -> FilePath -> FilePath -> Double -> IO ()

4647convTest iterations trainFile validateFile rate = do

src/Grenade.hs+2

@@ -20,7 +20,9 @@ import Grenade.Core.Network as X

2020import Grenade.Core.Runner as X

2121import Grenade.Core.Shape as X

2222import Grenade.Core.Phase as X

23+import Grenade.Layers.Crop as X

2324import Grenade.Layers.Dropout as X

25+import Grenade.Layers.Pad as X

2426import Grenade.Layers.Pooling as X

2527import Grenade.Layers.Flatten as X

2628import Grenade.Layers.Fuse as X

src/Grenade/Layers/Crop.hsnew file+70

@@ -0,0 +1,70 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE FlexibleInstances #-}

10+{-# LANGUAGE FlexibleContexts #-}

11+{-# LANGUAGE PolyKinds #-}

12+

13+module Grenade.Layers.Crop (

14+ Crop (..)

15+ ) where

16+

17+import Data.Maybe

18+import Data.Proxy

19+import Data.Singletons.TypeLits

20+import GHC.TypeLits

21+

22+import Grenade.Core.Network

23+import Grenade.Core.Shape

24+

25+import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)

26+import Numeric.LinearAlgebra.Static (extract, create)

27+

28+-- | A cropping layer for a neural network.

29+data Crop :: Nat

30+ -> Nat

31+ -> Nat

32+ -> Nat -> * where

33+ Crop :: ( KnownNat cropLeft

34+ , KnownNat cropTop

35+ , KnownNat cropRight

36+ , KnownNat cropBottom

37+ ) => Crop cropLeft cropTop cropRight cropBottom

38+

39+instance Show (Crop cropLeft cropTop cropRight cropBottom) where

40+ show Crop = "Crop"

41+

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

43+instance ( Monad m

44+ , KnownNat cropLeft

45+ , KnownNat cropTop

46+ , KnownNat cropRight

47+ , KnownNat cropBottom

48+ , KnownNat inputRows

49+ , KnownNat inputColumns

50+ , KnownNat outputRows

51+ , KnownNat outputColumns

52+ , (inputRows - cropTop - cropBottom) ~ outputRows

53+ , (inputColumns - cropLeft - cropRight) ~ outputColumns

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

55+ runForwards Crop (S2D' input) =

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

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

58+ nrows = fromIntegral $ natVal (Proxy :: Proxy outputRows)

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

60+ m = extract input

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

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

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

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

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

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

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

68+ eo = extract dEdy

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

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

src/Grenade/Layers/Pad.hsnew file+70

@@ -0,0 +1,70 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE FlexibleInstances #-}

10+{-# LANGUAGE FlexibleContexts #-}

11+{-# LANGUAGE PolyKinds #-}

12+

13+module Grenade.Layers.Pad (

14+ Pad (..)

15+ ) where

16+

17+import Data.Maybe

18+import Data.Proxy

19+import Data.Singletons.TypeLits

20+import GHC.TypeLits

21+

22+import Grenade.Core.Network

23+import Grenade.Core.Shape

24+

25+import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)

26+import Numeric.LinearAlgebra.Static (extract, create)

27+

28+-- | A padding layer for a neural network.

29+data Pad :: Nat

30+ -> Nat

31+ -> Nat

32+ -> Nat -> * where

33+ Pad :: ( KnownNat padLeft

34+ , KnownNat padTop

35+ , KnownNat padRight

36+ , KnownNat padBottom

37+ ) => Pad padLeft padTop padRight padBottom

38+

39+instance Show (Pad padLeft padTop padRight padBottom) where

40+ show Pad = "Pad"

41+

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

43+instance ( Monad m

44+ , KnownNat padLeft

45+ , KnownNat padTop

46+ , KnownNat padRight

47+ , KnownNat padBottom

48+ , KnownNat inputRows

49+ , KnownNat inputColumns

50+ , KnownNat outputRows

51+ , KnownNat outputColumns

52+ , (inputRows + padTop + padBottom) ~ outputRows

53+ , (inputColumns + padLeft + padRight) ~ outputColumns

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

55+ runForwards Pad (S2D' input) =

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

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

58+ padr = fromIntegral $ natVal (Proxy :: Proxy padRight)

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

60+ m = extract input

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

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

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

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

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

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

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

68+ m = extract dEdy

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

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