@@ -9,6 +9,8 @@
99import Control.Applicative
1010import Control.Monad
1111import Control.Monad.Random
12+import Control.Monad.Trans.Class
13+import Control.Monad.Trans.Except
1214
1315import qualified Data.Attoparsec.Text as A
1416import qualified Data.Text as T
@@ -35,35 +37,23 @@ randomMnist :: MonadRandom m
3537 '[ 'D2 28 28, 'D3 24 24 10, 'D3 12 12 10, 'D3 12 12 10, 'D3 8 8 16, 'D3 4 4 16, 'D1 256, 'D1 256, 'D1 80, 'D1 80, 'D1 10, 'D1 10])
3638randomMnist = randomNetwork
3739
38−
39−convTest :: Int -> FilePath -> FilePath -> LearningParameters -> IO ()
40+convTest :: Int -> FilePath -> FilePath -> LearningParameters -> ExceptT String IO ()
4041convTest iterations trainFile validateFile rate = do
41− net0 <- evalRandIO randomMnist
42− fT <- T.readFile trainFile
43− fV <- T.readFile validateFile
44− let trainRows = traverse (A.parseOnly p) (T.lines fT)
45− let validateRows = traverse (A.parseOnly p) (T.lines fV)
46− case (trainRows, validateRows) of
47− (Right tr', Right vr') -> foldM_ (runIteration tr' vr') net0 [1..iterations]
48− err -> print err
49−
50− where
51− trainEach !rate' !nt !(i, o) = train rate' nt i o
52−
53− p :: A.Parser (S' ('D2 28 28), S' ('D1 10))
54− p = do
55− lab <- A.decimal
56− pixels <- many (A.char ',' >> A.double)
57− let lab' = replicate lab 0 ++ [1] ++ replicate (9 - lab) 0
58− return (S2D' $ SA.fromList pixels, S1D' $ SA.fromList lab')
59−
60− runIteration trainRows validateRows net i = do
61− let trained' = foldl (trainEach rate) net trainRows
62− let res = fmap (\(rowP,rowL) -> (rowL,) $ runNet trained' rowP) validateRows
63− let res' = fmap (\(S1D' label, S1D' prediction) -> (maxIndex (SA.extract label), maxIndex (SA.extract prediction))) res
64− print trained'
65− putStrLn $ "Iteration " ++ show i ++ ": " ++ show (length (filter ((==) <$> fst <*> snd) res')) ++ " of " ++ show (length res')
66− return trained'
42+ net0 <- lift randomMnist
43+ trainData <- readMNIST trainFile
44+ validateData <- readMNIST validateFile
45+ lift $ foldM_ (runIteration trainData validateData) net0 [1..iterations]
46+
47+ where
48+ trainEach rate' !network (i, o) = train rate' network i o
49+
50+ runIteration trainRows validateRows net i = do
51+ let trained' = foldl (trainEach ( rate { learningRate = learningRate rate * 0.9 ^ i} )) net trainRows
52+ let res = fmap (\(rowP,rowL) -> (rowL,) $ runNet trained' rowP) validateRows
53+ let res' = fmap (\(S1D' label, S1D' prediction) -> (maxIndex (SA.extract label), maxIndex (SA.extract prediction))) res
54+ print trained'
55+ putStrLn $ "Iteration " ++ show i ++ ": " ++ show (length (filter ((==) <$> fst <*> snd) res')) ++ " of " ++ show (length res')
56+ return trained'
6757
6858data MnistOpts = MnistOpts FilePath FilePath Int LearningParameters
6959
@@ -81,4 +71,20 @@ main :: IO ()
8171main = do
8272 MnistOpts mnist vali iter rate <- execParser (info (mnist' <**> helper) idm)
8373 putStrLn "Training convolutional neural network..."
84− convTest iter mnist vali rate
74+
75+ res <- runExceptT $ convTest iter mnist vali rate
76+ case res of
77+ Right () -> pure ()
78+ Left err -> putStrLn err
79+
80+readMNIST :: FilePath -> ExceptT String IO [(S' ('D2 28 28), S' ('D1 10))]
81+readMNIST mnist = ExceptT $ do
82+ mnistdata <- T.readFile mnist
83+ return $ traverse (A.parseOnly parseMNIST) (T.lines mnistdata)
84+
85+parseMNIST :: A.Parser (S' ('D2 28 28), S' ('D1 10))
86+parseMNIST = do
87+ lab <- A.decimal
88+ pixels <- many (A.char ',' >> A.double)
89+ let lab' = replicate lab 0 ++ [1] ++ replicate (9 - lab) 0
90+ return (S2D' $ SA.fromList pixels, S1D' $ SA.fromList lab')