diff --git a/.ghci b/.ghci --- a/.ghci +++ b/.ghci @@ -1,1 +1,1 @@ -:set -XDataKinds +m +s +t +:set -XDataKinds +m +s +t diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,6 @@ -*.swp -.stack-work/ -dist/ -tags +*.swp +.stack-work/ +dist/ +tags +src/highlight.js +src/style.css diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,46 +1,49 @@ -# neural - Neural Nets in native Haskell - -[![Build Status](https://travis-ci.org/brunjlar/neural.svg?branch=master)](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 + +[![Build Status](https://travis-ci.org/brunjlar/neural.svg?branch=master)](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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/benchmark/benchmark.hs b/benchmark/benchmark.hs --- a/benchmark/benchmark.hs +++ b/benchmark/benchmark.hs @@ -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 diff --git a/doctest/doctest.hs b/doctest/doctest.hs --- a/doctest/doctest.hs +++ b/doctest/doctest.hs @@ -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 diff --git a/examples/MNIST/MNIST.hs b/examples/MNIST/MNIST.hs --- a/examples/MNIST/MNIST.hs +++ b/examples/MNIST/MNIST.hs @@ -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) diff --git a/examples/iris/iris.hs b/examples/iris/iris.hs --- a/examples/iris/iris.hs +++ b/examples/iris/iris.hs @@ -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)))) diff --git a/examples/sin/Graph.hs b/examples/sin/Graph.hs new file mode 100644 --- /dev/null +++ b/examples/sin/Graph.hs @@ -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) '*' diff --git a/examples/sin/sin.hs b/examples/sin/sin.hs new file mode 100644 --- /dev/null +++ b/examples/sin/sin.hs @@ -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 diff --git a/examples/sqrt/sqrt.hs b/examples/sqrt/sqrt.hs --- a/examples/sqrt/sqrt.hs +++ b/examples/sqrt/sqrt.hs @@ -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 diff --git a/neural.cabal b/neural.cabal --- a/neural.cabal +++ b/neural.cabal @@ -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 , - . - * /automatic differentiation/ for automatic gradient descent/ backpropagation training + . + * /automatic differentiation/ for automatic gradient descent/ backpropagation training (using Edward Kmett's fabulous 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 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 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 diff --git a/src/Data/FixedSize.hs b/src/Data/FixedSize.hs new file mode 100644 --- /dev/null +++ b/src/Data/FixedSize.hs @@ -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 diff --git a/src/Data/FixedSize/Class.hs b/src/Data/FixedSize/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/FixedSize/Class.hs @@ -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) diff --git a/src/Data/FixedSize/Matrix.hs b/src/Data/FixedSize/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/Data/FixedSize/Matrix.hs @@ -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) diff --git a/src/Data/FixedSize/Vector.hs b/src/Data/FixedSize/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Data/FixedSize/Vector.hs @@ -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 +-- 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 diff --git a/src/Data/FixedSize/Volume.hs b/src/Data/FixedSize/Volume.hs new file mode 100644 --- /dev/null +++ b/src/Data/FixedSize/Volume.hs @@ -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 diff --git a/src/Data/MyPrelude.hs b/src/Data/MyPrelude.hs --- a/src/Data/MyPrelude.hs +++ b/src/Data/MyPrelude.hs @@ -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) diff --git a/src/Data/Utils.hs b/src/Data/Utils.hs --- a/src/Data/Utils.hs +++ b/src/Data/Utils.hs @@ -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 diff --git a/src/Data/Utils/Analytic.hs b/src/Data/Utils/Analytic.hs --- a/src/Data/Utils/Analytic.hs +++ b/src/Data/Utils/Analytic.hs @@ -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) diff --git a/src/Data/Utils/Arrow.hs b/src/Data/Utils/Arrow.hs --- a/src/Data/Utils/Arrow.hs +++ b/src/Data/Utils/Arrow.hs @@ -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 diff --git a/src/Data/Utils/Cache.hs b/src/Data/Utils/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Data/Utils/Cache.hs @@ -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') diff --git a/src/Data/Utils/List.hs b/src/Data/Utils/List.hs --- a/src/Data/Utils/List.hs +++ b/src/Data/Utils/List.hs @@ -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 diff --git a/src/Data/Utils/Matrix.hs b/src/Data/Utils/Matrix.hs deleted file mode 100644 --- a/src/Data/Utils/Matrix.hs +++ /dev/null @@ -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) diff --git a/src/Data/Utils/Pipes.hs b/src/Data/Utils/Pipes.hs --- a/src/Data/Utils/Pipes.hs +++ b/src/Data/Utils/Pipes.hs @@ -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 diff --git a/src/Data/Utils/Random.hs b/src/Data/Utils/Random.hs --- a/src/Data/Utils/Random.hs +++ b/src/Data/Utils/Random.hs @@ -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 --- 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 --- 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 +-- 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 +-- 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 diff --git a/src/Data/Utils/Stack.hs b/src/Data/Utils/Stack.hs --- a/src/Data/Utils/Stack.hs +++ b/src/Data/Utils/Stack.hs @@ -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 diff --git a/src/Data/Utils/Statistics.hs b/src/Data/Utils/Statistics.hs --- a/src/Data/Utils/Statistics.hs +++ b/src/Data/Utils/Statistics.hs @@ -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 --- . --- --- >>> 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 --- --- 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 +-- . +-- +-- >>> 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 +-- +-- 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 diff --git a/src/Data/Utils/Traversable.hs b/src/Data/Utils/Traversable.hs --- a/src/Data/Utils/Traversable.hs +++ b/src/Data/Utils/Traversable.hs @@ -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 diff --git a/src/Data/Utils/Vector.hs b/src/Data/Utils/Vector.hs deleted file mode 100644 --- a/src/Data/Utils/Vector.hs +++ /dev/null @@ -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) diff --git a/src/Numeric/Neural.hs b/src/Numeric/Neural.hs --- a/src/Numeric/Neural.hs +++ b/src/Numeric/Neural.hs @@ -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 diff --git a/src/Numeric/Neural/Convolution.hs b/src/Numeric/Neural/Convolution.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Neural/Convolution.hs @@ -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) diff --git a/src/Numeric/Neural/Layer.hs b/src/Numeric/Neural/Layer.hs --- a/src/Numeric/Neural/Layer.hs +++ b/src/Numeric/Neural/Layer.hs @@ -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 --- 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 +-- 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 +-- 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' diff --git a/src/Numeric/Neural/Model.hs b/src/Numeric/Neural/Model.hs --- a/src/Numeric/Neural/Model.hs +++ b/src/Numeric/Neural/Model.hs @@ -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) diff --git a/src/Numeric/Neural/Normalization.hs b/src/Numeric/Neural/Normalization.hs --- a/src/Numeric/Neural/Normalization.hs +++ b/src/Numeric/Neural/Normalization.hs @@ -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 diff --git a/src/Numeric/Neural/Pipes.hs b/src/Numeric/Neural/Pipes.hs --- a/src/Numeric/Neural/Pipes.hs +++ b/src/Numeric/Neural/Pipes.hs @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/test/Data/FixedSize/ClassSpec.hs b/test/Data/FixedSize/ClassSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/FixedSize/ClassSpec.hs @@ -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 diff --git a/test/Data/FixedSize/MatrixSpec.hs b/test/Data/FixedSize/MatrixSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/FixedSize/MatrixSpec.hs @@ -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 diff --git a/test/Data/FixedSize/VectorSpec.hs b/test/Data/FixedSize/VectorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/FixedSize/VectorSpec.hs @@ -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 diff --git a/test/Data/FixedSize/VolumeSpec.hs b/test/Data/FixedSize/VolumeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/FixedSize/VolumeSpec.hs @@ -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)]]])" diff --git a/test/Data/Utils/CacheSpec.hs b/test/Data/Utils/CacheSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Utils/CacheSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Utils/MatrixSpec.hs b/test/Utils/MatrixSpec.hs deleted file mode 100644 --- a/test/Utils/MatrixSpec.hs +++ /dev/null @@ -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 diff --git a/test/Utils/VectorSpec.hs b/test/Utils/VectorSpec.hs deleted file mode 100644 --- a/test/Utils/VectorSpec.hs +++ /dev/null @@ -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)