8767e83 · grenade · git.iko.soy

git.iko.soy/grenade

on master help sign in

Change the singleton type for shape.

8767e83Huw Campbell10 years ago

grenade.cabal+3

compare with master

unifiedsplit

@@ -122,6 +122,9 @@ test-suite test

122 hs-source-dirs:

123 test

124

125+ if impl(ghc < 8.0)

126+ ghc-options: -fno-warn-incomplete-patterns

127+

125 build-depends:

128 build-depends:

126 base >= 4.8 && < 5

129 base >= 4.8 && < 5

127 , grenade

130 , grenade

src/Grenade/Core/Shape.hs+33−15

@@ -81,16 +81,16 @@ deriving instance Show (S n)

81-- clear and makes adding the KnownNat constraints simple.

82-- We can also keep our code TH free, which is great.

83data instance Sing (n :: Shape) where

84− D1Sing :: KnownNat a => Sing ('D1 a)

84+ D1Sing :: Sing a -> Sing ('D1 a)

85− D2Sing :: (KnownNat a, KnownNat b) => Sing ('D2 a b)

85+ D2Sing :: Sing a -> Sing b -> Sing ('D2 a b)

86− D3Sing :: (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => Sing ('D3 a b c)

86+ D3Sing :: KnownNat (a * c) => Sing a -> Sing b -> Sing c -> Sing ('D3 a b c)

88instance KnownNat a => SingI ('D1 a) where

89− sing = D1Sing

89+ sing = D1Sing sing

90instance (KnownNat a, KnownNat b) => SingI ('D2 a b) where

91− sing = D2Sing

91+ sing = D2Sing sing sing

92instance (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => SingI ('D3 a b c) where

93− sing = D3Sing

93+ sing = D3Sing sing sing sing

95instance SingI x => Num (S x) where

96 (+) = n2 (+)

@@ -139,18 +139,30 @@ randomOfShape :: forall x m. ( MonadRandom m, SingI x ) => m (S x)

139randomOfShape = do

140 seed :: Int <- getRandom

141 return $ case (sing :: Sing x) of

142+ D1Sing l ->

143+ withKnownNat l $

142− D1Sing -> S1D (randomVector seed Uniform * 2 - 1)

144+ S1D (randomVector seed Uniform * 2 - 1)

145+ D2Sing r c ->

146+ withKnownNat r $ withKnownNat c $

143− D2Sing -> S2D (uniformSample seed (-1) 1)

147+ S2D (uniformSample seed (-1) 1)

148+ D3Sing r c d ->

149+ withKnownNat r $ withKnownNat c $ withKnownNat d $

144− D3Sing -> S3D (uniformSample seed (-1) 1)

150+ S3D (uniformSample seed (-1) 1)

145

151

146-- | Generate a shape from a Storable Vector.

152-- | Generate a shape from a Storable Vector.

147--

153--

148-- Returns Nothing if the vector is of the wrong size.

154-- Returns Nothing if the vector is of the wrong size.

149fromStorable :: forall x. SingI x => Vector Double -> Maybe (S x)

155fromStorable :: forall x. SingI x => Vector Double -> Maybe (S x)

150fromStorable xs = case sing :: Sing x of

156fromStorable xs = case sing :: Sing x of

157+ D1Sing l ->

158+ withKnownNat l $

151− D1Sing -> S1D <$> H.create xs

159+ S1D <$> H.create xs

160+ D2Sing r c ->

161+ withKnownNat r $ withKnownNat c $

152− D2Sing -> S2D <$> mkL xs

162+ S2D <$> mkL xs

163+ D3Sing r c d ->

164+ withKnownNat r $ withKnownNat c $ withKnownNat d $

153− D3Sing -> S3D <$> mkL xs

165+ S3D <$> mkL xs

154 where

166 where

155 mkL :: forall rows columns. (KnownNat rows, KnownNat columns)

167 mkL :: forall rows columns. (KnownNat rows, KnownNat columns)

156 => Vector Double -> Maybe (L rows columns)

168 => Vector Double -> Maybe (L rows columns)

@@ -176,6 +188,12 @@ n2 f (S3D x) (S3D y) = S3D (f x y)

176-- Helper function for creating the number instances

188-- Helper function for creating the number instances

177nk :: forall x. SingI x => Double -> S x

189nk :: forall x. SingI x => Double -> S x

178nk x = case (sing :: Sing x) of

190nk x = case (sing :: Sing x) of

191+ D1Sing l ->

192+ withKnownNat l $

179− D1Sing -> S1D (konst x)

193+ S1D (konst x)

194+ D2Sing r c ->

195+ withKnownNat r $ withKnownNat c $

180− D2Sing -> S2D (konst x)

196+ S2D (konst x)

197+ D3Sing r c d ->

198+ withKnownNat r $ withKnownNat c $ withKnownNat d $

181− D3Sing -> S3D (konst x)

199+ S3D (konst x)

test/Test/Grenade/Layers/Convolution.hs+1−2

@@ -19,7 +19,6 @@ import Grenade.Core

19import Grenade.Layers.Convolution

21import Hedgehog

22−import Hedgehog.Gen ( Gen )

23import qualified Hedgehog.Gen as Gen

22import qualified Hedgehog.Gen as Gen

25import Test.Hedgehog.Hmatrix

24import Test.Hedgehog.Hmatrix

@@ -41,7 +40,7 @@ genConvolution :: ( KnownNat channels

41 , KnownNat kernelFlattened

40 , KnownNat kernelFlattened

42 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

41 , kernelFlattened ~ (kernelRows * kernelColumns * channels)

43 , Monad m

42 , Monad m

44− ) => Gen m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

43+ ) => Gen.Gen m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)

45genConvolution = Convolution <$> uniformSample <*> uniformSample

44genConvolution = Convolution <$> uniformSample <*> uniformSample

47genOpaqueOpaqueConvolution :: Monad m => Gen m OpaqueConvolution

46genOpaqueOpaqueConvolution :: Monad m => Gen m OpaqueConvolution

test/Test/Grenade/Layers/Nonlinear.hs−13

@@ -16,7 +16,6 @@ import Data.Proxy

16#endif

18import Grenade

19−import GHC.TypeLits

21import Hedgehog

20import Hedgehog

@@ -56,18 +55,6 @@ prop_tanh_grad = property $

56 (S2D x) -> norm_Inf x < 0.001

55 (S2D x) -> norm_Inf x < 0.001

57 (S3D x) -> norm_Inf x < 0.001) :: Bool)

56 (S3D x) -> norm_Inf x < 0.001) :: Bool)

59−prop_softmax_grad :: Property

60−prop_softmax_grad = property $

61− blindForAll genNat >>= \case

62− (SomeNat (_ :: Proxy s)) ->

63− blindForAll genOfShape >>= \(ds :: S ('D1 s)) ->

64− let (tape, f :: S ('D1 s)) = runForwards Relu ds

65− ((), ret :: S ('D1 s)) = runBackwards Relu tape (1 :: S ('D1 s))

66− (_, numer :: S ('D1 s)) = runForwards Relu (ds + 0.0001)

67− numericalGradient = (numer - f) * 10000

68− in assert ((case numericalGradient - ret of

69− (S1D x) -> norm_Inf x < 0.0001) :: Bool)

70−

71tests :: IO Bool

58tests :: IO Bool

72tests = $$(checkConcurrent)

59tests = $$(checkConcurrent)

test/Test/Grenade/Layers/Pooling.hs+2−2

@@ -13,7 +13,7 @@ import GHC.TypeLits

13import Grenade.Layers.Pooling

15import Hedgehog

16−import Hedgehog.Gen ( Gen )

16+import qualified Hedgehog.Gen as Gen

18import Test.Hedgehog.Compat

@@ -23,7 +23,7 @@ data OpaquePooling :: * where

23instance Show OpaquePooling where

24 show (OpaquePooling n) = show n

26−genOpaquePooling :: Monad m => Gen m OpaquePooling

26+genOpaquePooling :: Monad m => Gen.Gen m OpaquePooling

27genOpaquePooling = do

28 Just kernelHeight <- someNatVal <$> choose 2 15

29 Just kernelWidth <- someNatVal <$> choose 2 15

test/Test/Grenade/Recurrent/Layers/LSTM.hs+2−2

@@ -11,7 +11,7 @@

11module Test.Grenade.Recurrent.Layers.LSTM where

13import Hedgehog

14−import Hedgehog.Gen ( Gen )

14+import qualified Hedgehog.Gen as Gen

15import Hedgehog.Internal.Source

16import Hedgehog.Internal.Show

17import Hedgehog.Internal.Property ( failWith, Diff (..) )

@@ -29,7 +29,7 @@ import qualified Numeric.LinearAlgebra.Static as S

29import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference

30import Test.Hedgehog.Hmatrix

32−genLSTM :: forall i o m. (KnownNat i, KnownNat o, Monad m) => Gen m (LSTM i o)

32+genLSTM :: forall i o m. (KnownNat i, KnownNat o, Monad m) => Gen.Gen m (LSTM i o)

33genLSTM = do

34 let w = uniformSample

35 u = uniformSample

test/Test/Hedgehog/Compat.hs+11−10

@@ -1,11 +1,16 @@

1{-# LANGUAGE RankNTypes #-}

2−module Test.Hedgehog.Compat where

2+module Test.Hedgehog.Compat (

3+ (...)

4+ , choose

5+ , blindForAll

6+ , semiBlindForAll

7+ , forAllRender

8+ )where

4import Control.Monad.Trans.Class (MonadTrans(..))

10import Control.Monad.Trans.Class (MonadTrans(..))

6import Data.Typeable ( typeOf )

12import Data.Typeable ( typeOf )

8−import Hedgehog.Gen ( Gen )

9import qualified Hedgehog.Gen as Gen

14import qualified Hedgehog.Gen as Gen

10import qualified Hedgehog.Range as Range

15import qualified Hedgehog.Range as Range

11import Hedgehog.Internal.Property

16import Hedgehog.Internal.Property

@@ -16,23 +21,19 @@ import Hedgehog.Internal.Show

16(...) = (.) . (.)

21(...) = (.) . (.)

17{-# INLINE (...) #-}

22{-# INLINE (...) #-}

19−choose :: ( Monad m, Integral a ) => a -> a -> Gen m a

24+choose :: ( Monad m, Integral a ) => a -> a -> Gen.Gen m a

20choose = Gen.integral ... Range.constant

25choose = Gen.integral ... Range.constant

22−-- | Generates a random input for the test by running the provided generator.

23−blindForAll :: Monad m => Gen m a -> Test m a

27+blindForAll :: Monad m => Gen.Gen m a -> Test m a

24blindForAll = Test . lift . lift

28blindForAll = Test . lift . lift

26−-- | Generates a random input for the test by running the provided generator.

27−semiBlindForAll :: (Monad m, Show a, HasCallStack) => Gen m a -> Test m a

30+semiBlindForAll :: (Monad m, Show a, HasCallStack) => Gen.Gen m a -> Test m a

28semiBlindForAll gen = do

31semiBlindForAll gen = do

29 x <- Test . lift $ lift gen

32 x <- Test . lift $ lift gen

30 writeLog $ Input (getCaller callStack) (typeOf ()) (showPretty x)

33 writeLog $ Input (getCaller callStack) (typeOf ()) (showPretty x)

31 return x

34 return x

33−

34−-- | Generates a random input for the test by running the provided generator.

35−forAllRender :: (Monad m, HasCallStack) => ( a -> String ) -> Gen m a -> Test m a

36+forAllRender :: (Monad m, HasCallStack) => ( a -> String ) -> Gen.Gen m a -> Test m a

36forAllRender render gen = do

37forAllRender render gen = do

37 x <- Test . lift $ lift gen

38 x <- Test . lift $ lift gen

38 writeLog $ Input (getCaller callStack) (typeOf ()) (render x)

39 writeLog $ Input (getCaller callStack) (typeOf ()) (render x)

test/Test/Hedgehog/Hmatrix.hs+13−10

@@ -7,29 +7,32 @@ module Test.Hedgehog.Hmatrix where

8import Grenade

9import Data.Singletons

10+import Data.Singletons.TypeLits

11−import Hedgehog.Gen ( Gen )

12import qualified Hedgehog.Gen as Gen

13import qualified Hedgehog.Range as Range

15−import GHC.TypeLits

16−

17import qualified Numeric.LinearAlgebra.Static as HStatic

15import qualified Numeric.LinearAlgebra.Static as HStatic

19−randomVector :: forall m n. ( Monad m, KnownNat n ) => Gen m (HStatic.R n)

17+randomVector :: forall m n. ( Monad m, KnownNat n ) => Gen.Gen m (HStatic.R n)

20randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded

18randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded

22−uniformSample :: forall mm m n. ( Monad mm, KnownNat m, KnownNat n ) => Gen mm (HStatic.L m n)

20+uniformSample :: forall mm m n. ( Monad mm, KnownNat m, KnownNat n ) => Gen.Gen mm (HStatic.L m n)

23uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded

21uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded

25-- | Generate random data of the desired shape

23-- | Generate random data of the desired shape

26−genOfShape :: forall m x. ( Monad m, SingI x ) => Gen m (S x)

24+genOfShape :: forall m x. ( Monad m, SingI x ) => Gen.Gen m (S x)

27genOfShape =

25genOfShape =

28 case (sing :: Sing x) of

26 case (sing :: Sing x) of

27+ D1Sing l ->

28+ withKnownNat l $

29− D1Sing -> S1D <$> randomVector

29+ S1D <$> randomVector

30+ D2Sing r c ->

31+ withKnownNat r $ withKnownNat c $

30− D2Sing -> S2D <$> uniformSample

32+ S2D <$> uniformSample

33+ D3Sing r c d ->

34+ withKnownNat r $ withKnownNat c $ withKnownNat d $

31− D3Sing -> S3D <$> uniformSample

35+ S3D <$> uniformSample

32−

34nice :: S shape -> String

37nice :: S shape -> String

35nice (S1D x) = show . HStatic.extract $ x

38nice (S1D x) = show . HStatic.extract $ x

test/Test/Hedgehog/Network.hs+188−96

@@ -1,4 +1,5 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE RankNTypes #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ScopedTypeVariables #-}

@@ -9,6 +10,7 @@

9{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE FlexibleContexts #-}

10module Test.Hedgehog.Network where

11module Test.Hedgehog.Network where

13+import Control.Monad ( guard )

12import Control.Monad.ST ( runST )

14import Control.Monad.ST ( runST )

14import Data.Constraint

16import Data.Constraint

@@ -19,10 +21,11 @@ import qualified Data.Vector.Storable as VS

19import qualified Data.Vector.Storable.Mutable as VS ( write )

21import qualified Data.Vector.Storable.Mutable as VS ( write )

20import Data.Singletons

22import Data.Singletons

21import Data.Singletons.Prelude.List

23import Data.Singletons.Prelude.List

24+import Data.Singletons.TypeLits

25+

22-- import Data.Type.Equality

26-- import Data.Type.Equality

24import Hedgehog

28import Hedgehog

25−import Hedgehog.Gen ( Gen )

26import qualified Hedgehog.Gen as Gen

29import qualified Hedgehog.Gen as Gen

27import Hedgehog.Internal.Source

30import Hedgehog.Internal.Source

28import Hedgehog.Internal.Property ( failWith )

31import Hedgehog.Internal.Property ( failWith )

@@ -37,7 +40,7 @@ import Test.Hedgehog.Hmatrix

37import Test.Grenade.Layers.Convolution

40import Test.Grenade.Layers.Convolution

39import Numeric.LinearAlgebra ( flatten )

42import Numeric.LinearAlgebra ( flatten )

40−import Numeric.LinearAlgebra.Static ( size , extract, norm_Inf )

43+import Numeric.LinearAlgebra.Static ( extract, norm_Inf )

41import Unsafe.Coerce

44import Unsafe.Coerce

43data SomeNetwork :: * where

46data SomeNetwork :: * where

@@ -48,8 +51,9 @@ instance Show SomeNetwork where

49-- | Generate a random network of a random type

52-- | Generate a random network of a random type

50--

53--

51−-- This is slightly insane

54+-- This is slightly insane for a few reasons. Everything must be wrapped up

55+-- in a SomeNetwork.

52−genNetwork :: Monad m => Gen m SomeNetwork

56+genNetwork :: Monad m => Gen.Gen m SomeNetwork

53genNetwork =

57genNetwork =

54 Gen.recursive Gen.choice [

58 Gen.recursive Gen.choice [

55 do SomeSing ( r :: Sing final ) <- genShape

59 do SomeSing ( r :: Sing final ) <- genShape

@@ -59,126 +63,214 @@ genNetwork =

59 do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork

63 do SomeNetwork ( rest :: Network layers shapes ) <- genNetwork

60 case ( sing :: Sing shapes ) of

64 case ( sing :: Sing shapes ) of

61 SNil -> Gen.discard

65 SNil -> Gen.discard

62− SCons ( r :: Sing h ) ( _ :: Sing hs ) ->

66+ SCons ( h :: Sing h ) ( _ :: Sing hs ) ->

63− withSingI r $ Gen.choice [

67+ withSingI h $

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

68+ case h of

67− D1Sing ->

69+ D1Sing l -> withKnownNat l $

68 Gen.choice [

70 Gen.choice [

71+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

72+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

69− pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

73+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

70 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

74 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

71 , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))

75 , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))

72 ]

76 ]

73− D2Sing ->

77+ D2Sing r c -> withKnownNat r $ withKnownNat c $

74 Gen.choice [

78 Gen.choice [

79+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

80+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

75− pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

81+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

76 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

82 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

77 , do -- Build a convolution layer with one filter output

83 , do -- Build a convolution layer with one filter output

78 -- Figure out some kernel sizes which work for this layer

84 -- Figure out some kernel sizes which work for this layer

79 -- There must be a better way than this...

85 -- There must be a better way than this...

80− let dumb :: S h = 0

86+ let output_r = natVal r

81− case dumb of

87+ let output_c = natVal c

82− S2D x -> do

88+

83− let (rs, cs) = size x

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

84− let output_r = fromIntegral rs

168+ let output_r = natVal r

85− let output_c = fromIntegral cs

169+ let output_c = natVal c

86−

170+

87− let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

171+ let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]

88−

172+

89− -- Get some kernels which will fit

173+ -- Get some kernels which will fit

90− kernel_r <- choose 1 output_r

174+ kernel_r <- choose 1 output_r

91− kernel_c <- choose 1 output_c

175+ kernel_c <- choose 1 output_c

92−

176+

93− -- Build up some strides which also fit

177+ -- Build up some strides which also fit

94− stride_r <- Gen.element $ ok output_r kernel_r

178+ stride_r <- Gen.element $ ok output_r kernel_r

95− stride_c <- Gen.element $ ok output_c kernel_c

179+ stride_c <- Gen.element $ ok output_c kernel_c

96−

180+

97− -- Determine the input size

181+ -- Determine the input size

98− let input_r = (output_r - 1) * stride_r + kernel_r

182+ let input_r = (output_r - 1) * stride_r + kernel_r

99− let input_c = (output_c - 1) * stride_c + kernel_c

183+ let input_c = (output_c - 1) * stride_c + kernel_c

100−

184+

185+ guard (input_r < 100)

186+ guard (input_c < 100)

187+

101− -- Remake types for input

188+ -- 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

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

103− ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

190+ ( Just (SomeNat (_ :: Proxy inRows)), Just (SomeNat (_ :: Proxy inCols)),

104− Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

191+ Just (SomeNat (_ :: Proxy outRows)), Just (SomeNat (_ :: Proxy outCols)),

105− Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

192+ Just (SomeNat (pkr :: Proxy kernelRows)), Just (SomeNat (pkc :: Proxy kernelCols)),

106− Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

193+ Just (SomeNat (_ :: Proxy strideRows)), Just (SomeNat (_ :: Proxy strideCols))) ->

107− let p1 = natDict pkr

194+ let p1 = natDict pkr

108− p2 = natDict pkc

195+ p2 = natDict pkc

109− in case ( p1 %* p2

196+ in case ( p1 %* p2

110− -- Fake it till you make it.

197+ -- Fake it till you make it.

111− , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))

198+ , (unsafeCoerce (Dict :: Dict ()) :: Dict ( ( 'D2 outRows outCols ) ~ h ))

112− , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

199+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outRows - 1) * strideRows) ~ (inRows - kernelRows)))

113− , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

200+ , (unsafeCoerce (Dict :: Dict ()) :: Dict (((outCols - 1) * strideCols) ~ (inCols - kernelCols)))) of

114− (Dict, Dict, Dict, Dict) -> do

201+ (Dict, Dict, Dict, Dict) ->

115− conv <- genConvolution

116− pure (SomeNetwork (conv :~> rest :: Network ( Convolution 1 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

202+ pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))

117− _ -> Gen.discard

203+ _ -> Gen.discard -- Can't occur

118 ]

204 ]

119− D3Sing ->

205+ D3Sing r c d -> withKnownNat d $ withKnownNat r $ withKnownNat c $

120 Gen.choice [

206 Gen.choice [

207+ pure (SomeNetwork (Tanh :~> rest :: Network ( Tanh ': layers ) ( h ': h ': hs )))

208+ , pure (SomeNetwork (Logit :~> rest :: Network ( Logit ': layers ) ( h ': h ': hs )))

121− pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

209+ , pure (SomeNetwork (Relu :~> rest :: Network ( Relu ': layers ) ( h ': h ': hs )))

122 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

210 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))

123 ]

211 ]

124− ]

125 ]

212 ]

126

213

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.

128prop_auto_diff :: Property

217prop_auto_diff :: Property

129−prop_auto_diff = property $ do

218+prop_auto_diff = withTests 10000 . property $ do

130 SomeNetwork (network :: Network layers shapes) <- forAll genNetwork

219 SomeNetwork (network :: Network layers shapes) <- forAll genNetwork

131 (input :: S (Head shapes)) <- forAllRender nice genOfShape

220 (input :: S (Head shapes)) <- forAllRender nice genOfShape

132 (target :: S (Last shapes)) <- forAllRender nice oneUp

221 (target :: S (Last shapes)) <- forAllRender nice oneUp

133 (tested :: S (Head shapes)) <- forAllRender nice oneUp

222 (tested :: S (Head shapes)) <- forAllRender nice oneUp

134

223

135− let (tapes, output) = runNetwork network input

224+ let (!tapes, !output) = runNetwork network input

136− let (_, bgrad) = runGradient network tapes target

225+ let (_, !backgrad) = runGradient network tapes target

137− let inputDiff = input + tested * 0.00001

226+ let inputDiff = input + tested * 0.00001

138− let expected = maxVal ( bgrad * tested )

227+ let expected = maxVal ( backgrad * tested )

139− let (_, outputDiff) = runNetwork network inputDiff

228+ let (_, !outputDiff) = runNetwork network inputDiff

140− let result = maxVal ( outputDiff * target - output * target ) / 0.00001

229+ let result = maxVal ( outputDiff * target - output * target ) / 0.00001

141

230

142 result ~~~ expected

231 result ~~~ expected

143

232

144 where

233 where

145

234

146-- Make a shape where all are 0 except for 1 value, which is 1.

235-- 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)

148oneUp =

237oneUp =

149 case ( sing :: Sing shape ) of

238 case ( sing :: Sing shape ) of

239+ D1Sing l -> withKnownNat l $

150− D1Sing -> let x = 0 :: S ( shape )

240+ let x = 0 :: S ( shape )

151− in case x of

241+ in case x of

152− ( S1D x' ) -> do

242+ ( S1D x' ) -> do

153− let ex = extract x'

243+ let ex = extract x'

154− let len = VS.length ex

244+ let len = VS.length ex

155− ix <- choose 0 (len - 1)

245+ ix <- choose 0 (len - 1)

156− let nx = runST $ do ex' <- VS.thaw ex

246+ let nx = runST $ do ex' <- VS.thaw ex

157− VS.write ex' ix 1.0

247+ VS.write ex' ix 1.0

158− VS.freeze ex'

248+ VS.freeze ex'

159− maybe Gen.discard pure . fromStorable $ nx

249+ maybe Gen.discard pure . fromStorable $ nx

160−

250+

251+ D2Sing r c -> withKnownNat r $ withKnownNat c $

161− D2Sing -> let x = 0 :: S ( shape )

252+ let x = 0 :: S ( shape )

162− in case x of

253+ in case x of

163− ( S2D x' ) -> do

254+ ( S2D x' ) -> do

164− let ex = flatten ( extract x' )

255+ let ex = flatten ( extract x' )

165− let len = VS.length ex

256+ let len = VS.length ex

166− ix <- choose 0 (len - 1)

257+ ix <- choose 0 (len - 1)

167− let nx = runST $ do ex' <- VS.thaw ex

258+ let nx = runST $ do ex' <- VS.thaw ex

168− VS.write ex' ix 1

259+ VS.write ex' ix 1

169− VS.freeze ex'

260+ VS.freeze ex'

170− maybe Gen.discard pure . fromStorable $ nx

261+ maybe Gen.discard pure . fromStorable $ nx

171−

262+

263+ D3Sing r c d -> withKnownNat r $ withKnownNat c $ withKnownNat d $

172− D3Sing -> let x = 0 :: S ( shape )

264+ let x = 0 :: S ( shape )

173− in case x of

265+ in case x of

174− ( S3D x' ) -> do

266+ ( S3D x' ) -> do

175− let ex = flatten ( extract x' )

267+ let ex = flatten ( extract x' )

176− let len = VS.length ex

268+ let len = VS.length ex

177− ix <- choose 0 (len - 1)

269+ ix <- choose 0 (len - 1)

178− let nx = runST $ do ex' <- VS.thaw ex

270+ let nx = runST $ do ex' <- VS.thaw ex

179− VS.write ex' ix 1

271+ VS.write ex' ix 1

180− VS.freeze ex'

272+ VS.freeze ex'

181− maybe Gen.discard pure . fromStorable $ nx

273+ maybe Gen.discard pure . fromStorable $ nx

182

274

183maxVal :: S shape -> Double

275maxVal :: S shape -> Double

184maxVal ( S1D x ) = norm_Inf x

276maxVal ( S1D x ) = norm_Inf x

@@ -187,7 +279,7 @@ maxVal ( S3D x ) = norm_Inf x

187

279

188(~~~) :: (Monad m, HasCallStack) => Double -> Double -> Test m ()

280(~~~) :: (Monad m, HasCallStack) => Double -> Double -> Test m ()

189(~~~) x y =

281(~~~) x y =

190− if (x - y) < 1e-5 then

282+ if abs (x - y) < 1e-5 then

191 success

283 success

192 else

284 else

193 withFrozenCallStack $

285 withFrozenCallStack $

test/Test/Hedgehog/TypeLits.hs+5−6

@@ -13,7 +13,6 @@ import Data.Proxy

13#endif

14import Data.Singletons

16−import Hedgehog.Gen ( Gen )

17import qualified Hedgehog.Gen as Gen

16import qualified Hedgehog.Gen as Gen

19import Grenade

18import Grenade

@@ -22,7 +21,7 @@ import GHC.TypeLits

22import GHC.TypeLits.Witnesses

21import GHC.TypeLits.Witnesses

23import Test.Hedgehog.Compat

22import Test.Hedgehog.Compat

25−genNat :: Monad m => Gen m SomeNat

24+genNat :: Monad m => Gen.Gen m SomeNat

26genNat = do

25genNat = do

27 Just n <- someNatVal <$> choose 1 10

26 Just n <- someNatVal <$> choose 1 10

28 return n

27 return n

@@ -33,7 +32,7 @@ type Shape' = ('KProxy :: KProxy Shape)

33type Shape' = Shape

32type Shape' = Shape

34#endif

33#endif

36−genShape :: Monad m => Gen m (SomeSing Shape')

35+genShape :: Monad m => Gen.Gen m (SomeSing Shape')

37genShape

36genShape

38 = Gen.choice [

37 = Gen.choice [

39 genD1

38 genD1

@@ -41,20 +40,20 @@ genShape

41 , genD3

40 , genD3

42 ]

41 ]

44−genD1 :: Monad m => Gen m (SomeSing Shape')

43+genD1 :: Monad m => Gen.Gen m (SomeSing Shape')

45genD1 = do

44genD1 = do

46 n <- genNat

45 n <- genNat

47 return $ case n of

46 return $ case n of

48 SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

47 SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))

50−genD2 :: Monad m => Gen m (SomeSing Shape')

49+genD2 :: Monad m => Gen.Gen m (SomeSing Shape')

51genD2 = do

50genD2 = do

52 n <- genNat

51 n <- genNat

53 m <- genNat

52 m <- genNat

54 return $ case (n, m) of

53 return $ case (n, m) of

55 (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

54 (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))

57−genD3 :: Monad m => Gen m (SomeSing Shape')

56+genD3 :: Monad m => Gen.Gen m (SomeSing Shape')

58genD3 = do

57genD3 = do

59 n <- genNat

58 n <- genNat

60 m <- genNat

59 m <- genNat

test/test.hs+3−2

@@ -18,7 +18,9 @@ import System.IO

18main :: IO ()

19main =

20 disorderMain [

21+ Test.Hedgehog.Network.tests

22+

21− Test.Grenade.Layers.Pooling.tests

23+ , Test.Grenade.Layers.Pooling.tests

22 , Test.Grenade.Layers.Convolution.tests

24 , Test.Grenade.Layers.Convolution.tests

23 , Test.Grenade.Layers.FullyConnected.tests

25 , Test.Grenade.Layers.FullyConnected.tests

24 , Test.Grenade.Layers.Nonlinear.tests

26 , Test.Grenade.Layers.Nonlinear.tests

@@ -29,7 +31,6 @@ main =

30 , Test.Grenade.Recurrent.Layers.LSTM.tests

32 , Test.Grenade.Recurrent.Layers.LSTM.tests

32− , Test.Hedgehog.Network.tests

33 ]

34 ]

35disorderMain :: [IO Bool] -> IO ()

36disorderMain :: [IO Bool] -> IO ()