3126857...master · grenade

.gitignore+1

@@ -3,3 +3,4 @@ cabal.project.local

33cabal.sandbox.config

44dist/

55dist-newstyle/

6+.stack-work/

.travis.yml+12−12

@@ -2,30 +2,30 @@

22

33# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.

44env:

5− - CABALVER=1.24 GHCVER=8.0.2

6− - CABALVER=2.0 GHCVER=8.2.2

7− - CABALVER=2.0 GHCVER=8.4.4

8− - CABALVER=2.0 GHCVER=8.6.5

5+ - GHCVER=8.0.2

6+ - GHCVER=8.2.2

7+ - GHCVER=8.4.4

8+ - GHCVER=8.6.5

9+ - GHCVER=8.8.3

10+ - GHCVER=8.10.1

911

1012# Note: the distinction between `before_install` and `install` is not important.

1113before_install:

1214 - travis_retry sudo add-apt-repository -y ppa:hvr/ghc

1315 - travis_retry sudo apt-get update

14− - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER happy-1.19.5 alex-3.1.7 libblas-dev liblapack-dev

15− - export PATH=/opt/alex/3.1.7/bin:/opt/happy/1.19.5/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH

16+ - travis_retry sudo apt-get install cabal-install-3.2 ghc-$GHCVER libblas-dev liblapack-dev

17+ - export PATH=/opt/cabal/bin:/opt/ghc/$GHCVER/bin:$PATH

1618

1719install:

18− - cabal --version

1920 - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"

20− - travis_retry cabal update

21− - cabal sandbox init

22− - cabal install --enable-tests --enable-benchmarks

21+ - travis_retry cabal-3.2 update

2322

2423notifications:

2524 email: false

2625

2726# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.

2827script:

29− - cabal build

30− - cabal test --show-details=streaming

28+ - cabal-3.2 configure --enable-tests

29+ - cabal-3.2 build all

30+ - cabal-3.2 test --test-show-details=direct -j1

3131

examples/grenade-examples.cabal+6−5

@@ -26,7 +26,7 @@ executable feedforward

2626 , bytestring

2727 , cereal

2828 , either

29− , optparse-applicative >= 0.13 && < 0.16

29+ , optparse-applicative >= 0.13 && < 0.18

3030 , text == 1.2.*

3131 , mtl >= 2.2.1 && < 2.3

3232 , hmatrix

@@ -42,7 +42,7 @@ executable mnist

4242 , grenade

4343 , attoparsec

4444 , either

45− , optparse-applicative >= 0.13 && < 0.16

45+ , optparse-applicative >= 0.13 && < 0.18

4646 , text == 1.2.*

4747 , mtl >= 2.2.1 && < 2.3

4848 , hmatrix >= 0.18 && < 0.21

@@ -61,7 +61,7 @@ executable gan-mnist

6161 , bytestring

6262 , cereal

6363 , either

64− , optparse-applicative >= 0.13 && < 0.16

64+ , optparse-applicative >= 0.13 && < 0.18

6565 , text == 1.2.*

6666 , mtl >= 2.2.1 && < 2.3

6767 , hmatrix >= 0.18 && < 0.21

@@ -78,7 +78,7 @@ executable recurrent

7878 , grenade

7979 , attoparsec

8080 , either

81− , optparse-applicative >= 0.13 && < 0.16

81+ , optparse-applicative >= 0.13 && < 0.18

8282 , text == 1.2.*

8383 , mtl >= 2.2.1 && < 2.3

8484 , hmatrix >= 0.18 && < 0.21

@@ -96,13 +96,14 @@ executable shakespeare

9696 , bytestring

9797 , cereal

9898 , either

99− , optparse-applicative >= 0.13 && < 0.16

99+ , optparse-applicative >= 0.13 && < 0.18

100100 , text == 1.2.*

101101 , mtl >= 2.2.1 && < 2.3

102102 , hmatrix >= 0.18 && < 0.21

103103 , transformers

104104 , semigroups

105105 , singletons

106+ , singletons-base

106107 , vector

107108 , MonadRandom

108109 , containers

examples/main/feedforward.hs+3−1

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

