4dc408f · grenade · git.iko.soy

README.md+5−1

compare with master

unifiedsplit

@@ -89,7 +89,6 @@ and the tests run using:

89

90Grenade is currently known to build with ghc 7.10 and 8.0.

91

92−

93Thanks

92Thanks

94------

93------

95Writing a library like this has been on my mind for a while now, but a big shout

94Writing a library like this has been on my mind for a while now, but a big shout

@@ -108,8 +107,13 @@ Being purely functional, it should also be easy to run batches in parallel, whic

108would be appropriate for larger networks, my current examples however are single

107would be appropriate for larger networks, my current examples however are single

109threaded.

108threaded.

110

109

110+<<<<<<< 20e7e483d75613f16580baa71b44fa9864c940fd

111Training 15 generations over Kaggle's 41000 sample MNIST training set on a single

112core took around 12 minutes, achieving 1.5% error rate on a 1000 sample holdout set.

113+=======

114+Training 15 generations over Kaggle's 42000 sample MNIST training set took under

115+an hour on my laptop, achieving 0.5% error rate on a 1000 sample holdout set.

116+>>>>>>> Add very basic model saving and loading

113

117

114Contributing

118Contributing

115------------

119------------

grenade.cabal+3

@@ -22,6 +22,7 @@ library

22 , containers

23 , deepseq

24 , either == 4.4.*

25+ , cereal

25 , exceptions == 0.8.*

26 , exceptions == 0.8.*

26 , hmatrix

27 , hmatrix

27 , MonadRandom

28 , MonadRandom

@@ -85,6 +86,8 @@ executable feedforward

85 build-depends: base

86 build-depends: base

86 , grenade

87 , grenade

87 , attoparsec

88 , attoparsec

89+ , bytestring

90+ , cereal

88 , either

91 , either

89 , optparse-applicative == 0.12.*

92 , optparse-applicative == 0.12.*

90 , text == 1.2.*

93 , text == 1.2.*

main/feedforward.hs+38−18

@@ -8,6 +8,9 @@ import Control.Monad

8import Control.Monad.Random

9import Data.List ( foldl' )

10

11+import qualified Data.ByteString as B

12+import Data.Serialize

13+

11import GHC.TypeLits

14import GHC.TypeLits

12

15

13import qualified Numeric.LinearAlgebra.Static as SA

16import qualified Numeric.LinearAlgebra.Static as SA

@@ -16,13 +19,12 @@ import Options.Applicative

16

19

17import Grenade

20import Grenade

18

21

19−-- The defininition for our simple feed forward network.

20−-- The type level list represents the shapes passed through the layers. One can see that for this demonstration

21−-- we are using relu, tanh and logit non-linear units, which can be easily subsituted for each other in and out.

22−

23−-- It's important to keep the type signatures, as there's many layers which can "squeeze" into the gaps

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

25

22

23+-- The defininition for our simple feed forward network.

24+-- The type level lists represents the layers and the shapes passed through the layers.

25+-- One can see that for this demonstration we are using relu, tanh and logit non-linear

26+-- units, which can be easily subsituted for each other in and out.

27+--

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

27type FFNet = Network '[ FullyConnected 2 40, Tanh, FullyConnected 40 10, Relu, FullyConnected 10 1, Logit ]

29type FFNet = Network '[ FullyConnected 2 40, Tanh, FullyConnected 40 10, Relu, FullyConnected 10 1, Logit ]

28 '[ 'D1 2, 'D1 40, 'D1 40, 'D1 10, 'D1 10, 'D1 1, 'D1 1]

30 '[ 'D1 2, 'D1 40, 'D1 40, 'D1 10, 'D1 10, 'D1 1, 'D1 1]

@@ -30,8 +32,8 @@ type FFNet = Network '[ FullyConnected 2 40, Tanh, FullyConnected 40 10, Relu, F

30randomNet :: MonadRandom m => m FFNet

32randomNet :: MonadRandom m => m FFNet

31randomNet = randomNetwork

33randomNet = randomNetwork

32

34

33−netTest :: MonadRandom m => LearningParameters -> Int -> m String

35+netTrain :: FFNet -> LearningParameters -> Int -> IO FFNet

34−netTest rate n = do

36+netTrain net0 rate n = do

35 inps <- replicateM n $ do

37 inps <- replicateM n $ do

36 s <- getRandom

38 s <- getRandom

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

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

@@ -39,20 +41,28 @@ netTest rate n = do

39 if v `inCircle` (fromRational 0.33, 0.33) || v `inCircle` (fromRational (-0.33), 0.33)

41 if v `inCircle` (fromRational 0.33, 0.33) || v `inCircle` (fromRational (-0.33), 0.33)

