module Codec.Image.PNG
(
PNGImage, Width, Height
, loadPNGFile
, dimensions
, imageData
, hasAlphaChannel
) where
import Codec.Compression.Zlib
import Text.Parsec.Combinator
import Text.Parsec.Prim
import Data.Array.Unboxed
import Data.Array.Storable
import Data.Word
import Data.List
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as C
import Data.Int
import Data.Char
import System.IO
import Control.Monad.Error
import Codec.Image.PNG.Internal.Parser
import Codec.Image.PNG.Internal.CRC
import Codec.Image.PNG.Internal.Filters
data RawPNGChunk = RawPNGChunk {
rawPngChunk_type :: !String,
rawPngChunk_data :: !LB.ByteString
} deriving (Show)
type Width = Word32
type Height = Word32
type Rgb = (Word8, Word8, Word8)
data PNGChunk =
IHDR {
ihdr_width :: !Width
, ihdr_height :: !Height
, ihdr_bitDepth :: !BitDepth
, ihdr_colorType :: !ColorType
, ihdr_compressionMethod :: !CompressionMethod
, ihdr_filterMethod :: !FilterMethod
, ihdr_interlaceMethod :: !InterlaceMethod }
| PLTE {
plte_entries :: !(Array Word8 Rgb) }
| IDAT {
idat_data :: !LB.ByteString }
| UnknownChunk RawPNGChunk
| IEND
deriving (Show)
data ColorType = Ct0 | Ct2 | Ct3 | Ct4 | Ct6 deriving (Show,Eq)
data BitDepth = Bd1 | Bd2 | Bd4 | Bd8 | Bd16 deriving (Show,Eq)
data CompressionMethod = Deflate deriving (Show,Eq)
data FilterMethod = Adaptive deriving (Show,Eq)
data InterlaceMethod = NoInterlace | Adam7 deriving (Show,Eq)
isIDAT :: PNGChunk -> Bool
isIDAT (IDAT _) = True
isIDAT _ = False
data PNGImage = PNGImage {
pngImg_header :: !PNGChunk
, pngImg_otherChunks :: ![PNGChunk]
, pngImg_imageData :: !(StorableArray (Int,Int) Word8)
}
instance Show PNGImage where
show _ = "PNGImage"
pngHeaderBytes :: LB.ByteString
pngHeaderBytes = LB.pack [137, 80, 78, 71, 13, 10, 26, 10]
pngFile :: Parser [RawPNGChunk]
pngFile = do
string pngHeaderBytes
hdr <- rawPngChunk
when (rawPngChunk_type hdr /= "IHDR") $
fail "expecting IHDR as the first chunk"
rest <- many1 rawPngChunk
return (hdr:rest)
rawPngChunk :: Parser RawPNGChunk
rawPngChunk = do
len <- anyWord32
chunkType <- block 4
chunkData <- block (fromIntegral len)
let expectedCrc = crc (LB.concat [chunkType,chunkData])
word32 expectedCrc <?> "valid crc"
return $ RawPNGChunk (C.unpack chunkType) chunkData
parsePlte :: Parser PNGChunk
parsePlte = do
paletteEntries <- many1 paletteEntry
return . PLTE $ listArray (0, fromIntegral (length paletteEntries1)) paletteEntries
where
paletteEntry = liftM3 (,,) anyWord8 anyWord8 anyWord8
parseIhdr :: Parser PNGChunk
parseIhdr = do
width <- anyWord32
height <- anyWord32
bitDepth <- allowedValues word8 [(8,Bd8)]
<?> "valid bit depth (supported: Bd8)"
colorType <- allowedValues word8 [(2,Ct2), (6,Ct6)]
<?> "valid colorType: supported Ct2,Ct6"
compressionMethod <- allowedValues word8 [(0, Deflate)]
<?> "valid compression method: supported Deflate"
filterMethod <- allowedValues word8 [(0, Adaptive)]
<?> "valid filter method: supported Adaptive"
interlaceMethod <- allowedValues word8 [(0, NoInterlace)]
<?> "valid interlace method: supported NoInterlace"
return $ IHDR {
ihdr_width = width
, ihdr_height = height
, ihdr_bitDepth = bitDepth
, ihdr_colorType = colorType
, ihdr_compressionMethod = compressionMethod
, ihdr_filterMethod = filterMethod
, ihdr_interlaceMethod = interlaceMethod
}
toPngChunk :: RawPNGChunk -> Either String PNGChunk
toPngChunk raw =
case chunkName of
"IHDR" -> parseChunkData parseIhdr
"PLTE" -> parseChunkData parsePlte
"IEND" -> return IEND
"IDAT" -> return $ IDAT (rawPngChunk_data raw)
_ -> return $ UnknownChunk raw
where
parseChunkData a =
case runP a () "" (rawPngChunk_data raw) of
Left e -> fail $ "failed to parse chunk " ++ show chunkName ++ ", " ++ show e
Right x -> return x
chunkName = rawPngChunk_type raw
toPngImage :: [RawPNGChunk] -> IO (Either String PNGImage)
toPngImage chunks = do
case mapM toPngChunk chunks >>= return . partition isIDAT of
Right (_, []) -> return $ Left "File has no chunks!"
Right (dataChunks, hdr:otherChunks) -> do
let dataDecompressed = decompress . LB.concat . map idat_data $ dataChunks
bpp = bytesPerPixel (ihdr_colorType hdr) (ihdr_bitDepth hdr)
w = fromIntegral (ihdr_width hdr)
h = fromIntegral (ihdr_height hdr)
sls <- defilter_scanlines_arr (w,h) (fromIntegral bpp) dataDecompressed
return $ Right (PNGImage hdr otherChunks sls)
Left x -> return $ Left x
loadPNGFile :: FilePath -> IO (Either String PNGImage)
loadPNGFile fn = do
rawChunks <- parseFromFile pngFile fn
case rawChunks of
Right chunks -> toPngImage chunks `catchError` (\e -> return (Left (show e)))
Left s -> return (Left s)
sampleWidth :: BitDepth -> Int
sampleWidth Bd1 = 1
sampleWidth Bd2 = 2
sampleWidth Bd4 = 4
sampleWidth Bd8 = 8
sampleWidth Bd16 = 16
bytesPerPixel :: ColorType -> BitDepth -> Int
bytesPerPixel Ct0 Bd16 = 2
bytesPerPixel Ct0 _ = 1
bytesPerPixel Ct2 Bd1 = 1
bytesPerPixel Ct2 Bd2 = 1
bytesPerPixel Ct2 Bd4 = 2
bytesPerPixel Ct2 Bd8 = 3
bytesPerPixel Ct2 Bd16 = 6
bytesPerPixel Ct3 _ = 3
bytesPerPixel Ct4 Bd8 = 2
bytesPerPixel Ct4 Bd16 = 4
bytesPerPixel Ct4 _ = 1
bytesPerPixel Ct6 Bd8 = 4
bytesPerPixel Ct6 Bd16 = 8
bytesPerPixel Ct6 Bd4 = 2
bytesPerPixel Ct6 _ = 1
hasAlphaChannel :: PNGImage -> Bool
hasAlphaChannel img = case ihdr_colorType hdr of
Ct6 -> True
_ -> False
where hdr = pngImg_header img
dimensions :: PNGImage -> (Width,Height)
dimensions img = (ihdr_width hdr, ihdr_height hdr)
where hdr = pngImg_header img
pixelWidth :: PNGImage -> Int
pixelWidth img = bytesPerPixel (ihdr_colorType hdr) (ihdr_bitDepth hdr)
where hdr = pngImg_header img
imageData :: PNGImage -> StorableArray (Int,Int) Word8
imageData img = pngImg_imageData img