# Basic OCR using a 1-Layer Neural Network in Haskell

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.

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 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
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
author:              Castle Kerr
maintainer:          [email protected]
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

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

• Please also include your .cabal file, just in case you had some strange ghc-options on. It will also make it easier to use the same packages as you did.
– Zeta
Jul 7, 2017 at 16:46
• @Zeta I've now added by .cabal file. Thanks! Jul 7, 2017 at 22:52
• I haven't had time to check the code thoroughly yet, but it seems like you deviate from the original C implementation. Your nodes only contain the Weight, but not the Input or Output in a local fashion. Speaking about local, updateWeight is currently a scapegoat, as it evaluates the lists. Since you're working with fixed size lists, array or vector should be suitable. I'll try to review your code till the end of the week.
– Zeta
Jul 18, 2017 at 13:02
• @Zeta Right, I started out doing it like the original C implementation (where I used a tuple of ([Weight],[Input],Output)), but over the course of several iterations of refactoring, the tuple was broken apart into its components, because it seemed unnatural to group them. calcNode was the only function that gained readability from grouping them together. Jul 18, 2017 at 14:49
• Oh. I completely forgot this review. I'll grab my laptop tomorrow and have a look at it.
– Zeta
Oct 6, 2017 at 5:52

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