40 then S1D $ fromRational 1

42 then S1D $ fromRational 1

41 else S1D $ fromRational 0

43 else S1D $ fromRational 0

42− net0 <- randomNet

43

44

44 let trained = foldl' trainEach net0 (zip inps outs)

45 let trained = foldl' trainEach net0 (zip inps outs)

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

46+ return trained

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

47−

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

49− return $ unlines outMat

50

47

51 where

48 where

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

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

53 v `inCircle` (o, r) = SA.norm_2 (v - o) <= r

50 v `inCircle` (o, r) = SA.norm_2 (v - o) <= r

54 trainEach !network (i,o) = train rate network i o

51 trainEach !network (i,o) = train rate network i o

55

52

53+netLoad :: FilePath -> IO FFNet

54+netLoad modelPath = do

55+ modelData <- B.readFile modelPath

56+ either fail return $ runGet (get :: Get FFNet) modelData

57+

58+netScore :: FFNet -> IO ()

59+netScore network = do

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

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

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

63+ putStrLn $ unlines outMat

64+

65+ where

56 render n' | n' <= 0.2 = ' '

66 render n' | n' <= 0.2 = ' '

57 | n' <= 0.4 = '.'

67 | n' <= 0.4 = '.'

58 | n' <= 0.6 = '-'

68 | n' <= 0.6 = '-'

@@ -62,7 +72,7 @@ netTest rate n = do

62 normx :: S ('D1 1) -> Double

72 normx :: S ('D1 1) -> Double

63 normx (S1D r) = SA.mean r

73 normx (S1D r) = SA.mean r

64

74

65−data FeedForwardOpts = FeedForwardOpts Int LearningParameters

75+data FeedForwardOpts = FeedForwardOpts Int LearningParameters (Maybe FilePath) (Maybe FilePath)

66

76

67feedForward' :: Parser FeedForwardOpts

77feedForward' :: Parser FeedForwardOpts

68feedForward' =

78feedForward' =

@@ -72,9 +82,19 @@ feedForward' =

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

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

73 <*> option auto (long "l2" <> value 0.0005)

83 <*> option auto (long "l2" <> value 0.0005)

74 )

84 )

85+ <*> optional (strOption (long "load"))

86+ <*> optional (strOption (long "save"))

75

87

76main :: IO ()

88main :: IO ()

77main = do

89main = do

