neural 0.1.1.0 → 0.2.0.0

raw patch · 22 files changed

+595/−172 lines, 22 filesdep +JuicyPixelsdep +bytestringdep +criteriondep ~neuralnew-component:exe:MNISTPVP ok

version bump matches the API change (PVP)

Dependencies added: JuicyPixels, bytestring, criterion, kan-extensions, monad-par, monad-par-extras, pipes-bytestring, pipes-safe, pipes-zlib, reflection

Dependency ranges changed: neural

API changes (from Hackage documentation)

Files

• .ghci +1/−1
• .gitignore +1/−0
• README.markdown +18/−3
• benchmark/benchmark.hs +79/−0
• examples/MNIST/MNIST.hs +89/−0
• examples/iris/iris.hs +3/−5
• examples/sqrt/sqrt.hs +5/−4
• neural.cabal +46/−7
• src/Data/MyPrelude.hs +4/−4
• src/Data/Utils.hs +2/−0
• src/Data/Utils/Analytic.hs +50/−31
• src/Data/Utils/List.hs +14/−0
• src/Data/Utils/Matrix.hs +20/−1
• src/Data/Utils/Pipes.hs +61/−0
• src/Data/Utils/Statistics.hs +3/−1
• src/Data/Utils/Traversable.hs +1/−13
• src/Data/Utils/Vector.hs +6/−2
• src/Numeric/Neural/Layer.hs +10/−10
• src/Numeric/Neural/Model.hs +139/−74
• src/Numeric/Neural/Normalization.hs +35/−14
• src/Numeric/Neural/Pipes.hs +4/−2
• stack.yaml +4/−0

@@ -1,1 +1,1 @@-:set -XDataKinds
+:set -XDataKinds +m +s +t

@@ -1,3 +1,4 @@ *.swp
 .stack-work/
 dist/
+tags

@@ -2,6 +2,8 @@ 
 [![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.
@@ -21,11 +23,24 @@ 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 implement the
+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, using a multitude of
-available combinators or [arrow notation](http://downloads.haskell.org/~ghc/8.0.1/docs/html/users_guide/glasgow_exts.html#arrow-notation).
+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.

@@ -0,0 +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

@@ -0,0 +1,89 @@+{-# 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, MonadIO m) => FilePath -> Producer Word8 m ()
+bytes f = decompress (fromFile f) >-> toWord8
+
+labels :: (MonadSafe m, MonadIO m) => FilePath -> Producer Digit m ()
+labels f = bytes f >-> P.drop 8 >-> P.map (toEnum . fromIntegral)
+
+images :: (MonadSafe m, MonadIO 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, MonadIO 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)

@@ -73,9 +73,7 @@ 
     f l = let Right x = parseOnly sampleParser l in x
 
-irisModel :: StdModel (Vector 4) (Vector 3) Attributes Iris
-irisModel = mkStdModel
-    ((tanhLayer :: Layer 4 2) >>> tanhLayer >>^ softmax)
-    crossEntropyError
+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)))) 
-    decode1ofN

@@ -2,11 +2,12 @@ 
 module Main where
 
-import Control.Arrow        hiding (loop)
+import Control.Category      
 import Control.Monad.Random
 import Data.MyPrelude
-import Numeric.Neural
 import Data.Utils
+import Numeric.Neural
+import Prelude              hiding (id, (.))
 
 main :: IO ()
 main = do
@@ -30,8 +31,8 @@ 
     sqrtModel :: StdModel (Vector 1) (Vector 1) Double Double
     sqrtModel = mkStdModel
-        ((tanhLayer :: Layer 1 2) >>> linearLayer)
-        (sqDiff . pure . fromDouble)
+        (linearLayer . (tanhLayer :: Layer 1 2))
+        (\x -> Diff $ Identity . sqDiff (pure $ fromDouble x))
         pure 
         vhead
 

