git.iko.soy/grenade
on master help sign in
Simplify, start working toward randomNet again
a87fde1Huw Campbell
main/feedforward.hs+6−10
compare with master
unifiedsplit
@@ -17,7 +17,6 @@ import Options.Applicative
17
17
18import Grenade
18import Grenade
19
19
20−
21-- The defininition for our simple feed forward network.
20-- The defininition for our simple feed forward network.
22-- The type level list represents the shapes passed through the layers. One can see that for this demonstration
21-- The type level list represents the shapes passed through the layers. One can see that for this demonstration
23-- we are using relu, tanh and logit non-linear units, which can be easily subsituted for each other in and out.
22-- we are using relu, tanh and logit non-linear units, which can be easily subsituted for each other in and out.
@@ -26,12 +25,10 @@ import Grenade
26-- between the shapes, so inference can't do it all for us.
25-- between the shapes, so inference can't do it all for us.
27
26
28-- With around 100000 examples, this should show two clear circles which have been learned by the network.
27-- With around 100000 examples, this should show two clear circles which have been learned by the network.
29−randomNet :: MonadRandom m => m (Network '[ 'D1 2, 'D1 40, 'D1 40, 'D1 10, 'D1 10, 'D1 1, 'D1 1])
28+randomNet :: MonadRandom m
30−randomNet = do
29+ => m (Network '[ FullyConnected 2 40, Tanh, FullyConnected 40 10, Relu, FullyConnected 10 1, Logit ]
31− a :: FullyConnected 2 40 <- randomFullyConnected
30+ '[ 'D1 2, 'D1 40, 'D1 40, 'D1 10, 'D1 10, 'D1 1, 'D1 1])
32− b :: FullyConnected 40 10 <- randomFullyConnected
31+randomNet = randomNetwork
33− c :: FullyConnected 10 1 <- randomFullyConnected
34− return $ a :~> Tanh :~> b :~> Relu :~> c :~> O Logit
35
32
36netTest :: MonadRandom m => LearningParameters -> Int -> m String
33netTest :: MonadRandom m => LearningParameters -> Int -> m String
37netTest rate n = do
34netTest rate n = do
@@ -46,7 +43,7 @@ netTest rate n = do
46
43
47 let trained = foldl trainEach net0 (zip inps outs)
44 let trained = foldl trainEach net0 (zip inps outs)
48 let testIns = [ [ (x,y) | x <- [0..50] ]
45 let testIns = [ [ (x,y) | x <- [0..50] ]
49− | y <- [0..20] ]
46+ | y <- [0..20] ]
50
47
51 let outMat = fmap (fmap (\(x,y) -> (render . normx) $ runNet trained (S1D' $ SA.vector [x / 25 - 1,y / 10 - 1]))) testIns
48 let outMat = fmap (fmap (\(x,y) -> (render . normx) $ runNet trained (S1D' $ SA.vector [x / 25 - 1,y / 10 - 1]))) testIns
52 return $ unlines outMat
49 return $ unlines outMat
@@ -54,7 +51,7 @@ netTest rate n = do
54 where
51 where
55 inCircle :: KnownNat n => SA.R n -> (SA.R n, Double) -> Bool
52 inCircle :: KnownNat n => SA.R n -> (SA.R n, Double) -> Bool
56 v `inCircle` (o, r) = SA.norm_2 (v - o) <= r
53 v `inCircle` (o, r) = SA.norm_2 (v - o) <= r
57− trainEach !nt !(i, o) = train rate i o nt
54+ trainEach !nt !(i, o) = train rate nt i o
58
55
59 render n' | n' <= 0.2 = ' '
56 render n' | n' <= 0.2 = ' '
60 | n' <= 0.4 = '.'
57 | n' <= 0.4 = '.'
@@ -65,7 +62,6 @@ netTest rate n = do
65 normx :: S' ('D1 1) -> Double
62 normx :: S' ('D1 1) -> Double
66 normx (S1D' r) = SA.mean r
63 normx (S1D' r) = SA.mean r
67
64
68−
69data FeedForwardOpts = FeedForwardOpts Int LearningParameters
65data FeedForwardOpts = FeedForwardOpts Int LearningParameters
70
66
71feedForward' :: Parser FeedForwardOpts
67feedForward' :: Parser FeedForwardOpts
main/mnist.hs+7−11
@@ -30,19 +30,15 @@ import Grenade
30
30
31-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,
31-- With the mnist data from Kaggle normalised to doubles between 0 and 1, learning rate of 0.01 and 15 iterations,
32-- this network should get down to about a 1.3% error rate.
32-- this network should get down to about a 1.3% error rate.
33+randomMnist :: MonadRandom m
34+ => m (Network '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Relu, Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, FlattenLayer, Relu, FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]
33−randomMnistNet :: MonadRandom m => m (Network '[ '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])
35+ '[ '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])
34−randomMnistNet = do
36+randomMnist = randomNetwork
35− a :: Convolution 1 10 5 5 1 1 <- randomConvolution
37+
36− let b :: Pooling 2 2 2 2 = Pooling
37− c :: Convolution 10 16 5 5 1 1 <- randomConvolution
38− let d :: Pooling 2 2 2 2 = Pooling
39− e :: FullyConnected 256 80 <- randomFullyConnected
40− f :: FullyConnected 80 10 <- randomFullyConnected
41− return $ a :~> b :~> Relu :~> c :~> d :~> FlattenLayer :~> Relu :~> e :~> Logit :~> f :~> O Logit
42
38
43convTest :: Int -> FilePath -> FilePath -> LearningParameters -> IO ()
39convTest :: Int -> FilePath -> FilePath -> LearningParameters -> IO ()
44convTest iterations trainFile validateFile rate = do
40convTest iterations trainFile validateFile rate = do
45− net0 <- evalRandIO randomMnistNet
41+ net0 <- evalRandIO randomMnist
46 fT <- T.readFile trainFile
42 fT <- T.readFile trainFile
47 fV <- T.readFile validateFile
43 fV <- T.readFile validateFile
48 let trainRows = traverse (A.parseOnly p) (T.lines fT)
44 let trainRows = traverse (A.parseOnly p) (T.lines fT)
@@ -52,7 +48,7 @@ convTest iterations trainFile validateFile rate = do
52 err -> print err
48 err -> print err
53
49
54 where
50 where
55− trainEach !rate' !nt !(i, o) = train rate' i o nt
51+ trainEach !rate' !nt !(i, o) = train rate' nt i o
56
52
57 p :: A.Parser (S' ('D2 28 28), S' ('D1 10))
53 p :: A.Parser (S' ('D2 28 28), S' ('D1 10))
58 p = do
54 p = do
src/Grenade/Core/Network.hs+34−10
@@ -8,14 +8,20 @@
8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE FlexibleContexts #-}
10{-# LANGUAGE FlexibleInstances #-}
10{-# LANGUAGE FlexibleInstances #-}
11+{-# LANGUAGE LambdaCase #-}
11
12
12module Grenade.Core.Network (
13module Grenade.Core.Network (
13 Layer (..)
14 Layer (..)
14 , Network (..)
15 , Network (..)
15 , UpdateLayer (..)
16 , UpdateLayer (..)
16 , LearningParameters (..)
17 , LearningParameters (..)
18+ , Gradients (..)
19+ , CreatableNetwork (..)
17 ) where
20 ) where
18
21
22+import Control.Monad.Random (MonadRandom)
23+
24+
19import Grenade.Core.Shape
25import Grenade.Core.Shape
20
26
21data LearningParameters = LearningParameters {
27data LearningParameters = LearningParameters {
@@ -26,12 +32,14 @@ data LearningParameters = LearningParameters {
26
32
27-- | Class for updating a layer. All layers implement this, and it is
33-- | Class for updating a layer. All layers implement this, and it is
28-- shape independent.
34-- shape independent.
29−class UpdateLayer x where
35+class Show x => UpdateLayer x where
30 -- | The type for the gradient for this layer.
36 -- | The type for the gradient for this layer.
31 -- Unit if there isn't a gradient to pass back.
37 -- Unit if there isn't a gradient to pass back.
32 type Gradient x :: *
38 type Gradient x :: *
33 -- | Update a layer with its gradient and learning parameters
39 -- | Update a layer with its gradient and learning parameters
34 runUpdate :: LearningParameters -> x -> Gradient x -> x
40 runUpdate :: LearningParameters -> x -> Gradient x -> x
41+ -- | Create a random layer, many layers will use pure
42+ createRandom :: MonadRandom m => m x
35
43
36-- | Class for a layer. All layers implement this, however, they don't
44-- | Class for a layer. All layers implement this, however, they don't
37-- need to implement it for all shapes, only ones which are appropriate.
45-- need to implement it for all shapes, only ones which are appropriate.
@@ -46,19 +54,35 @@ class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where
46 runBackards :: x -> S' i -> S' o -> (Gradient x, S' i)
54 runBackards :: x -> S' i -> S' o -> (Gradient x, S' i)
47
55
48-- | Type of a network.
56-- | Type of a network.
57+-- The [*] type specifies the types of the layers. This is needed for parallel
58+-- running and being all the gradients beck together.
49-- The [Shape] type specifies the shapes of data passed between the layers.
59-- The [Shape] type specifies the shapes of data passed between the layers.
50-- Could be considered to be a heterogeneous list of layers which are able to
60-- Could be considered to be a heterogeneous list of layers which are able to
51-- transform the data shapes of the network.
61-- transform the data shapes of the network.
52−data Network :: [Shape] -> * where
62+data Network :: [*] -> [Shape] -> * where
53− O :: (Show x, Layer x i o, KnownShape o, KnownShape i)
54− => !x
55− -> Network '[i, o]
63+ O :: Layer x i o => !x -> Network '[x] '[i, o]
56− (:~>) :: (Show x, Layer x i h, KnownShape h, KnownShape i)
57− => !x
58− -> !(Network (h ': hs))
59− -> Network (i ': h ': hs)
64+ (:~>) :: Layer x i h => !x -> !(Network xs (h ': hs)) -> Network (x ': xs) (i ': h ': hs)
60infixr 5 :~>
65infixr 5 :~>
61
66
62−instance Show (Network h) where
67+instance Show (Network l h) where
63 show (O a) = "O " ++ show a
68 show (O a) = "O " ++ show a
64 show (i :~> o) = show i ++ "\n:~>\n" ++ show o
69 show (i :~> o) = show i ++ "\n:~>\n" ++ show o
70+
71+-- | Gradients of a network.
72+-- Parameterised on the layers of a Network.
73+data Gradients :: [*] -> * where
74+ OG :: UpdateLayer x => Gradient x -> Gradients '[x]
75+ (:/>) :: UpdateLayer x => Gradient x -> Gradients xs -> Gradients (x ': xs)
76+
77+
78+-- | A network can easily be created by hand with (:~>), but an easy way to initialise a random
79+-- network is with the randomNetwork.
80+class CreatableNetwork (xs :: [*]) (ss :: [Shape]) where
81+ -- | Create a network of the types requested
82+ randomNetwork :: MonadRandom m => m (Network xs ss)
83+
84+instance Layer x i o => CreatableNetwork (x ': '[]) (i ': o ': '[]) where
85+ randomNetwork = O <$> createRandom
86+
87+instance (Layer x i o, CreatableNetwork xs (o ': r ': rs)) => CreatableNetwork (x ': xs) (i ': o ': r ': rs) where
88+ randomNetwork = (:~>) <$> createRandom <*> randomNetwork
src/Grenade/Core/Runner.hs+35−23
@@ -7,52 +7,64 @@
7
7
8module Grenade.Core.Runner (
8module Grenade.Core.Runner (
9 train
9 train
10+ , backPropagate
10 , runNet
11 , runNet
12+ , applyUpdate
11 ) where
13 ) where
12
14
13import Data.Singletons.Prelude
15import Data.Singletons.Prelude
14import Grenade.Core.Network
16import Grenade.Core.Network
15import Grenade.Core.Shape
17import Grenade.Core.Shape
16
18
17−-- | Update a network with new weights after training with an instance.
19+-- | Drive and network and collect it's back propogated gradients.
18−train :: forall i o hs. (Head hs ~ i, Last hs ~ o, KnownShape i, KnownShape o)
20+backPropagate :: forall input output shapes layers. (Head shapes ~ input, Last shapes ~ output)
19− => LearningParameters -- ^ learning rate
21+ => Network layers shapes -> S' input -> S' output -> Gradients layers
20− -> S' i -- ^ input vector
22+backPropagate network input target =
21− -> S' o -- ^ target vector
23+ fst $ go input network
22− -> Network hs -- ^ network to train
23− -> Network hs
24−train rate x0 target = fst . go x0
25 where
24 where
26− go :: forall j js. (Head js ~ j, Last js ~ o, KnownShape j)
25+ go :: forall j js sublayers. (Head js ~ j, Last js ~ output)
27− => S' j -- ^ input vector
26+ => S' j -- ^ input vector
28− -> Network js -- ^ network to train
27+ -> Network sublayers js -- ^ network to train
29− -> (Network js, S' j)
28+ -> (Gradients sublayers, S' j)
30 -- handle input from the beginning, feeding upwards.
29 -- handle input from the beginning, feeding upwards.
31 go !x (layer :~> n)
30 go !x (layer :~> n)
32 = let y = runForwards layer x
31 = let y = runForwards layer x
33− -- run the rest of the network, and get the layer from above.
32+ -- recursively run the rest of the network, and get the layer from above.
34 (n', dWs') = go y n
33 (n', dWs') = go y n
35 -- calculate the gradient for this layer to pass down,
34 -- calculate the gradient for this layer to pass down,
36 (layer', dWs) = runBackards layer x dWs'
35 (layer', dWs) = runBackards layer x dWs'
37
36
38− -- Update this layer using the gradient
39− newLayer = runUpdate rate layer layer'
40−
41− in (newLayer :~> n', dWs)
37+ in (layer' :/> n', dWs)
42
38
43 -- handle the output layer, bouncing the derivatives back down.
39 -- handle the output layer, bouncing the derivatives back down.
44 go !x (O layer)
40 go !x (O layer)
45 = let y = runForwards layer x
41 = let y = runForwards layer x
46− -- the gradient (how much y affects the error)
42+ -- the gradient (how much y affects the error)
47 (layer', dWs) = runBackards layer x (y - target)
43 (layer', dWs) = runBackards layer x (y - target)
48− newLayer = runUpdate rate layer layer'
49
44
50− in (O newLayer, dWs)
45+ in (OG layer', dWs)
46+
47+-- | Update a network with new weights after training with an instance.
48+train :: forall input output shapes layers. (Head shapes ~ input, Last shapes ~ output)
49+ => LearningParameters -- ^ learning rate
50+ -> Network layers shapes -- ^ network to train
51+ -> S' input -> S' output -- ^ target vector
52+ -> Network layers shapes
53+train rate network input output =
54+ let grads = backPropagate network input output
55+ in applyUpdate rate network grads
56+
57+applyUpdate :: LearningParameters -> Network ls ss -> Gradients ls -> Network ls ss
58+applyUpdate rate (O layer) (OG gradient)
59+ = O (runUpdate rate layer gradient)
60+applyUpdate rate (layer :~> rest) (gradient :/> grest)
61+ = runUpdate rate layer gradient :~> applyUpdate rate rest grest
62+applyUpdate _ _ _
63+ = error "Impossible for the gradients of a network to have a different length to the network"
51
64
52-- | Just forwards propagation with no training.
65-- | Just forwards propagation with no training.
53−runNet :: Network hs
66+runNet :: Network layers hs
54 -> S' (Head hs) -- ^ input vector
67 -> S' (Head hs) -- ^ input vector
55 -> S' (Last hs) -- ^ target vector
68 -> S' (Last hs) -- ^ target vector
56−runNet (layer :~> n) !x = let y = runForwards layer x
69+runNet (layer :~> n) !x = let y = runForwards layer x in runNet n y
57− in runNet n y
58runNet (O layer) !x = runForwards layer x
70runNet (O layer) !x = runForwards layer x
src/Grenade/Core/Shape.hs+1−18
@@ -1,9 +1,7 @@
1−{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
4{-# LANGUAGE KindSignatures #-}
3{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE TypeOperators #-}
8{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE PolyKinds #-}
7{-# LANGUAGE PolyKinds #-}
@@ -18,11 +16,9 @@
18module Grenade.Core.Shape (
16module Grenade.Core.Shape (
19 Shape (..)
17 Shape (..)
20 , S' (..)
18 , S' (..)
21− , KnownShape (..)
22 ) where
19 ) where
23
20
24import Data.Singletons.TypeLits
21import Data.Singletons.TypeLits
25−import Data.Proxy
26
22
27import Numeric.LinearAlgebra.Static
23import Numeric.LinearAlgebra.Static
28
24
@@ -36,7 +32,7 @@ data Shape =
36 | D2 Nat Nat
32 | D2 Nat Nat
37 | D3 Nat Nat Nat
33 | D3 Nat Nat Nat
38
34
39−instance KnownShape x => Num (S' x) where
35+instance Num (S' x) where
40 (+) (S1D' x) (S1D' y) = S1D' (x + y)
36 (+) (S1D' x) (S1D' y) = S1D' (x + y)
41 (+) (S2D' x) (S2D' y) = S2D' (x + y)
37 (+) (S2D' x) (S2D' y) = S2D' (x + y)
42 (+) (S3D' x) (S3D' y) = S3D' (vectorZip (+) x y)
38 (+) (S3D' x) (S3D' y) = S3D' (vectorZip (+) x y)
@@ -72,16 +68,3 @@ instance Show (S' n) where
72 show (S1D' a) = "S1D' " ++ show a
68 show (S1D' a) = "S1D' " ++ show a
73 show (S2D' a) = "S2D' " ++ show a
69 show (S2D' a) = "S2D' " ++ show a
74 show (S3D' a) = "S3D' " ++ show a
70 show (S3D' a) = "S3D' " ++ show a
75−
76−-- | Singleton for Shape
77−class KnownShape (n :: Shape) where
78− shapeSing :: Proxy n
79−
80−instance KnownShape ('D1 n) where
81− shapeSing = Proxy
82−
83−instance KnownShape ('D2 n m) where
84− shapeSing = Proxy
85−
86−instance KnownShape ('D3 l n m) where
87− shapeSing = Proxy
src/Grenade/Layers/Convolution.hs+12−1
@@ -119,7 +119,14 @@ randomConvolution = do
119 mm = konst 0
119 mm = konst 0
120 return $ Convolution wN mm
120 return $ Convolution wN mm
121
121
122+instance ( KnownNat channels
123+ , KnownNat filters
124+ , KnownNat kernelRows
125+ , KnownNat kernelColumns
126+ , KnownNat strideRows
127+ , KnownNat strideColumns
128+ , KnownNat (kernelRows * kernelColumns * channels)
122−instance UpdateLayer (Convolution channels filters kernelRows kernelCols strideRows strideCols) where
129+ ) => UpdateLayer (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where
123 type Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols) = (Convolution' channels filters kernelRows kernelCols strideRows strideCols)
130 type Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols) = (Convolution' channels filters kernelRows kernelCols strideRows strideCols)
124 runUpdate LearningParameters {..} (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =
131 runUpdate LearningParameters {..} (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =
125 let newMomentum = konst learningMomentum * oldMomentum - konst learningRate * kernelGradient
132 let newMomentum = konst learningMomentum * oldMomentum - konst learningRate * kernelGradient
@@ -127,6 +134,8 @@ instance UpdateLayer (Convolution channels filters kernelRows kernelCols strideR
127 newKernel = oldKernel + newMomentum - regulariser
134 newKernel = oldKernel + newMomentum - regulariser
128 in Convolution newKernel newMomentum
135 in Convolution newKernel newMomentum
129
136
137+ createRandom = randomConvolution
138+
130-- | A two dimentional image may have a convolution filter applied to it
139-- | A two dimentional image may have a convolution filter applied to it
131instance ( KnownNat kernelRows
140instance ( KnownNat kernelRows
132 , KnownNat kernelCols
141 , KnownNat kernelCols
@@ -139,6 +148,7 @@ instance ( KnownNat kernelRows
139 , KnownNat outputCols
148 , KnownNat outputCols
140 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
149 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
141 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
150 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
151+ , KnownNat (kernelRows * kernelCols * 1)
142 ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where
152 ) => Layer (Convolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where
143 runForwards (Convolution kernel _) (S2D' input) =
153 runForwards (Convolution kernel _) (S2D' input) =
144 let ex = extract input
154 let ex = extract input
@@ -192,6 +202,7 @@ instance ( KnownNat kernelRows
192 , KnownNat channels
202 , KnownNat channels
193 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
203 , ((outputRows - 1) * strideRows) ~ (inputRows - kernelRows)
194 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
204 , ((outputCols - 1) * strideCols) ~ (inputCols - kernelCols)
205+ , KnownNat (kernelRows * kernelCols * channels)
195 ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where
206 ) => Layer (Convolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where
196 runForwards (Convolution kernel _) (S3D' input) =
207 runForwards (Convolution kernel _) (S3D' input) =
197 let ex = vecToList $ fmap extract input
208 let ex = vecToList $ fmap extract input
src/Grenade/Layers/Crop.hs+2−5
@@ -28,11 +28,7 @@ data Crop :: Nat
28 -> Nat
28 -> Nat
29 -> Nat
29 -> Nat
30 -> Nat -> * where
30 -> Nat -> * where
31− Crop :: ( KnownNat cropLeft
32− , KnownNat cropTop
33− , KnownNat cropRight
34− , KnownNat cropBottom
35− ) => Crop cropLeft cropTop cropRight cropBottom
31+ Crop :: Crop cropLeft cropTop cropRight cropBottom
36
32
37instance Show (Crop cropLeft cropTop cropRight cropBottom) where
33instance Show (Crop cropLeft cropTop cropRight cropBottom) where
38 show Crop = "Crop"
34 show Crop = "Crop"
@@ -40,6 +36,7 @@ instance Show (Crop cropLeft cropTop cropRight cropBottom) where
40instance UpdateLayer (Crop l t r b) where
36instance UpdateLayer (Crop l t r b) where
41 type Gradient (Crop l t r b) = ()
37 type Gradient (Crop l t r b) = ()
42 runUpdate _ x _ = x
38 runUpdate _ x _ = x
39+ createRandom = return Crop
43
40
44-- | A two dimentional image can be cropped.
41-- | A two dimentional image can be cropped.
45instance ( KnownNat cropLeft
42instance ( KnownNat cropLeft
src/Grenade/Layers/Dropout.hs+1
@@ -34,6 +34,7 @@ data Dropout o =
34instance (KnownNat i) => UpdateLayer (Dropout i) where
34instance (KnownNat i) => UpdateLayer (Dropout i) where
35 type Gradient (Dropout i) = ()
35 type Gradient (Dropout i) = ()
36 runUpdate _ x _ = x
36 runUpdate _ x _ = x
37+ createRandom = randomDropout 0.95
37
38
38randomDropout :: (MonadRandom m, KnownNat i)
39randomDropout :: (MonadRandom m, KnownNat i)
39 => Double -> m (Dropout i)
40 => Double -> m (Dropout i)
src/Grenade/Layers/Flatten.hs+2
@@ -28,6 +28,8 @@ data FlattenLayer = FlattenLayer
28instance UpdateLayer FlattenLayer where
28instance UpdateLayer FlattenLayer where
29 type Gradient FlattenLayer = ()
29 type Gradient FlattenLayer = ()
30 runUpdate _ _ _ = FlattenLayer
30 runUpdate _ _ _ = FlattenLayer
31+ createRandom = return FlattenLayer
32+
31
33
32instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer FlattenLayer ('D2 x y) ('D1 a) where
34instance (KnownNat a, KnownNat x, KnownNat y, a ~ (x * y)) => Layer FlattenLayer ('D2 x y) ('D1 a) where
33 runForwards _ (S2D' y) = S1D' . fromList . toList . flatten . extract $ y
35 runForwards _ (S2D' y) = S1D' . fromList . toList . flatten . extract $ y
src/Grenade/Layers/FullyConnected.hs+2
@@ -45,6 +45,8 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (FullyConnected i o) where
45 newActivations = oldActivations + newMomentum - regulariser
45 newActivations = oldActivations + newMomentum - regulariser
46 in FullyConnected newBias newBiasMomentum newActivations newMomentum
46 in FullyConnected newBias newBiasMomentum newActivations newMomentum
47
47
48+ createRandom = randomFullyConnected
49+
48instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o) where
50instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o) where
49 -- Do a matrix vector multiplication and return the result.
51 -- Do a matrix vector multiplication and return the result.
50 runForwards (FullyConnected wB _ wN _) (S1D' v) = S1D' (wB + wN #> v)
52 runForwards (FullyConnected wB _ wN _) (S1D' v) = S1D' (wB + wN #> v)
src/Grenade/Layers/Fuse.hs+5−4
@@ -23,23 +23,24 @@ import Grenade.Core.Shape
23-- This does however have a trade off, internal incremental states in the Wengert tape are
23-- This does however have a trade off, internal incremental states in the Wengert tape are
24-- not retained during reverse accumulation. So less RAM is used, but more compute is required.
24-- not retained during reverse accumulation. So less RAM is used, but more compute is required.
25data Fuse :: * -> * -> Shape -> Shape -> Shape -> * where
25data Fuse :: * -> * -> Shape -> Shape -> Shape -> * where
26− (:$$) :: (Show x, Show y, Layer x i h, Layer y h o, KnownShape h, KnownShape i, KnownShape o)
26+ (:$$) :: (Layer x i h, Layer y h o)
27 => !x
27 => !x
28 -> !y
28 -> !y
29 -> Fuse x y i h o
29 -> Fuse x y i h o
30infixr 5 :$$
30infixr 5 :$$
31
31
32−instance Show (Fuse x y i h o) where
32+instance (Show x, Show y) => Show (Fuse x y i h o) where
33 show (x :$$ y) = "(" ++ show x ++ " :$$ " ++ show y ++ ")"
33 show (x :$$ y) = "(" ++ show x ++ " :$$ " ++ show y ++ ")"
34
34
35−instance (KnownShape i, KnownShape h, KnownShape o) => UpdateLayer (Fuse x y i h o) where
35+instance (Layer x i h, Layer y h o) => UpdateLayer (Fuse x y i h o) where
36 type Gradient (Fuse x y i h o) = (Gradient x, Gradient y)
36 type Gradient (Fuse x y i h o) = (Gradient x, Gradient y)
37 runUpdate lr (x :$$ y) (x', y') =
37 runUpdate lr (x :$$ y) (x', y') =
38 let newX = runUpdate lr x x'
38 let newX = runUpdate lr x x'
39 newY = runUpdate lr y y'
39 newY = runUpdate lr y y'
40 in (newX :$$ newY)
40 in (newX :$$ newY)
41+ createRandom = (:$$) <$> createRandom <*> createRandom
41
42
42−instance (KnownShape i, KnownShape h, KnownShape o) => Layer (Fuse x y i h o) i o where
43+instance (Layer x i h, Layer y h o) => Layer (Fuse x y i h o) i o where
43 runForwards (x :$$ y) input =
44 runForwards (x :$$ y) input =
44 let yInput :: S' h = runForwards x input
45 let yInput :: S' h = runForwards x input
45 in runForwards y yInput
46 in runForwards y yInput
src/Grenade/Layers/Logit.hs+1
@@ -25,6 +25,7 @@ data Logit = Logit
25instance UpdateLayer Logit where
25instance UpdateLayer Logit where
26 type Gradient Logit = ()
26 type Gradient Logit = ()
27 runUpdate _ _ _ = Logit
27 runUpdate _ _ _ = Logit
28+ createRandom = return Logit
28
29
29instance (KnownNat i) => Layer Logit ('D1 i) ('D1 i) where
30instance (KnownNat i) => Layer Logit ('D1 i) ('D1 i) where
30 runForwards _ (S1D' y) = S1D' (logistic y)
31 runForwards _ (S1D' y) = S1D' (logistic y)
src/Grenade/Layers/Pad.hs+2−5
@@ -28,11 +28,7 @@ data Pad :: Nat
28 -> Nat
28 -> Nat
29 -> Nat
29 -> Nat
30 -> Nat -> * where
30 -> Nat -> * where
31− Pad :: ( KnownNat padLeft
32− , KnownNat padTop
33− , KnownNat padRight
34− , KnownNat padBottom
35− ) => Pad padLeft padTop padRight padBottom
31+ Pad :: Pad padLeft padTop padRight padBottom
36
32
37instance Show (Pad padLeft padTop padRight padBottom) where
33instance Show (Pad padLeft padTop padRight padBottom) where
38 show Pad = "Pad"
34 show Pad = "Pad"
@@ -40,6 +36,7 @@ instance Show (Pad padLeft padTop padRight padBottom) where
40instance UpdateLayer (Pad l t r b) where
36instance UpdateLayer (Pad l t r b) where
41 type Gradient (Pad l t r b) = ()
37 type Gradient (Pad l t r b) = ()
42 runUpdate _ x _ = x
38 runUpdate _ x _ = x
39+ createRandom = return Pad
43
40
44-- | A two dimentional image can be padped.
41-- | A two dimentional image can be padped.
45instance ( KnownNat padLeft
42instance ( KnownNat padLeft
src/Grenade/Layers/Pooling.hs+2−5
@@ -41,11 +41,7 @@ data Pooling :: Nat
41 -> Nat
41 -> Nat
42 -> Nat
42 -> Nat
43 -> Nat -> * where
43 -> Nat -> * where
44− Pooling :: ( KnownNat kernelRows
45− , KnownNat kernelColumns
46− , KnownNat strideRows
47− , KnownNat strideColumns
48− ) => Pooling kernelRows kernelColumns strideRows strideColumns
44+ Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns
49
45
50instance Show (Pooling k k' s s') where
46instance Show (Pooling k k' s s') where
51 show Pooling = "Pooling"
47 show Pooling = "Pooling"
@@ -54,6 +50,7 @@ instance Show (Pooling k k' s s') where
54instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where
50instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where
55 type Gradient (Pooling kr kc sr sc) = ()
51 type Gradient (Pooling kr kc sr sc) = ()
56 runUpdate _ Pooling _ = Pooling
52 runUpdate _ Pooling _ = Pooling
53+ createRandom = return Pooling
57
54
58-- | A two dimentional image can be pooled.
55-- | A two dimentional image can be pooled.
59instance ( KnownNat kernelRows
56instance ( KnownNat kernelRows
src/Grenade/Layers/Relu.hs+1
@@ -25,6 +25,7 @@ data Relu = Relu
25instance UpdateLayer Relu where
25instance UpdateLayer Relu where
26 type Gradient Relu = ()
26 type Gradient Relu = ()
27 runUpdate _ _ _ = Relu
27 runUpdate _ _ _ = Relu
28+ createRandom = return Relu
28
29
29instance ( KnownNat i) => Layer Relu ('D1 i) ('D1 i) where
30instance ( KnownNat i) => Layer Relu ('D1 i) ('D1 i) where
30 runForwards _ (S1D' y) = S1D' (relu y)
31 runForwards _ (S1D' y) = S1D' (relu y)
src/Grenade/Layers/Tanh.hs+2−1
@@ -15,13 +15,14 @@ import Grenade.Core.Network
15import Grenade.Core.Shape
15import Grenade.Core.Shape
16
16
17-- | A Tanh layer.
17-- | A Tanh layer.
18−-- A layer which can act between any shape of the same dimension, perfoming an tanh function.s
18+-- A layer which can act between any shape of the same dimension, perfoming a tanh function.
19data Tanh = Tanh
19data Tanh = Tanh
20 deriving Show
20 deriving Show
21
21
22instance UpdateLayer Tanh where
22instance UpdateLayer Tanh where
23 type Gradient Tanh = ()
23 type Gradient Tanh = ()
24 runUpdate _ _ _ = Tanh
24 runUpdate _ _ _ = Tanh
25+ createRandom = return Tanh
25
26
26instance KnownNat i => Layer Tanh ('D1 i) ('D1 i) where
27instance KnownNat i => Layer Tanh ('D1 i) ('D1 i) where
27 runForwards _ (S1D' y) = S1D' (tanh y)
28 runForwards _ (S1D' y) = S1D' (tanh y)