78− FeedForwardOpts examples rate <- execParser (info (feedForward' <**> helper) idm)

90+ FeedForwardOpts examples rate load save <- execParser (info (feedForward' <**> helper) idm)

79− putStrLn "Training network..."

91+ net0 <- case load of

80− putStrLn =<< evalRandIO (netTest rate examples)

92+ Just loadFile -> netLoad loadFile

93+ Nothing -> randomNet

94+

95+ net <- netTrain net0 rate examples

96+ netScore net

97+

98+ case save of

99+ Just saveFile -> B.writeFile saveFile $ runPut (put net)

100+ Nothing -> return ()

main/shakespeare.hs+3−3

@@ -50,11 +50,11 @@ type F = FeedForward

50type R = Recurrent

51

52-- The definition of our network

53−type Shakespeare = RecurrentNetwork '[ R (LSTM 40 40), F (FullyConnected 40 40), F Logit]

53+type Shakespeare = RecurrentNetwork '[ R (LSTM 40 50), R (LSTM 50 40), F (FullyConnected 40 40), F Logit]

54− '[ 'D1 40, 'D1 40, 'D1 40, 'D1 40 ]

54+ '[ 'D1 40, 'D1 50, 'D1 40, 'D1 40, 'D1 40 ]

55

56-- The definition of the "sideways" input, which the network if fed recurrently.

57−type Shakespearian = RecurrentInputs '[ R (LSTM 40 40), F (FullyConnected 40 40), F Logit]

57+type Shakespearian = RecurrentInputs '[ R (LSTM 40 50), R (LSTM 50 40), F (FullyConnected 40 40), F Logit]

58

59randomNet :: MonadRandom m => m (Shakespeare, Shakespearian)

60randomNet = randomRecurrent

src/Grenade/Core/Network.hs+13

@@ -29,6 +29,8 @@ import Control.Monad.Random (MonadRandom)

29import Data.List ( foldl' )

30import Data.Singletons

31

32+import Data.Serialize

33+

32import Grenade.Core.Shape

34import Grenade.Core.Shape

33

35

34-- | Learning parameters for stochastic gradient descent.

36-- | Learning parameters for stochastic gradient descent.

@@ -101,3 +103,14 @@ instance (SingI i, SingI o, Layer x i o) => CreatableNetwork (x ': '[]) (i ': o

101

103

102instance (SingI i, SingI o, Layer x i o, CreatableNetwork xs (o ': r ': rs)) => CreatableNetwork (x ': xs) (i ': o ': r ': rs) where

104instance (SingI i, SingI o, Layer x i o, CreatableNetwork xs (o ': r ': rs)) => CreatableNetwork (x ': xs) (i ': o ': r ': rs) where

103 randomNetwork = (:~>) <$> createRandom <*> randomNetwork

105 randomNetwork = (:~>) <$> createRandom <*> randomNetwork

106+

107+

108+-- | Add very simple serialisation to the network

109+instance (SingI i, SingI o, Layer x i o, Serialize x) => Serialize (Network '[x] '[i, o]) where

110+ put (O x) = put x

111+ put _ = error "impossible"

112+ get = O <$> get

113+

114+instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o ': r ': rs))) => Serialize (Network (x ': xs) (i ': o ': r ': rs)) where

115+ put (x :~> r) = put x >> put r

116+ get = (:~>) <$> get <*> get

src/Grenade/Layers/Convolution.hs+17

@@ -16,7 +16,9 @@ module Grenade.Layers.Convolution (

16import Control.Monad.Random hiding ( fromList )

17import Data.Maybe

18import Data.Proxy

19+import Data.Serialize

19import Data.Singletons.TypeLits

20import Data.Singletons.TypeLits

21+

20import GHC.TypeLits

22import GHC.TypeLits

21

23

22import Numeric.LinearAlgebra hiding ( uniformSample, konst )

24import Numeric.LinearAlgebra hiding ( uniformSample, konst )

@@ -125,6 +127,21 @@ instance ( KnownNat channels

125

127

126 createRandom = randomConvolution

128 createRandom = randomConvolution

127

129

130+instance ( KnownNat channels

131+ , KnownNat filters

132+ , KnownNat kernelRows

133+ , KnownNat kernelColumns

134+ , KnownNat strideRows

135+ , KnownNat strideColumns

136+ , KnownNat (kernelRows * kernelColumns * channels)

137+ ) => Serialize (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where

138+ put (Convolution w _) = putListOf put . toList . flatten . extract $ w

139+ get = do

140+ let f = fromIntegral $ natVal (Proxy :: Proxy filters)

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

142+ let mm = konst 0

143+ return $ Convolution wN mm

144+

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

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

129instance ( KnownNat kernelRows

146instance ( KnownNat kernelRows

130 , KnownNat kernelCols

147 , KnownNat kernelCols

src/Grenade/Layers/Flatten.hs+7

@@ -7,6 +7,8 @@ module Grenade.Layers.Flatten (

7 FlattenLayer (..)

8 ) where

9

10+import Data.Serialize

11+

10import Data.Singletons.TypeLits

12import Data.Singletons.TypeLits

11import GHC.TypeLits

13import GHC.TypeLits

12

14

@@ -41,6 +43,11 @@ instance (KnownNat y, KnownNat x, KnownNat z, z ~ 1) => Layer FlattenLayer ('D3

41 runForwards _ (S3D y) = S2D y

43 runForwards _ (S3D y) = S2D y

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

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

43

45

46+instance Serialize FlattenLayer where

47+ put _ = return ()

48+ get = return FlattenLayer

49+

50+

44fromJust' :: Maybe x -> x

51fromJust' :: Maybe x -> x

45fromJust' (Just x) = x

52fromJust' (Just x) = x

46fromJust' Nothing = error $ "FlattenLayer error: data shape couldn't be converted."

53fromJust' Nothing = error $ "FlattenLayer error: data shape couldn't be converted."

src/Grenade/Layers/FullyConnected.hs+17

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

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

6module Grenade.Layers.FullyConnected (

7module Grenade.Layers.FullyConnected (

7 FullyConnected (..)

8 FullyConnected (..)

8 , randomFullyConnected

9 , randomFullyConnected

@@ -10,8 +11,11 @@ module Grenade.Layers.FullyConnected (

10

11

11import Control.Monad.Random hiding (fromList)

12import Control.Monad.Random hiding (fromList)

12

13

14+import Data.Proxy

15+import Data.Serialize

13import Data.Singletons.TypeLits

16import Data.Singletons.TypeLits

14

17

18+import qualified Numeric.LinearAlgebra as LA

15import Numeric.LinearAlgebra.Static

19import Numeric.LinearAlgebra.Static

16

20

17import Grenade.Core.Network

21import Grenade.Core.Network

@@ -55,6 +59,19 @@ instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o)

55 dWs = tr wN #> dEdy

59 dWs = tr wN #> dEdy

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

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

57

61

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

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

64+ putListOf put . LA.toList . extract $ b

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

66+

67+ get = do

68+ let f = fromIntegral $ natVal (Proxy :: Proxy i)

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

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

71+ let bm = konst 0

72+ let mm = konst 0

73+ return $ FullyConnected b bm k mm

74+

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

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

59 => m (FullyConnected i o)

76 => m (FullyConnected i o)

60randomFullyConnected = do

77randomFullyConnected = do

src/Grenade/Layers/Logit.hs+6

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

7 ) where

8

9

10+import Data.Serialize

11+

10import Data.Singletons.TypeLits

12import Data.Singletons.TypeLits

11import Grenade.Core.Network

13import Grenade.Core.Network

12import Grenade.Core.Shape

14import Grenade.Core.Shape

@@ -35,6 +37,10 @@ instance (KnownNat i, KnownNat j, KnownNat k) => Layer Logit ('D3 i j k) ('D3 i

35 runForwards _ (S3D y) = S3D (logistic y)

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

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

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

37

39

40+instance Serialize Logit where

41+ put _ = return ()

42+ get = return Logit

43+

38logistic :: Floating a => a -> a

44logistic :: Floating a => a -> a

39logistic x = 1 / (1 + exp (-x))

45logistic x = 1 / (1 + exp (-x))

40

46

src/Grenade/Layers/Pad.hs+5

@@ -10,6 +10,7 @@ module Grenade.Layers.Pad (

10

11import Data.Maybe

12import Data.Proxy

13+import Data.Serialize

13import Data.Singletons.TypeLits

14import Data.Singletons.TypeLits

14import GHC.TypeLits

15import GHC.TypeLits

15

16

@@ -34,6 +35,10 @@ instance UpdateLayer (Pad l t r b) where

34 runUpdate _ x _ = x

35 runUpdate _ x _ = x

35 createRandom = return Pad

36 createRandom = return Pad

36

37

38+instance Serialize (Pad l t r b) where

39+ put _ = return ()

40+ get = return Pad

41+

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

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

38instance ( KnownNat padLeft

43instance ( KnownNat padLeft

39 , KnownNat padTop

44 , KnownNat padTop

src/Grenade/Layers/Pooling.hs+5

@@ -12,6 +12,7 @@ module Grenade.Layers.Pooling (

12

13import Data.Maybe

14import Data.Proxy

15+import Data.Serialize

15import Data.Singletons.TypeLits

16import Data.Singletons.TypeLits

16import GHC.TypeLits

17import GHC.TypeLits

17

18

@@ -39,6 +40,10 @@ instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns)

39 runUpdate _ Pooling _ = Pooling

40 runUpdate _ Pooling _ = Pooling

40 createRandom = return Pooling

41 createRandom = return Pooling

41

42

43+instance Serialize (Pooling kernelRows kernelColumns strideRows strideColumns) where

44+ put _ = return ()

45+ get = return Pooling

46+

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

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

43instance ( KnownNat kernelRows

48instance ( KnownNat kernelRows

44 , KnownNat kernelColumns

49 , KnownNat kernelColumns

src/Grenade/Layers/Relu.hs+6

@@ -6,6 +6,8 @@ module Grenade.Layers.Relu (

6 Relu (..)

7 ) where

8

9+import Data.Serialize

10+

9import GHC.TypeLits

11import GHC.TypeLits

10import Grenade.Core.Network

12import Grenade.Core.Network

11import Grenade.Core.Shape

13import Grenade.Core.Shape

@@ -23,6 +25,10 @@ instance UpdateLayer Relu where

23 runUpdate _ _ _ = Relu

25 runUpdate _ _ _ = Relu

24 createRandom = return Relu

26 createRandom = return Relu

25

27

28+instance Serialize Relu where

29+ put _ = return ()

30+ get = return Relu

31+

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

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

27 runForwards _ (S1D y) = S1D (relu y)

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

28 where

34 where

src/Grenade/Layers/Tanh.hs+6

@@ -6,6 +6,8 @@ module Grenade.Layers.Tanh (

6 Tanh (..)

7 ) where

8

9+import Data.Serialize

10+

9import GHC.TypeLits

11import GHC.TypeLits

10import Grenade.Core.Network

12import Grenade.Core.Network

11import Grenade.Core.Shape

13import Grenade.Core.Shape

@@ -20,6 +22,10 @@ instance UpdateLayer Tanh where

20 runUpdate _ _ _ = Tanh

22 runUpdate _ _ _ = Tanh

21 createRandom = return Tanh

23 createRandom = return Tanh

22

24

25+instance Serialize Tanh where

26+ put _ = return ()

27+ get = return Tanh

28+

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

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

24 runForwards _ (S1D y) = S1D (tanh y)

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

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

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