@@ -1,5 +1,5 @@ name: neural-version: 0.1.1.0+version: 0.2.0.0 cabal-version: >=1.10 build-type: Simple license: MIT@@ -15,8 +15,7 @@     .     Features include     .-    * /composability/ via-    <https://hackage.haskell.org/package/base-4.9.0.0/docs/Control-Arrow.html Arrow> instances and+    * /composability/ via arrow-like instances and     <https://hackage.haskell.org/package/pipes pipes>,     .     * /automatic differentiation/ for automatic gradient descent/ backpropagation training@@ -25,13 +24,16 @@     The idea is to be able to easily define new components and wire them up in flexible, possibly     complicated ways (convolutional deep networks etc.).     .-    Two examples are included as proof of concept:+    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     <https://en.wikipedia.org/wiki/Iris_flower_data_set Iris flower> problem.     .+    * A first (still simple) neural network for recognizing handwritten digits from the equally famous+    <https://en.wikipedia.org/wiki/MNIST_database MNIST> database.+    .     The library is still very much experimental at this point. category: Machine Learning author: Lars Bruenjes@@ -47,6 +49,11 @@     type: git     location: https://github.com/brunjlar/neural.git +source-repository this+    type: git+    location: https://github.com/brunjlar/neural.git+    tag: 0.1.1.0+ library     exposed-modules:         Numeric.Neural@@ -60,6 +67,7 @@         Data.Utils.Arrow         Data.Utils.List         Data.Utils.Matrix+        Data.Utils.Pipes         Data.Utils.Random         Data.Utils.Stack         Data.Utils.Statistics@@ -69,17 +77,24 @@         base >=4.7 && <5,         ad >=4.3.2 && <4.4,         array >=0.5.1.0 && <0.6,+        bytestring >=0.10.6.0 && <0.11,         deepseq >=1.4.1.1 && <1.5,         directory >=1.2.2.0 && <1.3,         filepath >=1.4.0.0 && <1.5,         ghc-typelits-natnormalise >=0.4.1 && <0.5,         hspec >=2.2.2 && <2.3,+        kan-extensions >=4.2.3 && <4.3,         lens ==4.13.*,         MonadRandom >=0.4.2.2 && <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.8 && <4.2,+        pipes-bytestring >=2.1.1 && <2.2,+        pipes-safe >=2.2.3 && <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.4.2.0 && <0.5,@@ -94,7 +109,7 @@     build-depends:         base >=4.7 && <5,         attoparsec >=0.13.0.1 && <0.14,-        neural >=0.1.1.0 && <0.2,+        neural >=0.2.0.0 && <0.3,         text >=1.2.2.1 && <1.3     default-language: Haskell2010     hs-source-dirs: examples/iris@@ -105,11 +120,24 @@     build-depends:         base >=4.7 && <5,         MonadRandom >=0.4.2.2 && <0.5,-        neural >=0.1.1.0 && <0.2+        neural >=0.2.0.0 && <0.3     default-language: Haskell2010     hs-source-dirs: examples/sqrt     ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math +executable MNIST+    main-is: MNIST.hs+    build-depends:+        base >=4.7 && <5,+        array >=0.5.1.0 && <0.6,+        JuicyPixels >=3.2.7 && <3.3,+        neural >=0.2.0.0 && <0.3,+        pipes >=4.1.8 && <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+ test-suite neural-test     type: exitcode-stdio-1.0     main-is: Spec.hs@@ -117,7 +145,7 @@         base >=4.7 && <5,         hspec >=2.2.2 && <2.3,         MonadRandom >=0.4.2.2 && <0.5,-        neural >=0.1.1.0 && <0.2+        neural >=0.2.0.0 && <0.3     default-language: Haskell2010     hs-source-dirs: test     other-modules:@@ -133,4 +161,15 @@         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++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.2.0.0 && <0.3+    default-language: Haskell2010+    hs-source-dirs: benchmark     ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math

@@ -13,12 +13,12 @@ -}
 
 module Data.MyPrelude
-    ( NFData(..)
+    ( NFData(..), deepseq, force
     , (&), (^.), (.~), Lens', Getter, to, lens
     , when, unless, forM, forM_, void, replicateM, forever, guard
     , Identity(..)
     , MonadIO(..)
-    , MonadRandom, getRandom, getRandomR, RandT, runRandT, evalRandT, StdGen, mkStdGen
+    , MonadRandom, getRandom, getRandomR, Rand, RandT, runRand, evalRand, runRandT, evalRandT, StdGen, mkStdGen
     , MonadState(..)
     , lift
     , State, StateT, modify, runState, evalState, execState, runStateT, evalStateT, execStateT
@@ -36,12 +36,12 @@     , printf
     ) where
 
-import Control.DeepSeq            (NFData(..))
+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, RandT, runRandT, evalRandT, StdGen, mkStdGen)
+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)

