From e1826a4c5975260c784d3f6c43fd53a7092d64e4 Mon Sep 17 00:00:00 2001 From: Miguel Date: Fri, 22 Mar 2019 20:11:55 +0100 Subject: hoooray. fixed stupid bug. now at least 90% MNIST after one epoch --- mnist/Neuronet.hs | 12 +++-- mnist/main.hs | 152 ++++++++++++++++-------------------------------------- 2 files changed, 53 insertions(+), 111 deletions(-) (limited to 'mnist') diff --git a/mnist/Neuronet.hs b/mnist/Neuronet.hs index 517f3b8..e3344c7 100644 --- a/mnist/Neuronet.hs +++ b/mnist/Neuronet.hs @@ -2,10 +2,12 @@ N E U R O T I C U S - A small and straight forward neural network coded in Haskell - from scratch. It uses gradient descent and the beatuiful + A small and straightforward neural network coded in Haskell + from scratch. It uses gradient descent and the beauty of backpropagation for learning. + TODOS: improve performance, parallelize, CUDA, FFI + Michal Idziorek March 2019 @@ -17,6 +19,9 @@ module Neuronet ,train -- train with one sample ,trainBatch -- train with batch ,asknet -- ask the neuroal net + + ,wghtact + ,backprop )where import Numeric.LinearAlgebra (Matrix,Vector,tr,scale,cmap,(#>),randn,toList,fromList,toLists,fromLists,Container) @@ -83,6 +88,7 @@ trainBatch r net xs ys = zipWith (upd r) net bp fc v a = zipWith ff v a ff (a,b) (c,d) = (a+c,b+d) --- | Update a Layer given the `direction` and `training rate` +-- | Update a single Layer given the `direction` and `training rate` upd :: Double -> Layer -> (Matrix Double,Vector Double) -> Layer upd r (a,b) (c,d) = (a-scale r c,b-scale r d) + diff --git a/mnist/main.hs b/mnist/main.hs index d00e3c6..a91984a 100644 --- a/mnist/main.hs +++ b/mnist/main.hs @@ -1,6 +1,6 @@ import Neuronet import System.Random(randomRIO) -import Numeric.LinearAlgebra (Matrix,Vector,tr,scale,cmap,(#>),randn,toList,fromList,toLists,fromLists,Container) +import Numeric.LinearAlgebra import Data.List import Data.List.Split import Data.Tuple.Extra @@ -34,113 +34,49 @@ testing :: (Vector Double -> Vector Double -> Bool) -> Neuronet -> Samples -> In testing f net s = length . filter id $ map (\(x,y)->f y (asknet net x)) s -- finally some learning and testing with MNIST +-- MNIST files from http://yann.lecun.com/exdb/mnist/ +main :: IO () main = mainMNIST --- Paths to the unpacked files from http://yann.lecun.com/exdb/mnist/ -train_img="train-images-idx3-ubyte" -train_lbl="train-labels-idx1-ubyte" -test_img="t10k-images-idx3-ubyte" -test_lbl="t10k-labels-idx1-ubyte" - +-- create Samples given two MNIST files for images and labels +read_samples :: FilePath -> FilePath -> IO Samples +read_samples f1 f2 = do + h1 <- openFile f1 ReadMode + h2 <- openFile f2 ReadMode + xs <- BS.hGetContents h1 >>= return . map (fromList.map ((/255).fromIntegral)) . + chunksOf (28*28) . BS.unpack.BS.drop 16 + ys <- BS.hGetContents h2 >>= return. map (fromList.val.fromIntegral) . + BS.unpack . BS.drop 8 + return $ zip xs ys + where zrs= take 9 $ repeat 0 + val x= take x zrs ++ [1] ++ drop x zrs + +-- MNIST main function +mainMNIST :: IO () mainMNIST =do - nt <- neuronet [28*28,10,10] - h1 <- openFile train_img ReadMode - h2 <- openFile train_lbl ReadMode - xs <- BS.hGetContents h1 >>= return. map (fromList.map fromIntegral) . chunksOf (28*28) . BS.unpack.BS.drop 16 - ys <- BS.hGetContents h2 >>= return. map (fromList.val.fromIntegral) . BS.unpack. BS.drop 8 - tr <- epochs 1 100 (zip xs ys) >>= return . training (1/100) nt - - print "bye" - where zrs= take 9 $ repeat 0 - val x= take x zrs ++ [1::Double] ++ drop x zrs - -main2 = do - - easynet<-neuronet [20,10,10] - samples<-(map ( \(a,b) -> (fromList (val a++val b),fromList $ val $ a+b)) . filter ((<10).uncurry (+))) <$> gensamp 4000 - tstsmpl<-(map ( \(a,b) -> (fromList (val a++val b),fromList $ val $ a+b)) . filter ((<10).uncurry (+))) <$> gensamp 1000 - trained <- epochs 200 100 samples >>= return . training (3/100) easynet - print $ testing tst trained tstsmpl - - where zrs= take 9 $ repeat 0.01 - val x= take x zrs ++ [0.99] ++ drop x zrs - getVal x=snd . last . sort $ zip x [0..9] - tst y1 y2 = getVal (toList y1) == getVal (toList y2) - -gensamp :: Int -> IO [(Int,Int)] -gensamp 0 = return [] -gensamp n = (\a b r->(a,b):r) <$> randomRIO (0,9) <*> randomRIO (0,9) <*> gensamp (n-1) - -{- -main3 = do - - let numtrain=300000 - - easynet<-neuronet [20,15,10] - - samples<-filter ((<10).uncurry (+)) <$> gensamp numtrain - let testsmp=filter ((<10).uncurry (+))[(a,b)|a<-[0..10],b<-[0..10]] - - let trained=foldl' training easynet samples - let res = map (\(a,b)->test trained (a,b) == a+b) testsmp - let right=length $ filter (id) res - let all = length res - - print $ "trained adding up to 10 with "++ show numtrain ++" random training samples" - print $ "correct answers during testing: " ++ show right ++ "/" ++ show all ++ " (" ++ show (right*100`div`all) ++ "%)" - print "what can I add for you?" - str<-lines<$>getContents - mapM_ (addit trained) str - - where zrs= take 9 $ repeat 0.01 - val x= take x zrs ++ [0.99] ++ drop x zrs - getVal x=snd . last . sort $ zip x [0..9] - - training net (s1,s2) = train 0.25 net (fromList $ val s1++val s2) (fromList $ val $ s1+s2) - test net (s1,s2) = getVal . toList $ asknet net (fromList $ val s1++val s2) - - - addit n x= do let w=words x - let a=read $ w!!0 :: Int - let b=read $ w!!1 :: Int - putStrLn $ "I try to add " ++ show a ++ " and " ++ show b - putStrLn $ "I think this is = " ++ show (test n (a,b) ) - putStrLn "what two numbers do you want me to add master?" - - - - - - - -showImg a | BS.null a = print "--" - | otherwise = do mapM_ putVal $ BS.unpack $ BS.take 28 a - putStr "\n" - showImg $ BS.drop 28 a - -putVal v | v==0 = putStr " " - | v<50 = putStr "." - | v<128 = putStr "o" - | v<160 = putStr "O" - | otherwise = putStr "0" - - -main2 = do - -- 0 1 2 3 4 5 6 7 8 9 - let m=(4><10)[ 0, 100,0, 100,0, 100,0, 100,0, 100 - ,0, 0, 100,100,0, 0, 100,100,0, 0 - ,0, 0, 0, 0, 100,100,100,100,0, 0 - ,0, 0, 0, 0, 0, 0, 0, 0, 100,100] - - let b=vector . take 4 . repeat $ (-50) - - let z= repeat 0.01 - let vv x= vector $ take x z ++ [0.99] ++ take (9-x) z - let v = vv 6 - let z= m #> v + b - let a= cmap sigmoid z - print m - print v - print z - print a --} + let ep = 1 -- number of epochs + let mbs = 10 -- mini-batch size + let lr = 3 -- learning rate + nt <- neuronet [28*28,30,10] + smpl_train <- read_samples "train-images-idx3-ubyte" "train-labels-idx1-ubyte" + smpl_test <- read_samples "t10k-images-idx3-ubyte" "t10k-labels-idx1-ubyte" + tr <- epochs ep mbs smpl_train >>= return . training (lr/fromIntegral mbs) nt + let passed = testing chk tr smpl_test + print $ show passed ++ "/10000 (" ++ show (fromIntegral passed/100)++ "%)" + where chk y1 y2 = val y1 == val y2 + val x=snd . last . sort $ zip (toList x) [0..9] + +-- just a quick and simple network created manually, used for experimenting +mainMANUAL :: IO () +mainMANUAL = do + + let nt =[ ((2><2)[0.2,0.3,0.4,0.5],fromList[0.6,-0.6]) -- L1 + ,((2><2)[-0.5,-0.4,-0.3,-0.2],fromList[0.4,0.5]) -- L2 + ,((1><2)[0.25,0.35],fromList[0.9]) -- L3 + ] + + print nt + print $ wghtact nt $ fromList [0.8,0.9] + print $ backprop nt (fromList [0.8,0.9]) (fromList [1]) + print $ train 0.3 nt (fromList [0.8,0.9]) (fromList [1]) + print $ trainBatch 0.15 nt [fromList [0.8,0.9],fromList [0.8,0.9]] [fromList [1],fromList [1]] -- cgit v1.2.3