Basic OCR using a 1-Layer Neural Network in Haskell

Question

I've used this tutorial in order to learn the basics of creating a neural network from scratch. The program is meant to read handwritten numbers from the MNIST database. The author of the tutorial implements the algorithm in C, and claims that it only takes less than 10 seconds to go through both the training and testing phase. My Haskell implementation takes about 50 seconds.

I've also noticed by heap profiling that my code is progressively using more memory as it trains. I've been successful at eliminating most of the memory issues using force from Control.DeepSeq, but I'd expect my code to use a constant amount of memory.

How can I make this code faster, and more efficient? Any style tips are welcome as well. I don't have much experience in optimizing Haskell code.

Here's the guts of the application, NeuralNumbers.hs:

{- |
Module      :  NeuralNumbers
Description :  Read handwritten numbers with a neural network.
Copyright   :  Castle Kerr
License     :  BSD3

Maintainer  :  [email protected]
Stability   :  experimental
Portability :  portable

Read handwritten numbers from IDX files using a neural network.
-}

module NeuralNumbers
    ( Network
    , train
    , test
    ) where

import Control.Arrow (first)
import Data.List (mapAccumL, zipWith4)
import Data.Word (Word8)
import System.IO (Handle, IOMode(ReadMode), openBinaryFile)

import Control.DeepSeq (force)
import System.Random (randoms, getStdGen)
import Data.List.Split (chunksOf)
import qualified Data.ByteString.Lazy as BS
import qualified Data.Binary.Get as Get

type Label  = Word8 -- ^ The number represented by a corresponding image
type Image  = [Word8] -- ^ A 28 by 28 list of pixels with brightness 0-255
type Input  = Double -- ^ A 0 or 1 representing a white or black pixel
type Output = Double -- ^ A number between 0 and 1 for a node's output
type Weight = Double -- ^ A number between 0 and 1 for a node's multiplier
type Node   = [Weight] -- ^ The weights used by a node
type Layer  = [Node] -- ^ A single layer of a neural network

-- | A neural network for reading handwritten numbers.
newtype Network = Network [Layer]

layerSize, imageSize :: Num a => a
layerSize = 10
imageSize = 28 * 28

-- | Generate and train a new neural network using
-- the images and labels from the given IDX-format files.
-- Return the neural network along with its success rate.
train :: FilePath -- ^ Images file
      -> FilePath -- ^ Labels file
      -> IO (Network,Double) -- ^ Neural net and success rate
train imgsPath lblsPath = fmap (first (Network . pure)) $
    runBatch train' imgsPath lblsPath =<< getRandomLayer

-- | Test a given neural network using the images
-- and labels from the given IDX-format files. The
-- network will not learn from any of the images.
-- Return the success rate.
test :: Network -- ^ Neural network to test
     -> FilePath -- ^ Images file
     -> FilePath -- ^ Labels file
     -> IO Double -- ^ Success rate of tests
test (Network [layer]) imgsPath lblsPath =
    snd <$> runBatch test' imgsPath lblsPath layer
test _ _ _ = error "Invalid network"

runBatch
    :: (Layer -> (Image,Label) -> (Layer,Bool))
    -> FilePath -> FilePath
    -> Layer -> IO (Layer,Double)
runBatch run imgsPath lblsPath layer =
    fmap (fmap percentTrue . mapAccumL run layer) $
    zip <$> getImages imgsPath <*> getLabels lblsPath

train' :: Layer -> (Image,Label) -> (Layer,Bool)
train' layer (image, label) = (force layer', label == guess)
  where
    inputs = fromIntegral . min 1 <$> image
    outputs = calcNode inputs <$> layer
    guess = snd (maximum (zip outputs [0..]))
    targetOutputs = replicate (fromIntegral label) 0 ++ 1 : repeat 0
    layer' = zipWith4 updateWeights
                targetOutputs
                outputs
                (repeat inputs)
                layer

