module Graphics.Netpbm (
PPMType (..)
, PPM (..)
, PpmPixelRGB8
, PpmPixelRGB16
, PPMHeader (..)
, PpmPixelData (..)
, 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 Foreign.Storable.Record as Store
import Foreign.Storable (Storable (..))
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 {
ppmHeader :: PPMHeader
, ppmData :: PpmPixelData
}
data PPMHeader = PPMHeader {
ppmType :: PPMType
, ppmWidth :: Int
, ppmHeight :: Int
} deriving (Eq, Show)
instance Show PPM where
show PPM { ppmHeader = PPMHeader { 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 |]
storePixel8 :: Store.Dictionary PpmPixelRGB8
storePixel8 =
Store.run $ liftA3 PpmPixelRGB8
(Store.element (\(PpmPixelRGB8 x _ _) -> x))
(Store.element (\(PpmPixelRGB8 _ y _) -> y))
(Store.element (\(PpmPixelRGB8 _ _ z) -> z))
storePixel16 :: Store.Dictionary PpmPixelRGB16
storePixel16 =
Store.run $ liftA3 PpmPixelRGB16
(Store.element (\(PpmPixelRGB16 x _ _) -> x))
(Store.element (\(PpmPixelRGB16 _ y _) -> y))
(Store.element (\(PpmPixelRGB16 _ _ z) -> z))
instance Storable PpmPixelRGB8 where
sizeOf = Store.sizeOf storePixel8
alignment = Store.alignment storePixel8
peek = Store.peek storePixel8
poke = Store.poke storePixel8
instance Storable PpmPixelRGB16 where
sizeOf = Store.sizeOf storePixel16
alignment = Store.alignment storePixel16
peek = Store.peek storePixel16
poke = Store.poke storePixel16
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
comments
skipSpace
comments
height <- decimalC
comments
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 (PPMHeader 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 <$> ((:) <$> digit <*> many (comments *> digit))
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
Partial cont -> resultToEither (cont "")
r -> resultToEither r
where
resultToEither r = case r 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"
Fail _ cs e -> Left $ e ++ "; contexts: " ++ show cs