@@ -16,6 +16,7 @@     ( 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
@@ -26,6 +27,7 @@ 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

@@ -1,6 +1,8 @@ {-# OPTIONS_HADDOCK show-extensions #-}
 
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 {-|
 Module      : Data.Utils.Analytic
@@ -11,48 +13,65 @@ Stability   : experimental
 Portability : portable
 
-This module defines the numeric type 'Analytic', which has "built in differentiation".
+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
-    , fromDouble
-    , fromAnalytic
-    , gradient
+    ( Analytic(..)
+    , Diff(..)
+    , Diff'
+    , diff
+    , gradWith'
     ) where
 
-import qualified Numeric.AD.Rank1.Kahn    as K
-import qualified Numeric.AD.Internal.Kahn as K
+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, (.))
 
--- | The numeric type 'Analytic' is a wrapper around Edward Kmett's @'K.Kahn' Double@ type.
---   Using functions from Analytics to Analytics, we automatically get numerically exact gradients.
---   An number of type 'Analytic' is conceptionally a 'Double' together with an infinitesimal component.
+-- | Class 'Analytic' is a helper class for defining differentiable functions.
 --
-newtype Analytic = Analytic { toKahn :: K.Kahn Double }
-    deriving (Show, Num, Eq, Floating, Fractional, Ord, Real, RealFloat, RealFrac)
+class (Floating a, Ord a) => Analytic a where
 
--- | Converts a 'Double' to an 'Analytic' without infinitesimal component.
---
-fromDouble :: Double -> Analytic
-fromDouble = Analytic . K.auto
+    fromDouble :: Double -> a
 
--- | Tries to convert an 'Analytic' to a 'Double'.
---   This conversion will work if the 'Analytic' has no infinitesimal component.
+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.
 --
-fromAnalytic :: Analytic -> Maybe Double
-fromAnalytic x = case toKahn x of
-    K.Kahn (K.Lift y) -> Just y
-    _                 -> Nothing
+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. 
 --
--- >>> gradient (\_ d -> d) (\[x, y] -> x * x + 3 * y + 7) [2, 1]
+-- >>> gradWith' (\_ d -> d) (Diff $ \[x, y] -> Identity $ x * x + 3 * y + 7) [2, 1]
 -- (14.0,[4.0,3.0])
 --
-gradient :: Traversable t 
-            => (Double -> Double -> a)  -- ^ how to combine argument and gradient
-            -> (t Analytic -> Analytic) -- ^ analytic function 
-            -> t Double                 -- ^ function argument
-            -> (Double, t a)            -- ^ function value and combination of argument and gradient
-gradient c f = K.gradWith' c f' where
-    f' = toKahn . f . fmap Analytic
+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)

@@ -30,10 +30,13 @@     , 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.
 --
@@ -171,3 +174,14 @@ 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

@@ -7,6 +7,7 @@ {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 {-|
 Module      : Data.Utils.Matrix
@@ -27,6 +28,7 @@     , column
     , mgenerate
     , (!!?)
+    , (!!!)
     , transpose
     ) where
 
@@ -37,7 +39,7 @@ -- | @'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)
+    deriving (Eq, Show, Functor, Foldable, Traversable, NFData)
 
 instance (KnownNat m, KnownNat n) => Applicative (Matrix m n) where
 
@@ -105,6 +107,23 @@ --
 (!!?) :: 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
+--
+-- >>> m !!! (5, 7)
+-- *** Exception: Data.Utils.Matrix.!!!: invalid index
+--
+(!!!) :: Matrix m n a -> (Int, Int) -> a
+m !!! (i, j) = fromMaybe (error "Data.Utils.Matrix.!!!: invalid index") (m !!? (i, j))
 
 -- | Transposes a matrix.
 --

@@ -0,0 +1,61 @@+{-# 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, MonadIO 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

@@ -36,7 +36,9 @@ 
 -- | A type for representing probabilities.
 --
-newtype Probability a = Probability { fromProbability :: a } 
+newtype Probability a = Probability 
+    { fromProbability :: a -- ^ the wrapped number 
+    } 
     deriving (Show, Read, Eq, Ord, Num, NFData, Functor)
 
 -- | Smart constructor for probabilities.

@@ -14,15 +14,14 @@ 
 module Data.Utils.Traversable
     ( fromList
-    , safeHead
     ) where
 
-import Data.MyPrelude
 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)
 --
@@ -31,14 +30,3 @@ --
 fromList :: (Applicative t, Traversable t) => [a] -> Maybe (t a)
 fromList xs = sequenceA $ evalStack (sequenceA $ pure pop) xs
-
--- | 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

@@ -79,6 +79,10 @@                         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
@@ -86,7 +90,7 @@ -- 11
 --
 (<%>) :: Num a => Vector n a -> Vector n a -> a
-xs <%> ys = sum $ zipWith (*) (toList xs) (toList ys)
+Vector v <%> Vector w = V.sum $ V.zipWith (*) v w
 
 -- | The vector of length zero.
 nil :: Vector 0 a
@@ -129,7 +133,7 @@ -- *** Exception: Data.Utils.Vector.!: invalid index 
 --
 (!) :: Vector n a -> Int -> a
-v ! i = fromMaybe (error "Data.Utils.Vector.!: invalid index")   (v !? i)
+v ! i = fromMaybe (error "Data.Utils.Vector.!: invalid index") (v !? i)
 
 -- | Gets the first element of a vector of length greater than zero.
 --

@@ -3,6 +3,7 @@ {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
 
 {-|
 Module      : Numeric.Neural.Layer
@@ -26,7 +27,6 @@     , softmax
     ) where
 
-import Control.Arrow
 import Control.Category
 import Data.Proxy
 import GHC.TypeLits
@@ -38,14 +38,14 @@ 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 @j@.
+-- | 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 Analytic) (Vector o Analytic)
+type Layer i o = Component (Vector i) (Vector o)
 
-linearLayer' :: ParamFun (Matrix o (i + 1)) (Vector i Analytic) (Vector o Analytic)
+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.
+-- | Creates a /linear/ 'Layer', i.e. a layer that multiplies the input with a weight 'Matrix' and adds a bias to get the output.
 --   
 --   Random initialization follows the recommendation from chapter 3 of the online book 
 --   <http://neuralnetworksanddeeplearning.com/ Neural Networks and Deep Learning> by Michael Nielsen.
@@ -67,20 +67,20 @@ 
 -- | Creates a 'Layer' as a combination of a linear layer and a non-linear activation function.
 --
-layer :: (KnownNat i, KnownNat o) => (Analytic -> Analytic) -> Layer i o
-layer f = arr (fmap f) . linearLayer
+layer :: (KnownNat i, KnownNat o) => Diff' -> Layer i o
+layer f = cArr (diff f) . linearLayer
 
--- | This is simply 'layer', specialized to 'tanh'-activation. Output values are all in the interval [0,1].
+-- | 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 simply 'layer', specialized to the logistic function as activation. Output values are all in the interval [-1,1].
+-- | 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 simply 'layer', specialized to the /rectified linear unit/ activation function. 
+-- | 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

@@ -1,13 +1,16 @@ {-# OPTIONS_HADDOCK show-extensions #-}
 
+{-# LANGUAGE Arrows #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveFoldable #-}
 {-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE Arrows #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 {-|
 Module      : Neural.Model
@@ -18,8 +21,11 @@ Stability   : experimental
 Portability : portable
 
-This module defines /parameterized functions/, /components/ and /models/. The parameterized functions and components
-are instances of the 'Arrow' typeclass and can therefore be combined easily and flexibly. 
+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.
@@ -30,8 +36,15 @@     , Component(..)
     , _weights
     , activate
-    , Model(..)
     , _component
+    , Pair(..)
+    , FEither(..)
+    , Convolve(..)
+    , cArr
+    , cFirst
+    , cLeft
+    , cConvolve
+    , Model(..)
     , model
     , modelR
     , modelError
@@ -40,72 +53,75 @@     , 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 Prelude                      hiding (id, (.))
 import Data.Utils.Analytic
 import Data.Utils.Arrow
-import Data.Utils.Statistics  (mean)
+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 'Analytic'@.
+--   parameters are of type @t s@.
 --   When such components are composed, they all share the /same/ parameters.
 --
-newtype ParamFun t a b = ParamFun { runPF :: a -> t Analytic -> b }
+newtype ParamFun s t a b = ParamFun { runPF :: a -> t s -> b }
 
-instance Category (ParamFun t) where
+instance Category (ParamFun s t) where
 
     id = arr id
 
     ParamFun f . ParamFun g = ParamFun $ \x ts -> f (g x ts) ts
 
-instance Arrow (ParamFun t) where
+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 t) where
+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 t) where
+instance ArrowConvolve (ParamFun s t) where
 
     convolve (ParamFun f) = ParamFun $ \xs ts -> flip f ts <$> xs
 
-instance Functor (ParamFun t a) where fmap = fmapArr
+instance Functor (ParamFun s t a) where fmap = fmapArr
 
-instance Applicative (ParamFun t a) where pure = pureArr; (<*>) = apArr
+instance Applicative (ParamFun s t a) where pure = pureArr; (<*>) = apArr
 
-instance Profunctor (ParamFun t) where dimap  = dimapArr
+instance Profunctor (ParamFun s t) where dimap  = dimapArr
 
--- | A @'Component' a b@ is a parameterized function from @a@ to @b@, combined with /some/ collection of analytic parameters,
+-- | 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 a b = forall t. (Traversable t, Applicative t) => Component
-    { weights :: t Double                                -- ^ the specific parameter values
-    , compute :: ParamFun t a b                          -- ^ the encapsulated parameterized function
-    , initR   :: forall m. MonadRandom m => m (t Double) -- ^ randomly sets the parameters
+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 a b) [Double]
-_weights= lens (\(Component ws _ _)    -> toList ws)
-               (\(Component _  c i) ws -> let Just ws' = fromList ws in Component ws' c i)
+_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 a b -> a -> b
-activate (Component ws f _) x = runPF f x $ fromDouble <$> ws
+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)
 
@@ -115,8 +131,18 @@ 
     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)
@@ -125,7 +151,7 @@ 
 instance Category Component where
 
-    id = arr id
+    id = cArr id
 
     Component ws c i . Component ws' c' i' = Component
         { weights = Pair ws ws'
@@ -133,60 +159,89 @@         , initR   = Pair <$> i <*> i'
         }
 
-instance Arrow Component where
+-- | 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
+    }
 
