@@ -0,0 +1,203 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE TemplateHaskell #-}
9+{-# LANGUAGE FlexibleContexts #-}
10+module Test.Hedgehog.Network where
11+
12+import Control.Monad.ST ( runST )
13+
14+import Data.Constraint
15+#if __GLASGOW_HASKELL__ < 800
16+import Data.Proxy
17+#endif
18+import qualified Data.Vector.Storable as VS
19+import qualified Data.Vector.Storable.Mutable as VS ( write )
20+import Data.Singletons
21+import Data.Singletons.Prelude.List
22+-- import Data.Type.Equality
23+
24+import Hedgehog
25+import Hedgehog.Gen ( Gen )
26+import qualified Hedgehog.Gen as Gen
27+import Hedgehog.Internal.Source
28+import Hedgehog.Internal.Property ( failWith )
29+
30+import Grenade
31+
32+import GHC.TypeLits
33+import GHC.TypeLits.Witnesses
34+import Test.Hedgehog.Compat
35+import Test.Hedgehog.TypeLits
36+import Test.Hedgehog.Hmatrix
37+import Test.Grenade.Layers.Convolution
38+
39+import Numeric.LinearAlgebra ( flatten )
40+import Numeric.LinearAlgebra.Static ( size , extract, norm_Inf )
41+import Unsafe.Coerce
42+
43+data SomeNetwork :: * where
44+ SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork
45+
46+instance Show SomeNetwork where
47+ show (SomeNetwork net) = show net
48+
49+-- | Generate a random network of a random type
50+--
51+-- This is slightly insane
52+genNetwork :: Monad m => Gen m SomeNetwork
53+genNetwork =
54+ Gen.recursive Gen.choice [
55+ do SomeSing ( r :: Sing final ) <- genShape
56+ withSingI r $
57+ pure (SomeNetwork (NNil :: Network '[] '[ final ] ))
58+ ] [
59+ do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork
60+ case ( sing :: Sing shapes ) of
61+ 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 ->
68+ Gen.choice [
69+ pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
70+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))
71+ , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))
72+ ]
73+ D2Sing ->
74+ Gen.choice [
75+ pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
76+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))
77+ , do -- Build a convolution layer with one filter output
78+ -- Figure out some kernel sizes which work for this layer
79+ -- 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
118+ ]
119+ D3Sing ->
120+ Gen.choice [
121+ pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
122+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))
123+ ]
124+ ]
125+ ]
126+
127+-- Test a partial derivative numerically for a random network and input
128+prop_auto_diff :: Property
129+prop_auto_diff = property $ do
130+ SomeNetwork (network :: Network layers shapes) <- forAll genNetwork
131+ (input :: S (Head shapes)) <- forAllRender nice genOfShape
132+ (target :: S (Last shapes)) <- forAllRender nice oneUp
133+ (tested :: S (Head shapes)) <- forAllRender nice oneUp
134+
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
141+
142+ result ~~~ expected
143+
144+ where
145+
146+-- 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)
148+oneUp =
149+ 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
182+
183+maxVal :: S shape -> Double
184+maxVal ( S1D x ) = norm_Inf x
185+maxVal ( S2D x ) = norm_Inf x
186+maxVal ( S3D x ) = norm_Inf x
187+
188+(~~~) :: (Monad m, HasCallStack) => Double -> Double -> Test m ()
189+(~~~) x y =
190+ if (x - y) < 1e-5 then
191+ success
192+ else
193+ withFrozenCallStack $
194+ failWith Nothing $ unlines [
195+ "━━━ Not Simliar ━━━"
196+ , show x
197+ , show y
198+ ]
199+infix 4 ~~~
200+
201+
202+tests :: IO Bool
203+tests = $$(checkConcurrent)