diff --git a/MNIST.hs b/MNIST.hs index 4de5b9d..72d1e51 100644 --- a/MNIST.hs +++ b/MNIST.hs @@ -3,15 +3,18 @@ import qualified Data.ByteString.Lazy as BS import Data.Int +import Data.Binary import Data.List (findIndex, maximumBy) import Data.List.Split (chunksOf) import Data.Ord (comparing) import Debug.Trace (trace) +import Codec.Compression.GZip +import qualified Data.ByteString.Lazy as B + import Control.DeepSeq import Numeric.LinearAlgebra -import Codec.Compression.GZip import System.Random import System.Environment (getArgs) import System.Console.CmdArgs.Implicit @@ -92,6 +95,23 @@ testSamples = do ims <- testIms return $! [ img --> toLabel lbl | (lbl, img) <- ims] +newtype StorableSample a = StorableSample { getSample :: Sample a } + +instance (Element a, Binary a) => Binary (StorableSample a) where + put (StorableSample (vecIn, vecOut)) = do + put (toList vecIn) + put (toList vecOut) + get = do + vecIn <- get + vecOut <- get + return $ StorableSample (fromList vecIn --> fromList vecOut) + +loadSamples :: FilePath -> IO (Samples Double) +loadSamples fp = fmap (map getSample . decode . decompress) (B.readFile fp) + +saveSamples :: FilePath -> Samples Double -> IO () +saveSamples fp = B.writeFile fp . compress . encode . map StorableSample + classify :: Network Double -> Sample Double -> IO () classify net spl = do putStrLn (drawImage (fst spl) @@ -115,8 +135,8 @@ main = do net <- case filePath args of "" -> newNetwork [784, hiddenNeurons args, 10] fp -> loadNetwork fp :: IO (Network Double) - trSamples <- trainSamples - tstSamples <- testSamples + trSamples <- loadSamples "mnist-data/trainSamples.spls" + tstSamples <- loadSamples "mnist-data/testSamples.spls" let bad = tstSamples `deepseq` test net tstSamples putStrLn $ "Initial performance of network: recognized " ++ show bad ++ " of 10k" let debug network epochs = "Left epochs: " ++ show epochs diff --git a/Network.hs b/Network.hs index 11f85c8..e0dc4e1 100644 --- a/Network.hs +++ b/Network.hs @@ -40,6 +40,7 @@ module Network ( ) where import Data.List.Split (chunksOf) +import Data.List (foldl') import Data.Binary import Data.Maybe (fromMaybe) import Text.Read (readMaybe) @@ -146,7 +147,7 @@ output :: (Numeric a, Num (Vector a)) -> ActivationFunction a -> Vector a -> Vector a -output net act input = foldl f input (layers net) +output net act input = foldl' f input (layers net) where f vec layer = cmap act ((weights layer #> vec) + biases layer) rawOutputs :: (Numeric a, Num (Vector a)) @@ -206,7 +207,7 @@ trainSGD :: (Numeric Double, Floating Double) -> Double -> Network Double trainSGD net costFunction lambda trainSamples miniBatchSize eta = - foldl updateMiniBatch net (chunksOf miniBatchSize trainSamples) + foldl' updateMiniBatch net (chunksOf miniBatchSize trainSamples) where updateMiniBatch = update eta costFunction lambda (length trainSamples) update :: LearningRate @@ -220,10 +221,10 @@ update eta costFunction lambda n net spls = case newNablas of Nothing -> net Just x -> net { layers = layers' x } where newNablas :: Maybe [Layer Double] - newNablas = foldl updateNablas Nothing spls + newNablas = foldl' updateNablas Nothing spls updateNablas :: Maybe [Layer Double] -> Sample Double -> Maybe [Layer Double] updateNablas mayNablas sample = - let nablasDelta = backprop net costFunction sample + let !nablasDelta = backprop net costFunction sample f nabla nablaDelta = nabla { weights = weights nabla + weights nablaDelta, biases = biases nabla + biases nablaDelta } @@ -252,8 +253,9 @@ backprop net costFunction spl = finalNablas (headZ, headA) = head rawFeedforward -- get starting delta, based on the activation of the last layer startDelta = getDelta costFunction headZ headA (snd spl) - -- calculate weighs of last layer in advance + -- calculate nabla of biases lastNablaB = startDelta + -- calculate nabla of weighs of last layer in advance lastNablaW = startDelta `outer` previousA where previousA | length rawFeedforward > 1 = snd $ rawFeedforward !! 1 @@ -262,7 +264,7 @@ backprop net costFunction spl = finalNablas -- reverse layers, analogy to the reversed (z, a) list layersReversed = reverse $ layers net -- calculate nablas, beginning at the end of the network (startDelta) - (finalNablas, _) = foldl calculate ([lastLayer], startDelta) + (finalNablas, _) = foldl' calculate ([lastLayer], startDelta) [1..length layersReversed - 1] -- takes the index and updates nablas calculate (nablas, oldDelta) idx =