-    arr 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
+    }
 
-    first (Component ws c i) = Component
-        { weights = ws
-        , compute = first c
-        , 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)
 
-instance ArrowChoice Component where
+-- | 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
+    }
 
-    left (Component ws c i) = Component ws (left c) i
+-- | Composition of functors.
+--
+data Convolve f g a = Convolve (f (g a))
+    deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
 
-instance ArrowConvolve Component where
+-- | 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
+    }
 
-    convolve (Component ws c i) = Component ws (convolve c) i
+instance NFData (Component f g) where
 
-instance Functor (Component a) where fmap = fmapArr
+    rnf (Component ws _ _) = rnf ws
 
-instance Applicative (Component a) where pure = pureArr; (<*>) = apArr
 
-instance Profunctor Component where dimap = dimapArr
-
--- | A @'Model' f g a b c@ wraps a @'Component' (f 'Analytic') (g 'Analytic')@
+-- | 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 Analytic) (g Analytic)
-             -> (a -> (f Double, g Analytic -> Analytic)) 
-             -> (b -> f Double)                          
-             -> (g Double -> c)                         
+    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 Analytic) (g Analytic))
+_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) = activate $ i ^>> fmap fromDouble ^>> c >>^ fmap (fromJust . fromAnalytic) >>^ o
+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)
@@ -195,28 +250,29 @@         ws <- r
         return $ Model (Component ws f r) e i o
 
