@@ -1,4 +1,5 @@
11{-# LANGUAGE CPP #-}
2+{-# LANGUAGE BangPatterns #-}
23{-# LANGUAGE RankNTypes #-}
34{-# LANGUAGE DataKinds #-}
45{-# LANGUAGE ScopedTypeVariables #-}
@@ -9,6 +10,7 @@
910{-# LANGUAGE FlexibleContexts #-}
1011module Test.Hedgehog.Network where
1112
13+import Control.Monad ( guard )
1214import Control.Monad.ST ( runST )
1315
1416import Data.Constraint
@@ -19,10 +21,11 @@ import qualified Data.Vector.Storable as VS
1921import qualified Data.Vector.Storable.Mutable as VS ( write )
2022import Data.Singletons
2123import Data.Singletons.Prelude.List
24+import Data.Singletons.TypeLits
25+
2226-- import Data.Type.Equality
2327
2428import Hedgehog
25−import Hedgehog.Gen ( Gen )
2629import qualified Hedgehog.Gen as Gen
2730import Hedgehog.Internal.Source
2831import Hedgehog.Internal.Property ( failWith )
@@ -37,7 +40,7 @@ import Test.Hedgehog.Hmatrix
3740import Test.Grenade.Layers.Convolution
3841
3942import Numeric.LinearAlgebra ( flatten )
40−import Numeric.LinearAlgebra.Static ( size , extract, norm_Inf )
43+import Numeric.LinearAlgebra.Static ( extract, norm_Inf )
4144import Unsafe.Coerce
4245
4346data SomeNetwork :: * where
@@ -48,8 +51,9 @@ instance Show SomeNetwork where
4851
4952-- | Generate a random network of a random type
5053--
51−-- This is slightly insane
52−genNetwork :: Monad m => Gen m SomeNetwork
54+-- This is slightly insane for a few reasons. Everything must be wrapped up
55+-- in a SomeNetwork.
56+genNetwork :: Monad m => Gen.Gen m SomeNetwork
5357genNetwork =
5458 Gen.recursive Gen.choice [
5559 do SomeSing ( r :: Sing final ) <- genShape
@@ -59,126 +63,214 @@ genNetwork =
5963 do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork
6064 case ( sing :: Sing shapes ) of
6165 SNil -> Gen.discard
62− SCons ( r :: Sing h ) ( _ :: Sing hs ) ->
63− withSingI r $ Gen.choice [
64− pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))
65− , pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))
66− , case r of
67− D1Sing ->
66+ SCons ( h :: Sing h ) ( _ :: Sing hs ) ->
67+ withSingI h $
68+ case h of
69+ D1Sing l -> withKnownNat l $
6870 Gen.choice [
69− pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
71+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))
72+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))
73+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
7074 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))
7175 , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))
7276 ]
73− D2Sing ->
77+ D2Sing r c -> withKnownNat r $ withKnownNat c $
7478 Gen.choice [
75− pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
79+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))
80+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))
81+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
7682 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))
7783 , do -- Build a convolution layer with one filter output
7884 -- Figure out some kernel sizes which work for this layer
7985 -- There must be a better way than this...
80− let dumb :: S h = 0
81− case dumb of
82− S2D x -> do
83− let (rs, cs) = size x
84− let output_r = fromIntegral rs
85− let output_c = fromIntegral cs
86−
87− let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
88−
89− -- Get some kernels which will fit
90− kernel_r <- choose 1 output_r
91− kernel_c <- choose 1 output_c
92−
93− -- Build up some strides which also fit
94− stride_r <- Gen.element $ ok output_r kernel_r
95− stride_c <- Gen.element $ ok output_c kernel_c
96−
97− -- Determine the input size
98− let input_r = (output_r - 1) * stride_r + kernel_r
99− let input_c = (output_c - 1) * stride_c + kernel_c
100−
101− -- Remake types for input
102− case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of
103− ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),
104− Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),
105− Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),
106− Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->
107− let p1 = natDict pkr
108− p2 = natDict pkc
109− in case ( p1 %* p2
110− -- Fake it till you make it.
111− , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))
112− , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
113− , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
114− (Dict, Dict, Dict, Dict) -> do
115− conv <- genConvolution
116− pure (SomeNetwork (conv :~> rest :: Network ( Convolution 1 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))
117− _ -> Gen.discard
86+ let output_r = natVal r
87+ let output_c = natVal c
88+
89+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
90+
91+ -- Get some kernels which will fit
92+ kernel_r <- choose 1 output_r
93+ kernel_c <- choose 1 output_c
94+
95+ -- Build up some strides which also fit
96+ stride_r <- Gen.element $ ok output_r kernel_r
97+ stride_c <- Gen.element $ ok output_c kernel_c
98+
99+ -- Determine the input size
100+ let input_r = (output_r - 1) * stride_r + kernel_r
101+ let input_c = (output_c - 1) * stride_c + kernel_c
102+
103+ guard (input_r < 100)
104+ guard (input_c < 100)
105+
106+ -- Remake types for input
107+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of
108+ ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),
109+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),
110+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),
111+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->
112+ let p1 = natDict pkr
113+ p2 = natDict pkc
114+ in case ( p1 %* p2
115+ -- Fake it till you make it.
116+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))
117+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
118+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
119+ (Dict, Dict, Dict, Dict) -> do
120+ conv <- genConvolution
121+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution 1 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))
122+ _ -> Gen.discard -- Can't occur
123+ , do -- Build a convolution layer with one filter output
124+ -- Figure out some kernel sizes which work for this layer
125+ -- There must be a better way than this...
126+ let output_r = natVal r
127+ let output_c = natVal c
128+
129+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
130+
131+ -- Get some kernels which will fit
132+ kernel_r <- choose 1 output_r
133+ kernel_c <- choose 1 output_c
134+ channels <- choose 1 10
135+
136+ -- Build up some strides which also fit
137+ stride_r <- Gen.element $ ok output_r kernel_r
138+ stride_c <- Gen.element $ ok output_c kernel_c
139+
140+ -- Determine the input size
141+ let input_r = (output_r - 1) * stride_r + kernel_r
142+ let input_c = (output_c - 1) * stride_c + kernel_c
143+
144+ guard (input_r < 100)
145+ guard (input_c < 100)
146+
147+ -- Remake types for input
148+ case ( someNatVal channels, someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of
149+ ( Just (SomeNat (chan :: Proxy channels)),
150+ Just (SomeNat (pinr :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),
151+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),
152+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),
153+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->
154+ let p1 = natDict pkr
155+ p2 = natDict pkc
156+ p3 = natDict chan
157+ in case ( p1 %* p2 %* p3
158+ , natDict pinr %* natDict chan
159+ -- Fake it till you make it.
160+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))
161+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
162+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
163+ (Dict, Dict, Dict, Dict, Dict) -> do
164+ conv <- genConvolution
165+ pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))
166+ _ -> Gen.discard -- Can't occur
167+ , do -- Build a Pooling layer
168+ let output_r = natVal r
169+ let output_c = natVal c
170+
171+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
172+
173+ -- Get some kernels which will fit
174+ kernel_r <- choose 1 output_r
175+ kernel_c <- choose 1 output_c
176+
177+ -- Build up some strides which also fit
178+ stride_r <- Gen.element $ ok output_r kernel_r
179+ stride_c <- Gen.element $ ok output_c kernel_c
180+
181+ -- Determine the input size
182+ let input_r = (output_r - 1) * stride_r + kernel_r
183+ let input_c = (output_c - 1) * stride_c + kernel_c
184+
185+ guard (input_r < 100)
186+ guard (input_c < 100)
187+
188+ -- Remake types for input
189+ case ( someNatVal input_r, someNatVal input_c, someNatVal output_r, someNatVal output_c, someNatVal kernel_r, someNatVal kernel_c, someNatVal stride_r, someNatVal stride_c ) of
190+ ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),
191+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),
192+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),
193+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->
194+ let p1 = natDict pkr
195+ p2 = natDict pkc
196+ in case ( p1 %* p2
197+ -- Fake it till you make it.
198+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))
199+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))
200+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of
201+ (Dict, Dict, Dict, Dict) ->
202+ pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))
203+ _ -> Gen.discard -- Can't occur
118204 ]
119− D3Sing ->
205+ D3Sing r c d -> withKnownNat d $ withKnownNat r $ withKnownNat c $
120206 Gen.choice [
121− pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
207+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))
208+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))
209+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
122210 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))
123211 ]
124− ]
125212 ]
126213
127−-- Test a partial derivative numerically for a random network and input
214+-- | Test a partial derivative numerically for a random network and input
215+--
216+-- This is the most important test.
128217prop_auto_diff :: Property
129−prop_auto_diff = property $ do
218+prop_auto_diff = withTests 10000 . property $ do
130219 SomeNetwork (network :: Network layers shapes) <- forAll genNetwork
131220 (input :: S (Head shapes)) <- forAllRender nice genOfShape
132221 (target :: S (Last shapes)) <- forAllRender nice oneUp
133222 (tested :: S (Head shapes)) <- forAllRender nice oneUp
134223
135− let (tapes, output) = runNetwork network input
136− let (_, bgrad) = runGradient network tapes target
137− let inputDiff = input + tested * 0.00001
138− let expected = maxVal ( bgrad * tested )
139− let (_, outputDiff) = runNetwork network inputDiff
140− let result = maxVal ( outputDiff * target - output * target ) / 0.00001
224+ let (!tapes, !output) = runNetwork network input
225+ let (_, !backgrad) = runGradient network tapes target
226+ let inputDiff = input + tested * 0.00001
227+ let expected = maxVal ( backgrad * tested )
228+ let (_, !outputDiff) = runNetwork network inputDiff
229+ let result = maxVal ( outputDiff * target - output * target ) / 0.00001
141230
142231 result ~~~ expected
143232
144233 where
145234
146235-- Make a shape where all are 0 except for 1 value, which is 1.
147−oneUp :: forall shape m. ( Monad m, SingI shape ) => Gen m (S shape)
236+oneUp :: forall shape m. ( Monad m, SingI shape ) => Gen.Gen m (S shape)
148237oneUp =
149238 case ( sing :: Sing shape ) of
150− D1Sing -> let x = 0 :: S ( shape )
151− in case x of
152− ( S1D x' ) -> do
153− let ex = extract x'
154− let len = VS.length ex
155− ix <- choose 0 (len - 1)
156− let nx = runST $ do ex' <- VS.thaw ex
157− VS.write ex' ix 1.0
158− VS.freeze ex'
159− maybe Gen.discard pure . fromStorable $ nx
160−
161− D2Sing -> let x = 0 :: S ( shape )
162− in case x of
163− ( S2D x' ) -> do
164− let ex = flatten ( extract x' )
165− let len = VS.length ex
166− ix <- choose 0 (len - 1)
167− let nx = runST $ do ex' <- VS.thaw ex
168− VS.write ex' ix 1
169− VS.freeze ex'
170− maybe Gen.discard pure . fromStorable $ nx
171−
172− D3Sing -> let x = 0 :: S ( shape )
173− in case x of
174− ( S3D x' ) -> do
175− let ex = flatten ( extract x' )
176− let len = VS.length ex
177− ix <- choose 0 (len - 1)
178− let nx = runST $ do ex' <- VS.thaw ex
179− VS.write ex' ix 1
180− VS.freeze ex'
181− maybe Gen.discard pure . fromStorable $ nx
239+ D1Sing l -> withKnownNat l $
240+ let x = 0 :: S ( shape )
241+ in case x of
242+ ( S1D x' ) -> do
243+ let ex = extract x'
244+ let len = VS.length ex
245+ ix <- choose 0 (len - 1)
246+ let nx = runST $ do ex' <- VS.thaw ex
247+ VS.write ex' ix 1.0
248+ VS.freeze ex'
249+ maybe Gen.discard pure . fromStorable $ nx
250+
251+ D2Sing r c -> withKnownNat r $ withKnownNat c $
252+ let x = 0 :: S ( shape )
253+ in case x of
254+ ( S2D x' ) -> do
255+ let ex = flatten ( extract x' )
256+ let len = VS.length ex
257+ ix <- choose 0 (len - 1)
258+ let nx = runST $ do ex' <- VS.thaw ex
259+ VS.write ex' ix 1
260+ VS.freeze ex'
261+ maybe Gen.discard pure . fromStorable $ nx
262+
263+ D3Sing r c d -> withKnownNat r $ withKnownNat c $ withKnownNat d $
264+ let x = 0 :: S ( shape )
265+ in case x of
266+ ( S3D x' ) -> do
267+ let ex = flatten ( extract x' )
268+ let len = VS.length ex
269+ ix <- choose 0 (len - 1)
270+ let nx = runST $ do ex' <- VS.thaw ex
271+ VS.write ex' ix 1
272+ VS.freeze ex'
273+ maybe Gen.discard pure . fromStorable $ nx
182274
183275maxVal :: S shape -> Double
184276maxVal ( S1D x ) = norm_Inf x
@@ -187,7 +279,7 @@ maxVal ( S3D x ) = norm_Inf x
187279
188280(~~~) :: (Monad m, HasCallStack) => Double -> Double -> Test m ()
189281(~~~) x y =
190− if (x - y) < 1e-5 then
282+ if abs (x - y) < 1e-5 then
191283 success
192284 else
193285 withFrozenCallStack $