@@ -0,0 +1,275 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE FlexibleContexts #-}
10+module Grenade.Layers.Deconvolution (
11+ Deconvolution (..)
12+ , Deconvolution' (..)
13+ , randomDeconvolution
14+ ) where
15+
16+import Control.Monad.Random hiding ( fromList )
17+import Data.Maybe
18+import Data.Proxy
19+import Data.Serialize
20+import Data.Singletons.TypeLits
21+
22+import GHC.TypeLits
23+
24+import Numeric.LinearAlgebra hiding ( uniformSample, konst )
25+import qualified Numeric.LinearAlgebra as LA
26+import Numeric.LinearAlgebra.Static hiding ((|||), build, toRows)
27+
28+import Grenade.Core
29+import Grenade.Layers.Internal.Convolution
30+import Grenade.Layers.Internal.Update
31+
32+-- | A Deconvolution layer for a neural network.
33+-- This uses the im2col Deconvolution trick popularised by Caffe, which essentially turns the
34+-- many, many, many, many loop Deconvolution into a single matrix multiplication.
35+--
36+-- The Deconvolution layer takes all of the kernels for the Deconvolution, which are flattened
37+-- and then put into columns in the matrix.
38+--
39+-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:
40+-- `out = (in - kernel) / stride + 1` for both dimensions.
41+--
42+-- One probably shouldn't build their own layer, but rather use the randomDeconvolution function.
43+data Deconvolution :: Nat -- Number of channels, for the first layer this could be RGB for instance.
44+ -> Nat -- Number of filters, this is the number of channels output by the layer.
45+ -> Nat -- The number of rows in the kernel filter
46+ -> Nat -- The number of column in the kernel filter
47+ -> Nat -- The row stride of the Deconvolution filter
48+ -> Nat -- The columns stride of the Deconvolution filter
49+ -> * where
50+ Deconvolution :: ( KnownNat channels
51+ , KnownNat filters
52+ , KnownNat kernelRows
53+ , KnownNat kernelColumns
54+ , KnownNat strideRows
55+ , KnownNat strideColumns
56+ , KnownNat kernelFlattened
57+ , kernelFlattened ~ (kernelRows * kernelColumns * filters))
58+ => !(L kernelFlattened channels) -- The kernel filter weights
59+ -> !(L kernelFlattened channels) -- The last kernel update (or momentum)
60+ -> Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns
61+
62+data Deconvolution' :: Nat -- Number of channels, for the first layer this could be RGB for instance.
63+ -> Nat -- Number of filters, this is the number of channels output by the layer.
64+ -> Nat -- The number of rows in the kernel filter
65+ -> Nat -- The number of column in the kernel filter
66+ -> Nat -- The row stride of the Deconvolution filter
67+ -> Nat -- The columns stride of the Deconvolution filter
68+ -> * where
69+ Deconvolution' :: ( KnownNat channels
70+ , KnownNat filters
71+ , KnownNat kernelRows
72+ , KnownNat kernelColumns
73+ , KnownNat strideRows
74+ , KnownNat strideColumns
75+ , KnownNat kernelFlattened
76+ , kernelFlattened ~ (kernelRows * kernelColumns * filters))
77+ => !(L kernelFlattened channels) -- The kernel filter gradient
78+ -> Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns
79+
80+instance Show (Deconvolution c f k k' s s') where
81+ show (Deconvolution a _) = renderConv a
82+ where
83+ renderConv mm =
84+ let m = extract mm
85+ ky = fromIntegral $ natVal (Proxy :: Proxy k)
86+ rs = LA.toColumns m
87+ ms = map (take ky) $ toLists . reshape ky <$> rs
88+
89+ render n' | n' <= 0.2 = ' '
90+ | n' <= 0.4 = '.'
91+ | n' <= 0.6 = '-'
92+ | n' <= 0.8 = '='
93+ | otherwise = '#'
94+
95+ px = (fmap . fmap . fmap) render ms
96+ in unlines $ foldl1 (zipWith (\a' b' -> a' ++ " | " ++ b')) $ px
97+
98+randomDeconvolution :: ( MonadRandom m
99+ , KnownNat channels
100+ , KnownNat filters
101+ , KnownNat kernelRows
102+ , KnownNat kernelColumns
103+ , KnownNat strideRows
104+ , KnownNat strideColumns
105+ , KnownNat kernelFlattened
106+ , kernelFlattened ~ (kernelRows * kernelColumns * filters))
107+ => m (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns)
108+randomDeconvolution = do
109+ s <- getRandom
110+ let wN = uniformSample s (-1) 1
111+ mm = konst 0
112+ return $ Deconvolution wN mm
113+
114+instance ( KnownNat channels
115+ , KnownNat filters
116+ , KnownNat kernelRows
117+ , KnownNat kernelColumns
118+ , KnownNat strideRows
119+ , KnownNat strideColumns
120+ , KnownNat (kernelRows * kernelColumns * filters)
121+ ) => UpdateLayer (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where
122+ type Gradient (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) = (Deconvolution' channels filters kernelRows kernelCols strideRows strideCols)
123+ runUpdate LearningParameters {..} (Deconvolution oldKernel oldMomentum) (Deconvolution' kernelGradient) =
124+ let (newKernel, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldKernel kernelGradient oldMomentum
125+ in Deconvolution newKernel newMomentum
126+
127+ createRandom = randomDeconvolution
128+
129+instance ( KnownNat channels
130+ , KnownNat filters
131+ , KnownNat kernelRows
132+ , KnownNat kernelColumns
133+ , KnownNat strideRows
134+ , KnownNat strideColumns
135+ , KnownNat (kernelRows * kernelColumns * filters)
136+ ) => Serialize (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where
137+ put (Deconvolution w _) = putListOf put . toList . flatten . extract $ w
138+ get = do
139+ let f = fromIntegral $ natVal (Proxy :: Proxy channels)
140+ wN <- maybe (fail "Vector of incorrect size") return . create . reshape f . LA.fromList =<< getListOf get
141+ let mm = konst 0
142+ return $ Deconvolution wN mm
143+
144+-- | A two dimentional image may have a Deconvolution filter applied to it
145+instance ( KnownNat kernelRows
146+ , KnownNat kernelCols
147+ , KnownNat filters
148+ , KnownNat strideRows
149+ , KnownNat strideCols
150+ , KnownNat inputRows
151+ , KnownNat inputCols
152+ , KnownNat outputRows
153+ , KnownNat outputCols
154+ , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
155+ , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
156+ , KnownNat (kernelRows * kernelCols * filters)
157+ , KnownNat (outputRows * filters)
158+ ) => Layer (Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) where
159+ type Tape (Deconvolution 1 filters kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols 1)
160+ runForwards c (S2D input) =
161+ runForwards c (S3D input :: S ('D3 inputRows inputCols 1))
162+
163+ runBackwards c tape grads =
164+ case runBackwards c tape grads of
165+ (c', S3D back :: S ('D3 inputRows inputCols 1)) -> (c', S2D back)
166+
167+-- | A two dimentional image may have a Deconvolution filter applied to it
168+instance ( KnownNat kernelRows
169+ , KnownNat kernelCols
170+ , KnownNat strideRows
171+ , KnownNat strideCols
172+ , KnownNat inputRows
173+ , KnownNat inputCols
174+ , KnownNat outputRows
175+ , KnownNat outputCols
176+ , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
177+ , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
178+ , KnownNat (kernelRows * kernelCols * 1)
179+ , KnownNat (outputRows * 1)
180+ ) => Layer (Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) where
181+ type Tape (Deconvolution 1 1 kernelRows kernelCols strideRows strideCols) ('D2 inputRows inputCols) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols 1)
182+ runForwards c (S2D input) =
183+ case runForwards c (S3D input :: S ('D3 inputRows inputCols 1)) of
184+ (tps, S3D fore :: S ('D3 outputRows outputCols 1)) -> (tps, S2D fore)
185+
186+ runBackwards c tape (S2D grads) =
187+ case runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1)) of
188+ (c', S3D back :: S ('D3 inputRows inputCols 1)) -> (c', S2D back)
189+
190+-- | A two dimentional image may have a Deconvolution filter applied to it
191+instance ( KnownNat kernelRows
192+ , KnownNat kernelCols
193+ , KnownNat strideRows
194+ , KnownNat strideCols
195+ , KnownNat inputRows
196+ , KnownNat inputCols
197+ , KnownNat outputRows
198+ , KnownNat outputCols
199+ , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
200+ , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
201+ , KnownNat (kernelRows * kernelCols * 1)
202+ , KnownNat (outputRows * 1)
203+ , KnownNat channels
204+ ) => Layer (Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) where
205+ type Tape (Deconvolution channels 1 kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D2 outputRows outputCols) = S ('D3 inputRows inputCols channels)
206+ runForwards c input =
207+ case runForwards c input of
208+ (tps, S3D fore :: S ('D3 outputRows outputCols 1)) -> (tps, S2D fore)
209+
210+ runBackwards c tape (S2D grads) =
211+ runBackwards c tape (S3D grads :: S ('D3 outputRows outputCols 1))
212+
213+-- | A three dimensional image (or 2d with many channels) can have
214+-- an appropriately sized Deconvolution filter run across it.
215+instance ( KnownNat kernelRows
216+ , KnownNat kernelCols
217+ , KnownNat filters
218+ , KnownNat strideRows
219+ , KnownNat strideCols
220+ , KnownNat inputRows
221+ , KnownNat inputCols
222+ , KnownNat outputRows
223+ , KnownNat outputCols
224+ , KnownNat channels
225+ , ((inputRows - 1) * strideRows) ~ (outputRows - kernelRows)
226+ , ((inputCols - 1) * strideCols) ~ (outputCols - kernelCols)
227+ , KnownNat (kernelRows * kernelCols * filters)
228+ , KnownNat (outputRows * filters)
229+ ) => Layer (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) where
230+
231+ type Tape (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) ('D3 inputRows inputCols channels) ('D3 outputRows outputCols filters) = S ('D3 inputRows inputCols channels)
232+
233+ runForwards (Deconvolution kernel _) (S3D input) =
234+ let ex = extract input
235+ ek = extract kernel
236+ ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
237+ iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
238+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
239+ ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
240+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
241+ sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
242+ ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
243+ oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
244+
245+ c = vid2col 1 1 1 1 ix iy ex
246+
247+ mt = c LA.<> tr ek
248+
249+ r = col2vid kx ky sx sy ox oy mt
250+ rs = fromJust . create $ r
251+ in (S3D input, S3D rs)
252+ runBackwards (Deconvolution kernel _) (S3D input) (S3D dEdy) =
253+ let ex = extract input
254+ ix = fromIntegral $ natVal (Proxy :: Proxy inputRows)
255+ iy = fromIntegral $ natVal (Proxy :: Proxy inputCols)
256+ kx = fromIntegral $ natVal (Proxy :: Proxy kernelRows)
257+ ky = fromIntegral $ natVal (Proxy :: Proxy kernelCols)
258+ sx = fromIntegral $ natVal (Proxy :: Proxy strideRows)
259+ sy = fromIntegral $ natVal (Proxy :: Proxy strideCols)
260+ ox = fromIntegral $ natVal (Proxy :: Proxy outputRows)
261+ oy = fromIntegral $ natVal (Proxy :: Proxy outputCols)
262+
263+ c = vid2col 1 1 1 1 ix iy ex
264+
265+ eo = extract dEdy
266+ ek = extract kernel
267+
268+ vs = vid2col kx ky sx sy ox oy eo
269+
270+ kN = fromJust . create . tr $ tr c LA.<> vs
271+
272+ dW = vs LA.<> ek
273+
274+ xW = col2vid 1 1 1 1 ix iy dW
275+ in (Deconvolution' kN, S3D . fromJust . create $ xW)