-errFun :: (Functor f, Foldable h, Traversable t)
-          => (a -> (f Double, g Analytic -> Analytic))
-          -> h a
-          -> ParamFun t (f Analytic) (g Analytic)
-          -> (t Analytic -> Analytic)
-errFun e xs f = runPF f' xs where
-
-    f' = toList ^>> convolve f'' >>^ mean
+errFun :: forall f t a g. (Functor f, Traversable t)
+          => (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'' = proc x -> do
-        let (x', h) = e x
-            x''     = fromDouble <$> x'
+    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 (Model c e _ _) xs = case c of
-    Component ws f _ -> let f'  = errFun e xs f
-                            f'' = fromJust . fromAnalytic . f' . fmap fromDouble
-                        in  f'' ws
+modelError m xs = mean $ modelError' m <$> toList xs
 
 -- | Performs one step of gradient descent/ backpropagation on the model,
 descent :: (Foldable h)
@@ -226,10 +282,19 @@            -> (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 f' = errFun e xs f
-            (err, ws') = gradient (\w dw -> w - eta * dw) f' ws
-            c'         = Component ws' f r
-            m          = Model c' e i o
+        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.
@@ -239,8 +304,8 @@ --   output allone.
 --
 mkStdModel :: (Functor f, Functor g) 
-              => Component (f Analytic) (g Analytic)
-              -> (c -> g Analytic -> Analytic)
+              => Component f g
+              -> (c -> Diff g Identity)
               -> (b -> f Double)
               -> (g Double -> c)
               -> StdModel f g b c

@@ -3,6 +3,7 @@ {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE BangPatterns #-}
 
 {-|
 Module      : Numeric.Neural.Normalization
@@ -24,9 +25,12 @@     , crossEntropyError
     , white
     , whiten
+    , Classifier
+    , mkStdClassifier
     ) where
 
-import Control.Arrow
+import Control.Arrow          (first)
+import Control.Category
 import Data.Proxy
 import GHC.TypeLits
 import GHC.TypeLits.Witnesses
@@ -35,7 +39,9 @@ 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.
 --
@@ -129,31 +135,31 @@ 
 -- | Computes the cross entropy error (assuming "1 of n" encoding).
 --
--- >>> crossEntropyError LT (cons 0.8 (cons 0.1 (cons 0.1 nil))) :: Float
--- 0.22314353
+-- >>> runDiff (crossEntropyError LT) (cons 0.8 (cons 0.1 (cons 0.1 nil))) :: Identity Double
+-- Identity 0.2231435513142097
 --
--- >>> crossEntropyError EQ (cons 0.8 (cons 0.1 (cons 0.1 nil))) :: Float
--- 2.3025851 
+-- >>> runDiff (crossEntropyError EQ) (cons 0.8 (cons 0.1 (cons 0.1 nil))) :: Identity Double
+-- Identity 2.3025850929940455
 --
-crossEntropyError :: (Enum a, Floating b, KnownNat n) => a -> Vector n b -> b
-crossEntropyError a ys = negate $ log $ encode1ofN a <%> ys
+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 Float]
+-- >>> 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.224745],[0.0,0.0],[0.0,1.224745]]
+-- [[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
+        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.
@@ -162,8 +168,23 @@           => 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
+whiten (Model c e i o) xss = Model c e' i' o where
 
-    c' = white xss' ^>> c
+    w = white $ i <$> xss
 
-    xss' = (fmap fromDouble . 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

@@ -1,5 +1,7 @@ {-# OPTIONS_HADDOCK show-extensions #-}
 
+{-# LANGUAGE BangPatterns #-}
+
 {-|
 Module      : Numeric.Neural.Pipes
 Description : a pipes API for models
@@ -48,9 +50,9 @@ 
     loop m' i' = do
         xs <- await
-        let eta = f i'
+        let !eta = f i'
         let (e, m'') = descent m' eta xs
-        yield TS
+        m'' `deepseq` yield TS
             { tsModel      = m''
             , tsGeneration = i'
             , tsEta        = eta

@@ -9,7 +9,11 @@ 
 # 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-zlib-0.4.4
+    - ratio-int-0.1.2
 
 # Override default flag values for local packages and extra-deps
 flags: {}