test' :: Layer -> (Image,Label) -> (Layer,Bool)
test' layer (image, label) =
    (layer, snd (train' layer (image, label)))

calcNode :: [Input] -> [Weight] -> Output
calcNode inputs weights =
    sum (zipWith (*) inputs weights) / imageSize

updateWeights :: Output -> Output -> [Input] -> [Weight] -> [Weight]
updateWeights target actual =
    zipWith (\input weight -> weight + input * dx)
  where
    dx = 0.05 * (target - actual)

percentTrue :: [Bool] -> Double
percentTrue xs =
    len (filter id xs) / len xs * 100
  where
    len = fromIntegral . length

getRandomLayer :: IO Layer
getRandomLayer = take layerSize
    . chunksOf imageSize
    . randoms <$> getStdGen

getLength :: Handle -> Int -> IO Int
getLength handle fileHeaderSize = fromIntegral .
    Get.runGet (Get.skip 4 >> Get.getWord32be)
        <$> BS.hGet handle fileHeaderSize

getImages :: FilePath -> IO [Image]
getImages path = do
    file <- openBinaryFile path ReadMode
    numImages <- getLength file 16
    take numImages . chunksOf imageSize . BS.unpack
        <$> BS.hGetContents file

getLabels :: FilePath -> IO [Label]
getLabels path = do
    file <- openBinaryFile path ReadMode
    numLabels <- getLength file 8
    take numLabels . BS.unpack
        <$> BS.hGetContents file

Here's the Main.hs:

import Text.Printf
import NeuralNumbers

main :: IO ()
main = do
    (layer, trainingRate) <- train
        "train-images.idx3-ubyte" "train-labels.idx1-ubyte"
    testingRate <- test layer
        "t10k-images.idx3-ubyte" "t10k-labels.idx1-ubyte"
    printf "Training: %.2f%% success rate\n" trainingRate
    printf "Testing: %.2f%% success rate\n" testingRate

And here's the nn-numbers.cabal:

name:                nn-numbers
version:             0.1.0.0
license:             BSD3
license-file:        LICENSE
author:              Castle Kerr
maintainer:          [email protected]
copyright:           2017 Castle Kerr
build-type:          Simple
cabal-version:       >=1.10

library
  hs-source-dirs:      src
  exposed-modules:     NeuralNumbers
  build-depends:       base
                       , binary
                       , bytestring
                       , split
                       , random
                       , deepseq
  ghc-options:         -O2 -Wall -Werror
  default-language:    Haskell2010

executable nn-numbers
  hs-source-dirs:      app
  main-is:             Main.hs
  ghc-options:         -O2 -rtsopts
  build-depends:       base, nn-numbers
  default-language:    Haskell2010

Answer 1

A couple things jump out at me:

1. Lists in Haskell are not data structures for storing like data, but rather control structures. Admittedly, Haskell hides the fact that they're implemented as linked lists. Use rather array - if your inputs are of constant size (as they appear to be) then this shouldn't cause any real problems.

2. It's partly a matter of personal preference, but I would avoid using type and use rather newtype, combined with the GeneralizedNewtypeDeriving extension to derive any instances that you need. This will make some parts of your code more verbose, but it will add type safety guarantees you would otherwise not have.

3. length is \$O(n)\$ in Haskell. Hence len (filter id xs) / len xs will traverse the list (at least) twice.

4. I believe ByteString has a readFile function that would simplify some of your code. It would also possibly prevent you from having to unpack the ByteString, which is \$O(n)\$.

5. When you zip layer with outputs, with outputs defined in terms of layer, I believe this traverses the list twice. Also, (++) is \$O(n)\$ in the first argument - this can be fixed with using a dedicated array data type.

   outputs = calcNode inputs <$> layer
       guess = snd (maximum (zip outputs [0..]))
       targetOutputs = replicate (fromIntegral label) 0 ++ 1 : repeat 0
       layer' = zipWith4 updateWeights
                    targetOutputs
                    outputs
                    (repeat inputs)
                    layer