{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.Neural.FeedForward where
--module Data.Neural.FeedForward
--    ( Neuron (..)
--    , NetworkTemplate (..)
--    , Network (..)
--    , Activation
--    , Derivative
--
--    , makeNetwork
--    , e
--    , hyperbolic
--    , sigmoid
--    , sigmoid'
--    ) where

import           Prelude                        as P
import           System.Random
import           Control.Monad.Identity
import           Control.Monad.Random
import           Control.Monad.Error
import           Data.Text
import           Data.Either
import           Data.Array.Repa                as R

data Neuron = Input
            | Bias
            | Hidden
            | Output
            deriving (Show)

data NetworkTemplate = NetworkTemplate [[Neuron]] deriving Show

type Active = Array U DIM1 Double
type Inert = Array U DIM1 Double
data Layer = Explicit Active Inert
           | Weight (Array U DIM2 Double)

type Activation = (Double -> Double)
type Derivative = (Double -> Double)
data Network = Network Activation [Layer]
             | Empty

e :: Double
e = 2.71828182845904523536028747135266249775724709369995

hyperbolic :: Activation
hyperbolic x = ((e ** (2.0 * x)) - 1.0) / ((e ** (2.0 * x)) + 1.0)

sigmoid :: Activation
sigmoid x = 1.0 / (1.0 + (e ** (0.0 - x)))

sigmoid' :: Derivative
sigmoid' x = (sigmoid x) * (1.0 - (sigmoid x))

instance (RandomGen g, MonadError e m) => MonadError e (RandT g m) where
        throwError = lift . throwError
--        catchError = lift . catchError  --No auto lift due to GHC 7.6.3 bug.
        catchError = catchError

makeNetwork :: (RandomGen g) => Activation -> NetworkTemplate ->  g -> Either String (Network, g)
makeNetwork act (NetworkTemplate net) gen = runIdentity (runErrorT (runRandT (makeNetwork' act net) gen))

makeNetwork' :: (RandomGen g) => Activation ->  [[Neuron]] -> RandT g (ErrorT String Identity) Network
makeNetwork' _ []       = throwError "Network must have an input and output layer."
makeNetwork' _ [l]      = throwError "Network must have an input and output layer."
makeNetwork' act (l:ls) = do
        input <- validInput l
        let (hs, [o]) = notLast ls
        hidden <- P.mapM validHidden hs
        output <- validOutput o
        return Empty

decompose = undefined

notLast []     = ([], [])
notLast [x]    = ([], [x])
notLast (x:xs) = notLast' ([x], []) xs
    where notLast' (front, _) [x]    = (front, [x])
          notLast' (front, _) (x:xs) = notLast' (front P.++ [x], []) xs

validInput = P.mapM isValid
    where isValid (Input)  = return Input
          isValid (Bias)   = return Bias
          isValid (Hidden) = throwError "Hidden neuron found in input layer."
          isValid (Output) = throwError "Output neuron found in input layer."

validHidden = P.mapM isValid
    where isValid (Input)  = throwError "Input neuron found in hidden layer."
          isValid (Bias)   = return Bias
          isValid (Hidden) = return Hidden
          isValid (Output) = throwError "Output neuron found in hidden layer."

validOutput = P.mapM isValid
    where isValid (Input)  = throwError "Input neuron found in output layer."
          isValid (Bias)   = throwError "Bias neuron found in output layer."
          isValid (Hidden) = throwError "Hidden neuron found in output layer."
          isValid (Output) = return Output

breakLayer = P.foldl s ([], [])
    where s (layer, bias) (Bias) = (layer, bias P.++ [Bias])
          s (layer, bias) x      = (layer P.++ [x], bias)

