module AI.HNN.Net where
import AI.HNN.Layer
import AI.HNN.Neuron
import Control.Arrow
import Data.List
import Data.Array.Vector
check :: [[Neuron]] -> Bool
check nss = let l = length nss in l > 1 && l < 3
nn :: [[Neuron]] -> [[Neuron]]
nn nss | check nss = nss
| otherwise = error "Invalid nn"
computeNetU :: [[Neuron]] -> UArr Double -> UArr Double
computeNetU neuralss xs = let nss = nn neuralss in computeLayerU (nss !! 1) $ computeLayerU (head nss) xs
computeNet :: [[Neuron]] -> [Double] -> [Double]
computeNet neuralss = fromU . computeNetU neuralss . toU
quadErrorNetU :: [[Neuron]] -> (UArr Double, UArr Double) -> Double
quadErrorNetU nss (xs,ys) = (sumU . zipWithU (\y s -> (y s)**2) ys $ computeNetU nss xs)/2.0
quadErrorNet :: [[Neuron]] -> ([Double], [Double]) -> Double
quadErrorNet nss = quadErrorNetU nss . (toU *** toU)
globalQuadErrorNetU :: [[Neuron]] -> [(UArr Double, UArr Double)] -> Double
globalQuadErrorNetU nss = sum . map (quadErrorNetU nss)
globalQuadErrorNet :: [[Neuron]] -> [([Double], [Double])] -> Double
globalQuadErrorNet nss = globalQuadErrorNetU nss . map (toU *** toU)
backPropU :: Double -> [[Neuron]] -> (UArr Double, UArr Double) -> [[Neuron]]
backPropU alpha nss (xs, ys) = [aux (head nss) ds_hidden xs
,aux (nss !! 1) ds_out output_hidden]
where
output_hidden = computeLayerU (head nss) xs
output_out = computeLayerU (nss !! 1) output_hidden
ds_out = zipWithU (\s y -> s * (1 s) * (y s)) output_out ys
ds_hidden = zipWithU (\x s -> x * (1x) * s) output_hidden . toU $ map (sumU . zipWithU (*) ds_out) . map toU . transpose . map (fromU . weights) $ (nss !! 1)
aux ns ds xs = zipWith (\n d -> n { weights = zipWithU (\w x -> w + alpha * d * x) (weights n) xs }) ns (fromU ds)
backProp :: Double -> [[Neuron]] -> ([Double], [Double]) -> [[Neuron]]
backProp alpha nss = backPropU alpha nss . (toU *** toU)
trainAux :: Double -> [[Neuron]] -> [(UArr Double, UArr Double)] -> [[Neuron]]
trainAux alpha = foldl' (backPropU alpha)
trainU :: Double -> Double -> [[Neuron]] -> [(UArr Double, UArr Double)] -> [[Neuron]]
trainU alpha epsilon nss samples = until (\nss' -> globalQuadErrorNetU nss' samples < epsilon) (\nss' -> trainAux alpha nss' samples) nss
train :: Double -> Double -> [[Neuron]] -> [([Double], [Double])] -> [[Neuron]]
train alpha epsilon nss = trainU alpha epsilon nss . map (toU *** toU)