PPM/PGM Image processing library in Haskell

Question

I've written a small library for reading and writing PGM/PPM images. The format is described here. I attach the library itself and a small utility to convert binary encoded images to ASCII encoding. Any type of comment will be appriciated. However, these points are most important to me:

• Abusing of the type system - I fear that I forced my OOP design on the Haskell type system. I wanted to use typeclasses in order to prevent code duplication as much as possible between PGM and PPM images. However, the final result was that I had to duplicate code in several places. The worse thing is that I was forced to add a type signature in the bin2asc utility, so it doesn't support PGM. How can I design this library better to support both types?

• Performance - Running my bin2asc utility on this image takes 0.633 seconds. I think it's a bit slow for an image in such size. Since I don't know how to profile code in Haskell I can't tell which function takes most of the time. Is there any bad practice that I have done that hurts performance?

• Branching in mixed IO/Maybe functions - When using the do notiaion in a function that returns a Maybe I prevent checking for Nothings by chaining monads. However, in bin2asc I have to check explicitly for Nothing, creating an extra branch. Is there anything I can do to prevent this?

• Parsing multiple values in a function - For parseHeader - I had to use multple r variables to hold the remainders. Is there any less error-prone implementation?

PNM.hs

module Data.PNM
       ( Coord
       , Image(..)
       , ImageType(..)
       , Encoding(..)
       , PPMImage(..)
       , PGMImage(..)
       , parseHeader
       , Header(..)
       ) where

import Data.Array
import Data.Char
import Data.List
import qualified Data.ByteString.Lazy as S
import qualified Data.ByteString.Lazy.Char8 as SC
import Data.Word
import Control.Monad
import System.IO
import Control.Applicative
import Debug.Trace

type Coord = (Int,Int)
data GrayscalePixel = GrayscalePixel Int deriving Show
data ColorPixel = ColorPixel Int Int Int deriving Show
data Encoding = ASCII | Binary deriving (Show,Eq)
data ImageType = PPM | PGM deriving (Eq,Show)

data PPMImage = PPMImage (Array Coord ColorPixel) deriving Show
data PGMImage = PGMImage (Array Coord GrayscalePixel)
data Header = Header { imageType :: ImageType
                     , imageEncoding :: Encoding
                     , imageCoords :: Coord
                     , imageBitDepth :: Int }

class Pixel p where
  readPixel :: Encoding -> S.ByteString -> Maybe (p,S.ByteString)
  encodePixel :: Encoding -> p -> S.ByteString

class Image img where
  decode :: S.ByteString -> Maybe img
  dimensions :: img -> Coord

  encode :: Encoding -> img -> S.ByteString
  hLoad :: Handle -> IO (Maybe img)
  hLoad h = decode <$> S.hGetContents h

  load :: FilePath -> IO (Maybe img)
  load fileName = decode <$> S.readFile fileName

  dump :: Encoding -> img -> FilePath -> IO ()
  dump encoding img fileName = do
    let encodedImage = encode encoding img
    S.writeFile fileName encodedImage

encodePixels :: (Pixel p) => Encoding -> [p] -> SC.ByteString
encodePixels encoding pixels = SC.concat $ fmap (encodePixel encoding) pixels

