Skip to content

Instantly share code, notes, and snippets.

@masaponto

masaponto/mlp.hs

Created Dec 27, 2014
Embed
What would you like to do?
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] )]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.