module Graphics.Pgm (pgmToArray,
pgmsToArrays,
pgmToArrayWithComments, pgmsToArraysWithComments,
arrayToPgmWithComment,
pgmsFromFile, pgmsFromHandle,
arrayToPgm, arrayToFile, arrayToHandle, arraysToHandle,
arraysToFile) where
import Text.Parsec
import Text.Parsec.ByteString (Parser)
import System.IO
import Data.Array.Unboxed
import Data.ByteString as B (take, drop, unpack, pack, ByteString,
append, hGetContents, hPutStr)
import Data.ByteString.Internal (c2w)
import Data.Word
import Text.Printf
import Control.Monad (liftM)
import Data.List (intercalate)
magicNumber :: Parser ()
magicNumber = do { char 'P'; char '5'; return () }
integer :: Parser Int
integer = do { s <- many1 digit; return $ read s }
width :: Parser Int
width = integer
height :: Parser Int
height = integer
maxVal :: Parser Int
maxVal = do { i <- integer; return $ min 65536 i }
comment :: Parser String
comment = do { char '#'; c <- manyTill anyChar (try newline); return $ c ++ "\n" }
commentAwareWhiteSpace :: Parser String
commentAwareWhiteSpace = liftM concat $ many1 (choice [comment,do { many1 space; return "" }])
pgmHeader :: Parser (Int,Int,Int,String)
pgmHeader = do magicNumber <?> "magic number"
hVal0 <- commentAwareWhiteSpace
cols <- width <?> "width"
hVal1 <- commentAwareWhiteSpace
rows <- height <?> "height"
hVal2 <- commentAwareWhiteSpace
m <- maxVal <?> "maximum grey value"
space
let q = hVal0 ++ hVal1 ++ hVal2
return (rows,cols,m, Prelude.init q)
pgmWithComments :: (IArray UArray a, Integral a) => Parser (UArray (Int,Int) a, String)
pgmWithComments = do (rows,cols,m,comments) <- pgmHeader
let d = if (m < 256) then 1 else 2
ip <- getInput
let body = B.take (rows*cols*d) ip
setInput $ B.drop (rows*cols*d) ip
let arr = readArray d rows cols body
return (arr,comments)
pgmsWithComments :: (IArray UArray a, Integral a) => Parser [(UArray (Int,Int) a, String)]
pgmsWithComments = many1 (do { h <- pgmWithComments ; spaces ; return h })
pgm :: (IArray UArray a, Integral a) => Parser (UArray (Int,Int) a)
pgm = do (rows,cols,m,_) <- pgmHeader
let d = if (m < 256) then 1 else 2
ip <- getInput
let body = B.take (rows*cols*d) ip
setInput $ B.drop (rows*cols*d) ip
let arr = readArray d rows cols body
return (arr)
pgms :: (IArray UArray a, Integral a) => Parser [UArray (Int,Int) a]
pgms = many1 (do { h <- pgm ; spaces ; return h })
pgmToArray :: (Integral a, IArray UArray a) => B.ByteString -> Either ParseError (UArray (Int,Int) a)
pgmToArray s = parse pgm "Failed to parse PGM." s
pgmToArrayWithComments :: (Integral a, IArray UArray a) => B.ByteString -> Either ParseError (UArray (Int,Int) a, String)
pgmToArrayWithComments s = parse pgmWithComments "Failed to parse PGM." s
pgmsToArrays :: (Integral a, IArray UArray a) => B.ByteString -> Either ParseError [UArray (Int,Int) a]
pgmsToArrays s = parse pgms "Failed to parse PGMs." s
pgmsToArraysWithComments :: (Integral a, IArray UArray a) => B.ByteString -> Either ParseError [(UArray (Int,Int) a, String)]
pgmsToArraysWithComments s = parse pgmsWithComments "Failed to parse PGMs." s
pgmsFromFile :: String -> IO (Either ParseError [UArray (Int,Int) Int])
pgmsFromFile fname = do h <- openFile fname ReadMode
s <- pgmsFromHandle h
hClose h
return s
pgmsFromHandle :: Handle -> IO (Either ParseError [UArray (Int,Int) Int])
pgmsFromHandle h = liftM pgmsToArrays $ B.hGetContents h
readArray8 :: Int -> Int -> B.ByteString -> UArray (Int,Int) Word8
readArray8 rows cols src = listArray ((0,0), (rows1,cols1)) (unpack src)
readArray16 :: Int -> Int -> B.ByteString -> UArray (Int,Int) Word16
readArray16 rows cols src = listArray ((0,0), (rows1,cols1)) src'
where raw = unpack src
src' = pairWith f raw
f a b = (fromIntegral a)*256 + (fromIntegral b)
readArray :: (IArray UArray a, Integral a) => Int -> Int -> Int -> B.ByteString -> UArray (Int,Int) a
readArray 1 rows cols src = amap fromIntegral $ readArray8 rows cols src
readArray 2 rows cols src = amap fromIntegral $ readArray16 rows cols src
pair :: [a] -> [(a,a)]
pair [] = []
pair (_:[]) = []
pair (a:b:ls) = (a,b):(pair ls)
pairWith :: (a -> a -> b) -> [a] -> [b]
pairWith f ls = Prelude.map (\(a,b) -> f a b) $ pair ls
pgmHeaderString :: Int -> Int -> Word16 -> String -> B.ByteString
pgmHeaderString rows cols mVal comm = pack $ (Prelude.map c2w) $
printf "P5\n#%s\n%d %d %d\n" (format comm)
(cols+1) (rows+1) mVal
where format str = Data.List.intercalate "\n#" $ lines str
arrayToPgm :: IArray m Word16 => m (Int,Int) Word16 -> B.ByteString
arrayToPgm arr = pgmHeaderString rows cols mVal "" `B.append`
listToByteString mVal (elems arr)
where (rows,cols) = (xmaxxmin,ymaxymin)
((xmin,ymin),(xmax,ymax)) = bounds arr
mVal = arrayLift max arr
arrayToPgmWithComment :: IArray m Word16 => m (Int,Int) Word16 -> String -> B.ByteString
arrayToPgmWithComment arr cm = pgmHeaderString rows cols mVal cm `B.append`
listToByteString mVal (elems arr)
where (rows,cols) = (xmaxxmin,ymaxymin)
((xmin,ymin),(xmax,ymax)) = bounds arr
mVal = arrayLift max arr
arrayLift :: (Ix i, IArray m a) => (a -> a -> a) -> m i a -> a
arrayLift f arr = Prelude.foldl f (head q) q
where q = elems arr
listToByteString :: Word16 -> [Word16] -> B.ByteString
listToByteString d vs
| d < 256 = pack $ ((Prelude.map fromIntegral vs)::[Word8])
| otherwise = pack $ concat $ map (\x -> [fromIntegral (x `div` 256),
fromIntegral (x `rem` 256)]) vs
arrayToHandle :: IArray m Word16 => Handle -> m (Int,Int) Word16 -> IO ()
arrayToHandle h arr = B.hPutStr h (arrayToPgm arr)
arrayToFile :: IArray m Word16 => String -> m (Int,Int) Word16 -> IO ()
arrayToFile fname arr = do h <- openFile fname WriteMode
arrayToHandle h arr
hClose h
arraysToHandle :: IArray m Word16 => Handle -> [m (Int,Int) Word16] -> IO ()
arraysToHandle h arrs = mapM_ (arrayToHandle h) arrs
arraysToFile :: IArray m Word16 => String -> [m (Int,Int) Word16] -> IO ()
arraysToFile fname arrs = do h <- openFile fname WriteMode
arraysToHandle h arrs
hClose h