neural (empty) → 0.1.0.0

raw patch · 25 files changed

+2112/−0 lines, 25 filesdep +MonadRandomdep +STMonadTransdep +adsetup-changed

Dependencies added: MonadRandom, STMonadTrans, ad, array, attoparsec, base, deepseq, directory, doctest, filepath, ghc-typelits-natnormalise, hspec, lens, mtl, neural, parallel, pipes, profunctors, text, transformers, typelits-witnesses, vector

Files

LICENSE +21/−0
Setup.hs +2/−0
doctest/doctest.hs +12/−0
examples/iris/iris.hs +78/−0
examples/sqrt/sqrt.hs +45/−0
neural.cabal +106/−0
src/Data/MyPrelude.hs +59/−0
src/Data/Utils.hs +33/−0
src/Data/Utils/Analytic.hs +58/−0
src/Data/Utils/Arrow.hs +66/−0
src/Data/Utils/List.hs +173/−0
src/Data/Utils/Matrix.hs +115/−0
src/Data/Utils/Random.hs +162/−0
src/Data/Utils/Stack.hs +95/−0
src/Data/Utils/Statistics.hs +158/−0
src/Data/Utils/Traversable.hs +44/−0
src/Data/Utils/Vector.hs +189/−0
src/Numeric/Neural.hs +25/−0
src/Numeric/Neural/Layer.hs +77/−0
src/Numeric/Neural/Model.hs +242/−0
src/Numeric/Neural/Normalization.hs +133/−0
src/Numeric/Neural/Pipes.hs +90/−0
test/Spec.hs +1/−0
test/Utils/MatrixSpec.hs +71/−0
test/Utils/VectorSpec.hs +57/−0

+ LICENSE view

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

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ doctest/doctest.hs view

@@ -0,0 +1,12 @@+import Test.DocTest
+
+main :: IO ()
+main = doctest [ "src/Data/Utils/Analytic.hs"
+               , "src/Data/Utils/Matrix.hs"
+               , "src/Data/Utils/List.hs"
+               , "src/Data/Utils/Random.hs"
+               , "src/Data/Utils/Statistics.hs"
+               , "src/Data/Utils/Traversable.hs"
+               , "src/Data/Utils/Vector.hs"
+               , "src/Numeric/Neural/Normalization.hs"
+               ]

+ examples/iris/iris.hs view

@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+
+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" (length xs)
+    (g, q) <- flip evalRandT (mkStdGen 123456) $ do
+        m <- modelR irisModel
+        runEffect $
+                simpleBatchP xs 5
+            >-> descentP m 1 (\i -> 0.02 * 5000 / (5000 + fromIntegral i))
+            >-> reportTSP 1000 (report xs)
+            >-> consumeTSP (check xs)
+    printf "reached prediction accuracy of %5.3f after %d generations\n" q g
+
+  where
+
+    report xs ts = liftIO $ 
+        printf "%6d %6.4f %8.6f %6.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 :: StdModel (Vector 4) (Vector 3) Attributes Iris
+irisModel = mkStdModel
+    ((tanhLayer :: Layer 4 2) >>> tanhLayer >>^ softmax)
+    crossEntropyError
+    (\(Attributes sl sw pl pw) -> cons sl (cons sw (cons pl (cons pw nil)))) 
+    decode1ofN

+ examples/sqrt/sqrt.hs view

