git.iko.soy/grenade
on master help sign in
swap
afb9f9b62 ahead, 0 behind
53 files changed+744−567
since splitsnapshots
unifiedsplit
.gitignore+3−1 .travis.yml+12−10 README.md+5−3 bench/bench-lstm.hs+1−40 cbits/gradient_decent.c → cbits/gradient_descent.c+2−2 cbits/gradient_decent.h → cbits/gradient_descent.h+1−1 examples/grenade-examples.cabal+10−9 examples/mafia+62 examples/main/feedforward.hs+3−1 examples/main/gan-mnist.hs+3 examples/main/mnist.hs+4 examples/main/recurrent.hs+5−5 examples/main/shakespeare.hs+20−17 framework/mafia+62 grenade.cabal+38−23 mafia+1−123 src/Grenade/Core/Layer.hs+8−3 src/Grenade/Core/Network.hs+11−6 src/Grenade/Core/Runner.hs+2−1 src/Grenade/Core/Shape.hs+29−21 src/Grenade/Layers/Concat.hs+7−1 src/Grenade/Layers/Convolution.hs+8−7 src/Grenade/Layers/Crop.hs+10−2 src/Grenade/Layers/Deconvolution.hs+8−7 src/Grenade/Layers/Elu.hs+3−3 src/Grenade/Layers/FullyConnected.hs+7−8 src/Grenade/Layers/Internal/Update.hs+12−12 src/Grenade/Layers/Logit.hs+15−9 src/Grenade/Layers/Merge.hs+6−1 src/Grenade/Layers/Pad.hs+7−4 src/Grenade/Layers/Pooling.hs+6−3 src/Grenade/Layers/Reshape.hs+1−1 src/Grenade/Layers/Sinusoid.hs+39 src/Grenade/Layers/Tanh.hs+3−3 src/Grenade/Recurrent/Core/Layer.hs+7−2 src/Grenade/Recurrent/Core/Network.hs+12−10 src/Grenade/Recurrent/Core/Runner.hs+5−6 src/Grenade/Recurrent/Layers/BasicRecurrent.hs+9−8 src/Grenade/Recurrent/Layers/ConcatRecurrent.hs+7−1 src/Grenade/Recurrent/Layers/LSTM.hs+56−79 src/Grenade/Utils/OneHot.hs+6−5 stack.yaml+78 stack.yaml.lock+19 test/Test/Grenade/Layers/Convolution.hs+9−5 test/Test/Grenade/Layers/FullyConnected.hs+7−2 test/Test/Grenade/Layers/PadCrop.hs−4 test/Test/Grenade/Layers/Pooling.hs+11−7 test/Test/Grenade/Network.hs+40−36 test/Test/Grenade/Recurrent/Layers/LSTM.hs+13−8 test/Test/Grenade/Recurrent/Layers/LSTM/Reference.hs+25−21 test/Test/Hedgehog/Compat.hs+4−21 test/Test/Hedgehog/Hmatrix.hs+7−5 test/Test/Hedgehog/TypeLits.hs+15−20
.gitignore+3−1
@@ -1,4 +1,6 @@
1+cabal.project.local
12.cabal-sandbox/
23cabal.sandbox.config
34dist/
4−
5+dist-newstyle/
6+.stack-work/
.travis.yml+12−10
@@ -2,28 +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.22 GHCVER=7.10.3
6− - CABALVER=1.24 GHCVER=8.0.1
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
711
812# Note: the distinction between `before_install` and `install` is not important.
913before_install:
1014 - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
1115 - travis_retry sudo apt-get update
12− - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER happy-1.19.5 alex-3.1.7 libblas-dev liblapack-dev
13− - 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
1418
1519install:
16− - cabal --version
1720 - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
18− - travis_retry cabal update
19− - cabal sandbox init
20− - cabal install --enable-tests --enable-benchmarks
21+ - travis_retry cabal-3.2 update
2122
2223notifications:
2324 email: false
2425
2526# 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.
2627script:
27− - cabal build
28− - 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
2931
README.md+5−3
@@ -3,6 +3,7 @@ Grenade
33
44[![Build Status](https://api.travis-ci.org/HuwCampbell/grenade.svg?branch=master)](https://travis-ci.org/HuwCampbell/grenade)
55[![Hackage page (downloads and API reference)][hackage-png]][hackage]
6+[![Hackage-Deps][hackage-deps-png]][hackage-deps]
67
78
89```
@@ -23,7 +24,7 @@ specified and initialised with random weights in a few lines of code with
2324type MNIST
2425 = Network
2526 '[ Convolution 1 10 5 5 1 1, Pooling 2 2 2 2, Relu
26− , Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, FlattenLayer, Relu
27+ , Convolution 10 16 5 5 1 1, Pooling 2 2 2 2, Reshape, Relu
2728 , FullyConnected 256 80, Logit, FullyConnected 80 10, Logit]
2829 '[ 'D2 28 28, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10
2930 , 'D3 8 8 16, 'D3 4 4 16, 'D1 256, 'D1 256
@@ -158,7 +159,7 @@ and the tests run using:
158159./mafia test
159160```
160161
161−Grenade builds with ghc 7.10 and 8.0.
162+Grenade builds with ghc 7.10, 8.0, 8.2 and 8.4.
162163
163164Thanks
164165------
@@ -187,4 +188,5 @@ Contributions are welcome.
187188
188189 [hackage]: http://hackage.haskell.org/package/grenade
189190 [hackage-png]: http://img.shields.io/hackage/v/grenade.svg
190−
191+ [hackage-deps]: http://packdeps.haskellers.com/reverse/grenade
192+ [hackage-deps-png]: https://img.shields.io/hackage-deps/v/grenade.svg
bench/bench-lstm.hs+1−40
@@ -5,61 +5,22 @@ import Criterion.Main
55
66import Grenade
77import Grenade.Recurrent
8−import Grenade.Layers.Internal.Update
9−
10−import qualified Numeric.LinearAlgebra.Static as H
118
129main :: IO ()
1310main = do
14− layer60 :: LSTM 40 60 <- createRandom
15− layer512 :: LSTM 40 512 <- createRandom
1611 input40 :: S ('D1 40) <- randomOfShape
17− rec60 :: S ('D1 60) <- randomOfShape
18− rec512 :: S ('D1 512) <- randomOfShape
1912 lstm :: RecNet <- randomRecurrent
2013
21− let upIn60 :: H.R 3600 = H.randomVector 1 H.Uniform * 2 - 1
22− let upIn512 :: H.R 262144 = H.randomVector 1 H.Uniform * 2 - 1
23−
2414 defaultMain [
25− bgroup "lstm" [ bench "forwards-60" $ nf (nfT3 . uncurry (testRun60 layer60)) (rec60, input40)
26− , bench "forwards-512" $ nf (nfT3 . uncurry (testRun512 layer512)) (rec512, input40)
27− , bench "backwards-60" $ nf (nfT3 . uncurry4 (testRun60' layer60)) (rec60, input40, rec60, rec60)
28− , bench "backwards-512" $ nf (nfT3 . uncurry4 (testRun512' layer512)) (rec512, input40, rec512, rec512)
29− ]
30− , bgroup "update" [ bench "matrix-60x60" $ nf (uncurry3 (decendVector 1 1 1)) (upIn60, upIn60, upIn60)
31− , bench "matrix-512x512" $ nf (uncurry3 (decendVector 1 1 1)) (upIn512, upIn512, upIn512)
32− ]
33− , bgroup "train" [ bench "one-time-step" $ whnf (nfT2 . trainRecurrent lp lstm 0) [(input40, Just input40)]
15+ bgroup "train" [ bench "one-time-step" $ whnf (nfT2 . trainRecurrent lp lstm 0) [(input40, Just input40)]
3416 , bench "ten-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm 0) $ replicate 10 (input40, Just input40)
3517 , bench "fifty-time-steps" $ whnf (nfT2 . trainRecurrent lp lstm 0) $ replicate 50 (input40, Just input40)
3618 ]
3719 ]
3820
39−testRun60 :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> ((S ('D1 60), S ('D1 40)), S ('D1 60), S ('D1 60))
40−testRun60 = runRecurrentForwards
41−
42−testRun60' :: LSTM 40 60 -> S ('D1 60) -> S ('D1 40) -> S ('D1 60) -> S ('D1 60) -> (Gradient (LSTM 40 60), S ('D1 60), S ('D1 40))
43−testRun60' = curry . runRecurrentBackwards
44−
45−testRun512 :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> ((S ('D1 512), S ('D1 40)), S ('D1 512), S ('D1 512))
46−testRun512 = runRecurrentForwards
47−
48−testRun512' :: LSTM 40 512 -> S ('D1 512) -> S ('D1 40) -> S ('D1 512) -> S ('D1 512) -> (Gradient (LSTM 40 512), S ('D1 512), S ('D1 40))
49−testRun512' = curry . runRecurrentBackwards
50−
51−uncurry4 :: (t -> t1 -> t2 -> t3 -> t4) -> (t, t1, t2, t3) -> t4
52−uncurry4 f (a,b,c,d) = f a b c d
53−
54−uncurry3 :: (t -> t1 -> t2 -> t3) -> (t, t1, t2) -> t3
55−uncurry3 f (a,b,c) = f a b c
56−
5721nfT2 :: (a, b) -> (a, b)
5822nfT2 (!a, !b) = (a, b)
5923
60−nfT3 :: (a, b, c) -> (b, c)
61−nfT3 (!_, !b, !c) = (b, c)
62−
6324
6425type R = Recurrent
6526type RecNet = RecurrentNetwork '[ R (LSTM 40 512), R (LSTM 512 40) ]
cbits/gradient_decent.c → cbits/gradient_descent.crenamed+2−2
@@ -1,6 +1,6 @@
1−#include "gradient_decent.h"
1+#include "gradient_descent.h"
22
3−void decend_cpu(int len, double rate, double momentum, double regulariser,
3+void descend_cpu(int len, double rate, double momentum, double regulariser,
44 const double* weights,
55 const double* gradient,
66 const double* last,
cbits/gradient_decent.h → cbits/gradient_descent.hrenamed+1−1
@@ -1,7 +1,7 @@
11#include <stdio.h>
22#include <stdint.h>
33
4−void decend_cpu(int len, double rate, double momentum, double regulariser,
4+void descend_cpu(int len, double rate, double momentum, double regulariser,
55 const double* weights,
66 const double* gradient,
77 const double* last,
examples/grenade-examples.cabal+10−9
@@ -26,7 +26,7 @@ executable feedforward
2626 , bytestring
2727 , cereal
2828 , either
29− , optparse-applicative == 0.13.*
29+ , optparse-applicative >= 0.13 && < 0.18
3030 , text == 1.2.*
3131 , mtl >= 2.2.1 && < 2.3
3232 , hmatrix
@@ -42,10 +42,10 @@ executable mnist
4242 , grenade
4343 , attoparsec
4444 , either
45− , optparse-applicative == 0.13.*
45+ , optparse-applicative >= 0.13 && < 0.18
4646 , text == 1.2.*
4747 , mtl >= 2.2.1 && < 2.3
48− , hmatrix >= 0.18 && < 0.19
48+ , hmatrix >= 0.18 && < 0.21
4949 , transformers
5050 , semigroups
5151 , singletons
@@ -61,10 +61,10 @@ executable gan-mnist
6161 , bytestring
6262 , cereal
6363 , either
64− , optparse-applicative == 0.13.*
64+ , optparse-applicative >= 0.13 && < 0.18
6565 , text == 1.2.*
6666 , mtl >= 2.2.1 && < 2.3
67− , hmatrix >= 0.18 && < 0.19
67+ , hmatrix >= 0.18 && < 0.21
6868 , transformers
6969 , semigroups
7070 , singletons
@@ -78,10 +78,10 @@ executable recurrent
7878 , grenade
7979 , attoparsec
8080 , either
81− , optparse-applicative == 0.13.*
81+ , optparse-applicative >= 0.13 && < 0.18
8282 , text == 1.2.*
8383 , mtl >= 2.2.1 && < 2.3
84− , hmatrix >= 0.18 && < 0.19
84+ , hmatrix >= 0.18 && < 0.21
8585 , transformers
8686 , semigroups
8787 , singletons
@@ -96,13 +96,14 @@ executable shakespeare
9696 , bytestring
9797 , cereal
9898 , either
99− , optparse-applicative == 0.13.*
99+ , optparse-applicative >= 0.13 && < 0.18
100100 , text == 1.2.*
101101 , mtl >= 2.2.1 && < 2.3
102− , hmatrix >= 0.18 && < 0.19
102+ , hmatrix >= 0.18 && < 0.21
103103 , transformers
104104 , semigroups
105105 , singletons
106+ , singletons-base
106107 , vector
107108 , MonadRandom
108109 , containers
examples/mafianew file+62
@@ -0,0 +1,62 @@
1+#!/bin/sh -eu
2+
3+: ${MAFIA_HOME:=$HOME/.mafia}
4+: ${MAFIA_VERSIONS:=$MAFIA_HOME/versions}
5+
6+latest_version () {
7+ git ls-remote https://github.com/haskell-mafia/mafia | grep refs/heads/master | cut -f 1
8+}
9+
10+build_version() {
11+ MAFIA_VERSION="$1"
12+ MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia')
13+ MAFIA_FILE=mafia-$MAFIA_VERSION
14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE
15+ mkdir -p $MAFIA_VERSIONS
16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"
17+ git clone https://github.com/haskell-mafia/mafia $MAFIA_TEMP
18+ git --git-dir="$MAFIA_TEMP/.git" --work-tree="$MAFIA_TEMP" reset --hard $MAFIA_VERSION || {
19+ echo "mafia version ($MAFIA_VERSION) could not be found." >&2
20+ exit 1
21+ }
22+ (cd "$MAFIA_TEMP" && ./bin/bootstrap) || {
23+ got=$?
24+ echo "mafia version ($MAFIA_VERSION) could not be built." >&2
25+ exit "$got"
26+ }
27+ chmod +x "$MAFIA_TEMP/.cabal-sandbox/bin/mafia"
28+ # Ensure executable is on same file-system so final mv is atomic.
29+ mv -f "$MAFIA_TEMP/.cabal-sandbox/bin/mafia" "$MAFIA_PATH.$$"
30+ mv "$MAFIA_PATH.$$" "$MAFIA_PATH" || {
31+ rm -f "$MAFIA_PATH.$$"
32+ echo "INFO: mafia version ($MAFIA_VERSION) already exists not overiding," >&2
33+ echo "INFO: this is expected if parallel builds of the same version of" >&2
34+ echo "INFO: mafia occur, we are playing by first in, wins." >&2
35+ exit 0
36+ }
37+}
38+
39+enable_version() {
40+ if [ $# -eq 0 ]; then
41+ MAFIA_VERSION="$(latest_version)"
42+ echo "INFO: No explicit mafia version requested installing latest ($MAFIA_VERSION)." >&2
43+ else
44+ MAFIA_VERSION="$1"
45+ fi
46+ [ -x "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" ] || build_version "$MAFIA_VERSION"
47+ ln -sf "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" "$MAFIA_HOME/versions/mafia"
48+}
49+
50+exec_mafia () {
51+ [ -x "$MAFIA_HOME/versions/mafia" ] || enable_version
52+ "$MAFIA_HOME/versions/mafia" "$@"
53+}
54+
55+#
56+# The actual start of the script.....
57+#
58+
59+case "${1:-}" in
60+upgrade) shift; enable_version "$@" ;;
61+*) exec_mafia "$@"
62+esac
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+5−5
@@ -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
@@ -31,10 +31,10 @@ import Grenade.Recurrent
3131-- creation function know how to treat the layers.
3232type R = Recurrent
3333
34−type RecNet = RecurrentNetwork '[ R (LSTM 1 4), R (LSTM 4 1)]
35− '[ 'D1 1, 'D1 4, 'D1 1 ]
34+type RecNet = RecurrentNetwork '[ R (LSTM 1 1)]
35+ '[ 'D1 1, 'D1 1]
3636
37−type RecInput = RecurrentInputs '[ R (LSTM 1 4), R (LSTM 4 1)]
37+type RecInput = RecurrentInputs '[ R (LSTM 1 1)]
3838
3939randomNet :: MonadRandom m => m RecNet
4040randomNet = randomRecurrent
examples/main/shakespeare.hs+20−17
@@ -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,11 +34,16 @@ 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
4242-- about an hour.
4343--
44+-- Grab the input from
45+-- https://raw.githubusercontent.com/karpathy/char-rnn/master/data/tinyshakespeare/input.txt
46+--
4447-- This is a first class recurrent net.
4548--
4649-- The F and R types are tagging types to ensure that the runner and
@@ -69,39 +72,39 @@ loadShakespeare :: FilePath -> ExceptT String IO (Vector Int, M.Map Char Int, Ve
6972loadShakespeare path = do
7073 contents <- lift $ readFile path
7174 let annotated = annotateCapitals contents
72− (m,cs) <- ExceptT . return . note "Couldn't fit data in hotMap" $ hotMap (Proxy :: Proxy 40) annotated
75+ (m,cs) <- ExceptT . return $ hotMap (Proxy :: Proxy 40) annotated
7376 hot <- ExceptT . return . note "Couldn't generate hot values" $ traverse (`M.lookup` m) annotated
7477 return (V.fromList hot, m, cs)
7578
7679trainSlice :: LearningParameters -> Shakespeare -> Shakespearian -> Vector Int -> Int -> Int -> (Shakespeare, Shakespearian)
77−trainSlice !rate !net !recIns input offset size =
80+trainSlice !lrate !net !recIns input offset size =
7881 let e = fmap (x . oneHot) . V.toList $ V.slice offset size input
7982 in case reverse e of
8083 (o : l : xs) ->
8184 let examples = reverse $ (l, Just o) : ((,Nothing) <$> xs)
82− in trainRecurrent rate net recIns examples
85+ in trainRecurrent lrate net recIns examples
8386 _ -> error "Not enough input"
8487 where
8588 x = fromMaybe (error "Hot variable didn't fit.")
8689
8790runShakespeare :: ShakespeareOpts -> ExceptT String IO ()
88−runShakespeare ShakespeareOpts {..} = do
89− (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare trainingFile
91+runShakespeare opts = do
92+ (shakespeare, oneHotMap, oneHotDictionary) <- loadShakespeare $ trainingFile opts
9093 (net0, i0) <- lift $
91− case loadPath of
94+ case loadPath opts of
9295 Just loadFile -> netLoad loadFile
9396 Nothing -> (,0) <$> randomNet
9497
9598 (trained, bestInput) <- lift $ foldM (\(!net, !io) size -> do
96− xs <- take (iterations `div` 10) <$> getRandomRs (0, length shakespeare - size - 1)
97− let (!trained, !bestInput) = foldl' (\(!n, !i) offset -> trainSlice rate n i shakespeare offset size) (net, io) xs
98− 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)
99102 putStrLn ("TRAINING STEP WITH SIZE: " ++ show size)
100103 putStrLn (unAnnotateCapitals results)
101104 return (trained, bestInput)
102− ) (net0, i0) $ replicate 10 sequenceSize
105+ ) (net0, i0) $ replicate 10 (sequenceSize opts)
103106
104− case savePath of
107+ case savePath opts of
105108 Just saveFile -> lift . B.writeFile saveFile $ runPut (put trained >> put bestInput)
106109 Nothing -> return ()
107110
@@ -113,12 +116,12 @@ generateParagraph :: forall layers shapes n a. (Last shapes ~ 'D1 n, Head shapes
113116 -> Vector a
114117 -> S ('D1 n)
115118 -> IO [a]
116−generateParagraph n s temperature hotmap hotdict =
119+generateParagraph n s temp hotmap hotdict =
117120 go s
118121 where
119122 go x y =
120123 do let (_, ns, o) = runRecurrent n x y
121− un <- sample temperature hotdict o
124+ un <- sample temp hotdict o
122125 Just re <- return $ makeHot hotmap un
123126 rest <- unsafeInterleaveIO $ go ns re
124127 return (un : rest)
framework/mafianew file+62
@@ -0,0 +1,62 @@
1+#!/bin/sh -eu
2+
3+: ${MAFIA_HOME:=$HOME/.mafia}
4+: ${MAFIA_VERSIONS:=$MAFIA_HOME/versions}
5+
6+latest_version () {
7+ git ls-remote https://github.com/haskell-mafia/mafia | grep refs/heads/master | cut -f 1
8+}
9+
10+build_version() {
11+ MAFIA_VERSION="$1"
12+ MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia')
13+ MAFIA_FILE=mafia-$MAFIA_VERSION
14+ MAFIA_PATH=$MAFIA_VERSIONS/$MAFIA_FILE
15+ mkdir -p $MAFIA_VERSIONS
16+ echo "Building $MAFIA_FILE in $MAFIA_TEMP"
17+ git clone https://github.com/haskell-mafia/mafia $MAFIA_TEMP
18+ git --git-dir="$MAFIA_TEMP/.git" --work-tree="$MAFIA_TEMP" reset --hard $MAFIA_VERSION || {
19+ echo "mafia version ($MAFIA_VERSION) could not be found." >&2
20+ exit 1
21+ }
22+ (cd "$MAFIA_TEMP" && ./bin/bootstrap) || {
23+ got=$?
24+ echo "mafia version ($MAFIA_VERSION) could not be built." >&2
25+ exit "$got"
26+ }
27+ chmod +x "$MAFIA_TEMP/.cabal-sandbox/bin/mafia"
28+ # Ensure executable is on same file-system so final mv is atomic.
29+ mv -f "$MAFIA_TEMP/.cabal-sandbox/bin/mafia" "$MAFIA_PATH.$$"
30+ mv "$MAFIA_PATH.$$" "$MAFIA_PATH" || {
31+ rm -f "$MAFIA_PATH.$$"
32+ echo "INFO: mafia version ($MAFIA_VERSION) already exists not overiding," >&2
33+ echo "INFO: this is expected if parallel builds of the same version of" >&2
34+ echo "INFO: mafia occur, we are playing by first in, wins." >&2
35+ exit 0
36+ }
37+}
38+
39+enable_version() {
40+ if [ $# -eq 0 ]; then
41+ MAFIA_VERSION="$(latest_version)"
42+ echo "INFO: No explicit mafia version requested installing latest ($MAFIA_VERSION)." >&2
43+ else
44+ MAFIA_VERSION="$1"
45+ fi
46+ [ -x "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" ] || build_version "$MAFIA_VERSION"
47+ ln -sf "$MAFIA_HOME/versions/mafia-$MAFIA_VERSION" "$MAFIA_HOME/versions/mafia"
48+}
49+
50+exec_mafia () {
51+ [ -x "$MAFIA_HOME/versions/mafia" ] || enable_version
52+ "$MAFIA_HOME/versions/mafia" "$@"
53+}
54+
55+#
56+# The actual start of the script.....
57+#
58+
59+case "${1:-}" in
60+upgrade) shift; enable_version "$@" ;;
61+*) exec_mafia "$@"
62+esac
grenade.cabal+38−23
@@ -7,7 +7,7 @@ maintainer: Huw Campbell <huw.campbell@gmail.com>
77copyright: (c) 2016-2017 Huw Campbell.
88synopsis: Practical Deep Learning in Haskell
99category: AI, Machine Learning
10−cabal-version: >= 1.8
10+cabal-version: >= 1.10
1111build-type: Simple
1212description:
1313 Grenade is a composable, dependently typed, practical, and fast
@@ -17,7 +17,7 @@ description:
1717 Grenade provides an API for composing layers of a neural network
1818 into a sequence parallel graph in a type safe manner; running
1919 networks with reverse automatic differentiation to calculate their
20− gradients; and applying gradient decent for learning.
20+ gradients; and applying gradient descent for learning.
2121 .
2222 Documentation and examples are available on github
2323 <https://github.com/HuwCampbell/grenade>.
@@ -26,8 +26,8 @@ extra-source-files:
2626 README.md
2727 cbits/im2col.h
2828 cbits/im2col.c
29− cbits/gradient_decent.h
30− cbits/gradient_decent.c
29+ cbits/gradient_descent.h
30+ cbits/gradient_descent.c
3131 cbits/pad.h
3232 cbits/pad.c
3333
@@ -38,17 +38,17 @@ source-repository head
3838library
3939 build-depends:
4040 base >= 4.8 && < 5
41− , bytestring == 0.10.*
42− , containers >= 0.5 && < 0.6
41+ , bytestring >= 0.10.0
42+ , containers >= 0.5 && < 0.7
4343 , cereal >= 0.5 && < 0.6
4444 , deepseq >= 1.4 && < 1.5
45− , exceptions == 0.8.*
46− , hmatrix == 0.18.*
45+ , hmatrix >= 0.18 && < 0.21
4746 , MonadRandom >= 0.4 && < 0.6
48− , mtl >= 2.2.1 && < 2.3
49− , primitive >= 0.6 && < 0.7
50− , text == 1.2.*
51− , singletons >= 2.1 && < 2.4
47+ , primitive >= 0.6 && < 0.8
48+ -- Versions of singletons are *tightly* coupled with the
49+ -- GHC version so its fine to drop version bounds.
50+ , singletons
51+ , singletons-base
5252 , vector >= 0.11 && < 0.13
5353
5454 ghc-options:
@@ -56,9 +56,14 @@ library
5656 hs-source-dirs:
5757 src
5858
59+ default-language: Haskell2010
60+
5961 if impl(ghc < 8.0)
6062 ghc-options: -fno-warn-incomplete-patterns
63+ cpp-options: -DType=*
6164
65+ if impl(ghc >= 8.6)
66+ default-extensions: NoStarIsType
6267
6368 exposed-modules:
6469 Grenade
@@ -84,6 +89,7 @@ library
8489 Grenade.Layers.Pooling
8590 Grenade.Layers.Relu
8691 Grenade.Layers.Reshape
92+ Grenade.Layers.Sinusoid
8793 Grenade.Layers.Softmax
8894 Grenade.Layers.Tanh
8995 Grenade.Layers.Trivial
@@ -108,10 +114,10 @@ library
108114 Grenade.Utils.OneHot
109115
110116 includes: cbits/im2col.h
111− cbits/gradient_decent.h
117+ cbits/gradient_descent.h
112118 cbits/pad.h
113119 c-sources: cbits/im2col.c
114− cbits/gradient_decent.c
120+ cbits/gradient_descent.c
115121 cbits/pad.c
116122
117123 cc-options: -std=c99 -O3 -msse4.2 -Wall -Werror -DCABAL=1
@@ -126,6 +132,7 @@ test-suite test
126132 hs-source-dirs:
127133 test
128134
135+ default-language: Haskell2010
129136
130137 other-modules: Test.Hedgehog.Compat
131138 Test.Hedgehog.Hmatrix
@@ -146,16 +153,20 @@ test-suite test
146153
147154 if impl(ghc < 8.0)
148155 ghc-options: -fno-warn-incomplete-patterns
156+ cpp-options: -DType=*
157+
158+ if impl(ghc >= 8.6)
159+ default-extensions: NoStarIsType
149160
150161 build-depends:
151− base >= 4.8 && < 5
162+ base
152163 , grenade
153− , hedgehog >= 0.4 && < 0.5
164+ , hedgehog >= 1.0 && < 1.1
154165 , hmatrix
155166 , mtl
156167 , singletons
157168 , text == 1.2.*
158− , typelits-witnesses
169+ , typelits-witnesses < 0.4
159170 , transformers
160171 , constraints
161172 , MonadRandom
@@ -175,10 +186,12 @@ benchmark bench
175186 hs-source-dirs:
176187 bench
177188
189+ default-language: Haskell2010
190+
178191 build-depends:
179− base >= 3 && < 5
180− , bytestring == 0.10.*
181− , criterion == 1.1.*
192+ base
193+ , bytestring
194+ , criterion >= 1.1 && < 1.6
182195 , grenade
183196 , hmatrix
184197
@@ -192,9 +205,11 @@ benchmark bench-lstm
192205 hs-source-dirs:
193206 bench
194207
208+ default-language: Haskell2010
209+
195210 build-depends:
196− base >= 3 && < 5
197− , bytestring == 0.10.*
198− , criterion == 1.1.*
211+ base
212+ , bytestring
213+ , criterion
199214 , grenade
200215 , hmatrix
mafiamode 100755 → 120000+1−123
@@ -1,123 +0,0 @@
1−#!/bin/sh -eu
2−
3−: ${MAFIA_HOME:=$HOME/.mafia}
4−
5−fetch_latest () {
6− if [ -z ${MAFIA_TEST_MODE+x} ]; then
7− TZ=$(date +"%T")
8− curl --silent "https://raw.githubusercontent.com/ambiata/mafia/master/script/mafia?$TZ"
9− else
10− cat ../script/mafia
11− fi
12−}
13−
14−latest_version () {
15− git ls-remote https://github.com/ambiata/mafia | grep refs/heads/master | cut -f 1
16−}
17−
18−local_version () {
19− awk '/^# Version: / { print $3; exit 0; }' $0
20−}
21−
22−run_upgrade () {
23− MAFIA_TEMP=$(mktemp 2>/dev/null || mktemp -t 'upgrade_mafia')
24−
25− clean_up () {
26− rm -f "$MAFIA_TEMP"
27− }
28−
29− trap clean_up EXIT
30−
31− MAFIA_CUR="$0"
32−
33− if [ -L "$MAFIA_CUR" ]; then
34− echo 'Refusing to overwrite a symlink; run `upgrade` from the canonical path.' >&2
35− exit 1
36− fi
37−
38− echo "Checking for a new version of mafia ..."
39− fetch_latest > $MAFIA_TEMP
40−
41− LATEST_VERSION=$(latest_version)
42− echo "# Version: $LATEST_VERSION" >> $MAFIA_TEMP
43−
44− if ! cmp $MAFIA_CUR $MAFIA_TEMP >/dev/null 2>&1; then
45− mv $MAFIA_TEMP $MAFIA_CUR
46− chmod +x $MAFIA_CUR
47− echo "New version found and upgraded. You can now commit it to your git repo."
48− else
49− echo "You have latest mafia."
50− fi
51−}
52−
53−exec_mafia () {
54− MAFIA_VERSION=$(local_version)
55−
56− if [ "x$MAFIA_VERSION" = "x" ]; then
57− # If we can't find the mafia version, then we need to upgrade the script.
58− run_upgrade
59− else
60− MAFIA_BIN=$MAFIA_HOME/bin
61− MAFIA_FILE=mafia-$MAFIA_VERSION
62− MAFIA_PATH=$MAFIA_BIN/$MAFIA_FILE
63−
64− [ -f "$MAFIA_PATH" ] || {
65− # Create a temporary directory which will be deleted when the script
66− # terminates. Unfortunately `mktemp` doesn't behave the same on
67− # Linux and OS/X so we need to try two different approaches.
68− MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia')
69−
70− # Create a temporary file in MAFIA_BIN so we can do an atomic copy/move dance.
71− mkdir -p $MAFIA_BIN
72−
73− clean_up () {
74− rm -rf "$MAFIA_TEMP"
75− }
76−
77− trap clean_up EXIT
78−
79− echo "Building $MAFIA_FILE in $MAFIA_TEMP"
80−
81− ( cd "$MAFIA_TEMP"
82−
83− git clone https://github.com/ambiata/mafia
84− cd mafia
85−
86− git reset --hard $MAFIA_VERSION
87−
88− bin/bootstrap ) || exit $?
89−
90− MAFIA_PATH_TEMP=$(mktemp --tmpdir=$MAFIA_BIN $MAFIA_FILE-XXXXXX 2>/dev/null || TMPDIR=$MAFIA_BIN mktemp -t $MAFIA_FILE)
91−
92− clean_up_temp () {
93− clean_up
94− rm -f "$MAFIA_PATH_TEMP"
95− }
96− trap clean_up_temp EXIT
97−
98− cp "$MAFIA_TEMP/mafia/.cabal-sandbox/bin/mafia" "$MAFIA_PATH_TEMP"
99− chmod 755 "$MAFIA_PATH_TEMP"
100− mv "$MAFIA_PATH_TEMP" "$MAFIA_PATH"
101−
102− clean_up_temp
103− }
104−
105− exec $MAFIA_PATH "$@"
106− fi
107−}
108−
109−#
110−# The actual start of the script.....
111−#
112−
113−if [ $# -gt 0 ]; then
114− MODE="$1"
115−else
116− MODE=""
117−fi
118−
119−case "$MODE" in
120−upgrade) shift; run_upgrade "$@" ;;
121−*) exec_mafia "$@"
122−esac
123−# Version: 360716306a06db842ec022a7b9f161d2208483f0
@@ -0,0 +1 @@
1+framework/mafia
src/Grenade/Core/Layer.hs+8−3
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE TypeOperators #-}
@@ -19,7 +20,7 @@ neural network.
1920There are two classes of interest: `UpdateLayer` and `Layer`.
2021
2122`UpdateLayer` is required for all types which are used as a layer
22−in a network. Having no shape information, this class is agnotostic
23+in a network. Having no shape information, this class is agnostic
2324to the input and output data of the layer.
2425
2526An instance of `Layer` on the other hand is required for usage in
@@ -41,6 +42,10 @@ import Control.Monad.Random ( MonadRandom )
4142
4243import Data.List ( foldl' )
4344
45+#if MIN_VERSION_base(4,9,0)
46+import Data.Kind (Type)
47+#endif
48+
4449import Grenade.Core.Shape
4550import Grenade.Core.LearningParameters
4651
@@ -50,7 +55,7 @@ import Grenade.Core.LearningParameters
5055class UpdateLayer x where
5156 -- | The type for the gradient for this layer.
5257 -- Unit if there isn't a gradient to pass back.
53− type Gradient x :: *
58+ type Gradient x :: Type
5459
5560 -- | Update a layer with its gradient and learning parameters
5661 runUpdate :: LearningParameters -> x -> Gradient x -> x
@@ -72,7 +77,7 @@ class UpdateLayer x => Layer x (i :: Shape) (o :: Shape) where
7277 -- | The Wengert tape for this layer. Includes all that is required
7378 -- to generate the back propagated gradients efficiently. As a
7479 -- default, `S i` is fine.
75− type Tape x i o :: *
80+ type Tape x i o :: Type
7681
7782 -- | Used in training and scoring. Take the input from the previous
7883 -- layer, and give the output from this layer.
src/Grenade/Core/Network.hs+11−6
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE BangPatterns #-}
34{-# LANGUAGE GADTs #-}
@@ -33,12 +34,16 @@ module Grenade.Core.Network (
3334import Control.Monad.Random ( MonadRandom )
3435
3536import Data.Singletons
36−import Data.Singletons.Prelude
3737import Data.Serialize
3838
39+#if MIN_VERSION_base(4,9,0)
40+import Data.Kind (Type)
41+#endif
42+
3943import Grenade.Core.Layer
4044import Grenade.Core.LearningParameters
4145import Grenade.Core.Shape
46+import Prelude.Singletons
4247
4348-- | Type of a network.
4449--
@@ -48,7 +53,7 @@ import Grenade.Core.Shape
4853--
4954-- Can be considered to be a heterogeneous list of layers which are able to
5055-- transform the data shapes of the network.
51−data Network :: [*] -> [Shape] -> * where
56+data Network :: [Type] -> [Shape] -> Type where
5257 NNil :: SingI i
5358 => Network '[] '[i]
5459
@@ -66,7 +71,7 @@ instance (Show x, Show (Network xs rs)) => Show (Network (x ': xs) (i ': rs)) wh
6671-- | Gradient of a network.
6772--
6873-- Parameterised on the layers of the network.
69−data Gradients :: [*] -> * where
74+data Gradients :: [Type] -> Type where
7075 GNil :: Gradients '[]
7176
7277 (:/>) :: UpdateLayer x
@@ -77,7 +82,7 @@ data Gradients :: [*] -> * where
7782-- | Wegnert Tape of a network.
7883--
7984-- Parameterised on the layers and shapes of the network.
80−data Tapes :: [*] -> [Shape] -> * where
85+data Tapes :: [Type] -> [Shape] -> Type where
8186 TNil :: SingI i
8287 => Tapes '[] '[i]
8388
@@ -139,7 +144,7 @@ runGradient net tapes o =
139144 = (GNil, o)
140145
141146
142−-- | Apply one step of stochastic gradient decent across the network.
147+-- | Apply one step of stochastic gradient descent across the network.
143148applyUpdate :: LearningParameters
144149 -> Network layers shapes
145150 -> Gradients layers
@@ -152,7 +157,7 @@ applyUpdate _ NNil GNil
152157
153158-- | A network can easily be created by hand with (:~>), but an easy way to
154159-- initialise a random network is with the randomNetwork.
155−class CreatableNetwork (xs :: [*]) (ss :: [Shape]) where
160+class CreatableNetwork (xs :: [Type]) (ss :: [Shape]) where
156161 -- | Create a network with randomly initialised weights.
157162 --
158163 -- Calls to this function will not compile if the type of the neural
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+29−21
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE KindSignatures #-}
@@ -7,6 +8,7 @@
78{-# LANGUAGE FlexibleContexts #-}
89{-# LANGUAGE ScopedTypeVariables #-}
910{-# LANGUAGE RankNTypes #-}
11+{-# LANGUAGE UndecidableInstances #-}
1012{-|
1113Module : Grenade.Core.Shape
1214Description : Dependently typed shapes of data which are passed between layers of a network
@@ -17,26 +19,22 @@ Stability : experimental
1719
1820-}
1921module Grenade.Core.Shape (
20− Shape (..)
21− , S (..)
22− , Sing (..)
23−
22+ S (..)
23+ , Shape (..)
24+ , SShape (..)
2425 , randomOfShape
2526 , fromStorable
2627 ) where
2728
2829import Control.DeepSeq (NFData (..))
2930import Control.Monad.Random ( MonadRandom, getRandom )
30−
31+import Data.Kind (Type)
3132import Data.Proxy
3233import Data.Serialize
3334import Data.Singletons
34−import Data.Singletons.TypeLits
3535import Data.Vector.Storable ( Vector )
3636import qualified Data.Vector.Storable as V
37−
3837import GHC.TypeLits
39−
4038import qualified Numeric.LinearAlgebra.Static as H
4139import Numeric.LinearAlgebra.Static
4240import qualified Numeric.LinearAlgebra as NLA
@@ -81,17 +79,27 @@ deriving instance Show (S n)
8179-- These could probably be derived with template haskell, but this seems
8280-- clear and makes adding the KnownNat constraints simple.
8381-- 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
8491data instance Sing (n :: Shape) where
8592 D1Sing :: Sing a -> Sing ('D1 a)
8693 D2Sing :: Sing a -> Sing b -> Sing ('D2 a b)
8794 D3Sing :: KnownNat (a * c) => Sing a -> Sing b -> Sing c -> Sing ('D3 a b c)
95+#endif
8896
8997instance KnownNat a => SingI ('D1 a) where
90− sing = D1Sing sing
98+ sing = D1Sing
9199instance (KnownNat a, KnownNat b) => SingI ('D2 a b) where
92− sing = D2Sing sing sing
100+ sing = D2Sing
93101instance (KnownNat a, KnownNat b, KnownNat c, KnownNat (a * c)) => SingI ('D3 a b c) where
94− sing = D3Sing sing sing sing
102+ sing = D3Sing
95103
96104instance SingI x => Num (S x) where
97105 (+) = n2 (+)
@@ -140,13 +148,13 @@ randomOfShape :: forall x m. ( MonadRandom m, SingI x ) => m (S x)
140148randomOfShape = do
141149 seed :: Int <- getRandom
142150 return $ case (sing :: Sing x) of
143− D1Sing SNat ->
151+ D1Sing ->
144152 S1D (randomVector seed Uniform * 2 - 1)
145153
146− D2Sing SNat SNat ->
154+ D2Sing ->
147155 S2D (uniformSample seed (-1) 1)
148156
149− D3Sing SNat SNat SNat ->
157+ D3Sing ->
150158 S3D (uniformSample seed (-1) 1)
151159
152160-- | Generate a shape from a Storable Vector.
@@ -154,13 +162,13 @@ randomOfShape = do
154162-- Returns Nothing if the vector is of the wrong size.
155163fromStorable :: forall x. SingI x => Vector Double -> Maybe (S x)
156164fromStorable xs = case sing :: Sing x of
157− D1Sing SNat ->
165+ D1Sing ->
158166 S1D <$> H.create xs
159167
160− D2Sing SNat SNat ->
168+ D2Sing ->
161169 S2D <$> mkL xs
162170
163− D3Sing SNat SNat SNat ->
171+ D3Sing ->
164172 S3D <$> mkL xs
165173 where
166174 mkL :: forall rows columns. (KnownNat rows, KnownNat columns)
@@ -197,13 +205,13 @@ n2 f (S2D x) (S2D y) = S2D (f x y)
197205n2 f (S3D x) (S3D y) = S3D (f x y)
198206
199207-- Helper function for creating the number instances
200−nk :: forall x. SingI x => Double -> S x
208+nk :: forall x. (SingI x) => Double -> S x
201209nk x = case (sing :: Sing x) of
202− D1Sing SNat ->
210+ D1Sing ->
203211 S1D (konst x)
204212
205− D2Sing SNat SNat ->
213+ D2Sing ->
206214 S2D (konst x)
207215
208− D3Sing SNat SNat SNat ->
216+ D3Sing ->
209217 S3D (konst x)
src/Grenade/Layers/Concat.hs+7−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE TypeOperators #-}
@@ -8,6 +9,7 @@
89{-# LANGUAGE FlexibleInstances #-}
910{-# LANGUAGE ScopedTypeVariables #-}
1011{-# LANGUAGE StandaloneDeriving #-}
12+{-# LANGUAGE UndecidableInstances #-}
1113{-|
1214Module : Grenade.Layers.Concat
1315Description : Concatenation layer
@@ -26,6 +28,10 @@ import Data.Serialize
2628import Data.Singletons
2729import GHC.TypeLits
2830
31+#if MIN_VERSION_base(4,9,0)
32+import Data.Kind (Type)
33+#endif
34+
2935import Grenade.Core
3036
3137import Numeric.LinearAlgebra.Static ( row, (===), splitRows, unrow, (#), split, R )
@@ -43,7 +49,7 @@ import Numeric.LinearAlgebra.Static ( row, (===), splitRows, unrow, (#
4349--
4450-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad
4551-- and Crop layers to ensure this is the case.
46−data Concat :: Shape -> * -> Shape -> * -> * where
52+data Concat :: Shape -> Type -> Shape -> Type -> Type where
4753 Concat :: x -> y -> Concat m x n y
4854
4955instance (Show x, Show y) => Show (Concat m x n y) where
src/Grenade/Layers/Convolution.hs+8−7
@@ -1,12 +1,13 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE RecordWildCards #-}
44{-# LANGUAGE GADTs #-}
55{-# LANGUAGE TypeOperators #-}
66{-# LANGUAGE TypeFamilies #-}
77{-# LANGUAGE MultiParamTypeClasses #-}
88{-# LANGUAGE FlexibleInstances #-}
99{-# LANGUAGE FlexibleContexts #-}
10+{-# LANGUAGE UndecidableInstances #-}
1011{-|
1112Module : Grenade.Layers.Convolution
1213Description : Convolution layer
@@ -27,9 +28,9 @@ import Control.Monad.Random hiding ( fromList )
2728import Data.Maybe
2829import Data.Proxy
2930import Data.Serialize
30−import Data.Singletons.TypeLits
3131
3232import GHC.TypeLits
33+import Data.Kind (Type)
3334
3435import Numeric.LinearAlgebra hiding ( uniformSample, konst )
3536import qualified Numeric.LinearAlgebra as LA
@@ -56,7 +57,7 @@ data Convolution :: Nat -- Number of channels, for the first layer this could be
5657 -> Nat -- The number of column in the kernel filter
5758 -> Nat -- The row stride of the convolution filter
5859 -> Nat -- The columns stride of the convolution filter
59− -> * where
60+ -> Type where
6061 Convolution :: ( KnownNat channels
6162 , KnownNat filters
6263 , KnownNat kernelRows
@@ -75,7 +76,7 @@ data Convolution' :: Nat -- Number of channels, for the first layer this could b
7576 -> Nat -- The number of column in the kernel filter
7677 -> Nat -- The row stride of the convolution filter
7778 -> Nat -- The columns stride of the convolution filter
78− -> * where
79+ -> Type where
7980 Convolution' :: ( KnownNat channels
8081 , KnownNat filters
8182 , KnownNat kernelRows
@@ -129,9 +130,9 @@ instance ( KnownNat channels
129130 , KnownNat strideColumns
130131 , KnownNat (kernelRows * kernelColumns * channels)
131132 ) => UpdateLayer (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) where
132− type Gradient (Convolution channels filters kernelRows kernelCols strideRows strideCols) = (Convolution' channels filters kernelRows kernelCols strideRows strideCols)
133− runUpdate LearningParameters {..} (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =
134− let (newKernel, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldKernel kernelGradient oldMomentum
133+ type Gradient (Convolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Convolution' channels filters kernelRows kernelColumns strideRows strideColumns)
134+ runUpdate lp (Convolution oldKernel oldMomentum) (Convolution' kernelGradient) =
135+ let (newKernel, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldKernel kernelGradient oldMomentum
135136 in Convolution newKernel newMomentum
136137
137138 createRandom = randomConvolution
src/Grenade/Layers/Crop.hs+10−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE ScopedTypeVariables #-}
34{-# LANGUAGE GADTs #-}
@@ -5,6 +6,7 @@
56{-# LANGUAGE TypeFamilies #-}
67{-# LANGUAGE FlexibleContexts #-}
78{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE UndecidableInstances #-}
810{-|
911Module : Grenade.Layers.Crop
1012Description : Cropping layer
@@ -18,8 +20,10 @@ module Grenade.Layers.Crop (
1820
1921import Data.Maybe
2022import Data.Proxy
21−import Data.Singletons.TypeLits
23+import Data.Serialize
24+
2225import GHC.TypeLits
26+import Data.Kind (Type)
2327
2428import Grenade.Core
2529import Grenade.Layers.Internal.Pad
@@ -31,7 +35,7 @@ import Numeric.LinearAlgebra.Static (extract, create)
3135data Crop :: Nat
3236 -> Nat
3337 -> Nat
34− -> Nat -> * where
38+ -> Nat -> Type where
3539 Crop :: Crop cropLeft cropTop cropRight cropBottom
3640
3741instance Show (Crop cropLeft cropTop cropRight cropBottom) where
@@ -42,6 +46,10 @@ instance UpdateLayer (Crop l t r b) where
4246 runUpdate _ x _ = x
4347 createRandom = return Crop
4448
49+instance Serialize (Crop l t r b) where
50+ put _ = return ()
51+ get = return Crop
52+
4553-- | A two dimentional image can be cropped.
4654instance ( KnownNat cropLeft
4755 , KnownNat cropTop
src/Grenade/Layers/Deconvolution.hs+8−7
@@ -1,12 +1,13 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE RecordWildCards #-}
44{-# LANGUAGE GADTs #-}
55{-# LANGUAGE TypeOperators #-}
66{-# LANGUAGE TypeFamilies #-}
77{-# LANGUAGE MultiParamTypeClasses #-}
88{-# LANGUAGE FlexibleInstances #-}
99{-# LANGUAGE FlexibleContexts #-}
10+{-# LANGUAGE UndecidableInstances #-}
1011{-|
1112Module : Grenade.Layers.Deconvolution
1213Description : Deconvolution layer
@@ -31,9 +32,9 @@ import Control.Monad.Random hiding ( fromList )
3132import Data.Maybe
3233import Data.Proxy
3334import Data.Serialize
34−import Data.Singletons.TypeLits
3535
3636import GHC.TypeLits
37+import Data.Kind (Type)
3738
3839import Numeric.LinearAlgebra hiding ( uniformSample, konst )
3940import qualified Numeric.LinearAlgebra as LA
@@ -55,7 +56,7 @@ data Deconvolution :: Nat -- Number of channels, for the first layer this could
5556 -> Nat -- The number of column in the kernel filter
5657 -> Nat -- The row stride of the Deconvolution filter
5758 -> Nat -- The columns stride of the Deconvolution filter
58− -> * where
59+ -> Type where
5960 Deconvolution :: ( KnownNat channels
6061 , KnownNat filters
6162 , KnownNat kernelRows
@@ -74,7 +75,7 @@ data Deconvolution' :: Nat -- Number of channels, for the first layer this could
7475 -> Nat -- The number of column in the kernel filter
7576 -> Nat -- The row stride of the Deconvolution filter
7677 -> Nat -- The columns stride of the Deconvolution filter
77− -> * where
78+ -> Type where
7879 Deconvolution' :: ( KnownNat channels
7980 , KnownNat filters
8081 , KnownNat kernelRows
@@ -128,9 +129,9 @@ instance ( KnownNat channels
128129 , KnownNat strideColumns
129130 , KnownNat (kernelRows * kernelColumns * filters)
130131 ) => UpdateLayer (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) where
131− type Gradient (Deconvolution channels filters kernelRows kernelCols strideRows strideCols) = (Deconvolution' channels filters kernelRows kernelCols strideRows strideCols)
132− runUpdate LearningParameters {..} (Deconvolution oldKernel oldMomentum) (Deconvolution' kernelGradient) =
133− let (newKernel, newMomentum) = decendMatrix learningRate learningMomentum learningRegulariser oldKernel kernelGradient oldMomentum
132+ type Gradient (Deconvolution channels filters kernelRows kernelColumns strideRows strideColumns) = (Deconvolution' channels filters kernelRows kernelColumns strideRows strideColumns)
133+ runUpdate lp (Deconvolution oldKernel oldMomentum) (Deconvolution' kernelGradient) =
134+ let (newKernel, newMomentum) = descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) oldKernel kernelGradient oldMomentum
134135 in Deconvolution newKernel newMomentum
135136
136137 createRandom = randomDeconvolution
src/Grenade/Layers/Elu.hs+3−3
@@ -36,12 +36,12 @@ instance Serialize Elu where
3636 get = return Elu
3737
3838instance ( KnownNat i) => Layer Elu ('D1 i) ('D1 i) where
39− type Tape Elu ('D1 i) ('D1 i) = S ('D1 i)
39+ type Tape Elu ('D1 i) ('D1 i) = LAS.R i
4040
41− runForwards _ (S1D y) = (S1D y, S1D (elu y))
41+ runForwards _ (S1D y) = (y, S1D (elu y))
4242 where
4343 elu = LAS.dvmap (\a -> if a <= 0 then exp a - 1 else a)
44− runBackwards _ (S1D y) (S1D dEdy) = ((), S1D (elu' y * dEdy))
44+ runBackwards _ y (S1D dEdy) = ((), S1D (elu' y * dEdy))
4545 where
4646 elu' = LAS.dvmap (\a -> if a <= 0 then exp a else 1)
4747
src/Grenade/Layers/FullyConnected.hs+7−8
@@ -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,20 +37,20 @@ 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) = decendVector learningRate learningMomentum learningRegulariser oldBias biasGradient oldBiasMomentum
43− (newActivations, newMomentum) = decendMatrix 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
4746
4847instance (KnownNat i, KnownNat o) => Layer (FullyConnected i o) ('D1 i) ('D1 o) where
49− type Tape (FullyConnected i o) ('D1 i) ('D1 o) = S ('D1 i)
48+ type Tape (FullyConnected i o) ('D1 i) ('D1 o) = R i
5049 -- Do a matrix vector multiplication and return the result.
51− runForwards (FullyConnected (FullyConnected' wB wN) _) (S1D v) = (S1D v, S1D (wB + wN #> v))
50+ runForwards (FullyConnected (FullyConnected' wB wN) _) (S1D v) = (v, S1D (wB + wN #> v))
5251
5352 -- Run a backpropogation step for a full connected layer.
54− runBackwards (FullyConnected (FullyConnected' _ wN) _) (S1D x) (S1D dEdy) =
53+ runBackwards (FullyConnected (FullyConnected' _ wN) _) x (S1D dEdy) =
5554 let wB' = dEdy
5655 mm' = dEdy `outer` x
5756 -- calcluate derivatives for next step
src/Grenade/Layers/Internal/Update.hs+12−12
@@ -1,7 +1,7 @@
11{-# LANGUAGE ForeignFunctionInterface #-}
22module Grenade.Layers.Internal.Update (
3− decendMatrix
4− , decendVector
3+ descendMatrix
4+ , descendVector
55 ) where
66
77import Data.Maybe ( fromJust )
@@ -17,8 +17,8 @@ import qualified Numeric.LinearAlgebra.Devel as U
1717
1818import System.IO.Unsafe ( unsafePerformIO )
1919
20−decendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)
21−decendMatrix rate momentum regulariser weights gradient lastUpdate =
20+descendMatrix :: (KnownNat rows, KnownNat columns) => Double -> Double -> Double -> L rows columns -> L rows columns -> L rows columns -> (L rows columns, L rows columns)
21+descendMatrix rate momentum regulariser weights gradient lastUpdate =
2222 let (rows, cols) = size weights
2323 len = rows * cols
2424 -- Most gradients come in in ColumnMajor,
@@ -29,7 +29,7 @@ decendMatrix rate momentum regulariser weights gradient lastUpdate =
2929 weights' = flatten . tr . extract $ weights
3030 gradient' = flatten . tr . extract $ gradient
3131 lastUpdate' = flatten . tr . extract $ lastUpdate
32− (vw, vm) = decendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'
32+ (vw, vm) = descendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'
3333
3434 -- Note that it's ColumnMajor, as we did a transpose before
3535 -- using the internal vectors.
@@ -37,17 +37,17 @@ decendMatrix rate momentum regulariser weights gradient lastUpdate =
3737 mm = U.matrixFromVector U.ColumnMajor rows cols vm
3838 in (fromJust . create $ mw, fromJust . create $ mm)
3939
40−decendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)
41−decendVector rate momentum regulariser weights gradient lastUpdate =
40+descendVector :: (KnownNat r) => Double -> Double -> Double -> R r -> R r -> R r -> (R r, R r)
41+descendVector rate momentum regulariser weights gradient lastUpdate =
4242 let len = size weights
4343 weights' = extract weights
4444 gradient' = extract gradient
4545 lastUpdate' = extract lastUpdate
46− (vw, vm) = decendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'
46+ (vw, vm) = descendUnsafe len rate momentum regulariser weights' gradient' lastUpdate'
4747 in (fromJust $ create vw, fromJust $ create vm)
4848
49−decendUnsafe :: Int -> Double -> Double -> Double -> Vector Double -> Vector Double -> Vector Double -> (Vector Double, Vector Double)
50−decendUnsafe len rate momentum regulariser weights gradient lastUpdate =
49+descendUnsafe :: Int -> Double -> Double -> Double -> Vector Double -> Vector Double -> Vector Double -> (Vector Double, Vector Double)
50+descendUnsafe len rate momentum regulariser weights gradient lastUpdate =
5151 unsafePerformIO $ do
5252 outWPtr <- mallocForeignPtrArray len
5353 outMPtr <- mallocForeignPtrArray len
@@ -60,11 +60,11 @@ decendUnsafe len rate momentum regulariser weights gradient lastUpdate =
6060 withForeignPtr lPtr $ \lPtr' ->
6161 withForeignPtr outWPtr $ \outWPtr' ->
6262 withForeignPtr outMPtr $ \outMPtr' ->
63− decend_cpu len rate momentum regulariser wPtr' gPtr' lPtr' outWPtr' outMPtr'
63+ descend_cpu len rate momentum regulariser wPtr' gPtr' lPtr' outWPtr' outMPtr'
6464
6565 return (U.unsafeFromForeignPtr0 outWPtr len, U.unsafeFromForeignPtr0 outMPtr len)
6666
6767foreign import ccall unsafe
68− decend_cpu
68+ descend_cpu
6969 :: Int -> Double -> Double -> Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()
7070
src/Grenade/Layers/Logit.hs+15−9
@@ -34,18 +34,24 @@ instance UpdateLayer Logit where
3434 createRandom = return Logit
3535
3636instance (a ~ b, SingI a) => Layer Logit a b where
37+ -- Wengert tape optimisation:
38+ --
39+ -- Derivative of the sigmoid function is
40+ -- d σ(x) / dx = σ(x) • (1 - σ(x))
41+ -- but we have already calculated σ(x) in
42+ -- the forward pass, so just store that
43+ -- and use it in the backwards pass.
3744 type Tape Logit a b = S a
38− runForwards _ a = (a, logistic a)
39− runBackwards _ a g = ((), logistic' a * g)
45+ runForwards _ a =
46+ let l = sigmoid a
47+ in (l, l)
48+ runBackwards _ l g =
49+ let sigmoid' = l * (1 - l)
50+ in ((), sigmoid' * g)
4051
4152instance Serialize Logit where
4253 put _ = return ()
4354 get = return Logit
4455
45−logistic :: Floating a => a -> a
46−logistic x = 1 / (1 + exp (-x))
47−
48−logistic' :: Floating a => a -> a
49−logistic' x = logix * (1 - logix)
50− where
51− logix = logistic x
56+sigmoid :: Floating a => a -> a
57+sigmoid x = 1 / (1 + exp (-x))
src/Grenade/Layers/Merge.hs+6−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE TypeOperators #-}
@@ -23,13 +24,17 @@ import Data.Serialize
2324
2425import Data.Singletons
2526
27+#if MIN_VERSION_base(4,9,0)
28+import Data.Kind (Type)
29+#endif
30+
2631import Grenade.Core
2732
2833-- | A Merging layer.
2934--
3035-- Similar to Concat layer, except sums the activations instead of creating a larger
3136-- shape.
32−data Merge :: * -> * -> * where
37+data Merge :: Type -> Type -> Type where
3338 Merge :: x -> y -> Merge x y
3439
3540instance (Show x, Show y) => Show (Merge x y) where
src/Grenade/Layers/Pad.hs+7−4
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE ScopedTypeVariables #-}
34{-# LANGUAGE GADTs #-}
@@ -5,6 +6,7 @@
56{-# LANGUAGE TypeFamilies #-}
67{-# LANGUAGE MultiParamTypeClasses #-}
78{-# LANGUAGE FlexibleContexts #-}
9+{-# LANGUAGE UndecidableInstances #-}
810{-|
911Module : Grenade.Core.Pad
1012Description : Padding layer for 2D and 3D images
@@ -19,8 +21,9 @@ module Grenade.Layers.Pad (
1921import Data.Maybe
2022import Data.Proxy
2123import Data.Serialize
22−import Data.Singletons.TypeLits
24+
2325import GHC.TypeLits
26+import Data.Kind (Type)
2427
2528import Grenade.Core
2629import Grenade.Layers.Internal.Pad
@@ -34,7 +37,7 @@ import Numeric.LinearAlgebra.Static (extract, create)
3437data Pad :: Nat
3538 -> Nat
3639 -> Nat
37− -> Nat -> * where
40+ -> Nat -> Type where
3841 Pad :: Pad padLeft padTop padRight padBottom
3942
4043instance Show (Pad padLeft padTop padRight padBottom) where
@@ -49,7 +52,7 @@ instance Serialize (Pad l t r b) where
4952 put _ = return ()
5053 get = return Pad
5154
52−-- | A two dimentional image can be padped.
55+-- | A two dimentional image can be padded.
5356instance ( KnownNat padLeft
5457 , KnownNat padTop
5558 , KnownNat padRight
@@ -79,7 +82,7 @@ instance ( KnownNat padLeft
7982 vs = subMatrix (padt, padl) (nrows, ncols) m
8083 in ((), S2D . fromJust . create $ vs)
8184
82−-- | A two dimentional image can be padped.
85+-- | A two dimentional image can be padded.
8386instance ( KnownNat padLeft
8487 , KnownNat padTop
8588 , KnownNat padRight
src/Grenade/Layers/Pooling.hs+6−3
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE ScopedTypeVariables #-}
34{-# LANGUAGE StandaloneDeriving #-}
@@ -6,6 +7,7 @@
67{-# LANGUAGE TypeFamilies #-}
78{-# LANGUAGE MultiParamTypeClasses #-}
89{-# LANGUAGE FlexibleContexts #-}
10+{-# LANGUAGE UndecidableInstances #-}
911{-|
1012Module : Grenade.Core.Pooling
1113Description : Max Pooling layer for 2D and 3D images
@@ -20,8 +22,9 @@ module Grenade.Layers.Pooling (
2022import Data.Maybe
2123import Data.Proxy
2224import Data.Serialize
23−import Data.Singletons.TypeLits
25+
2426import GHC.TypeLits
27+import Data.Kind (Type)
2528
2629import Grenade.Core
2730import Grenade.Layers.Internal.Pooling
@@ -36,14 +39,14 @@ import Numeric.LinearAlgebra.Static as LAS hiding ((|||), build, toRow
3639-- The kernel size dictates which input and output sizes will "fit". Fitting the equation:
3740-- `out = (in - kernel) / stride + 1` for both dimensions.
3841--
39−data Pooling :: Nat -> Nat -> Nat -> Nat -> * where
42+data Pooling :: Nat -> Nat -> Nat -> Nat -> Type where
4043 Pooling :: Pooling kernelRows kernelColumns strideRows strideColumns
4144
4245instance Show (Pooling k k' s s') where
4346 show Pooling = "Pooling"
4447
4548instance UpdateLayer (Pooling kernelRows kernelColumns strideRows strideColumns) where
46− type Gradient (Pooling kr kc sr sc) = ()
49+ type Gradient (Pooling kernelRows kernelColumns strideRows strideColumns) = ()
4750 runUpdate _ Pooling _ = Pooling
4851 createRandom = return Pooling
4952
src/Grenade/Layers/Reshape.hs+1−1
@@ -3,6 +3,7 @@
33{-# LANGUAGE TypeFamilies #-}
44{-# LANGUAGE MultiParamTypeClasses #-}
55{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE UndecidableInstances #-}
67{-|
78Module : Grenade.Layers.Reshape
89Description : Multipurpose reshaping layer
@@ -16,7 +17,6 @@ module Grenade.Layers.Reshape (
1617
1718import Data.Serialize
1819
19−import Data.Singletons.TypeLits
2020import GHC.TypeLits
2121
2222import Numeric.LinearAlgebra.Static
src/Grenade/Layers/Sinusoid.hsnew file+39
@@ -0,0 +1,39 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-|
7+Module : Grenade.Layers.Sinusoid
8+Description : Sinusoid nonlinear layer
9+Copyright : (c) Manuel Schneckenreither, 2018
10+License : BSD2
11+Stability : experimental
12+-}
13+module Grenade.Layers.Sinusoid (
14+ Sinusoid (..)
15+ ) where
16+
17+import Data.Serialize
18+import Data.Singletons
19+
20+import Grenade.Core
21+
22+-- | A Sinusoid layer.
23+-- A layer which can act between any shape of the same dimension, performing a sin function.
24+data Sinusoid = Sinusoid
25+ deriving Show
26+
27+instance UpdateLayer Sinusoid where
28+ type Gradient Sinusoid = ()
29+ runUpdate _ _ _ = Sinusoid
30+ createRandom = return Sinusoid
31+
32+instance Serialize Sinusoid where
33+ put _ = return ()
34+ get = return Sinusoid
35+
36+instance (a ~ b, SingI a) => Layer Sinusoid a b where
37+ type Tape Sinusoid a b = S a
38+ runForwards _ a = (a, sin a)
39+ runBackwards _ a g = ((), cos a * g)
src/Grenade/Layers/Tanh.hs+3−3
@@ -1,8 +1,8 @@
11{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE TypeFamilies #-}
42{-# LANGUAGE FlexibleInstances #-}
53{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeOperators #-}
66{-|
77Module : Grenade.Layers.Tanh
88Description : Hyperbolic tangent nonlinear layer
@@ -20,7 +20,7 @@ import Data.Singletons
2020import Grenade.Core
2121
2222-- | A Tanh layer.
23−-- A layer which can act between any shape of the same dimension, perfoming a tanh function.
23+-- A layer which can act between any shape of the same dimension, performing a tanh function.
2424data Tanh = Tanh
2525 deriving Show
2626
src/Grenade/Recurrent/Core/Layer.hs+7−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE TypeFamilies #-}
34{-# LANGUAGE MultiParamTypeClasses #-}
@@ -8,6 +9,10 @@ module Grenade.Recurrent.Core.Layer (
89 , RecurrentUpdateLayer (..)
910 ) where
1011
12+#if MIN_VERSION_base(4,9,0)
13+import Data.Kind (Type)
14+#endif
15+
1116import Grenade.Core
1217
1318-- | Class for a recurrent layer.
@@ -15,11 +20,11 @@ import Grenade.Core
1520-- of an extra recurrent data shape.
1621class UpdateLayer x => RecurrentUpdateLayer x where
1722 -- | Shape of data that is passed between each subsequent run of the layer
18− type RecurrentShape x :: *
23+ type RecurrentShape x :: Type
1924
2025class (RecurrentUpdateLayer x, Num (RecurrentShape x)) => RecurrentLayer x (i :: Shape) (o :: Shape) where
2126 -- | Wengert Tape
22− type RecTape x i o :: *
27+ type RecTape x i o :: Type
2328 -- | Used in training and scoring. Take the input from the previous
2429 -- layer, and give the output from this layer.
2530 runRecurrentForwards :: x -> RecurrentShape x -> S i -> (RecTape x i o, RecurrentShape x, S o)
src/Grenade/Recurrent/Core/Network.hs+12−10
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE TypeOperators #-}
@@ -28,22 +29,23 @@ module Grenade.Recurrent.Core.Network (
2829
2930
3031import Control.Monad.Random ( MonadRandom )
31−import Data.Singletons ( SingI )
32−import Data.Singletons.Prelude ( Head, Last )
3332import Data.Serialize
3433
34+import Data.Kind (Type)
35+
3536import Grenade.Core
3637import Grenade.Recurrent.Core.Layer
38+import Prelude.Singletons
3739
3840-- | Witness type to say indicate we're building up with a normal feed
3941-- forward layer.
40−data FeedForward :: * -> *
42+data FeedForward :: Type -> Type
4143-- | Witness type to say indicate we're building up with a recurrent layer.
42−data Recurrent :: * -> *
44+data Recurrent :: Type -> Type
4345
4446-- | Type of a recurrent neural network.
4547--
46−-- The [*] type specifies the types of the layers.
48+-- The [Type] type specifies the types of the layers.
4749--
4850-- The [Shape] type specifies the shapes of data passed between the layers.
4951--
@@ -52,7 +54,7 @@ data Recurrent :: * -> *
5254--
5355-- Often, to make the definitions more concise, one will use a type alias
5456-- for these empty data types.
55−data RecurrentNetwork :: [*] -> [Shape] -> * where
57+data RecurrentNetwork :: [Type] -> [Shape] -> Type where
5658 RNil :: SingI i
5759 => RecurrentNetwork '[] '[i]
5860
@@ -71,7 +73,7 @@ infixr 5 :~@>
7173-- | Gradient of a network.
7274--
7375-- Parameterised on the layers of the network.
74−data RecurrentGradient :: [*] -> * where
76+data RecurrentGradient :: [Type] -> Type where
7577 RGNil :: RecurrentGradient '[]
7678
7779 (://>) :: UpdateLayer x
@@ -81,7 +83,7 @@ data RecurrentGradient :: [*] -> * where
8183
8284-- | Recurrent inputs (sideways shapes on an imaginary unrolled graph)
8385-- Parameterised on the layers of a Network.
84−data RecurrentInputs :: [*] -> * where
86+data RecurrentInputs :: [Type] -> Type where
8587 RINil :: RecurrentInputs '[]
8688
8789 (:~~+>) :: (UpdateLayer x, Fractional (RecurrentInputs xs))
@@ -95,7 +97,7 @@ data RecurrentInputs :: [*] -> * where
9597--
9698-- We index on the time step length as well, to ensure
9799-- that that all Tape lengths are the same.
98−data RecurrentTape :: [*] -> [Shape] -> * where
100+data RecurrentTape :: [Type] -> [Shape] -> Type where
99101 TRNil :: SingI i
100102 => RecurrentTape '[] '[i]
101103
@@ -204,7 +206,7 @@ instance (Show x, Show (RecurrentNetwork xs rs)) => Show (RecurrentNetwork (Recu
204206
205207-- | A network can easily be created by hand with (:~~>) and (:~@>), but an easy way to initialise a random
206208-- recurrent network and a set of random inputs for it is with the randomRecurrent.
207−class CreatableRecurrent (xs :: [*]) (ss :: [Shape]) where
209+class CreatableRecurrent (xs :: [Type]) (ss :: [Shape]) where
208210 -- | Create a network of the types requested
209211 randomRecurrent :: MonadRandom m => m (RecurrentNetwork xs ss)
210212
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+9−8
@@ -1,6 +1,6 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE RecordWildCards #-}
44{-# LANGUAGE TypeOperators #-}
55{-# LANGUAGE TypeFamilies #-}
66{-# LANGUAGE MultiParamTypeClasses #-}
@@ -16,7 +16,8 @@ module Grenade.Recurrent.Layers.BasicRecurrent (
1616
1717import Control.Monad.Random ( MonadRandom, getRandom )
1818
19−import Data.Singletons.TypeLits
19+
20+import Data.Kind (Type)
2021
2122import Numeric.LinearAlgebra.Static
2223
@@ -27,7 +28,7 @@ import Grenade.Recurrent.Core
2728
2829data BasicRecurrent :: Nat -- Input layer size
2930 -> Nat -- Output layer size
30− -> * where
31+ -> Type where
3132 BasicRecurrent :: ( KnownNat input
3233 , KnownNat output
3334 , KnownNat matrixCols
@@ -40,7 +41,7 @@ data BasicRecurrent :: Nat -- Input layer size
4041
4142data BasicRecurrent' :: Nat -- Input layer size
4243 -> Nat -- Output layer size
43− -> * where
44+ -> Type where
4445 BasicRecurrent' :: ( KnownNat input
4546 , KnownNat output
4647 , KnownNat matrixCols
@@ -55,11 +56,11 @@ instance Show (BasicRecurrent i o) where
5556instance (KnownNat i, KnownNat o, KnownNat (i + o)) => UpdateLayer (BasicRecurrent i o) where
5657 type Gradient (BasicRecurrent i o) = (BasicRecurrent' i o)
5758
58− runUpdate LearningParameters {..} (BasicRecurrent oldBias oldBiasMomentum oldActivations oldMomentum) (BasicRecurrent' biasGradient activationGradient) =
59− 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
6061 newBias = oldBias + newBiasMomentum
61− newMomentum = konst learningMomentum * oldMomentum - konst learningRate * activationGradient
62− regulariser = konst (learningRegulariser * learningRate) * oldActivations
62+ newMomentum = konst (learningMomentum lp) * oldMomentum - konst (learningRate lp) * activationGradient
63+ regulariser = konst (learningRegulariser lp * learningRate lp) * oldActivations
6364 newActivations = oldActivations + newMomentum - regulariser
6465 in BasicRecurrent newBias newBiasMomentum newActivations newMomentum
6566
src/Grenade/Recurrent/Layers/ConcatRecurrent.hs+7−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE TypeOperators #-}
@@ -8,6 +9,7 @@
89{-# LANGUAGE FlexibleInstances #-}
910{-# LANGUAGE ScopedTypeVariables #-}
1011{-# LANGUAGE StandaloneDeriving #-}
12+{-# LANGUAGE UndecidableInstances #-}
1113{-|
1214Module : Grenade.Layers.Concat
1315Description : Concatenation layer
@@ -26,6 +28,10 @@ import Data.Serialize
2628import Data.Singletons
2729import GHC.TypeLits
2830
31+#if MIN_VERSION_base(4,9,0)
32+import Data.Kind (Type)
33+#endif
34+
2935import Grenade.Core
3036import Grenade.Recurrent.Core
3137
@@ -44,7 +50,7 @@ import Numeric.LinearAlgebra.Static ( (#), split, R )
4450--
4551-- 3D images become 3D images with more channels. The sizes must be the same, one can use Pad
4652-- and Crop layers to ensure this is the case.
47−data ConcatRecurrent :: Shape -> * -> Shape -> * -> * where
53+data ConcatRecurrent :: Shape -> Type -> Shape -> Type -> Type where
4854 ConcatRecLeft :: x -> y -> ConcatRecurrent m (Recurrent x) n (FeedForward y)
4955 ConcatRecRight :: x -> y -> ConcatRecurrent m (FeedForward x) n (Recurrent y)
5056 ConcatRecBoth :: x -> y -> ConcatRecurrent m (Recurrent x) n (Recurrent y)
src/Grenade/Recurrent/Layers/LSTM.hs+56−79
@@ -1,8 +1,8 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE BangPatterns #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE GADTs #-}
45{-# LANGUAGE RankNTypes #-}
5−{-# LANGUAGE RecordWildCards #-}
66{-# LANGUAGE TypeOperators #-}
77{-# LANGUAGE TypeFamilies #-}
88{-# LANGUAGE MultiParamTypeClasses #-}
@@ -21,7 +21,7 @@ import Control.Monad.Random ( MonadRandom, getRandom )
2121-- import Data.List ( foldl1' )
2222import Data.Proxy
2323import Data.Serialize
24−import Data.Singletons.TypeLits
24+import Data.Kind (Type)
2525
2626import qualified Numeric.LinearAlgebra as LA
2727import Numeric.LinearAlgebra.Static
@@ -29,6 +29,7 @@ import Numeric.LinearAlgebra.Static
2929import Grenade.Core
3030import Grenade.Recurrent.Core
3131import Grenade.Layers.Internal.Update
32+import GHC.TypeLits
3233
3334
3435-- | Long Short Term Memory Recurrent unit
@@ -36,14 +37,14 @@ import Grenade.Layers.Internal.Update
3637-- This is a Peephole formulation, so the recurrent shape is
3738-- just the cell state, the previous output is not held or used
3839-- at all.
39−data LSTM :: Nat -> Nat -> * where
40+data LSTM :: Nat -> Nat -> Type where
4041 LSTM :: ( KnownNat input
4142 , KnownNat output
4243 ) => !(LSTMWeights input output) -- Weights
4344 -> !(LSTMWeights input output) -- Momentums
4445 -> LSTM input output
4546
46−data LSTMWeights :: Nat -> Nat -> * where
47+data LSTMWeights :: Nat -> Nat -> Type where
4748 LSTMWeights :: ( KnownNat input
4849 , KnownNat output
4950 ) => {
@@ -70,7 +71,7 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where
7071
7172 -- Run the update function for each group matrix/vector of weights, momentums and gradients.
7273 -- Hmm, maybe the function should be used instead of passing in the learning parameters.
73− runUpdate LearningParameters {..} (LSTM w m) g =
74+ runUpdate lp (LSTM w m) g =
7475 let (wf, wf') = u lstmWf w m g
7576 (uf, uf') = u lstmUf w m g
7677 (bf, bf') = v lstmBf w m g
@@ -87,11 +88,11 @@ instance (KnownNat i, KnownNat o) => UpdateLayer (LSTM i o) where
8788 -- Utility function for updating with the momentum, gradients, and weights.
8889 u :: forall x ix out. (KnownNat ix, KnownNat out) => (x -> (L out ix)) -> x -> x -> x -> ((L out ix), (L out ix))
8990 u e (e -> weights) (e -> momentum) (e -> gradient) =
90− decendMatrix learningRate learningMomentum learningRegulariser weights gradient momentum
91+ descendMatrix (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum
9192
9293 v :: forall x ix. (KnownNat ix) => (x -> (R ix)) -> x -> x -> x -> ((R ix), (R ix))
9394 v e (e -> weights) (e -> momentum) (e -> gradient) =
94− decendVector learningRate learningMomentum learningRegulariser weights gradient momentum
95+ descendVector (learningRate lp) (learningMomentum lp) (learningRegulariser lp) weights gradient momentum
9596
9697 -- There's a lot of updates here, so to try and minimise the number of data copies
9798 -- we'll create a mutable bucket for each.
@@ -127,23 +128,29 @@ instance (KnownNat i, KnownNat o) => RecurrentUpdateLayer (LSTM i o) where
127128
128129instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) where
129130
130− type RecTape (LSTM i o) ('D1 i) ('D1 o) = (S ('D1 o), S ('D1 i))
131+ -- The tape stores essentially every variable we calculate,
132+ -- so we don't have to run any forwards component again.
133+ 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)
131134 -- Forward propagation for the LSTM layer.
132135 -- The size of the cell state is also the size of the output.
133− runRecurrentForwards (LSTM (LSTMWeights {..}) _) (S1D cell) (S1D input) =
136+ runRecurrentForwards (LSTM lw _) (S1D cell) (S1D input) =
134137 let -- Forget state vector
135− f_t = sigmoid $ lstmBf + lstmWf #> input + lstmUf #> cell
138+ f_s = lstmBf lw + lstmWf lw #> input + lstmUf lw #> cell
139+ f_t = sigmoid f_s
136140 -- Input state vector
137− i_t = sigmoid $ lstmBi + lstmWi #> input + lstmUi #> cell
141+ i_s = lstmBi lw + lstmWi lw #> input + lstmUi lw #> cell
142+ i_t = sigmoid i_s
138143 -- Output state vector
139− o_t = sigmoid $ lstmBo + lstmWo #> input + lstmUo #> cell
144+ o_s = lstmBo lw + lstmWo lw #> input + lstmUo lw #> cell
145+ o_t = sigmoid o_s
140146 -- Cell input state vector
141− c_x = tanh $ lstmBc + lstmWc #> input
147+ c_s = lstmBc lw + lstmWc lw #> input
148+ c_x = tanh c_s
142149 -- Cell state
143150 c_t = f_t * cell + i_t * c_x
144151 -- Output (it's sometimes recommended to use tanh c_t)
145152 h_t = o_t * c_t
146− in ((S1D cell, S1D input), S1D c_t, S1D h_t)
153+ in ((cell, input, f_s, f_t, i_s, i_t, o_s, o_t, c_s, c_x, c_t), S1D c_t, S1D h_t)
147154
148155 -- Run a backpropogation step for an LSTM layer.
149156 -- We're doing all the derivatives by hand here, so one should
@@ -151,29 +158,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w
151158 --
152159 -- There's a test version using the AD library without hmatrix in the test
153160 -- suite. These should match always.
154− runRecurrentBackwards (LSTM (LSTMWeights {..}) _) (S1D cell, S1D input) (S1D cellGrad) (S1D h_t') =
155− -- We're not keeping the Wengert tape during the forward pass,
156− -- so we're duplicating some work here.
157− --
158− -- If I was being generous, I'd call it checkpointing.
159− --
160− -- Maybe think about better ways to store some intermediate states.
161− let -- Forget state vector
162− f_s = lstmBf + lstmWf #> input + lstmUf #> cell
163− f_t = sigmoid f_s
164− -- Input state vector
165− i_s = lstmBi + lstmWi #> input + lstmUi #> cell
166− i_t = sigmoid i_s
167− -- Output state vector
168− o_s = lstmBo + lstmWo #> input + lstmUo #> cell
169− o_t = sigmoid o_s
170− -- Cell input state vector
171− c_s = lstmBc + lstmWc #> input
172− c_x = tanh c_s
173− -- Cell state
174− c_t = f_t * cell + i_t * c_x
175−
176− -- Reverse Mode AD Derivitives
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') =
162+ let -- Reverse Mode AD Derivitives
177163 c_t' = h_t' * o_t + cellGrad
178164
179165 f_t' = c_t' * cell
@@ -189,8 +175,8 @@ instance (KnownNat i, KnownNat o) => RecurrentLayer (LSTM i o) ('D1 i) ('D1 o) w
189175 c_s' = tanh' c_s * c_x'
190176
191177 -- The derivatives to pass sideways (recurrent) and downwards
192− cell' = tr lstmUf #> f_s' + tr lstmUo #> o_s' + tr lstmUi #> i_s' + c_t' * f_t
193− 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'
194180
195181 -- Calculate the gradient Matricies for the input
196182 lstmWf' = f_s' `outer` input
@@ -235,7 +221,8 @@ randomLSTM = do
235221
236222-- | Maths
237223--
238−-- TODO: move to not here
224+-- TODO: Move to not here
225+-- Optimise backwards derivative
239226sigmoid :: Floating a => a -> a
240227sigmoid x = 1 / (1 + exp (-x))
241228
@@ -248,44 +235,34 @@ tanh' :: (Floating a) => a -> a
248235tanh' t = 1 - s ^ (2 :: Int) where s = tanh t
249236
250237instance (KnownNat i, KnownNat o) => Serialize (LSTM i o) where
251− put (LSTM LSTMWeights {..} _) = do
252− u lstmWf
253− u lstmUf
254− v lstmBf
255− u lstmWi
256− u lstmUi
257− v lstmBi
258− u lstmWo
259− u lstmUo
260− v lstmBo
261− u lstmWc
262− v lstmBc
263− where
264− u :: forall a b. (KnownNat a, KnownNat b) => Putter (L b a)
265− u = putListOf put . LA.toList . LA.flatten . extract
266− v :: forall a. (KnownNat a) => Putter (R a)
267− 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
268255
269256 get = do
270− lstmWf <- u
271− lstmUf <- u
272− lstmBf <- v
273− lstmWi <- u
274− lstmUi <- u
275− lstmBi <- v
276− lstmWo <- u
277− lstmUo <- u
278− lstmBo <- v
279− lstmWc <- u
280− lstmBc <- v
281− return $ LSTM (LSTMWeights {..}) (LSTMWeights w0 u0 v0 w0 u0 v0 w0 u0 v0 w0 v0)
282− where
283− u :: forall a b. (KnownNat a, KnownNat b) => Get (L b a)
284− u = let f = fromIntegral $ natVal (Proxy :: Proxy a)
285− in maybe (fail "Vector of incorrect size") return . create . LA.reshape f . LA.fromList =<< getListOf get
286− v :: forall a. (KnownNat a) => Get (R a)
287− v = maybe (fail "Vector of incorrect size") return . create . LA.fromList =<< getListOf get
288−
289− w0 = konst 0
290− u0 = konst 0
291− 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+6−5
@@ -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
@@ -52,15 +52,16 @@ oneHot hot =
5252
5353-- | Create a one hot map from any enumerable.
5454-- Returns a map, and the ordered list for the reverse transformation
55−hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Maybe (Map a Int, Vector a)
55+hotMap :: (Ord a, KnownNat n) => Proxy n -> [a] -> Either String (Map a Int, Vector a)
5656hotMap n as =
5757 let len = fromIntegral $ natVal n
5858 uniq = [ c | (c:_) <- group $ sort as]
5959 hotl = length uniq
60− in if hotl <= len
60+ in if hotl == len
6161 then
62− Just (M.fromList $ zip uniq [0..], V.fromList uniq)
63− else Nothing
62+ Right (M.fromList $ zip uniq [0..], V.fromList uniq)
63+ else
64+ Left ("Couldn't create hotMap of size " ++ show len ++ " from vector with " ++ show hotl ++ " unique characters")
6465
6566-- | From a map and value, create a 1D Shape
6667-- with one index hot (1) with the rest 0.
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/Convolution.hs+9−5
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE TemplateHaskell #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE GADTs #-}
@@ -15,6 +16,10 @@ import Data.Singletons ()
1516import GHC.TypeLits
1617import GHC.TypeLits.Witnesses
1718
19+#if MIN_VERSION_base(4,9,0)
20+import Data.Kind (Type)
21+#endif
22+
1823import Grenade.Core
1924import Grenade.Layers.Convolution
2025
@@ -25,7 +30,7 @@ import Test.Hedgehog.Hmatrix
2530import Test.Hedgehog.TypeLits
2631import Test.Hedgehog.Compat
2732
28−data OpaqueConvolution :: * where
33+data OpaqueConvolution :: Type where
2934 OpaqueConvolution :: Convolution channels filters kernelRows kernelColumns strideRows strideColumns -> OpaqueConvolution
3035
3136instance Show OpaqueConvolution where
@@ -39,11 +44,10 @@ genConvolution :: ( KnownNat channels
3944 , KnownNat strideColumns
4045 , KnownNat kernelFlattened
4146 , kernelFlattened ~ (kernelRows * kernelColumns * channels)
42− , Monad m
43− ) => Gen.Gen m (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)
47+ ) => Gen (Convolution channels filters kernelRows kernelColumns strideRows strideColumns)
4448genConvolution = Convolution <$> uniformSample <*> uniformSample
4549
46−genOpaqueOpaqueConvolution :: Monad m => Gen m OpaqueConvolution
50+genOpaqueOpaqueConvolution :: Gen OpaqueConvolution
4751genOpaqueOpaqueConvolution = do
4852 channels <- genNat
4953 filters <- genNat
@@ -59,7 +63,7 @@ genOpaqueOpaqueConvolution = do
5963 p2 = natDict pkc
6064 p3 = natDict pch
6165 in case p1 %* p2 %* p3 of
62− Dict -> OpaqueConvolution <$> (genConvolution :: Monad n => Gen n (Convolution ch fl kr kc sr sc))
66+ Dict -> OpaqueConvolution <$> (genConvolution :: Gen (Convolution ch fl kr kc sr sc))
6367
6468prop_conv_net_witness = property $
6569 blindForAll genOpaqueOpaqueConvolution >>= \onet ->
test/Test/Grenade/Layers/FullyConnected.hs+7−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE BangPatterns #-}
23{-# LANGUAGE TemplateHaskell #-}
34{-# LANGUAGE DataKinds #-}
@@ -12,6 +13,10 @@ import Data.Singletons ()
1213
1314import GHC.TypeLits
1415
16+#if MIN_VERSION_base(4,9,0)
17+import Data.Kind (Type)
18+#endif
19+
1520import Grenade.Core
1621import Grenade.Layers.FullyConnected
1722
@@ -20,13 +25,13 @@ import Hedgehog
2025import Test.Hedgehog.Compat
2126import Test.Hedgehog.Hmatrix
2227
23−data OpaqueFullyConnected :: * where
28+data OpaqueFullyConnected :: Type where
2429 OpaqueFullyConnected :: (KnownNat i, KnownNat o) => FullyConnected i o -> OpaqueFullyConnected
2530
2631instance Show OpaqueFullyConnected where
2732 show (OpaqueFullyConnected n) = show n
2833
29−genOpaqueFullyConnected :: Monad m => Gen m OpaqueFullyConnected
34+genOpaqueFullyConnected :: Gen OpaqueFullyConnected
3035genOpaqueFullyConnected = do
3136 input :: Integer <- choose 2 100
3237 output :: Integer <- choose 1 100
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/Layers/Pooling.hs+11−7
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE TemplateHaskell #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE KindSignatures #-}
@@ -9,26 +10,29 @@ module Test.Grenade.Layers.Pooling where
910import Data.Proxy
1011import Data.Singletons ()
1112
13+#if MIN_VERSION_base(4,9,0)
14+import Data.Kind (Type)
15+#endif
16+
1217import GHC.TypeLits
1318import Grenade.Layers.Pooling
1419
1520import Hedgehog
16−import qualified Hedgehog.Gen as Gen
1721
1822import Test.Hedgehog.Compat
1923
20−data OpaquePooling :: * where
24+data OpaquePooling :: Type where
2125 OpaquePooling :: (KnownNat kh, KnownNat kw, KnownNat sh, KnownNat sw) => Pooling kh kw sh sw -> OpaquePooling
2226
2327instance Show OpaquePooling where
2428 show (OpaquePooling n) = show n
2529
26−genOpaquePooling :: Monad m => Gen.Gen m OpaquePooling
30+genOpaquePooling :: Gen OpaquePooling
2731genOpaquePooling = do
28− Just kernelHeight <- someNatVal <$> choose 2 15
29− Just kernelWidth <- someNatVal <$> choose 2 15
30− Just strideHeight <- someNatVal <$> choose 2 15
31− Just strideWidth <- someNatVal <$> choose 2 15
32+ ~(Just kernelHeight) <- someNatVal <$> choose 2 15
33+ ~(Just kernelWidth ) <- someNatVal <$> choose 2 15
34+ ~(Just strideHeight) <- someNatVal <$> choose 2 15
35+ ~(Just strideWidth ) <- someNatVal <$> choose 2 15
3236
3337 case (kernelHeight, kernelWidth, strideHeight, strideWidth) of
3438 (SomeNat (_ :: Proxy kh), SomeNat (_ :: Proxy kw), SomeNat (_ :: Proxy sh), SomeNat (_ :: Proxy sw)) ->
test/Test/Grenade/Network.hs+40−36
@@ -14,17 +14,12 @@ 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
2320import Data.Singletons.Prelude.List
2421import Data.Singletons.TypeLits
2522
26−-- import Data.Type.Equality
27−
2823import Hedgehog
2924import qualified Hedgehog.Gen as Gen
3025import Hedgehog.Internal.Source
@@ -32,7 +27,15 @@ import Hedgehog.Internal.Property ( failWith )
3227
3328import Grenade
3429
30+#if MIN_VERSION_base(4,11,0)
31+import GHC.TypeLits hiding (natVal)
32+#else
3533import GHC.TypeLits
34+#endif
35+#if MIN_VERSION_base(4,9,0)
36+import Data.Kind (Type)
37+#endif
38+
3639import GHC.TypeLits.Witnesses
3740import Test.Hedgehog.Compat
3841import Test.Hedgehog.TypeLits
@@ -43,7 +46,7 @@ import Numeric.LinearAlgebra ( flatten )
4346import Numeric.LinearAlgebra.Static ( extract, norm_Inf )
4447import Unsafe.Coerce
4548
46−data SomeNetwork :: * where
49+data SomeNetwork :: Type where
4750 SomeNetwork :: ( SingI shapes, SingI (Head shapes), SingI (Last shapes), Show (Network layers shapes) ) => Network layers shapes -> SomeNetwork
4851
4952instance Show SomeNetwork where
@@ -53,7 +56,7 @@ instance Show SomeNetwork where
5356--
5457-- This is slightly insane for a few reasons. Everything must be wrapped up
5558-- in a SomeNetwork.
56−genNetwork :: Monad m => Gen.Gen m SomeNetwork
59+genNetwork :: Gen SomeNetwork
5760genNetwork =
5861 Gen.recursive Gen.choice [
5962 do SomeSing ( r :: Sing final ) <- genShape
@@ -74,8 +77,9 @@ genNetwork =
7477 , pure (SomeNetwork (Elu :~> rest :: Network ( Elu ': layers ) ( h ': h ': hs )))
7578 , pure (SomeNetwork (Softmax :~> rest :: Network ( Softmax ': layers ) ( h ': h ': hs )))
7679 , do -- Reshape to two dimensions
77− let divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]
78− let len = natVal l
80+ let divisors :: Integer -> [Integer]
81+ divisors n = 1 : [x | x <- [2..(n-1)], n `rem` x == 0]
82+ let len = fromIntegral $ natVal l
7983 rs <- Gen.element $ divisors len
8084 let cs = len `quot` rs
8185 case ( someNatVal rs, someNatVal cs, someNatVal len ) of
@@ -96,8 +100,8 @@ genNetwork =
96100 , do -- Build a convolution layer with one filter output
97101 -- Figure out some kernel sizes which work for this layer
98102 -- There must be a better way than this...
99− let output_r = natVal r
100− let output_c = natVal c
103+ let output_r = fromIntegral $ natVal r
104+ let output_c = fromIntegral $ natVal c
101105
102106 let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
103107
@@ -136,8 +140,8 @@ genNetwork =
136140 , do -- Build a convolution layer with one filter output
137141 -- Figure out some kernel sizes which work for this layer
138142 -- There must be a better way than this...
139− let output_r = natVal r
140− let output_c = natVal c
143+ let output_r = fromIntegral $ natVal r
144+ let output_c = fromIntegral $ natVal c
141145
142146 let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
143147
@@ -178,8 +182,8 @@ genNetwork =
178182 pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels 1 kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))
179183 _ -> Gen.discard -- Can't occur
180184 , do -- Build a Pooling layer
181− let output_r = natVal r
182− let output_c = natVal c
185+ let output_r = fromIntegral $ natVal r
186+ let output_c = fromIntegral $ natVal c
183187
184188 let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
185189
@@ -215,8 +219,8 @@ genNetwork =
215219 pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D2 inRows inCols) ': h ': hs )))
216220 _ -> Gen.discard -- Can't occur
217221 , do -- Build a Pad layer
218− let output_r = natVal r
219− let output_c = natVal c
222+ let output_r = fromIntegral $ natVal r
223+ let output_c = fromIntegral $ natVal c
220224
221225 pad_left <- choose 0 (output_r - 1)
222226 pad_right <- choose 0 (output_r - 1 - pad_left)
@@ -242,8 +246,8 @@ genNetwork =
242246 pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D2 inputRows inputColumns) ': h ': hs )))
243247 _ -> Gen.discard -- Can't occur
244248 , do -- Build a Crop layer
245− let output_r = natVal r
246− let output_c = natVal c
249+ let output_r = fromIntegral $ natVal r
250+ let output_c = fromIntegral $ natVal c
247251
248252 crop_left <- choose 0 10
249253 crop_right <- choose 0 10
@@ -275,9 +279,9 @@ genNetwork =
275279 , do -- Build a convolution layer with one filter output
276280 -- Figure out some kernel sizes which work for this layer
277281 -- There must be a better way than this...
278− let output_r = natVal r
279− let output_c = natVal c
280− let output_f = natVal f
282+ let output_r = fromIntegral $ natVal r
283+ let output_c = fromIntegral $ natVal c
284+ let output_f = fromIntegral $ natVal f
281285
282286 let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
283287
@@ -318,9 +322,9 @@ genNetwork =
318322 pure (SomeNetwork (conv :~> rest :: Network ( Convolution channels filters kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols channels) ': h ': hs )))
319323 _ -> Gen.discard -- Can't occur
320324 , do -- Build a Pooling layer
321− let output_r = natVal r
322− let output_c = natVal c
323− let output_f = natVal f
325+ let output_r = fromIntegral $ natVal r
326+ let output_c = fromIntegral $ natVal c
327+ let output_f = fromIntegral $ natVal f
324328
325329 let ok extent kernel = [stride | stride <- [ 1 .. extent ], (extent - kernel) `mod` stride == 0]
326330
@@ -359,9 +363,9 @@ genNetwork =
359363 pure (SomeNetwork (Pooling :~> rest :: Network ( Pooling kernelRows kernelCols strideRows strideCols ': layers ) ( ('D3 inRows inCols filters) ': h ': hs )))
360364 _ -> Gen.discard -- Can't occur
361365 , do -- Build a Pad layer
362− let output_r = natVal r
363− let output_c = natVal c
364− let output_f = natVal f
366+ let output_r = fromIntegral $ natVal r
367+ let output_c = fromIntegral $ natVal c
368+ let output_f = fromIntegral $ natVal f
365369
366370 pad_left <- choose 0 (output_r - 1)
367371 pad_right <- choose 0 (output_r - 1 - pad_left)
@@ -389,9 +393,9 @@ genNetwork =
389393 pure (SomeNetwork (Pad :~> rest :: Network ( Pad padLeft padTop padRight padBottom ': layers ) ( ('D3 inputRows inputColumns filters) ': h ': hs )))
390394 _ -> Gen.discard -- Can't occur
391395 , do -- Build a Crop layer
392− let output_r = natVal r
393− let output_c = natVal c
394− let output_f = natVal f
396+ let output_r = fromIntegral $ natVal r
397+ let output_c = fromIntegral $ natVal c
398+ let output_f = fromIntegral $ natVal f
395399
396400 crop_left <- choose 0 10
397401 crop_right <- choose 0 10
@@ -438,13 +442,13 @@ prop_auto_diff = withDiscards 1000 . withTests 10000 . property $ do
438442 result ~~~ expected
439443
440444-- Make a shape where all are 0 except for 1 value, which is 1.
441−oneUp :: forall shape m. ( Monad m, SingI shape ) => Gen.Gen m (S shape)
445+oneUp :: forall shape. ( SingI shape ) => Gen (S shape)
442446oneUp =
443447 case ( sing :: Sing shape ) of
444448 D1Sing SNat ->
445449 let x = 0 :: S ( shape )
446450 in case x of
447− ( S1D x' ) -> do
451+ ( S1D x' ) -> do
448452 let ex = extract x'
449453 let len = VS.length ex
450454 ix <- choose 0 (len - 1)
@@ -456,7 +460,7 @@ oneUp =
456460 D2Sing SNat SNat ->
457461 let x = 0 :: S ( shape )
458462 in case x of
459− ( S2D x' ) -> do
463+ ( S2D x' ) -> do
460464 let ex = flatten ( extract x' )
461465 let len = VS.length ex
462466 ix <- choose 0 (len - 1)
@@ -468,7 +472,7 @@ oneUp =
468472 D3Sing SNat SNat SNat ->
469473 let x = 0 :: S ( shape )
470474 in case x of
471− ( S3D x' ) -> do
475+ ( S3D x' ) -> do
472476 let ex = flatten ( extract x' )
473477 let len = VS.length ex
474478 ix <- choose 0 (len - 1)
@@ -482,7 +486,7 @@ maxVal ( S1D x ) = norm_Inf x
482486maxVal ( S2D x ) = norm_Inf x
483487maxVal ( S3D x ) = norm_Inf x
484488
485−(~~~) :: (Monad m, HasCallStack) => Double -> Double -> Test m ()
489+(~~~) :: (Monad m, HasCallStack) => Double -> Double -> PropertyT m ()
486490(~~~) x y =
487491 if abs (x - y) < 2e-5 then
488492 success
test/Test/Grenade/Recurrent/Layers/LSTM.hs+13−8
@@ -11,7 +11,6 @@
1111module Test.Grenade.Recurrent.Layers.LSTM where
1212
1313import Hedgehog
14−import qualified Hedgehog.Gen as Gen
1514import Hedgehog.Internal.Source
1615import Hedgehog.Internal.Show
1716import Hedgehog.Internal.Property ( failWith, Diff (..) )
@@ -29,7 +28,7 @@ import qualified Numeric.LinearAlgebra.Static as S
2928import qualified Test.Grenade.Recurrent.Layers.LSTM.Reference as Reference
3029import Test.Hedgehog.Hmatrix
3130
32−genLSTM :: forall i o m. (KnownNat i, KnownNat o, Monad m) => Gen.Gen m (LSTM i o)
31+genLSTM :: forall i o. (KnownNat i, KnownNat o) => Gen (LSTM i o)
3332genLSTM = do
3433 let w = uniformSample
3534 u = uniformSample
@@ -66,7 +65,9 @@ prop_lstm_reference_backwards =
6665 input :: S.R 3 <- forAll randomVector
6766 cell :: S.R 2 <- forAll randomVector
6867 net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
69− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
68+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))
69+ = runRecurrentForwards net (S1D cell) (S1D input)
70+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
7071 case actualBacks of
7172 (actualGradients, _, _ :: S ('D1 3)) ->
7273 let refNet = Reference.lstmToReference lstmWeights
@@ -80,7 +81,9 @@ prop_lstm_reference_backwards_input =
8081 input :: S.R 3 <- forAll randomVector
8182 cell :: S.R 2 <- forAll randomVector
8283 net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
83− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
84+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))
85+ = runRecurrentForwards net (S1D cell) (S1D input)
86+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
8487 case actualBacks of
8588 (_, _, S1D actualGradients :: S ('D1 3)) ->
8689 let refNet = Reference.lstmToReference lstmWeights
@@ -94,7 +97,9 @@ prop_lstm_reference_backwards_cell =
9497 input :: S.R 3 <- forAll randomVector
9598 cell :: S.R 2 <- forAll randomVector
9699 net@(LSTM lstmWeights _) :: LSTM 3 2 <- forAll genLSTM
97− let actualBacks = runRecurrentBackwards net (S1D cell, S1D input) (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
100+ let (tape, _ :: S ('D1 2), _ :: S ('D1 2))
101+ = runRecurrentForwards net (S1D cell) (S1D input)
102+ actualBacks = runRecurrentBackwards net tape (S1D (S.konst 1) :: S ('D1 2)) (S1D (S.konst 1) :: S ('D1 2))
98103 case actualBacks of
99104 (_, S1D actualGradients, _ :: S ('D1 3)) ->
100105 let refNet = Reference.lstmToReference lstmWeights
@@ -103,7 +108,7 @@ prop_lstm_reference_backwards_cell =
103108 refGradients = Reference.runLSTMbackOnCell refInput refNet refCell
104109 in toList refGradients ~~~ H.toList (S.extract actualGradients)
105110
106−(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> Test m ()
111+(~~~) :: (Monad m, Eq a, Ord a, Num a, Fractional a, Show a, HasCallStack) => [a] -> [a] -> PropertyT m ()
107112(~~~) x y =
108113 if all (< 1e-8) (zipWith (-) x y) then
109114 success
@@ -116,9 +121,9 @@ prop_lstm_reference_backwards_cell =
116121 , showPretty x
117122 , showPretty y
118123 ]
119− Just diff ->
124+ Just differ ->
120125 withFrozenCallStack $
121− failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" diff) ""
126+ failWith (Just $ Diff "Failed (" "- lhs" "~/~" "+ rhs" ")" differ) ""
122127infix 4 ~~~
123128
124129tests :: 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/Compat.hs+4−21
@@ -3,36 +3,19 @@ module Test.Hedgehog.Compat (
33 (...)
44 , choose
55 , blindForAll
6− , semiBlindForAll
7− , forAllRender
86 )where
97
10−import Control.Monad.Trans.Class (MonadTrans(..))
11−
8+import Hedgehog (Gen)
129import qualified Hedgehog.Gen as Gen
1310import qualified Hedgehog.Range as Range
1411import Hedgehog.Internal.Property
15−import Hedgehog.Internal.Source
16−import Hedgehog.Internal.Show
1712
1813(...) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
1914(...) = (.) . (.)
2015{-# INLINE (...) #-}
2116
22−choose :: ( Monad m, Integral a ) => a -> a -> Gen.Gen m a
17+choose :: Integral a => a -> a -> Gen a
2318choose = Gen.integral ... Range.constant
2419
25−blindForAll :: Monad m => Gen.Gen m a -> Test m a
26−blindForAll = Test . lift . lift
27−
28−semiBlindForAll :: (Monad m, Show a, HasCallStack) => Gen.Gen m a -> Test m a
29−semiBlindForAll gen = do
30− x <- Test . lift $ lift gen
31− withFrozenCallStack $ annotate (showPretty x)
32− return x
33−
34−forAllRender :: (Monad m, HasCallStack) => ( a -> String ) -> Gen.Gen m a -> Test m a
35−forAllRender render gen = do
36− x <- Test . lift $ lift gen
37− withFrozenCallStack $ footnote (render x)
38− return x
20+blindForAll :: Monad m => Gen a -> PropertyT m a
21+blindForAll = forAllWith (const "blind")
test/Test/Hedgehog/Hmatrix.hs+7−5
@@ -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
@@ -9,19 +10,20 @@ import Grenade
910import Data.Singletons
1011import Data.Singletons.TypeLits
1112
13+import Hedgehog (Gen)
1214import qualified Hedgehog.Gen as Gen
1315import qualified Hedgehog.Range as Range
1416
1517import qualified Numeric.LinearAlgebra.Static as HStatic
1618
17−randomVector :: forall m n. ( Monad m, KnownNat n ) => Gen.Gen m (HStatic.R n)
19+randomVector :: forall n. ( KnownNat n ) => Gen (HStatic.R n)
1820randomVector = (\s -> HStatic.randomVector s HStatic.Uniform * 2 - 1) <$> Gen.int Range.linearBounded
1921
20−uniformSample :: forall mm m n. ( Monad mm, KnownNat m, KnownNat n ) => Gen.Gen mm (HStatic.L m n)
22+uniformSample :: forall m n. ( KnownNat m, KnownNat n ) => Gen (HStatic.L m n)
2123uniformSample = (\s -> HStatic.uniformSample s (-1) 1 ) <$> Gen.int Range.linearBounded
2224
2325-- | Generate random data of the desired shape
24−genOfShape :: forall m x. ( Monad m, SingI x ) => Gen.Gen m (S x)
26+genOfShape :: forall x. ( SingI x ) => Gen (S x)
2527genOfShape =
2628 case (sing :: Sing x) of
2729 D1Sing l ->
test/Test/Hedgehog/TypeLits.hs+15−20
@@ -7,32 +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
16+import Hedgehog (Gen)
1617import qualified Hedgehog.Gen as Gen
1718
1819import Grenade
1920
20−import GHC.TypeLits
21−import GHC.TypeLits.Witnesses
22−import Test.Hedgehog.Compat
21+import GHC.TypeLits (SomeNat (..), natVal, someNatVal)
22+import GHC.TypeLits.Witnesses ((%*), natDict)
23+import Test.Hedgehog.Compat (choose)
2324
24−genNat :: Monad m => Gen.Gen m SomeNat
25+genNat :: Gen SomeNat
2526genNat = do
26− Just n <- someNatVal <$> choose 1 10
27+ ~(Just n) <- someNatVal <$> choose 1 10
2728 return n
2829
29−#if __GLASGOW_HASKELL__ < 800
30−type Shape' = ('KProxy :: KProxy Shape)
31−#else
32−type Shape' = Shape
33−#endif
34−
35−genShape :: Monad m => Gen.Gen m (SomeSing Shape')
30+genShape :: Gen (SomeSing Shape)
3631genShape
3732 = Gen.choice [
3833 genD1
@@ -40,20 +35,20 @@ genShape
4035 , genD3
4136 ]
4237
43−genD1 :: Monad m => Gen.Gen m (SomeSing Shape')
38+genD1 :: Gen (SomeSing Shape)
4439genD1 = do
4540 n <- genNat
4641 return $ case n of
4742 SomeNat (_ :: Proxy x) -> SomeSing (sing :: Sing ('D1 x))
4843
49−genD2 :: Monad m => Gen.Gen m (SomeSing Shape')
44+genD2 :: Gen (SomeSing Shape)
5045genD2 = do
5146 n <- genNat
5247 m <- genNat
5348 return $ case (n, m) of
5449 (SomeNat (_ :: Proxy x), SomeNat (_ :: Proxy y)) -> SomeSing (sing :: Sing ('D2 x y))
5550
56−genD3 :: Monad m => Gen.Gen m (SomeSing Shape')
51+genD3 :: Gen (SomeSing Shape)
5752genD3 = do
5853 n <- genNat
5954 m <- genNat
@@ -63,7 +58,7 @@ genD3 = do
6358 case natDict px %* natDict pz of
6459 Dict -> SomeSing (sing :: Sing ('D3 x y z))
6560
66−rss :: SomeSing Shape' -> String
61+rss :: SomeSing Shape -> String
6762rss (SomeSing (r :: Sing s)) = case r of
6863 (D1Sing a@SNat) -> "D1 " ++ show (natVal a)
6964 (D2Sing a@SNat b@SNat) -> "D2 " ++ show (natVal a) ++ " " ++ show (natVal b)