@@ -0,0 +1,203 @@
2+{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE TemplateHaskell #-}
9+{-# LANGUAGE FlexibleContexts #-}
10+module Test.Hedgehog.Network where
12+import Control.Monad.ST ( runST )
14+import Data.Constraint
15+#if __GLASGOW_HASKELL__ < 800
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
25+import Hedgehog.Gen ( Gen )
26+import qualified Hedgehog.Gen as Gen
27+import Hedgehog.Internal.Source
28+import Hedgehog.Internal.Property ( failWith )
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
39+import Numeric.LinearAlgebra ( flatten )
40+import Numeric.LinearAlgebra.Static ( size , extract, norm_Inf )
43+data SomeNetwork :: * where
44+ SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork
46+instance Show SomeNetwork where
47+ show (SomeNetwork net) = show net
49+-- | Generate a random network of a random type
51+-- This is slightly insane
52+genNetwork :: Monad m => Gen m SomeNetwork
54+ Gen.recursive Gen.choice [
55+ do SomeSing ( r :: Sing final ) <- genShape
57+ pure (SomeNetwork (NNil :: Network '[] '[ final ] ))
59+ do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork
60+ case ( sing :: Sing shapes ) of
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 )))
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 )))
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...
83+ let (rs, cs) = size x
84+ let output_r = fromIntegral rs
85+ let output_c = fromIntegral cs
87+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
89+ -- Get some kernels which will fit
90+ kernel_r <- choose 1 output_r
91+ kernel_c <- choose 1 output_c
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
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
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
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 )))
121+ pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))
122+ , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))
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
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
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)
149+ case ( sing :: Sing shape ) of
150+ D1Sing -> let x = 0 :: S ( shape )
154+ let len = VS.length ex
155+ ix <- choose 0 (len - 1)
156+ let nx = runST $ do ex' <- VS.thaw ex
159+ maybe Gen.discard pure . fromStorable $ nx
161+ D2Sing -> let x = 0 :: S ( shape )
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
170+ maybe Gen.discard pure . fromStorable $ nx
172+ D3Sing -> let x = 0 :: S ( shape )
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
181+ maybe Gen.discard pure . fromStorable $ nx
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
188+(~~~) :: (Monad m, HasCallStack) => Double -> Double -> Test m ()
190+ if (x - y) < 1e-5 then
193+ withFrozenCallStack $
194+ failWith Nothing $ unlines [
195+ "━━━ Not Simliar ━━━"
203+tests = $$(checkConcurrent)