Neural Networks in Haskell with Control.Lens

NeuralNetwork.hs

{-# LANGUAGE TemplateHaskell, Rank2Types #-}
module NeuralNetwork where

import Control.Lens
import Control.Monad (mapM_)
import Control.Monad.State
import qualified Data.Vector as V
import Data.Vector.Lens

type NetworkState a = State Network a

data Network = Network {_layers  :: V.Vector Layer}   deriving (Show, Eq)

data Layer   = Layer   {_neurons :: V.Vector Neuron}  deriving (Show, Eq)

data Neuron  = Neuron  { _weights :: V.Vector Double
                       , _value   :: Double}  
             deriving (Show, Eq)

makeLenses ''Network
makeLenses ''Layer
makeLenses ''Neuron

fl :: [a] -> V.Vector a
fl = V.fromList

orNetwork :: Network
orNetwork = Network $ fl [Layer $ fl [Neuron (fl [20]) 0, Neuron (fl [20]) 0, Neuron (fl [-20]) 1],
                          Layer $ fl [Neuron (fl [1]) 0]]

vIndex :: Int -> Lens' (V.Vector a) a
vIndex n = lens (\v -> v V.! n) (\v a -> V.update v (V.fromList [(n, a)]))

sigmoid :: Double -> Double
sigmoid x = 1 / (1 + exp (-x))

classify :: Double -> Double
classify x = if sigmoid x >= 0.5 then 1 else 0

createNeuron :: Int -> Neuron
createNeuron neurons = Neuron (V.replicate neurons 1) 0 

createLayer :: Int -> Int -> Layer
createLayer neurons1 neurons2 = Layer $ V.replicate (neurons1 + 1) (createNeuron neurons2)

createNetwork :: [Int] -> Network
createNetwork = Network . go 
  where go (n1:[])    = V.fromList [Layer $ V.replicate n1 (Neuron (V.fromList [1.0]) 0)]
        go (n1:n2:ns) = V.cons (createLayer n1 n2) (go (n2:ns))

-- %= is over (modify) but with state
addInputs :: V.Vector Double -> NetworkState ()
addInputs inputs = (layers . vIndex 0 . neurons) %= (\neurons -> go (V.toList inputs) (V.toList neurons))
  where go []     (n:[]) = V.fromList [set value 1 n]
        go (x:xs) (n:ns) = V.cons (set value x n) (go xs ns)

propagate :: V.Vector Double -> NetworkState (V.Vector Double)
propagate inputs = do
  addInputs inputs
  len <- fmap V.length (use layers)
  flip mapM_ [1 .. len - 1] $ \i -> do
    layerBelow <- use (layers . vIndex (i - 1))
    layer      <- use (layers . vIndex i)
    flip mapM_ [0 .. V.length (view neurons layer) - 1] $ \j -> do
      let ws      = toVectorOf (neurons . each . weights . vIndex j) layerBelow
          values  = toVectorOf (neurons . each . value) layerBelow
          v       = V.sum $  V.zipWith (*) ws values
      -- .= is set but with state
      (layers . vIndex i . neurons . vIndex j . value) .= (classify v)
  fmap (toVectorOf $ vIndex (len - 1) . neurons . each . value) (use layers)