module Graphics.Netpbm (
PPMType (..)
, PPM (..)
, PpmPixelRGB8
, PpmPixelRGB16
, parsePPM
, PpmParseResult
) where
import Control.Monad
import Control.Applicative
import Data.Attoparsec.ByteString as A
import Data.Attoparsec.ByteString.Char8 as A8
import Data.Attoparsec.Binary (anyWord16be)
import Data.ByteString (ByteString)
import Data.Char (ord)
import Data.List (foldl')
import Data.Word (Word8, Word16)
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Generic
import qualified Data.Vector.Generic.Mutable
import Data.Vector.Unboxed.Deriving
data PPMType = P1
| P2
| P3
| P4
| P5
| P6
deriving (Eq, Show, Enum, Ord)
data PPM = PPM {
ppmType :: PPMType
, ppmWidth :: !Int
, ppmHeight :: !Int
, ppmData :: PpmPixelData
}
instance Show PPM where
show PPM { ppmType, ppmWidth, ppmHeight } = "PPM " ++ show ppmType ++ " image " ++ dim
where
dim = show (ppmWidth, ppmHeight)
data PpmPixelRGB8 = PpmPixelRGB8 !Word8
!Word8
!Word8
deriving (Eq, Show)
data PpmPixelRGB16 = PpmPixelRGB16 !Word16
!Word16
!Word16
deriving (Eq, Show)
data PpmPixelData = PpmPixelDataRGB8 (U.Vector PpmPixelRGB8)
| PpmPixelDataRGB16 (U.Vector PpmPixelRGB16)
derivingUnbox "PpmPixelRGB8"
[t| PpmPixelRGB8 -> (Word8, Word8, Word8) |]
[| \ (PpmPixelRGB8 a b c) -> (a, b, c) |]
[| \ (a, b, c) -> PpmPixelRGB8 a b c |]
derivingUnbox "PpmPixelRGB16"
[t| PpmPixelRGB16 -> (Word16, Word16, Word16) |]
[| \ (PpmPixelRGB16 a b c) -> (a, b, c) |]
[| \ (a, b, c) -> PpmPixelRGB16 a b c |]
magicNumberParser :: Parser PPMType
magicNumberParser = do
magic <- choice ["P1", "P2", "P3", "P4", "P5", "P6"]
case magic of
"P1" -> return P1
"P2" -> return P2
"P3" -> return P3
"P4" -> return P4
"P5" -> return P5
"P6" -> return P6
_ -> fail $ "PPM: uknown PPM format " ++ show magic
ppmParser :: Parser PPM
ppmParser = do
ppmType <- magicNumberParser
when (ppmType /= P6) $ error "haskell-netpbm currently only supports PPM P6"
comments
skipSpace
comments
width <- decimalC
skipSpace
comments
height <- decimalC
skipSpace
comments
maxColorVal <- decimalC
when (not $ isValidColorVal maxColorVal) $
fail $ "PPM: invalid color maxval " ++ show maxColorVal
comments
_ <- A8.satisfy isSpace
raster <- if maxColorVal < 256
then PpmPixelDataRGB8 <$> (U.replicateM (height * width) $
PpmPixelRGB8 <$> anyWord8 <*> anyWord8 <*> anyWord8)
else PpmPixelDataRGB16 <$> (U.replicateM (height * width) $
PpmPixelRGB16 <$> anyWord16be <*> anyWord16be <*> anyWord16be)
return $ PPM ppmType width height raster
where
isValidColorVal v = v > 0 && v < 65536
comments = void $ many comment
comment = "#" .*> A.takeWhile isNotNewline <* endOfLine
isNotNewline w = w /= 10 && w /= 13
decimalC :: Parser Int
decimalC = foldl' shiftDecimalChar 0 <$> many1' (digit <* comments)
shiftDecimalChar a d = a * 10 + ord d (48 :: Int)
imagesParser :: Parser [PPM]
imagesParser = many1 (ppmParser <* skipSpace)
type PpmParseResult = Either String ([PPM], Maybe ByteString)
parsePPM :: ByteString -> PpmParseResult
parsePPM bs = case parse imagesParser bs of
Done "" images -> Right (images, Nothing)
Done rest images -> Right (images, Just rest)
Fail _ _ e -> Left e
Partial cont -> case cont "" of
Done "" images -> Right (images, Nothing)
Done rest images -> Right (images, Just rest)
Partial _ -> error "parsePPM bug: Got a partial result after end of input"