git.iko.soy/grenade
on master help sign in
Initial commit
08afd74Huw Campbell
.gitmodulesnew file+15
compare with master
unifiedsplit
@@ -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>
6+copyright: (c) 2015 Ambiata.
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+ ]