HuwCampbell/grenade
1
1
Fork 0
mirror of https://github.com/HuwCampbell/grenade.git synced 2024-11-22 06:55:13 +03:00
Code Issues Projects Releases Wiki Activity

Add extra composition

Browse Source
This commit is contained in:
Huw Campbell 2017-02-01 22:11:55 +11:00
parent 32f3e317e8
commit a23103ee7b
33 changed files with 432 additions and 224 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
bench/bench-lstm.hs
View File

@ -22,8 +22,8 @@ main = do
let upIn512 :: H.R 262144 = H.randomVector 1 H.Uniform * 2 - 1
defaultMain [
bgroup "lstm" [ bench "forwards-60" $ nf (nfT2 . uncurry (testRun60 layer60)) (rec60, input40)
, bench "forwards-512" $ nf (nfT2 . uncurry (testRun512 layer512)) (rec512, input40)
bgroup "lstm" [ bench "forwards-60" $ nf (nfT3 . uncurry (testRun60 layer60)) (rec60, input40)
, bench "forwards-512" $ nf (nfT3 . uncurry (testRun512 layer512)) (rec512, input40)
, bench "backwards-60" $ nf (nfT3 . uncurry4 (testRun60' layer60)) (rec60, input40, rec60, rec60)
, bench "backwards-512" $ nf (nfT3 . uncurry4 (testRun512' layer512)) (rec512, input40, rec512, rec512)
]
@ -36,17 +36,17 @@ main = do
]
]
testRun60 :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> (S ('D1 60), S ('D1 60))
testRun60 :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> ((S ('D1 60), S ('D1 40)), S ('D1 60), S ('D1 60))
testRun60 = runRecurrentForwards
testRun60' :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> S ('D1 60) -> S ('D1 60) -> (Gradient (LSTM 40 60), S ('D1 60), S ('D1 40))
testRun60' = runRecurrentBackwards
testRun60' = curry . runRecurrentBackwards
testRun512 :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> (S ('D1 512), S ('D1 512))
testRun512 :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> ((S ('D1 512), S ('D1 40)), S ('D1 512), S ('D1 512))
testRun512 = runRecurrentForwards
testRun512' :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> S ('D1 512) -> S ('D1 512) -> (Gradient (LSTM 40 512), S ('D1 512), S ('D1 40))
testRun512' = runRecurrentBackwards
testRun512' = curry . runRecurrentBackwards
uncurry4 :: (t -> t1 -> t2 -> t3 -> t4) -> (t, t1, t2, t3) -> t4
uncurry4 f (a,b,c,d) = f a b c d
@ -61,12 +61,11 @@ nfT3 :: (a, b, c) -> (b, c)
nfT3 (!_, !b, !c) = (b, c)
type F = FeedForward
type R = Recurrent
type RecNet = RecurrentNetwork '[ R (LSTM 40 512), R (LSTM 512 40), F (FullyConnected 40 40), F Logit]
'[ 'D1 40, 'D1 512, 'D1 40, 'D1 40, 'D1 40 ]
type RecNet = RecurrentNetwork '[ R (LSTM 40 512), R (LSTM 512 40) ]
'[ 'D1 40, 'D1 512, 'D1 40 ]
type RecInput = RecurrentInputs '[ R (LSTM 40 512), R (LSTM 512 40), F (FullyConnected 40 40), F Logit]
type RecInput = RecurrentInputs '[ R (LSTM 40 512), R (LSTM 512 40) ]
lp :: LearningParameters
lp = LearningParameters 0.1 0 0

5
grenade.cabal
View File

@ -43,6 +43,9 @@ library
exposed-modules:
Grenade
Grenade.Core
Grenade.Core.Layer
Grenade.Core.LearningParameters
Grenade.Core.Network
Grenade.Core.Runner
Grenade.Core.Shape
@ -51,7 +54,6 @@ library
Grenade.Layers.Dropout
Grenade.Layers.FullyConnected
Grenade.Layers.Flatten
Grenade.Layers.Fuse
Grenade.Layers.Logit
Grenade.Layers.Relu
Grenade.Layers.Elu
@ -70,7 +72,6 @@ library
Grenade.Recurrent.Layers.BasicRecurrent
Grenade.Recurrent.Layers.LSTM
Grenade.Recurrent.Layers.Trivial
Grenade.Utils.OneHot

10
main/mnist.hs
View File

@ -33,8 +33,14 @@ import Grenade.Utils.OneHot
-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,
-- this network should get down to about a 1.3% error rate.
type MNIST = Network '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Elu, Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Elu, FlattenLayer, FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]
'[ 'D2 28 28, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10, 'D3 8 8 16, 'D3 4 4 16, 'D3 4 4 16, 'D1 256, 'D1 80, 'D1 80, 'D1 10, 'D1 10]
type MNISTa = Network '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Elu, Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Elu, FlattenLayer ]
'[ 'D2 28 28, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10, 'D3 8 8 16, 'D3 4 4 16, 'D3 4 4 16, 'D1 256 ]
type MNISTb = Network '[ Convolution 1 10 7 7 1 1, Pooling 2 2 2 2, Elu, Convolution 10 16 4 4 1 1, Pooling 2 2 2 2, Elu, FlattenLayer ]
'[ 'D2 28 28, 'D3 22 22 10, 'D3 11 11 10, 'D3 11 11 10, 'D3 8 8 16, 'D3 4 4 16, 'D3 4 4 16, 'D1 256 ]
type MNIST = Network '[ (MNISTa, MNISTb), FullyConnected 256 80, Logit, FullyConnected 80 10, Logit ]
'[ 'D2 28 28, 'D1 256, 'D1 80, 'D1 80, 'D1 10, 'D1 10 ]
randomMnist :: MonadRandom m => m MNIST
randomMnist = randomNetwork