11{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE ScopedTypeVariables #-}

45{-# LANGUAGE TypeOperators #-}

@@ -10,8 +11,9 @@ import Data.List ( foldl' )

1011

1112import qualified Data.ByteString as B

1213import Data.Serialize

14+#if ! MIN_VERSION_base(4,13,0)

1315import Data.Semigroup ( (<>) )

14−

16+#endif

1517import GHC.TypeLits

1618

1719import qualified Numeric.LinearAlgebra.Static as SA

examples/main/gan-mnist.hs+3

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

11{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE GADTs #-}

45{-# LANGUAGE ScopedTypeVariables #-}

@@ -43,7 +44,9 @@ import Control.Monad.Trans.Except

4344import qualified Data.Attoparsec.Text as A

4445import qualified Data.ByteString as B

4546import Data.List ( foldl' )

47+#if ! MIN_VERSION_base(4,13,0)

4648import Data.Semigroup ( (<>) )

49+#endif

4750import Data.Serialize

4851import qualified Data.Text as T

4952import qualified Data.Text.IO as T

examples/main/mnist.hs+4

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

11{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE ScopedTypeVariables #-}

45{-# LANGUAGE TypeOperators #-}

@@ -13,7 +14,10 @@ import Control.Monad.Trans.Except

1314

1415import qualified Data.Attoparsec.Text as A

1516import Data.List ( foldl' )

17+#if ! MIN_VERSION_base(4,13,0)

1618import Data.Semigroup ( (<>) )

19+#endif

20+

1721import qualified Data.Text as T

1822import qualified Data.Text.IO as T

1923import qualified Data.Vector.Storable as V

examples/main/recurrent.hs+2−2

@@ -9,12 +9,12 @@

99import Control.Monad ( foldM )

1010import Control.Monad.Random ( MonadRandom, getRandomR )

1111

12−#if __GLASGOW_HASKELL__ < 800

12+#if MIN_VERSION_base(4,13,0)

1313import Data.List ( unfoldr )

1414#else

1515import Data.List ( cycle, unfoldr )

16−#endif

1716import Data.Semigroup ( (<>) )

17+#endif

1818

1919import qualified Numeric.LinearAlgebra.Static as SA

2020

examples/main/shakespeare.hs+16−16

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

11{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE CPP #-}

33{-# LANGUAGE DataKinds #-}

44{-# LANGUAGE ScopedTypeVariables #-}

55{-# LANGUAGE TypeOperators #-}

@@ -13,18 +13,16 @@ import Control.Monad.Trans.Except

1313import Data.Char ( isUpper, toUpper, toLower )

1414import Data.List ( foldl' )

1515import Data.Maybe ( fromMaybe )

16−import Data.Semigroup ( (<>) )

16+

1717

1818import qualified Data.Vector as V

1919import Data.Vector ( Vector )

2020

2121import qualified Data.Map as M

22−import Data.Proxy ( Proxy (..) )

2322

2423import qualified Data.ByteString as B

2524import Data.Serialize

2625

27−import Data.Singletons.Prelude

2826import GHC.TypeLits

2927

3028import Numeric.LinearAlgebra.Static ( konst )

@@ -36,6 +34,8 @@ import Grenade.Recurrent

3634import Grenade.Utils.OneHot

3735

3836import System.IO.Unsafe ( unsafeInterleaveIO )

37+import Data.Proxy

38+import Prelude.Singletons

3939

4040-- The defininition for our natural language recurrent network.

4141-- This network is able to learn and generate simple words in

@@ -77,34 +77,34 @@ loadShakespeare path = do

7777 return (V.fromList hot, m, cs)

7878

7979trainSlice :: LearningParameters -> Shakespeare -> Shakespearian -> Vector Int -> Int -> Int -> (Shakespeare, Shakespearian)

80−trainSlice !rate !net !recIns input offset size =

80+trainSlice !lrate !net !recIns input offset size =

8181 let e = fmap (x . oneHot) . V.toList $ V.slice offset size input

8282 in case reverse e of

8383 (o : l : xs) ->

8484 let examples = reverse $ (l, Just o) : ((,Nothing) <$> xs)

85− in trainRecurrent rate net recIns examples

85+ in trainRecurrent lrate net recIns examples

8686 _ -> error "Not enough input"

8787 where

8888 x = fromMaybe (error "Hot variable didn't fit.")

8989

9090runShakespeare :: ShakespeareOpts -> ExceptT String IO ()

91−runShakespeare ShakespeareOpts {..} = do

92− (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare trainingFile

91+runShakespeare opts = do

92+ (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare $ trainingFile opts

9393 (net0, i0) <- lift $

94− case loadPath of

94+ case loadPath opts of

9595 Just loadFile -> netLoad loadFile

9696 Nothing -> (,0) <$> randomNet

9797

9898 (trained, bestInput) <- lift $ foldM (\(!net, !io) size -> do

99− xs <- take (iterations `div` 10) <$> getRandomRs (0, length shakespeare - size - 1)

100− let (!trained, !bestInput) = foldl' (\(!n, !i) offset -> trainSlice rate n i shakespeare offset size) (net, io) xs

101− results <- take 1000 <$> generateParagraph trained bestInput temperature oneHotMap oneHotDictionary ( S1D $ konst 0)

99+ xs <- take (iterations opts `div` 10) <$> getRandomRs (0, length shakespeare - size - 1)

100+ let (!trained, !bestInput) = foldl' (\(!n, !i) offset -> trainSlice (rate opts) n i shakespeare offset size) (net, io) xs

101+ results <- take 1000 <$> generateParagraph trained bestInput (temperature opts) oneHotMap oneHotDictionary ( S1D $ konst 0)

102102 putStrLn ("TRAINING STEP WITH SIZE: " ++ show size)

103103 putStrLn (unAnnotateCapitals results)

104104 return (trained, bestInput)

105− ) (net0, i0) $ replicate 10 sequenceSize

105+ ) (net0, i0) $ replicate 10 (sequenceSize opts)

106106

107− case savePath of

107+ case savePath opts of

108108 Just saveFile -> lift . B.writeFile saveFile $ runPut (put trained >> put bestInput)

109109 Nothing -> return ()

110110

@@ -116,12 +116,12 @@ generateParagraph :: forall layers shapes n a. (Last shapes ~ 'D1 n, Head shapes

116116 -> Vector a

117117 -> S ('D1 n)

118118 -> IO [a]

119−generateParagraph n s temperature hotmap hotdict =

119+generateParagraph n s temp hotmap hotdict =

120120 go s

121121 where

122122 go x y =

123123 do let (_, ns, o) = runRecurrent n x y

124− un <- sample temperature hotdict o

124+ un <- sample temp hotdict o

125125 Just re <- return $ makeHot hotmap un

126126 rest <- unsafeInterleaveIO $ go ns re

127127 return (un : rest)

grenade.cabal+2−1

@@ -38,7 +38,7 @@ source-repository head

3838library

3939 build-depends:

4040 base >= 4.8 && < 5

41− , bytestring == 0.10.*

41+ , bytestring >= 0.10.0

4242 , containers >= 0.5 && < 0.7

4343 , cereal >= 0.5 && < 0.6

4444 , deepseq >= 1.4 && < 1.5

@@ -48,6 +48,7 @@ library

4848 -- Versions of singletons are *tightly* coupled with the

4949 -- GHC version so its fine to drop version bounds.

5050 , singletons

51+ , singletons-base

5152 , vector >= 0.11 && < 0.13

5253

5354 ghc-options:

src/Grenade/Core/Network.hs+1−1

@@ -34,7 +34,6 @@ module Grenade.Core.Network (

3434import Control.Monad.Random ( MonadRandom )

3535

3636import Data.Singletons

37−import Data.Singletons.Prelude

3837import Data.Serialize

3938

4039#if MIN_VERSION_base(4,9,0)

@@ -44,6 +43,7 @@ import Data.Kind (Type)

4443import Grenade.Core.Layer

4544import Grenade.Core.LearningParameters

4645import Grenade.Core.Shape

46+import Prelude.Singletons

4747

4848-- | Type of a network.

4949--

src/Grenade/Core/Runner.hs+2−1

@@ -13,11 +13,12 @@ module Grenade.Core.Runner (

1313 , runNet

1414 ) where

1515

16−import Data.Singletons.Prelude

1716

1817import Grenade.Core.LearningParameters

1918import Grenade.Core.Network

2019import Grenade.Core.Shape

20+import Data.Singletons

21+import Prelude.Singletons

2122

2223-- | Perform reverse automatic differentiation on the network

2324-- for the current input and expected output.

src/Grenade/Core/Shape.hs+27−25

@@ -19,30 +19,22 @@ Stability : experimental

1919

2020-}

2121module Grenade.Core.Shape (

22− Shape (..)

23− , S (..)

24− , Sing (..)

25−

22+ S (..)

23+ , Shape (..)

24+ , SShape (..)

2625 , randomOfShape

2726 , fromStorable

2827 ) where

2928

3029import Control.DeepSeq (NFData (..))

3130import Control.Monad.Random ( MonadRandom, getRandom )

32−

31+import Data.Kind (Type)

3332import Data.Proxy

3433import Data.Serialize

3534import Data.Singletons

36−import Data.Singletons.TypeLits

3735import Data.Vector.Storable ( Vector )

3836import qualified Data.Vector.Storable as V

39−

40−#if MIN_VERSION_base(4,11,0)

41−import GHC.TypeLits hiding (natVal)

42−#else

4337import GHC.TypeLits

44−#endif

45−

4638import qualified Numeric.LinearAlgebra.Static as H

4739import Numeric.LinearAlgebra.Static

4840import qualified Numeric.LinearAlgebra as NLA

@@ -87,17 +79,27 @@ deriving instance Show (S n)

8779-- These could probably be derived with template haskell, but this seems

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

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

82+#if MIN_VERSION_singletons(2,6,0)

83+-- In singletons 2.6 Sing switched from a data family to a type family.

84+type instance Sing = SShape

85+

86+data SShape :: Shape -> Type where

87+ D1Sing :: KnownNat a => SShape ('D1 a)

88+ D2Sing :: (KnownNat a, KnownNat b) => SShape ('D2 a b)

89+ D3Sing :: (KnownNat (a * c), KnownNat a, KnownNat b, KnownNat c) => SShape ('D3 a b c)

90+#else

9091data instance Sing (n :: Shape) where

9192 D1Sing :: Sing a -> Sing ('D1 a)

9293 D2Sing :: Sing a -> Sing b -> Sing ('D2 a b)

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

95+#endif

9496

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

96− sing = D1Sing sing

98+ sing = D1Sing

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

98− sing = D2Sing sing sing

100+ sing = D2Sing

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

100− sing = D3Sing sing sing sing

102+ sing = D3Sing

101103

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

103105 (+) = n2 (+)

@@ -146,13 +148,13 @@ randomOfShape :: forall x m. ( MonadRandom m, SingI x ) => m (S x)

146148randomOfShape = do

147149 seed :: Int <- getRandom

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

149− D1Sing SNat ->

151+ D1Sing ->

150152 S1D (randomVector seed Uniform * 2 - 1)

151153

152− D2Sing SNat SNat ->

154+ D2Sing ->

153155 S2D (uniformSample seed (-1) 1)

154156

155− D3Sing SNat SNat SNat ->

157+ D3Sing ->

156158 S3D (uniformSample seed (-1) 1)

157159

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

@@ -160,13 +162,13 @@ randomOfShape = do

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

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

162164fromStorable xs = case sing :: Sing x of

163− D1Sing SNat ->

165+ D1Sing ->

164166 S1D <$> H.create xs

165167

166− D2Sing SNat SNat ->

168+ D2Sing ->

167169 S2D <$> mkL xs

168170

169− D3Sing SNat SNat SNat ->

171+ D3Sing ->

170172 S3D <$> mkL xs

171173 where

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

@@ -203,13 +205,13 @@ n2 f (S2D x) (S2D y) = S2D (f x y)

203205n2 f (S3D x) (S3D y) = S3D (f x y)

204206

205207-- Helper function for creating the number instances

206−nk :: forall x. SingI x => Double -> S x

208+nk :: forall x. (SingI x) => Double -> S x

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

208− D1Sing SNat ->

210+ D1Sing ->

209211 S1D (konst x)

210212

211− D2Sing SNat SNat ->

213+ D2Sing ->

212214 S2D (konst x)

213215

214− D3Sing SNat SNat SNat ->

216+ D3Sing ->

215217 S3D (konst x)

src/Grenade/Layers/Convolution.hs+2−10

@@ -1,7 +1,6 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DataKinds #-}

33{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE RecordWildCards #-}

54{-# LANGUAGE GADTs #-}

65{-# LANGUAGE TypeOperators #-}

76{-# LANGUAGE TypeFamilies #-}

@@ -29,16 +28,9 @@ import Control.Monad.Random hiding ( fromList )

2928import Data.Maybe

3029import Data.Proxy

3130import Data.Serialize

32−import Data.Singletons.TypeLits

3331

34−#if MIN_VERSION_base(4,11,0)

35−import GHC.TypeLits hiding (natVal)

36−#else

3732import GHC.TypeLits

38−#endif

39−#if MIN_VERSION_base(4,9,0)

4033import Data.Kind (Type)

41−#endif

4234

4335import Numeric.LinearAlgebra hiding ( uniformSample, konst )

4436import qualified Numeric.LinearAlgebra as LA

@@ -139,8 +131,8 @@ instance ( KnownNat channels

139131 , KnownNat (kernelRows * kernelColumns * channels)

140132 ) => UpdateLayer (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where

141133 type Gradient (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Convolution' channels filters kernelRows kernelColumns strideRows strideColumns)

142− runUpdate LearningParameters {..} (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =

143− let (newKernel, newMomentum) = descendMatrix learningRate learningMomentum learningRegulariser oldKernel kernelGradient oldMomentum

134+ runUpdate lp (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =

135+ let (newKernel, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldKernel kernelGradient oldMomentum

144136 in Convolution newKernel newMomentum

145137

146138 createRandom = randomConvolution

src/Grenade/Layers/Crop.hs−7

@@ -21,16 +21,9 @@ module Grenade.Layers.Crop (

2121import Data.Maybe

2222import Data.Proxy

2323import Data.Serialize

24−import Data.Singletons.TypeLits

2524

26−#if MIN_VERSION_base(4,11,0)

27−import GHC.TypeLits hiding (natVal)

28−#else

2925import GHC.TypeLits

30−#endif

31−#if MIN_VERSION_base(4,9,0)

3226import Data.Kind (Type)

33−#endif

3427

3528import Grenade.Core

3629import Grenade.Layers.Internal.Pad

src/Grenade/Layers/Deconvolution.hs+2−10

@@ -1,7 +1,6 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DataKinds #-}

33{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE RecordWildCards #-}

54{-# LANGUAGE GADTs #-}

65{-# LANGUAGE TypeOperators #-}

76{-# LANGUAGE TypeFamilies #-}

@@ -33,16 +32,9 @@ import Control.Monad.Random hiding ( fromList )

3332import Data.Maybe

3433import Data.Proxy

3534import Data.Serialize

36−import Data.Singletons.TypeLits

3735

38−#if MIN_VERSION_base(4,11,0)

39−import GHC.TypeLits hiding (natVal)

40−#else

4136import GHC.TypeLits

42−#endif

43−#if MIN_VERSION_base(4,9,0)

4437import Data.Kind (Type)

45−#endif

4638

4739import Numeric.LinearAlgebra hiding ( uniformSample, konst )

4840import qualified Numeric.LinearAlgebra as LA

@@ -138,8 +130,8 @@ instance ( KnownNat channels

138130 , KnownNat (kernelRows * kernelColumns * filters)

139131 ) => UpdateLayer (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where

140132 type Gradient (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns)

141− runUpdate LearningParameters {..} (Deconvolution oldKernel oldMomentum) (Deconvolution' kernelGradient) =

142− let (newKernel, newMomentum) = descendMatrix learningRate learningMomentum learningRegulariser oldKernel kernelGradient oldMomentum

133+ runUpdate lp (Deconvolution oldKernel oldMomentum) (Deconvolution' kernelGradient) =

134+ let (newKernel, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldKernel kernelGradient oldMomentum

143135 in Deconvolution newKernel newMomentum

144136

145137 createRandom = randomDeconvolution

src/Grenade/Layers/FullyConnected.hs+4−5

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

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE RecordWildCards #-}

32{-# LANGUAGE TypeOperators #-}

43{-# LANGUAGE TypeFamilies #-}

54{-# LANGUAGE MultiParamTypeClasses #-}

@@ -14,7 +13,6 @@ import Control.Monad.Random hiding (fromList)

1413

1514import Data.Proxy

1615import Data.Serialize

17−import Data.Singletons.TypeLits

1816

1917import qualified Numeric.LinearAlgebra as LA

2018import Numeric.LinearAlgebra.Static

@@ -22,6 +20,7 @@ import Numeric.LinearAlgebra.Static

2220import Grenade.Core

2321

2422import Grenade.Layers.Internal.Update

23+import GHC.TypeLits

2524

2625-- | A basic fully connected (or inner product) neural network layer.

2726data FullyConnected i o = FullyConnected

@@ -38,9 +37,9 @@ instance Show (FullyConnected i o) where

3837instance (KnownNat i, KnownNat o) => UpdateLayer (FullyConnected i o) where

3938 type Gradient (FullyConnected i o) = (FullyConnected' i o)

4039

41− runUpdate LearningParameters {..} (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =

42− let (newBias, newBiasMomentum) = descendVector learningRate learningMomentum learningRegulariser oldBias biasGradient oldBiasMomentum

43− (newActivations, newMomentum) = descendMatrix learningRate learningMomentum learningRegulariser oldActivations activationGradient oldMomentum

40+ runUpdate lp (FullyConnected (FullyConnected' oldBias oldActivations) (FullyConnected' oldBiasMomentum oldMomentum)) (FullyConnected' biasGradient activationGradient) =

41+ let (newBias, newBiasMomentum) = descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldBias biasGradient oldBiasMomentum

42+ (newActivations, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldActivations activationGradient oldMomentum

4443 in FullyConnected (FullyConnected' newBias newActivations) (FullyConnected' newBiasMomentum newMomentum)

4544

4645 createRandom = randomFullyConnected

src/Grenade/Layers/Pad.hs−7

@@ -21,16 +21,9 @@ module Grenade.Layers.Pad (

2121import Data.Maybe

2222import Data.Proxy

2323import Data.Serialize

24−import Data.Singletons.TypeLits

2524

26−#if MIN_VERSION_base(4,11,0)

27−import GHC.TypeLits hiding (natVal)

28−#else

2925import GHC.TypeLits

30−#endif

31−#if MIN_VERSION_base(4,9,0)

3226import Data.Kind (Type)

33−#endif

3427

3528import Grenade.Core

3629import Grenade.Layers.Internal.Pad

src/Grenade/Layers/Pooling.hs−7

@@ -22,16 +22,9 @@ module Grenade.Layers.Pooling (

2222import Data.Maybe

2323import Data.Proxy

2424import Data.Serialize

25−import Data.Singletons.TypeLits

2625

27−#if MIN_VERSION_base(4,11,0)

28−import GHC.TypeLits hiding (natVal)

29−#else

3026import GHC.TypeLits

31−#endif

32−#if MIN_VERSION_base(4,9,0)

3327import Data.Kind (Type)

34−#endif

3528

3629import Grenade.Core

3730import Grenade.Layers.Internal.Pooling

src/Grenade/Layers/Reshape.hs−1

@@ -17,7 +17,6 @@ module Grenade.Layers.Reshape (

1717

1818import Data.Serialize

1919

20−import Data.Singletons.TypeLits

2120import GHC.TypeLits

2221

2322import Numeric.LinearAlgebra.Static

src/Grenade/Recurrent/Core/Network.hs+1−4

@@ -29,16 +29,13 @@ module Grenade.Recurrent.Core.Network (

2929

3030

3131import Control.Monad.Random ( MonadRandom )

32−import Data.Singletons ( SingI )

33−import Data.Singletons.Prelude ( Head, Last )

3432import Data.Serialize

3533

36−#if MIN_VERSION_base(4,9,0)

3734import Data.Kind (Type)

38−#endif

3935

4036import Grenade.Core

4137import Grenade.Recurrent.Core.Layer

38+import Prelude.Singletons

4239

4340-- | Witness type to say indicate we're building up with a normal feed

4441-- forward layer.

src/Grenade/Recurrent/Core/Runner.hs+5−6

@@ -6,7 +6,6 @@

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE FlexibleContexts #-}

88{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE RecordWildCards #-}

109

1110module Grenade.Recurrent.Core.Runner (

1211 runRecurrentExamples

@@ -18,10 +17,10 @@ module Grenade.Recurrent.Core.Runner (

1817 ) where

1918

2019import Data.List ( foldl' )

21−import Data.Singletons.Prelude

2220import Grenade.Core

2321

2422import Grenade.Recurrent.Core.Network

23+import Prelude.Singletons

2524

2625type RecurrentGradients layers = [RecurrentGradient layers]

2726

@@ -101,11 +100,11 @@ updateRecInputs :: Fractional (RecurrentInputs sublayers)

101100 -> RecurrentInputs sublayers

102101 -> RecurrentInputs sublayers

103102

104−updateRecInputs l@LearningParameters {..} (() :~~+> xs) (() :~~+> ys)

105− = () :~~+> updateRecInputs l xs ys

103+updateRecInputs lp (() :~~+> xs) (() :~~+> ys)

104+ = () :~~+> updateRecInputs lp xs ys

106105

107−updateRecInputs l@LearningParameters {..} (x :~@+> xs) (y :~@+> ys)

108− = (realToFrac (1 - learningRate * learningRegulariser) * x - realToFrac learningRate * y) :~@+> updateRecInputs l xs ys

106+updateRecInputs lp (x :~@+> xs) (y :~@+> ys)

107+ = (realToFrac (1 - learningRate lp * learningRegulariser lp) * x - realToFrac (learningRate lp) * y) :~@+> updateRecInputs lp xs ys

109108

110109updateRecInputs _ RINil RINil

111110 = RINil

src/Grenade/Recurrent/Layers/BasicRecurrent.hs+4−8

@@ -1,7 +1,6 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DataKinds #-}

33{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE RecordWildCards #-}

54{-# LANGUAGE TypeOperators #-}

65{-# LANGUAGE TypeFamilies #-}

76{-# LANGUAGE MultiParamTypeClasses #-}

@@ -17,11 +16,8 @@ module Grenade.Recurrent.Layers.BasicRecurrent (

1716

1817import Control.Monad.Random ( MonadRandom, getRandom )

1918

20−import Data.Singletons.TypeLits

2119

22−#if MIN_VERSION_base(4,9,0)

2320import Data.Kind (Type)

24−#endif

2521

2622import Numeric.LinearAlgebra.Static

2723

@@ -60,11 +56,11 @@ instance Show (BasicRecurrent i o) where

6056instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where

6157 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)

6258

63− runUpdate LearningParameters {..} (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

64− let newBiasMomentum = konst learningMomentum * oldBiasMomentum - konst learningRate * biasGradient

59+ runUpdate lp (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =

60+ let newBiasMomentum = konst (learningMomentum lp) * oldBiasMomentum - konst (learningRate lp) * biasGradient

6561 newBias = oldBias + newBiasMomentum

66− newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient

67− regulariser = konst (learningRegulariser * learningRate) * oldActivations

62+ newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient

63+ regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations

6864 newActivations = oldActivations + newMomentum - regulariser

6965 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum

7066

src/Grenade/Recurrent/Layers/LSTM.hs+41−55

@@ -3,7 +3,6 @@

33{-# LANGUAGE DataKinds #-}

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE RankNTypes #-}

6−{-# LANGUAGE RecordWildCards #-}

76{-# LANGUAGE TypeOperators #-}

87{-# LANGUAGE TypeFamilies #-}

98{-# LANGUAGE MultiParamTypeClasses #-}

@@ -22,11 +21,7 @@ import Control.Monad.Random ( MonadRandom, getRandom )

2221-- import Data.List ( foldl1' )

2322import Data.Proxy

2423import Data.Serialize

25−import Data.Singletons.TypeLits

26−

27−#if MIN_VERSION_base(4,9,0)

2824import Data.Kind (Type)

29−#endif

3025

3126import qualified Numeric.LinearAlgebra as LA

3227import Numeric.LinearAlgebra.Static

@@ -34,6 +29,7 @@ import Numeric.LinearAlgebra.Static

3429import Grenade.Core

3530import Grenade.Recurrent.Core

3631import Grenade.Layers.Internal.Update

32+import GHC.TypeLits

3733

3834

3935-- | Long Short Term Memory Recurrent unit

@@ -75,7 +71,7 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

7571

7672 -- Run the update function for each group matrix/vector of weights, momentums and gradients.

7773 -- Hmm, maybe the function should be used instead of passing in the learning parameters.

78− runUpdate LearningParameters {..} (LSTM w m) g =

74+ runUpdate lp (LSTM w m) g =

7975 let (wf, wf') = u lstmWf w m g

8076 (uf, uf') = u lstmUf w m g

8177 (bf, bf') = v lstmBf w m g

@@ -92,11 +88,11 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where

9288 -- Utility function for updating with the momentum, gradients, and weights.

9389 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))

9490 u e (e -> weights) (e -> momentum) (e -> gradient) =

95− descendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum

91+ descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

9692

9793 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))

9894 v e (e -> weights) (e -> momentum) (e -> gradient) =

99− descendVector learningRate learningMomentum learningRegulariser weights gradient momentum

95+ descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum

10096

10197 -- There's a lot of updates here, so to try and minimise the number of data copies

10298 -- we'll create a mutable bucket for each.

@@ -137,18 +133,18 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

137133 type RecTape (LSTM i o) ('D1 i) ('D1 o) = (R o, R i, R o, R o, R o, R o, R o, R o, R o, R o, R o)

138134 -- Forward propagation for the LSTM layer.

139135 -- The size of the cell state is also the size of the output.

140− runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =

136+ runRecurrentForwards (LSTM lw _) (S1D cell) (S1D input) =

141137 let -- Forget state vector

142− f_s = lstmBf + lstmWf #> input + lstmUf #> cell

138+ f_s = lstmBf lw + lstmWf lw #> input + lstmUf lw #> cell

143139 f_t = sigmoid f_s

144140 -- Input state vector

145− i_s = lstmBi + lstmWi #> input + lstmUi #> cell

141+ i_s = lstmBi lw + lstmWi lw #> input + lstmUi lw #> cell

146142 i_t = sigmoid i_s

147143 -- Output state vector

148− o_s = lstmBo + lstmWo #> input + lstmUo #> cell

144+ o_s = lstmBo lw + lstmWo lw #> input + lstmUo lw #> cell

149145 o_t = sigmoid o_s

150146 -- Cell input state vector

151− c_s = lstmBc + lstmWc #> input

147+ c_s = lstmBc lw + lstmWc lw #> input

152148 c_x = tanh c_s

153149 -- Cell state

154150 c_t = f_t * cell + i_t * c_x

@@ -162,7 +158,7 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

162158 --

163159 -- There's a test version using the AD library without hmatrix in the test

164160 -- suite. These should match always.

165− runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t) (S1D cellGrad) (S1D h_t') =

161+ runRecurrentBackwards (LSTM lw _) (cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t) (S1D cellGrad) (S1D h_t') =

166162 let -- Reverse Mode AD Derivitives

167163 c_t' = h_t' * o_t + cellGrad

168164

@@ -179,8 +175,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w

179175 c_s' = tanh' c_s * c_x'

180176

181177 -- The derivatives to pass sideways (recurrent) and downwards

182− cell' = tr lstmUf #> f_s' + tr lstmUo #> o_s' + tr lstmUi #> i_s' + c_t' * f_t

183− input' = tr lstmWf #> f_s' + tr lstmWo #> o_s' + tr lstmWi #> i_s' + tr lstmWc #> c_s'

178+ cell' = tr (lstmUf lw) #> f_s' + tr (lstmUo lw) #> o_s' + tr (lstmUi lw) #> i_s' + c_t' * f_t

179+ input' = tr (lstmWf lw) #> f_s' + tr (lstmWo lw) #> o_s' + tr (lstmWi lw) #> i_s' + tr (lstmWc lw) #> c_s'

184180

185181 -- Calculate the gradient Matricies for the input

186182 lstmWf' = f_s' `outer` input

@@ -239,44 +235,34 @@ tanh' :: (Floating a) => a -> a

239235tanh' t = 1 - s ^ (2 :: Int) where s = tanh t

240236

241237instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where

242− put (LSTM LSTMWeights {..} _) = do

243− u lstmWf

244− u lstmUf

245− v lstmBf

246− u lstmWi

247− u lstmUi

248− v lstmBi

249− u lstmWo

250− u lstmUo

251− v lstmBo

252− u lstmWc

253− v lstmBc

254− where

255− u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

256− u = putListOf put . LA.toList . LA.flatten . extract

257− v :: forall a. (KnownNat a) => Putter (R a)

258− v = putListOf put . LA.toList . extract

238+ put (LSTM lw _) = do

239+ u (lstmWf lw)

240+ u (lstmUf lw)

241+ v (lstmBf lw)

242+ u (lstmWi lw)

243+ u (lstmUi lw)

244+ v (lstmBi lw)

245+ u (lstmWo lw)

246+ u (lstmUo lw)

247+ v (lstmBo lw)

248+ u (lstmWc lw)

249+ v (lstmBc lw)

250+ where

251+ u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)

252+ u = putListOf put . LA.toList . LA.flatten . extract

253+ v :: forall a. (KnownNat a) => Putter (R a)

254+ v = putListOf put . LA.toList . extract

259255

260256 get = do

261− lstmWf <- u

262− lstmUf <- u

263− lstmBf <- v

264− lstmWi <- u

265− lstmUi <- u

266− lstmBi <- v

267− lstmWo <- u

268− lstmUo <- u

269− lstmBo <- v

270− lstmWc <- u

271− lstmBc <- v

272− return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

273− where

274− u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

275− u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

276− in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

277− v :: forall a. (KnownNat a) => Get (R a)

278− v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

279−

280− w0 = konst 0

281− u0 = konst 0

282− v0 = konst 0

257+ w <- LSTMWeights <$> u <*> u <*> v <*> u <*> u <*> v <*> u <*> u <*> v <*> u <*> v

258+ return $ LSTM w (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)

259+ where

260+ u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)

261+ u = let f = fromIntegral $ natVal (Proxy :: Proxy a)

262+ in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get

263+ v :: forall a. (KnownNat a) => Get (R a)

264+ v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get

265+

266+ w0 = konst 0

267+ u0 = konst 0

268+ v0 = konst 0

src/Grenade/Utils/OneHot.hs+1−1

@@ -22,7 +22,6 @@ import Data.Map ( Map )

2222import qualified Data.Map as M

2323

2424import Data.Proxy

25−import Data.Singletons.TypeLits

2625

2726import Data.Vector ( Vector )

2827import qualified Data.Vector as V

@@ -31,6 +30,7 @@ import qualified Data.Vector.Storable as VS

3130import Numeric.LinearAlgebra ( maxIndex )

3231import Numeric.LinearAlgebra.Devel

3332import Numeric.LinearAlgebra.Static

33+import GHC.TypeLits

3434

3535import Grenade.Core.Shape

3636

stack.yamlnew file+78

@@ -0,0 +1,78 @@

1+# This file was automatically generated by 'stack init'

2+#

3+# Some commonly used options have been documented as comments in this file.

4+# For advanced use and comprehensive documentation of the format, please see:

5+# https://docs.haskellstack.org/en/stable/yaml_configuration/

6+

7+# A warning or info to be displayed to the user on config load.

8+# user-message: |

9+

10+# Resolver to choose a 'specific' stackage snapshot or a compiler version.

11+# A snapshot resolver dictates the compiler version and the set of packages

12+# to be used for project dependencies. For example:

13+#

14+# resolver: lts-3.5

15+# resolver: nightly-2015-09-21

16+# resolver: ghc-7.10.2

17+#

18+# The location of a snapshot can be provided as a file or url. Stack assumes

19+# a snapshot provided as a file might change, whereas a url resource does not.

20+#

21+# resolver: ./custom-snapshot.yaml

22+# resolver: https://example.com/snapshots/2018-01-01.yaml

23+resolver: lts-20.18

24+

25+# User packages to be built.

26+# Various formats can be used as shown in the example below.

27+#

28+# packages:

29+# - some-directory

30+# - https://example.com/foo/bar/baz-0.0.2.tar.gz

31+# subdirs:

32+# - auto-update

33+# - wai

34+packages:

35+ - .

36+ - examples

37+

38+# Dependency packages to be pulled from upstream that are not in the resolver.

39+# These entries can reference officially published versions as well as

40+# forks / in-progress versions pinned to a git hash. For example:

41+#

42+# extra-deps:

43+# - acme-missiles-0.3

44+# - git: https://github.com/commercialhaskell/stack.git

45+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

46+#

47+extra-deps:

48+ - typelits-witnesses-0.3.0.3

49+

50+# Override default flag values for local packages and extra-deps

51+# flags: {}

52+

53+# Extra package databases containing global packages

54+# extra-package-dbs: []

55+

56+# Control whether we use the GHC we find on the path

57+# system-ghc: true

58+#

59+# Require a specific version of stack, using version ranges

60+# require-stack-version: -any # Default

61+# require-stack-version: ">=2.1"

62+#

63+# Override the architecture used by stack, especially useful on Windows

64+# arch: i386

65+# arch: x86_64

66+#

67+# Extra directories used by stack for building

68+# extra-include-dirs: [/path/to/dir]

69+# extra-lib-dirs: [/path/to/dir]

70+#

71+# Allow a newer minor version of GHC than the snapshot specifies

72+# compiler-check: newer-minor

73+

74+nix:

75+ enable: true

76+ packages:

77+ - blas

78+ - lapack

stack.yaml.locknew file+19

@@ -0,0 +1,19 @@

1+# This file was autogenerated by Stack.

2+# You should not edit this file by hand.

3+# For more information, please see the documentation at:

4+# https://docs.haskellstack.org/en/stable/lock_files

5+

6+packages:

7+- completed:

8+ hackage: typelits-witnesses-0.3.0.3@sha256:2d9df4ac6ff3077bfd2bf659e4b495e157723ac5b45c519762853f55df5c16db,2738

9+ pantry-tree:

10+ sha256: 6a42a462f98e94933b6e9721acd912c6c6b6a4743635efd15cc5871908c816a0

11+ size: 469

12+ original:

13+ hackage: typelits-witnesses-0.3.0.3

14+snapshots:

15+- completed:

16+ sha256: 9fa4bece7acfac1fc7930c5d6e24606004b09e80aa0e52e9f68b148201008db9

17+ size: 649606

18+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/18.yaml

19+ original: lts-20.18

test/Test/Grenade/Layers/PadCrop.hs−4

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

77{-# LANGUAGE ScopedTypeVariables #-}

88{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

99

10−#if __GLASGOW_HASKELL__ < 800

11−{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

12−#endif

13−

1410module Test.Grenade.Layers.PadCrop where

1511

1612import Grenade

test/Test/Grenade/Network.hs−3

@@ -14,9 +14,6 @@ import Control.Monad ( guard )

1414import Control.Monad.ST ( runST )

1515

1616import Data.Constraint

17−#if __GLASGOW_HASKELL__ < 800

18−import Data.Proxy

19−#endif

2017import qualified Data.Vector.Storable as VS

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

2219import Data.Singletons

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

@@ -121,9 +121,9 @@ prop_lstm_reference_backwards_cell =

121121 , showPretty x

122122 , showPretty y

123123 ]

124− Just diff ->

124+ Just differ ->

125125 withFrozenCallStack $

126− failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" diff) ""

126+ failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" differ) ""

127127infix 4 ~~~

128128

129129tests :: IO Bool

test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+25−21

@@ -6,7 +6,6 @@

66{-# LANGUAGE DeriveFunctor #-}

77{-# LANGUAGE DeriveFoldable #-}

88{-# LANGUAGE DeriveTraversable #-}

9−{-# LANGUAGE RecordWildCards #-}

109{-# LANGUAGE FlexibleContexts #-}

1110{-# LANGUAGE RankNTypes #-}

1211

@@ -15,9 +14,13 @@ module Test.Grenade.Recurrent.Layers.LSTM.Reference where

1514

1615import Data.Reflection

1716import Numeric.AD.Mode.Reverse

18−import Numeric.AD.Internal.Reverse ( Tape )

17+import Numeric.AD.Internal.Reverse (Tape)

1918

19+import GHC.TypeLits (KnownNat)

20+

21+import Grenade.Recurrent.Layers.LSTM (LSTMWeights (..))

2022import qualified Grenade.Recurrent.Layers.LSTM as LSTM

23+

2124import qualified Numeric.LinearAlgebra.Static as S

2225import qualified Numeric.LinearAlgebra as H

2326

@@ -54,31 +57,32 @@ data RefLSTM a = RefLSTM

5457 , refLstmBc :: Vector a -- Bias Cell (b_c)

5558 } deriving (Functor, Foldable, Traversable, Eq, Show)

5659

57−lstmToReference :: LSTM.LSTMWeights a b -> RefLSTM Double

58−lstmToReference LSTM.LSTMWeights {..} =

59− let refLstmWf = Matrix . H.toLists . S.extract $ lstmWf -- Weight Forget (W_f)

60− refLstmUf = Matrix . H.toLists . S.extract $ lstmUf -- Cell State Forget (U_f)

61− refLstmBf = Vector . H.toList . S.extract $ lstmBf -- Bias Forget (b_f)

62− refLstmWi = Matrix . H.toLists . S.extract $ lstmWi -- Weight Input (W_i)

63− refLstmUi = Matrix . H.toLists . S.extract $ lstmUi -- Cell State Input (U_i)

64− refLstmBi = Vector . H.toList . S.extract $ lstmBi -- Bias Input (b_i)

65− refLstmWo = Matrix . H.toLists . S.extract $ lstmWo -- Weight Output (W_o)

66− refLstmUo = Matrix . H.toLists . S.extract $ lstmUo -- Cell State Output (U_o)

67− refLstmBo = Vector . H.toList . S.extract $ lstmBo -- Bias Output (b_o)

68− refLstmWc = Matrix . H.toLists . S.extract $ lstmWc -- Weight Cell (W_c)

69− refLstmBc = Vector . H.toList . S.extract $ lstmBc -- Bias Cell (b_c)

70− in RefLSTM {..}

60+lstmToReference :: (KnownNat a, KnownNat b) => LSTM.LSTMWeights a b -> RefLSTM Double

61+lstmToReference lw =

62+ RefLSTM

63+ { refLstmWf = Matrix . H.toLists . S.extract $ lstmWf lw -- Weight Forget (W_f)

64+ , refLstmUf = Matrix . H.toLists . S.extract $ lstmUf lw -- Cell State Forget (U_f)

65+ , refLstmBf = Vector . H.toList . S.extract $ lstmBf lw -- Bias Forget (b_f)

66+ , refLstmWi = Matrix . H.toLists . S.extract $ lstmWi lw -- Weight Input (W_i)

67+ , refLstmUi = Matrix . H.toLists . S.extract $ lstmUi lw -- Cell State Input (U_i)

68+ , refLstmBi = Vector . H.toList . S.extract $ lstmBi lw -- Bias Input (b_i)

69+ , refLstmWo = Matrix . H.toLists . S.extract $ lstmWo lw -- Weight Output (W_o)

70+ , refLstmUo = Matrix . H.toLists . S.extract $ lstmUo lw -- Cell State Output (U_o)

71+ , refLstmBo = Vector . H.toList . S.extract $ lstmBo lw -- Bias Output (b_o)

72+ , refLstmWc = Matrix . H.toLists . S.extract $ lstmWc lw -- Weight Cell (W_c)

73+ , refLstmBc = Vector . H.toList . S.extract $ lstmBc lw -- Bias Cell (b_c)

74+ }

7175

7276runLSTM :: Floating a => RefLSTM a -> Vector a -> Vector a -> (Vector a, Vector a)

73−runLSTM RefLSTM {..} cell input =

77+runLSTM rl cell input =

7478 let -- Forget state vector

75− f_t = sigmoid $ refLstmBf #+ refLstmWf #> input #+ refLstmUf #> cell

79+ f_t = sigmoid $ refLstmBf rl #+ refLstmWf rl #> input #+ refLstmUf rl #> cell

7680 -- Input state vector

77− i_t = sigmoid $ refLstmBi #+ refLstmWi #> input #+ refLstmUi #> cell

81+ i_t = sigmoid $ refLstmBi rl #+ refLstmWi rl #> input #+ refLstmUi rl #> cell

7882 -- Output state vector

79− o_t = sigmoid $ refLstmBo #+ refLstmWo #> input #+ refLstmUo #> cell

83+ o_t = sigmoid $ refLstmBo rl #+ refLstmWo rl #> input #+ refLstmUo rl #> cell

8084 -- Cell input state vector

81− c_x = fmap tanh $ refLstmBc #+ refLstmWc #> input

85+ c_x = fmap tanh $ refLstmBc rl #+ refLstmWc rl #> input

8286 -- Cell state

8387 c_t = f_t #* cell #+ i_t #* c_x

8488 -- Output (it's sometimes recommended to use tanh c_t)

test/Test/Hedgehog/Hmatrix.hs+3−2

@@ -1,7 +1,8 @@

1−{-# LANGUAGE RankNTypes #-}

21{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE KindSignatures #-}

43{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

56

67module Test.Hedgehog.Hmatrix where

78

test/Test/Hedgehog/TypeLits.hs+12−18

@@ -7,33 +7,27 @@

77{-# LANGUAGE GADTs #-}

88module Test.Hedgehog.TypeLits where

99

10−import Data.Constraint

11−#if __GLASGOW_HASKELL__ < 800

12−import Data.Proxy

10+import Data.Constraint (Dict (..))

11+import Data.Singletons (Proxy (..), Sing (..), SomeSing (..), sing)

12+#if MIN_VERSION_singletons(2,6,0)

13+import Data.Singletons.TypeLits (SNat (..))

1314#endif

14−import Data.Singletons

1515

1616import Hedgehog (Gen)

1717import qualified Hedgehog.Gen as Gen

1818

1919import Grenade

2020

21−import GHC.TypeLits

22−import GHC.TypeLits.Witnesses

23−import Test.Hedgehog.Compat

21+import GHC.TypeLits (SomeNat (..), natVal, someNatVal)

22+import GHC.TypeLits.Witnesses ((%*), natDict)

23+import Test.Hedgehog.Compat (choose)

2424

2525genNat :: Gen SomeNat

2626genNat = do

2727 ~(Just n) <- someNatVal <$> choose 1 10

2828 return n

2929

30−#if __GLASGOW_HASKELL__ < 800

31−type Shape' = ('KProxy :: KProxy Shape)

32−#else

33−type Shape' = Shape

34−#endif

35−

36−genShape :: Gen (SomeSing Shape')

30+genShape :: Gen (SomeSing Shape)

3731genShape

3832 = Gen.choice [

3933 genD1

@@ -41,20 +35,20 @@ genShape

4135 , genD3

4236 ]

4337

44−genD1 :: Gen (SomeSing Shape')

38+genD1 :: Gen (SomeSing Shape)

4539genD1 = do

4640 n <- genNat

4741 return $ case n of

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

4943

50−genD2 :: Gen (SomeSing Shape')

44+genD2 :: Gen (SomeSing Shape)

5145genD2 = do

5246 n <- genNat

5347 m <- genNat

5448 return $ case (n, m) of

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

5650

57−genD3 :: Gen (SomeSing Shape')

51+genD3 :: Gen (SomeSing Shape)

5852genD3 = do

5953 n <- genNat

6054 m <- genNat

@@ -64,7 +58,7 @@ genD3 = do

6458 case natDict px %* natDict pz of

6559 Dict -> SomeSing (sing :: Sing ('D3 x y z))

6660

67−rss :: SomeSing Shape' -> String

61+rss :: SomeSing Shape -> String

6862rss (SomeSing (r :: Sing s)) = case r of

6963 (D1Sing a@SNat) -> "D1 " ++ show (natVal a)

7064 (D2Sing a@SNat b@SNat) -> "D2 " ++ show (natVal a) ++ " " ++ show (natVal b)