nn.hs

module NeuralNetwork where

import Data.List
import System.Random
import Control.Monad
import Numeric.LinearAlgebra

learnCnst = 0.01

addThres v = vector $ toList v ++ [1.0]

remThres v = vector $ init $ toList v

sigmoid x = 1.0 / (1.0 + exp (-x))

forward :: Matrix Double -> Vector Double -> Vector Double
forward w o = w #> o

errorOut :: Vector Double -> Vector Double -> Vector Double
errorOut teacher o = o - teacher

errorMid :: Matrix Double -> Vector Double -> Vector Double -> Vector Double
errorMid w nextErr i = remThres $ (tr w #> nextErr) * (1 - i)*i

errors :: Vector Double -> [Matrix Double] ->
    [Vector Double] -> [Vector Double]
errors teacher weights is = scanr f initial $ tail $ zip (init is) weights
    where
        f (i, w) err = errorMid w err i
        initial = errorOut teacher $ last is

updateWeight :: Matrix Double -> Vector Double -> Vector Double -> Matrix Double
updateWeight w o err  = w - learnCnst * err `outer` o

compute :: [Matrix Double] -> Vector Double -> [Vector Double]
comptue [] input = [input]
compute weights input = out $ scanl (\i w -> addThres $ sigmoid $ forward w i) (addThres input) $ init weights
    where
        out xs = xs ++ [forward (last weights) (last xs)]

backProp :: Vector Double -> Vector Double -> [Matrix Double] -> [Matrix Double]
backProp input teacher weights =
    zipWith3 updateWeight weights (init is ++ [addThres $ last is]) $ errors teacher weights is
    where
        is = compute weights input

sqError :: Vector Double -> Vector Double -> Double
sqError teacher out = (teacher - out) <.> (teacher - out) * 0.5

trainMain :: [Matrix Double] -> Vector Double -> Vector Double ->
    (Double, [Matrix Double])
trainMain weights input teacher = (sqError teacher out, res)
    where
        out = last $ compute weights input
        res = backProp input teacher weights 

trainLoop' :: [Matrix Double] -> [(Vector Double, Vector Double)] ->
    Double -> (Double, [Matrix Double])
trainLoop' weights [] e = (e, weights)
trainLoop' weights (dat:rest) err = trainLoop' weights' rest $ err + err'
    where
        (err', weights') = uncurry (trainMain weights) dat

sqErrors :: [Matrix Double] -> [(Vector Double, Vector Double)] -> [Double]
sqErrors weights datas = let (e, w) = trainLoop' weights datas 0.0 in e : sqErrors w datas

trainLoop :: Double -> [Matrix Double] -> [(Vector Double, Vector Double)] -> [Matrix Double]
trainLoop e weights datas = if err < e
                              then res
                              else trainLoop e res datas
    where
        (err, res) = trainLoop' weights datas 0.0

trainLoopN :: Int -> [Matrix Double] -> [(Vector Double, Vector Double)] -> (Double, [Matrix Double])
trainLoopN 0 weights datas = trainLoop' weights datas 0.0 
trainLoopN n weights datas = let (_, ws) = trainLoop' weights datas 0.0 in trainLoopN (n-1) ws datas

randomWeight :: Int -> Int -> IO (Matrix Double)
randomWeight n m = fmap (matrix n . take (n*m) . randomRs (-1.0, 1.0)) getStdGen

randomWeights3 :: Int -> Int -> Int -> IO [Matrix Double]
randomWeights3 n m k = liftM2 (\w1 w2 -> w1:w2:[]) (randomWeight (n+1) k) (randomWeight (k+1) m)

mkData f x = (vector [x], vector [f x])
mkDatas f n a b = fmap (map (mkData f) . take n . randomRs (a, b)) getStdGen