3
src/Grenade.hs
View File

@ -2,6 +2,8 @@ module Grenade (
module X
) where
import Grenade.Core.LearningParameters as X
import Grenade.Core.Layer as X
import Grenade.Core.Network as X
import Grenade.Core.Runner as X
import Grenade.Core.Shape as X
@ -10,7 +12,6 @@ import Grenade.Layers.Dropout as X
import Grenade.Layers.Pad as X
import Grenade.Layers.Pooling as X
import Grenade.Layers.Flatten as X
import Grenade.Layers.Fuse as X
import Grenade.Layers.FullyConnected as X
import Grenade.Layers.Logit as X
import Grenade.Layers.Convolution as X

8
src/Grenade/Core.hs Normal file
View File

@ -0,0 +1,8 @@
module Grenade.Core (
module X
) where
import Grenade.Core.Layer as X
import Grenade.Core.LearningParameters as X
import Grenade.Core.Shape as X
import Grenade.Core.Network as X

82
src/Grenade/Core/Layer.hs Normal file
View File

@ -0,0 +1,82 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-|
Module : Grenade.Core.Network
Description : Core definition a simple neural etwork
Copyright : (c) Huw Campbell, 2016-2017
License : BSD2
Stability : experimental
-}
module Grenade.Core.Layer (
Layer (..)
, UpdateLayer (..)
) where
import Control.Monad.Random (MonadRandom)
import Data.List ( foldl' )
import Data.Singletons
import Grenade.Core.Shape
import Grenade.Core.LearningParameters
-- | Class for updating a layer. All layers implement this, and it is
-- shape independent.
class UpdateLayer x where
{-# MINIMAL runUpdate, createRandom #-}
-- | The type for the gradient for this layer.
-- Unit if there isn't a gradient to pass back.
type Gradient x :: *
-- | Update a layer with its gradient and learning parameters
runUpdate :: LearningParameters -> x -> Gradient x -> x
-- | Create a random layer, many layers will use pure
createRandom :: MonadRandom m => m x
-- | Update a layer with many Gradients
runUpdates :: LearningParameters -> x -> [Gradient x] -> x
runUpdates rate = foldl' (runUpdate rate)
-- | Class for a layer. All layers implement this, however, they don't
-- need to implement it for all shapes, only ones which are appropriate.
class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where
-- | The Wengert tape for this layer. Includes all that is required
-- to generate the back propagated gradients efficiently. As a
-- default, `S i` is fine.
type Tape x i o :: *
-- | Used in training and scoring. Take the input from the previous
-- layer, and give the output from this layer.
runForwards :: x -> S i -> (Tape x i o, S o)
-- | Back propagate a step. Takes the current layer, the input that the
-- layer gave from the input and the back propagated derivatives from
-- the layer above.
-- Returns the gradient layer and the derivatives to push back further.
runBackwards :: x -> Tape x i o -> S o -> (Gradient x, S i)
-- | Run two layers in parallel, combining their outputs.
-- This just kind of "smooshes" the weights together.
instance (UpdateLayer x, UpdateLayer y) => UpdateLayer (x, y) where
type Gradient (x, y) = (Gradient x, Gradient y)
runUpdate lr (x, y) (x', y') = (runUpdate lr x x', runUpdate lr y y')
createRandom = (,) <$> createRandom <*> createRandom
-- | Combine the outputs and the inputs, summing the output shape
instance (SingI i, SingI o, Layer x i o, Layer y i o) => Layer (x, y) i o where
type Tape (x, y) i o = (Tape x i o, Tape y i o)
runForwards (x, y) input =
let (xT, xOut) = runForwards x input
(yT, yOut) = runForwards y input
in ((xT, yT), xOut + yOut)
runBackwards (x, y) (xTape, yTape) o =
let (x', xB) = runBackwards x xTape o
(y', yB) = runBackwards y yTape o
in ((x', y'), xB + yB)

10
src/Grenade/Core/LearningParameters.hs Normal file
View File

@ -0,0 +1,10 @@
module Grenade.Core.LearningParameters (
LearningParameters (..)
) where
-- | Learning parameters for stochastic gradient descent.
data LearningParameters = LearningParameters {
learningRate :: Double
, learningMomentum :: Double
, learningRegulariser :: Double
} deriving (Eq, Show)

108
src/Grenade/Core/Network.hs
View File

@ -1,5 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@ -17,63 +19,24 @@ Neural network we support.
-}
module Grenade.Core.Network (
Layer (..)
, Network (..)
, UpdateLayer (..)
, LearningParameters (..)
Network (..)
, Gradients (..)
, Tapes (..)
, CreatableNetwork (..)
, applyUpdate
) where
import Control.Monad.Random (MonadRandom)
import Data.List ( foldl' )
import Data.Singletons
import Control.Monad.Random ( MonadRandom )
import Data.Singletons
import Data.Singletons.Prelude
import Data.Serialize
import Grenade.Core.Layer
import Grenade.Core.LearningParameters
import Grenade.Core.Shape
-- | Learning parameters for stochastic gradient descent.
data LearningParameters = LearningParameters {
learningRate :: Double
, learningMomentum :: Double
, learningRegulariser :: Double
} deriving (Eq, Show)
-- | Class for updating a layer. All layers implement this, and it is
-- shape independent.
class UpdateLayer x where
{-# MINIMAL runUpdate, createRandom #-}
-- | The type for the gradient for this layer.
-- Unit if there isn't a gradient to pass back.
type Gradient x :: *
-- | Update a layer with its gradient and learning parameters
runUpdate :: LearningParameters -> x -> Gradient x -> x
-- | Create a random layer, many layers will use pure
createRandom :: MonadRandom m => m x
-- | Update a layer with many Gradients
runUpdates :: LearningParameters -> x -> [Gradient x] -> x
runUpdates rate = foldl' (runUpdate rate)
-- | Class for a layer. All layers implement this, however, they don't
-- need to implement it for all shapes, only ones which are appropriate.
class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where
-- | The Wengert tape for this layer. Includes all that is required
-- to generate the back propagated gradients efficiently. As a
-- default, `S i` is fine.
type Tape x i o :: *
-- | Used in training and scoring. Take the input from the previous
-- layer, and give the output from this layer.
runForwards :: x -> S i -> (Tape x i o, S o)
-- | Back propagate a step. Takes the current layer, the input that the
-- layer gave from the input and the back propagated derivatives from
-- the layer above.
-- Returns the gradient layer and the derivatives to push back further.
runBackwards :: x -> Tape x i o -> S o -> (Gradient x, S i)
-- | Type of a network.
--
-- The [*] type specifies the types of the layers.
@ -92,6 +55,16 @@ instance Show (Network '[] '[i]) where
instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) where
show (x :~> xs) = show x ++ "\n~>\n" ++ show xs
-- | Apply one step of stochastic gradient decent across the network.
applyUpdate :: LearningParameters -> Network ls ss -> Gradients ls -> Network ls ss
applyUpdate _ NNil GNil
= NNil
applyUpdate rate (layer :~> rest) (gradient :/> grest)
= runUpdate rate layer gradient :~> applyUpdate rate rest grest
-- | Gradients of a network.
-- Parameterised on the layers of a Network.
data Gradients :: [*] -> * where
@ -116,7 +89,6 @@ instance SingI i => CreatableNetwork '[] '[i] where
instance (SingI i, SingI o, Layer x i o, CreatableNetwork xs (o ': rs)) => CreatableNetwork (x ': xs) (i ': o ': rs) where
randomNetwork = (:~>) <$> createRandom <*> randomNetwork
-- | Add very simple serialisation to the network
instance SingI i => Serialize (Network '[] '[i]) where
put NNil = pure ()
@ -125,3 +97,43 @@ instance SingI i => Serialize (Network '[] '[i]) where
instance (SingI i, SingI o, Layer x i o, Serialize x, Serialize (Network xs (o ': rs))) => Serialize (Network (x ': xs) (i ': o ': rs)) where
put (x :~> r) = put x >> put r
get = (:~>) <$> get <*> get
-- | Ultimate composition.
--
-- This allows a complete network to be treated as a layer in a bigger network.
instance CreatableNetwork sublayers subshapes => UpdateLayer (Network sublayers subshapes) where
type Gradient (Network sublayers subshapes) = Gradients sublayers
runUpdate = applyUpdate
createRandom = randomNetwork
instance (CreatableNetwork sublayers subshapes, i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (Network sublayers subshapes) i o where
type Tape (Network sublayers subshapes) i o = Tapes sublayers subshapes
runForwards net i =
go i net
where
go :: forall js ss. (Last js ~ Last subshapes)
=> S (Head js) -- ^ input vector
-> Network ss js -- ^ network to train
-> (Tapes ss js, S (Last js))
go !x (layer :~> n) =
let (tape, forward) = runForwards layer x
(tapes, answer) = go forward n
in (tape :\> tapes, answer)
go !x NNil
= (TNil, x)
runBackwards net tapes o =
go net tapes
where
go :: forall js ss. (Last js ~ Last subshapes)
=> Network ss js -- ^ network to train
-> Tapes ss js -- ^ network to train
-> (Gradients ss, S (Head js))
go (layer :~> n) (tape :\> nt) =
let (gradients, feed) = go n nt
(layer', backGrad) = runBackwards layer tape feed
in (layer' :/> gradients, backGrad)
go NNil TNil
= (GNil, o)

10
src/Grenade/Core/Runner.hs
View File

@ -25,6 +25,9 @@ module Grenade.Core.Runner (
) where
import Data.Singletons.Prelude
import Grenade.Core.Layer
import Grenade.Core.LearningParameters
import Grenade.Core.Network
import Grenade.Core.Shape
@ -57,13 +60,6 @@ backPropagate network input target =
go !x NNil
= (GNil, x - target)
-- | Apply one step of stochastic gradient decent across the network.
applyUpdate :: LearningParameters -> Network ls ss -> Gradients ls -> Network ls ss
applyUpdate _ NNil GNil
= NNil
applyUpdate rate (layer :~> rest) (gradient :/> grest)
= runUpdate rate layer gradient :~> applyUpdate rate rest grest
-- | Update a network with new weights after training with an instance.
train :: LearningParameters -> Network layers shapes -> S (Head shapes) -> S (Last shapes) -> Network layers shapes
train rate network input output =

39
src/Grenade/Graph/Core/Network.hs Normal file
View File

@ -0,0 +1,39 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-|
Module : Grenade.Graph.Core.Network
Description : Core definition of the Shapes of data we understand
Copyright : (c) Huw Campbell, 2016-2017
License : BSD2
Stability : experimental
This module defines the core data types for the shapes of data that
are understood by Grenade.
-}
module Grenade.Graph.Core.Network (
Fin (..)
) where
import Data.Constraint
import Data.Singletons
import Data.Proxy
import Grenade
import GHC.TypeLits
data Edge :: * where
E :: Fin n -> Shape -> Edge
data Fin n where
Fin0 :: Fin (n + 1)
FinS :: Fin n -> Fin (n + 1)
data Network :: [*] -> [Edge] -> * where { }

3
src/Grenade/Layers/Convolution.hs
View File

@ -25,8 +25,7 @@ import Numeric.LinearAlgebra hiding ( uniformSample, konst )
import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra.Static hiding ((|||), build, toRows)
import Grenade.Core.Network
import Grenade.Core.Shape
import Grenade.Core
import Grenade.Layers.Internal.Convolution
import Grenade.Layers.Internal.Update

3
src/Grenade/Layers/Crop.hs
View File

@ -13,8 +13,7 @@ import Data.Proxy
import Data.Singletons.TypeLits
import GHC.TypeLits
import Grenade.Core.Network
import Grenade.Core.Shape
import Grenade.Core
import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)
import Numeric.LinearAlgebra.Static (extract, create)

3
src/Grenade/Layers/Dropout.hs
View File

@ -10,8 +10,7 @@ module Grenade.Layers.Dropout (
import Control.Monad.Random hiding (fromList)
import GHC.TypeLits
import Grenade.Core.Shape
import Grenade.Core.Network
import Grenade.Core
-- Dropout layer help to reduce overfitting.
-- Idea here is that the vector is a shape of 1s and 0s, which we multiply the input by.

60
src/Grenade/Layers/Elu.hs Normal file
View File

@ -0,0 +1,60 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Grenade.Layers.Elu (
Elu (..)
) where
import Data.Serialize
import GHC.TypeLits
import Grenade.Core
import qualified Numeric.LinearAlgebra.Static as LAS
-- | An exponential linear unit.
-- A layer which can act between any shape of the same dimension, acting as a
-- diode on every neuron individually.
data Elu = Elu
deriving Show
instance UpdateLayer Elu where
type Gradient Elu = ()
runUpdate _ _ _ = Elu
createRandom = return Elu
instance Serialize Elu where
put _ = return ()
get = return Elu
instance ( KnownNat i) => Layer Elu ('D1 i) ('D1 i) where
type Tape Elu ('D1 i) ('D1 i) = S ('D1 i)
runForwards _ (S1D y) = (S1D y, S1D (elu y))
where
elu = LAS.dvmap (\a -> if a <= 0 then exp a - 1 else a)
runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (elu' y * dEdy))
where
elu' = LAS.dvmap (\a -> if a <= 0 then exp a else 1)
instance (KnownNat i, KnownNat j) => Layer Elu ('D2 i j) ('D2 i j) where
type Tape Elu ('D2 i j) ('D2 i j) = S ('D2 i j)
runForwards _ (S2D y) = (S2D y, S2D (elu y))
where
elu = LAS.dmmap (\a -> if a <= 0 then exp a - 1 else a)
runBackwards _ (S2D y) (S2D dEdy) = ((), S2D (elu' y * dEdy))
where
elu' = LAS.dmmap (\a -> if a <= 0 then exp a else 1)
instance (KnownNat i, KnownNat j, KnownNat k) => Layer Elu ('D3 i j k) ('D3 i j k) where
type Tape Elu ('D3 i j k) ('D3 i j k) = S ('D3 i j k)
runForwards _ (S3D y) = (S3D y, S3D (elu y))
where
elu = LAS.dmmap (\a -> if a <= 0 then exp a - 1 else a)
runBackwards _ (S3D y) (S3D dEdy) = ((), S3D (elu' y * dEdy))
where
elu' = LAS.dmmap (\a -> if a <= 0 then exp a else 1)

3
src/Grenade/Layers/Flatten.hs
View File

@ -15,8 +15,7 @@ import GHC.TypeLits
import Numeric.LinearAlgebra.Static
import Numeric.LinearAlgebra.Data as LA ( flatten )
import Grenade.Core.Shape
import Grenade.Core.Network
import Grenade.Core
-- | Flatten Layer
--

3
src/Grenade/Layers/FullyConnected.hs
View File

@ -19,8 +19,7 @@ import Data.Singletons.TypeLits
import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra.Static
import Grenade.Core.Network
import Grenade.Core.Shape
import Grenade.Core
import Grenade.Layers.Internal.Update

83
src/Grenade/Layers/Fuse.hs
View File

@ -1,83 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Grenade.Layers.Fuse (
SubNetwork (..)
, BranchNetwork (..)
) where
import Data.Singletons.Prelude
import Grenade.Core.Network
import Grenade.Core.Shape
import Grenade.Core.Runner
-- | Fuse two layers into one layer.
-- This can be used to simplify a network if a complicated repeated structure is used.
data SubNetwork :: [*] -> [Shape] -> * where
SubNetwork :: Network sublayers subshapes -> SubNetwork sublayers subshapes
instance CreatableNetwork sublayers subshapes => UpdateLayer (SubNetwork sublayers subshapes) where
type Gradient (SubNetwork sublayers subshapes) = Gradients sublayers
runUpdate lr (SubNetwork net) = SubNetwork . applyUpdate lr net
createRandom = SubNetwork <$> randomNetwork
instance (CreatableNetwork sublayers subshapes, i ~ (Head subshapes), o ~ (Last subshapes)) => Layer (SubNetwork sublayers subshapes) i o where
type Tape (SubNetwork sublayers subshapes) i o = Tapes sublayers subshapes
runForwards (SubNetwork net) i =
go i net
where
go :: forall js ss. (Last js ~ Last subshapes)
=> S (Head js) -- ^ input vector
-> Network ss js -- ^ network to train
-> (Tapes ss js, S (Last js))
go !x (layer :~> n) =
let (tape, forward) = runForwards layer x
(tapes, answer) = go forward n
in (tape :\> tapes, answer)
go !x NNil
= (TNil, x)
runBackwards (SubNetwork net) tapes o =
go net tapes
where
go :: forall js ss. (Last js ~ Last subshapes)
=> Network ss js -- ^ network to train
-> Tapes ss js -- ^ network to train
-> (Gradients ss, S (Head js))
go (layer :~> n) (tape :\> nt) =
let (gradients, feed) = go n nt
(layer', backGrad) = runBackwards layer tape feed
in (layer' :/> gradients, backGrad)
go NNil TNil
= (GNil, o)
-- | Run two layers in parallel, combining their outputs. The way in which the output is combined is dependent
-- on the inut
data BranchNetwork :: * -> * -> * where
BranchNetwork :: x -> y -> BranchNetwork x y
instance (UpdateLayer x, UpdateLayer y) => UpdateLayer (BranchNetwork x y) where
type Gradient (BranchNetwork x y) = (Gradient x, Gradient y)
runUpdate lr (BranchNetwork x y) (x', y') = BranchNetwork (runUpdate lr x x') (runUpdate lr y y')
createRandom = BranchNetwork <$> createRandom <*> createRandom
instance (SingI i, SingI o, Layer x i o, Layer y i o) => Layer (BranchNetwork x y) i o where
type Tape (BranchNetwork x y) i o = (Tape x i o, Tape y i o)
runForwards (BranchNetwork x y) input =
let (xT, xOut) = runForwards x input
(yT, yOut) = runForwards y input
in ((xT, yT), xOut + yOut)
runBackwards (BranchNetwork x y) (xTape, yTape) o =
let (x', xB) = runBackwards x xTape o
(y', yB) = runBackwards y yTape o
in ((x', y'), xB + yB)

3
src/Grenade/Layers/Logit.hs
View File

@ -11,8 +11,7 @@ module Grenade.Layers.Logit (
import Data.Serialize
import Data.Singletons
import Grenade.Core.Network
import Grenade.Core.Shape
import Grenade.Core
-- | A Logit layer.
-- A layer which can act between any shape of the same dimension, perfoming an sigmoid function.

3
src/Grenade/Layers/Pad.hs
View File

@ -14,8 +14,7 @@ import Data.Serialize
import Data.Singletons.TypeLits
import GHC.TypeLits
import Grenade.Core.Network
import Grenade.Core.Shape
import Grenade.Core
import Numeric.LinearAlgebra (konst, subMatrix, diagBlock)
import Numeric.LinearAlgebra.Static (extract, create)

3
src/Grenade/Layers/Pooling.hs
View File

@ -16,8 +16,7 @@ import Data.Serialize
import Data.Singletons.TypeLits
import GHC.TypeLits
import Grenade.Core.Network
import Grenade.Core.Shape
import Grenade.Core
import Grenade.Layers.Internal.Pooling
import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRows)

3
src/Grenade/Layers/Relu.hs
View File

@ -9,8 +9,7 @@ module Grenade.Layers.Relu (
import Data.Serialize
import GHC.TypeLits
import Grenade.Core.Network
import Grenade.Core.Shape
import Grenade.Core
import qualified Numeric.LinearAlgebra.Static as LAS

53
src/Grenade/Layers/Softmax.hs Normal file
View File

@ -0,0 +1,53 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Grenade.Layers.Softmax (
Softmax (..)
, softmax
, softmax'
) where
import Data.Serialize
import GHC.TypeLits
import Grenade.Core
import Numeric.LinearAlgebra.Static as LAS
-- | A Softmax layer
-- This layer is like a logit layer, but normalises
-- a set of matricies to be probabilities.
data Softmax = Softmax
deriving Show
instance UpdateLayer Softmax where
type Gradient Softmax = ()
runUpdate _ _ _ = Softmax
createRandom = return Softmax
instance ( KnownNat i ) => Layer Softmax ('D1 i) ('D1 i) where
type Tape Softmax ('D1 i) ('D1 i) = S ('D1 i)
runForwards _ (S1D y) = (S1D y, S1D (softmax y))
runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (softmax' y dEdy))
instance Serialize Softmax where
put _ = return ()
get = return Softmax
softmax :: KnownNat i => LAS.R i -> LAS.R i
softmax xs =
let xs' = LAS.dvmap exp xs
s = LAS.dot xs' 1
in LAS.dvmap (/ s) xs'
softmax' :: KnownNat i => LAS.R i -> LAS.R i -> LAS.R i
softmax' x grad =
let yTy = outer sm sm
d = diag sm
g = d - yTy
in g #> grad
where
sm = softmax x

3
src/Grenade/Layers/Tanh.hs
View File

@ -10,8 +10,7 @@ module Grenade.Layers.Tanh (
import Data.Serialize
import Data.Singletons
import Grenade.Core.Network
import Grenade.Core.Shape
import Grenade.Core
-- | A Tanh layer.
-- A layer which can act between any shape of the same dimension, perfoming a tanh function.

1
src/Grenade/Recurrent.hs
View File

@ -6,4 +6,3 @@ import Grenade.Recurrent.Core.Network as X
import Grenade.Recurrent.Core.Runner as X
import Grenade.Recurrent.Layers.BasicRecurrent as X
import Grenade.Recurrent.Layers.LSTM as X
import Grenade.Recurrent.Layers.Trivial as X

3
src/Grenade/Recurrent/Core/Network.hs
View File

@ -22,8 +22,7 @@ import Data.Singletons ( SingI )
import Data.Serialize
import qualified Data.Vector.Storable as V
import Grenade.Core.Shape
import Grenade.Core.Network
import Grenade.Core
import qualified Numeric.LinearAlgebra as LA
import qualified Numeric.LinearAlgebra.Static as LAS

3
src/Grenade/Recurrent/Core/Runner.hs
View File

@ -16,8 +16,7 @@ module Grenade.Recurrent.Core.Runner (
) where
import Data.Singletons.Prelude
import Grenade.Core.Network
import Grenade.Core.Shape
import Grenade.Core
import Grenade.Recurrent.Core.Network

3
src/Grenade/Recurrent/Layers/BasicRecurrent.hs
View File

@ -24,8 +24,7 @@ import Numeric.LinearAlgebra.Static
import GHC.TypeLits
import Grenade.Core.Network
import Grenade.Core.Shape
import Grenade.Core
import Grenade.Recurrent.Core.Network
data BasicRecurrent :: Nat -- Input layer size

4
src/Grenade/Recurrent/Layers/LSTM.hs
View File

@ -20,7 +20,6 @@ module Grenade.Recurrent.Layers.LSTM (
import Control.Monad.Random ( MonadRandom, getRandom )
-- import Data.List ( foldl1' )
import Data.Proxy
import Data.Serialize
@ -29,8 +28,7 @@ import Data.Singletons.TypeLits
import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra.Static
import Grenade.Core.Network
import Grenade.Core.Shape
import Grenade.Core
import Grenade.Layers.Internal.Update

30
src/Grenade/Recurrent/Layers/Trivial.hs
View File

@ -1,30 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Grenade.Recurrent.Layers.Trivial (
Trivial (..)
) where
import Data.Serialize
import Grenade.Core.Network
-- | A trivial layer.
data Trivial = Trivial
deriving Show
instance Serialize Trivial where
put _ = return ()
get = return Trivial
instance UpdateLayer Trivial where
type Gradient Trivial = ()
runUpdate _ _ _ = Trivial
createRandom = return Trivial
instance (a ~ b) => Layer Trivial a b where
type Tape Trivial a b = ()
runForwards _ x = ((), x)
runBackwards _ _ y = ((), y)

3
test/Test/Grenade/Layers/Convolution.hs
View File

@ -15,8 +15,7 @@ import Data.Singletons ()
import GHC.TypeLits
import GHC.TypeLits.Witnesses
import Grenade.Core.Shape
import Grenade.Core.Network
import Grenade.Core
import Grenade.Layers.Convolution
import Disorder.Jack

3
test/Test/Grenade/Layers/FullyConnected.hs
View File

@ -12,8 +12,7 @@ import Data.Singletons ()
import GHC.TypeLits
import Grenade.Core.Shape
import Grenade.Core.Network
import Grenade.Core
import Grenade.Layers.FullyConnected
import Disorder.Jack

72
test/Test/Grenade/Layers/Nonlinear.hs Normal file
View File

@ -0,0 +1,72 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Test.Grenade.Layers.Nonlinear where
import Data.Singletons
import Grenade
import GHC.TypeLits
import Disorder.Jack
import Test.Jack.Hmatrix
import Test.Jack.TypeLits
import Numeric.LinearAlgebra.Static ( norm_Inf )
prop_sigmoid_grad :: Property
prop_sigmoid_grad =
gambleDisplay (const "Shape") genShape $ \case
(SomeSing (r :: Sing s)) ->
withSingI r $
gamble genOfShape $ \(ds :: S s) ->
let (tape, f :: S s) = runForwards Logit ds
((), ret :: S s) = runBackwards Logit tape (1 :: S s)
(_, numer :: S s) = runForwards Logit (ds + 0.0001)
numericalGradient = (numer - f) * 10000
in counterexample (show numericalGradient ++ show ret)
((case numericalGradient - ret of
(S1D x) -> norm_Inf x < 0.0001
(S2D x) -> norm_Inf x < 0.0001
(S3D x) -> norm_Inf x < 0.0001) :: Bool)
prop_tanh_grad :: Property
prop_tanh_grad =
gambleDisplay (const "Shape") genShape $ \case
(SomeSing (r :: Sing s)) ->
withSingI r $
gamble genOfShape $ \(ds :: S s) ->
let (tape, f :: S s) = runForwards Tanh ds
((), ret :: S s) = runBackwards Tanh tape (1 :: S s)
(_, numer :: S s) = runForwards Tanh (ds + 0.0001)
numericalGradient = (numer - f) * 10000
in counterexample (show numericalGradient ++ show ret)
((case numericalGradient - ret of
(S1D x) -> norm_Inf x < 0.001
(S2D x) -> norm_Inf x < 0.001
(S3D x) -> norm_Inf x < 0.001) :: Bool)
prop_softmax_grad :: Property
prop_softmax_grad =
gamble genNat $ \case
(SomeNat (_ :: Proxy s)) ->
gamble genOfShape $ \(ds :: S ('D1 s)) ->
let (tape, f :: S ('D1 s)) = runForwards Relu ds
((), ret :: S ('D1 s)) = runBackwards Relu tape (1 :: S ('D1 s))
(_, numer :: S ('D1 s)) = runForwards Relu (ds + 0.0001)
numericalGradient = (numer - f) * 10000
in counterexample (show numericalGradient ++ show ret)
((case numericalGradient - ret of
(S1D x) -> norm_Inf x < 0.0001) :: Bool)
return []
tests :: IO Bool
tests = $quickCheckAll

14
test/Test/Grenade/Recurrent/Layers/LSTM.hs
View File

@ -44,7 +44,7 @@ prop_lstm_reference_forwards =
gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
let actual = runRecurrentForwards net (S1D cell) (S1D input)
in case actual of
((S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->
(_, (S1D cellOut) :: S ('D1 2), (S1D output) :: S ('D1 2)) ->
let cellOut' = Reference.Vector . H.toList . S.extract $ cellOut
output' = Reference.Vector . H.toList . S.extract $ output
refNet = Reference.lstmToReference lstmWeights
@ -57,9 +57,9 @@ prop_lstm_reference_backwards =
gamble randomVector $ \(input :: S.R 3) ->
gamble randomVector $ \(cell :: S.R 2) ->
gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
let actualBacks = runRecurrentBackwards net (S1D cell) (S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
in case actualBacks of
(actualGradients, _, _) ->
(actualGradients, _, _ :: S ('D1 3)) ->
let refNet = Reference.lstmToReference lstmWeights
refCell = Reference.Vector . H.toList . S.extract $ cell
refInput = Reference.Vector . H.toList . S.extract $ input
@ -70,9 +70,9 @@ prop_lstm_reference_backwards_input =
gamble randomVector $ \(input :: S.R 3) ->
gamble randomVector $ \(cell :: S.R 2) ->
gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
let actualBacks = runRecurrentBackwards net (S1D cell) (S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
in case actualBacks of
(_, _, S1D actualGradients) ->
(_, _, S1D actualGradients :: S ('D1 3)) ->
let refNet = Reference.lstmToReference lstmWeights
refCell = Reference.Vector . H.toList . S.extract $ cell
refInput = Reference.Vector . H.toList . S.extract $ input
@ -83,9 +83,9 @@ prop_lstm_reference_backwards_cell =
gamble randomVector $ \(input :: S.R 3) ->
gamble randomVector $ \(cell :: S.R 2) ->
gamble genLSTM $ \(net@(LSTM lstmWeights _) :: LSTM 3 2) ->
let actualBacks = runRecurrentBackwards net (S1D cell) (S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
in case actualBacks of
(_, S1D actualGradients, _) ->
(_, S1D actualGradients, _ :: S ('D1 3)) ->
let refNet = Reference.lstmToReference lstmWeights
refCell = Reference.Vector . H.toList . S.extract $ cell
refInput = Reference.Vector . H.toList . S.extract $ input