2369ec3 · grenade · git.iko.soy

README.md+12−4

compare with master

unifiedsplit

@@ -23,9 +23,18 @@ randomMnist :: MonadRandom m => m MNIST

23randomMnist = randomNetwork

24```

25

26−And that's it. Because the types are rich, there's no specific term level code

26+And that's it. Because the types are so rich, there's no specific term level code

27−required; although it is of course possible and easy to construct one explicitly

27+required to construct this network; although it is of course possible and

28−oneself.

28+easy to construct and deconstruct the networks and layers explicitly oneself.

29+

30+If recurrent neural networks are more your style, you can try defining something

31+["unreasonably effective"](http://karpathy.github.io/2015/05/21/rnn-effectiveness/)

32+with

33+```haskell

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

35+ '[ 'D1 40, 'D1 80, 'D1 40, 'D1 40, 'D1 40 ]

36+```

37+

29

38

30The network can be thought of as a heterogeneous list of layers, where its type

39The network can be thought of as a heterogeneous list of layers, where its type

31includes not only the layers of the network, but also the shapes of data that

40includes not only the layers of the network, but also the shapes of data that

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

89

98

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

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

91

100

92−

93Thanks

101Thanks

94------

102------

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

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

grenade.cabal+5

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

@@ -132,6 +135,8 @@ executable shakespeare

132 build-depends: base

135 build-depends: base

133 , grenade

136 , grenade

134 , attoparsec

137 , attoparsec

138+ , bytestring

139+ , cereal

135 , either

140 , either

136 , optparse-applicative == 0.12.*

141 , optparse-applicative == 0.12.*

137 , text == 1.2.*

142 , 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+47−20

@@ -11,7 +11,7 @@ import Control.Monad.Random

11import Control.Monad.Trans.Except

12

13import Data.Char ( isUpper, toUpper, toLower )

14−import Data.List ( unfoldr, foldl' )

14+import Data.List ( foldl' )

15import Data.Maybe ( fromMaybe )

16

17import qualified Data.Vector as V

@@ -20,6 +20,8 @@ import Data.Vector ( Vector )

20import qualified Data.Map as M

21import Data.Proxy ( Proxy (..) )

22

23+import qualified Data.ByteString as B

24+import Data.Serialize

23

25

24import Data.Singletons.Prelude

26import Data.Singletons.Prelude

25import GHC.TypeLits

27import GHC.TypeLits

@@ -32,29 +34,31 @@ import Grenade

32import Grenade.Recurrent

34import Grenade.Recurrent

33import Grenade.Utils.OneHot

35import Grenade.Utils.OneHot

34

36

37+import System.IO.Unsafe ( unsafeInterleaveIO )

38+

35-- The defininition for our natural language recurrent network.

39-- The defininition for our natural language recurrent network.

36-- This network is able to learn and generate simple words in

40-- This network is able to learn and generate simple words in

37-- about an hour.

41-- about an hour.

38--

42--

39−-- This is a first class recurrent net, although it's similar to

43+-- This is a first class recurrent net.

40−-- an unrolled graph.

41--

44--

42-- The F and R types are tagging types to ensure that the runner and

45-- The F and R types are tagging types to ensure that the runner and

43-- creation function know how to treat the layers.

46-- creation function know how to treat the layers.

44--

47--

45-- As an example, here's a short sequence generated.

48-- As an example, here's a short sequence generated.

46--

49--

47−-- > the see and and the sir, and and the make and the make and go the make and go the make and the

50+-- > KING RICHARD III:

48−--

51+-- > And as the heaven her his words, we the son, I show sand stape but the lament to shall were the sons with a strend

52+

49type F = FeedForward

53type F = FeedForward

50type R = Recurrent

54type R = Recurrent

51

55

52-- The definition of our network

56-- The definition of our network

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

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

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

58+ '[ 'D1 40, 'D1 80, 'D1 40, 'D1 40, 'D1 40 ]

55

59

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

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

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

58

62

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

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

60randomNet = randomRecurrent

64randomNet = randomRecurrent

@@ -82,36 +86,50 @@ trainSlice !rate !net !recIns input offset size =

82runShakespeare :: ShakespeareOpts -> ExceptT String IO ()

86runShakespeare :: ShakespeareOpts -> ExceptT String IO ()

83runShakespeare ShakespeareOpts {..} = do

87runShakespeare ShakespeareOpts {..} = do

84 (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare trainingFile

88 (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare trainingFile

85− (net0, i0) <- lift randomNet

89+ (net0, i0) <- lift $

90+ case loadPath of

91+ Just loadFile -> netLoad loadFile

92+ Nothing -> randomNet

93+

86− lift $ foldM_ (\(!net, !io) size -> do

94+ (trained, bestInput) <- lift $ foldM (\(!net, !io) size -> do

87− xs <- take (iterations `div` 15) <$> getRandomRs (0, length shakespeare - size - 1)

95+ xs <- take (iterations `div` 10) <$> getRandomRs (0, length shakespeare - size - 1)

88 let (!trained, !bestInput) = foldl' (\(!n, !i) offset -> trainSlice rate n i shakespeare offset size) (net, io) xs

96 let (!trained, !bestInput) = foldl' (\(!n, !i) offset -> trainSlice rate n i shakespeare offset size) (net, io) xs

89− let results = take 100 $ generateParagraph trained bestInput oneHotMap oneHotDictionary ( S1D $ konst 0)

97+ results <- take 1000 <$> generateParagraph trained bestInput temperature oneHotMap oneHotDictionary ( S1D $ konst 0)

90 putStrLn ("TRAINING STEP WITH SIZE: " ++ show size)

98 putStrLn ("TRAINING STEP WITH SIZE: " ++ show size)

91 putStrLn (unAnnotateCapitals results)

99 putStrLn (unAnnotateCapitals results)

92 return (trained, bestInput)

100 return (trained, bestInput)

93− ) (net0, i0) [10,10,15,15,20,20,25,25,30,30,35,35,40,40,50 :: Int]

101+ ) (net0, i0) $ replicate 10 sequenceSize

102+

103+ case savePath of

104+ Just saveFile -> lift . B.writeFile saveFile $ runPut (put (trained, bestInput))

105+ Nothing -> return ()

94

106

95generateParagraph :: forall layers shapes n a. (Last shapes ~ 'D1 n, Head shapes ~ 'D1 n, KnownNat n, Ord a)

107generateParagraph :: forall layers shapes n a. (Last shapes ~ 'D1 n, Head shapes ~ 'D1 n, KnownNat n, Ord a)

96 => RecurrentNetwork layers shapes

108 => RecurrentNetwork layers shapes

97 -> RecurrentInputs layers

109 -> RecurrentInputs layers

110+ -> Double

98 -> M.Map a Int

111 -> M.Map a Int

99 -> Vector a

112 -> Vector a

100 -> S ('D1 n)

113 -> S ('D1 n)

101− -> [a]

114+ -> IO [a]

102−generateParagraph n s hotmap hotdict i =

115+generateParagraph n s temperature hotmap hotdict =

103− unfoldr go (s, i)

116+ go s

104 where

117 where

105− go (x, y) =

118+ go x y =

106 do let (ns, o) = runRecurrent n x y

119 do let (ns, o) = runRecurrent n x y

107− un <- unHot hotdict o

120+ un <- sample temperature hotdict o

108− re <- makeHot hotmap un

121+ Just re <- return $ makeHot hotmap un

109− Just (un, (ns, re))

122+ rest <- unsafeInterleaveIO $ go ns re

123+ return (un : rest)

110

124

111data ShakespeareOpts = ShakespeareOpts {

125data ShakespeareOpts = ShakespeareOpts {

112 trainingFile :: FilePath

126 trainingFile :: FilePath

113 , iterations :: Int

127 , iterations :: Int

114 , rate :: LearningParameters

128 , rate :: LearningParameters

129+ , sequenceSize :: Int

130+ , temperature :: Double

131+ , loadPath :: Maybe FilePath

132+ , savePath :: Maybe FilePath

115 }

133 }

116

134

117shakespeare' :: Parser ShakespeareOpts

135shakespeare' :: Parser ShakespeareOpts

@@ -122,6 +140,10 @@ shakespeare' = ShakespeareOpts <$> argument str (metavar "TRAIN")

122 <*> option auto (long "momentum" <> value 0.95)

140 <*> option auto (long "momentum" <> value 0.95)

123 <*> option auto (long "l2" <> value 0.000001)

141 <*> option auto (long "l2" <> value 0.000001)

124 )

142 )

143+ <*> option auto (long "sequence-length" <> short 's' <> value 50)

144+ <*> option auto (long "temperature" <> short 't' <> value 0.4)

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

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

125

147

126main :: IO ()

148main :: IO ()

127main = do

149main = do

@@ -132,6 +154,11 @@ main = do

132 Left err -> putStrLn err

154 Left err -> putStrLn err

133

155

134

156

157+netLoad :: FilePath -> IO (Shakespeare, Shakespearian)

158+netLoad modelPath = do

159+ modelData <- B.readFile modelPath

160+ either fail return $ runGet get modelData

161+

135-- Replace capitals with an annotation and the lower case letter

162-- Replace capitals with an annotation and the lower case letter

136-- http://fastml.com/one-weird-trick-for-training-char-rnns/

163-- http://fastml.com/one-weird-trick-for-training-char-rnns/

137annotateCapitals :: String -> String

164annotateCapitals :: String -> String

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/Core/Shape.hs+25−27

@@ -65,30 +65,36 @@ data S (n :: Shape) where

65

66deriving instance Show (S n)

67

68+-- Singletons

69+-- These could probably be derived with template haskell, but this seems

70+-- clear and makes adding the KnownNat constraints simple.

71+data instance Sing (n :: Shape) where

72+ D1Sing :: KnownNat a => Sing ('D1 a)

73+ D2Sing :: (KnownNat a, KnownNat b) => Sing ('D2 a b)

74+ D3Sing :: (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => Sing ('D3 a b c)

75+

76+instance KnownNat a => SingI ('D1 a) where

77+ sing = D1Sing

78+instance (KnownNat a, KnownNat b) => SingI ('D2 a b) where

79+ sing = D2Sing

80+instance (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => SingI ('D3 a b c) where

81+ sing = D3Sing

82+

68instance SingI x => Num (S x) where

83instance SingI x => Num (S x) where

69 (+) = n2 (+)

84 (+) = n2 (+)

70 (-) = n2 (-)

85 (-) = n2 (-)

71 (*) = n2 (*)

86 (*) = n2 (*)

72 abs = n1 abs

87 abs = n1 abs

73 signum = n1 signum

88 signum = n1 signum

74− fromInteger x = case (sing :: Sing x) of

75− D1Sing -> S1D (konst $ fromInteger x)

76− D2Sing -> S2D (konst $ fromInteger x)

77− D3Sing -> S3D (konst $ fromInteger x)

89+ fromInteger x = nk (fromInteger x)

78

90

79instance SingI x => Fractional (S x) where

91instance SingI x => Fractional (S x) where

80 (/) = n2 (/)

92 (/) = n2 (/)

81 recip = n1 recip

93 recip = n1 recip

82− fromRational x = case (sing :: Sing x) of

83− D1Sing -> S1D (konst $ fromRational x)

84− D2Sing -> S2D (konst $ fromRational x)

85− D3Sing -> S3D (konst $ fromRational x)

94+ fromRational x = nk (fromRational x)

86

95

87instance SingI x => Floating (S x) where

96instance SingI x => Floating (S x) where

88− pi = case (sing :: Sing x) of

97+ pi = nk pi

89− D1Sing -> S1D (konst pi)

90− D2Sing -> S2D (konst pi)

91− D3Sing -> S3D (konst pi)

92 exp = n1 exp

98 exp = n1 exp

93 log = n1 log

99 log = n1 log

94 sqrt = n1 sqrt

100 sqrt = n1 sqrt

@@ -107,21 +113,6 @@ instance SingI x => Floating (S x) where

107 acosh = n1 acosh

113 acosh = n1 acosh

108 atanh = n1 atanh

114 atanh = n1 atanh

109

115

110−-- Singletons

111−-- These could probably be derived with template haskell, but this seems

112−-- clear and makes adding the KnownNat constraints simple.

113−data instance Sing (n :: Shape) where

114− D1Sing :: KnownNat a => Sing ('D1 a)

115− D2Sing :: (KnownNat a, KnownNat b) => Sing ('D2 a b)

116− D3Sing :: (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => Sing ('D3 a b c)

117−

118−instance KnownNat a => SingI ('D1 a) where

119− sing = D1Sing

120−instance (KnownNat a, KnownNat b) => SingI ('D2 a b) where

121− sing = D2Sing

122−instance (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => SingI ('D3 a b c) where

123− sing = D3Sing

124−

125--

116--

126-- I haven't made shapes strict, as sometimes they're not needed

117-- I haven't made shapes strict, as sometimes they're not needed

127-- (the last input gradient back for instance)

118-- (the last input gradient back for instance)

@@ -170,3 +161,10 @@ n2 f (S1D x) (S1D y) = S1D (f x y)

170n2 f (S2D x) (S2D y) = S2D (f x y)

161n2 f (S2D x) (S2D y) = S2D (f x y)

171n2 f (S3D x) (S3D y) = S3D (f x y)

162n2 f (S3D x) (S3D y) = S3D (f x y)

172n2 _ _ _ = error "Impossible to have different constructors for the same shaped network"

163n2 _ _ _ = error "Impossible to have different constructors for the same shaped network"

164+

165+-- Helper function for creating the number instances

166+nk :: forall x. SingI x => Double -> S x

167+nk x = case (sing :: Sing x) of

168+ D1Sing -> S1D (konst x)

169+ D2Sing -> S2D (konst x)

170+ D3Sing -> S3D (konst x)

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

src/Grenade/Recurrent/Core/Network.hs+40

@@ -19,10 +19,15 @@ module Grenade.Recurrent.Core.Network (

19

20import Control.Monad.Random ( MonadRandom )

21import Data.Singletons ( SingI )

22+import Data.Serialize

23+import qualified Data.Vector.Storable as V

22

24

23import Grenade.Core.Shape

25import Grenade.Core.Shape

24import Grenade.Core.Network

26import Grenade.Core.Network

25

27

28+import qualified Numeric.LinearAlgebra as LA

29+import qualified Numeric.LinearAlgebra.Static as LAS

30+

26

31

27-- | Witness type to say indicate we're building up with a normal feed

32-- | Witness type to say indicate we're building up with a normal feed

28-- forward layer.

33-- forward layer.

@@ -96,3 +101,38 @@ instance (SingI i, RecurrentLayer x i o, CreatableRecurrent xs (o ': r ': rs)) =

96 (rest, resti) <- randomRecurrent

101 (rest, resti) <- randomRecurrent

97 return (thisLayer :~@> rest, thisShape :~@+> resti)

102 return (thisLayer :~@> rest, thisShape :~@+> resti)

98

103

104+-- | Add very simple serialisation to the recurrent network

105+instance (SingI i, SingI o, Layer x i o, Serialize x) => Serialize (RecurrentNetwork '[FeedForward x] '[i, o]) where

106+ put (OR x) = put x

107+ put _ = error "impossible"

108+ get = OR <$> get

109+

110+instance (SingI i, Layer x i o, Serialize x, Serialize (RecurrentNetwork xs (o ': r ': rs))) => Serialize (RecurrentNetwork (FeedForward x ': xs) (i ': o ': r ': rs)) where

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

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

113+

114+instance (SingI i, RecurrentLayer x i o, Serialize x, Serialize (RecurrentNetwork xs (o ': r ': rs))) => Serialize (RecurrentNetwork (Recurrent x ': xs) (i ': o ': r ': rs)) where

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

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

117+

118+instance (UpdateLayer x) => (Serialize (RecurrentInputs '[FeedForward x])) where

119+ put _ = return ()

120+ get = return (ORS ())

121+

122+instance (UpdateLayer x, Serialize (RecurrentInputs (y ': ys))) => (Serialize (RecurrentInputs (FeedForward x ': y ': ys))) where

123+ put ( () :~~+> rest) = put rest

124+ get = ( () :~~+> ) <$> get

125+

126+instance (SingI (RecurrentShape x), RecurrentUpdateLayer x, Serialize (RecurrentInputs (y ': ys))) => (Serialize (RecurrentInputs (Recurrent x ': y ': ys))) where

127+ put ( i :~@+> rest ) = do

128+ _ <- (case i of

129+ (S1D x) -> putListOf put . LA.toList . LAS.extract $ x

130+ (S2D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

131+ (S3D x) -> putListOf put . LA.toList . LA.flatten . LAS.extract $ x

132+ ) :: PutM ()

133+ put rest

134+

135+ get = do

136+ Just i <- fromStorable . V.fromList <$> getListOf get

137+ rest <- get

138+ return ( i :~@+> rest)

src/Grenade/Recurrent/Core/Runner.hs+7−1

@@ -19,6 +19,12 @@ import Grenade.Core.Shape

19import Grenade.Recurrent.Core.Network

20

21-- | Drive and network and collect its back propogated gradients.

22+--

23+-- TODO: split this nicely into backpropagate and update.

24+--

25+-- QUESTION: Should we return a list of gradients or the sum of

26+-- the gradients? It's different taking into account

27+-- momentum and L2.

22trainRecurrent :: forall shapes layers. SingI (Last shapes)

28trainRecurrent :: forall shapes layers. SingI (Last shapes)

23 => LearningParameters

29 => LearningParameters

24 -> RecurrentNetwork layers shapes

30 -> RecurrentNetwork layers shapes

@@ -94,7 +100,7 @@ trainRecurrent rate network recinputs examples =

94 = () :~~+> updateRecInputs l xs ys

100 = () :~~+> updateRecInputs l xs ys

95

101

96 updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)

102 updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)

97− = (x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys

103+ = (realToFrac (learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys

98

104

99 updateRecInputs _ (ORS ()) (ORS ())

105 updateRecInputs _ (ORS ()) (ORS ())

100 = ORS ()

106 = ORS ()

src/Grenade/Recurrent/Layers/LSTM.hs+48−1

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

8{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE ViewPatterns #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

11

12

12-- GHC 7.10 doesn't see recurrent run functions as total.

13-- GHC 7.10 doesn't see recurrent run functions as total.

13{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

14{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

@@ -19,9 +20,13 @@ module Grenade.Recurrent.Layers.LSTM (

19

20

20import Control.Monad.Random ( MonadRandom, getRandom )

21import Control.Monad.Random ( MonadRandom, getRandom )

21

22

23+

22-- import Data.List ( foldl1' )

24-- import Data.List ( foldl1' )

25+import Data.Proxy

26+import Data.Serialize

23import Data.Singletons.TypeLits

27import Data.Singletons.TypeLits

24

28

29+import qualified Numeric.LinearAlgebra as LA

25import Numeric.LinearAlgebra.Static

30import Numeric.LinearAlgebra.Static

26

31

27import Grenade.Core.Network

32import Grenade.Core.Network

@@ -118,7 +123,6 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

118

123

119 -- v :: forall x ix. (x -> (R ix)) -> x -> x -> R ix

124 -- v :: forall x ix. (x -> (R ix)) -> x -> x -> R ix

120 -- v e (e -> a) (e -> b) = a + b

125 -- v e (e -> a) (e -> b) = a + b

121−

122 createRandom = randomLSTM

126 createRandom = randomLSTM

123

127

124instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

128instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where

@@ -245,3 +249,46 @@ sigmoid' x = logix * (1 - logix)

245

249

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

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

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

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

252+

253+instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

254+ put (LSTM LSTMWeights {..} _) = do

255+ u lstmWf

256+ u lstmUf

257+ v lstmBf

258+ u lstmWi

259+ u lstmUi

260+ v lstmBi

261+ u lstmWo

262+ u lstmUo

263+ v lstmBo

264+ u lstmWc

265+ v lstmBc

266+ where

267+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

268+ u = putListOf put . LA.toList . LA.flatten . extract

269+ v :: forall a. (KnownNat a) => Putter (R a)

270+ v = putListOf put . LA.toList . extract

271+

272+ get = do

273+ lstmWf <- u

274+ lstmUf <- u

275+ lstmBf <- v

276+ lstmWi <- u

277+ lstmUi <- u

278+ lstmBi <- v

279+ lstmWo <- u

280+ lstmUo <- u

281+ lstmBo <- v

282+ lstmWc <- u

283+ lstmBc <- v

284+ return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

285+ where

286+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

287+ u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

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

289+ v :: forall a. (KnownNat a) => Get (R a)

290+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

291+

292+ w0 = konst 0

293+ u0 = konst 0

294+ v0 = konst 0

src/Grenade/Recurrent/Layers/Trivial.hs+6

@@ -7,12 +7,18 @@ module Grenade.Recurrent.Layers.Trivial (

7 Trivial (..)

8 ) where

9

10+import Data.Serialize

11+

10import Grenade.Core.Network

12import Grenade.Core.Network

11

13

12-- | A trivial layer.

14-- | A trivial layer.

13data Trivial = Trivial

15data Trivial = Trivial

14 deriving Show

16 deriving Show

15

17

18+instance Serialize Trivial where

19+ put _ = return ()

20+ get = return Trivial

21+

16instance UpdateLayer Trivial where

22instance UpdateLayer Trivial where

17 type Gradient Trivial = ()

23 type Gradient Trivial = ()

18 runUpdate _ _ _ = Trivial

24 runUpdate _ _ _ = Trivial

src/Grenade/Utils/OneHot.hs+11−2

@@ -11,8 +11,11 @@ module Grenade.Utils.OneHot (

11 , hotMap

12 , makeHot

13 , unHot

14+ , sample

14 ) where

15 ) where

15

16

17+import qualified Control.Monad.Random as MR

18+

16import Data.List ( group, sort )

19import Data.List ( group, sort )

17

20

18import Data.Map ( Map )

21import Data.Map ( Map )

@@ -23,6 +26,7 @@ import Data.Singletons.TypeLits

23

26

24import Data.Vector ( Vector )

27import Data.Vector ( Vector )

25import qualified Data.Vector as V

28import qualified Data.Vector as V

29+import qualified Data.Vector.Storable as VS

26

30

27import Numeric.LinearAlgebra ( maxIndex )

31import Numeric.LinearAlgebra ( maxIndex )

28import Numeric.LinearAlgebra.Devel

32import Numeric.LinearAlgebra.Devel

@@ -76,9 +80,14 @@ makeHot m x = do

76 return vec

80 return vec

77 else Nothing

81 else Nothing

78

82

79−unHot :: forall a n. (KnownNat n)

83+unHot :: forall a n. KnownNat n

80− => Vector a -> (S ('D1 n)) -> Maybe a

84+ => Vector a -> S ('D1 n) -> Maybe a

81unHot v (S1D xs)

85unHot v (S1D xs)

82 = (V.!?) v

86 = (V.!?) v

83 $ maxIndex (extract xs)

87 $ maxIndex (extract xs)

84

88

89+sample :: forall a n m. (KnownNat n, MR.MonadRandom m)

90+ => Double -> Vector a -> S ('D1 n) -> m a

91+sample temperature v (S1D xs) = do

92+ ix <- MR.fromList . zip [0..] . fmap (toRational . exp . (/ temperature) . log) . VS.toList . extract $ xs

93+ return $ v V.! ix

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

@@ -22,6 +22,7 @@ import Grenade.Layers.Convolution

22import Disorder.Jack

23

24import Test.Jack.Hmatrix

25+import Test.Jack.TypeLits

25

26

26data OpaqueConvolution :: * where

27data OpaqueConvolution :: * where

27 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution

28 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution

@@ -42,12 +43,12 @@ genConvolution = Convolution <$> uniformSample <*> uniformSample

42

43

43genOpaqueOpaqueConvolution :: Jack OpaqueConvolution

44genOpaqueOpaqueConvolution :: Jack OpaqueConvolution

44genOpaqueOpaqueConvolution = do

45genOpaqueOpaqueConvolution = do

45− Just channels <- someNatVal <$> choose (1, 10)

46+ channels <- genNat

46− Just filters <- someNatVal <$> choose (1, 10)

47+ filters <- genNat

47− Just kernel_h <- someNatVal <$> choose (2, 20)

48+ kernel_h <- genNat

48− Just kernel_w <- someNatVal <$> choose (2, 20)

49+ kernel_w <- genNat

49− Just stride_h <- someNatVal <$> choose (1, 10)

50+ stride_h <- genNat

50− Just stride_w <- someNatVal <$> choose (1, 10)

51+ stride_w <- genNat

51 case (channels, filters, kernel_h, kernel_w, stride_h, stride_w) of

52 case (channels, filters, kernel_h, kernel_w, stride_h, stride_w) of

52 ( SomeNat (pch :: Proxy ch), SomeNat (_ :: Proxy fl),

53 ( SomeNat (pch :: Proxy ch), SomeNat (_ :: Proxy fl),

53 SomeNat (pkr :: Proxy kr), SomeNat (pkc :: Proxy kc),

54 SomeNat (pkr :: Proxy kr), SomeNat (pkc :: Proxy kc),

test/Test/Grenade/Recurrent/Layers/LSTM.hs+1−1

@@ -90,7 +90,7 @@ prop_lstm_reference_backwards_cell =

90 refCell = Reference.Vector . H.toList . S.extract $ cell

91 refInput = Reference.Vector . H.toList . S.extract $ input

92 refGradients = Reference.runLSTMbackOnCell refInput refNet refCell

93− in toList refGradients ~~~ (H.toList . S.extract $ actualGradients)

93+ in toList refGradients ~~~ H.toList (S.extract actualGradients)

94

95

96(~~~) as bs = all (< 1e-8) (zipWith (-) as bs)