[Haskell] image writing library

[Remi Turk]

On Thu, Aug 05, 2004 at 02:07:02PM +0200, Ketil Malde wrote:
> 
> Hi,
> 
> I would like to write an (Array (Int,Int) Int) to a file in some kind
> of image format.  I implemented (quick and very dirty) XBM output, but
> it would be nice to have some colors, and anyway, I can't seem to show
> the XBMs as grayscale.
> 
> I've searched around a bit, but the only stuff I could find was
> defunct references to GIF writer, Jeroen Fokker's JPEG stuff (which
> may still work, but I don't want JPEG compression), and the PPM
> support in Andrew Cooke's Pancito.
> 
> Ripping out the latter currently seems to be the best bet, not sure
> how closely tied it is to the rest of the code.  So, before I start,
> does anybody know any other libraries or programs that could be used?

I once wrote a mini PPM read/write library for a
markov-like-chains-in-images fun project.

with the following basic API:

type Image      = Matrix Color
withColor       :: ((Int, Int, Int) -> (Int, Int, Int)) -> Color -> Color
-- The Int-argument gives the maximum number for a color value: usually 255
readPPM         :: String -> (Int, Image)
showPPM         :: Int -> Image -> String

Though it's quite horribly slow it does work:

Prelude PPM Matrix> (maxColor, img) <- readPPM `fmap` readFile "/tmp/foo.ppm"
Prelude PPM Matrix> let img' = amap (withColor $ \(r,g,b) -> (r,g,b)) img
Prelude PPM Matrix> writeFile "/tmp/bar.ppm" $ showPPM maxColor img'

bar.ppm == foo.ppm afterwards.

The Matrix module merely reexports some IArray instance.
(DiffUArray, in my program)

Happy hacking,
Remi

-- 
Nobody can be exactly like me. Even I have trouble doing it.
-------------- next part --------------
{-
    Copyright (C) 2004 Remi Turk <rturk at science.uva.nl>
-}
module Matrix (
    Matrix,
    Location,
    module Array
) where

-- DiffArrays are MUCH faster (in this case, usually)
--import Array
import Data.Array.Diff as Array
--import Data.Array.Unboxed as Array

type Location   = (Int, Int)
type Matrix a   = DiffUArray Location a
-------------- next part --------------
{-
    Copyright (C) 2004 Remi Turk <rturk at science.uva.nl>
-}
module PPM (
    Color,
    Image,
    readPPM,
    showPPM,
    withColor,
    fromColor,
    toColor
) where

import Char
import Text.ParserCombinators.Parsec
import Data.Bits

import Matrix

--type Color      = (Int, Int, Int)
type Color      = Int
type Image      = Matrix Color

withColor       :: ((Int, Int, Int) -> (Int, Int, Int)) -> Color -> Color
withColor f     = toColor . f . fromColor

toColor         :: (Int, Int, Int) -> Color
fromColor       :: Color -> (Int, Int, Int)
{-
toColor         = id
fromColor       = id
-}
toColor (r,g,b) = (r `shiftL` 16) .|. (g `shiftL` 8) .|. b
fromColor col   = (col `shiftR` 16, (col `shiftR` 8) .&. 0xFF, col .&. 0xFF)

skip parser = parser >> return ()

magicNo     = string "P6" >> return () <?> "magicNo"
comment     = char '#' >> skipMany (noneOf "\n") >> skip newline <?> "comment"
whitespace  = skipMany1 (satisfy isSpace) <?> "whitespace"
number      = many1 (satisfy isDigit) <?> "number"

separator   = many1 (whitespace <|> comment)

readPPM             :: String -> (Int, Image)
readPPM s           = case parse parser "readImage" s of
                        Left err    -> error (show err)
                        Right image -> image
    where
        parser      :: GenParser Char st (Int, Image)
        parser      = do
                        magicNo;
                        separator
                        width <- read `fmap` number;    separator
                        height <- read `fmap` number;   separator
                        maxColor <- read `fmap` number; newline
                        pixels <- many pixel
                        let
                            bounds = ((1, 1), (width, height))
                            locs  = [(x,y) | y <- [1..height], x <- [1..width]]
                        return (maxColor, array bounds (zip locs pixels))
        pixel       = do
                        r <- anyChar
                        g <- anyChar
                        b <- anyChar
                        return $ toColor (ord r, ord g, ord b)

showPPM             :: Int -> Image -> String
showPPM maxColor image
                    = showString
                        (unlines ["P6", show w, show h, show maxColor])
                        $ map chr $ concatMap (f . fromColor)
                        $ map (image!) locs
    where
        f (r,g,b)   = [r,g,b]
        (_,(w,h))   = bounds image
        locs        = [(x,y) | y <- [1..h], x <- [1..w]]