@@ -0,0 +1,45 @@+{-# LANGUAGE DataKinds #-}
+
+import Control.Arrow        hiding (loop)
+import Control.Monad.Random
+import Data.MyPrelude
+import Numeric.Neural
+import Data.Utils
+
+main :: IO ()
+main = do
+    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
+    
+    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
+        ((tanhLayer :: Layer 1 2) >>> linearLayer)
+        (sqDiff . pure . fromDouble)
+        pure 
+        vhead
+
+    getErr ts = let m = tsModel ts in mean [abs (sqrt x - model m x) | x <- [0, 0.1 .. 4]]
+
+    report ts = do
+        let e = getErr ts
+        liftIO $ printf "%6d %10.8f %10.8f\n" (tsGeneration ts) (tsBatchError ts) e
+
+    check ts = do
+        let e = getErr ts
+        if e < 0.015 then do
+            liftIO $ printf "\nmodel error after %d generations: %f\n\n" (tsGeneration ts)  e
+            return $ Just (tsModel ts)
+                     else return Nothing

+ neural.cabal view

@@ -0,0 +1,106 @@+name: neural+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: MIT+license-file: LICENSE+copyright: Copyright: (c) 2016 Dr. Lars Bruenjes+maintainer: brunjlar@gmail.com+homepage: http://github.com/brunjlar/neural+synopsis: Neural Networks in native Haskell+description:+    Please see README.md+category: Machine Learning+author: Lars Bruenjes++source-repository head+    type: git+    location: https://github.com/brunjlar/neural.git++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.Random+        Data.Utils.Stack+        Data.Utils.Statistics+        Data.Utils.Traversable+        Data.Utils.Vector+    build-depends:+        base >=4.7 && <5,+        ad >=4.3.2 && <4.4,+        array >=0.5.1.0 && <0.6,+        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,+        lens ==4.13.*,+        MonadRandom >=0.4.2.2 && <0.5,+        mtl >=2.2.1 && <2.3,+        parallel >=3.2.1.0 && <3.3,+        pipes >=4.1.8 && <4.2,+        profunctors ==5.2.*,+        STMonadTrans >=0.3.3 && <0.4,+        text >=1.2.2.1 && <1.3,+        transformers >=0.4.2.0 && <0.5,+        typelits-witnesses >=0.2.0.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++executable iris+    main-is: iris.hs+    build-depends:+        base >=4.7 && <5,+        attoparsec >=0.13.0.1 && <0.14,+        neural >=0.1.0.0 && <0.2,+        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++executable sqrt+    main-is: sqrt.hs+    build-depends:+        base >=4.7 && <5,+        MonadRandom >=0.4.2.2 && <0.5,+        neural >=0.1.0.0 && <0.2+    default-language: Haskell2010+    hs-source-dirs: examples/sqrt+    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+    build-depends:+        base >=4.7 && <5,+        hspec >=2.2.2 && <2.3,+        MonadRandom >=0.4.2.2 && <0.5,+        neural >=0.1.0.0 && <0.2+    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.10.1 && <0.11,+        neural >=0.1.0.0 && <0.2+    default-language: Haskell2010+    hs-source-dirs: doctest+    ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fexcess-precision -optc-O3 -optc-ffast-math

+ src/Data/MyPrelude.hs view

@@ -0,0 +1,59 @@+{-# 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(..)
+    , (&), (^.), (.~), Lens', Getter, to, lens
+    , when, unless, forM, forM_, void, replicateM, forever, guard
+    , Identity(..)
+    , MonadIO(..)
+    , MonadRandom, getRandom, getRandomR, RandT, 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(..))
+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.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)

+ src/Data/Utils.hs view

