08afd74 · grenade · git.iko.soy

.gitmodulesnew file+15

@@ -0,0 +1,15 @@

1+[submodule "lib/disorder"]

2+ path = lib/disorder

3+ url = git@github.com:ambiata/disorder.hs

4+[submodule "lib/x"]

5+ path = lib/x

6+ url = git@github.com:ambiata/x.git

7+[submodule "lib/p"]

8+ path = lib/p

9+ url = git@github.com:ambiata/p.git

10+[submodule "lib/disorder.hs"]

11+ path = lib/disorder.hs

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

13+[submodule "lib/hmatrix"]

14+ path = lib/hmatrix

15+ url = git@github.com:albertoruiz/hmatrix.git

README.mdnew file+58

@@ -0,0 +1,58 @@

1+Grenade

2+=======

3+

4+```

5+First shalt thou take out the Holy Pin, then shalt thou count to three, no more, no less.

6+Three shall be the number thou shalt count, and the number of the counting shall be three.

7+Four shalt thou not count, neither count thou two, excepting that thou then proceed to three.

8+Five is right out.

9+```

10+

11+💣 Machine learning which might blow up in your face 💣

12+

13+Grenade is a type safe, practical and pretty quick neural network library for concise and precise

14+specifications 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

17+initialised 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)])

20+randomMnistNet = do

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

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

23+ c :: Convolution 10 16 5 5 1 1 <- randomConvolution

24+ let d :: Pooling 2 2 2 2 = Pooling

25+ e :: FullyConnected 256 80 <- randomFullyConnected

26+ f :: FullyConnected 80 10 <- randomFullyConnected

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

