neural 0.3.0.0 → 0.3.0.1
raw patch · 47 files changed
+3333/−2805 lines, 47 filesdep +ansi-terminaldep +containersdep +randomdep ~Globdep ~JuicyPixelsdep ~MonadRandomsetup-changednew-component:exe:sin
Dependencies added: ansi-terminal, containers, random, vector-sized
Dependency ranges changed: Glob, JuicyPixels, MonadRandom, STMonadTrans, ad, array, attoparsec, bytestring, criterion, deepseq, directory, doctest, filepath, ghc-typelits-natnormalise, hspec, kan-extensions, lens, monad-par, monad-par-extras, mtl, neural, parallel, pipes, pipes-bytestring, pipes-safe, pipes-zlib, profunctors, reflection, text, transformers, typelits-witnesses, vector
Files
- .ghci +1/−1
- .gitignore +6/−4
- .travis.yml +40/−122
- LICENSE +21/−21
- README.markdown +49/−46
- Setup.hs +2/−2
- benchmark/benchmark.hs +79/−79
- doctest/doctest.hs +10/−10
- examples/MNIST/MNIST.hs +92/−89
- examples/iris/iris.hs +77/−79
- examples/sin/Graph.hs +58/−0
- examples/sin/sin.hs +43/−0
- examples/sqrt/sqrt.hs +50/−50
- neural.cabal +178/−158
- src/Data/FixedSize.hs +25/−0
- src/Data/FixedSize/Class.hs +53/−0
- src/Data/FixedSize/Matrix.hs +99/−0
- src/Data/FixedSize/Vector.hs +171/−0
- src/Data/FixedSize/Volume.hs +84/−0
- src/Data/MyPrelude.hs +61/−59
- src/Data/Utils.hs +35/−35
- src/Data/Utils/Analytic.hs +77/−77
- src/Data/Utils/Arrow.hs +66/−66
- src/Data/Utils/Cache.hs +77/−0
- src/Data/Utils/List.hs +187/−187
- src/Data/Utils/Matrix.hs +0/−131
- src/Data/Utils/Pipes.hs +85/−61
- src/Data/Utils/Random.hs +163/−162
- src/Data/Utils/Stack.hs +95/−95
- src/Data/Utils/Statistics.hs +160/−160
- src/Data/Utils/Traversable.hs +32/−32
- src/Data/Utils/Vector.hs +0/−195
- src/Numeric/Neural.hs +27/−25
- src/Numeric/Neural/Convolution.hs +108/−0
- src/Numeric/Neural/Layer.hs +102/−95
- src/Numeric/Neural/Model.hs +294/−313
- src/Numeric/Neural/Normalization.hs +192/−190
- src/Numeric/Neural/Pipes.hs +166/−92
- stack.yaml +10/−40
- test/Data/FixedSize/ClassSpec.hs +27/−0
- test/Data/FixedSize/MatrixSpec.hs +80/−0
- test/Data/FixedSize/VectorSpec.hs +82/−0
- test/Data/FixedSize/VolumeSpec.hs +32/−0
- test/Data/Utils/CacheSpec.hs +36/−0
- test/Spec.hs +1/−1
- test/Utils/MatrixSpec.hs +0/−71
- test/Utils/VectorSpec.hs +0/−57
.ghci view
@@ -1,1 +1,1 @@-:set -XDataKinds +m +s +t +:set -XDataKinds +m +s +t
.gitignore view
@@ -1,4 +1,6 @@-*.swp -.stack-work/ -dist/ -tags +*.swp+.stack-work/+dist/+tags+src/highlight.js+src/style.css
.travis.yml view
@@ -1,122 +1,40 @@-# Copy these contents into the root directory of your Github project in a file -# named .travis.yml - -# Use new container infrastructure to enable caching -sudo: false - -# Choose a lightweight base image; we provide our own build tools. -language: c - -# Caching so the next build will be fast too. -cache: - directories: - - $HOME/.ghc - - $HOME/.cabal - - $HOME/.stack - -# The different configurations we want to test. We have BUILD=cabal which uses -# cabal-install, and BUILD=stack which uses Stack. More documentation on each -# of those below. -# -# We set the compiler values here to tell Travis to use a different -# cache file per set of arguments. -# -# If you need to have different apt packages for each combination in the -# matrix, you can use a line such as: -# addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} -matrix: - include: - # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: - # https://github.com/hvr/multi-ghc-travis - - env: BUILD=cabal GHCVER=8.0.1 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC 8.0.1" - addons: {apt: {packages: [cabal-install-1.22,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS - # variable, such as using --stack-yaml to point to a different file. - - env: BUILD=stack ARGS="" - compiler: ": #stack default" - addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} - - - env: BUILD=stack ARGS="--resolver lts-5" - compiler: ": #stack 7.10.3" - addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} - - - env: BUILD=stack ARGS="--resolver nightly-2016-06-16" - compiler: ": #stack 8.0.1" - addons: {apt: {packages: [ghc-8.0.1], sources: [hvr-ghc]}} - -before_install: -# Using compiler above sets CC to an invalid value, so unset it -- unset CC - -# We want to always allow newer versions of packages when building on GHC HEAD -- CABALARGS="" -- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi - -# Download and unpack the stack executable -- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH -- mkdir -p ~/.local/bin -- | - if [ `uname` = "Darwin" ] - then - travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin - else - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - fi - - # Use the more reliable S3 mirror of Hackage - mkdir -p $HOME/.cabal - echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config - echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config - - if [ "$CABALVER" != "1.16" ] - then - echo 'jobs: $ncpus' >> $HOME/.cabal/config - fi - -# Get the list of packages from the stack.yaml file -- PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') - -install: -- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" -- if [ -f configure.ac ]; then autoreconf -i; fi -- | - set -ex - case "$BUILD" in - stack) - stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies - ;; - cabal) - cabal --version - travis_retry cabal update - cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES - ;; - esac - set +ex - -script: -- | - set -ex - case "$BUILD" in - stack) - stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps - ;; - cabal) - cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES - - ORIGDIR=$(pwd) - for dir in $PACKAGES - do - cd $dir - cabal check || [ "$CABALVER" == "1.16" ] - cabal sdist - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ - (cd dist && cabal install --force-reinstalls "$SRC_TGZ") - cd $ORIGDIR - done - ;; - esac - set +ex - -- stack --no-terminal --skip-ghc-check test +# This is the simple Travis configuration, which is intended for use+# on applications which do not require cross-platform and+# multiple-GHC-version support. For more information and other+# options, see:+#+# https://docs.haskellstack.org/en/stable/travis_ci/+#+# Copy these contents into the root directory of your Github project in a file+# named .travis.yml++# Use new container infrastructure to enable caching+sudo: false++# Do not choose a language; we provide our own build tools.+language: generic++# Caching so the next build will be fast too.+cache:+ directories:+ - $HOME/.stack++# Ensure necessary system libraries are present+addons:+ apt:+ packages:+ - libgmp-dev++before_install:+# Download and unpack the stack executable+- mkdir -p ~/.local/bin+- export PATH=$HOME/.local/bin:$PATH+- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'++install:+# Build dependencies+- stack --no-terminal --install-ghc test --only-dependencies++script:+# Build the package, its tests, and its docs and run the tests+- stack --no-terminal test --haddock --no-haddock-deps
LICENSE view
@@ -1,21 +1,21 @@-The MIT License (MIT) - -Copyright (c) 2016 Lars Brünjes - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. +The MIT License (MIT)++Copyright (c) 2016 Lars Brünjes++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
README.markdown view
@@ -1,46 +1,49 @@-# neural - Neural Nets in native Haskell - -[](https://travis-ci.org/brunjlar/neural) - -## Motivation - -The goal of this project is to provide a flexible framework for -[neural networks](https://en.wikipedia.org/wiki/Artificial_neural_network) -(and similar parameterized models) in Haskell. - -There are already a couple of neural network libraries out there on Hackage, but as far as I can tell, -they either - -- are wrappers for an engine written in another language or -- offer a limitted choice of network architectures, training algorithms or error functions - or are not easily extensible. - -The goal of this library is to have an implementation in native Haskell (reasonably efficient) -which offers maximal flexibility. - -Furthermore, [gradient descent/backpropagation](https://en.wikipedia.org/wiki/Backpropagation) should work automatically, using -[automatic differentiation](https://hackage.haskell.org/package/ad-4.3.2/docs/Numeric-AD.html). -This means that new and complicated activation functions and/or network architectures can be used without the need -to first calculate derivatives by hand. - -In order to provide a powerful and flexible API, models are constructed using *components* which behave as if they implemented the -[Arrow and ArrowChoice](https://hackage.haskell.org/package/base-4.9.0.0/docs/Control-Arrow.html) typeclasses. -They can therefore easily be combined and transformed. - -Once a model has been constructed, it can be hooked up into a customized training algorithm using [pipes](https://hackage.haskell.org/package/pipes), -so that various aspects of the algorithm (loading data, choosing random samples, reporting intermediate results, stop criterium etc.) can be defined in a modular, -decoupled way. - -Even though neural networks are the primary motivation for this project, any other kind of model can be -defined in the same framework, whenever the model depends on a collection of numerical parameters in a differentiable -way. - One simple example for this would be [linear regression](https://en.wikipedia.org/wiki/Linear_regression). - -## Examples - -At the moment, three examples are included: - -- [sqrt](examples/sqrt) models the regression problem of approximating the square root function on the interval [0,4]. - -- [iris](examples/iris) solves the famous [Iris Flower](https://en.wikipedia.org/wiki/Iris_flower_data_set) classification problem. - -- [MNIST](examples/MNIST) tackles the equally famous [MNIST](https://en.wikipedia.org/wiki/MNIST_database) problem of recognizing handwritten digits. +# neural - Neural Nets in native Haskell++[](https://travis-ci.org/brunjlar/neural)++## Motivation++The goal of this project is to provide a flexible framework for +[neural networks](https://en.wikipedia.org/wiki/Artificial_neural_network) +(and similar parameterized models) in Haskell.++There are already a couple of neural network libraries out there on Hackage, but as far as I can tell,+they either++- are wrappers for an engine written in another language or+- offer a limitted choice of network architectures, training algorithms or error functions+ or are not easily extensible.++The goal of this library is to have an implementation in native Haskell (reasonably efficient)+which offers maximal flexibility.++Furthermore, [gradient descent/backpropagation](https://en.wikipedia.org/wiki/Backpropagation) should work automatically, using+[automatic differentiation](https://hackage.haskell.org/package/ad-4.3.2/docs/Numeric-AD.html).+This means that new and complicated activation functions and/or network architectures can be used without the need+to first calculate derivatives by hand.++In order to provide a powerful and flexible API, models are constructed using *components* which behave as if they implemented the+[Arrow and ArrowChoice](https://hackage.haskell.org/package/base-4.9.0.0/docs/Control-Arrow.html) typeclasses. +They can therefore easily be combined and transformed.++Once a model has been constructed, it can be hooked up into a customized training algorithm using [pipes](https://hackage.haskell.org/package/pipes),+so that various aspects of the algorithm (loading data, choosing random samples, reporting intermediate results, stop criterium etc.) can be defined in a modular,+decoupled way.++Even though neural networks are the primary motivation for this project, any other kind of model can be+defined in the same framework, whenever the model depends on a collection of numerical parameters in a differentiable+way. - One simple example for this would be [linear regression](https://en.wikipedia.org/wiki/Linear_regression).++## Examples++At the moment, four [examples](examples) are included:++- [sin](examples/sin) models the regression problem of approximating the sine function on the interval [0,2 pi].++- [sqrt](examples/sqrt) models the similar regression problem of approximating the square root function+on the interval [0,4].++- [iris](examples/iris) solves the famous [Iris Flower](https://en.wikipedia.org/wiki/Iris_flower_data_set) classification problem.++- [MNIST](examples/MNIST) tackles the equally famous [MNIST](https://en.wikipedia.org/wiki/MNIST_database) problem of recognizing handwritten digits.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
benchmark/benchmark.hs view
@@ -1,79 +1,79 @@-{-# LANGUAGE DataKinds #-} -{-# LANGUAGE BangPatterns #-} - -module Main where - -import Control.Category -import Criterion.Main -import Data.MyPrelude -import Data.Utils -import Data.Void -import Numeric.Neural -import Prelude hiding (id, (.)) - -main :: IO () -main = defaultMain - [ bgroup "white" - [ bench "10/200" $ whnf (w 10) 200 - , bench "10/2000" $ whnf (w 10) 2000 - , bench "10/20000" $ whnf (w 10) 20000 - , bench "100/200" $ whnf (w 100) 200 - , bench "100/2000" $ whnf (w 100) 2000 - , bench "100/20000" $ whnf (w 100) 20000 - , bench "1000/200" $ whnf (w 1000) 200 - , bench "1000/2000" $ whnf (w 1000) 2000 - , bench "1000/20000" $ whnf (w 1000) 20000 - ] - , env setupEnv $ \ ~(m, xss) -> bgroup "linear" - [ l m xss 1 5 - , l m xss 5 5 - , l m xss 10 5 - ] - ] - -w :: Int -> Int -> Double -w sampleCount testCount = flip evalRand (mkStdGen 123456) $ do - stats <- mkStats' - samples <- replicateM sampleCount $ mkSample stats - let m = whiten model' samples - xss <- replicateM testCount $ mkSample stats - return $ sum [model m xs | xs <- xss] - - where - - mkStats' :: MonadRandom m => m (Vector Width (Double, Double)) - mkStats' = sequenceA (pure $ (,) <$> getRandomR (-100, 100) <*> getRandomR (0.1, 20)) - - mkSample :: MonadRandom m => Vector Width (Double, Double) -> m (Vector Width Double) - mkSample = mapM $ uncurry boxMuller' - - model' :: Model (Vector Width) Identity Void (Vector Width Double) Double - model' = Model (cArr $ Diff $ Identity . sum) absurd id runIdentity - -type Width = 10 - -l :: M -> [Vector Width' Double] -> Int -> Int -> Benchmark -l m xss batchSize steps = bench (printf "%d/%d" batchSize steps) $ whnf l' steps where - - l' :: Int -> Double - l' steps' = - let m' = loop steps' m - xs = pure 0 - in modelError m' [(xs, xs)] - - loop :: Int -> M -> M - loop 0 m' = m' - loop !n m' = - let m'' = m' `deepseq` snd $ descent m' 0.01 [(xs, xs) | xs <- take batchSize xss] - in loop (pred n) m'' - -setupEnv :: IO (M, [Vector Width' Double]) -setupEnv = return $ flip evalRand (mkStdGen 987654) $ do - let e xs = Diff $ Identity . sqDiff (fromDouble <$> xs) - m <- modelR $ mkStdModel linearLayer e id id - xss <- replicateM 100 $ let r = getRandomR (-5, 5) in sequence $ pure r - return (m, xss) - -type M = StdModel (Vector Width') (Vector Width') (Vector Width' Double) (Vector Width' Double) - -type Width' = 100 +{-# LANGUAGE DataKinds #-}+{-# LANGUAGE BangPatterns #-}++module Main where++import Control.Category+import Criterion.Main+import Data.MyPrelude+import Data.Utils+import Data.Void+import Numeric.Neural+import Prelude hiding (id, (.))++main :: IO ()+main = defaultMain + [ bgroup "white" + [ bench "10/200" $ whnf (w 10) 200+ , bench "10/2000" $ whnf (w 10) 2000+ , bench "10/20000" $ whnf (w 10) 20000+ , bench "100/200" $ whnf (w 100) 200+ , bench "100/2000" $ whnf (w 100) 2000+ , bench "100/20000" $ whnf (w 100) 20000+ , bench "1000/200" $ whnf (w 1000) 200+ , bench "1000/2000" $ whnf (w 1000) 2000+ , bench "1000/20000" $ whnf (w 1000) 20000+ ]+ , env setupEnv $ \ ~(m, xss) -> bgroup "linear"+ [ l m xss 1 5 + , l m xss 5 5+ , l m xss 10 5+ ]+ ]++w :: Int -> Int -> Double+w sampleCount testCount = flip evalRand (mkStdGen 123456) $ do+ stats <- mkStats'+ samples <- replicateM sampleCount $ mkSample stats+ let m = whiten model' samples+ xss <- replicateM testCount $ mkSample stats+ return $ sum [model m xs | xs <- xss]++ where++ mkStats' :: MonadRandom m => m (Vector Width (Double, Double))+ mkStats' = sequenceA (pure $ (,) <$> getRandomR (-100, 100) <*> getRandomR (0.1, 20))++ mkSample :: MonadRandom m => Vector Width (Double, Double) -> m (Vector Width Double)+ mkSample = mapM $ uncurry boxMuller'++ model' :: Model (Vector Width) Identity Void (Vector Width Double) Double+ model' = Model (cArr $ Diff $ Identity . sum) absurd id runIdentity++type Width = 10++l :: M -> [Vector Width' Double] -> Int -> Int -> Benchmark+l m xss batchSize steps = bench (printf "%d/%d" batchSize steps) $ whnf l' steps where++ l' :: Int -> Double+ l' steps' = + let m' = loop steps' m + xs = pure 0+ in modelError m' [(xs, xs)]++ loop :: Int -> M -> M+ loop 0 m' = m'+ loop !n m' =+ let m'' = m' `deepseq` snd $ descent m' 0.01 [(xs, xs) | xs <- take batchSize xss]+ in loop (pred n) m''++setupEnv :: IO (M, [Vector Width' Double])+setupEnv = return $ flip evalRand (mkStdGen 987654) $ do+ let e xs = Diff $ Identity . sqDiff (fromDouble <$> xs)+ m <- modelR $ mkStdModel linearLayer e id id+ xss <- replicateM 100 $ let r = getRandomR (-5, 5) in sequence $ pure r+ return (m, xss)++type M = StdModel (Vector Width') (Vector Width') (Vector Width' Double) (Vector Width' Double)++type Width' = 100
doctest/doctest.hs view
@@ -1,10 +1,10 @@-module Main (main) where - -import System.FilePath.Glob (glob) -import Test.DocTest (doctest) - -main :: IO () -main = do - glob "src/**/*.hs" >>= doctest - glob "examples/iris/**/*.hs" >>= doctest - glob "examples/sqrt/**/*.hs" >>= doctest +module Main (main) where++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = do+ glob "src/**/*.hs" >>= doctest+ glob "examples/iris/**/*.hs" >>= doctest+ glob "examples/sqrt/**/*.hs" >>= doctest
examples/MNIST/MNIST.hs view
@@ -1,89 +1,92 @@-{-# LANGUAGE DataKinds #-} - -module Main where - -import Codec.Picture -import Control.Category -import qualified Data.Array as A -import Data.MyPrelude -import Data.Utils -import Numeric.Neural -import Pipes.GZip (decompress) -import qualified Pipes.Prelude as P -import Prelude hiding (id, (.)) - -main :: IO () -main = do - xs <- runSafeT $ P.toListM (trainSamples >-> P.take 1000) - printf "loaded %d train samples\n" (length xs) - ys <- runSafeT $ P.toListM (testSamples >-> P.take 500) - printf "loaded %d test samples\n" (length ys) - flip evalRandT (mkStdGen 999999) $ do - xs' <- takeR 100 $ fst <$> xs - m <- modelR (whiten mnistModel xs') - runEffect $ - simpleBatchP xs 20 - >-> descentP m 1 (const 0.1) - >-> reportTSP 1 report - >-> consumeTSP (check ys) - - where - - report ts = liftIO $ printf "%7d %8.6f %10.8f\n" (tsGeneration ts) (tsEta ts) (tsBatchError ts) - - check ys ts = - if tsGeneration ts `mod` 25 == 0 - then do - let a = accuracy (tsModel ts) ys :: Double - liftIO $ printf "\naccuracy %f\n\n" a - return Nothing - else return Nothing - - correct m (img, d) = model m img == d - - accuracy m ys = let c = length $ filter (correct m) ys - in fromIntegral c / fromIntegral (length ys) - -type Img = Image Pixel8 - -data Digit = Zero | One | Two | Three | Four | Five | Six | Seven | Eight | Nine - deriving (Show, Read, Eq, Ord, Enum, Bounded) - -type Sample = (Img, Digit) - -trainImagesFile, trainLabelsFile, testImagesFile, testLabelsFile :: FilePath -trainImagesFile = "examples" </> "MNIST" </> "train-images-idx3-ubyte" <.> "gz" -trainLabelsFile = "examples" </> "MNIST" </> "train-labels-idx1-ubyte" <.> "gz" -testImagesFile = "examples" </> "MNIST" </> "t10k-images-idx3-ubyte" <.> "gz" -testLabelsFile = "examples" </> "MNIST" </> "t10k-labels-idx1-ubyte" <.> "gz" - -bytes :: MonadSafe m => FilePath -> Producer Word8 m () -bytes f = decompress (fromFile f) >-> toWord8 - -labels :: MonadSafe m => FilePath -> Producer Digit m () -labels f = bytes f >-> P.drop 8 >-> P.map (toEnum . fromIntegral) - -images :: MonadSafe m => FilePath -> Producer Img m () -images f = bytes f >-> P.drop 16 >-> chunks (28 * 28) >-> P.map g - - where - - g xs = let a = A.listArray ((0, 0), (27, 27)) xs - in generateImage (\x y -> 255 - a A.! (y, x)) 28 28 - -trainSamples, testSamples :: MonadSafe m => Producer Sample m () -trainSamples = P.zip (images trainImagesFile) (labels trainLabelsFile) -testSamples = P.zip (images testImagesFile) (labels testLabelsFile) - -writeImg :: MonadIO m => FilePath -> Img -> m () -writeImg f i = liftIO $ saveTiffImage (f <.> "tiff") (ImageY8 i) - -mnistModel :: Classifier (Matrix 28 28) 10 Img Digit -mnistModel = mkStdClassifier c i where - - c = tanhLayer . (tanhLayer :: Layer 784 10) . cArr f - - i img = let m = mgenerate $ \(x, y) -> fromIntegral (pixelAt img x y) in force m - - f :: Diff (Matrix 28 28) (Vector 784) - f = Diff $ \m -> generate $ \w -> m !!! (w `mod` 28, w `div` 28) +{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Main where++import Codec.Picture+import Control.Category+import qualified Data.Array as A+import Data.MyPrelude+import Data.Utils+import Numeric.Neural+import Pipes.GZip (decompress)+import qualified Pipes.Prelude as P+import Prelude hiding (id, (.))++main :: IO ()+main = flip evalRandT (mkStdGen 999999) $ do+ xs <- getSamples [0 .. 999]+ m <- modelR (whiten mnistModel $ fst <$> xs)+ liftIO $ printf "generation learning rate batch error\n\n"+ (a, g) <- runEffect $+ cachingBatchP getSamples 60000 20 2000 100+ >-> descentP m 1 (\g -> 0.4 * 100 / (100 + fromIntegral g))+ >-> reportTSP 1 report+ >-> consumeTSP check+ liftIO $ printf "\nreached accuracy of %f after %d generations\n" a g++ where++ getSamples xs = liftIO $ runSafeT $ P.toListM $ trainSamples >-> indicesP xs++ report ts = liftIO $ do+ let g = tsGeneration ts+ when (g `mod` 5 == 0) $ printf " %7d %8.6f %10.8f\n" g (tsEta ts) (tsBatchError ts)++ check ts = do+ let g = tsGeneration ts+ if g `mod` 50 == 0+ then do+ a <- liftIO $ accuracy $ tsModel ts+ liftIO $ printf "\naccuracy %f\n\n" a+ return $ if a > 0.9 then Just (a, g) else Nothing+ else return Nothing++accuracy :: MNISTModel -> IO Double+accuracy m = runSafeT $ fromJust <$> classifierAccuracyP m testSamples++type Img = Image Pixel8++data Digit = Zero | One | Two | Three | Four | Five | Six | Seven | Eight | Nine+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++type Sample = (Img, Digit)++trainImagesFile, trainLabelsFile, testImagesFile, testLabelsFile :: FilePath+trainImagesFile = "examples" </> "MNIST" </> "train-images-idx3-ubyte" <.> "gz"+trainLabelsFile = "examples" </> "MNIST" </> "train-labels-idx1-ubyte" <.> "gz"+testImagesFile = "examples" </> "MNIST" </> "t10k-images-idx3-ubyte" <.> "gz"+testLabelsFile = "examples" </> "MNIST" </> "t10k-labels-idx1-ubyte" <.> "gz"++bytes :: MonadSafe m => FilePath -> Producer Word8 m ()+bytes f = decompress (fromFile f) >-> toWord8++labels :: MonadSafe m => FilePath -> Producer Digit m ()+labels f = bytes f >-> P.drop 8 >-> P.map (toEnum . fromIntegral)++images :: MonadSafe m => FilePath -> Producer Img m ()+images f = bytes f >-> P.drop 16 >-> chunks (28 * 28) >-> P.map g++ where++ g xs = let a = A.listArray ((0, 0), (27, 27)) xs+ in generateImage (\x y -> 255 - a A.! (y, x)) 28 28++trainSamples, testSamples :: MonadSafe m => Producer Sample m ()+trainSamples = P.zip (images trainImagesFile) (labels trainLabelsFile)+testSamples = P.zip (images testImagesFile) (labels testLabelsFile)++writeImg :: MonadIO m => FilePath -> Img -> m ()+writeImg f i = liftIO $ saveTiffImage (f <.> "tiff") (ImageY8 i)++type MNISTModel = Classifier (Matrix 28 28) 10 Img Digit++mnistModel :: MNISTModel+mnistModel = mkStdClassifier c i where++ c = tanhLayer' . (tanhLayer' :: Layer 784 30) . cArr f++ i img = let m = generate $ \(x, y) -> fromIntegral (pixelAt img x y) in force m++ f :: Diff (Matrix 28 28) (Vector 784)+ f = Diff $ \m -> generate $ \w -> m ! (w `mod` 28, w `div` 28)
examples/iris/iris.hs view
@@ -1,79 +1,77 @@-{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DataKinds #-} - -module Main where - -import Control.Applicative -import Control.Arrow hiding (loop) -import Data.Attoparsec.Text -import qualified Data.Text as T -import Data.MyPrelude -import Numeric.Neural -import Data.Utils - -main :: IO () -main = do - xs <- readSamples - printf "read %d samples\n\n" (length xs) - printf "generation learning rate model error accuracy\n\n" - (g, q) <- flip evalRandT (mkStdGen 123456) $ do - m <- modelR (whiten irisModel $ fst <$> xs) - runEffect $ - simpleBatchP xs 5 - >-> descentP m 1 (\i -> 0.1 * 5000 / (5000 + fromIntegral i)) - >-> reportTSP 1000 (report xs) - >-> consumeTSP (check xs) - printf "\nreached prediction accuracy of %5.3f after %d generations\n" q g - - where - - report xs ts = liftIO $ - printf "%10d %14.4f %12.6f %9.4f\n" (tsGeneration ts) (tsEta ts) (modelError (tsModel ts) xs) (getQuota xs ts) - - check xs ts = return $ - let g = tsGeneration ts - q = getQuota xs ts - in if g `mod` 100 == 0 && q >= 0.99 - then Just (g, q) - else Nothing - - getQuota xs ts = - let ys = map (model $ tsModel ts) $ fst <$> xs :: [Iris] - n = length $ filter (uncurry (==)) $ zip ys $ snd <$> xs - q = fromIntegral n / fromIntegral (length xs) :: Double - in q - -data Iris = Setosa | Versicolor | Virginica deriving (Show, Read, Eq, Ord, Enum) - -data Attributes = Attributes Double Double Double Double deriving (Show, Read, Eq, Ord) - -type Sample = (Attributes, Iris) - -sampleParser :: Parser Sample -sampleParser = f <$> (double <* char ',') - <*> (double <* char ',') - <*> (double <* char ',') - <*> (double <* char ',') - <*> irisParser - where - - f sl sw pl pw i = (Attributes sl sw pl pw, i) - - irisParser :: Parser Iris - irisParser = string "Iris-setosa" *> return Setosa - <|> string "Iris-versicolor" *> return Versicolor - <|> string "Iris-virginica" *> return Virginica - -readSamples :: IO [Sample] -readSamples = do - ls <- T.lines . T.pack <$> readFile ("examples" </> "iris" </> "data" <.> "csv") - return $ f <$> ls - - where - - f l = let Right x = parseOnly sampleParser l in x - -irisModel :: Classifier (Vector 4) 3 Attributes Iris -irisModel = mkStdClassifier - ((tanhLayer :: Layer 4 2) >>> tanhLayer) - (\(Attributes sl sw pl pw) -> cons sl (cons sw (cons pl (cons pw nil)))) +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}++module Main where++import Control.Applicative+import Control.Arrow hiding (loop)+import Data.Attoparsec.Text+import qualified Data.Text as T+import Data.MyPrelude+import Numeric.Neural+import Data.Utils++main :: IO ()+main = do+ xs <- readSamples+ printf "read %d samples\n\n" (length xs)+ printf "generation learning rate model error accuracy\n\n"+ (g, q) <- flip evalRandT (mkStdGen 123456) $ do+ m <- modelR (whiten irisModel $ fst <$> xs)+ runEffect $+ simpleBatchP xs 5+ >-> descentP m 1 (\i -> 0.1 * 5000 / (5000 + fromIntegral i))+ >-> reportTSP 1000 (report xs)+ >-> consumeTSP (check xs)+ printf "\nreached prediction accuracy of %5.3f after %d generations\n" q g++ where++ report xs ts = liftIO $ + printf "%10d %14.4f %12.6f %9.4f\n" (tsGeneration ts) (tsEta ts) (modelError (tsModel ts) xs) (accuracy xs ts)++ check xs ts = return $+ let g = tsGeneration ts+ q = accuracy xs ts+ in if g `mod` 100 == 0 && q >= 0.99+ then Just (g, q)+ else Nothing++ accuracy xs ts = fromJust $ classifierAccuracyP' (tsModel ts) xs :: Double++data Iris = Setosa | Versicolor | Virginica deriving (Show, Read, Eq, Ord, Enum)++data Attributes = Attributes Double Double Double Double deriving (Show, Read, Eq, Ord)++type Sample = (Attributes, Iris)++sampleParser :: Parser Sample+sampleParser = f <$> (double <* char ',')+ <*> (double <* char ',')+ <*> (double <* char ',')+ <*> (double <* char ',')+ <*> irisParser+ where + + f sl sw pl pw i = (Attributes sl sw pl pw, i)++ irisParser :: Parser Iris+ irisParser = string "Iris-setosa" *> return Setosa+ <|> string "Iris-versicolor" *> return Versicolor+ <|> string "Iris-virginica" *> return Virginica++readSamples :: IO [Sample]+readSamples = do+ ls <- T.lines . T.pack <$> readFile ("examples" </> "iris" </> "data" <.> "csv")+ return $ f <$> ls++ where++ f l = let Right x = parseOnly sampleParser l in x++type IrisModel = Classifier (Vector 4) 3 Attributes Iris++irisModel :: IrisModel+irisModel = mkStdClassifier+ ((tanhLayer :: Layer 4 2) >>> tanhLayer)+ (\(Attributes sl sw pl pw) -> cons sl (cons sw (cons pl (cons pw nil))))
+ examples/sin/Graph.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Graph where++import Control.Monad+import Control.Monad.ST (ST, runST)+import qualified Data.Array.Unboxed as U+import qualified Data.Array.ST as ST++graph :: (Double -> Double) -> Double -> Double -> Int -> Int -> IO ()+graph f xMin xMax height width = do+ let a = array+ forM_ [1..height] $ \y -> do+ forM_ [1..width] $ \x -> putChar (a U.! (y, x))+ putChar '\n'++ where++ array :: U.UArray (Int, Int) Char+ array = runST $ do+ a <- ST.newArray ((1, 1), (height, width)) ' ' :: forall s. ST s (ST.STUArray s (Int, Int) Char)+ let dx = (xMax - xMin) / fromIntegral (pred width)+ xys = [let x = xMin + fromIntegral j * dx in (x, f x) | j <- [0 .. pred width]]+ ys = snd <$> xys+ yMin = minimum ys+ yMax = maximum ys+ x_to_j x = round $ (x - xMin) / (xMax - xMin) * fromIntegral (pred width) + 1+ j_to_x j = xMin + dx * fromIntegral (pred j)+ y_to_i y = height - round ((y - yMin) / (yMax - yMin) * fromIntegral (pred height))++ draw a x_to_j j_to_x y_to_i+ ST.freeze a++ where++ draw :: forall s. ST.STUArray s (Int, Int) Char -> (Double -> Int) -> (Int -> Double) -> (Double -> Int) -> ST s ()+ draw a x_to_j j_to_x y_to_i = drawXAxis >> drawYAxis >> drawGraph++ where++ drawXAxis :: ST s ()+ drawXAxis = do+ let i = y_to_i 0+ when (i >= 1 && i <= height) $+ forM_ [1..width] $ \j -> ST.writeArray a (i, j) '-'++ drawYAxis :: ST s ()+ drawYAxis = do+ let j = x_to_j 0+ when (j >= 1 && j <= width) $+ forM_ [1..height] $ \i -> ST.writeArray a (i, j) '-'++ drawGraph :: ST s ()+ drawGraph = forM_ [1..width] $ \j -> do+ let x = j_to_x j+ y = f x+ i = y_to_i y+ ST.writeArray a (i, j) '*'
+ examples/sin/sin.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DataKinds #-}++import Control.Category+import Control.Monad.Random+import Data.MyPrelude+import Data.Utils+import Graph+import Numeric.Neural+import qualified System.Console.ANSI as ANSI+import Prelude hiding ((.))++main :: IO ()+main = flip evalRandT (mkStdGen 739570) $ do+ let xs = [0, 0.01 .. 2 * pi]+ m <- modelR $ whiten sinModel xs+ runEffect $+ simpleBatchP [(x, sin x) | x <- xs] 10+ >-> descentP m 1 (const 0.5)+ >-> reportTSP 50 report+ >-> consumeTSP check++ where++ sinModel :: StdModel (Vector 1) (Vector 1) Double Double+ sinModel = mkStdModel+ (tanhLayer . (tanhLayer :: Layer 1 4))+ (\x -> Diff $ Identity . sqDiff (pure $ fromDouble x))+ pure+ vhead++ getError ts =+ let m = tsModel ts+ in maximum [abs (sin x - model m x) | x <- [0, 0.1 .. 2 * pi]]++ report ts = liftIO $ do+ ANSI.clearScreen+ ANSI.setSGR [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red]+ ANSI.setCursorPosition 0 0+ printf "Generation %d\n" (tsGeneration ts)+ ANSI.setSGR [ANSI.Reset]+ graph (model (tsModel ts)) 0 (2 * pi) 20 50++ check ts = return $ if getError ts < 0.1 then Just () else Nothing
examples/sqrt/sqrt.hs view
@@ -1,50 +1,50 @@-{-# LANGUAGE DataKinds #-} - -module Main where - -import Control.Category -import Control.Monad.Random -import Data.MyPrelude -import Data.Utils -import Numeric.Neural -import Prelude hiding (id, (.)) - -main :: IO () -main = do - putStrLn "generation batch error model error\n" - m <- flip evalRandT (mkStdGen 691245) $ do - m <- modelR sqrtModel - runEffect $ - simpleBatchP [(x, sqrt x) | x <- [0, 0.001 .. 4]] 10 - >-> descentP m 1 (const 0.03) - >-> reportTSP 100 report - >-> consumeTSP check - - putStrLn " x sqrt x predicted error\n" - forM_ [0 :: Double, 0.1 .. 4] $ \x -> do - let y' = model m x - y = sqrt x - e = abs (y - y') - printf "%3.1f %10.8f %10.8f %10.8f\n" x y y' e - - where - - sqrtModel :: StdModel (Vector 1) (Vector 1) Double Double - sqrtModel = mkStdModel - (linearLayer . (tanhLayer :: Layer 1 2)) - (\x -> Diff $ Identity . sqDiff (pure $ fromDouble x)) - pure - vhead - - getErr ts = let m = tsModel ts in mean [abs (sqrt x - model m x) | x <- [0, 0.1 .. 4]] - - report ts = do - let e = getErr ts - liftIO $ printf " %6d %10.8f %10.8f\n" (tsGeneration ts) (tsBatchError ts) e - - check ts = do - let e = getErr ts - if e < 0.015 then do - liftIO $ printf "\nmodel error after %d generations: %f\n\n" (tsGeneration ts) e - return $ Just (tsModel ts) - else return Nothing +{-# LANGUAGE DataKinds #-}++module Main where++import Control.Category +import Control.Monad.Random+import Data.MyPrelude+import Data.Utils+import Numeric.Neural+import Prelude hiding (id, (.))++main :: IO ()+main = do+ putStrLn "generation batch error model error\n"+ m <- flip evalRandT (mkStdGen 691245) $ do+ m <- modelR sqrtModel+ runEffect $+ simpleBatchP [(x, sqrt x) | x <- [0, 0.001 .. 4]] 10+ >-> descentP m 1 (const 0.03) + >-> reportTSP 100 report+ >-> consumeTSP check+ + putStrLn " x sqrt x predicted error\n"+ forM_ [0 :: Double, 0.1 .. 4] $ \x -> do+ let y' = model m x+ y = sqrt x+ e = abs (y - y')+ printf "%3.1f %10.8f %10.8f %10.8f\n" x y y' e++ where++ sqrtModel :: StdModel (Vector 1) (Vector 1) Double Double+ sqrtModel = mkStdModel+ (linearLayer . (tanhLayer :: Layer 1 2))+ (\x -> Diff $ Identity . sqDiff (pure $ fromDouble x))+ pure + vhead++ getErr ts = let m = tsModel ts in mean [abs (sqrt x - model m x) | x <- [0, 0.1 .. 4]]++ report ts = do+ let e = getErr ts+ liftIO $ printf " %6d %10.8f %10.8f\n" (tsGeneration ts) (tsBatchError ts) e++ check ts = do+ let e = getErr ts+ if e < 0.015 then do+ liftIO $ printf "\nmodel error after %d generations: %f\n\n" (tsGeneration ts) e+ return $ Just (tsModel ts)+ else return Nothing
neural.cabal view
@@ -1,175 +1,195 @@-name: neural-version: 0.3.0.0-cabal-version: >=1.10-build-type: Simple-license: MIT-license-file: LICENSE-copyright: Copyright: (c) 2016 Lars Bruenjes-maintainer: brunjlar@gmail.com-stability: provisional-homepage: https://github.com/brunjlar/neural-bug-reports: https://github.com/brunjlar/neural/issues-synopsis: Neural Networks in native Haskell+name: neural+version: 0.3.0.1+synopsis: Neural Networks in native Haskell description:- The goal of `neural` is to provide a modular and flexible neural network library written in native Haskell.- .- Features include- .- * /composability/ via arrow-like instances and+ The goal of `neural` is to provide a modular and flexible neural network library written in native Haskell.+ .+ Features include+ .+ * /composability/ via arrow-like instances and <https://hackage.haskell.org/package/pipes pipes>,- .- * /automatic differentiation/ for automatic gradient descent/ backpropagation training+ .+ * /automatic differentiation/ for automatic gradient descent/ backpropagation training (using Edward Kmett's fabulous <https://hackage.haskell.org/package/ad ad> library).- .- The idea is to be able to easily define new components and wire them up in flexible, possibly- complicated ways (convolutional deep networks etc.).- .- Three examples are included as proof of concept:- .- * A simple neural network that approximates the sqrt function on [0,4].- .- * A slightly more complicated neural network that solves the famous+ .+ The idea is to be able to easily define new components and wire them up in flexible, possibly+ complicated ways (convolutional deep networks etc.).+ .+ Four examples are included as proof of concept:+ .+ * A simple neural network that approximates the sine function on [0,2 pi].+ .+ * Another simple neural network that approximates the sqrt function on [0,4].+ .+ * A slightly more complicated neural network that solves the famous <https://en.wikipedia.org/wiki/Iris_flower_data_set Iris flower> problem.- .- * A first (still simple) neural network for recognizing handwritten digits from the equally famous+ .+ * A first (still simple) neural network for recognizing handwritten digits from the equally famous <https://en.wikipedia.org/wiki/MNIST_database MNIST> database.- .- The library is still very much experimental at this point.-category: Machine Learning-author: Lars Bruenjes-tested-with: GHC ==7.10.3 GHC ==8.0.1-extra-source-files:- .travis.yml- .gitignore- .ghci- stack.yaml- README.markdown+ .+ The library is still very much experimental at this point. -source-repository head- type: git- location: https://github.com/brunjlar/neural.git+extra-source-files:+ .travis.yml+ .gitignore+ .ghci+ stack.yaml+ README.markdown -source-repository this- type: git- location: https://github.com/brunjlar/neural.git- tag: 0.3.0.0+homepage: https://github.com/brunjlar/neural+bug-reports: https://github.com/brunjlar/neural/issues+license: MIT+license-file: LICENSE+author: Lars Bruenjes+maintainer: brunjlar@gmail.com+copyright: Copyright: (c) 2016 Lars Bruenjes+category: Machine Learning+build-type: Simple+cabal-version: >=1.10+stability: provisional+tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2 library- exposed-modules:- Numeric.Neural- Numeric.Neural.Layer- Numeric.Neural.Model- Numeric.Neural.Normalization- Numeric.Neural.Pipes- Data.MyPrelude- Data.Utils- Data.Utils.Analytic- Data.Utils.Arrow- Data.Utils.List- Data.Utils.Matrix- Data.Utils.Pipes- Data.Utils.Random- Data.Utils.Stack- Data.Utils.Statistics- Data.Utils.Traversable- Data.Utils.Vector- build-depends:- base >=4.7 && <5,- ad >=4.3.2.1 && <4.4,- array >=0.5.1.1 && <0.6,- bytestring >=0.10.8.1 && <0.11,- deepseq >=1.4.2.0 && <1.5,- directory >=1.2.6.2 && <1.3,- filepath >=1.4.1.0 && <1.5,- ghc-typelits-natnormalise >=0.4.1 && <0.5,- hspec >=2.2.3 && <2.3,- kan-extensions >=5.0.1 && <5.1,- lens ==4.14.*,- MonadRandom >=0.4.2.3 && <0.5,- monad-par >=0.3.4.7 && <0.4,- monad-par-extras >=0.3.3 && <0.4,- mtl >=2.2.1 && <2.3,- parallel >=3.2.1.0 && <3.3,- pipes >=4.1.9 && <4.2,- pipes-bytestring >=2.1.3 && <2.2,- pipes-safe >=2.2.4 && <2.3,- profunctors ==5.2.*,- reflection >=2.1.2 && <2.2,- STMonadTrans >=0.3.3 && <0.4,- text >=1.2.2.1 && <1.3,- transformers >=0.5.2.0 && <0.6,- typelits-witnesses >=0.2.3.0 && <0.3,- vector >=0.11.0.0 && <0.12- default-language: Haskell2010- hs-source-dirs: src- ghc-options: -Wall -fexcess-precision -optc-O3 -optc-ffast-math+ hs-source-dirs: src+ exposed-modules: Numeric.Neural+ , Numeric.Neural.Convolution+ , Numeric.Neural.Layer+ , Numeric.Neural.Model+ , Numeric.Neural.Normalization+ , Numeric.Neural.Pipes+ , Data.FixedSize+ , Data.FixedSize.Class+ , Data.FixedSize.Matrix+ , Data.FixedSize.Vector+ , Data.FixedSize.Volume+ , Data.MyPrelude+ , Data.Utils+ , Data.Utils.Analytic+ , Data.Utils.Arrow+ , Data.Utils.Cache+ , Data.Utils.List+ , Data.Utils.Pipes+ , Data.Utils.Random+ , Data.Utils.Stack+ , Data.Utils.Statistics+ , Data.Utils.Traversable+ other-modules:+ ghc-options: -Wall -fexcess-precision -optc-O3 -optc-ffast-math+ build-depends: base >= 4.7 && < 5+ , ad+ , array+ , bytestring+ , containers+ , deepseq+ , directory+ , filepath+ , ghc-typelits-natnormalise+ , hspec+ , kan-extensions+ , lens+ , MonadRandom+ , monad-par+ , monad-par-extras+ , mtl+ , parallel+ , pipes+ , pipes-bytestring+ , pipes-safe+ , profunctors+ , random+ , reflection+ , STMonadTrans+ , text+ , transformers+ , typelits-witnesses+ , vector+ , vector-sized+ default-language: Haskell2010 +test-suite neural-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base >= 4.7 && < 5+ , hspec+ , MonadRandom+ , neural+ other-modules: Data.Utils.CacheSpec+ , Data.FixedSize.ClassSpec+ , Data.FixedSize.MatrixSpec+ , Data.FixedSize.VectorSpec+ , Data.FixedSize.VolumeSpec+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math+ default-language: Haskell2010++test-suite neural-doctest+ type: exitcode-stdio-1.0+ hs-source-dirs: doctest+ main-is: doctest.hs+ build-depends: base >= 4.7 && < 5+ , doctest+ , Glob+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math+ default-language: Haskell2010++benchmark neural-bench+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmark+ main-is: benchmark.hs+ build-depends: base >= 4.7 && < 5+ , criterion+ , neural+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math+ default-language: Haskell2010+ executable iris- main-is: iris.hs- build-depends:- base >=4.7 && <5,- attoparsec >=0.13.0.2 && <0.14,- neural >=0.3.0.0 && <0.4,- text >=1.2.2.1 && <1.3- default-language: Haskell2010- hs-source-dirs: examples/iris- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math+ hs-source-dirs: examples/iris+ main-is: iris.hs+ build-depends: base >= 4.7 && < 5+ , attoparsec+ , neural+ , text+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math+ default-language: Haskell2010 +executable sin+ hs-source-dirs: examples/sin+ main-is: sin.hs+ other-modules: Graph+ build-depends: base >= 4.7 && < 5+ , ansi-terminal+ , array+ , neural+ , MonadRandom+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math+ default-language: Haskell2010+ executable sqrt- main-is: sqrt.hs- build-depends:- base >=4.7 && <5,- MonadRandom >=0.4.2.3 && <0.5,- neural >=0.3.0.0 && <0.4- default-language: Haskell2010- hs-source-dirs: examples/sqrt- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math+ hs-source-dirs: examples/sqrt+ main-is: sqrt.hs+ build-depends: base >= 4.7 && < 5+ , MonadRandom+ , neural+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math+ default-language: Haskell2010 executable MNIST- main-is: MNIST.hs- build-depends:- base >=4.7 && <5,- array >=0.5.1.1 && <0.6,- JuicyPixels >=3.2.7.1 && <3.3,- neural >=0.3.0.0 && <0.4,- pipes >=4.1.9 && <4.2,- pipes-zlib >=0.4.4 && <0.5- default-language: Haskell2010- hs-source-dirs: examples/MNIST- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math+ hs-source-dirs: examples/MNIST+ main-is: MNIST.hs+ build-depends: base >= 4.7 && < 5+ , array+ , JuicyPixels+ , neural+ , pipes+ , pipes-zlib+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math+ default-language: Haskell2010 -test-suite neural-test- type: exitcode-stdio-1.0- main-is: Spec.hs- build-depends:- base >=4.7 && <5,- hspec >=2.2.3 && <2.3,- MonadRandom >=0.4.2.3 && <0.5,- neural >=0.3.0.0 && <0.4- default-language: Haskell2010- hs-source-dirs: test- other-modules:- Utils.MatrixSpec- Utils.VectorSpec- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math-test-suite neural-doctest- type: exitcode-stdio-1.0- main-is: doctest.hs- build-depends:- base >=4.7 && <5,- doctest >=0.11.0 && <0.12,- Glob >=0.7.5 && <0.8- default-language: Haskell2010- hs-source-dirs: doctest- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math+source-repository head+ type: git+ location: https://github.com/brunjlar/neural.git -benchmark neural-bench- type: exitcode-stdio-1.0- main-is: benchmark.hs- build-depends:- base >=4.7 && <5,- criterion >=1.1.1.0 && <1.2,- neural >=0.3.0.0 && <0.4- default-language: Haskell2010- hs-source-dirs: benchmark- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math+source-repository this+ type: git+ location: https://github.com/brunjlar/neural.git+ tag: 0.3.0.1
+ src/Data/FixedSize.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-|+Module : Data.FixedSize+Description : fixed-size containers+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module provides some fixed-size containers.+-}++module Data.FixedSize+ ( module Data.FixedSize.Class+ , module Data.FixedSize.Matrix+ , module Data.FixedSize.Vector+ , module Data.FixedSize.Volume+ ) where++import Data.FixedSize.Class+import Data.FixedSize.Matrix+import Data.FixedSize.Vector+import Data.FixedSize.Volume
+ src/Data/FixedSize/Class.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}++{-|+Module : Data.FixedSize.Class+Description : class definitions+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module defines the class of fixed-size containers.++-}++module Data.FixedSize.Class+ ( FixedSize(..)+ , (!)+ ) where++import GHC.TypeLits+import Data.MyPrelude++-- | The class of fixed-size containers.+--+class (Applicative f, Traversable f) => FixedSize (f :: * -> *) where++ -- | The type of indices.+ --+ type Index f :: *++ -- | The size of the container.+ --+ type Size f :: Nat++ -- | Gets the element at the specified index if the index is valid,+ -- otherwise 'Nothing'.+ --+ (!?) :: f a -> Index f -> Maybe a++ -- | Generates a container by applying the given function to each index.+ --+ generate :: (Index f -> a) -> f a++-- | Gets the element at the specified index, throws an exception+-- if the index is invalid.+--+(!) :: FixedSize f => f a -> Index f -> a+x ! i = fromMaybe (error "Data.FixedSize.Class.!: invalid index") (x !? i)
+ src/Data/FixedSize/Matrix.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-|+Module : Data.FixedSize.Matrix+Description : fixed-size matrices+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module defines fixed-size /matrices/ and some basic typeclass instances and operations for them.+-}++module Data.FixedSize.Matrix+ ( Matrix(..)+ , (<%%>)+ , row+ , column+ , transpose+ ) where++import Data.MyPrelude+import Data.FixedSize.Class+import Data.FixedSize.Vector+import GHC.TypeLits++-- | @'Matrix' m n a@ is the type of /matrices/ with @m@ rows, @n@ columns and entries of type @a@.+--+newtype Matrix (m :: Nat) (n :: Nat) a = Matrix (Vector m (Vector n a))+ deriving (Eq, Show, Functor, Foldable, Traversable, NFData)++instance (KnownNat m, KnownNat n) => Applicative (Matrix m n) where++ pure x = Matrix $ pure (pure x)++ Matrix fs <*> Matrix xs = Matrix $ (<*>) <$> fs <*> xs++instance (KnownNat m, KnownNat n) => FixedSize (Matrix m n) where++ type Index (Matrix m n) = (Int, Int)++ type Size (Matrix m n) = m * n++ m !? (i, j) = row m i >>= (!? j)++ generate f = Matrix $ generate (\i -> generate (\j -> f (i, j)))++-- | Multiplication of a /matrix/ by a (column-)/vector/.+--+-- >>> :set -XDataKinds+-- >>> (pure 1 :: Matrix 1 2 Int) <%%> cons 1 (cons 2 nil)+-- [3]+--+(<%%>) :: Num a => Matrix m n a -> Vector n a -> Vector m a+Matrix rows <%%> v = (v <%>) <$> rows++-- | Gives the matrix row with the specified index (starting at zero) if the index is valid,+-- otherwise 'Nothing'.+--+-- >>> :set -XDataKinds+-- >>> row (pure 42 :: Matrix 2 4 Int) 0+-- Just [42,42,42,42]+--+-- >>> row (pure 42 :: Matrix 2 4 Int) 2+-- Nothing+--+row :: KnownNat m => Matrix m n a -> Int -> Maybe (Vector n a)+row (Matrix rows) = (rows !?)++-- | Gives the matrix column with the specified index (starting at zero) if the index is valid,+-- otherwise 'Nothing'.+--+-- >>> :set -XDataKinds+-- >>> column (pure 42 :: Matrix 2 4 Int) 3+-- Just [42,42]+--+-- >>> column (pure 42 :: Matrix 2 4 Int) 4+-- Nothing+--+column :: KnownNat n => Matrix m n a -> Int -> Maybe (Vector m a)+column (Matrix rows) j = sequenceA $ (!? j) <$> rows++-- | Transposes a matrix.+--+-- >>> transpose (Matrix $ cons (cons 'a' nil) (cons (cons 'b' nil) nil))+-- Matrix ["ab"]+--+transpose :: (KnownNat m, KnownNat n) => Matrix m n a -> Matrix n m a+transpose m = generate $ \(i, j) -> fromJust $ m !? (j, i)
+ src/Data/FixedSize/Vector.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_HADDOCK show-extensions #-}++{-|+Module : Data.FixedSize.Vector+Description : fixed-length vectors+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module defines fixed-length /vectors/ and some basic typeclass instances and operations for them.+-}++module Data.FixedSize.Vector+ ( Vector+ , vZipWith+ , (<%>)+ , nil+ , cons+ , vhead+ , vtail+ , (<+>)+ , (<->)+ , sqNorm+ , sqDiff+ , toVector+ , fromVector+ , KnownNat+ , natVal+ ) where++import Data.FixedSize.Class+import Data.MyPrelude+import Data.Proxy+import Data.Utils.Traversable (fromList)+import qualified Data.Vector as V+import qualified Data.Vector.Sized as VS+import GHC.TypeLits++-- | @'Vector' n a@ is the type of vectors of length @n@ with elements of type @a@.+-- This is a simple wrapper around the 'VS.Vector' type from Joe Hermaszewski's+-- <https://hackage.haskell.org/package/vector-sized-0.3.3.0 vector-sized> library.+--+newtype Vector n a = Vector (VS.Vector n a)+ deriving (Eq, Functor, Applicative, Foldable, Traversable, NFData)++instance Show a => Show (Vector n a) where++ show (Vector v) = show $ VS.fromSized v++instance (KnownNat n, Read a) => Read (Vector n a) where++ readsPrec p s = let xs = readsPrec p s+ n' = fromIntegral (natVal (Proxy :: Proxy n))+ in [(Vector $ fromJust $ VS.toSized ys, t) | (ys, t) <- xs, length ys == n']++instance KnownNat n => FixedSize (Vector n) where++ type Index (Vector n) = Int++ type Size (Vector n) = n++ (Vector v) !? i = VS.fromSized v V.!? i++ generate = Vector . VS.generate++-- | Function @'vZipWith'@ zips two vectors of the same length, using the specified function.+--+-- >>> :set -XDataKinds+-- >>> let f = fromJust . fromList in vZipWith div (f [6,9]) (f [2,3]) :: Vector 2 Int+-- [3,3]+--+vZipWith :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c+vZipWith f (Vector v) (Vector w) = Vector $ VS.zipWith f v w++-- | The /scalar product/ of two vectors of the same length.+--+-- >>> :set -XDataKinds+-- >>> cons 1 (cons 2 nil) <%> cons 3 (cons 4 nil) :: Int+-- 11+--+(<%>) :: Num a => Vector n a -> Vector n a -> a+v <%> w = sum $ vZipWith (*) v w++-- | The vector of length zero.+nil :: Vector 0 a+nil = Vector VS.empty++-- | Prepends the specified element to the specified vector.+--+-- >>> cons False (cons True nil)+-- [False,True]+--+cons :: forall a n. a -> Vector n a -> Vector (n + 1) a+cons x (Vector xs) = Vector $ VS.cons x xs++-- | Gets the first element of a vector of length greater than zero.+--+-- >>> vhead (cons 'x' (cons 'y' nil))+-- 'x'+--+vhead :: Vector (n + 1) a -> a+vhead (Vector v) = VS.head v++-- | For a vector of length greater than zero, gets the vector with its first element removed.+--+-- >>> vtail (cons 'x' (cons 'y' nil))+-- "y"+--+vtail :: forall a n. Vector (n + 1) a -> Vector n a+vtail (Vector v) = Vector $ VS.tail v++infixl 6 <+>++-- | Adds two vectors of the same length.+--+-- >>> :set -XDataKinds+-- >>> (cons 1 (cons 2 nil)) <+> (cons 3 (cons 4 nil)) :: Vector 2 Int+-- [4,6]+--+(<+>) :: Num a => Vector n a -> Vector n a -> Vector n a+(<+>) = vZipWith (+)++infixl 6 <->++-- | Subtracts two vectors of the same length.+--+-- >>> :set -XDataKinds+-- >>> (cons 1 (cons 2 nil)) <-> (cons 3 (cons 4 nil)) :: Vector 2 Int+-- [-2,-2]+--+(<->) :: Num a => Vector n a -> Vector n a -> Vector n a+(<->) = vZipWith (-)++-- | Calculates the /squared/ euclidean norm of a vector,+-- i.e. the scalar product of the vector by itself.+--+-- >>> :set -XDataKinds+-- >>> sqNorm (cons 3 (cons 4 nil)) :: Int+-- 25+--+sqNorm :: Num a => Vector n a -> a+sqNorm v = v <%> v++-- | Calculates the /squared/ euclidean distance between two vectors of the same length.+--+-- >>> :set -XDataKinds+-- >>> sqDiff (cons 1 (cons 2 nil)) (cons 3 (cons 4 nil)) :: Int+-- 8+--+sqDiff :: (Num a, KnownNat n) => Vector n a -> Vector n a -> a+sqDiff v w = sqNorm (v <-> w)++-- | Converts a fixed-size container to a 'Vector' of the same size.+--+toVector :: (FixedSize f, KnownNat (Size f)) => f a -> Vector (Size f) a+toVector = Vector . fromJust . VS.fromList . toList++-- | Converts a 'Vector' to an arbitrary fixed-size container of the same size.+--+fromVector :: FixedSize f => Vector (Size f) a -> f a+fromVector = fromJust . fromList . toList
+ src/Data/FixedSize/Volume.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module : Data.FixedSize.Volume+Description : fixed-size volumes+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module defines fixed-size /volumes/ and some basic typeclass instances and operations for them.+A 'Volume' is a 'Matrix' with 'Vector' entries, i.e. a three-dimensional array.+-}++module Data.FixedSize.Volume+ ( Volume(..)+ , toVolume+ , slice+ , fromMatrix+ ) where++import Data.MyPrelude+import Data.FixedSize.Class+import Data.FixedSize.Matrix+import Data.FixedSize.Vector+import GHC.TypeLits++-- | @'Volume' m n d a@ is the type of /volumes/ with @m@ rows, @n@ columns, depth @d@ and entries of type @a@.+--+newtype Volume (m :: Nat) (n :: Nat) (d :: Nat) a = Volume (Matrix m n (Vector d a))+ deriving (Eq, Show, Functor, Foldable, Traversable, NFData)++-- | Converts a 'Matrix' of 'Vector's to the equivalent 'Volume'.+--+toVolume :: Matrix m n (Vector d a) -> Volume m n d a+toVolume = Volume++instance (KnownNat m, KnownNat n, KnownNat d) => Applicative (Volume m n d) where++ pure x = Volume $ pure (pure x)++ Volume fs <*> Volume xs = Volume $ (<*>) <$> fs <*> xs++instance (KnownNat m, KnownNat n, KnownNat d) => FixedSize (Volume m n d) where++ type Index (Volume m n d) = (Int, Int, Int)++ type Size (Volume m n d) = m * n * d++ Volume m !? (i, j, k) = m !? (i, j) >>= (!? k)++ generate f = Volume $ generate (\(i, j) -> generate (\k -> f (i, j, k)))++-- | @'slice' v i@ gives the matrix "at depth @i@" of volume @v@ (or 'Nothing' if @i@ is invalid).+--+-- >>> :set -XDataKinds+-- >>> slice (pure True :: Volume 2 2 3 Bool) 2+-- Just (Matrix [[True,True],[True,True]])+--+-- >>> slice (pure True :: Volume 2 2 3 Bool) 3+-- Nothing+--+slice :: KnownNat d => Volume m n d a -> Int -> Maybe (Matrix m n a)+slice (Volume m) i = sequenceA $ (!? i) <$> m++-- | Converts a 'Matrix' into a 'Volume' of depth one.+--+-- >>> fromMatrix (pure 0) :: Volume 2 2 1 Int+-- Volume (Matrix [[[0],[0]],[[0],[0]]])+--+fromMatrix :: Matrix m n a -> Volume m n 1 a+fromMatrix = Volume . fmap pure
src/Data/MyPrelude.hs view
@@ -1,59 +1,61 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-| -Module : Data.MyPrelude -Description : commonly used standard types and functions -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module simply reexports a selection of commonly used standard types and functions. --} - -module Data.MyPrelude - ( NFData(..), deepseq, force - , (&), (^.), (.~), Lens', Getter, to, lens - , when, unless, forM, forM_, void, replicateM, forever, guard - , Identity(..) - , MonadIO(..) - , MonadRandom, getRandom, getRandomR, Rand, RandT, runRand, evalRand, runRandT, evalRandT, StdGen, mkStdGen - , MonadState(..) - , lift - , State, StateT, modify, runState, evalState, execState, runStateT, evalStateT, execStateT - , Writer, WriterT, tell, runWriter, execWriter, runWriterT, execWriterT - , lefts, rights - , toList - , on - , sort, sortBy, minimumBy, maximumBy, foldl', intercalate - , catMaybes, fromJust, fromMaybe - , (<>) - , getDirectoryContents - , getArgs - , (</>), (<.>) - , withFile, IOMode(..), hPutStr, hPutStrLn - , printf - ) where - -import Control.DeepSeq (NFData(..), deepseq, force) -import Control.Lens ((&), (^.), (.~), Lens', Getter, to, lens) -import Control.Monad (when, unless, forM, forM_, void, replicateM, forever, guard) -import Control.Monad.Identity (Identity(..)) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Random (MonadRandom, getRandom, getRandomR, Rand, RandT, runRand, evalRand, runRandT, evalRandT, StdGen, mkStdGen) -import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State (State, StateT, modify, runState, evalState, execState, runStateT, evalStateT, execStateT) -import Control.Monad.Trans.Writer (Writer, WriterT, tell, runWriter, execWriter, runWriterT, execWriterT) -import Data.Either (lefts, rights) -import Data.Foldable (toList) -import Data.Function (on) -import Data.List (sort, sortBy, minimumBy, maximumBy, foldl', intercalate) -import Data.Maybe (catMaybes, fromJust, fromMaybe) -import Data.Monoid ((<>)) -import System.Directory (getDirectoryContents) -import System.Environment (getArgs) -import System.FilePath ((</>), (<.>)) -import System.IO (withFile, IOMode(..), hPutStr, hPutStrLn) -import Text.Printf (printf) +{-# OPTIONS_HADDOCK show-extensions #-}++{-|+Module : Data.MyPrelude+Description : commonly used standard types and functions+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module simply reexports a selection of commonly used standard types and functions.+-}++module Data.MyPrelude+ ( NFData(..), deepseq, force+ , (&), (^.), (.~), Lens', Getter, to, lens+ , when, unless, forM, forM_, void, replicateM, replicateM_, forever, guard+ , Identity(..)+ , MonadIO(..)+ , MonadRandom, getRandom, getRandomR, Rand, RandT, runRand, evalRand, runRandT, evalRandT+ , MonadState(..)+ , lift+ , State, StateT, modify, runState, evalState, execState, runStateT, evalStateT, execStateT+ , Writer, WriterT, tell, runWriter, execWriter, runWriterT, execWriterT+ , lefts, rights+ , toList+ , on+ , sort, sortBy, minimumBy, maximumBy, foldl', intercalate+ , catMaybes, fromJust, fromMaybe+ , (<>)+ , getDirectoryContents+ , getArgs+ , (</>), (<.>)+ , withFile, IOMode(..), hPutStr, hPutStrLn+ , Random(..), StdGen, mkStdGen+ , printf+ ) where++import Control.DeepSeq (NFData(..), deepseq, force)+import Control.Lens ((&), (^.), (.~), Lens', Getter, to, lens)+import Control.Monad (when, unless, forM, forM_, void, replicateM, replicateM_, forever, guard)+import Control.Monad.Identity (Identity(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Random (MonadRandom, getRandom, getRandomR, Rand, RandT, runRand, evalRand, runRandT, evalRandT)+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State (State, StateT, modify, runState, evalState, execState, runStateT, evalStateT, execStateT)+import Control.Monad.Trans.Writer (Writer, WriterT, tell, runWriter, execWriter, runWriterT, execWriterT)+import Data.Either (lefts, rights)+import Data.Foldable (toList)+import Data.Function (on)+import Data.List (sort, sortBy, minimumBy, maximumBy, foldl', intercalate)+import Data.Maybe (catMaybes, fromJust, fromMaybe)+import Data.Monoid ((<>))+import System.Directory (getDirectoryContents)+import System.Environment (getArgs)+import System.FilePath ((</>), (<.>))+import System.IO (withFile, IOMode(..), hPutStr, hPutStrLn)+import System.Random (Random(..), StdGen, mkStdGen)+import Text.Printf (printf)
src/Data/Utils.hs view
@@ -1,35 +1,35 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-| -Module : Data.Utils -Description : various utilities -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module reexports various utility modules for convenience. --} - -module Data.Utils - ( module Data.Utils.Analytic - , module Data.Utils.Arrow - , module Data.Utils.Matrix - , module Data.Utils.Pipes - , module Data.Utils.Random - , module Data.Utils.Stack - , module Data.Utils.Statistics - , module Data.Utils.Traversable - , module Data.Utils.Vector - ) where - -import Data.Utils.Analytic -import Data.Utils.Arrow -import Data.Utils.Matrix -import Data.Utils.Pipes -import Data.Utils.Random -import Data.Utils.Stack -import Data.Utils.Statistics -import Data.Utils.Traversable -import Data.Utils.Vector +{-# OPTIONS_HADDOCK show-extensions #-}++{-|+Module : Data.Utils+Description : various utilities+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module reexports various utility modules for convenience.+-}++module Data.Utils+ ( module Data.FixedSize+ , module Data.Utils.Analytic+ , module Data.Utils.Arrow+ , module Data.Utils.Cache+ , module Data.Utils.Pipes+ , module Data.Utils.Random+ , module Data.Utils.Stack+ , module Data.Utils.Statistics+ , module Data.Utils.Traversable+ ) where++import Data.FixedSize+import Data.Utils.Analytic+import Data.Utils.Arrow+import Data.Utils.Cache+import Data.Utils.Pipes+import Data.Utils.Random+import Data.Utils.Stack+import Data.Utils.Statistics+import Data.Utils.Traversable
src/Data/Utils/Analytic.hs view
@@ -1,77 +1,77 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} - -{-| -Module : Data.Utils.Analytic -Description : "analytic" values -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module defines the numeric class 'Analytic', "differentiable" functions @'Diff' f g@ -and an adapted version of 'Numeric.AD.gradWith''. --} - -module Data.Utils.Analytic - ( Analytic(..) - , Diff(..) - , Diff' - , diff - , gradWith' - ) where - -import Control.Category -import Data.MyPrelude -import Data.Reflection (Reifies) -import qualified Numeric.AD as AD -import Numeric.AD.Internal.Reverse (Reverse, Tape) -import Prelude hiding (id, (.)) - --- | Class 'Analytic' is a helper class for defining differentiable functions. --- -class (Floating a, Ord a) => Analytic a where - - fromDouble :: Double -> a - -instance Analytic Double where - - fromDouble = id - -instance Reifies s Tape => Analytic (Reverse s Double) where - - fromDouble = AD.auto - --- | Type @'Diff' f g@ can be thought of as the type of "differentiable" functions @f Double -> g Double@. -newtype Diff f g = Diff { runDiff :: forall a. Analytic a => f a -> g a } - -instance Category Diff where - - id = Diff id - - Diff f . Diff g = Diff (f . g) - --- | Type @'Diff''@ can be thought of as the type of differentiable functions --- @Double -> Double@. -type Diff' = forall a. Analytic a => a -> a - --- | Lifts a differentiable function by pointwise application. --- -diff :: Functor f => Diff' -> Diff f f -diff f = Diff (fmap f) - --- | Computes the gradient of an analytic function and combines it with the argument. --- --- >>> gradWith' (\_ d -> d) (Diff $ \[x, y] -> Identity $ x * x + 3 * y + 7) [2, 1] --- (14.0,[4.0,3.0]) --- -gradWith' :: Traversable t - => (Double -> Double -> a) -- ^ how to combine argument and gradient - -> Diff t Identity -- ^ differentiable function - -> t Double -- ^ function argument - -> (Double, t a) -- ^ function value and combination of argument and gradient -gradWith' c f = AD.gradWith' c (runIdentity . runDiff f) +{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}++{-|+Module : Data.Utils.Analytic+Description : "analytic" values+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module defines the numeric class 'Analytic', "differentiable" functions @'Diff' f g@+and an adapted version of 'Numeric.AD.gradWith''.+-}++module Data.Utils.Analytic+ ( Analytic(..)+ , Diff(..)+ , Diff'+ , diff+ , gradWith'+ ) where++import Control.Category+import Data.MyPrelude+import Data.Reflection (Reifies)+import qualified Numeric.AD as AD+import Numeric.AD.Internal.Reverse (Reverse, Tape)+import Prelude hiding (id, (.))++-- | Class 'Analytic' is a helper class for defining differentiable functions.+--+class (Floating a, Ord a) => Analytic a where++ fromDouble :: Double -> a++instance Analytic Double where++ fromDouble = id++instance Reifies s Tape => Analytic (Reverse s Double) where++ fromDouble = AD.auto++-- | Type @'Diff' f g@ can be thought of as the type of "differentiable" functions @f Double -> g Double@.+newtype Diff f g = Diff { runDiff :: forall a. Analytic a => f a -> g a }++instance Category Diff where++ id = Diff id++ Diff f . Diff g = Diff (f . g)++-- | Type @'Diff''@ can be thought of as the type of differentiable functions+-- @Double -> Double@.+type Diff' = forall a. Analytic a => a -> a++-- | Lifts a differentiable function by pointwise application.+--+diff :: Functor f => Diff' -> Diff f f+diff f = Diff (fmap f)++-- | Computes the gradient of an analytic function and combines it with the argument.+--+-- >>> gradWith' (\_ d -> d) (Diff $ \[x, y] -> Identity $ x * x + 3 * y + 7) [2, 1]+-- (14.0,[4.0,3.0])+--+gradWith' :: Traversable t+ => (Double -> Double -> a) -- ^ how to combine argument and gradient+ -> Diff t Identity -- ^ differentiable function+ -> t Double -- ^ function argument+ -> (Double, t a) -- ^ function value and combination of argument and gradient+gradWith' c f = AD.gradWith' c (runIdentity . runDiff f)
src/Data/Utils/Arrow.hs view
@@ -1,66 +1,66 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-# LANGUAGE Arrows #-} -{-# LANGUAGE RankNTypes #-} - -{-| -Module : Data.Utils.Arrow -Description : arrow utilities -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module defines utility functions for /arrows/. --} - -module Data.Utils.Arrow - ( ArrowConvolve(..) - , fmapArr - , pureArr - , apArr - , dimapArr - ) where - -import Control.Arrow - --- | Arrows implementing 'ArrowConvolve' can be mapped over containers. --- This means that every functor (@f :: Hask -> Hask@) lifts to a functor (@a -> a@). --- --- Instances should satisfy the following laws: --- --- * @convolve id = id@ --- --- * @convolve (g . h) = convolve g . convolve h@ --- --- * @convolve . arr = arr . fmap@ --- -class Arrow a => ArrowConvolve a where - - convolve :: forall f b c. Functor f => a b c -> a (f b) (f c) - --- | A function suitable to define the canonical 'Functor' instance for arrows. --- -fmapArr :: Arrow a => (c -> d) -> a b c -> a b d -fmapArr f a = a >>^ f - --- | A function to define 'pure' for arrows. --- Combining this with 'apArr', the canonical 'Applicative' instance for arrows can easily be defined. --- -pureArr :: Arrow a => c -> a b c -pureArr = arr . const - --- | A function to define @('<*>')@ for arrows. --- Combining this with 'pureArr', the canonical 'Applicative' instance for arrows can easily be defined. --- -apArr :: Arrow a => a b (c -> d) -> a b c -> a b d -apArr a b = proc x -> do - f <- a -< x - y <- b -< x - returnA -< f y - --- | A function suitable to define the canonical 'Data.Profunctor.Profunctor' instance for arrows. --- -dimapArr :: Arrow a => (b -> c) -> (d -> e) -> a c d -> a b e -dimapArr f g a = f ^>> a >>^ g +{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}++{-|+Module : Data.Utils.Arrow+Description : arrow utilities+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module defines utility functions for /arrows/.+-}++module Data.Utils.Arrow+ ( ArrowConvolve(..)+ , fmapArr+ , pureArr+ , apArr+ , dimapArr+ ) where++import Control.Arrow++-- | Arrows implementing 'ArrowConvolve' can be mapped over containers.+-- This means that every functor (@f :: Hask -> Hask@) lifts to a functor (@a -> a@).+--+-- Instances should satisfy the following laws:+--+-- * @convolve id = id@+--+-- * @convolve (g . h) = convolve g . convolve h@+--+-- * @convolve . arr = arr . fmap@+--+class Arrow a => ArrowConvolve a where++ convolve :: forall f b c. Functor f => a b c -> a (f b) (f c)++-- | A function suitable to define the canonical 'Functor' instance for arrows.+--+fmapArr :: Arrow a => (c -> d) -> a b c -> a b d+fmapArr f a = a >>^ f++-- | A function to define 'pure' for arrows.+-- Combining this with 'apArr', the canonical 'Applicative' instance for arrows can easily be defined.+--+pureArr :: Arrow a => c -> a b c+pureArr = arr . const++-- | A function to define @('<*>')@ for arrows.+-- Combining this with 'pureArr', the canonical 'Applicative' instance for arrows can easily be defined.+--+apArr :: Arrow a => a b (c -> d) -> a b c -> a b d+apArr a b = proc x -> do+ f <- a -< x+ y <- b -< x+ returnA -< f y++-- | A function suitable to define the canonical 'Data.Profunctor.Profunctor' instance for arrows.+--+dimapArr :: Arrow a => (b -> c) -> (d -> e) -> a c d -> a b e+dimapArr f g a = f ^>> a >>^ g
+ src/Data/Utils/Cache.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE ScopedTypeVariables #-}++{-|+Module : Data.Utils.Cache+Description : caching+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module defines simple size-limitted caches and utilities for working with them.+-}++module Data.Utils.Cache+ ( Cache+ , newCache+ , retrieveC+ ) where++import qualified Data.Map as M+import Data.MyPrelude+import qualified Data.Set as S++-- | A @'Cache' m k v@ is a cache with keys of type @k@ and values of type @v@.+-- If an uncached key is requested, its value is retrieved using effects in monad @m@.+--+data Cache m k v = Cache+ { cMap :: M.Map k v+ , cQueue :: [k]+ , cGet :: [k] -> m [v]+ , cCapacity :: Int+ }++-- | Creates a new cache with the given retrieval function and maximal cache capacity.+--+newCache :: ([k] -> m [v]) -> Int -> Cache m k v+newCache g c = Cache+ { cMap = M.empty+ , cQueue = []+ , cGet = g+ , cCapacity = max c 0+ }++instance (Show k, Show v) => Show (Cache m k v) where++ show c = show (cMap c, cQueue c)++-- | Retrieves the values for the specified keys from the cache.+-- Uncached values will be retrieved and cached while respecting the maximal cache capacity+-- (old values will be dropped first).+--+retrieveC :: forall m k v. (Monad m, Ord k) => Cache m k v -> [k] -> m ([v], Cache m k v)+retrieveC c xs = do+ let (m, xs') = f+ (ys, zs) = splitAt (length xs') $ cQueue c+ n = foldl' (flip M.delete) (cMap c) ys+ xs'' = toList xs'+ vs <- cGet c xs''+ let xvs = zip xs'' vs+ l = max (cCapacity c) $ length ys+ m' = foldl' (\m'' (x, v) -> M.insert x v m'') m xvs+ n' = foldl' (\n'' (x, v) -> M.insert x v n'') n $ take l xvs+ zs' = zs ++ take l xs''+ c' = c { cMap = n', cQueue = zs' }+ vs' = (m' M.!) <$> xs+ return (vs', c')++ where++ f :: (M.Map k v, S.Set k)+ f = foldl' f' (M.empty, S.empty) xs where+ f' (m, xs') x = case M.lookup x (cMap c) of+ Just y -> (M.insert x y m, xs')+ Nothing -> ( m, S.insert x xs')
src/Data/Utils/List.hs view
@@ -1,187 +1,187 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{-| -Module : Data.Utils.List -Description : list utilities -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module provides various utilities for working with lists. --} - -module Data.Utils.List - ( splitLast - , pick - , distribute - , pad - , ListEditorT - , editListT - , editT - , tryLeftT - , tryRightT - , focusT - , ListEditor - , editList - , pairs - , indexOf - , safeHead - ) where - -import qualified Control.Monad.Identity as I -import qualified Control.Monad.State as S -import Data.MyPrelude (runIdentity) -import Data.Utils.Traversable (fromList) - --- | Splits off the last element of a non-empty list. --- --- >>> splitLast [1, 2, 3] --- Just ([1,2],3) --- --- >>> splitLast [] --- Nothing --- -splitLast :: [a] -> Maybe ([a], a) -splitLast [] = Nothing -splitLast [x] = Just ([], x) -splitLast (x : xs@(_ : _)) = - let Just (ys, y) = splitLast xs - in Just (x : ys, y) - --- | Given a valid index, returns the list element at the index and the remaining elements. --- --- >>> pick 1 [1,2,3,4] --- (2,[1,3,4]) --- -pick :: Int -> [a] -> (a, [a]) -pick n xs = let (ys, z : zs) = splitAt n xs in (z, ys ++ zs) - --- | Distributes the elements of a list as uniformly as possible amongst a specified number of groups. --- --- >>> distribute 3 [1,2,3,4,5] --- [[3],[4,1],[5,2]] --- -distribute :: Int -> [a] -> [[a]] -distribute n = go (replicate n []) where - - go :: [[a]] -> [a] -> [[a]] - go acc [] = acc - go (acc : accs) (x : xs) = go (accs ++ [x : acc]) xs - go _ _ = error "need something to distribute to" - --- | Pads a litst with a provided element on the left. --- --- >>> pad 4 'x' "oo" --- "xxoo" --- -pad :: Int -> a -> [a] -> [a] -pad l x xs = replicate (l - length xs) x ++ xs - -type LZ a = ([a], [a]) - -lz :: [a] -> LZ a -lz xs = ([], xs) - -lzToList :: LZ a -> [a] -lzToList (xs, ys) = reverse xs ++ ys - -lzEdit :: [a] -> LZ a -> LZ a -lzEdit ys (xs, _) = (xs, ys) - -lzLeft :: LZ a -> Maybe (LZ a) -lzLeft ([] , _ ) = Nothing -lzLeft (x : xs, ys) = Just (xs, x : ys) - -lzRight :: LZ a -> Maybe (LZ a) -lzRight (_ , [] ) = Nothing -lzRight (xs, y : ys) = Just (y : xs, ys) - -lzFocus :: LZ a -> [a] -lzFocus = snd - --- | @'ListEditorT' a m@ is a monad transformer for editting lists of type @[a]@. --- -newtype ListEditorT a m b = ListEditorT (S.StateT (LZ a) m b) - deriving (Functor, Applicative, Monad, S.MonadState (LZ a)) - --- | Runs the editor. --- -editListT :: Monad m => ListEditorT a m () -> [a] -> m [a] -editListT (ListEditorT e) xs = lzToList <$> S.execStateT e (lz xs) - --- | Replaces the list at the "cursor" with the provided list. --- -editT :: Monad m => [a] -> ListEditorT a m () -editT = ListEditorT . S.modify . lzEdit - -tryT :: Monad m => (LZ a -> Maybe (LZ a)) -> ListEditorT a m Bool -tryT f = do - z <- S.get - case f z of - Nothing -> return False - Just z' -> S.put z' >> return True - --- | Tries to move the "cursor" to the left. --- -tryLeftT :: Monad m => ListEditorT a m Bool -tryLeftT = tryT lzLeft - --- | Tries to move the "cursor" to the right. --- -tryRightT :: Monad m => ListEditorT a m Bool -tryRightT = tryT lzRight - --- | Gets the list under the "cursor". --- -focusT :: Monad m => ListEditorT a m [a] -focusT = lzFocus <$> S.get - --- | Monad for pure list editting. --- -type ListEditor a = ListEditorT a I.Identity - --- | Runs the pure editor. --- --- >>> editList (do _ <- tryRightT; editT [3,2]) [1,2,3] --- [1,3,2] --- -editList :: ListEditor a () -> [a] -> [a] -editList e xs = I.runIdentity $ editListT e xs - --- | Gets all pairs of adjacent list elements. --- --- >>> pairs "Haskell" --- [('H','a'),('a','s'),('s','k'),('k','e'),('e','l'),('l','l')] --- -pairs :: [a] -> [(a, a)] -pairs xs = zip xs $ tail xs - --- | Gets the first index of the provided element in the list or 'Nothing' if it is not in the list. --- --- >>> indexOf "Haskell" 'l' --- Just 5 --- --- >>> indexOf "Haskell" 'y' --- Nothing --- -indexOf :: Eq a => [a] -> a -> Maybe Int -indexOf [] _ = Nothing -indexOf (x : xs) y - | x == y = Just 0 - | otherwise = succ <$> indexOf xs y - --- | Returns the head of a non-empty list or 'Nothing' for the empty list. --- --- >>> safeHead "Haskell" --- Just 'H' --- --- >>> safeHead "" --- Nothing --- -safeHead :: [a] -> Maybe a -safeHead = (runIdentity <$>) . fromList +{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-|+Module : Data.Utils.List+Description : list utilities+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module provides various utilities for working with lists.+-}++module Data.Utils.List+ ( splitLast+ , pick+ , distribute+ , pad+ , ListEditorT+ , editListT+ , editT+ , tryLeftT+ , tryRightT+ , focusT+ , ListEditor+ , editList+ , pairs+ , indexOf+ , safeHead+ ) where++import qualified Control.Monad.Identity as I+import qualified Control.Monad.State as S+import Data.MyPrelude (runIdentity)+import Data.Utils.Traversable (fromList)++-- | Splits off the last element of a non-empty list.+--+-- >>> splitLast [1, 2, 3]+-- Just ([1,2],3)+--+-- >>> splitLast []+-- Nothing+--+splitLast :: [a] -> Maybe ([a], a)+splitLast [] = Nothing+splitLast [x] = Just ([], x)+splitLast (x : xs@(_ : _)) =+ let Just (ys, y) = splitLast xs+ in Just (x : ys, y)++-- | Given a valid index, returns the list element at the index and the remaining elements.+--+-- >>> pick 1 [1,2,3,4]+-- (2,[1,3,4])+--+pick :: Int -> [a] -> (a, [a])+pick n xs = let (ys, z : zs) = splitAt n xs in (z, ys ++ zs)++-- | Distributes the elements of a list as uniformly as possible amongst a specified number of groups.+--+-- >>> distribute 3 [1,2,3,4,5]+-- [[3],[4,1],[5,2]]+--+distribute :: Int -> [a] -> [[a]]+distribute n = go (replicate n []) where++ go :: [[a]] -> [a] -> [[a]]+ go acc [] = acc+ go (acc : accs) (x : xs) = go (accs ++ [x : acc]) xs+ go _ _ = error "need something to distribute to"++-- | Pads a litst with a provided element on the left.+--+-- >>> pad 4 'x' "oo"+-- "xxoo"+--+pad :: Int -> a -> [a] -> [a]+pad l x xs = replicate (l - length xs) x ++ xs++type LZ a = ([a], [a])++lz :: [a] -> LZ a+lz xs = ([], xs)++lzToList :: LZ a -> [a]+lzToList (xs, ys) = reverse xs ++ ys++lzEdit :: [a] -> LZ a -> LZ a+lzEdit ys (xs, _) = (xs, ys)++lzLeft :: LZ a -> Maybe (LZ a)+lzLeft ([] , _ ) = Nothing+lzLeft (x : xs, ys) = Just (xs, x : ys)++lzRight :: LZ a -> Maybe (LZ a)+lzRight (_ , [] ) = Nothing+lzRight (xs, y : ys) = Just (y : xs, ys)++lzFocus :: LZ a -> [a]+lzFocus = snd++-- | @'ListEditorT' a m@ is a monad transformer for editting lists of type @[a]@.+--+newtype ListEditorT a m b = ListEditorT (S.StateT (LZ a) m b)+ deriving (Functor, Applicative, Monad, S.MonadState (LZ a))++-- | Runs the editor.+--+editListT :: Monad m => ListEditorT a m () -> [a] -> m [a]+editListT (ListEditorT e) xs = lzToList <$> S.execStateT e (lz xs)++-- | Replaces the list at the "cursor" with the provided list.+--+editT :: Monad m => [a] -> ListEditorT a m ()+editT = ListEditorT . S.modify . lzEdit++tryT :: Monad m => (LZ a -> Maybe (LZ a)) -> ListEditorT a m Bool+tryT f = do+ z <- S.get+ case f z of+ Nothing -> return False+ Just z' -> S.put z' >> return True++-- | Tries to move the "cursor" to the left.+--+tryLeftT :: Monad m => ListEditorT a m Bool+tryLeftT = tryT lzLeft++-- | Tries to move the "cursor" to the right.+--+tryRightT :: Monad m => ListEditorT a m Bool+tryRightT = tryT lzRight++-- | Gets the list under the "cursor".+--+focusT :: Monad m => ListEditorT a m [a]+focusT = lzFocus <$> S.get++-- | Monad for pure list editting.+--+type ListEditor a = ListEditorT a I.Identity++-- | Runs the pure editor.+--+-- >>> editList (do _ <- tryRightT; editT [3,2]) [1,2,3]+-- [1,3,2]+--+editList :: ListEditor a () -> [a] -> [a]+editList e xs = I.runIdentity $ editListT e xs++-- | Gets all pairs of adjacent list elements.+--+-- >>> pairs "Haskell"+-- [('H','a'),('a','s'),('s','k'),('k','e'),('e','l'),('l','l')]+--+pairs :: [a] -> [(a, a)]+pairs xs = zip xs $ tail xs++-- | Gets the first index of the provided element in the list or 'Nothing' if it is not in the list.+--+-- >>> indexOf "Haskell" 'l'+-- Just 5+--+-- >>> indexOf "Haskell" 'y'+-- Nothing+--+indexOf :: Eq a => [a] -> a -> Maybe Int+indexOf [] _ = Nothing+indexOf (x : xs) y+ | x == y = Just 0+ | otherwise = succ <$> indexOf xs y++-- | Returns the head of a non-empty list or 'Nothing' for the empty list.+--+-- >>> safeHead "Haskell"+-- Just 'H'+--+-- >>> safeHead ""+-- Nothing+--+safeHead :: [a] -> Maybe a+safeHead = (runIdentity <$>) . fromList
− src/Data/Utils/Matrix.hs
@@ -1,131 +0,0 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{-| -Module : Data.Utils.Matrix -Description : fixed-size matrices -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module defines fixed-size /matrices/ and some basic typeclass instances and operations for them. --} - -module Data.Utils.Matrix - ( Matrix(..) - , (<%%>) - , row - , column - , mgenerate - , (!!?) - , (!!!) - , transpose - ) where - -import GHC.TypeLits -import Data.MyPrelude -import Data.Utils.Vector - --- | @'Matrix' m n a@ is the type of /matrices/ with @m@ rows, @n@ columns and entries of type @a@. --- -newtype Matrix (m :: Nat) (n :: Nat) a = Matrix (Vector m (Vector n a)) - deriving (Eq, Show, Functor, Foldable, Traversable, NFData) - -instance (KnownNat m, KnownNat n) => Applicative (Matrix m n) where - - pure x = Matrix $ pure (pure x) - - Matrix fs <*> Matrix xs = Matrix $ (<*>) <$> fs <*> xs - --- | Multiplication of a /matrix/ by a (column-)/vector/. --- --- >>> :set -XDataKinds --- >>> (pure 1 :: Matrix 1 2 Int) <%%> cons 1 (cons 2 nil) --- [3] --- -(<%%>) :: Num a => Matrix m n a -> Vector n a -> Vector m a -Matrix rows <%%> v = (v <%>) <$> rows - --- | Gives the matrix row with the specified index (starting at zero) if the index is valid, --- otherwise 'Nothing'. --- --- >>> :set -XDataKinds --- >>> row (pure 42 :: Matrix 2 4 Int) 0 --- Just [42,42,42,42] --- --- >>> row (pure 42 :: Matrix 2 4 Int) 2 --- Nothing --- -row :: Matrix m n a -> Int -> Maybe (Vector n a) -row (Matrix rows) = (rows !?) - --- | Gives the matrix column with the specified index (starting at zero) if the index is valid, --- otherwise 'Nothing'. --- --- >>> :set -XDataKinds --- >>> column (pure 42 :: Matrix 2 4 Int) 3 --- Just [42,42] --- --- >>> column (pure 42 :: Matrix 2 4 Int) 4 --- Nothing --- -column :: Matrix m n a -> Int -> Maybe (Vector m a) -column (Matrix rows) j = sequenceA $ (!? j) <$> rows - --- | Generates a matrix by applying the given function to each index (row, column). --- --- >>> :set -XDataKinds --- >>> mgenerate id :: Matrix 3 2 (Int, Int) --- Matrix [[(0,0),(0,1)],[(1,0),(1,1)],[(2,0),(2,1)]] --- -mgenerate :: (KnownNat m, KnownNat n) => ((Int, Int) -> a) -> Matrix m n a -mgenerate f = Matrix $ generate (\i -> generate (\j -> f (i, j))) - --- | Gives the matrix element with the specified index (row, column) if the index is valid, --- otherwise 'Nothing'. --- --- >>> :set -XDataKinds --- >>> let m = mgenerate (uncurry (+)) :: Matrix 2 3 Int --- >>> m !!? (0,0) --- Just 0 --- --- >>> m !!? (1, 2) --- Just 3 --- --- >>> m !!? (5, 7) --- Nothing --- -(!!?) :: Matrix m n a -> (Int, Int) -> Maybe a -m !!? (i, j) = row m i >>= (!? j) - --- | Gives the matrix element with the specified index (row, column) if the index is valid, --- otherwise throws an exception. --- --- >>> :set -XDataKinds --- >>> let m = mgenerate (uncurry (+)) :: Matrix 2 3 Int --- >>> m !!! (0,0) --- 0 --- --- >>> m !!! (1, 2) --- 3 --- -(!!!) :: Matrix m n a -> (Int, Int) -> a -m !!! (i, j) = fromMaybe (error "Data.Utils.Matrix.!!!: invalid index") (m !!? (i, j)) - --- | Transposes a matrix. --- --- >>> transpose (Matrix $ cons (cons 'a' nil) (cons (cons 'b' nil) nil)) --- Matrix ["ab"] --- -transpose :: (KnownNat m, KnownNat n) => Matrix m n a -> Matrix n m a -transpose m = mgenerate $ \(i, j) -> fromJust $ m !!? (j, i)
src/Data/Utils/Pipes.hs view
@@ -1,61 +1,85 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-# LANGUAGE RankNTypes #-} - -{-| -Module : Data.Utils.Pipes -Description : list utilities -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module provides various utilities for working with pipes. --} - -module Data.Utils.Pipes - ( chunks - , fromFile - , toWord8 - , MonadSafe - , runSafeP - , runSafeT - , ByteString - , Word8 - ) where - -import Control.Monad.Codensity (lowerCodensity) -import Data.ByteString (ByteString, unpack) -import Data.MyPrelude -import Data.Word (Word8) -import Pipes -import Pipes.ByteString (fromHandle) -import Pipes.Safe -import qualified Pipes.Safe.Prelude as P - --- | Collects upstream data in chunks of a specified size and then passes those chunks downstram. --- --- >>> import qualified Pipes.Prelude as P --- >>> runEffect $ each [1 .. 10 :: Int] >-> chunks 3 >-> P.mapM_ print --- [1,2,3] --- [4,5,6] --- [7,8,9] --- --- >>> runEffect $ each [1 .. 30000 :: Int] >-> chunks 10000 >-> P.mapM_ (print . sum) --- 50005000 --- 150005000 --- 250005000 --- -chunks :: Monad m => Int -> Pipe a [a] m () -chunks n = forever $ lowerCodensity (replicateM n (lift await)) >>= yield - --- | Safely produces 'ByteString's from a file. --- -fromFile :: MonadSafe m => FilePath -> Producer' ByteString m () -fromFile f = P.withFile f ReadMode fromHandle - --- | Converts a stream of 'ByteString's into a stream of 'Word8's. --- -toWord8 :: Monad m => Pipe ByteString Word8 m () -toWord8 = forever $ await >>= each . unpack +{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE RankNTypes #-}++{-|+Module : Data.Utils.Pipes+Description : pipe utilities+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module provides various utilities for working with pipes.+-}++module Data.Utils.Pipes+ ( chunks+ , fromFile+ , toWord8+ , MonadSafe+ , runSafeP+ , runSafeT+ , ByteString+ , Word8+ , indicesP+ ) where++import Control.Monad.Codensity (lowerCodensity)+import Data.ByteString (ByteString, unpack)+import Data.MyPrelude+import Data.Word (Word8)+import Data.Utils.List (pairs)+import Pipes+import Pipes.ByteString (fromHandle)+import Pipes.Safe+import qualified Pipes.Safe.Prelude as P++-- | Collects upstream data in chunks of a specified size and then passes those chunks downstram.+--+-- >>> import qualified Pipes.Prelude as P+-- >>> runEffect $ each [1 .. 10 :: Int] >-> chunks 3 >-> P.mapM_ print+-- [1,2,3]+-- [4,5,6]+-- [7,8,9]+--+-- >>> runEffect $ each [1 .. 30000 :: Int] >-> chunks 10000 >-> P.mapM_ (print . sum)+-- 50005000+-- 150005000+-- 250005000+--+chunks :: Monad m => Int -> Pipe a [a] m ()+chunks n = forever $ lowerCodensity (replicateM n (lift await)) >>= yield++-- | Safely produces 'ByteString's from a file.+--+fromFile :: MonadSafe m => FilePath -> Producer' ByteString m ()+fromFile f = P.withFile f ReadMode fromHandle++-- | Converts a stream of 'ByteString's into a stream of 'Word8's.+--+toWord8 :: Monad m => Pipe ByteString Word8 m ()+toWord8 = forever $ await >>= each . unpack++-- | Passes upstream elements with the specified indices downstream.+-- Indices will first be sorted, duplicate indices are allowed, negative indices will be ignored.+--+-- >>> import qualified Pipes.Prelude as P+-- >>> P.toList (each [0 .. 10 :: Int] >-> indicesP [2,2,2,0,0,1,1,-3])+-- [0,0,1,1,2,2,2]+--+indicesP :: Monad m => [Int] -> Pipe a a m ()+indicesP = indicesP' . offsets where++ offsets xs = [y - x | (x, y) <- pairs $ 0 : sort [x | x <- xs, x >= 0]]++ indicesP' [] = return ()+ indicesP' (x : xs) = do+ y <- await+ indicesP'' x y xs++ indicesP'' 0 y [] = yield y+ indicesP'' 0 y (0 : xs) = yield y >> indicesP'' 0 y xs+ indicesP'' 0 y (n : xs) = yield y >> indicesP' (pred n : xs)+ indicesP'' n _ xs = indicesP' $ pred n : xs
src/Data/Utils/Random.hs view
@@ -1,162 +1,163 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE BangPatterns #-} - -{-| -Module : Data.Utils.Random -Description : random number utilities -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module provides utilities for working with module 'Control.Monad.Random'. --} - -module Data.Utils.Random - ( pickR' - , pickR - , takeR' - , takeR - , fisherYates - , shuffleR - , boxMuller - , boxMuller' - , roulette - ) where - -import Control.Monad (forM_, unless, replicateM) -import Control.Monad.Random -import qualified Control.Monad.ST.Trans as ST -import Control.Monad.Trans.Class (lift) -import qualified Data.Array as A -import Data.List (mapAccumL) -import Data.Utils.List (pick) - -pickR'' :: MonadRandom m => Int -> [a] -> m (a, [a]) -pickR'' l xs = do - i <- getRandomR (0, pred l) - return $ pick i xs - --- | Picks a random element of the list and returns that element and the remaining elements. --- --- >>> evalRand (pickR' "Haskell") (mkStdGen 4712) --- ('s',"Hakell") --- -pickR' :: MonadRandom m => [a] -> m (a, [a]) -pickR' xs = pickR'' (length xs) xs - --- | Picks a random element of the list. --- --- >>> evalRand (pickR "Haskell") (mkStdGen 4712) --- 's' --- -pickR :: MonadRandom m => [a] -> m a -pickR xs = fst <$> pickR' xs - --- | Takes the specified number of random elements from the list. --- Returns those elements and the remaining elements. --- --- >>> evalRand (takeR' 3 "Haskell") (mkStdGen 4712) --- ("aks","Hell") --- -takeR' :: forall m a. MonadRandom m => Int -> [a] -> m ([a], [a]) -takeR' n xs = go n (length xs) [] xs - - where - - go :: Int -> Int -> [a] -> [a] -> m ([a], [a]) - go 0 _ ys zs = return (ys, zs) - go _ 0 ys zs = return (ys, zs) - go !m !l ys zs = do - (!w, ws) <- pickR'' l zs - go (pred m) (pred l) (w : ys) ws - --- | Takes the specified number of random elements from the list. --- --- >>> evalRand (takeR 3 "Haskell") (mkStdGen 4712) --- "aks" --- -takeR :: MonadRandom m => Int -> [a] -> m [a] -takeR n xs = fst <$> takeR' n xs - --- | Shuffles an array with the --- < https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle Fisher-Yates algorithm>. --- -fisherYates :: forall m a. MonadRandom m => A.Array Int a -> m (A.Array Int a) -fisherYates a = ST.runSTArray st where - - st :: forall s. ST.STT s m (ST.STArray s Int a) - st = do - let (m, n) = A.bounds a - b <- ST.thawSTArray a - forM_ [m .. pred n] $ \i -> do - j <- lift $ getRandomR (i, n) - unless (i == j) $ do - x <- ST.readSTArray b i - y <- ST.readSTArray b j - ST.writeSTArray b i y - ST.writeSTArray b j x - return b - --- | Shuffles an list with the --- < https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle Fisher-Yates algorithm>. --- --- >>> evalRand (shuffleR "Haskell") (mkStdGen 4712) --- "skalHle" --- -shuffleR :: MonadRandom m => [a] -> m [a] -shuffleR xs = A.elems <$> fisherYates (A.listArray (1, length xs) xs) - --- | Uses the <https://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform Box-Muller transform> --- to sample the standard normal distribution (zero expectation, unit variance). --- --- >>> evalRand (replicateM 5 boxMuller) (mkStdGen 1234) :: [Float] --- [0.61298496,-0.19325614,4.4974413e-2,-0.31926495,-1.1109064] --- -boxMuller :: forall m a. (Floating a, Random a, Eq a, MonadRandom m) => m a -boxMuller = do - u1 <- u - u2 <- u - return $ sqrt (-2 * log u1) * cos (2 * pi * u2) - - where - - u :: m a - u = do - x <- getRandomR (0, 1) - if x == 0 then u else return x - --- | Uses the <https://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform Box-Muller transform> --- to sample a normal distribution with specified mean and stadard deviation. --- --- >>> evalRand (replicateM 5 $ boxMuller' 10 2) (mkStdGen 1234) :: [Float] --- [11.22597,9.613487,10.089949,9.36147,7.7781873] --- -boxMuller' :: (Floating a, Random a, Eq a, MonadRandom m) => a -> a -> m a -boxMuller' m s = boxMuller >>= \x -> return $ m + s * x - --- | Randomly selects the specified number of elements of a /weighted/ list. --- --- >>> evalRand (roulette 10 [('x', 1 :: Double), ('y', 2)]) (mkStdGen 1000) --- "yxxyyyyxxy" --- -roulette :: forall a b m. (Ord b, Fractional b, Random b, MonadRandom m) => Int -> [(a, b)] -> m [a] -roulette n xs = do - let (!s, ys) = mapAccumL f 0 xs - zs = map (\(a, b) -> (a, b / s)) ys - replicateM n $ g zs <$> getRandomR (0, 1) - - where - - f :: b -> (a, b) -> (b, (a, b)) - f s (a, w) = let !s' = s + w in (s', (a, s')) - - g :: [(a, b)] -> b -> a - g [] _ = error "empty list" - g [(a, _)] _ = a - g ((a, b') : ws) b - | b <= b' = a - | otherwise = g ws b +{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}++{-|+Module : Data.Utils.Random+Description : random number utilities+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module provides utilities for working with module 'Control.Monad.Random'.+-}++module Data.Utils.Random+ ( pickR'+ , pickR+ , takeR'+ , takeR+ , fisherYates+ , shuffleR+ , boxMuller+ , boxMuller'+ , roulette+ ) where++import Control.Monad (forM_, unless, replicateM)+import Control.Monad.Random+import qualified Control.Monad.ST.Trans as ST+import Control.Monad.Trans.Class (lift)+import qualified Data.Array as A+import Data.List (mapAccumL)+import Data.Utils.List (pick)+import System.Random (Random(..))++pickR'' :: MonadRandom m => Int -> [a] -> m (a, [a])+pickR'' l xs = do+ i <- getRandomR (0, pred l)+ return $ pick i xs++-- | Picks a random element of the list and returns that element and the remaining elements.+--+-- >>> evalRand (pickR' "Haskell") (mkStdGen 4712)+-- ('s',"Hakell")+--+pickR' :: MonadRandom m => [a] -> m (a, [a])+pickR' xs = pickR'' (length xs) xs++-- | Picks a random element of the list.+--+-- >>> evalRand (pickR "Haskell") (mkStdGen 4712)+-- 's'+--+pickR :: MonadRandom m => [a] -> m a+pickR xs = fst <$> pickR' xs++-- | Takes the specified number of random elements from the list.+-- Returns those elements and the remaining elements.+--+-- >>> evalRand (takeR' 3 "Haskell") (mkStdGen 4712)+-- ("aks","Hell")+--+takeR' :: forall m a. MonadRandom m => Int -> [a] -> m ([a], [a])+takeR' n xs = go n (length xs) [] xs++ where++ go :: Int -> Int -> [a] -> [a] -> m ([a], [a])+ go 0 _ ys zs = return (ys, zs)+ go _ 0 ys zs = return (ys, zs)+ go !m !l ys zs = do+ (!w, ws) <- pickR'' l zs+ go (pred m) (pred l) (w : ys) ws++-- | Takes the specified number of random elements from the list.+--+-- >>> evalRand (takeR 3 "Haskell") (mkStdGen 4712)+-- "aks"+--+takeR :: MonadRandom m => Int -> [a] -> m [a]+takeR n xs = fst <$> takeR' n xs++-- | Shuffles an array with the+-- < https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle Fisher-Yates algorithm>.+--+fisherYates :: forall m a. MonadRandom m => A.Array Int a -> m (A.Array Int a)+fisherYates a = ST.runSTArray st where++ st :: forall s. ST.STT s m (ST.STArray s Int a)+ st = do+ let (m, n) = A.bounds a+ b <- ST.thawSTArray a+ forM_ [m .. pred n] $ \i -> do+ j <- lift $ getRandomR (i, n)+ unless (i == j) $ do+ x <- ST.readSTArray b i+ y <- ST.readSTArray b j+ ST.writeSTArray b i y+ ST.writeSTArray b j x+ return b++-- | Shuffles an list with the+-- < https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle Fisher-Yates algorithm>.+--+-- >>> evalRand (shuffleR "Haskell") (mkStdGen 4712)+-- "skalHle"+--+shuffleR :: MonadRandom m => [a] -> m [a]+shuffleR xs = A.elems <$> fisherYates (A.listArray (1, length xs) xs)++-- | Uses the <https://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform Box-Muller transform>+-- to sample the standard normal distribution (zero expectation, unit variance).+--+-- >>> evalRand (replicateM 5 boxMuller) (mkStdGen 1234) :: [Float]+-- [0.61298496,-0.19325614,4.4974413e-2,-0.31926495,-1.1109064]+--+boxMuller :: forall m a. (Floating a, Random a, Eq a, MonadRandom m) => m a+boxMuller = do+ u1 <- u+ u2 <- u+ return $ sqrt (-2 * log u1) * cos (2 * pi * u2)++ where++ u :: m a+ u = do+ x <- getRandomR (0, 1)+ if x == 0 then u else return x++-- | Uses the <https://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform Box-Muller transform>+-- to sample a normal distribution with specified mean and stadard deviation.+--+-- >>> evalRand (replicateM 5 $ boxMuller' 10 2) (mkStdGen 1234) :: [Float]+-- [11.22597,9.613487,10.089949,9.36147,7.7781873]+--+boxMuller' :: (Floating a, Random a, Eq a, MonadRandom m) => a -> a -> m a+boxMuller' m s = boxMuller >>= \x -> return $ m + s * x++-- | Randomly selects the specified number of elements of a /weighted/ list.+--+-- >>> evalRand (roulette 10 [('x', 1 :: Double), ('y', 2)]) (mkStdGen 1000)+-- "yxxyyyyxxy"+--+roulette :: forall a b m. (Ord b, Fractional b, Random b, MonadRandom m) => Int -> [(a, b)] -> m [a]+roulette n xs = do+ let (!s, ys) = mapAccumL f 0 xs+ zs = map (\(a, b) -> (a, b / s)) ys+ replicateM n $ g zs <$> getRandomR (0, 1)++ where++ f :: b -> (a, b) -> (b, (a, b))+ f s (a, w) = let !s' = s + w in (s', (a, s'))++ g :: [(a, b)] -> b -> a+ g [] _ = error "empty list"+ g [(a, _)] _ = a+ g ((a, b') : ws) b+ | b <= b' = a+ | otherwise = g ws b
src/Data/Utils/Stack.hs view
@@ -1,95 +1,95 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{-| -Module : Data.Utils.Stack -Description : a simple stack monad -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module defines the 'StackT' monad transformer, -which is simply a wrapped state monad whose state is a list. --} - -module Data.Utils.Stack - ( StackT - , pop - , peek - , push - , runStackT - , evalStackT - , execStackT - , Stack - , runStack - , evalStack - , execStack - ) where - -import Control.Monad.Trans.Class (MonadTrans) -import Data.MyPrelude - --- | A computation of type @'StackT' s m a@ has access to a stack of elements of type @s@. --- -newtype StackT s m a = StackT (StateT [s] m a) - deriving (Functor, Applicative, Monad, MonadTrans) - --- | Peeks at the top element of the stack. Returns 'Nothing' if the stack is empty. --- -peek :: Monad m => StackT s m (Maybe s) -peek = do - xs <- StackT get - return $ case xs of - [] -> Nothing - (x : _) -> Just x - --- | Pops the top element from the stack. Returns 'Nothing' if the stack is empty. --- -pop :: Monad m => StackT s m (Maybe s) -pop = do - xs <- StackT get - case xs of - [] -> return Nothing - (x : xs') -> (StackT $ put xs') >> return (Just x) - --- | Pushes a new element onto the stack. --- -push :: Monad m => s -> StackT s m () -push x = StackT $ modify (x :) - --- | Runs a computation in the @'StackT' s m@ monad. --- -runStackT :: StackT s m a -> [s] -> m (a, [s]) -runStackT (StackT m) = runStateT m - --- | Evaluates a computation in the @'StackT' s m@ monad. --- -evalStackT :: Monad m => StackT s m a -> [s] -> m a -evalStackT m xs = fst <$> runStackT m xs - --- | Executes a computation in the @'StackT' s m@ monad. --- -execStackT :: Monad m => StackT s m a -> [s] -> m [s] -execStackT m xs = snd <$> runStackT m xs - --- | A pure stack monad. --- -type Stack s = StackT s Identity - --- | Runs a computation in the @'Stack' s@ monad. --- -runStack :: Stack s a -> [s] -> (a, [s]) -runStack m xs = runIdentity $ runStackT m xs - --- | Evaluates a computation in the @'Stack' s@ monad. --- -evalStack :: Stack s a -> [s] -> a -evalStack m xs = runIdentity $ evalStackT m xs - --- | Executes a computation in the @'Stack' s@ monad. --- -execStack :: Stack s a -> [s] -> [s] -execStack m xs = runIdentity $ execStackT m xs +{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-|+Module : Data.Utils.Stack+Description : a simple stack monad+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module defines the 'StackT' monad transformer,+which is simply a wrapped state monad whose state is a list.+-}++module Data.Utils.Stack+ ( StackT+ , pop+ , peek+ , push+ , runStackT+ , evalStackT+ , execStackT+ , Stack+ , runStack+ , evalStack+ , execStack+ ) where++import Control.Monad.Trans.Class (MonadTrans)+import Data.MyPrelude++-- | A computation of type @'StackT' s m a@ has access to a stack of elements of type @s@.+--+newtype StackT s m a = StackT (StateT [s] m a)+ deriving (Functor, Applicative, Monad, MonadTrans)++-- | Peeks at the top element of the stack. Returns 'Nothing' if the stack is empty.+--+peek :: Monad m => StackT s m (Maybe s)+peek = do+ xs <- StackT get+ return $ case xs of+ [] -> Nothing+ (x : _) -> Just x++-- | Pops the top element from the stack. Returns 'Nothing' if the stack is empty.+--+pop :: Monad m => StackT s m (Maybe s)+pop = do+ xs <- StackT get+ case xs of+ [] -> return Nothing+ (x : xs') -> (StackT $ put xs') >> return (Just x)++-- | Pushes a new element onto the stack.+--+push :: Monad m => s -> StackT s m ()+push x = StackT $ modify (x :)++-- | Runs a computation in the @'StackT' s m@ monad.+--+runStackT :: StackT s m a -> [s] -> m (a, [s])+runStackT (StackT m) = runStateT m++-- | Evaluates a computation in the @'StackT' s m@ monad.+--+evalStackT :: Monad m => StackT s m a -> [s] -> m a+evalStackT m xs = fst <$> runStackT m xs++-- | Executes a computation in the @'StackT' s m@ monad.+--+execStackT :: Monad m => StackT s m a -> [s] -> m [s]+execStackT m xs = snd <$> runStackT m xs++-- | A pure stack monad.+--+type Stack s = StackT s Identity++-- | Runs a computation in the @'Stack' s@ monad.+--+runStack :: Stack s a -> [s] -> (a, [s])+runStack m xs = runIdentity $ runStackT m xs++-- | Evaluates a computation in the @'Stack' s@ monad.+--+evalStack :: Stack s a -> [s] -> a+evalStack m xs = runIdentity $ evalStackT m xs++-- | Executes a computation in the @'Stack' s@ monad.+--+execStack :: Stack s a -> [s] -> [s]+execStack m xs = runIdentity $ execStackT m xs
src/Data/Utils/Statistics.hs view
@@ -1,160 +1,160 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} - -{-| -Module : Data.Utils.Statistics -Description : statistical utilities -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module provides utilities for working with statistics. --} - -module Data.Utils.Statistics - ( Probability - , probability - , fromProbability - , countMeanVar - , mean - , auc - , auc' - , round' - ) where - -import Control.Category ((>>>)) -import Control.DeepSeq (NFData) -import Data.Function (on) -import Data.List (sortOn, foldl', partition, groupBy) -import Data.Ord (Down(..)) - --- | A type for representing probabilities. --- -newtype Probability a = Probability - { fromProbability :: a -- ^ the wrapped number - } - deriving (Show, Read, Eq, Ord, Num, NFData, Functor) - --- | Smart constructor for probabilities. --- --- >>> probability (0.7 :: Double) --- Probability {fromProbability = 0.7} --- --- >>> probability (1.2 :: Double) --- Probability {fromProbability = 1.0} --- --- >>> probability (-0.3 :: Double) --- Probability {fromProbability = 0.0} --- -probability :: RealFloat a => a -> Probability a -probability x - | x < 0 = Probability 0 - | x > 1 = Probability 1 - | isNaN x = Probability 0.5 - | otherwise = Probability x - --- | Returns number of elements, mean and variance of a collection of elements. --- --- >>> countMeanVar [1, 2, 3, 4 :: Float] --- (4,2.5,1.25) --- -countMeanVar :: forall a. Fractional a => [a] -> (Int, a, a) -countMeanVar xs = - let (n, s, q) = foldl' f (0, 0, 0) xs - n' = fromIntegral n - m = s / n' - v = q / n' - m * m - in (n, m, v) - - where - - f :: (Int, a, a) -> a -> (Int, a, a) - f (!n, !s, !q) !x = (succ n, s + x, q + x * x) - --- | Calculates the mean of a collection of elements. --- --- >>> mean [1 .. 5 :: Float] --- 3.0 --- -mean :: forall a. Fractional a => [a] -> a -mean xs = - let (n, s) = foldl' f (0, 0) xs - n' = fromIntegral n - !m = s / n' - in m - - where - - f :: (Int, a) -> a -> (Int, a) - f (!n, !s) !x = (succ n, s + x) - --- | Calculates the --- <https://en.wikipedia.org/wiki/Receiver_operating_characteristic#Area_under_the_curve area under the curve>. --- --- >>> auc [(1, False), (2, True), (3, False), (4, True), (5, False), (6, True), (7, True)] --- Probability {fromProbability = 0.75} --- -auc :: Ord a => [(a, Bool)] -> Probability Double -auc = probability . auc' . map (\(a, b) -> (a, 1 :: Double, b)) - --- | Calculates the --- <https://en.wikipedia.org/wiki/Receiver_operating_characteristic#Area_under_the_curve area under the curve> --- for /weighted/ samples. --- --- >>> auc' [(1, (1 :: Double), False), (2, 0.5, True), (3, 1, False), (4, 1, True), (5, 1, False), (6, 1, True), (7, 1, True)] --- 0.8095238095238095 --- -auc' :: forall a b. (Ord a, Fractional b) => [(a, b, Bool)] -> b -auc' xs = let (ps , ns ) = partition third xs - (ps', ns') = both (normalize . sortOn (Down . fst) . map exceptThird) (ps, ns) - ns'' = zipWith (\(a, _) (b, b') -> (a, b, b')) ns' $ collate ns' - in go 0 ps' ns'' - - where - - third :: (c, d, e) -> e - third (_, _, e) = e - - exceptThird :: (c, d, e) -> (c, d) - exceptThird (c, d, _) = (c, d) - - both :: (c -> d) -> (c, c) -> (d, d) - both f (c, c') = (f c, f c') - - normalize :: [(a, b)] -> [(a, b)] - normalize = f >>> g >>> h - - where - - f ys = let !sb = sum $ map snd ys - in map (\(a, b) -> (a, let !q = b / sb in q)) ys - - g = groupBy ((==) `on` fst) - - h = map (\ys@((a, _) : _) -> (a, sum $ map snd ys)) - - collate :: [(a, b)] -> [(b, b)] - collate = scanr (\(_, b) (b', b'') -> (b, b' + b'')) (0, 0) - - go :: b -> [(a, b)] -> [(a, b, b)] -> b - go !x [] _ = x - go !x _ [] = x - go !x ps@((a, b) : ps') ns@((a', b', b'') : ns') - | a > a' = go (x + b * (b' + b'')) ps' ns - | a == a' = go (x + b * (b' / 2 + b'')) ps' ns' - | otherwise = go x ps ns' - --- | Rounds a 'Double' to the specified number of decimals. --- --- >>> round' 3 (2/3) --- 0.667 --- -round' :: Int -> Double -> Double -round' d x = let p = 10 ^ d - in fromIntegral (round (p * x) :: Integer) / p +{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}++{-|+Module : Data.Utils.Statistics+Description : statistical utilities+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module provides utilities for working with statistics.+-}++module Data.Utils.Statistics+ ( Probability+ , probability+ , fromProbability+ , countMeanVar+ , mean+ , auc+ , auc'+ , round'+ ) where++import Control.Category ((>>>))+import Control.DeepSeq (NFData)+import Data.Function (on)+import Data.List (sortOn, foldl', partition, groupBy)+import Data.Ord (Down(..))++-- | A type for representing probabilities.+--+newtype Probability a = Probability+ { fromProbability :: a -- ^ the wrapped number+ }+ deriving (Show, Read, Eq, Ord, Num, NFData, Functor)++-- | Smart constructor for probabilities.+--+-- >>> probability (0.7 :: Double)+-- Probability {fromProbability = 0.7}+--+-- >>> probability (1.2 :: Double)+-- Probability {fromProbability = 1.0}+--+-- >>> probability (-0.3 :: Double)+-- Probability {fromProbability = 0.0}+--+probability :: RealFloat a => a -> Probability a+probability x+ | x < 0 = Probability 0+ | x > 1 = Probability 1+ | isNaN x = Probability 0.5+ | otherwise = Probability x++-- | Returns number of elements, mean and variance of a collection of elements.+--+-- >>> countMeanVar [1, 2, 3, 4 :: Float]+-- (4,2.5,1.25)+--+countMeanVar :: forall a. Fractional a => [a] -> (Int, a, a)+countMeanVar xs =+ let (n, s, q) = foldl' f (0, 0, 0) xs+ n' = fromIntegral n+ m = s / n'+ v = q / n' - m * m+ in (n, m, v)++ where++ f :: (Int, a, a) -> a -> (Int, a, a)+ f (!n, !s, !q) !x = (succ n, s + x, q + x * x)++-- | Calculates the mean of a collection of elements.+--+-- >>> mean [1 .. 5 :: Float]+-- 3.0+--+mean :: forall a. Fractional a => [a] -> a+mean xs =+ let (n, s) = foldl' f (0, 0) xs+ n' = fromIntegral n+ !m = s / n'+ in m++ where++ f :: (Int, a) -> a -> (Int, a)+ f (!n, !s) !x = (succ n, s + x)++-- | Calculates the+-- <https://en.wikipedia.org/wiki/Receiver_operating_characteristic#Area_under_the_curve area under the curve>.+--+-- >>> auc [(1, False), (2, True), (3, False), (4, True), (5, False), (6, True), (7, True)]+-- Probability {fromProbability = 0.75}+--+auc :: Ord a => [(a, Bool)] -> Probability Double+auc = probability . auc' . map (\(a, b) -> (a, 1 :: Double, b))++-- | Calculates the+-- <https://en.wikipedia.org/wiki/Receiver_operating_characteristic#Area_under_the_curve area under the curve>+-- for /weighted/ samples.+--+-- >>> auc' [(1, (1 :: Double), False), (2, 0.5, True), (3, 1, False), (4, 1, True), (5, 1, False), (6, 1, True), (7, 1, True)]+-- 0.8095238095238095+--+auc' :: forall a b. (Ord a, Fractional b) => [(a, b, Bool)] -> b+auc' xs = let (ps , ns ) = partition third xs+ (ps', ns') = both (normalize . sortOn (Down . fst) . map exceptThird) (ps, ns)+ ns'' = zipWith (\(a, _) (b, b') -> (a, b, b')) ns' $ collate ns'+ in go 0 ps' ns''++ where++ third :: (c, d, e) -> e+ third (_, _, e) = e++ exceptThird :: (c, d, e) -> (c, d)+ exceptThird (c, d, _) = (c, d)++ both :: (c -> d) -> (c, c) -> (d, d)+ both f (c, c') = (f c, f c')++ normalize :: [(a, b)] -> [(a, b)]+ normalize = f >>> g >>> h++ where++ f ys = let !sb = sum $ map snd ys+ in map (\(a, b) -> (a, let !q = b / sb in q)) ys++ g = groupBy ((==) `on` fst)++ h = map (\ys@((a, _) : _) -> (a, sum $ map snd ys))++ collate :: [(a, b)] -> [(b, b)]+ collate = scanr (\(_, b) (b', b'') -> (b, b' + b'')) (0, 0)++ go :: b -> [(a, b)] -> [(a, b, b)] -> b+ go !x [] _ = x+ go !x _ [] = x+ go !x ps@((a, b) : ps') ns@((a', b', b'') : ns')+ | a > a' = go (x + b * (b' + b'')) ps' ns+ | a == a' = go (x + b * (b' / 2 + b'')) ps' ns'+ | otherwise = go x ps ns'++-- | Rounds a 'Double' to the specified number of decimals.+--+-- >>> round' 3 (2/3)+-- 0.667+--+round' :: Int -> Double -> Double+round' d x = let p = 10 ^ d+ in fromIntegral (round (p * x) :: Integer) / p
src/Data/Utils/Traversable.hs view
@@ -1,32 +1,32 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-| -Module : Data.Utils.Traversable -Description : utilities for traversables -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module contains utility functions related to the 'Traversable' typeclass. --} - -module Data.Utils.Traversable - ( fromList - ) where - -import Data.Utils.Stack - --- | Tries to create a traversable (which must also be applicative) from a list. --- If the list contains too few elements, 'Nothing' is returned, --- --- >>> import Data.MyPrelude --- >>> fromList [1, 2, 3] :: Maybe (Identity Int) --- Just (Identity 1) --- --- >>> fromList [] :: Maybe (Identity Char) --- Nothing --- -fromList :: (Applicative t, Traversable t) => [a] -> Maybe (t a) -fromList xs = sequenceA $ evalStack (sequenceA $ pure pop) xs +{-# OPTIONS_HADDOCK show-extensions #-}++{-|+Module : Data.Utils.Traversable+Description : utilities for traversables+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module contains utility functions related to the 'Traversable' typeclass.+-}++module Data.Utils.Traversable+ ( fromList+ ) where++import Data.Utils.Stack++-- | Tries to create a traversable (which must also be applicative) from a list.+-- If the list contains too few elements, 'Nothing' is returned,+--+-- >>> import Data.MyPrelude+-- >>> fromList [1, 2, 3] :: Maybe (Identity Int)+-- Just (Identity 1)+--+-- >>> fromList [] :: Maybe (Identity Char)+-- Nothing+--+fromList :: (Applicative t, Traversable t) => [a] -> Maybe (t a)+fromList xs = sequenceA $ evalStack (sequenceA $ pure pop) xs
− src/Data/Utils/Vector.hs
@@ -1,195 +0,0 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -#endif - -{-| -Module : Data.Utils.Vector -Description : fixed-length vectors -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module defines fixed-length /vectors/ and some basic typeclass instances and operations for them. --} - -module Data.Utils.Vector - ( Vector - , (<%>) - , nil - , cons - , generate - , (!?) - , (!) - , vhead - , vtail - , (<+>) - , (<->) - , sqNorm - , sqDiff - , KnownNat - , natVal - ) where - -import Data.Proxy -import qualified Data.Vector as V -import GHC.TypeLits -import GHC.TypeLits.Witnesses -import Data.MyPrelude - --- | @'Vector' n a@ is the type of vectors of length @n@ with elements of type @a@. -data Vector :: Nat -> * -> * where - - Vector :: KnownNat n => V.Vector a -> Vector n a - -instance Eq a => Eq (Vector n a) where - - Vector xs == Vector ys = xs == ys - -instance Show a => Show (Vector n a) where - - showsPrec p (Vector xs) = showsPrec p xs - -instance Functor (Vector n) where - - fmap f (Vector v) = Vector (f <$> v) - -instance forall n. KnownNat n => Applicative (Vector n) where - - pure x = let n = natVal (Proxy :: Proxy n) in Vector (V.replicate (fromIntegral n) x) - - Vector fs <*> Vector xs = Vector (V.zipWith ($) fs xs) - -instance Foldable (Vector n) where - - foldMap f (Vector xs) = foldMap f xs - -instance Traversable (Vector n) where - - sequenceA (Vector xs) = Vector <$> sequenceA xs - -instance (KnownNat n, Read a) => Read (Vector n a) where - - readsPrec p s = let xs = readsPrec p s :: [(V.Vector a, String)] - n' = fromIntegral (natVal (Proxy :: Proxy n)) - in [(Vector ys, t) | (ys, t) <- xs, length ys == n'] - -instance (NFData a) => NFData (Vector n a) where - - rnf (Vector v) = rnf v - --- | The /scalar product/ of two vectors of the same length. --- --- >>> :set -XDataKinds --- >>> cons 1 (cons 2 nil) <%> cons 3 (cons 4 nil) :: Int --- 11 --- -(<%>) :: Num a => Vector n a -> Vector n a -> a -Vector v <%> Vector w = V.sum $ V.zipWith (*) v w - --- | The vector of length zero. -nil :: Vector 0 a -nil = Vector V.empty - --- | Prepends the specified element to the specified vector. --- --- >>> cons False (cons True nil) --- [False,True] --- -cons :: forall a n. a -> Vector n a -> Vector (n + 1) a -cons x (Vector xs) = withNatOp (%+) (Proxy :: Proxy n) (Proxy :: Proxy 1) $ Vector $ V.cons x xs - --- | Generates a vector by applying the given function to each index. --- --- >>> :set -XDataKinds --- >>> generate id :: Vector 3 Int --- [0,1,2] --- -generate :: forall n a. KnownNat n => (Int -> a) -> Vector n a -generate = Vector . V.generate (fromIntegral $ natVal (Proxy :: Proxy n)) - --- | Gets the vector element at the specified index if the index is valid, otherwise 'Nothing'. --- --- >>> cons 'x' nil !? 0 --- Just 'x' --- --- >>> cons 'x' nil !? 1 --- Nothing --- -(!?) :: Vector n a -> Int -> Maybe a -Vector v !? i = v V.!? i - --- | Gets the vector element at the specified index, throws an exception if the index is invalid. --- --- >>> cons 'x' nil ! 0 --- 'x' --- -(!) :: Vector n a -> Int -> a -v ! i = fromMaybe (error "Data.Utils.Vector.!: invalid index") (v !? i) - --- | Gets the first element of a vector of length greater than zero. --- --- >>> vhead (cons 'x' (cons 'y' nil)) --- 'x' --- -vhead :: (1 <= n) => Vector n a -> a -vhead (Vector v) = V.head v - --- | For a vector of length greater than zero, gets the vector with its first element removed. --- --- >>> vtail (cons 'x' (cons 'y' nil)) --- "y" --- -vtail :: forall a n. (1 <= n) => Vector n a -> Vector (n - 1) a -vtail (Vector v) = withNatOp (%-) (Proxy :: Proxy n) (Proxy :: Proxy 1) $ Vector (V.tail v) - -infixl 6 <+> - --- | Adds two vectors of the same length. --- --- >>> :set -XDataKinds --- >>> (cons 1 (cons 2 nil)) <+> (cons 3 (cons 4 nil)) :: Vector 2 Int --- [4,6] --- -(<+>) :: (Num a, KnownNat n) => Vector n a -> Vector n a -> Vector n a -v <+> w = (+) <$> v <*> w - -infixl 6 <-> - --- | Subtracts two vectors of the same length. --- --- >>> :set -XDataKinds --- >>> (cons 1 (cons 2 nil)) <-> (cons 3 (cons 4 nil)) :: Vector 2 Int --- [-2,-2] --- -(<->) :: (Num a, KnownNat n) => Vector n a -> Vector n a -> Vector n a -v <-> w = (-) <$> v <*> w - --- | Calculates the /squared/ euclidean norm of a vector, --- i.e. the scalar product of the vector by itself. --- --- >>> :set -XDataKinds --- >>> sqNorm (cons 3 (cons 4 nil)) :: Int --- 25 --- -sqNorm :: Num a => Vector n a -> a -sqNorm v = v <%> v - --- | Calculates the /squared/ euclidean distance between two vectors of the same length. --- --- >>> :set -XDataKinds --- >>> sqDiff (cons 1 (cons 2 nil)) (cons 3 (cons 4 nil)) :: Int --- 8 --- -sqDiff :: (Num a, KnownNat n) => Vector n a -> Vector n a -> a -sqDiff v w = sqNorm (v <-> w)
src/Numeric/Neural.hs view
@@ -1,25 +1,27 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-| -Module : Numeric.Neural -Description : neural networks -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module reexports all the neural network related modules for convenience. --} - -module Numeric.Neural - ( module Numeric.Neural.Layer - , module Numeric.Neural.Model - , module Numeric.Neural.Normalization - , module Numeric.Neural.Pipes - ) where - -import Numeric.Neural.Layer -import Numeric.Neural.Model -import Numeric.Neural.Normalization -import Numeric.Neural.Pipes +{-# OPTIONS_HADDOCK show-extensions #-}++{-|+Module : Numeric.Neural+Description : neural networks+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module reexports all the neural network related modules for convenience.+-}++module Numeric.Neural+ ( module Numeric.Neural.Convolution+ , module Numeric.Neural.Layer+ , module Numeric.Neural.Model+ , module Numeric.Neural.Normalization+ , module Numeric.Neural.Pipes+ ) where++import Numeric.Neural.Convolution+import Numeric.Neural.Layer+import Numeric.Neural.Model+import Numeric.Neural.Normalization+import Numeric.Neural.Pipes
+ src/Numeric/Neural/Convolution.hs view
@@ -0,0 +1,108 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-|+Module : Numeric.Neural.Convolution+Description : convolutional layers+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module defines /convolutional/ layers.+-}++module Numeric.Neural.Convolution+ ( focus+ , focus'+ , cover+ , cover'+ , convolution+ ) where++import Control.Category+import Data.FixedSize+import Data.Functor.Compose (Compose(..))+import Data.Proxy+import Data.Utils+import GHC.TypeLits+import GHC.TypeLits.Witnesses+import Numeric.Neural.Layer+import Numeric.Neural.Model+import Prelude hiding (id, (.))++-- | Focuses on a specific region of a volume.+--+focus :: (KnownNat m, KnownNat n, KnownNat d, KnownNat m', KnownNat n')+ => a -- ^ the element to use for out-of-bound indices+ -> Volume m n d a -- ^ the original 'Volume'+ -> (Int, Int) -- ^ the upper left corner of the focused region+ -> Volume m' n' d a+focus x v (i, j) = generate $ \(i', j', k') -> maybe x id $ v !? (i + i', j + j', k')++-- | Specialization of 'focus' to 'Volume's with numeric values,+-- padding out-of-bound indices with zero.+--+-- >>> :set -XDataKinds+-- >>> let v = generate (\(i, j, k) -> i + j + k) :: Volume 2 2 3 Int+-- >>> focus' v (0, 1) :: Volume 1 2 3 Int+-- Volume (Matrix [[[1,2,3],[0,0,0]]])+--+focus' :: (KnownNat m, KnownNat n, KnownNat d, KnownNat m', KnownNat n', Num a)+ => Volume m n d a -- ^ the original 'Volume'+ -> (Int, Int) -- ^ the upper left corner of the focused region+ -> Volume m' n' d a+focus' = focus 0++-- | Covers a 'Volume' with (smaller) regions.+--+cover :: forall m n d a s m' n'.+ (KnownNat m, KnownNat n, KnownNat d, KnownNat s, KnownNat m', KnownNat n')+ => a -- ^ the element to use for out-of-bound indices+ -> Proxy s -- ^ a proxy to the region size+ -> Int -- ^ the stride+ -> Volume m n d a -- ^ the original 'Volume'+ -> Matrix m' n' (Vector (s * s * d) a)+cover x ps stride v = withNatOp (%*) ps ps $+ withNatOp (%*) (Proxy :: Proxy (s * s)) (Proxy :: Proxy d) $+ generate $ toVector . volume++ where volume :: (Int, Int) -> Volume s s d a+ volume (i, j) = focus x v (stride * i, stride * j)++-- | Specialization of 'cover' to 'Volume's with numeric values.+--+-- >>> :set -XDataKinds+-- >>> let v = generate (\(i, j, _) -> i + j) :: Volume 4 4 1 Int+-- >>> cover' (Proxy :: Proxy 3) 1 v :: Matrix 2 2 (Vector 9 Int)+-- Matrix [[[0,1,2,1,2,3,2,3,4],[1,2,3,2,3,4,3,4,5]],[[1,2,3,2,3,4,3,4,5],[2,3,4,3,4,5,4,5,6]]]+--+cover' :: forall m n d a s m' n'.+ (KnownNat m, KnownNat n, KnownNat d, KnownNat s, KnownNat m', KnownNat n', Num a)+ => Proxy s -- ^ a proxy to the region size+ -> Int -- ^ the stride+ -> Volume m n d a -- ^ the original 'Volume'+ -> Matrix m' n' (Vector (s * s * d) a)+cover' = cover 0++-- | Convolves a 'Layer' over a 'Volume'.+--+convolution :: forall s m n d m' n' d'.+ (KnownNat s, KnownNat m, KnownNat n, KnownNat d, KnownNat m', KnownNat n')+ => Proxy s -- ^ a proxy to the region size+ -> Int -- ^ the stride+ -> Layer (s * s * d) d' -- ^ the layer to convolve+ -> Component (Volume m n d) (Volume m' n' d')+convolution ps stride l = cArr (Diff $ toVolume . unCompose) .+ cConvolve l .+ cArr (Diff $ Compose . cover' ps stride)++ where++ unCompose :: Compose f g a -> f (g a)+ unCompose (Compose x) = x++ _ = natVal (Proxy :: Proxy d)
src/Numeric/Neural/Layer.hs view
@@ -1,95 +1,102 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} - -{-| -Module : Numeric.Neural.Layer -Description : layer components -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This modules defines special "layer" components and convenience functions for the creation of such layers. --} - -module Numeric.Neural.Layer - ( Layer - , linearLayer - , layer - , tanhLayer - , logisticLayer - , reLULayer - , softmax - ) where - -import Control.Category -import Data.Proxy -import GHC.TypeLits -import GHC.TypeLits.Witnesses -import Numeric.Neural.Model -import Prelude hiding (id, (.)) -import Data.Utils.Analytic -import Data.Utils.Matrix -import Data.Utils.Random -import Data.Utils.Vector - --- | A @'Layer' i o@ is a component that maps a 'Vector' of length @i@ to a 'Vector' of length @o@. --- -type Layer i o = Component (Vector i) (Vector o) - -linearLayer' :: forall i o s. Analytic s => ParamFun s (Matrix o (i + 1)) (Vector i s) (Vector o s) -linearLayer' = ParamFun $ \xs ws -> ws <%%> cons 1 xs - --- | Creates a /linear/ 'Layer', i.e. a layer that multiplies the input with a weight 'Matrix' and adds a bias to get the output. --- --- Random initialization follows the recommendation from chapter 3 of the online book --- <http://neuralnetworksanddeeplearning.com/ Neural Networks and Deep Learning> by Michael Nielsen. -linearLayer :: forall i o. (KnownNat i, KnownNat o) => Layer i o -linearLayer = withNatOp (%+) p (Proxy :: Proxy 1) Component - { weights = pure 0 - , compute = linearLayer' - , initR = sequenceA $ mgenerate r - } - - where - - p = Proxy :: Proxy i - - s = 1 / sqrt (fromIntegral $ natVal p) - - r (_, 0) = boxMuller - r (_, _) = boxMuller' 0 s - --- | Creates a 'Layer' as a combination of a linear layer and a non-linear activation function. --- -layer :: (KnownNat i, KnownNat o) => Diff' -> Layer i o -layer f = cArr (diff f) . linearLayer - --- | This is a simple 'Layer', specialized to 'tanh'-activation. Output values are all in the interval [0,1]. --- -tanhLayer :: (KnownNat i, KnownNat o) => Layer i o -tanhLayer = layer tanh - --- | This is a simple 'Layer', specialized to the logistic function as activation. Output values are all in the interval [-1,1]. --- -logisticLayer :: (KnownNat i, KnownNat o) => Layer i o -logisticLayer = layer $ \x -> 1 / (1 + exp (- x)) - --- | This is a simple 'Layer', specialized to the /rectified linear unit/ activation function. --- Output values are all non-negative. --- -reLULayer :: (KnownNat i, KnownNat o) => Layer i o -reLULayer = layer $ \x -> max 0 x - --- | The 'softmax' function normalizes a vector, so that all entries are in [0,1] with sum 1. --- This means the output entries can be interpreted as probabilities. --- -softmax :: (Floating a, Functor f, Foldable f) => f a -> f a -softmax xs = let xs' = exp <$> xs - s = sum xs' - in (/ s) <$> xs' +{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++{-|+Module : Numeric.Neural.Layer+Description : layer components+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This modules defines special "layer" components and convenience functions for the creation of such layers.+-}++module Numeric.Neural.Layer+ ( Layer+ , linearLayer+ , layer+ , tanhLayer+ , tanhLayer'+ , logisticLayer+ , reLULayer+ , softmax+ ) where++import Control.Category+import Data.FixedSize+import Data.Proxy+import Data.Utils.Analytic+import Data.Utils.Random+import GHC.TypeLits+import GHC.TypeLits.Witnesses+import Numeric.Neural.Model+import Prelude hiding (id, (.))++-- | A @'Layer' i o@ is a component that maps a 'Vector' of length @i@ to a 'Vector' of length @o@.+--+type Layer i o = Component (Vector i) (Vector o)++linearLayer' :: forall i o s. Analytic s => ParamFun s (Matrix o (i + 1)) (Vector i s) (Vector o s)+linearLayer' = ParamFun $ \xs ws -> ws <%%> cons 1 xs++-- | Creates a /linear/ 'Layer', i.e. a layer that multiplies the input with a weight 'Matrix' and adds a bias to get the output.+--+-- Random initialization follows the recommendation from chapter 3 of the online book+-- <http://neuralnetworksanddeeplearning.com/ Neural Networks and Deep Learning> by Michael Nielsen.+linearLayer :: forall i o. (KnownNat i, KnownNat o) => Layer i o+linearLayer = withNatOp (%+) p (Proxy :: Proxy 1) Component+ { weights = pure 0+ , compute = linearLayer'+ , initR = sequenceA $ generate r+ }++ where++ p = Proxy :: Proxy i++ s = 1 / sqrt (fromIntegral $ natVal p)++ r (_, 0) = boxMuller+ r (_, _) = boxMuller' 0 s++-- | Creates a 'Layer' as a combination of a linear layer and a non-linear activation function.+--+layer :: (KnownNat i, KnownNat o) => Diff' -> Layer i o+layer f = cArr (diff f) . linearLayer++-- | This is a simple 'Layer', specialized to 'tanh'-activation. Output values are all in the interval [-1,1].+--+tanhLayer :: (KnownNat i, KnownNat o) => Layer i o+tanhLayer = layer tanh+++-- | This is a simple 'Layer', specialized to a modified 'tanh'-activation, following the suggestion from+-- <http://yann.lecun.com/exdb/publis/pdf/lecun-98b.pdf Efficient BackProp> by LeCun et al., where+-- output values are all in the interval [-1.7159,1.7159].+tanhLayer' :: (KnownNat i, KnownNat o) => Layer i o+tanhLayer' = layer $ \x -> 1.7159 * tanh (2 * x / 3)++-- | This is a simple 'Layer', specialized to the logistic function as activation. Output values are all in the interval [0,1].+--+logisticLayer :: (KnownNat i, KnownNat o) => Layer i o+logisticLayer = layer $ \x -> 1 / (1 + exp (- x))++-- | This is a simple 'Layer', specialized to the /rectified linear unit/ activation function.+-- Output values are all non-negative.+--+reLULayer :: (KnownNat i, KnownNat o) => Layer i o+reLULayer = layer $ \x -> max 0 x++-- | The 'softmax' function normalizes a vector, so that all entries are in [0,1] with sum 1.+-- This means the output entries can be interpreted as probabilities.+--+softmax :: (Floating a, Functor f, Foldable f) => f a -> f a+softmax xs = let xs' = exp <$> xs+ s = sum xs'+ in (/ s) <$> xs'
src/Numeric/Neural/Model.hs view
@@ -1,313 +1,294 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-# LANGUAGE Arrows #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-| -Module : Neural.Model -Description : "neural" components and models -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This module defines /parameterized functions/, /components/ and /models/. -The parameterized functions are instances of the 'Arrow' and 'ArrowChoice' typeclasses, whereas -'Component's behave like 'Arrow's with choice over a different base category -(the category 'Diff' of differentiable functions). -Both parameterized functions and components can be combined easily and flexibly. - -/Models/ contain a component, can measure their error with regard to samples and can be trained by gradient descent/ -backpropagation. --} - -module Numeric.Neural.Model - ( ParamFun(..) - , Component(..) - , _weights - , activate - , _component - , Pair(..) - , FEither(..) - , Convolve(..) - , cArr - , cFirst - , cLeft - , cConvolve - , Model(..) - , model - , modelR - , modelError - , descent - , StdModel - , mkStdModel - ) where - -import Control.Applicative -import Control.Arrow -import Control.Category -import Control.Monad.Par (runPar) -import Control.Monad.Par.Combinator (parMapReduceRange, InclusiveRange(..)) -import Data.Profunctor -import Data.MyPrelude -import Prelude hiding (id, (.)) -import Data.Utils.Analytic -import Data.Utils.Arrow -import Data.Utils.Statistics (mean) -import Data.Utils.Traversable - --- | The type @'ParamFun' t a b@ describes parameterized functions from @a@ to @b@, where the --- parameters are of type @t s@. --- When such components are composed, they all share the /same/ parameters. --- -newtype ParamFun s t a b = ParamFun { runPF :: a -> t s -> b } - -instance Category (ParamFun s t) where - - id = arr id - - ParamFun f . ParamFun g = ParamFun $ \x ts -> f (g x ts) ts - -instance Arrow (ParamFun s t) where - - arr f = ParamFun (\x _ -> f x) - - first (ParamFun f) = ParamFun $ \(x, y) ts -> (f x ts, y) - -instance ArrowChoice (ParamFun s t) where - - left (ParamFun f) = ParamFun $ \ex ts -> case ex of - Left x -> Left (f x ts) - Right y -> Right y - -instance ArrowConvolve (ParamFun s t) where - - convolve (ParamFun f) = ParamFun $ \xs ts -> flip f ts <$> xs - -instance Functor (ParamFun s t a) where fmap = fmapArr - -instance Applicative (ParamFun s t a) where pure = pureArr; (<*>) = apArr - -instance Profunctor (ParamFun s t) where dimap = dimapArr - --- | A @'Component' f g@ is a parameterized differentiable function @f Double -> g Double@. --- In contrast to 'ParamFun', when components are composed, parameters are not shared. --- Each component carries its own collection of parameters instead. --- -data Component f g = forall t. (Traversable t, Applicative t, NFData (t Double)) => Component - { weights :: t Double -- ^ the specific parameter values - , compute :: forall s. Analytic s => ParamFun s t (f s) (g s) -- ^ the encapsulated parameterized function - , initR :: forall m. MonadRandom m => m (t Double) -- ^ randomly sets the parameters - } - --- | A 'Lens'' to get or set the weights of a component. --- The shape of the parameter collection is hidden by existential quantification, --- so this lens has to use simple generic lists. --- -_weights:: Lens' (Component f g) [Double] -_weights = lens (\(Component ws _ _) -> toList ws) - (\(Component _ c i) ws -> let Just ws' = fromList ws in Component ws' c i) - --- | Activates a component, i.e. applies it to the specified input, using the current parameter values. --- -activate :: Component f g -> f Double -> g Double -activate (Component ws f _) xs = runPF f xs ws - -data Empty a = Empty deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable) - -instance Applicative Empty where - - pure = const Empty - - Empty <*> Empty = Empty - -instance NFData (Empty a) where - - rnf Empty = () - --- | The analogue for pairs in the category of functors. --- -data Pair s t a = Pair (s a) (t a) deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable) - -instance (NFData (s a), NFData (t a)) => NFData (Pair s t a) where - - rnf (Pair xs ys) = rnf xs `seq` rnf ys `seq` () - -instance (Applicative s, Applicative t) => Applicative (Pair s t) where - - pure x = Pair (pure x) (pure x) - - Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y) - -instance Category Component where - - id = cArr id - - Component ws c i . Component ws' c' i' = Component - { weights = Pair ws ws' - , compute = ParamFun $ \x (Pair zs zs') -> runPF c (runPF c' x zs') zs - , initR = Pair <$> i <*> i' - } - --- | The analogue of 'Control.Arrow.arr' for 'Component's. --- -cArr :: Diff f g -> Component f g -cArr (Diff f) = Component - { weights = Empty - , compute = arr f - , initR = return Empty - } - --- | The analogue of 'Control.Arrow.first' for 'Component's. --- -cFirst :: Component f g -> Component (Pair f h) (Pair g h) -cFirst (Component ws c i) = Component - { weights = ws - , compute = ParamFun $ \(Pair xs ys) ws' -> Pair (runPF c xs ws') ys - , initR = i - } - --- | The analogue for 'Either' in the category of functors. --- -data FEither f g a = FLeft (f a) | FRight (g a) - deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable) - --- | The analogue of 'Control.Arrow.left' for 'Component's. --- -cLeft :: Component f g -> Component (FEither f h) (FEither g h) -cLeft (Component ws c i) = Component - { weights = ws - , compute = ParamFun $ \es ws' -> case es of - FLeft xs -> FLeft $ runPF c xs ws' - FRight ys -> FRight ys - , initR = i - } - --- | Composition of functors. --- -data Convolve f g a = Convolve (f (g a)) - deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable) - --- | The analogue of 'convolve' for 'Component's. --- -cConvolve :: Functor h => Component f g -> Component (Convolve h f) (Convolve h g) -cConvolve (Component ws c i) = Component - { weights = ws - , compute = ParamFun $ \(Convolve xss) ws' -> Convolve $ flip (runPF c) ws' <$> xss - , initR = i - } - -instance NFData (Component f g) where - - rnf (Component ws _ _) = rnf ws - - --- | A @'Model' f g a b c@ wraps a @'Component' f g@ --- and models functions @b -> c@ with "samples" (for model error determination) --- of type @a@. --- -data Model :: (* -> *) -> (* -> *) -> * -> * -> * -> * where - - Model :: (Functor f, Functor g) - => Component f g - -> (a -> (f Double, Diff g Identity)) - -> (b -> f Double) - -> (g Double -> c) - -> Model f g a b c - -instance Profunctor (Model f g a) where - - dimap m n (Model c e i o) = Model c e (i . m) (n . o) - -instance NFData (Model f g a b c) where - - rnf (Model c _ _ _) = rnf c - --- | A 'Lens' for accessing the component embedded in a model. --- -_component :: Lens' (Model f g a b c) (Component f g) -_component = lens (\(Model c _ _ _) -> c) - (\(Model _ e i o) c -> Model c e i o) - --- | Computes the modelled function. -model :: Model f g a b c -> b -> c -model (Model c _ i o) = o . activate c . i - --- | Generates a model with randomly initialized weights. All other properties are copied from the provided model. -modelR :: MonadRandom m => Model f g a b c -> m (Model f g a b c) -modelR (Model c e i o) = case c of - Component _ f r -> do - ws <- r - return $ Model (Component ws f r) e i o - -errFun :: forall f t a g. Functor f - => (a -> (f Double, Diff g Identity)) - -> a - -> (forall s. Analytic s => ParamFun s t (f s) (g s)) - -> Diff t Identity -errFun e x f = Diff $ runPF f' x where - - f' :: forall s. Analytic s => ParamFun s t a (Identity s) - f' = proc z -> do - let (x', Diff h) = e z - x'' = fromDouble <$> x' - y <- f -< x'' - returnA -< h y - -modelError' :: Model f g a b c -> a -> Double -modelError' (Model c e _ _) x = case c of - Component ws f _ -> let f' = errFun e x f - in runIdentity $ runDiff f' ws - --- | Calculates the avarage model error for a "mini-batch" of samples. --- -modelError :: Foldable h => Model f g a b c -> h a -> Double -modelError m xs = mean $ modelError' m <$> toList xs - --- | Performs one step of gradient descent/ backpropagation on the model, -descent :: (Foldable h) - => Model f g a b c -- ^ the model whose error should be decreased - -> Double -- ^ the learning rate - -> h a -- ^ a mini-batch of samples - -> (Double, Model f g a b c) -- ^ returns the average sample error and the improved model -descent (Model c e i o) eta xs = case c of - Component ws f r -> - let xs' = toList xs - l = length xs' - l' = fromIntegral l - scale = eta / l' - q j = do - let x = xs' !! j - (err', g') = gradWith' (\_ dw -> scale * dw) (errFun e x f) ws - return (err' / l', g') - s (err', g') (err'', g'') = return (err' + err'', (+) <$> g' <*> g'') - (err, ws') = runPar $ parMapReduceRange (InclusiveRange 0 $ pred l) q s (0, pure 0) - ws'' = (-) <$> ws <*> ws' - c' = Component ws'' f r - m = Model c' e i o - in (err, m) - --- | A type abbreviation for the most common type of models, where samples are just input-output tuples. -type StdModel f g b c = Model f g (b, c) b c - --- | Creates a 'StdModel', using the simplifying assumtion that the error can be computed from the expected --- output allone. --- -mkStdModel :: (Functor f, Functor g) - => Component f g - -> (c -> Diff g Identity) - -> (b -> f Double) - -> (g Double -> c) - -> StdModel f g b c -mkStdModel c e i o = Model c e' i o where - - e' (x, y) = (i x, e y) +{-# OPTIONS_HADDOCK show-extensions #-}++{-# OPTIONS_GHC -Wno-orphans #-}++{-# LANGUAGE Arrows #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-|+Module : Numeric.Neural.Model+Description : "neural" components and models+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module defines /parameterized functions/, /components/ and /models/.+The parameterized functions are instances of the 'Arrow' and 'ArrowChoice' typeclasses, whereas+'Component's behave like 'Arrow's with choice over a different base category+(the category 'Diff' of differentiable functions).+Both parameterized functions and components can be combined easily and flexibly.++/Models/ contain a component, can measure their error with regard to samples and can be trained by gradient descent/+backpropagation.+-}++module Numeric.Neural.Model+ ( ParamFun(..)+ , Component(..)+ , _weights+ , activate+ , cArr+ , cFirst+ , cLeft+ , cConvolve+ , Model(..)+ , _component+ , model+ , modelR+ , modelError+ , descent+ , StdModel+ , mkStdModel+ ) where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Monad.Par (runPar)+import Control.Monad.Par.Combinator (parMapReduceRange, InclusiveRange(..))+import Data.Functor.Compose (Compose(..))+import Data.Functor.Product (Product(..))+import Data.Functor.Sum (Sum(..))+import Data.Profunctor+import Data.MyPrelude+import Prelude hiding (id, (.))+import Data.Utils.Analytic+import Data.Utils.Arrow+import Data.Utils.Statistics (mean)+import Data.Utils.Traversable++-- | The type @'ParamFun' s t a b@ describes parameterized functions from @a@ to @b@, where the+-- parameters are of type @t s@.+-- When such components are composed, they all share the /same/ parameters.+--+newtype ParamFun s t a b = ParamFun { runPF :: a -> t s -> b }++instance Category (ParamFun s t) where++ id = arr id++ ParamFun f . ParamFun g = ParamFun $ \x ts -> f (g x ts) ts++instance Arrow (ParamFun s t) where++ arr f = ParamFun (\x _ -> f x)++ first (ParamFun f) = ParamFun $ \(x, y) ts -> (f x ts, y)++instance ArrowChoice (ParamFun s t) where++ left (ParamFun f) = ParamFun $ \ex ts -> case ex of+ Left x -> Left (f x ts)+ Right y -> Right y++instance ArrowConvolve (ParamFun s t) where++ convolve (ParamFun f) = ParamFun $ \xs ts -> flip f ts <$> xs++instance Functor (ParamFun s t a) where fmap = fmapArr++instance Applicative (ParamFun s t a) where pure = pureArr; (<*>) = apArr++instance Profunctor (ParamFun s t) where dimap = dimapArr++-- | A @'Component' f g@ is a parameterized differentiable function @f Double -> g Double@.+-- In contrast to 'ParamFun', when components are composed, parameters are not shared.+-- Each component carries its own collection of parameters instead.+--+data Component f g = forall t. (Traversable t, Applicative t, NFData (t Double)) => Component+ { weights :: t Double -- ^ the specific parameter values+ , compute :: forall s. Analytic s => ParamFun s t (f s) (g s) -- ^ the encapsulated parameterized function+ , initR :: forall m. MonadRandom m => m (t Double) -- ^ randomly sets the parameters+ }++-- | A 'Lens'' to get or set the weights of a component.+-- The shape of the parameter collection is hidden by existential quantification,+-- so this lens has to use simple generic lists.+--+_weights:: Lens' (Component f g) [Double]+_weights = lens (\(Component ws _ _) -> toList ws)+ (\(Component _ c i) ws -> let Just ws' = fromList ws in Component ws' c i)++-- | Activates a component, i.e. applies it to the specified input, using the current parameter values.+--+activate :: Component f g -> f Double -> g Double+activate (Component ws f _) xs = runPF f xs ws++data Empty a = Empty deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)++instance Applicative Empty where++ pure = const Empty++ Empty <*> Empty = Empty++instance NFData (Empty a) where++ rnf Empty = ()++instance (NFData (s a), NFData (t a)) => NFData (Product s t a) where++ rnf (Pair xs ys) = rnf xs `seq` rnf ys `seq` ()++instance Category Component where++ id = cArr id++ Component ws c i . Component ws' c' i' = Component+ { weights = Pair ws ws'+ , compute = ParamFun $ \x (Pair zs zs') -> runPF c (runPF c' x zs') zs+ , initR = Pair <$> i <*> i'+ }++-- | The analogue of 'Control.Arrow.arr' for 'Component's.+--+cArr :: Diff f g -> Component f g+cArr (Diff f) = Component+ { weights = Empty+ , compute = arr f+ , initR = return Empty+ }++-- | The analogue of 'Control.Arrow.first' for 'Component's.+--+cFirst :: Component f g -> Component (Product f h) (Product g h)+cFirst (Component ws c i) = Component+ { weights = ws+ , compute = ParamFun $ \(Pair xs ys) ws' -> Pair (runPF c xs ws') ys+ , initR = i+ }++-- | The analogue of 'Control.Arrow.left' for 'Component's.+--+cLeft :: Component f g -> Component (Sum f h) (Sum g h)+cLeft (Component ws c i) = Component+ { weights = ws+ , compute = ParamFun $ \es ws' -> case es of+ InL xs -> InL $ runPF c xs ws'+ InR ys -> InR ys+ , initR = i+ }++-- | The analogue of 'convolve' for 'Component's.+--+cConvolve :: Functor h => Component f g -> Component (Compose h f) (Compose h g)+cConvolve (Component ws c i) = Component+ { weights = ws+ , compute = ParamFun $ \(Compose xss) ws' -> Compose $ flip (runPF c) ws' <$> xss+ , initR = i+ }++instance NFData (Component f g) where++ rnf (Component ws _ _) = rnf ws++-- | A @'Model' f g a b c@ wraps a @'Component' f g@+-- and models functions @b -> c@ with "samples" (for model error determination)+-- of type @a@.+--+data Model :: (* -> *) -> (* -> *) -> * -> * -> * -> * where++ Model :: (Functor f, Functor g)+ => Component f g+ -> (a -> (f Double, Diff g Identity))+ -> (b -> f Double)+ -> (g Double -> c)+ -> Model f g a b c++instance Profunctor (Model f g a) where++ dimap m n (Model c e i o) = Model c e (i . m) (n . o)++instance NFData (Model f g a b c) where++ rnf (Model c _ _ _) = rnf c++-- | A 'Lens' for accessing the component embedded in a model.+--+_component :: Lens' (Model f g a b c) (Component f g)+_component = lens (\(Model c _ _ _) -> c)+ (\(Model _ e i o) c -> Model c e i o)++-- | Computes the modelled function.+model :: Model f g a b c -> b -> c+model (Model c _ i o) = o . activate c . i++-- | Generates a model with randomly initialized weights. All other properties are copied from the provided model.+modelR :: MonadRandom m => Model f g a b c -> m (Model f g a b c)+modelR (Model c e i o) = case c of+ Component _ f r -> do+ ws <- r+ return $ Model (Component ws f r) e i o++errFun :: forall f t a g. Functor f+ => (a -> (f Double, Diff g Identity))+ -> a+ -> (forall s. Analytic s => ParamFun s t (f s) (g s))+ -> Diff t Identity+errFun e x f = Diff $ runPF f' x where++ f' :: forall s. Analytic s => ParamFun s t a (Identity s)+ f' = proc z -> do+ let (x', Diff h) = e z+ x'' = fromDouble <$> x'+ y <- f -< x''+ returnA -< h y++modelError' :: Model f g a b c -> a -> Double+modelError' (Model c e _ _) x = case c of+ Component ws f _ -> let f' = errFun e x f+ in runIdentity $ runDiff f' ws++-- | Calculates the avarage model error for a "mini-batch" of samples.+--+modelError :: Foldable h => Model f g a b c -> h a -> Double+modelError m xs = mean $ modelError' m <$> toList xs++-- | Performs one step of gradient descent/ backpropagation on the model,+descent :: (Foldable h)+ => Model f g a b c -- ^ the model whose error should be decreased+ -> Double -- ^ the learning rate+ -> h a -- ^ a mini-batch of samples+ -> (Double, Model f g a b c) -- ^ returns the average sample error and the improved model+descent (Model c e i o) eta xs = case c of+ Component ws f r ->+ let xs' = toList xs+ l = length xs'+ l' = fromIntegral l+ scale = eta / l'+ q j = do+ let x = xs' !! j+ (err', g') = gradWith' (\_ dw -> scale * dw) (errFun e x f) ws+ return (err' / l', g')+ s (err', g') (err'', g'') = return (err' + err'', (+) <$> g' <*> g'')+ (err, ws') = runPar $ parMapReduceRange (InclusiveRange 0 $ pred l) q s (0, pure 0)+ ws'' = (-) <$> ws <*> ws'+ c' = Component ws'' f r+ m = Model c' e i o+ in (err, m)++-- | A type abbreviation for the most common type of models, where samples are just input-output tuples.+type StdModel f g b c = Model f g (b, c) b c++-- | Creates a 'StdModel', using the simplifying assumtion that the error can be computed from the expected+-- output allone.+--+mkStdModel :: (Functor f, Functor g)+ => Component f g+ -> (c -> Diff g Identity)+ -> (b -> f Double)+ -> (g Double -> c)+ -> StdModel f g b c+mkStdModel c e i o = Model c e' i o where++ e' (x, y) = (i x, e y)
src/Numeric/Neural/Normalization.hs view
@@ -1,190 +1,192 @@-{-# OPTIONS_HADDOCK show-extensions #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE BangPatterns #-} - -{-| -Module : Numeric.Neural.Normalization -Description : normalizing data -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This modules provides utilities for data normalization. --} - -module Numeric.Neural.Normalization - ( encode1ofN - , decode1ofN - , encodeEquiDist - , decodeEquiDist - , crossEntropyError - , white - , whiten - , Classifier - , mkStdClassifier - ) where - -import Control.Arrow (first) -import Control.Category -import Data.Proxy -import GHC.TypeLits -import GHC.TypeLits.Witnesses -import Data.MyPrelude -import Data.Utils.Analytic -import Data.Utils.Statistics -import Data.Utils.Traversable -import Data.Utils.Vector -import Numeric.Neural.Layer -import Numeric.Neural.Model -import Prelude hiding (id, (.)) - --- | Provides "1 of @n@" encoding for enumerable types. --- --- >>> :set -XDataKinds --- >>> encode1ofN LT :: Vector 3 Int --- [1,0,0] --- --- >>> encode1ofN EQ :: Vector 3 Int --- [0,1,0] --- --- >>> encode1ofN GT :: Vector 3 Int --- [0,0,1] --- -encode1ofN :: (Enum a, Num b, KnownNat n) => a -> Vector n b -encode1ofN x = generate $ \i -> if i == fromEnum x then 1 else 0 - --- | Provides "1 of @n@" decoding for enumerable types. --- --- >>> decode1ofN [0.9, 0.3, 0.1 :: Double] :: Ordering --- LT --- --- >>> decode1ofN [0.7, 0.8, 0.6 :: Double] :: Ordering --- EQ --- --- >>> decode1ofN [0.2, 0.3, 0.8 :: Double] :: Ordering --- GT --- -decode1ofN :: (Enum a, Ord b, Foldable f) => f b -> a -decode1ofN = toEnum . fst . maximumBy (compare `on` snd) . zip [0..] . toList - -polyhedron :: Floating a => Int -> [[a]] -polyhedron = fst . p - - where - - p 2 = ([[-1], [1]], 2) - p n = let (xs, d) = p (n - 1) - y = sqrt (d * d - 1) - v = y : replicate (n - 2) 0 - xs' = v : ((0 :) <$> xs) - shift = y / fromIntegral n - shifted = (\(z : zs) -> (z - shift : zs)) <$> xs' - scale = 1 / (y - shift) - scaled = ((scale *) <$>) <$> shifted - in (scaled, d * scale) - -polyhedron' :: forall a n. (Floating a, KnownNat n) => Proxy n -> [[a]] -polyhedron' p = withNatOp (%+) p (Proxy :: Proxy 1) $ - polyhedron (fromIntegral $ natVal (Proxy :: Proxy (n + 1))) - --- | Provides equidistant encoding for enumerable types. --- --- >>> :set -XDataKinds --- >>> encodeEquiDist LT :: Vector 2 Float --- [1.0,0.0] --- --- >>> encodeEquiDist EQ :: Vector 2 Float --- [-0.5,-0.86602545] --- --- >>> encodeEquiDist GT :: Vector 2 Float --- [-0.5,0.86602545] --- -encodeEquiDist :: forall a b n. (Enum a, Floating b, KnownNat n) => a -> Vector n b -encodeEquiDist x = let ys = polyhedron' (Proxy :: Proxy n) - y = ys !! fromEnum x - in fromJust (fromList y) - --- | Provides equidistant decoding for enumerable types. --- --- >>> :set -XDataKinds --- >>> let u = fromJust (fromList [0.9, 0.2]) :: Vector 2 Double --- >>> decodeEquiDist u :: Ordering --- LT --- --- >>> :set -XDataKinds --- >>> let v = fromJust (fromList [-0.4, -0.5]) :: Vector 2 Double --- >>> decodeEquiDist v :: Ordering --- EQ --- --- >>> :set -XDataKinds --- >>> let w = fromJust (fromList [0.1, 0.8]) :: Vector 2 Double --- >>> decodeEquiDist w :: Ordering --- GT --- -decodeEquiDist :: forall a b n. (Enum a, Ord b, Floating b, KnownNat n) => Vector n b -> a -decodeEquiDist y = let xs = polyhedron' (Proxy :: Proxy n) - xs' = (fromJust . fromList) <$> xs - ds = [(j, sqDiff x y) | (j, x) <- zip [0..] xs'] - i = fst $ minimumBy (compare `on` snd) ds - in toEnum i - --- | Computes the cross entropy error (assuming "1 of n" encoding). --- --- >>> runDiff (crossEntropyError LT) (cons 0.8 (cons 0.1 (cons 0.1 nil))) :: Identity Double --- Identity 0.2231435513142097 --- --- >>> runDiff (crossEntropyError EQ) (cons 0.8 (cons 0.1 (cons 0.1 nil))) :: Identity Double --- Identity 2.3025850929940455 --- -crossEntropyError :: (Enum a, KnownNat n) => a -> Diff (Vector n) Identity -crossEntropyError a = Diff $ \ys -> Identity $ negate $ log $ encode1ofN a <%> ys - --- | Function 'white' takes a batch of values (of a specific shape) --- and computes a normalization function which whitens values of that shape, --- so that each component has zero mean and unit variance. --- --- >>> :set -XDataKinds --- >>> let xss = [cons 1 (cons 1 nil), cons 1 (cons 2 nil), cons 1 (cons 3 nil)] :: [Vector 2 Double] --- >>> let f = white xss --- >>> f <$> xss --- [[0.0,-1.2247448713915887],[0.0,0.0],[0.0,1.2247448713915887]] -white :: (Applicative f, Traversable t, Eq a, Floating a) => t (f a) -> f a -> f a -white xss = ((w <$> sequenceA xss) <*>) where - - w xs = case toList xs of - [] -> id - xs' -> let (_, !m, !v) = countMeanVar xs' - !s = if v == 0 then 1 else 1 / sqrt v - in \x -> (x - m) * s - --- | Modifies a 'Model' by whitening the input before feeding it into the embedded component. --- -whiten :: (Applicative f, Traversable t) - => Model f g a b c -- ^ original model - -> t b -- ^ batch of input data - -> Model f g a b c -whiten (Model c e i o) xss = Model c e' i' o where - - w = white $ i <$> xss - - i' = w . i - - e' = first w . e - --- | A @'Classifier' f n b c@ is a 'Model' that classifies items of type @b@ into categories of type @c@, --- using a component with input shape @f@ and output shape @'Vector' n@. --- -type Classifier f n b c = StdModel f (Vector n) b c - --- | Makes a standard 'Classifier' which uses a softmax layer, "1 of n" encoding and the cross entropy error. --- -mkStdClassifier :: (Functor f, KnownNat n, Enum c) - => Component f (Vector n) -- ^ the embedded component - -> (b -> f Double) -- ^ converts input - -> Classifier f n b c -mkStdClassifier c i = mkStdModel (cArr (Diff softmax) . c) crossEntropyError i decode1ofN +{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE BangPatterns #-}++{-|+Module : Numeric.Neural.Normalization+Description : normalizing data+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This modules provides utilities for data normalization.+-}++module Numeric.Neural.Normalization+ ( encode1ofN+ , decode1ofN+ , encodeEquiDist+ , decodeEquiDist+ , crossEntropyError+ , white+ , whiten+ , Classifier+ , mkStdClassifier+ ) where++import Control.Arrow (first)+import Control.Category+import Data.FixedSize+import Data.Proxy+import GHC.TypeLits+import GHC.TypeLits.Witnesses+import Data.MyPrelude+import Data.Utils.Analytic+import Data.Utils.Statistics+import Data.Utils.Traversable+import Numeric.Neural.Layer+import Numeric.Neural.Model+import Prelude hiding (id, (.))++-- | Provides "1 of @n@" encoding for enumerable types.+--+-- >>> :set -XDataKinds+-- >>> encode1ofN LT :: Vector 3 Int+-- [1,0,0]+--+-- >>> encode1ofN EQ :: Vector 3 Int+-- [0,1,0]+--+-- >>> encode1ofN GT :: Vector 3 Int+-- [0,0,1]+--+encode1ofN :: (Enum a, Num b, KnownNat n) => a -> Vector n b+encode1ofN x = generate $ \i -> if i == fromEnum x then 1 else 0++-- | Provides "1 of @n@" decoding for enumerable types.+--+-- >>> decode1ofN [0.9, 0.3, 0.1 :: Double] :: Ordering+-- LT+--+-- >>> decode1ofN [0.7, 0.8, 0.6 :: Double] :: Ordering+-- EQ+--+-- >>> decode1ofN [0.2, 0.3, 0.8 :: Double] :: Ordering+-- GT+--+decode1ofN :: (Enum a, Ord b, Foldable f) => f b -> a+decode1ofN = toEnum . fst . maximumBy (compare `on` snd) . zip [0..] . toList++polyhedron :: Floating a => Int -> [[a]]+polyhedron = fst . p++ where++ p 2 = ([[-1], [1]], 2)+ p n = let (xs, d) = p (n - 1)+ y = sqrt (d * d - 1)+ v = y : replicate (n - 2) 0+ xs' = v : ((0 :) <$> xs)+ shift = y / fromIntegral n+ shifted = (\(z : zs) -> (z - shift : zs)) <$> xs'+ scale = 1 / (y - shift)+ scaled = ((scale *) <$>) <$> shifted+ in (scaled, d * scale)++polyhedron' :: forall a n. (Floating a, KnownNat n) => Proxy n -> [[a]]+polyhedron' p = withNatOp (%+) p (Proxy :: Proxy 1) $+ polyhedron (fromIntegral $ natVal (Proxy :: Proxy (n + 1)))++-- | Provides equidistant encoding for enumerable types.+--+-- >>> :set -XDataKinds+-- >>> encodeEquiDist LT :: Vector 2 Float+-- [1.0,0.0]+--+-- >>> encodeEquiDist EQ :: Vector 2 Float+-- [-0.5,-0.86602545]+--+-- >>> encodeEquiDist GT :: Vector 2 Float+-- [-0.5,0.86602545]+--+encodeEquiDist :: forall a b n. (Enum a, Floating b, KnownNat n) => a -> Vector n b+encodeEquiDist x = let ys = polyhedron' (Proxy :: Proxy n)+ y = ys !! fromEnum x+ in fromJust (fromList y)++-- | Provides equidistant decoding for enumerable types.+--+-- >>> :set -XDataKinds+-- >>> let u = fromJust (fromList [0.9, 0.2]) :: Vector 2 Double+-- >>> decodeEquiDist u :: Ordering+-- LT+--+-- >>> :set -XDataKinds+-- >>> let v = fromJust (fromList [-0.4, -0.5]) :: Vector 2 Double+-- >>> decodeEquiDist v :: Ordering+-- EQ+--+-- >>> :set -XDataKinds+-- >>> let w = fromJust (fromList [0.1, 0.8]) :: Vector 2 Double+-- >>> decodeEquiDist w :: Ordering+-- GT+--+decodeEquiDist :: forall a b n. (Enum a, Ord b, Floating b, KnownNat n) => Vector n b -> a+decodeEquiDist y = let xs = polyhedron' (Proxy :: Proxy n)+ xs' = (fromJust . fromList) <$> xs+ ds = [(j, sqDiff x y) | (j, x) <- zip [0..] xs']+ i = fst $ minimumBy (compare `on` snd) ds+ in toEnum i++-- | Computes the cross entropy error (assuming "1 of n" encoding).+-- To avoid @'log' 0@, values are first shifted into the interval [0.01, 0.99].+--+-- >>> runDiff (crossEntropyError LT) (cons 0.8 (cons 0.1 (cons 0.1 nil))) :: Identity Double+-- Identity 0.23067181773500128+--+-- >>> runDiff (crossEntropyError EQ) (cons 0.8 (cons 0.1 (cons 0.1 nil))) :: Identity Double+-- Identity 2.2256240518579173+--+crossEntropyError :: (Enum a, KnownNat n) => a -> Diff (Vector n) Identity+crossEntropyError a = Diff $ \ys -> Identity $ negate $ log $ (\y -> 0.98 * y + 0.01) $ encode1ofN a <%> ys++-- | Function 'white' takes a batch of values (of a specific shape)+-- and computes a normalization function which whitens values of that shape,+-- so that each component has zero mean and unit variance.+--+-- >>> :set -XDataKinds+-- >>> let xss = [cons 1 (cons 1 nil), cons 1 (cons 2 nil), cons 1 (cons 3 nil)] :: [Vector 2 Double]+-- >>> let f = white xss+-- >>> f <$> xss+-- [[0.0,-1.2247448713915887],[0.0,0.0],[0.0,1.2247448713915887]]+white :: (Applicative f, Traversable t, Eq a, Floating a) => t (f a) -> f a -> f a+white xss = ((w <$> sequenceA xss) <*>) where++ w xs = case toList xs of+ [] -> id+ xs' -> let (_, !m, !v) = countMeanVar xs'+ !s = if v == 0 then 1 else 1 / sqrt v+ in \x -> (x - m) * s++-- | Modifies a 'Model' by whitening the input before feeding it into the embedded component.+--+whiten :: (Applicative f, Traversable t)+ => Model f g a b c -- ^ original model+ -> t b -- ^ batch of input data+ -> Model f g a b c+whiten (Model c e i o) xss = Model c e' i' o where++ w = white $ i <$> xss++ i' = w . i++ e' = first w . e++-- | A @'Classifier' f n b c@ is a 'Model' that classifies items of type @b@ into categories of type @c@,+-- using a component with input shape @f@ and output shape @'Vector' n@.+--+type Classifier f n b c = StdModel f (Vector n) b c++-- | Makes a standard 'Classifier' which uses a softmax layer, "1 of n" encoding and the cross entropy error.+--+mkStdClassifier :: (Functor f, KnownNat n, Enum c)+ => Component f (Vector n) -- ^ the embedded component+ -> (b -> f Double) -- ^ converts input+ -> Classifier f n b c+mkStdClassifier c i = mkStdModel (cArr (Diff softmax) . c) crossEntropyError i decode1ofN
src/Numeric/Neural/Pipes.hs view
@@ -1,92 +1,166 @@-{-# OPTIONS_HADDOCK show-extensions #-} - -{-# LANGUAGE BangPatterns #-} - -{-| -Module : Numeric.Neural.Pipes -Description : a pipes API for models -Copyright : (c) Lars Brünjes, 2016 -License : MIT -Maintainer : brunjlar@gmail.com -Stability : experimental -Portability : portable - -This modules provides a "pipes"-based API for working with models. --} - -module Numeric.Neural.Pipes - ( TS(..) - , descentP - , simpleBatchP - , reportTSP - , consumeTSP - , module Pipes - ) where - -import Data.MyPrelude -import Numeric.Neural.Model -import Data.Utils.Random (takeR) -import Pipes -import qualified Pipes.Prelude as P - --- | The training state of a model. --- -data TS f g a b c = TS - { tsModel :: Model f g a b c -- ^ updated model - , tsGeneration :: Int -- ^ generation - , tsEta :: Double -- ^ learning rate - , tsBatchError :: Double -- ^ last training error - } - --- | A 'Pipe' for training a model: It consumes mini-batches of samples from upstream and pushes --- the updated training state downstream. --- -descentP :: (Foldable h, Monad m) => - Model f g a b c -- ^ initial model - -> Int -- ^ first generation - -> (Int -> Double) -- ^ computes the learning rate from the generation - -> Pipe (h a) (TS f g a b c) m r -descentP m i f = loop m i where - - loop m' i' = do - xs <- await - let !eta = f i' - let (e, m'') = descent m' eta xs - m'' `deepseq` yield TS - { tsModel = m'' - , tsGeneration = i' - , tsEta = eta - , tsBatchError = e - } - loop m'' (succ i') - --- | A simple 'Producer' of mini-batches. -simpleBatchP :: MonadRandom m - => [a] -- ^ all available samples - -> Int -- ^ the mini-batch size - -> Producer [a] m r -simpleBatchP xs n = forever $ lift (takeR n xs) >>= yield - --- | A 'Pipe' for progress reporting of model training. --- -reportTSP :: Monad m - => Int -- ^ report interval - -> (TS f g a b c -> m ()) -- ^ report action - -> Pipe (TS f g a b c) (TS f g a b c) m r -reportTSP n act = P.mapM $ \ts -> do - when (tsGeneration ts `mod` n == 0) (act ts) - return ts - --- | A 'Consumer' of training states that decides when training is finished and then returns a value. --- -consumeTSP :: Monad m - => (TS f g a b c -> m (Maybe x)) -- ^ check whether training is finished and what to return in that case - -> Consumer (TS f g a b c) m x -consumeTSP check = loop where - - loop = do - ts <- await - mx <- lift (check ts) - case mx of - Just x -> return x - Nothing -> loop +{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE BangPatterns #-}++{-|+Module : Numeric.Neural.Pipes+Description : a pipes API for models+Copyright : (c) Lars Brünjes, 2016+License : MIT+Maintainer : brunjlar@gmail.com+Stability : experimental+Portability : portable++This module provides a "pipes"-based API for working with models.+-}++module Numeric.Neural.Pipes+ ( TS(..)+ , descentP+ , simpleBatchP+ , cachingBatchP+ , reportTSP+ , consumeTSP+ , qualityP+ , qualityP'+ , classifierAccuracyP+ , classifierAccuracyP'+ , module Pipes+ ) where++import Data.MyPrelude+import Numeric.Neural.Model+import Numeric.Neural.Normalization+import Data.Utils.Cache+import Data.Utils.Random (takeR)+import Pipes+import qualified Pipes.Prelude as P++-- | The training state of a model.+--+data TS f g a b c = TS+ { tsModel :: Model f g a b c -- ^ updated model+ , tsGeneration :: Int -- ^ generation+ , tsEta :: Double -- ^ learning rate+ , tsBatchError :: Double -- ^ last training error+ }++-- | A 'Pipe' for training a model: It consumes mini-batches of samples from upstream and pushes+-- the updated training state downstream.+--+descentP :: (Foldable h, Monad m) =>+ Model f g a b c -- ^ initial model+ -> Int -- ^ first generation+ -> (Int -> Double) -- ^ computes the learning rate from the generation+ -> Pipe (h a) (TS f g a b c) m r+descentP m i f = loop m i where++ loop m' i' = do+ xs <- await+ let !eta = f i'+ let (e, m'') = descent m' eta xs+ m'' `deepseq` yield TS+ { tsModel = m''+ , tsGeneration = i'+ , tsEta = eta+ , tsBatchError = e+ }+ loop m'' (succ i')++-- | A simple 'Producer' of mini-batches.+simpleBatchP :: MonadRandom m+ => [a] -- ^ all available samples+ -> Int -- ^ mini-batch size+ -> Producer [a] m r+simpleBatchP xs n = forever $ lift (takeR n xs) >>= yield++-- | Function 'simpleBatchP' only works when all available samples fit into memory.+-- If this is not the case, 'cachingBatchP' can be used instead.+-- It takes an effectful way to get specific samples and then caches some of those samples+-- in memory for a couple of rounds, drawing mini-batches from the cached values.+--+cachingBatchP :: MonadRandom m+ => ([Int] -> m [a]) -- ^ get samples with specified indices+ -> Int -- ^ number of all available samples+ -> Int -- ^ mini-batch size+ -> Int -- ^ cache size+ -> Int -- ^ number of cache reuses+ -> Producer [a] m s+cachingBatchP f ns bs cs nr = do+ let c = newCache f cs+ loop c++ where++ loop c = do+ xs <- lift $ takeR cs [0 .. pred ns]+ (ys, c') <- lift $ retrieveC c xs+ replicateM_ nr $ lift (takeR bs ys) >>= yield+ loop c'++-- | A 'Pipe' for progress reporting of model training.+--+reportTSP :: Monad m+ => Int -- ^ report interval+ -> (TS f g a b c -> m ()) -- ^ report action+ -> Pipe (TS f g a b c) (TS f g a b c) m r+reportTSP n act = P.mapM $ \ts -> do+ when (tsGeneration ts `mod` n == 0) (act ts)+ return ts++-- | A 'Consumer' of training states that decides when training is finished and then returns a value.+--+consumeTSP :: Monad m+ => (TS f g a b c -> m (Maybe x)) -- ^ check whether training is finished and what to return in that case+ -> Consumer (TS f g a b c) m x+consumeTSP check = loop where++ loop = do+ ts <- await+ mx <- lift (check ts)+ case mx of+ Just x -> return x+ Nothing -> loop++-- | Computes the average "quality" of a given 'Model' over a stream of pairs of input and expected output.+--+qualityP :: (Monad m, Fractional x)+ => Model f g a b c -- ^ the 'Model'+ -> (b -> c -> c -> x) -- ^ gives the quality for given input, expected output and actual output+ -> Producer (b, c) m r -- ^ a 'Producer' of pairs of input and expected output+ -> m (Maybe x) -- ^ the average model quality or 'Nothing' if the 'Producer' was empty.+qualityP m f p = P.fold g (0, 0 :: Int) h $ void p++ where++ g (!xs, !n) (b, c) = let c' = model m b+ x = f b c c'+ in (x + xs, succ n)++ h (_, 0) = Nothing+ h (x, n) = Just $ x / fromIntegral n++-- | Pure version of 'qualityP'.+--+qualityP' :: Fractional x+ => Model f g a b c -- ^ the 'Model'+ -> (b -> c -> c -> x) -- ^ gives the quality for given input, expected output and actual output+ -> [(b, c)] -- ^ list of pairs of input and expected output+ -> Maybe x -- ^ the average model quality or 'Nothing' if the list was empty.+qualityP' m f xs = runIdentity $ qualityP m f $ each xs++-- | Specialization of 'qualityP' to the case of 'Classifier's.+--+classifierAccuracyP :: (Monad m, Eq c, Fractional x)+ => Classifier f n b c+ -> Producer (b, c) m r+ -> m (Maybe x)+classifierAccuracyP m = qualityP m $ \_ c c' -> if c == c' then 1 else 0++-- | Pure version of 'classifierAccuracyP'.+--+classifierAccuracyP' :: (Eq c, Fractional x)+ => Classifier f n b c+ -> [(b, c)]+ -> Maybe x+classifierAccuracyP' m xs = runIdentity $ classifierAccuracyP m $ each xs
stack.yaml view
@@ -1,40 +1,10 @@-# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md - -# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -resolver: nightly-2016-06-16 - -# Local packages, usually specified by relative directory name -packages: -- '.' - -# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) -extra-deps: - - friday-0.2.2.0 - - friday-juicypixels-0.1.1 - - natural-transformation-0.3.1 - - pipes-bytestring-2.1.3 - - pipes-group-1.0.5 - - pipes-zlib-0.4.4 - - ratio-int-0.1.2 - - STMonadTrans-0.3.3 - -# Override default flag values for local packages and extra-deps -flags: {} - -# Extra package databases containing global packages -extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true - -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: >= 1.0.0 - -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 - -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] +flags: {}+extra-package-dbs: []+packages:+- .+extra-deps:+- finite-typelits-0.1.1.0+- pipes-4.2.0+- pipes-safe-2.2.4+- pipes-zlib-0.4.4.1+resolver: lts-9.0
+ test/Data/FixedSize/ClassSpec.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DataKinds #-}++module Data.FixedSize.ClassSpec (spec) where++import Test.Hspec+import Data.Utils++spec :: Spec+spec = indexSpec++indexSpec :: Spec+indexSpec = describe "(!)" $ do++ let v = cons 'x' nil+ m = generate id :: Matrix 1 2 (Int, Int)+ o = generate id :: Volume 1 2 3 (Int, Int, Int)++ it "should give the specified element if the index is valid" $ do+ v ! 0 `shouldBe` 'x'+ m ! (0, 1) `shouldBe` (0, 1)+ o ! (0, 1, 2) `shouldBe` (0, 1, 2)+++ it "should throw an exception if the index is invalid" $ do+ print (v ! 1) `shouldThrow` anyErrorCall+ print (m ! (0, 2)) `shouldThrow` anyErrorCall+ print (o ! (0, 1, 3)) `shouldThrow` anyErrorCall
+ test/Data/FixedSize/MatrixSpec.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DataKinds #-}++module Data.FixedSize.MatrixSpec (spec) where++import Test.Hspec+import Data.Utils++spec :: Spec+spec = do+ mulSpec+ rowSpec+ columnSpec+ indexSpec+ transposeSpec+ apSpec+ generateSpec++mulSpec :: Spec+mulSpec = describe "(<%%>)" $++ it "should multiply a matrix by a vector" $ do+ let v = generate succ :: Vector 3 Int+ m <%%> v `shouldBe` cons 14 (cons 32 nil)++rowSpec :: Spec+rowSpec = describe "row" $ do++ it "should give the specified row of the matrix if the index is valid" $ do+ row m 0 `shouldBe` (Just $ cons 1 (cons 2 (cons 3 nil)))+ row m 1 `shouldBe` (Just $ cons 4 (cons 5 (cons 6 nil)))++ it "should return Nothing for an invalid row index" $ do+ row m (-1) `shouldBe` Nothing+ row m 2 `shouldBe` Nothing++columnSpec :: Spec+columnSpec = describe "column" $ do++ it "should give the specified column of the matrix if the index is valid" $ do+ column m 0 `shouldBe` (Just $ cons 1 (cons 4 nil))+ column m 2 `shouldBe` (Just $ cons 3 (cons 6 nil))++ it "should return Nothing for an invalid column index" $ do+ column m (-1) `shouldBe` Nothing+ column m 3 `shouldBe` Nothing++indexSpec :: Spec+indexSpec = describe "(!?)" $ do++ it "should give the specified element of the matrix if the index is valid" $ do+ m !? (0, 0) `shouldBe` Just 1+ m !? (1, 2) `shouldBe` Just 6++ it "should return Nothing for an invalid index" $ do+ m !? (2, 0) `shouldBe` Nothing+ m !? (0, 3) `shouldBe` Nothing++transposeSpec :: Spec+transposeSpec = describe "transpose" $++ it "should transpose the matrix" $+ transpose m `shouldBe` generate (\(i, j) -> 3 * j + i + 1)++apSpec :: Spec+apSpec = describe "(<*>)" $++ it "should be component-wise application" $+ (-) <$> m <*> m `shouldBe` pure 0++generateSpec :: Spec+generateSpec = describe "generate" $++ it "should generate a matrix" $ do++ let n = generate id :: Matrix 1 2 (Int, Int)+ show n `shouldBe` "Matrix [[(0,0),(0,1)]]"++m :: Matrix 2 3 Int+m = generate $ \(i, j) -> 3 * i + j + 1 -- 1 2 3+ -- 4 5 6
+ test/Data/FixedSize/VectorSpec.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DataKinds #-}++module Data.FixedSize.VectorSpec (spec) where++import Data.MyPrelude+import Data.Utils+import Test.Hspec++spec :: Spec+spec = do+ indexSpec+ generateSpec+ spSpec+ vheadSpec+ vtailSpec+ apSpec+ toVectorSpec+ fromVectorSpec++indexSpec :: Spec+indexSpec = describe "(!?)" $ do++ it "should give the element at a specified index if that index is valid" $+ cons 1 (cons 2 nil) !? 1 `shouldBe` Just (2 :: Int)++ it "should return Nothing if the index is not valid" $+ cons 1 (cons 2 nil) !? 2 `shouldBe` (Nothing :: Maybe Int)++generateSpec :: Spec+generateSpec = describe "generate" $++ it "should generate a vector" $+ generate id `shouldBe` cons 0 (cons 1 (cons 2 nil))++spSpec :: Spec+spSpec = describe "(<%>)" $++ it "should compute the scalar product of two vectors" $ do+ let v = cons 1 (cons 2 nil)+ w = cons 3 (cons 4 nil)+ v <%> w `shouldBe` (11 :: Int)++vheadSpec :: Spec+vheadSpec = describe "vhead" $++ it "should give the head of a vector of positive length" $+ vhead (cons 1 (cons 2 nil)) `shouldBe` (1 :: Int)++vtailSpec :: Spec+vtailSpec = describe "vtail" $++ it "should give the tail of a vector of positive length" $+ vtail (cons 1 (cons 2 nil)) `shouldBe` (cons 2 nil :: Vector 1 Int)++apSpec :: Spec+apSpec = describe "(<*>)" $++ it "should be component-wise application" $ do+ let v = cons 1 (cons 2 nil) :: Vector 2 Int+ (+) <$> v <*> v `shouldBe` ((* 2) <$> v)++toVectorSpec :: Spec+toVectorSpec = describe "toVector" $ do++ it "should convert a matrix to a vector" $ do++ let m = pure 'x' :: Matrix 3 2 Char+ v = toVector m+ toList v `shouldBe` "xxxxxx"++ it "should convert a volume to a vector" $ do++ let v = pure 'x' :: Volume 1 2 3 Char+ w = toVector v+ toList w `shouldBe` "xxxxxx"+fromVectorSpec :: Spec+fromVectorSpec = describe "fromVector" $++ it "should be inverse to 'toVector'" $ do++ let v = generate id :: Volume 1 2 3 (Int, Int, Int)+ fromVector (toVector v) `shouldBe` v
+ test/Data/FixedSize/VolumeSpec.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds #-}++module Data.FixedSize.VolumeSpec (spec) where++import Test.Hspec+import Data.Utils++spec :: Spec+spec = do+ indexSpec+ generateSpec++indexSpec :: Spec+indexSpec = describe "(!?)" $ do++ let v = generate id :: Volume 1 2 3 (Int, Int, Int)++ it "should give the specified element of the volume if the index is valid" $ do+ v !? (0, 0, 0) `shouldBe` Just (0, 0, 0)+ v !? (0, 1, 2) `shouldBe` Just (0, 1, 2)++ it "should return Nothing for an invalid index" $ do+ v !? (0, 0, 3) `shouldBe` Nothing+ v !? (1, 0, 0) `shouldBe` Nothing++generateSpec :: Spec+generateSpec = describe "generate" $++ it "should generate a volume" $ do++ let v = generate id :: Volume 1 1 3 (Int, Int, Int)+ show v `shouldBe` "Volume (Matrix [[[(0,0,0),(0,0,1),(0,0,2)]]])"
+ test/Data/Utils/CacheSpec.hs view
@@ -0,0 +1,36 @@+module Data.Utils.CacheSpec (spec) where++import Test.Hspec+import Data.MyPrelude+import Data.Utils++spec :: Spec+spec = cacheSpec++cacheSpec :: Spec+cacheSpec = describe "retrieveC" $ do++ it "should retrieve uncached elements" $+ let w = do+ (xs, _) <- retrieveC mkCache [1, 2, 3]+ return xs+ in runWriter w `shouldBe` ([1, 2, 3], [1, 2, 3])++ it "should use the cache if possible" $+ let w = do+ (_, c) <- retrieveC mkCache [1, 2, 3]+ (xs, _) <- retrieveC c [3, 3, 1, 4]+ return xs+ in runWriter w `shouldBe` ([3, 3, 1, 4], [1, 2, 3, 4])++ it "should respect the cache capacity" $+ let w = do+ (_, c ) <- retrieveC mkCache [1, 2, 3]+ (_, c') <- retrieveC c [3, 3, 1, 4]+ (xs, _ ) <- retrieveC c' [4, 1]+ return xs+ in runWriter w `shouldBe` ([4, 1], [1, 2, 3, 4, 1])++mkCache :: Cache (Writer [Int]) Int Int+mkCache = newCache f 3 where+ f xs = tell xs >> return xs
test/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− test/Utils/MatrixSpec.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE DataKinds #-} - -module Utils.MatrixSpec (spec) where - -import Test.Hspec -import Data.Utils - -spec :: Spec -spec = do - mulSpec - rowSpec - columnSpec - indexSpec - transposeSpec - apSpec - -mulSpec :: Spec -mulSpec = describe "(<%%>)" $ - - it "should multiply a matrix by a vector" $ do - let v = generate succ :: Vector 3 Int - m <%%> v `shouldBe` cons 14 (cons 32 nil) - -rowSpec :: Spec -rowSpec = describe "row" $ do - - it "should give the specified row of the matrix if the index is valid" $ do - row m 0 `shouldBe` (Just $ cons 1 (cons 2 (cons 3 nil))) - row m 1 `shouldBe` (Just $ cons 4 (cons 5 (cons 6 nil))) - - it "should return Nothing for an invalid row index" $ do - row m (-1) `shouldBe` Nothing - row m 2 `shouldBe` Nothing - -columnSpec :: Spec -columnSpec = describe "column" $ do - - it "should give the specified column of the matrix if the index is valid" $ do - column m 0 `shouldBe` (Just $ cons 1 (cons 4 nil)) - column m 2 `shouldBe` (Just $ cons 3 (cons 6 nil)) - - it "should return Nothing for an invalid column index" $ do - column m (-1) `shouldBe` Nothing - column m 3 `shouldBe` Nothing - -indexSpec :: Spec -indexSpec = describe "(!!?)" $ do - - it "should give the specified element of the matrix if the index is valid" $ do - m !!? (0, 0) `shouldBe` Just 1 - m !!? (1, 2) `shouldBe` Just 6 - - it "should return Nothing for an invalid index" $ do - m !!? (2, 0) `shouldBe` Nothing - m !!? (0, 3) `shouldBe` Nothing - -transposeSpec :: Spec -transposeSpec = describe "transpose" $ - - it "should transpose the matrix" $ - transpose m `shouldBe` mgenerate (\(i, j) -> 3 * j + i + 1) - -apSpec :: Spec -apSpec = describe "(<*>)" $ - - it "should be component-wise application" $ - (-) <$> m <*> m `shouldBe` pure 0 - -m :: Matrix 2 3 Int -m = mgenerate $ \(i, j) -> 3 * i + j + 1 -- 1 2 3 - -- 4 5 6
− test/Utils/VectorSpec.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE DataKinds #-} - -module Utils.VectorSpec (spec) where - -import Test.Hspec -import Data.Utils - -spec :: Spec -spec = do - indexSpec - generateSpec - spSpec - vheadSpec - vtailSpec - apSpec - -indexSpec :: Spec -indexSpec = describe "(!?)" $ do - - it "should give the element at a specified index if that index is valid" $ - cons 1 (cons 2 nil) !? 1 `shouldBe` Just (2 :: Int) - - it "should return Nothing if the index is not valid" $ - cons 1 (cons 2 nil) !? 2 `shouldBe` (Nothing :: Maybe Int) - -generateSpec :: Spec -generateSpec = describe "generate" $ - - it "should generate a vector" $ - generate id `shouldBe` cons 0 (cons 1 (cons 2 nil)) - -spSpec :: Spec -spSpec = describe "(<%>)" $ - - it "should compute the scalar product of two vectors" $ do - let v = cons 1 (cons 2 nil) - w = cons 3 (cons 4 nil) - v <%> w `shouldBe` (11 :: Int) - -vheadSpec :: Spec -vheadSpec = describe "vhead" $ - - it "should give the head of a vector of positive length" $ - vhead (cons 1 (cons 2 nil)) `shouldBe` (1 :: Int) - -vtailSpec :: Spec -vtailSpec = describe "vtail" $ - - it "should give the tail of a vector of positive length" $ - vtail (cons 1 (cons 2 nil)) `shouldBe` (cons 2 nil :: Vector 1 Int) - -apSpec :: Spec -apSpec = describe "(<*>)" $ - - it "should be component-wise application" $ do - let v = cons 1 (cons 2 nil) :: Vector 2 Int - (+) <$> v <*> v `shouldBe` ((* 2) <$> v)