@@ -0,0 +1,33 @@+{-# 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.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.Random
+import Data.Utils.Stack
+import Data.Utils.Statistics
+import Data.Utils.Traversable
+import Data.Utils.Vector

+ src/Data/Utils/Analytic.hs view

@@ -0,0 +1,58 @@+{-# OPTIONS_HADDOCK show-extensions #-}
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+{-|
+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 type 'Analytic', which has "built in differentiation".
+-}
+
+module Data.Utils.Analytic
+    ( Analytic
+    , fromDouble
+    , fromAnalytic
+    , gradient
+    ) where
+
+import qualified Numeric.AD.Rank1.Kahn    as K
+import qualified Numeric.AD.Internal.Kahn as K
+
+-- | 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.
+--
+newtype Analytic = Analytic { toKahn :: K.Kahn Double }
+    deriving (Show, Num, Eq, Floating, Fractional, Ord, Real, RealFloat, RealFrac)
+
+-- | Converts a 'Double' to an 'Analytic' without infinitesimal component.
+--
+fromDouble :: Double -> Analytic
+fromDouble = Analytic . K.auto
+
+-- | Tries to convert an 'Analytic' to a 'Double'.
+--   This conversion will work if the 'Analytic' has no infinitesimal component.
+--
+fromAnalytic :: Analytic -> Maybe Double
+fromAnalytic x = case toKahn x of
+    K.Kahn (K.Lift y) -> Just y
+    _                 -> Nothing
+
+-- | 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]
+-- (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

+ src/Data/Utils/Arrow.hs view

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

+ src/Data/Utils/List.hs view

@@ -0,0 +1,173 @@+{-# 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
+    ) where
+
+import qualified Control.Monad.Identity as I
+import qualified Control.Monad.State    as S
+
+-- | 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

+ src/Data/Utils/Matrix.hs view

@@ -0,0 +1,115 @@+{-# OPTIONS_HADDOCK show-extensions #-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-|
+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)
+
+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)
+
+-- | Transposes a matrix.
+--
+-- >>> transpose (Matrix $ cons (cons 'a' nil) (cons (cons 'b' nil) nil))
+-- Matrix ["ab"]
+--
+transpose :: (KnownNat m, KnownNat n) => Matrix m n a -> Matrix n m a
+transpose m = mgenerate $ \(i, j) -> fromJust $ m !!? (j, i)

+ src/Data/Utils/Random.hs view

@@ -0,0 +1,162 @@+{-# OPTIONS_HADDOCK show-extensions #-}
+
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns #-}
+
+{-|
+Module      : Data.Utils.Random
+Description : random number utilities
+Copyright   : (c) Lars Brünjes, 2016
+License     : MIT
+Maintainer  : brunjlar@gmail.com
+Stability   : experimental
+Portability : portable
+
+This module provides utilities for working with module 'Control.Monad.Random'.
+-}
+
+module Data.Utils.Random
+    ( pickR'
+    , pickR
+    , takeR'
+    , takeR
+    , fisherYates
+    , shuffleR
+    , boxMuller
+    , boxMuller'
+    , roulette
+    ) where
+
+import           Control.Monad             (forM_, unless, replicateM)
+import           Control.Monad.Random
+import qualified Control.Monad.ST.Trans    as ST
+import           Control.Monad.Trans.Class (lift)
+import qualified Data.Array                as A
+import           Data.List                 (mapAccumL)
+import           Data.Utils.List           (pick)
+
+pickR'' :: MonadRandom m => Int -> [a] -> m (a, [a])
+pickR'' l xs = do
+    i <- getRandomR (0, pred l)
+    return $ pick i xs
+
+-- | Picks a random element of the list and returns that element and the remaining elements.
+--
+-- >>> evalRand (pickR' "Haskell") (mkStdGen 4712)
+-- ('s',"Hakell")
+--
+pickR' :: MonadRandom m => [a] -> m (a, [a])
+pickR' xs = pickR'' (length xs) xs
+
+-- | Picks a random element of the list.
+--
+-- >>> evalRand (pickR "Haskell") (mkStdGen 4712)
+-- 's'
+--
+pickR :: MonadRandom m => [a] -> m a
+pickR xs = fst <$> pickR' xs
+
+-- | Takes the specified number of random elements from the list.
+--   Returns those elements and the remaining elements.
+--
+-- >>> evalRand (takeR' 3 "Haskell") (mkStdGen 4712)
+-- ("aks","Hell")
+--
+takeR' :: forall m a. MonadRandom m => Int -> [a] -> m ([a], [a])
+takeR' n xs = go n (length xs) [] xs
+
+  where
+
+    go :: Int -> Int -> [a] -> [a] -> m ([a], [a])
+    go 0  _  ys zs = return (ys, zs)
+    go _  0  ys zs = return (ys, zs)
+    go !m !l ys zs = do
+        (!w, ws) <- pickR'' l zs
+        go (pred m) (pred l) (w : ys) ws
+
+-- | Takes the specified number of random elements from the list.
+--
+-- >>> evalRand (takeR 3 "Haskell") (mkStdGen 4712)
+-- "aks"
+--
+takeR :: MonadRandom m => Int -> [a] -> m [a]
+takeR n xs = fst <$> takeR' n xs
+
+-- | Shuffles an array with the
+--   < https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle Fisher-Yates algorithm>.
+--
+fisherYates :: forall m a. MonadRandom m => A.Array Int a -> m (A.Array Int a)
+fisherYates a = ST.runSTArray st where
+
+    st :: forall s. ST.STT s m (ST.STArray s Int a)
+    st = do
+        let (m, n) = A.bounds a
+        b <- ST.thawSTArray a
+        forM_ [m .. pred n] $ \i -> do
+            j <- lift $ getRandomR (i, n)
+            unless (i == j) $ do
+                x <- ST.readSTArray b i
+                y <- ST.readSTArray b j
+                ST.writeSTArray b i y
+                ST.writeSTArray b j x
+        return b
+
+-- | Shuffles an list with the
+--   < https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle Fisher-Yates algorithm>.
+--
+-- >>> evalRand (shuffleR "Haskell") (mkStdGen 4712)
+-- "skalHle"
+--
+shuffleR :: MonadRandom m => [a] -> m [a]
+shuffleR xs = A.elems <$> fisherYates (A.listArray (1, length xs) xs)
+
+-- | Uses the <https://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform Box-Muller transform>
+--   to sample the standard normal distribution (zero expectation, unit variance).
+--
+-- >>> evalRand (replicateM 5 boxMuller) (mkStdGen 1234) :: [Float]
+-- [0.61298496,-0.19325614,4.4974413e-2,-0.31926495,-1.1109064]
+--
+boxMuller :: forall m a. (Floating a, Random a, Eq a, MonadRandom m) => m a
+boxMuller = do
+    u1 <- u
+    u2 <- u
+    return $ sqrt (-2 * log u1) * cos (2 * pi * u2)
+
+  where
+
+    u :: m a
+    u = do
+        x <- getRandomR (0, 1)
+        if x == 0 then u else return x
+
+-- | Uses the <https://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform Box-Muller transform>
+--   to sample a normal distribution with specified mean and stadard deviation.
+--
+-- >>> evalRand (replicateM 5 $ boxMuller' 10 2) (mkStdGen 1234) :: [Float]
+-- [11.22597,9.613487,10.089949,9.36147,7.7781873]
+--
+boxMuller' :: (Floating a, Random a, Eq a, MonadRandom m) => a -> a -> m a
+boxMuller' m s = boxMuller >>= \x -> return $ m + s * x
+
+-- | Randomly selects the specified number of elements of a /weighted/ list.
+--
+-- >>> evalRand (roulette 10 [('x', 1 :: Double), ('y', 2)]) (mkStdGen 1000)
+-- "yxxyyyyxxy"
+--
+roulette :: forall a b m. (Ord b, Fractional b, Random b, MonadRandom m) => Int -> [(a, b)] -> m [a]
+roulette n xs = do
+    let (!s, ys) = mapAccumL f 0 xs
+        zs       = map (\(a, b) -> (a, b / s)) ys
+    replicateM n $ g zs <$> getRandomR (0, 1) 
+
+  where
+
+    f :: b -> (a, b) -> (b, (a, b))
+    f s (a, w) = let !s' = s + w in (s', (a, s'))
+
+    g :: [(a, b)] -> b -> a
+    g []             _ = error "empty list"
+    g [(a, _)]       _ = a
+    g ((a, b') : ws) b
+        | b <= b'      = a
+        | otherwise    = g ws b

+ src/Data/Utils/Stack.hs view

@@ -0,0 +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 :: Monad m => StackT s m a -> [s] -> m (a, [s])
+runStackT (StackT m) = runStateT m
+
+-- | Evaluates a computation in the @'StackT' s m@ monad.
+--
+evalStackT :: Monad m => StackT s m a -> [s] -> m a
+evalStackT m xs = fst <$> runStackT m xs
+
+-- | Executes a computation in the @'StackT' s m@ monad.
+--
+execStackT :: Monad m => StackT s m a -> [s] -> m [s]
+execStackT m xs = snd <$> runStackT m xs
+
+-- | A pure stack monad.
+--
+type Stack s = StackT s Identity
+
+-- | Runs a computation in the @'Stack' s@ monad.
+--
+runStack :: Stack s a -> [s] -> (a, [s])
+runStack m xs = runIdentity $ runStackT m xs
+
+-- | Evaluates a computation in the @'Stack' s@ monad.
+--
+evalStack :: Stack s a -> [s] -> a
+evalStack m xs = runIdentity $ evalStackT m xs
+
+-- | Executes a computation in the @'Stack' s@ monad.
+--
+execStack :: Stack s a -> [s] -> [s]
+execStack m xs = runIdentity $ execStackT m xs

+ src/Data/Utils/Statistics.hs view

@@ -0,0 +1,158 @@+{-# 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 } 
+    deriving (Show, Read, Eq, Ord, Num, NFData, Functor)
+
+-- | Smart constructor for probabilities.
+--
+-- >>> probability (0.7 :: Double)
+-- Probability {fromProbability = 0.7}
+--
+-- >>> probability (1.2 :: Double)
+-- Probability {fromProbability = 1.0}
+--
+-- >>> probability (-0.3 :: Double)
+-- Probability {fromProbability = 0.0}
+--
+probability :: RealFloat a => a -> Probability a
+probability x
+    | x < 0     = Probability 0
+    | x > 1     = Probability 1
+    | isNaN x   = Probability 0.5
+    | otherwise = Probability x
+
+-- | Returns number of elements, mean and variance of a collection of elements.
+--
+-- >>> countMeanVar [1, 2, 3, 4 :: Float]
+-- (4,2.5,1.25)
+--
+countMeanVar :: forall a. Fractional a => [a] -> (Int, a, a)
+countMeanVar xs =
+    let (n, s, q) = foldl' f (0, 0, 0) xs
+        n'        = fromIntegral n
+        m         = s / n'
+        v         = q / n' - m * m
+    in  (n, m, v)
+
+  where
+
+    f :: (Int, a, a) -> a -> (Int, a, a)
+    f (!n, !s, !q) !x = (succ n, s + x, q + x * x)
+
+-- | Calculates the mean of a collection of elements.
+--
+-- >>> mean [1 .. 5 :: Float]
+-- 3.0
+--
+mean :: forall a. Fractional a => [a] -> a
+mean xs =
+    let (n, s) = foldl' f (0, 0) xs
+        n'        = fromIntegral n
+        !m        = s / n'
+    in  m
+
+  where
+
+    f :: (Int, a) -> a -> (Int, a)
+    f (!n, !s) !x = (succ n, s + x)
+
+-- | Calculates the 
+--   <https://en.wikipedia.org/wiki/Receiver_operating_characteristic#Area_under_the_curve area under the curve>.
+--
+-- >>> auc [(1, False), (2, True), (3, False), (4, True), (5, False), (6, True), (7, True)]
+-- Probability {fromProbability = 0.75}
+--
+auc :: Ord a => [(a, Bool)] -> Probability Double
+auc = probability . auc' . map (\(a, b) -> (a, 1 :: Double, b))
+
+-- | Calculates the 
+--   <https://en.wikipedia.org/wiki/Receiver_operating_characteristic#Area_under_the_curve area under the curve>
+--   for /weighted/ samples.
+--
+-- >>> auc' [(1, (1 :: Double), False), (2, 0.5, True), (3, 1, False), (4, 1, True), (5, 1, False), (6, 1, True), (7, 1, True)]
+-- 0.8095238095238095
+--
+auc' :: forall a b. (Ord a, Fractional b) => [(a, b, Bool)] -> b
+auc' xs = let (ps , ns ) = partition third xs
+              (ps', ns') = both (normalize . sortOn (Down . fst) . map exceptThird) (ps, ns)
+              ns''       = zipWith (\(a, _) (b, b') -> (a, b, b')) ns' $ collate ns'
+          in  go 0 ps' ns''
+
+  where
+
+    third :: (c, d, e) -> e
+    third (_, _, e) = e
+
+    exceptThird :: (c, d, e) -> (c, d)
+    exceptThird (c, d, _) = (c, d)
+
+    both :: (c -> d) -> (c, c) -> (d, d)
+    both f (c, c') = (f c, f c')
+
+    normalize :: [(a, b)] -> [(a, b)]
+    normalize = f >>> g >>> h
+
+      where
+
+        f ys = let !sb = sum $ map snd ys 
+               in  map (\(a, b) -> (a, let !q = b / sb in q)) ys
+
+        g = groupBy ((==) `on` fst)
+
+        h = map (\ys@((a, _) : _) -> (a, sum $ map snd ys))
+
+    collate :: [(a, b)] -> [(b, b)]
+    collate = scanr (\(_, b) (b', b'') -> (b, b' + b'')) (0, 0)
+
+    go :: b -> [(a, b)] -> [(a, b, b)] -> b
+    go !x []                _                        = x
+    go !x _                 []                       = x 
+    go !x ps@((a, b) : ps') ns@((a', b', b'') : ns')
+        | a > a'                                     = go (x + b * (b' + b''))     ps' ns
+        | a == a'                                    = go (x + b * (b' / 2 + b'')) ps' ns' 
+        | otherwise                                  = go x                        ps  ns' 
+
+-- | Rounds a 'Double' to the specified number of decimals.
+--
+-- >>> round' 3 (2/3)
+-- 0.667
+--
+round' :: Int -> Double -> Double
+round' d x = let p = 10 ^ d
+             in  fromIntegral (round (p * x) :: Integer) / p

+ src/Data/Utils/Traversable.hs view

@@ -0,0 +1,44 @@+{-# 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
+    , 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,
+--
+-- >>> 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
+
+-- | Returns the head of a non-empty list or 'Nothing' for the empty list.
+--
+-- >>> safeHead "Haskell"
+-- Just 'H'
+--
+-- >>> safeHead ""
+-- Nothing
+--
+safeHead :: [a] -> Maybe a
+safeHead = (runIdentity <$>) . fromList

+ src/Data/Utils/Vector.hs view

@@ -0,0 +1,189 @@+{-# OPTIONS_HADDOCK show-extensions #-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+
+{-|
+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']    
+
+-- | 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
+xs <%> ys = sum $ zipWith (*) (toList xs) (toList ys)
+
+-- | 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'
+--
+-- >>> cons 'x' nil ! 1
+-- *** Exception: Data.Utils.Vector.!: invalid index 
+--
+(!) :: 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, KnownNat n) => Vector n a -> a
+sqNorm v = v <%> v
+
+-- | Calculates the /squared/ euclidean distance between two vectors of the same length.
+--
+-- >>> :set -XDataKinds
+-- >>> sqDiff (cons 1 (cons 2 nil)) (cons 3 (cons 4 nil)) :: Int
+-- 8
+--
+sqDiff :: (Num a, KnownNat n) => Vector n a -> Vector n a -> a
+sqDiff v w = sqNorm (v <-> w)

+ src/Numeric/Neural.hs view

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

+ src/Numeric/Neural/Layer.hs view

@@ -0,0 +1,77 @@+{-# OPTIONS_HADDOCK show-extensions #-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-|
+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
+    , softmax
+    ) where
+
+import Control.Arrow
+import Control.Category
+import Data.Proxy
+import GHC.TypeLits
+import GHC.TypeLits.Witnesses
+import Data.MyPrelude
+import Numeric.Neural.Model
+import Prelude                 hiding (id, (.))
+import Data.Utils.Analytic
+import Data.Utils.Matrix
+import Data.Utils.Vector
+
+-- | A @'Layer' i o@ is a component that maps a vector of length @i@ to a vector of length @j@.
+--
+type Layer i o = Component (Vector i Analytic) (Vector o Analytic)
+
+linearLayer' :: ParamFun (Matrix o (i + 1)) (Vector i Analytic) (Vector o Analytic)
+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.
+--
+linearLayer :: forall i o. (KnownNat i, KnownNat o) => Layer i o
+linearLayer = withNatOp (%+) (Proxy :: Proxy i) (Proxy :: Proxy 1) Component
+    { weights = pure 0
+    , compute = linearLayer'
+    , initR   = sequenceA $ pure $ getRandomR (-0.001, 0.001)
+    }
+
+-- | 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
+
+-- | This is simply '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].
+--
+logisticLayer :: (KnownNat i, KnownNat o) => Layer i o
+logisticLayer = layer $ \x -> 1 / (1 + exp (- x))
+
+-- | The 'softmax' function normalizes a vector, so that all entries are in [0,1] with sum 1. 
+--   This means the output entries can be interpreted as probabilities.
+--
+softmax :: (Floating a, Functor f, Foldable f) => f a -> f a
+softmax xs = let xs' = exp <$> xs
+                 s   = sum xs'
+             in  (/ s) <$> xs'

+ src/Numeric/Neural/Model.hs view

@@ -0,0 +1,242 @@+{-# OPTIONS_HADDOCK show-extensions #-}
+
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+
+{-|
+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 and components
+are instances of the 'Arrow' typeclass and can therefore 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(..)
+    , weightsLens
+    , activate
+    , Model(..)
+    , model
+    , modelR
+    , modelError
+    , descent
+    , StdModel
+    , mkStdModel
+    ) where
+
+import Control.Arrow
+import Control.Category
+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 'Analytic'@.
+--   When such components are composed, they all share the /same/ parameters.
+--
+newtype ParamFun t a b = ParamFun { runPF :: a -> t Analytic -> b }
+
+instance Category (ParamFun t) where
+
+    id = arr id
+
+    ParamFun f . ParamFun g = ParamFun $ \x ts -> f (g x ts) ts
+
+instance Arrow (ParamFun t) where
+
+    arr f = ParamFun (\x _ -> f x)
+
+    first (ParamFun f) = ParamFun $ \(x, y) ts -> (f x ts, y)
+
+instance ArrowChoice (ParamFun 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
+
+    convolve (ParamFun f) = ParamFun $ \xs ts -> flip f ts <$> xs
+
+instance Functor (ParamFun t a) where fmap = fmapArr
+
+instance Applicative (ParamFun t a) where pure = pureArr; (<*>) = apArr
+
+instance Profunctor (ParamFun t) where dimap  = dimapArr
+
+-- | A @'Model' a b@ is a parameterized function from @a@ to @b@, combined with /some/ collection of analytic parameters,
+--   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
+    }
+
+-- | 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.
+--
+weightsLens :: Lens' (Component a b) [Double]
+weightsLens = 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
+
+data Empty a = Empty deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
+
+instance Applicative Empty where
+
+    pure = const Empty
+
+    Empty <*> Empty = Empty
+
+data Pair s t a = Pair (s a) (t a) deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
+
+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 = arr 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'
+        }
+
+instance Arrow Component where
+
+    arr f = Component
+        { weights = Empty
+        , compute = arr f
+        , initR   = return Empty
+        }
+
+    first (Component ws c i) = Component
+        { weights = ws
+        , compute = first c
+        , initR   = i
+        }
+
+instance ArrowChoice Component where
+
+    left (Component ws c i) = Component ws (left c) i
+
+instance ArrowConvolve Component where
+
+    convolve (Component ws c i) = Component ws (convolve c) i
+
+instance Functor (Component a) where fmap = fmapArr
+
+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')@
+--   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 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)
+
+-- | 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
+
+-- | 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 :: (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
+
+    f'' = proc x -> do
+        let (x', h) = e x
+            x''     = fromDouble <$> x'
+        y <- f -< x''
+        returnA -< h y
+
+-- | 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
+
+-- | 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 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
+        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 Analytic) (g Analytic)
+              -> (c -> g Analytic -> Analytic)
+              -> (b -> f Double)
+              -> (g Double -> c)
+              -> StdModel f g b c
+mkStdModel c e i o = Model c e' i o where
+
+    e' (x, y) = (i x, e y)

+ src/Numeric/Neural/Normalization.hs view

@@ -0,0 +1,133 @@+{-# OPTIONS_HADDOCK show-extensions #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+
+{-|
+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
+    ) where
+
+import Data.Proxy
+import GHC.TypeLits
+import GHC.TypeLits.Witnesses
+import Data.MyPrelude
+import Data.Utils.Traversable
+import Data.Utils.Vector
+
+-- | 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, Num b, 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).
+--
+-- >>> crossEntropyError LT (cons 0.8 (cons 0.1 (cons 0.1 nil))) :: Float
+-- 0.22314353
+--
+-- >>> crossEntropyError EQ (cons 0.8 (cons 0.1 (cons 0.1 nil))) :: Float
+-- 2.3025851 
+--
+crossEntropyError :: (Enum a, Floating b, KnownNat n) => a -> Vector n b -> b
+crossEntropyError a ys = negate $ log $ encode1ofN a <%> ys

+ src/Numeric/Neural/Pipes.hs view

@@ -0,0 +1,90 @@+{-# OPTIONS_HADDOCK show-extensions #-}
+
+{-|
+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
+        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

+ test/Spec.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

+ test/Utils/MatrixSpec.hs view

@@ -0,0 +1,71 @@+{-# LANGUAGE DataKinds #-}
+
+module Utils.MatrixSpec (spec) where
+
+import Test.Hspec
+import Data.Utils
+
+spec :: Spec
+spec = do
+    mulSpec
+    rowSpec
+    columnSpec
+    indexSpec
+    transposeSpec
+    apSpec
+
+mulSpec :: Spec
+mulSpec = describe "(<%%>)" $
+
+    it "should multiply a matrix by a vector" $ do
+        let v = generate succ :: Vector 3 Int
+        m <%%> v `shouldBe` cons 14 (cons 32 nil) 
+
+rowSpec :: Spec
+rowSpec = describe "row" $ do
+
+    it "should give the specified row of the matrix if the index is valid" $ do
+        row m 0 `shouldBe` (Just $ cons 1 (cons 2 (cons 3 nil)))
+        row m 1 `shouldBe` (Just $ cons 4 (cons 5 (cons 6 nil)))
+
+    it "should return Nothing for an invalid row index" $ do
+        row m (-1) `shouldBe` Nothing
+        row m   2  `shouldBe` Nothing
+
+columnSpec :: Spec
+columnSpec = describe "column" $ do
+
+    it "should give the specified column of the matrix if the index is valid" $ do
+        column m 0 `shouldBe` (Just $ cons 1 (cons 4 nil))
+        column m 2 `shouldBe` (Just $ cons 3 (cons 6 nil))
+
+    it "should return Nothing for an invalid column index" $ do
+        column m (-1) `shouldBe` Nothing
+        column m   3  `shouldBe` Nothing
+
+indexSpec :: Spec
+indexSpec = describe "(!!?)" $ do
+
+    it "should give the specified element of the matrix if the index is valid" $ do
+        m !!? (0, 0) `shouldBe` Just 1
+        m !!? (1, 2) `shouldBe` Just 6
+
+    it "should return Nothing for an invalid index" $ do
+        m !!? (2, 0) `shouldBe` Nothing
+        m !!? (0, 3) `shouldBe` Nothing
+
+transposeSpec :: Spec
+transposeSpec = describe "transpose" $
+
+    it "should transpose the matrix" $
+        transpose m `shouldBe` mgenerate (\(i, j) -> 3 * j + i + 1)
+
+apSpec :: Spec
+apSpec = describe "(<*>)" $
+
+    it "should be component-wise application" $
+        (-) <$> m <*> m `shouldBe` pure 0 
+
+m :: Matrix 2 3 Int
+m = mgenerate $ \(i, j) -> 3 * i + j + 1 -- 1 2 3
+                                         -- 4 5 6

+ test/Utils/VectorSpec.hs view

@@ -0,0 +1,57 @@+{-# 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)