28+```

29+

30+The network can be thought of as a heterogeneous list of layers, and its type signature includes a type

31+level list of the shapes of the data passed between the layers of the network.

32+

33+In the above example, the input layer can be seen to be a two dimensional (`D2`) image with 28 by 28 pixels.

34+The last item in the list is one dimensional (`D1`) with 10 values, representing the categories of the mnist data.

35+

36+Layers in Grenade are represented as Haskell classes, so creating one's own is easy in downstream code. If the shapes

37+of a network are not specified correctly and a layer can not sensibly perform the operation between two shapes, then

38+it will result in a compile time error.

39+

40+Thanks

41+------

42+Writing a library like this has been on my mind for a while now, but a big shout out must go to Justin Le, whose

43+dependently typed fully connected network inspired me to get cracking, gave many ideas for the type level tools I

44+needed, and was a great starting point for writing this library.

45+

46+Performance

47+-----------

48+Grenade is backed by hmatrix and blas, and uses a pretty clever convolution trick popularised by Caffe, which

49+is surprisingly effective and fast. So for many small scale problems it should be sufficient.

50+

51+That said, it's currently stuck on a single core and doesn't hit up the GPU, so there's a fair bit of performance

52+sitting there begging.

53+

54+Training 15 generations over Kaggle's mnist training data took a few hours.

55+

56+Contributing

57+------------

58+Contributions are welcome.

grenade.cabalnew file+99

@@ -0,0 +1,99 @@

1+name: grenade

2+version: 0.0.1

3+license: AllRightsReserved

4+author: Ambiata <info@ambiata.com>

5+maintainer: Ambiata <info@ambiata.com>

7+synopsis: grenade

8+category: System

9+cabal-version: >= 1.8

10+build-type: Simple

11+description: grenade.

12+

13+library

14+ build-depends:

15+ base >= 4.8 && < 5

16+ , bytestring == 0.10.*

17+ , either == 4.4.*

18+ , exceptions == 0.8.*

19+ , hmatrix

20+ , MonadRandom

21+ , mtl >= 2.2.1 && < 2.3

22+ , parallel == 3.2.*

23+ , text == 1.2.*

24+ , transformers

25+ , singletons

26+

27+ ghc-options:

28+ -Wall

29+ hs-source-dirs:

30+ src

31+

32+

33+ exposed-modules:

34+ Grenade

35+ Grenade.Core.Network

36+ Grenade.Core.Vector

37+ Grenade.Core.Runner

38+ Grenade.Core.Shape

39+ Grenade.Layers.Convolution

40+ Grenade.Layers.Dropout

41+ Grenade.Layers.FullyConnected

42+ Grenade.Layers.Flatten

43+ Grenade.Layers.Fuse

44+ Grenade.Layers.Logit

45+ Grenade.Layers.Relu

46+ Grenade.Layers.Tanh

47+ Grenade.Layers.Pooling

48+

49+

50+executable feedforward

51+ ghc-options: -Wall -threaded -O2

52+ main-is: main/feedforward.hs

53+ build-depends: base

54+ , grenade

55+ , attoparsec

56+ , either

57+ , optparse-applicative == 0.12.*

58+ , text

59+ , mtl >= 2.2.1 && < 2.3

60+ , hmatrix

61+ , transformers

62+ , singletons

63+ , MonadRandom

64+

65+executable mnist

66+ ghc-options: -Wall -threaded -O2

67+ main-is: main/mnist.hs

68+ build-depends: base

69+ , grenade

70+ , attoparsec

71+ , either

72+ , optparse-applicative == 0.12.*

73+ , text

74+ , mtl >= 2.2.1 && < 2.3

75+ , hmatrix

76+ , transformers

77+ , singletons

78+ , MonadRandom

79+

80+

81+test-suite test

82+ type: exitcode-stdio-1.0

83+

84+ main-is: test.hs

85+

86+ ghc-options: -Wall -threaded -O2

87+

88+ hs-source-dirs:

89+ test

90+

91+ build-depends:

92+ base >= 4.8 && < 5

93+ , grenade

94+ , ambiata-disorder-core

95+ , hmatrix

96+ , mtl

97+ , text

98+ , QuickCheck == 2.7.*

99+ , quickcheck-instances == 0.3.*

lib/disorder.hsnew file+1

Submodule changed.

lib/hmatrixnew file+1

Submodule changed.

mafianew file+113

@@ -0,0 +1,113 @@

1+#!/bin/sh -eu

2+

3+fetch_latest () {

4+ if [ -z ${MAFIA_TEST_MODE+x} ]; then

5+ TZ=$(date +"%T")

6+ curl --silent "https://raw.githubusercontent.com/ambiata/mafia/master/script/mafia?$TZ"

7+ else

8+ cat ../script/mafia

9+ fi

10+}

11+

12+latest_version () {

13+ git ls-remote https://github.com/ambiata/mafia | grep refs/heads/master | cut -f 1

14+}

15+

16+local_version () {

17+ awk '/^# Version: / { print $3; exit 0; }' $0

18+}

19+

20+run_upgrade () {

21+ MAFIA_TEMP=$(mktemp 2>/dev/null || mktemp -t 'upgrade_mafia')

22+

23+ clean_up () {

24+ rm -f "$MAFIA_TEMP"

25+ }

26+

27+ trap clean_up EXIT

28+

29+ MAFIA_CUR="$0"

30+

31+ if [ -L "$MAFIA_CUR" ]; then

32+ echo 'Refusing to overwrite a symlink; run `upgrade` from the canonical path.' >&2

33+ exit 1

34+ fi

35+

36+ echo "Checking for a new version of mafia ..."

37+ fetch_latest > $MAFIA_TEMP

38+

39+ LATEST_VERSION=$(latest_version)

40+ echo "# Version: $LATEST_VERSION" >> $MAFIA_TEMP

41+

42+ if ! cmp $MAFIA_CUR $MAFIA_TEMP >/dev/null 2>&1; then

43+ mv $MAFIA_TEMP $MAFIA_CUR

44+ chmod +x $MAFIA_CUR

45+ echo "New version found and upgraded. You can now commit it to your git repo."

46+ else

47+ echo "You have latest mafia."

48+ fi

49+}

50+

51+exec_mafia () {

52+ MAFIA_VERSION=$(local_version)

53+

54+ if [ "x$MAFIA_VERSION" = "x" ]; then

55+ # If we can't find the mafia version, then we need to upgrade the script.

56+ run_upgrade

57+ else

58+ MAFIA_BIN=$HOME/.ambiata/mafia/bin

59+ MAFIA_FILE=mafia-$MAFIA_VERSION

60+ MAFIA_PATH=$MAFIA_BIN/$MAFIA_FILE

61+

62+ [ -f "$MAFIA_PATH" ] || {

63+ # Create a temporary directory which will be deleted when the script

64+ # terminates. Unfortunately `mktemp` doesn't behave the same on

65+ # Linux and OS/X so we need to try two different approaches.

66+ MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia')

67+

68+ # Create a temporary file in MAFIA_BIN so we can do an atomic copy/move dance.

69+ mkdir -p $MAFIA_BIN

70+ MAFIA_PATH_TEMP=$(mktemp --tmpdir=$MAFIA_BIN $MAFIA_FILE-XXXXXX 2>/dev/null || TMPDIR=$MAFIA_BIN mktemp -t $MAFIA_FILE)

71+

72+ clean_up () {

73+ rm -rf "$MAFIA_TEMP"

74+ rm -f "$MAFIA_PATH_TEMP"

75+ }

76+

77+ trap clean_up EXIT

78+

79+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"

80+

81+ ( cd "$MAFIA_TEMP"

82+

83+ git clone https://github.com/ambiata/mafia

84+ cd mafia

85+

86+ git reset --hard $MAFIA_VERSION

87+

88+ bin/bootstrap ) || exit $?

89+

90+ cp "$MAFIA_TEMP/mafia/.cabal-sandbox/bin/mafia" "$MAFIA_PATH_TEMP"

91+ chmod +x "$MAFIA_PATH_TEMP"

92+ mv "$MAFIA_PATH_TEMP" "$MAFIA_PATH"

93+ }

94+

95+ exec $MAFIA_PATH "$@"

96+ fi

97+}

98+

99+#

100+# The actual start of the script.....

101+#

102+

103+if [ $# -gt 0 ]; then

104+ MODE="$1"

105+else

106+ MODE=""

107+fi

108+

109+case "$MODE" in

110+upgrade) shift; run_upgrade "$@" ;;

111+*) exec_mafia "$@"

112+esac

113+# Version: d64cd4f4ab42c1431752d7c84e355b7d001778f8

main/feedforward.hsnew file+83

@@ -0,0 +1,83 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TupleSections #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE FlexibleContexts #-}

9+

10+import Control.Monad

11+import Control.Monad.Identity

12+import Control.Monad.Random

13+

14+import GHC.TypeLits

15+

16+import qualified Numeric.LinearAlgebra.Static as SA

17+

18+import Options.Applicative

19+

20+import Grenade

21+

22+

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

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

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

26+

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

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

29+

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

32+randomNet = do

33+ a :: FullyConnected 2 40 <- randomFullyConnected

34+ b :: FullyConnected 40 10 <- randomFullyConnected

35+ c :: FullyConnected 10 1 <- randomFullyConnected

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

37+

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

39+netTest rate n = do

40+ inps <- replicateM n $ do

41+ s <- getRandom

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

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

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

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

46+ then S1D' $ fromRational 1

47+ else S1D' $ fromRational 0

48+ net0 <- randomNet

49+

50+ return . runIdentity $ do

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

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

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

54+

55+ outMat <- traverse (traverse (\(x,y) -> (render . normx) <$> runNet trained (S1D' $ SA.vector [x / 25 - 1,y / 10 - 1]))) testIns

56+ return $ unlines outMat

57+

58+ where

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

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

61+ trainEach !nt !(i, o) = train rate i o nt

62+

63+ render n' | n' <= 0.2 = ' '

64+ | n' <= 0.4 = '.'

65+ | n' <= 0.6 = '-'

66+ | n' <= 0.8 = '='

67+ | otherwise = '#'

68+

69+ normx :: S' ('D1 1) -> Double

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

71+

72+

73+data FeedForwardOpts = FeedForwardOpts Int Double

74+

75+feedForward' :: Parser FeedForwardOpts

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

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

78+

79+main :: IO ()

80+main = do

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

82+ putStrLn "Training network..."

83+ putStrLn =<< evalRandIO (netTest rate examples)

main/mnist.hsnew file+86

@@ -0,0 +1,86 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TupleSections #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE FlexibleContexts #-}

9+

10+import Control.Applicative

11+import Control.Monad

12+import Control.Monad.Identity

13+import Control.Monad.Random

14+

15+import qualified Data.Attoparsec.Text as A

16+import qualified Data.Text as T

17+import qualified Data.Text.IO as T

18+

19+import Numeric.LinearAlgebra (maxIndex)

20+import qualified Numeric.LinearAlgebra.Static as SA

21+

22+import Options.Applicative

23+

24+import Grenade

25+

26+-- The definition of our convolutional neural network.

27+-- In the type signature, we have a type level list of shapes which are passed between the layers.

28+-- One can see that the images we are inputing are two dimensional with 28 * 28 pixels.

29+

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

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

32+

33+-- 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.

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

36+randomMnistNet = do

37+ a :: Convolution 1 10 5 5 1 1 <- randomConvolution

38+ let b :: Pooling 2 2 2 2 = Pooling

39+ c :: Convolution 10 16 5 5 1 1 <- randomConvolution

40+ let d :: Pooling 2 2 2 2 = Pooling

41+ e :: FullyConnected 256 80 <- randomFullyConnected

42+ f :: FullyConnected 80 10 <- randomFullyConnected

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

44+

45+convTest :: Int -> FilePath -> FilePath -> Double -> IO ()

46+convTest iterations trainFile validateFile rate = do

47+ net0 <- evalRandIO randomMnistNet

48+ fT <- T.readFile trainFile

49+ fV <- T.readFile validateFile

50+ let trainRows = traverse (A.parseOnly p) (T.lines fT)

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

52+ case (trainRows, validateRows) of

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

54+ err -> putStrLn $ show err

55+

56+ where

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

58+

59+ p :: A.Parser (S' ('D2 28 28), S' ('D1 10))

60+ p = do

61+ lab <- A.decimal

62+ pixels <- many (A.char ',' >> A.double)

63+ let lab' = replicate lab 0 ++ [1] ++ replicate (9 - lab) 0

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

65+

66+ runIteration trainRows validateRows net i = do

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

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

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

70+ putStrLn $ show trained'

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

72+ return trained'

73+

74+data MnistOpts = MnistOpts FilePath FilePath Int Double

75+

76+mnist' :: Parser MnistOpts

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

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

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

80+ <*> option auto (long "train_rate" <> short 'r' <> value 0.01)

81+

82+main :: IO ()

83+main = do

84+ MnistOpts mnist vali iter rate <- execParser (info (mnist' <**> helper) idm)

85+ putStrLn "Training convolutional neural network..."

86+ convTest iter mnist vali rate

src/Grenade.hsnew file+30

@@ -0,0 +1,30 @@

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+

14+module Grenade (

15+ module X

16+ ) where

17+

18+import Grenade.Core.Vector as X

19+import Grenade.Core.Network as X

20+import Grenade.Core.Runner as X

21+import Grenade.Core.Shape as X

22+import Grenade.Layers.Dropout as X

23+import Grenade.Layers.Pooling as X

24+import Grenade.Layers.Flatten as X

25+import Grenade.Layers.Fuse as X

26+import Grenade.Layers.FullyConnected as X

27+import Grenade.Layers.Logit as X

28+import Grenade.Layers.Convolution as X

29+import Grenade.Layers.Relu as X

30+import Grenade.Layers.Tanh as X

src/Grenade/Core/Network.hsnew file+49

@@ -0,0 +1,49 @@

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+

14+module Grenade.Core.Network (

15+ Layer (..)

16+ , Network (..)

17+ ) where

18+

19+import Grenade.Core.Shape

20+

21+-- | 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.

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

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

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

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

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

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

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

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

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

32+

33+-- | Type of a network.

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

36+-- transform the date shapes of the network.

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

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

39+ => !x

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

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

42+ => !x

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

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

45+infixr 5 :~>

46+

47+instance Show (Network m h) where

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

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

src/Grenade/Core/Runner.hsnew file+55

@@ -0,0 +1,55 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE StandaloneDeriving #-}

7+{-# LANGUAGE TypeOperators #-}

8+{-# LANGUAGE TypeFamilies #-}

9+

10+module Grenade.Core.Runner (

11+ train

12+ , runNet

13+ ) where

14+

15+import Data.Singletons.Prelude

16+import Grenade.Core.Network

17+import Grenade.Core.Shape

18+

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

21+ => Double -- ^ learning rate

22+ -> S' i -- ^ input vector

23+ -> S' o -- ^ target vector

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

25+ -> m (Network m hs)

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

27+ where

28+ go :: forall m' j js. (Monad m', Head js ~ j, Last js ~ o, KnownShape j, KnownShape o)

29+ => S' j -- ^ input vector

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

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

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

33+ go !x (layer :~> n)

34+ = do y <- runForwards layer x

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

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

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

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

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

40+

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

42+ go !x (O layer)

43+ = do y <- runForwards layer x

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

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

46+ return (O layer', dWs)

47+

48+-- | Just forwards propagation with no training.

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

50+ => Network m hs

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

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

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

54+ runNet n y

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

src/Grenade/Core/Shape.hsnew file+83

@@ -0,0 +1,83 @@

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+

14+module Grenade.Core.Shape (

15+ Shape (..)

16+ , S' (..)

17+ , KnownShape (..)

18+ ) where

19+

20+import Data.Singletons.TypeLits

21+import Data.Proxy

22+

23+import Numeric.LinearAlgebra.Static

24+

25+import Grenade.Core.Vector

26+

27+-- | The current shapes we accept.

28+-- at the moment this is just one, two, and three dimensional

29+-- Vectors/Matricies.

30+data Shape =

31+ D1 Nat

32+ | D2 Nat Nat

33+ | D3 Nat Nat Nat

34+

35+instance KnownShape x => Num (S' x) where

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

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

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

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

40+

41+ (-) (S1D' x) (S1D' y) = S1D' (x - y)

42+ (-) (S2D' x) (S2D' y) = S2D' (x - y)

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

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

45+

46+ (*) (S1D' x) (S1D' y) = S1D' (x * y)

47+ (*) (S2D' x) (S2D' y) = S2D' (x * y)

48+ (*) (S3D' x) (S3D' y) = S3D' (vectorZip (\x' y' -> x' * y') x y)

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

50+

51+ abs (S1D' x) = S1D' (abs x)

52+ abs (S2D' x) = S2D' (abs x)

53+ abs (S3D' x) = S3D' (fmap abs x)

54+

55+ signum (S1D' x) = S1D' (signum x)

56+ signum (S2D' x) = S2D' (signum x)

57+ signum (S3D' x) = S3D' (fmap signum x)

58+

59+ fromInteger _ = error "Unimplemented: fromInteger on Shape"

60+

61+-- | Given a Shape n, these are the possible data structures with that shape.

62+data S' (n :: Shape) where

63+ S1D' :: (KnownNat o) => R o -> S' ('D1 o)

64+ S2D' :: (KnownNat rows, KnownNat columns) => L rows columns -> S' ('D2 rows columns)

65+ S3D' :: (KnownNat rows, KnownNat columns, KnownNat depth) => Vector depth (L rows columns) -> S' ('D3 rows columns depth)

66+

67+instance Show (S' n) where

68+ show (S1D' a) = "S1D' " ++ show a

69+ show (S2D' a) = "S2D' " ++ show a

70+ show (S3D' a) = "S3D' " ++ show a

71+

72+-- | Singleton for Shape

73+class KnownShape (n :: Shape) where

74+ shapeSing :: Proxy n

75+

76+instance KnownShape ('D1 n) where

77+ shapeSing = Proxy

78+

79+instance KnownShape ('D2 n m) where

80+ shapeSing = Proxy

81+

82+instance KnownShape ('D3 l n m) where

83+ shapeSing = Proxy

src/Grenade/Core/Vector.hsnew file+53

@@ -0,0 +1,53 @@

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+

11+module Grenade.Core.Vector (

12+ Vector

13+ , vectorZip

14+ , vecToList

15+ , mkVector

16+ ) where

17+

18+import Data.Proxy

19+import GHC.TypeLits

20+

21+-- | A more specific Tagged type, ensuring that a list

22+-- is equal to the Nat value.

23+newtype Vector (n :: Nat) a = Vector [a]

24+

25+instance Foldable (Vector n) where

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

27+

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

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

30+

31+instance Functor (Vector n) where

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

33+

34+instance Show a => Show (Vector n a) where

35+ showsPrec d = showsPrec d . vecToList

36+

37+instance Eq a => Eq (Vector n a) where

38+ (Vector as) == (Vector bs) = as == bs

39+

40+mkVector :: forall n a. KnownNat n => [a] -> Vector n a

41+mkVector as

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

43+ la = length as

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

48+

49+vecToList :: Vector n a -> [a]

50+vecToList (Vector as) = as

51+

52+vectorZip :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c

53+vectorZip f (Vector as) (Vector bs) = Vector (zipWith f as bs)

src/Grenade/Layers/Convolution.hsnew file+276

@@ -0,0 +1,276 @@

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+{-# LANGUAGE PatternGuards #-}

13+

14+module Grenade.Layers.Convolution (

15+ Convolution (..)

16+ , randomConvolution

17+ , im2col

18+ , vid2col

19+ , col2im

20+ , col2vid

21+ , fittingStarts

22+ ) where

23+

24+import Control.Monad.Random hiding (fromList)

25+import Data.Maybe

26+import Data.Proxy

27+import Data.Singletons.TypeLits

28+import GHC.TypeLits

29+

30+import Numeric.LinearAlgebra hiding (uniformSample, konst)

31+import qualified Numeric.LinearAlgebra as LA

32+import Numeric.LinearAlgebra.Static hiding ((|||), build, toRows)

33+

34+import Grenade.Core.Network

35+import Grenade.Core.Shape

36+import Grenade.Core.Vector

37+

38+-- | A convolution layer for a neural network.

39+-- This uses the im2col convolution trick popularised by Caffe, which essentially turns the

40+-- many, many, many, many loop convolution into a single matrix multiplication.

41+--

42+-- The convolution layer takes all of the kernels for the convolution, which are flattened

43+-- and then put into columns in the matrix.

44+--

45+-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:

46+-- `out = (in - kernel) / stride + 1` for both dimensions.

47+--

48+-- One probably shouldn't build their own layer, but rather use the randomConvolution function.

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

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

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

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

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

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

55+ -> * where

56+ Convolution :: ( KnownNat channels

57+ , KnownNat filters

58+ , KnownNat kernelRows

59+ , KnownNat kernelColumns

60+ , KnownNat strideRows

61+ , KnownNat strideColumns

62+ , KnownNat kernelFlattened

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

64+ => !(L kernelFlattened filters) -- ^ The kernel filter weights

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

66+ -> Convolution channels filters kernelRows kernelColumns strideRows strideColumns

67+

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

69+ show (Convolution a _) = renderConv a

70+ where

71+ renderConv mm =

72+ let m = extract mm

73+ ky = fromIntegral $ natVal (Proxy :: Proxy k)

74+ rs = LA.toColumns m

75+ ms = map (take ky) $ toLists . reshape ky <$> rs

76+

77+ render n' | n' <= 0.2 = ' '

78+ | n' <= 0.4 = '.'

79+ | n' <= 0.6 = '-'

80+ | n' <= 0.8 = '='

81+ | otherwise = '#'

82+

83+ px = (fmap . fmap . fmap) render ms

84+ in unlines $ foldl1 (zipWith (\a' b' -> a' ++ " | " ++ b')) $ px

85+

86+randomConvolution :: ( MonadRandom m

87+ , KnownNat channels

88+ , KnownNat filters

89+ , KnownNat kernelRows

90+ , KnownNat kernelColumns

91+ , KnownNat strideRows

92+ , KnownNat strideColumns

93+ , KnownNat kernelFlattened

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

95+ => m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

96+randomConvolution = do

97+ s :: Int <- getRandom

98+ let wN = uniformSample s (-1) 1

99+ mm = konst 0

100+ return $ Convolution wN mm

101+

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

103+instance ( Monad m

104+ , KnownNat kernelRows

105+ , KnownNat kernelCols

106+ , KnownNat filters

107+ , KnownNat strideRows

108+ , KnownNat strideCols

109+ , KnownNat inputRows

110+ , KnownNat inputCols

111+ , KnownNat outputRows

112+ , KnownNat outputCols

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

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

115+ ) => Layer m (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where

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

117+ let ex = extract input

118+ ek = extract kernel

119+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

120+ ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

121+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

122+ sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

123+ ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

124+ oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

125+ c = im2col kx ky sx sy ex

126+ mt = c LA.<> ek

127+ r = col2vid 1 1 1 1 ox oy mt

128+ rs = fmap (fromJust . create) r

129+ in return . S3D' $ mkVector rs

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

131+ let ex = extract input

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

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

134+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

135+ ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

136+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

137+ sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

138+ ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

139+ oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

140+ c = im2col kx ky sx sy ex

141+

142+ eo = vecToList $ fmap extract dEdy

143+ ek = extract kernel

144+

145+ vs = vid2col 1 1 1 1 ox oy eo

146+

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

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

149+ wd = konst (0.0005 * rate) * kernel

150+ rM = kernel + mm - wd

151+

152+ dW = vs LA.<> tr ek

153+

154+ xW = col2im kx ky sx sy ix iy dW

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

156+

157+

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

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

160+instance ( Monad m

161+ , KnownNat kernelRows

162+ , KnownNat kernelCols

163+ , KnownNat filters

164+ , KnownNat strideRows

165+ , KnownNat strideCols

166+ , KnownNat inputRows

167+ , KnownNat inputCols

168+ , KnownNat outputRows

169+ , KnownNat outputCols

170+ , KnownNat channels

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

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

173+ ) => Layer m (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where

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

175+ let ex = vecToList $ fmap extract input

176+ ek = extract kernel

177+ ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)

178+ iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)

179+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

180+ ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

181+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

182+ sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

183+ ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

184+ oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

185+ c = vid2col kx ky sx sy ix iy ex

186+ mt = c LA.<> ek

187+ r = col2vid 1 1 1 1 ox oy mt

188+ rs = fmap (fromJust . create) r

189+ in return . S3D' $ mkVector rs

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

191+ let ex = vecToList $ fmap extract input

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

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

194+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

195+ ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)

196+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

197+ sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)

198+ ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

199+ oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)

200+ c = vid2col kx ky sx sy ix iy ex

201+

202+ eo = vecToList $ fmap extract dEdy

203+ ek = extract kernel

204+

205+ vs = vid2col 1 1 1 1 ox oy eo

206+

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

212+ dW = vs LA.<> tr ek

213+

214+ xW = col2vid kx ky sx sy ix iy dW

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

216+

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

218+im2col nrows ncols srows scols m =

219+ let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols

220+ in im2colFit starts nrows ncols m

221+

222+im2colFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double

223+im2colFit starts nrows ncols m =

224+ let imRows = fmap (\start -> flatten $ subMatrix start (nrows, ncols) m) starts

225+ in fromRows imRows

226+

227+vid2col :: Int -> Int -> Int -> Int -> Int -> Int -> [Matrix Double] -> Matrix Double

228+vid2col nrows ncols srows scols inputrows inputcols ms =

229+ let starts = fittingStarts inputrows nrows srows inputcols ncols scols

230+ subs = fmap (im2colFit starts nrows ncols) ms

231+ in foldl1 (|||) subs

232+

233+col2vid :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> [Matrix Double]

234+col2vid nrows ncols srows scols drows dcols m =

235+ let starts = fittingStart (cols m) (nrows * ncols) (nrows * ncols)

236+ r = rows m

237+ mats = fmap (\s -> subMatrix (0,s) (r, nrows * ncols) m) starts

238+ colSts = fittingStarts drows nrows srows dcols ncols scols

239+ in fmap (col2imfit colSts nrows ncols drows dcols) mats

240+

241+col2im :: Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

242+col2im krows kcols srows scols drows dcols m =

243+ let starts = fittingStarts drows krows srows dcols kcols scols

244+ in col2imfit starts krows kcols drows dcols m

245+

246+col2imfit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

247+col2imfit starts krows kcols drows dcols m =

248+ let indicies = fmap (\[a,b] -> (a,b)) $ sequence [[0..(krows-1)], [0..(kcols-1)]]

249+ convs = fmap (zip indicies . toList) . toRows $ m

250+ pairs = zip convs starts

251+ accums = concat $ fmap (\(conv',(stx',sty')) -> fmap (\((ix,iy), val) -> ((ix + stx', iy + sty'), val)) conv') pairs

252+ in accum (LA.konst 0 (drows, dcols)) (+) accums

253+

254+

255+-- | These functions are not even remotely safe, but it's only called from the statically typed

256+-- commands, so we should be good ?!?!?

257+-- Returns the starting sub matrix locations which fit inside the larger matrix for the

258+-- convolution. Takes into account the stride and kernel size.

259+fittingStarts :: Int -> Int -> Int -> Int -> Int -> Int -> [(Int,Int)]

260+fittingStarts nrows kernelrows steprows ncols kernelcols stepcolsh =

261+ let rs = fittingStart nrows kernelrows steprows

262+ cs = fittingStart ncols kernelcols stepcolsh

263+ ls = sequence [rs, cs]

264+ in fmap (\[a,b] -> (a,b)) ls

265+

266+-- | Returns the starting sub vector which fit inside the larger vector for the

267+-- convolution. Takes into account the stride and kernel size.

268+fittingStart :: Int -> Int -> Int -> [Int]

269+fittingStart width kernel steps =

270+ let go left | left + kernel < width

271+ = left : go (left + steps)

272+ | left + kernel == width

273+ = left : []

274+ | otherwise

275+ = error "Kernel and step do not fit in matrix."

276+ in go 0

src/Grenade/Layers/Dropout.hsnew file+32

@@ -0,0 +1,32 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+

10+module Grenade.Layers.Dropout (

11+ Dropout (..)

12+ ) where

13+

14+import Control.Monad.Random hiding (fromList)

15+

16+import GHC.TypeLits

17+import Grenade.Core.Shape

18+import Grenade.Core.Network

19+

20+import Numeric.LinearAlgebra.Static

21+

22+-- Dropout layer help to reduce overfitting.

23+-- Idea here is that the vector is a shape of 1s and 0s, which we multiply the input by.

24+-- After backpropogation, we return a new matrix/vector, with different bits dropped out.

25+-- Double is the proportion to drop in each training iteration (like 1% or 5% would be

26+-- reasonable).

27+data Dropout o = Dropout Double (R o)

28+ deriving Show

29+

30+instance (MonadRandom m, KnownNat i) => Layer m (Dropout i) ('D1 i) ('D1 i) where

31+ runForwards _ _= error "todo"

32+ runBackards _ _ _ _ = error "todo"

src/Grenade/Layers/Flatten.hsnew file+45

@@ -0,0 +1,45 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+

10+module Grenade.Layers.Flatten (

11+ FlattenLayer (..)

12+ ) where

13+

14+import Data.Proxy

15+import Data.Singletons.TypeLits

16+import GHC.TypeLits

17+

18+import Numeric.LinearAlgebra.Static

19+import Numeric.LinearAlgebra.Data as LA (flatten, toList, takesV, reshape, vjoin)

20+

21+import Grenade.Core.Vector

22+import Grenade.Core.Shape

23+import Grenade.Core.Network

24+

25+data 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

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

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

31+

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

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

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

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

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

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

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

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

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

41+ return (FlattenLayer, S3D' ls')

42+

43+raiseShapeError :: Maybe a -> a

44+raiseShapeError (Just x) = x

45+raiseShapeError Nothing = error "Static shape creation from Flatten layer produced the wrong result"

src/Grenade/Layers/FullyConnected.hsnew file+56

@@ -0,0 +1,56 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+

10+module Grenade.Layers.FullyConnected (

11+ FullyConnected (..)

12+ , randomFullyConnected

13+ ) where

14+

15+import Control.Monad.Random hiding (fromList)

16+

17+import Data.Singletons.TypeLits

18+

19+import Numeric.LinearAlgebra.Static

20+

21+import Grenade.Core.Network

22+import Grenade.Core.Shape

23+

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

25+data FullyConnected i o = FullyConnected

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

27+ !(L o i) -- Activation weights

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

29+

30+instance Show (FullyConnected i o) where

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

32+

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

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

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

36+

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

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

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

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

41+ wd' = konst (0.0005 * rate) * wN

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

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

44+ -- calcluate derivatives for next step

45+ dWs = tr wN #> dEdy

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

47+

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

49+ => m (FullyConnected i o)

50+randomFullyConnected = do

51+ s1 :: Int <- getRandom

52+ s2 :: Int <- getRandom

53+ let wB = randomVector s1 Uniform * 2 - 1

54+ wN = uniformSample s2 (-1) 1

55+ mm = konst 0

56+ return $ FullyConnected wB wN mm

src/Grenade/Layers/Fuse.hsnew file+45

@@ -0,0 +1,45 @@

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+

14+

15+module Grenade.Layers.Fuse (

16+ Fuse (..)

17+ ) where

18+

19+import Grenade.Core.Network

20+import Grenade.Core.Shape

21+

22+-- | Fuse two layers into one layer.

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

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

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

28+ => !x

29+ -> !y

30+ -> Fuse m i h o

31+infixr 5 :$$

32+

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

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

35+

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

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

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

39+ runForwards y yInput

40+

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

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

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

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

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

src/Grenade/Layers/Logit.hsnew file+45

@@ -0,0 +1,45 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+

10+module Grenade.Layers.Logit (

11+ Logit (..)

12+ ) where

13+

14+import Data.Singletons.TypeLits

15+import Grenade.Core.Network

16+import Grenade.Core.Vector

17+import Grenade.Core.Shape

18+

19+-- | A Logit layer.

20+-- A layer which can act between any shape of the same dimension, perfoming an sigmoid function.

21+-- This layer should be used as the output layer of a network for logistic regression (classification)

22+-- problems.

23+data Logit = Logit

24+ deriving Show

25+

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

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

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

29+

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

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

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

33+

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

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

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

37+

38+

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

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

41+

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

43+logistic' x = logix * (1 - logix)

44+ where

45+ logix = logistic x

src/Grenade/Layers/Pooling.hsnew file+163

@@ -0,0 +1,163 @@

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.Pooling (

14+ Pooling (..)

15+ , poolForward

16+ , poolBackward

17+ ) where

18+

19+import Data.Maybe

20+import Data.Proxy

21+import Data.Singletons.TypeLits

22+import GHC.TypeLits

23+

24+import Grenade.Core.Network

25+import Grenade.Core.Shape

26+import Grenade.Core.Vector

27+import Grenade.Layers.Convolution

28+

29+import Numeric.LinearAlgebra hiding (uniformSample)

30+import qualified Numeric.LinearAlgebra as LA

31+import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)

32+

33+-- | A pooling layer for a neural network.

34+-- Does a max pooling, looking over a kernel similarly to the convolution network, but returning

35+-- maxarg only. This layer is often used to provide minor amounts of translational invariance.

36+--

37+-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:

38+-- `out = (in - kernel) / stride + 1` for both dimensions.

39+--

40+data Pooling :: Nat

41+ -> Nat

42+ -> Nat

43+ -> Nat -> * where

44+ Pooling :: ( KnownNat kernelRows

45+ , KnownNat kernelColumns

46+ , KnownNat strideRows

47+ , KnownNat strideColumns

48+ ) => Pooling kernelRows kernelColumns strideRows strideColumns

49+

50+instance Show (Pooling k k' s s') where

51+ show Pooling = "Pooling"

52+

53+

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

55+instance ( Monad m

56+ , KnownNat kernelRows

57+ , KnownNat kernelColumns

58+ , KnownNat strideRows

59+ , KnownNat strideColumns

60+ , KnownNat inputRows

61+ , KnownNat inputColumns

62+ , KnownNat outputRows

63+ , KnownNat outputColumns

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

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

66+ ) => Layer m (Pooling kernelRows kernelColumns strideRows strideColumns) ('D2 inputRows inputColumns) ('D2 outputRows outputColumns) where

67+ runForwards Pooling (S2D' input) =

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

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

70+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

71+ sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)

72+ ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

73+ oy = fromIntegral $ natVal (Proxy :: Proxy outputColumns)

74+ ex = extract input

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

76+ rs = fromJust . create $ r

77+ in return . S2D' $ rs

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

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

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

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

82+ sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)

83+ ex = extract input

84+ eo = extract dEdy

85+ vs = poolBackward kx ky sx sy ex eo

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

87+

88+

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

90+instance ( Monad m

91+ , KnownNat kernelRows

92+ , KnownNat kernelColumns

93+ , KnownNat strideRows

94+ , KnownNat strideColumns

95+ , KnownNat inputRows

96+ , KnownNat inputColumns

97+ , KnownNat outputRows

98+ , KnownNat outputColumns

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

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

101+ ) => Layer m (Pooling kernelRows kernelColumns strideRows strideColumns) ('D3 inputRows inputColumns channels) ('D3 outputRows outputColumns channels) where

102+ runForwards Pooling (S3D' input) =

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

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

105+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)

106+ ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)

107+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

108+ sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)

109+ ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)

110+ oy = fromIntegral $ natVal (Proxy :: Proxy outputColumns)

111+ ex = fmap extract input

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

113+ rs = fmap (fromJust . create) r

114+ in return . S3D' $ rs

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

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

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

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

119+ ky = fromIntegral $ natVal (Proxy :: Proxy kernelColumns)

120+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)

121+ sy = fromIntegral $ natVal (Proxy :: Proxy strideColumns)

122+ ex = fmap extract input

123+ eo = fmap extract dEdy

124+ ez = vectorZip (,) ex eo

125+ vs = poolBackwardList kx ky sx sy ix iy ez

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

127+

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

129+poolForward nrows ncols srows scols outputRows outputCols m =

130+ let starts = fittingStarts (rows m) nrows srows (cols m) ncols scols

131+ in poolForwardFit starts nrows ncols outputRows outputCols m

132+

133+poolForwardList :: Functor f => Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> f (Matrix Double) -> f (Matrix Double)

134+poolForwardList nrows ncols srows scols inRows inCols outputRows outputCols ms =

135+ let starts = fittingStarts inRows nrows srows inCols ncols scols

136+ in poolForwardFit starts nrows ncols outputRows outputCols <$> ms

137+

138+poolForwardFit :: [(Int,Int)] -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double

139+poolForwardFit starts nrows ncols _ outputCols m =

140+ let els = fmap (\start -> maxElement $ subMatrix start (nrows, ncols) m) starts

141+ in LA.matrix outputCols els

142+

143+poolBackward :: Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double

144+poolBackward krows kcols srows scols inputMatrix gradientMatrix =

145+ let inRows = (rows inputMatrix)

146+ inCols = (cols inputMatrix)

147+ starts = fittingStarts inRows krows srows inCols kcols scols

148+ in poolBackwardFit starts krows kcols inputMatrix gradientMatrix

149+

150+poolBackwardList :: Functor f => Int -> Int -> Int -> Int -> Int -> Int -> f (Matrix Double, Matrix Double) -> f (Matrix Double)

151+poolBackwardList krows kcols srows scols inRows inCols inputMatrices =

152+ let starts = fittingStarts inRows krows srows inCols kcols scols

153+ in (uncurry $ poolBackwardFit starts krows kcols) <$> inputMatrices

154+

155+poolBackwardFit :: [(Int,Int)] -> Int -> Int -> Matrix Double -> Matrix Double -> Matrix Double

156+poolBackwardFit starts krows kcols inputMatrix gradientMatrix =

157+ let inRows = (rows inputMatrix)

158+ inCols = (cols inputMatrix)

159+ inds = fmap (\start -> maxIndex $ subMatrix start (krows, kcols) inputMatrix) starts

160+ grads = toList $ flatten gradientMatrix

161+ grads' = zip3 starts grads inds

162+ accums = fmap (\((stx',sty'),grad,(inx, iny)) -> ((stx' + inx, sty' + iny), grad)) grads'

163+ in accum (LA.konst 0 (inRows, inCols)) (+) accums

src/Grenade/Layers/Relu.hsnew file+49

@@ -0,0 +1,49 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+

10+module Grenade.Layers.Relu (

11+ Relu (..)

12+ ) where

13+

14+import GHC.TypeLits

15+import Grenade.Core.Vector

16+import Grenade.Core.Network

17+import Grenade.Core.Shape

18+

19+import qualified Numeric.LinearAlgebra.Static as LAS

20+

21+-- | A rectifying linear unit.

22+-- A layer which can act between any shape of the same dimension, acting as a

23+-- diode on every neuron individually.

24+data Relu = Relu

25+ deriving Show

26+

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

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

29+ where

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

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

32+ where

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

34+

35+instance (Monad m, KnownNat i, KnownNat j) => Layer m Relu ('D2 i j) ('D2 i j) where

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

37+ where

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

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

40+ where

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

42+

43+instance (Monad m, KnownNat i, KnownNat j, KnownNat k) => Layer m Relu ('D3 i j k) ('D3 i j k) where

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

45+ where

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

48+ where

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

src/Grenade/Layers/Tanh.hsnew file+37

@@ -0,0 +1,37 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE StandaloneDeriving #-}

5+{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+

10+module Grenade.Layers.Tanh (

11+ Tanh (..)

12+ ) where

13+

14+import GHC.TypeLits

15+import Grenade.Core.Vector

16+import Grenade.Core.Network

17+import Grenade.Core.Shape

18+

19+-- | A Tanh layer.

20+-- A layer which can act between any shape of the same dimension, perfoming an tanh function.s

21+data Tanh = Tanh

22+ deriving Show

23+

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

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

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

27+

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

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

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

31+

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

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

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

35+

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

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

test/Test/Grenade/Layers/Convolution.hsnew file+251

@@ -0,0 +1,251 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

5+module Test.Grenade.Layers.Convolution where

6+

7+import Control.Monad.Identity

8+

9+import Grenade.Core.Shape

10+import Grenade.Core.Vector as Grenade

11+import Grenade.Core.Network

12+import Grenade.Layers.Convolution

13+

14+import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

15+import qualified Numeric.LinearAlgebra.Static as HStatic

16+

17+import Test.QuickCheck hiding ((><))

18+

19+prop_im2col_no_stride = once $

20+ let input = (3><4)

21+ [ 1.0, 2.0, 3.0, 4.0

22+ , 5.0, 6.0, 7.0, 8.0

23+ , 9.0, 10.0, 11.0, 12.0 ]

24+ expected = (6><4)

25+ [ 1.0, 2.0, 5.0, 6.0

26+ , 2.0, 3.0, 6.0, 7.0

27+ , 3.0, 4.0, 7.0, 8.0

28+ , 5.0, 6.0, 9.0, 10.0

29+ , 6.0, 7.0, 10.0, 11.0

30+ , 7.0, 8.0, 11.0, 12.0 ]

31+ out = im2col 2 2 1 1 input

32+ in expected === out

33+

34+prop_im2col_stride = once $

35+ let input = (3><4)

36+ [ 1.0, 2.0, 3.0, 4.0

37+ , 5.0, 6.0, 7.0, 8.0

38+ , 9.0, 10.0, 11.0, 12.0 ]

39+ expected = (4><4)

40+ [ 1.0, 2.0, 5.0, 6.0

41+ , 3.0, 4.0, 7.0, 8.0

42+ , 5.0, 6.0, 9.0, 10.0

43+ , 7.0, 8.0, 11.0, 12.0 ]

44+ out = im2col 2 2 1 2 input

45+ in expected === out

46+

47+prop_im2col_other = once $

48+ let input = (3><4)

49+ [ 1.0, 2.0, 3.0, 4.0

50+ , 5.0, 6.0, 7.0, 8.0

51+ , 9.0, 10.0, 11.0, 12.0 ]

52+ expected = (2><6)

53+ [ 1.0, 2.0, 5.0, 6.0 , 9.0, 10.0

54+ , 3.0, 4.0, 7.0, 8.0 , 11.0 ,12.0 ]

55+ out = im2col 3 2 1 2 input

56+ in expected === out

57+

58+-- If there's no overlap (stride is the same size as the kernel)

59+-- then col2im . im2col should be symmetric.

60+prop_im2col_sym_on_same_stride = once $

61+ let input = (3><4)

62+ [ 1.0, 2.0, 3.0, 4.0

63+ , 5.0, 6.0, 7.0, 8.0

64+ , 9.0, 10.0, 11.0, 12.0 ]

65+ out = col2im 3 2 3 2 3 4 . im2col 3 2 3 2 $ input

66+ in input === out

67+

68+-- If there is an overlap, then the gradient passed back should be

69+-- the sum of the gradients across the filters.

70+prop_im2col_col2im_additive = once $

71+ let input = (3><4)

72+ [ 1.0, 1.0, 1.0, 1.0

73+ , 1.0, 1.0, 1.0, 1.0

74+ , 1.0, 1.0, 1.0, 1.0 ]

75+ expected = (3><4)

76+ [ 1.0, 2.0, 2.0, 1.0

77+ , 2.0, 4.0, 4.0, 2.0

78+ , 1.0, 2.0, 2.0, 1.0 ]

79+ out = col2im 2 2 1 1 3 4 . im2col 2 2 1 1 $ input

80+ in expected === out

81+

82+prop_simple_conv_forwards = once $

83+ -- Create a convolution kernel with 4 filters.

84+ -- [ 1, 0 [ 0, 1 [ 0, 1 [ 0, 0

85+ -- , 0,-1 ] ,-1, 0 ] , 1, 0 ] ,-1,-1 ]

86+ let myKernel = (HStatic.matrix

87+ [ 1.0, 0.0, 0.0, 0.0

88+ , 0.0, 1.0, 1.0, 0.0

89+ , 0.0, -1.0, 1.0, -1.0

90+ ,-1.0, 0.0, 0.0, -1.0 ] :: HStatic.L 4 4)

91+ zeroKernel = (HStatic.matrix

92+ [ 0.0, 0.0, 0.0, 0.0

93+ , 0.0, 0.0, 0.0, 0.0

94+ , 0.0, 0.0, 0.0, 0.0

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

96+ --expectedKernel = (HStatic.matrix

97+ -- [ 0.0, 0.0, 0.0, -2.0

98+ -- ,-2.0, 1.0, 1.0, -5.0

99+ -- ,-3.0, -1.0, 1.0, -5.0

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

101+

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

103+

104+ input = S2D' (HStatic.matrix

105+ [ 1.0, 2.0, 5.0

106+ , 3.0, 4.0, 6.0] :: HStatic.L 2 3)

107+

108+ expect = ([(HStatic.matrix

109+ [ -3.0 , -4.0 ] :: HStatic.L 1 2)

110+ ,(HStatic.matrix

111+ [ -1.0 , 1.0 ] :: HStatic.L 1 2)

112+ ,(HStatic.matrix

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

114+ ,(HStatic.matrix

115+ [ -7.0 , -10.0 ] :: HStatic.L 1 2)]) :: [HStatic.L 1 2]

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

117+

118+ grad = S3D' ( mkVector

119+ [(HStatic.matrix

120+ [ 1 , 0 ] :: HStatic.L 1 2)

121+ ,(HStatic.matrix

122+ [ 0 , 0 ] :: HStatic.L 1 2)

123+ ,(HStatic.matrix

124+ [ 0 , 0 ] :: HStatic.L 1 2)

125+ ,(HStatic.matrix

126+ [ 0 , 1 ] :: HStatic.L 1 2)] ) :: S' ('D3 1 2 4)

127+

128+ expectBack = (HStatic.matrix

129+ [ 1.0, 0.0, 0.0

130+ , 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))

132+

133+ in case (out, inX, nc) of

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

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

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

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

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

139+

140+

141+prop_vid2col_no_stride = once $

142+ let input = [(3><4)

143+ [ 1.0, 2.0, 3.0, 4.0

144+ , 5.0, 6.0, 7.0, 8.0

145+ , 9.0, 10.0, 11.0, 12.0 ]

146+ , (3><4)

147+ [ 21.0, 22.0, 23.0, 24.0

148+ , 25.0, 26.0, 27.0, 28.0

149+ , 29.0, 30.0, 31.0, 32.0 ] ]

150+ expected = (6><8)

151+ [ 1.0, 2.0, 5.0, 6.0 , 21.0, 22.0, 25.0, 26.0

152+ , 2.0, 3.0, 6.0, 7.0 , 22.0, 23.0, 26.0, 27.0

153+ , 3.0, 4.0, 7.0, 8.0 , 23.0, 24.0, 27.0, 28.0

154+ , 5.0, 6.0, 9.0, 10.0 , 25.0, 26.0, 29.0, 30.0

155+ , 6.0, 7.0, 10.0, 11.0 , 26.0, 27.0, 30.0, 31.0

156+ , 7.0, 8.0, 11.0, 12.0 , 27.0, 28.0, 31.0, 32.0 ]

157+ out = vid2col 2 2 1 1 3 4 input

158+ in expected === out

159+

160+prop_vid2col_stride = once $

161+ let input = [(3><4)

162+ [ 1.0, 2.0, 3.0, 4.0

163+ , 5.0, 6.0, 7.0, 8.0

164+ , 9.0, 10.0, 11.0, 12.0 ]

165+ , (3><4)

166+ [ 21.0, 22.0, 23.0, 24.0

167+ , 25.0, 26.0, 27.0, 28.0

168+ , 29.0, 30.0, 31.0, 32.0 ] ]

169+ expected = (4><8)

170+ [ 1.0, 2.0, 5.0, 6.0 , 21.0, 22.0, 25.0, 26.0

171+ , 3.0, 4.0, 7.0, 8.0 , 23.0, 24.0, 27.0, 28.0

172+ , 5.0, 6.0, 9.0, 10.0 , 25.0, 26.0, 29.0, 30.0

173+ , 7.0, 8.0, 11.0, 12.0 , 27.0, 28.0, 31.0, 32.0 ]

174+ out = vid2col 2 2 1 2 3 4 input

175+ in expected === out

176+

177+

178+prop_vid2col_invert = once $

179+ let input = [(3><4)

180+ [ 1.0, 2.0, 3.0, 4.0

181+ , 5.0, 6.0, 7.0, 8.0

182+ , 9.0, 10.0, 11.0, 12.0 ]

183+ , (3><4)

184+ [ 21.0, 22.0, 23.0, 24.0

185+ , 25.0, 26.0, 27.0, 28.0

186+ , 29.0, 30.0, 31.0, 32.0 ] ]

187+ out = col2vid 3 2 3 2 3 4 . vid2col 3 2 3 2 3 4 $ input

188+ in input === out

189+

190+-- This test show that 2D convs act the same

191+-- 3D convs with one layer

192+prop_single_conv_forwards = once $

193+ -- Create a convolution kernel with 4 filters.

194+ -- [ 1, 0 [ 0, 1 [ 0, 1 [ 0, 0

195+ -- , 0,-1 ] ,-1, 0 ] , 1, 0 ] ,-1,-1 ]

196+ let myKernel = (HStatic.matrix

197+ [ 1.0, 0.0, 0.0, 0.0

198+ , 0.0, 1.0, 1.0, 0.0

199+ , 0.0, -1.0, 1.0, -1.0

200+ ,-1.0, 0.0, 0.0, -1.0 ] :: HStatic.L 4 4)

201+ zeroKernel = (HStatic.matrix

202+ [ 0.0, 0.0, 0.0, 0.0

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+ --expectedKernel = (HStatic.matrix

207+ -- [ 0.0, 0.0, 0.0, -2.0

208+ -- ,-2.0, 1.0, 1.0, -5.0

209+ -- ,-3.0, -1.0, 1.0, -5.0

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

211+

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

213+

214+ input = S3D' ( mkVector [HStatic.matrix

215+ [ 1.0, 2.0, 5.0

216+ , 3.0, 4.0, 6.0] :: HStatic.L 2 3] ) :: S' ('D3 2 3 1)

217+

218+ expect = ([(HStatic.matrix

219+ [ -3.0 , -4.0 ] :: HStatic.L 1 2)

220+ ,(HStatic.matrix

221+ [ -1.0 , 1.0 ] :: HStatic.L 1 2)

222+ ,(HStatic.matrix

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

224+ ,(HStatic.matrix

225+ [ -7.0 , -10.0 ] :: HStatic.L 1 2)]) :: [HStatic.L 1 2]

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

227+

228+ grad = S3D' ( mkVector

229+ [(HStatic.matrix

230+ [ 1 , 0 ] :: HStatic.L 1 2)

231+ ,(HStatic.matrix

232+ [ 0 , 0 ] :: HStatic.L 1 2)

233+ ,(HStatic.matrix

234+ [ 0 , 0 ] :: HStatic.L 1 2)

235+ ,(HStatic.matrix

236+ [ 0 , 1 ] :: HStatic.L 1 2)] ) :: S' ('D3 1 2 4)

237+

238+ expectBack = (HStatic.matrix

239+ [ 1.0, 0.0, 0.0

240+ , 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+

243+ in case (out, inX, nc) of

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

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

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

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

248+

249+return []

250+tests :: IO Bool

251+tests = $quickCheckAll

test/Test/Grenade/Layers/Pooling.hsnew file+56

@@ -0,0 +1,56 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

5+module Test.Grenade.Layers.Pooling where

6+

7+import Grenade.Layers.Pooling

8+

9+import Numeric.LinearAlgebra hiding (uniformSample, konst, (===))

10+

11+import Test.QuickCheck hiding ((><))

12+

13+prop_pool = once $

14+ let input = (3><4)

15+ [ 1.0, 2.0, 3.0, 4.0

16+ , 5.0, 6.0, 7.0, 8.0

17+ , 9.0, 10.0, 11.0, 12.0 ]

18+ expected = (2><3)

19+ [ 6.0, 7.0, 8.0

20+ , 10.0, 11.0, 12.0 ]

21+ out = poolForward 2 2 1 1 2 3 input

22+ in expected === out

23+

24+prop_pool_backwards = once $

25+ let input = (3><4)

26+ [ 1.0, 2.0, 3.0, 4.0

27+ , 5.0, 6.0, 7.0, 8.0

28+ , 9.0, 10.0, 11.0, 12.0 ]

29+ grads = (2><3)

30+ [ -6.0, -7.0, -8.0

31+ , -10.0, -11.0, -12.0 ]

32+ expected = (3><4)

33+ [ 0.0, 0.0, 0.0, 0.0

34+ , 0.0, -6.0, -7.0, -8.0

35+ , 0.0,-10.0,-11.0,-12.0 ]

36+ out = poolBackward 2 2 1 1 input grads

37+ in expected === out

38+

39+prop_pool_backwards_additive = once $

40+ let input = (3><4)

41+ [ 4.0, 2.0, 3.0, 4.0

42+ , 0.0, 0.0, 7.0, 8.0

43+ , 9.0, 0.0, 0.0, 0.0 ]

44+ grads = (2><3)

45+ [ -6.0, -7.0, -8.0

46+ , -10.0, -11.0, -12.0 ]

47+ expected = (3><4)

48+ [-6.0, 0.0, 0.0, 0.0

49+ , 0.0, 0.0,-18.0,-20.0

50+ ,-10.0, 0.0, 0.0, 0.0 ]

51+ out = poolBackward 2 2 1 1 input grads

52+ in expected === out

53+

54+return []

55+tests :: IO Bool

56+tests = $quickCheckAll

test/test.hsnew file+11

@@ -0,0 +1,11 @@

1+import Disorder.Core.Main

2+

3+import qualified Test.Grenade.Layers.Pooling as Test.Grenade.Layers.Pooling

4+import qualified Test.Grenade.Layers.Convolution as Test.Grenade.Layers.Convolution

5+

6+main :: IO ()

7+main =

8+ disorderMain [

9+ Test.Grenade.Layers.Pooling.tests

10+ , Test.Grenade.Layers.Convolution.tests

11+ ]