encodeHeader :: Header -> S.ByteString
encodeHeader (Header type' encoding (width,height) depth) =
  let fields = fmap SC.pack [ magic type' encoding
                            , show width
                            , show height
                            , show depth ]
      formattedFields = SC.intercalate (SC.singleton ' ') fields
  in formattedFields `SC.append` (SC.singleton '\n')
  where
    magic PGM ASCII = "P2"
    magic PPM ASCII = "P3"
    magic PGM Binary = "P5"
    magic PPM Binary = "P6"

nextWord :: S.ByteString -> S.ByteString
nextWord s
  | SC.null s = SC.empty
  | otherwise = let next = SC.dropWhile isSpace s
                in if SC.null next then SC.empty
                   else if SC.head next == '#'
                        then nextWord $ SC.dropWhile (/= '\n') next
                        else next

nextLine :: S.ByteString -> S.ByteString
nextLine = SC.drop 1 . SC.dropWhile (/= '\n')

parseMagic :: S.ByteString -> Maybe ((Encoding,ImageType),S.ByteString)
parseMagic s = do
  let (word,remainder) = SC.span (\c -> c /= '#' && not (isSpace c)) s
  result <- parseMagic' word
  return (result, remainder)
  where parseMagic' w
          | w == SC.pack "P2" = Just (ASCII,PGM)
          | w == SC.pack "P3" = Just (ASCII,PPM)
          | w == SC.pack "P5" = Just (Binary,PGM)
          | w == SC.pack "P6" = Just (Binary,PPM)
          | otherwise = Nothing

parseHeader :: S.ByteString -> Maybe (Header,S.ByteString)
parseHeader rawImage = do
  ((encoding,imageType),r1) <- parseMagic rawImage
  (width,r2) <- SC.readInt $ nextWord r1
  (height,r3) <- SC.readInt $ nextWord r2
  (bitDepth,r4) <- SC.readInt $ nextWord r3
  return ((Header imageType encoding (width,height) bitDepth),r4)

readPixels :: (Pixel p) => Encoding -> S.ByteString -> [p]
readPixels encoding s
  | SC.null s = []
  | otherwise = let result = readPixel encoding (next' s)
                in case result of
                  Nothing -> []
                  Just (pixel,r) -> pixel:readPixels encoding r
  where
    next'
      | encoding == ASCII = nextWord
      | encoding == Binary = id

instance Pixel GrayscalePixel where
  readPixel ASCII s = do
    (num, r) <- SC.readInt s
    return ((GrayscalePixel num),r)

  readPixel Binary s = do
    (x,xs) <- S.uncons s
    let pixelBin = fromIntegral x
    return $ ((GrayscalePixel pixelBin),xs)

  encodePixel ASCII (GrayscalePixel l) = SC.pack $ (show l) ++ " "
  encodePixel Binary (GrayscalePixel l) = SC.singleton $ chr l

instance Pixel ColorPixel where
  readPixel ASCII s = do
    (red, r1) <- SC.readInt s
    (green, r2) <- SC.readInt $ nextWord r1
    (blue, r3) <- SC.readInt $ nextWord r2
    return ((ColorPixel red green blue),r3)

  readPixel Binary s = do
    (red,r1) <- S.uncons s
    (green,r2) <- S.uncons r1
    (blue,r3) <- S.uncons r2
    return ((ColorPixel (fromIntegral red) (fromIntegral green) (fromIntegral blue)),r3)

  encodePixel ASCII (ColorPixel r g b) = SC.concat $ fmap toAscii [r,g,b]
    where toAscii l = SC.pack $ (show l) ++ " "
  encodePixel Binary (ColorPixel r g b) = SC.pack $ fmap chr [r,g,b]

instance Image PPMImage where
  dimensions (PPMImage pixels) = let (width,height) = snd $ bounds pixels
                                 in (width + 1,height + 1)

  decode rawImage = do
    (header,r) <- parseHeader rawImage
    let imgType = imageType header
    unless (imgType == PPM) Nothing
    let rawPixels = nextLine r
        pixels = readPixels (imageEncoding header) rawPixels
        (width,height) = imageCoords header
    unless ((length pixels) == (width * height)) Nothing
    return (PPMImage $ listArray ((0,0),(width - 1,height - 1)) pixels)

  encode encoding img@(PPMImage pixels) =
    let pixelList = elems pixels
        header = Header PPM encoding (dimensions img) 255
    in (encodeHeader header) `S.append` (encodePixels encoding pixelList)

instance Image PGMImage where
  dimensions (PGMImage pixels) = let (width,height) = snd $ bounds pixels
                                 in (width + 1,height + 1)

  decode rawImage = do
    (header,r) <- parseHeader rawImage
    let imgType = imageType header
    unless (imgType == PGM) Nothing
    let rawPixels = nextLine r
        pixels = readPixels (imageEncoding header) rawPixels
        (width,height) = imageCoords header
    unless ((length pixels) == (width * height)) Nothing
    return (PGMImage $ listArray ((0,0),(width - 1,height - 1)) pixels)

  encode encoding img@(PGMImage pixels) =
    let pixelList = elems pixels
        header = Header PGM encoding (dimensions img) 255
    in (encodeHeader header) `S.append` (encodePixels encoding pixelList)

Main.hs (pnmbin2asc):

import qualified Data.ByteString.Lazy as S
import System.Environment
import Data.PNM

convertImage :: (Image a) => Maybe a -> String -> IO ()
convertImage Nothing _ = do putStrLn "Bad Source Image"
convertImage (Just img) dest = dump ASCII img dest

main = do
  (source:dest:[]) <- getArgs
  content <- S.readFile source
  let header = parseHeader content
  case header of
    Nothing -> putStrLn $ source ++ ": Bad image"
    Just (header,_) -> case (imageEncoding header) of
      ASCII -> putStrLn $ source ++ ": Already an ASCII image"
      Binary -> let image = decode content :: Maybe PPMImage
                in convertImage image dest

P.S. I know about Parsec but I have yet to learn how to use it. I wanted to write this library without it for learning purpose

Answer 1

A few improvements I notice right off the bat

newtype vs. data replace single field data declarations with newtype. newtype has no runtime overhead.

data GrayscalePixel = GrayscalePixel Int
-- becomes
newtype GrayscalePixel = GrayscalePixel Int

Use StateT

A common pattern in your code (ex. parseHeader) is

foo x = do
    (a, s0) <- doSomething0 x
    (b, s1) <- doSomething1 s0
     ...
    (n, sn) <- doSomethingN sn_1
    return $ (f a b ... n, sn)

this is much clearer if you hide the state passing in the State monad, or in this case, the StateT monad transformer. parseHeader becomes

parseHeader :: StateT S.ByteString Maybe Header
parseHeader = do
    (enc, imgType) <- StateT parseMagic
    width  <- readInt
    height <- readInt
    depth  <- readInt
    return $ Header imgType enc (width, height) depth
    where readInt = StateT (SC.readInt . nextWord)

then you can use runStateT :: StateT s m a -> s -> m (a, s) to evaluate.

Profiling

As far as profiling is concerned, Haskell makes it really easy to get a good idea of where your program is slow. Just compile like ghc -O2 Main.hs -prof -auto-all, then run as ./Main src dest +RTS -p and it will produce Main.prof containing profiling information.

Here's the most important bit of the profiling output:

COST CENTRE         MODULE  %time %alloc
dump                PNM      36.6   44.6
encodePixel.toAscii PNM      27.2   24.3
encodePixels        PNM       7.2    8.8
readPixel           PNM       4.3    6.2
...

as you can see, dump and encodePixel.toAscii are taking the majority of time. In particular, encodePixel.toAscii is being very inefficient by showing an Int, then packing it into a ByteString using SC.pack. Optimizing these two functions should provide a nice speedup to your program.

Next Steps

A further improvement would be to use Data.Binary to parse the binary headers. It's designed for exactly this sort of task and is very fast, although I wouldn't recommend pursuing it unless you fix the two functions mentioned above. Currently the time taken to parse the headers is negligible compared to the cost of encoding to ASCII and dumping.

Answer 2

Regarding the problem selecting the right image type, you have enough information in your header to select which type of image to create.

  case header of
    Nothing -> putStrLn $ source ++ ": Bad image"
    Just (header,_) -> case (imageEncoding header) of
      ASCII -> putStrLn $ source ++ ": Already an ASCII image"
      Binary -> let image = decode content :: Maybe PPMImage
                in convertImage image dest

Becomes

  image <- case header of
    Nothing -> putStrLn $ source ++ ": Bad image"
    Just (Header _ ASCII _ _) ->
      putStrLn $ source ++ ": Already an ASCII image"
    Just (Header PPM _ _ _) -> decode content :: Maybe PPMImage
    Just (Header PGM _ _ _) -> decode content :: Maybe PGMImage
  convertImage image dest

Besides, this is a check that should really be happening inside your call to decode. Ask yourself what would happen if your user called decode content :: Maybe PGMImage with PPM encoded content.

Perhaps consider leaving the image format at the value level?

newtype Image pix = MkImg (Array Coord pix) deriving Show

decode PPM content :: Image p

---

Following up on cdk's answer: if you are worried about speed, you should take care how you represent your data.

data ColorPixel = ColorPixel Int Int Int deriving Show

While this looks like it's cheap, beware that those Ints are boxed values. This means that they can hold either thunks, or pointers to Ints. This extra layer of indirection is potentially harmful to performance, so try unpacking the values directly into the record:

{-# LANGUAGE BangPatterns #-}
data ColorPixel = ColorPixel {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int
    deriving Show

note: compiling with -funbox-strict-fields allows you to omit the UNPACK pragmas and have the compiler add them for you.

You should also do this for all performance sensitive single field datatypes that you don't convert into newtypes.

EDIT: Incorporated cdk's feedback re: UNPACK

REF: http://www.haskell.org/ghc/docs/7.0.2/html/users_guide/pragmas.html#unpack-pragma

Answer 3

I have some general design comments. You seem to approach the problem from the OO perspective: you have the Image object with a bunch of virtual methods and the Pixel object with virtual readPixel and encodePixel. These two methods, in turn, internally dispatch based on the type of encoding.

Even in the OO language, I would avoid defining objects that are too smart. Your Image, for instance, knows about file handles. Pixel polymorphism is also strained: readPixel is more like a constructor than a virtual function.

My approach would be more stream based. After reading the header, I would convert the rest of the file to a stream of Ints. For a binary file, that just means mapping fromIntegral over the input. For and ASCII file it means breaking the stream on whitespaces and mapping readInt over it.

Now you have a list of Ints and you either convert it directly to an array for grey scale, or group it into triples and then convert.

This description can be pretty much converted straight to almost self-explanatory code.

As for the encoding, one simple optimization would be to convert bytes to strings using a 256-entry lookup table (Data.Map). (Of course, this won't work if the max value for a pixel component is greater than 255.)