mlp.hs

import Data.List (transpose)
import System.Random
import Control.Monad (liftM)


type Vector a = [a]
type Matrix a = [Vector a]

-- vector expression
-- innner product
(/./) :: (Num a) => Vector a -> Vector a -> a
(/./) xs ys = sum $ zipWith (*) xs ys

-- dif
(/-/) :: (Num a) => Vector a -> Vector a -> Vector a
(/-/) = zipWith (-)

(/*/) :: (Num a) => Vector a -> Vector a -> Vector a
(/*/) xs ys = zipWith (*) xs ys

-- time
(*/) :: (Num a) => a -> Vector a -> Vector a
(*/) a = map (a*)


-- matrix expression
-- inner product
(|.|) :: (Num a) => Matrix a -> Matrix a -> Matrix a
(|.|) xss yss = [[xs /./ ys | ys <- yssT] | xs <- xss]
    where yssT = transpose yss

-- sum
(|-|) :: (Num a) => Matrix a -> Matrix a -> Matrix a
(|-|) = zipWith (/-/)


-- time scala * Matrix
(*|) :: (Num a) => a -> Matrix a -> Matrix a
(*|) a = map (a */)

-- time Matrix * Vector
(|./) :: (Num a) => Matrix a -> Vector a -> Vector a
(|./) xss ys = [ys /./ xs | xs <- xss]


-- sigmoid
sigmoid :: (Floating a) => a -> a -> a
sigmoid a x = 1 / (1 + exp (-a*x))

-- sigmoid dff
sigmoid' :: (Num a) => a -> a -> a
sigmoid' a x = a * x * (1 - x)


-- func of mid layer
h :: (Num a, Floating a) => Matrix a -> a -> Vector a -> Vector a
h wss a xs  = map (sigmoid a) (wss |./ xs)


-- error of out layer
outDelta :: (Num a, Floating a) => Vector a -> Vector a -> a -> Vector a
outDelta oys ds a = (oys /-/ ds) /*/ map (sigmoid' a) oys


-- error of mid layer
midDelta :: (Num a, Show a) => Vector a -> Matrix a -> Vector a -> a -> Vector a
midDelta mys vss oes a = (transpose vss |./ oes) /*/ map (sigmoid' a) mys


-- update weight vector of mid layer
updateW :: (Num a, Show a) => Matrix a -> Vector a -> Vector a -> a -> Matrix a
updateW wss mes xs r = wss |-| ( r *| ( transpose mess |.| xss ) )
    where mess = [mes]
          xss = [xs]


-- training
train :: (Num a, Floating a, Show a) => a -> a -> (Matrix a, Matrix a) -> (Vector a, Vector a) -> (Matrix a, Matrix a)
train a r wt t = wt'
    where wss = fst wt
          vss = snd wt
          ds = fst t
          xs = snd t

          mys = h wss a xs
          oys = h vss a mys

          oes = outDelta oys ds a
          mes = midDelta mys vss oes a

          wss' = updateW wss mes xs r
          vss' = updateW vss oes mys r

          wt' = (wss', vss')


-- do loop
loop :: (Num a, Floating a, Show a) => a -> a -> Int -> Int -> (Matrix a, Matrix a) -> [(Vector a, Vector a)] -> IO (Matrix a, Matrix a)
loop a r c n wt ts
    | c /= n = loop a r c' n (foldl (train a r) wt ts) ts
    | otherwise = return wt
    where c' = c+1


-- initialize weight vector randomly
initW :: Int -> IO (Vector Double)
initW d = liftM (take d . randomRs (-1, 1)) newStdGen


-- split list
splitList :: Int -> [a] -> [[a]]
splitList _ [] = []
splitList m xs = xs1 : splitList m xs2
  where (xs1, xs2) = splitAt m xs

addBius :: (Vector Double, Vector Double) -> (Vector Double, Vector Double)
addBius t = ( fst t, 1 : snd t)


main :: IO()
main = do
  wss <- fmap (splitList md) $ initW $ md * mn
  vss <- fmap (splitList mn) $ initW $ mn * on
  wt' <- loop a r 0 n (wss, vss) ts'
  print $ map (h (snd wt') a . h (fst wt') a) xss
    where
      a = 1
      r = 0.2
      n = 10000
      mn = 3
      on = 1

      md = length $ snd $ head ts'
      xss = map snd ts'

      ts' = map addBius ts

      ts = [([0], [1, 1] ),
            ([1], [1, 0] ),
            ([1], [0, 1] ),
            ([0], [0, 0] )]