diff --git a/Codec/Image/PNG.hs b/Codec/Image/PNG.hs new file mode 100644 --- /dev/null +++ b/Codec/Image/PNG.hs @@ -0,0 +1,244 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Formats.PNG +-- Copyright : (c) Marko Lauronen 2008 +-- License : BSD +-- +-- Maintainer : marko.lauronen@pp1.inet.fi +-- Stability : experimental +-- Portability : non-portable (GHC only) +-- +-- A simple, pure Haskell PNG loader. Currently supports 24bit RGB(A) images +-- with no interlacing. Also lacks support for color indexed (paletted) images. +-- +-- The image is stored in a StorableArray for compatibility with OpenGL (the +-- array supports getting Ptr Word8 to the image data using withStorableArray +-- function). +-- +----------------------------------------------------------------------------- +module Codec.Image.PNG + ( + -- * Types + PNGImage, Width, Height + -- * Functions + , loadPNGFile + , dimensions + --, pixelWidth + , 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 + +-- | Type for raw PNG chunks +-- The parsing happens in two phases: first the file is read into +-- raw chunks, then the raw chunks are parsed into actual PNGChunks +-- This is due to the CRC checksum that requires is easiest to compute +-- with raw chunk data. +data RawPNGChunk = RawPNGChunk { + rawPngChunk_type :: !String, + rawPngChunk_data :: !LB.ByteString + } deriving (Show) + +type Width = Word32 +type Height = Word32 +type Rgb = (Word8, Word8, Word8) + +-- | The actual fully parsed chunk type +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 -- chunk types not supported yet + | 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" + +-- | Raw chunk parsing + +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 + +-- | Final chunk parsing + +parsePlte :: Parser PNGChunk +parsePlte = do + paletteEntries <- many1 paletteEntry + return . PLTE $ listArray (0, fromIntegral (length paletteEntries-1)) paletteEntries + where + paletteEntry = liftM3 (,,) anyWord8 anyWord8 anyWord8 + +parseIhdr :: Parser PNGChunk +parseIhdr = do + width <- anyWord32 + height <- anyWord32 + -- [(1,Bd1), (2,Bd2), (4,Bd4), (8,Bd8), (16,Bd16)] + bitDepth <- allowedValues word8 [(8,Bd8)] + "valid bit depth (supported: Bd8)" + --[(0,Ct0), (2,Ct2), (3,Ct3), (4,Ct4), (6,Ct6)] + 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" + -- [(0, NoInterlace), (1, Adam7)] + 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 + } + +-- | conversion from raw chunks to final chunks +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 + +-- |Load a PNG file, Left value contains a description of a problem as a String, +-- if any +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 + +-- |Check if the image has alpha channel +hasAlphaChannel :: PNGImage -> Bool +hasAlphaChannel img = case ihdr_colorType hdr of + Ct6 -> True + _ -> False + where hdr = pngImg_header img + +-- |Get dimensions of the image (in pixels) +dimensions :: PNGImage -> (Width,Height) +dimensions img = (ihdr_width hdr, ihdr_height hdr) + where hdr = pngImg_header img + +-- |Bytes per pixel +pixelWidth :: PNGImage -> Int +pixelWidth img = bytesPerPixel (ihdr_colorType hdr) (ihdr_bitDepth hdr) + where hdr = pngImg_header img + +-- |Get image data as C-compatible StorableArray +imageData :: PNGImage -> StorableArray (Int,Int) Word8 +imageData img = pngImg_imageData img diff --git a/Codec/Image/PNG/Internal/CRC.hs b/Codec/Image/PNG/Internal/CRC.hs new file mode 100644 --- /dev/null +++ b/Codec/Image/PNG/Internal/CRC.hs @@ -0,0 +1,29 @@ +{-# OPTIONS -fglasgow-exts -fbang-patterns #-} + +module Codec.Image.PNG.Internal.CRC (update_crc, crc) where + +import Data.Word +import Data.Array.Unboxed +import Data.Bits +import qualified Data.ByteString.Lazy as LB + +crc_table :: UArray Word32 Word32 +crc_table = listArray (0,255) . map iterate_c $ [0..] + where + iterate_c = (!! 8) . iterate compute_c + compute_c c + | c .&. 1 == 1 = 0xedb88320 `xor` (c `shiftR` 1) + | otherwise = c `shiftR` 1 + +update_crc :: Word32 -> LB.ByteString -> Word32 +update_crc !c bs + | LB.null bs = c + | otherwise = let w = LB.head bs + newcrc = (crc_table ! ((c `xor` fromIntegral w) .&. 0xff)) `xor` (c `shiftR` 8) + in + update_crc newcrc (LB.tail bs) + +crc :: LB.ByteString -> Word32 +crc = (`xor` 0xffffffff) . update_crc 0xffffffff + +--test = crc $ LB.replicate 10000000 128 diff --git a/Codec/Image/PNG/Internal/Filters.hs b/Codec/Image/PNG/Internal/Filters.hs new file mode 100644 --- /dev/null +++ b/Codec/Image/PNG/Internal/Filters.hs @@ -0,0 +1,98 @@ +{-# OPTIONS -fglasgow-exts -fbang-patterns #-} + +module Codec.Image.PNG.Internal.Filters (defilter_scanlines_arr) where + +import Data.Array.Storable +import Data.Array.IO + +import Data.Word +import Data.Maybe + +import qualified Data.ByteString.Lazy as LB + +type Width = Int +type Height = Int + +-- | Defilter filtered PNG data (data includes scanlines prepended with filter +-- types). +defilter_scanlines_arr :: (Width,Height) -> Int -> LB.ByteString + -> IO (StorableArray (Width,Height) Word8) +defilter_scanlines_arr (width,height) bpp bs = do + (slTypes, imgArr) <- imageArray (widthInBytes, height) bs + doFilter widthInBytes bpp imgArr slTypes + return imgArr + where + widthInBytes = bpp*width + +-- | create mutable array for defiltering the image and break out scanline types +imageArray :: (Width,Height) -> LB.ByteString + -> IO ([Word8],StorableArray (Int,Int) Word8) +imageArray (width,height) bs = do + a <- newListArray ((0,0), (height-1, width-1)) $ LB.unpack imageData + return (scanlineTypes, a) + where + imageData = LB.concat scanlineData + (scanlineTypes, scanlineData) = unzip scanlines + scanlines = map (fromJust . LB.uncons) (chop bs) + chop b + | LB.null b = [] + | otherwise = let (sl,rest) = LB.splitAt slWidth b + in sl : chop rest + slWidth = fromIntegral (width+1) + +-- | Perform filtering on the image array (standard adaptive filters supported) +doFilter :: Width -> Int -> StorableArray (Int,Int) Word8 -> [Word8] + -> IO () +doFilter width bpp image scanlineTypes = doFilter' scanlineTypes 0 + where + doFilter' [] _ = return () + doFilter' (0:rest) !y = doFilter' rest (y+1) -- no filter on this line + doFilter' (1:rest) !y = sub_filter 0 >> doFilter' rest (y+1) + where sub_filter !x + | x> doFilter' rest (y+1) + where up_filter !x + | x> doFilter' rest (y+1) + where avg_filter !x + | x> doFilter' rest (y+1) + where paeth_filter !x + | x Int -> Int -> Int +paeth_predictor !a !b !c + | pa <= pb && pa <= pc = a + | pb <= pc = b + | otherwise = c + where + p = a + b - c + pa = abs(p-a) + pb = abs(p-b) + pc = abs(p-c) diff --git a/Codec/Image/PNG/Internal/Parser.hs b/Codec/Image/PNG/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/Codec/Image/PNG/Internal/Parser.hs @@ -0,0 +1,74 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Codec.Image.PNG.Internal.Parser where + +import Text.Parsec.Prim +import Text.Parsec.Combinator + +import Data.Word +import Data.Bits +import Numeric (showHex) + +import qualified Data.ByteString.Lazy as LB + +instance (Monad m) => Stream LB.ByteString m Word8 where + uncons = return . LB.uncons + +type Parser = Parsec LB.ByteString () + +word8 :: (Stream LB.ByteString m Word8) => Word8 -> ParsecT LB.ByteString u m Word8 +word8 = satisfy . (==) + +word16 :: (Stream LB.ByteString m Word8) => Word16 -> ParsecT LB.ByteString u m Word16 +word16 w = (word8 hi >> word8 lo >> return w) "0x" ++ showHex w "" + where + hi = fromIntegral (w `shiftR` 8) + lo = fromIntegral w + +word32 :: (Stream LB.ByteString m Word8) => Word32 -> ParsecT LB.ByteString u m Word32 +word32 w = (word16 hi >> word16 lo >> return w) "0x" ++ showHex w "" + where + hi = fromIntegral (w `shiftR` 16) + lo = fromIntegral w + +satisfy :: (Stream LB.ByteString m Word8) => (Word8 -> Bool) -> ParsecT LB.ByteString u m Word8 +satisfy f = tokenPrim (\c -> "0x" ++ showHex c "") + (\pos _ _ -> pos) + (\c -> if f c then Just c else Nothing) + +anyWord8 :: (Stream LB.ByteString m Word8) => ParsecT LB.ByteString u m Word8 +anyWord8 = anyToken + +anyWord16 :: (Stream LB.ByteString m Word8) => ParsecT LB.ByteString u m Word16 +anyWord16 = do + hi <- anyWord8 + lo <- anyWord8 + return $ (fromIntegral hi `shiftL` 8) .|. fromIntegral lo + +anyWord32 :: (Stream LB.ByteString m Word8) => ParsecT LB.ByteString u m Word32 +anyWord32 = do + hi <- anyWord16 + lo <- anyWord16 + return $ (fromIntegral hi `shiftL` 16) .|. fromIntegral lo + +string :: (Stream LB.ByteString m Word8) => LB.ByteString -> ParsecT LB.ByteString u m LB.ByteString +string s = mapM_ word8 (LB.unpack s) >> return s + +block :: (Stream LB.ByteString m Word8) => Int -> ParsecT LB.ByteString u m LB.ByteString +block size = do -- count size anyWord8 >>= return . LB.pack + i <- getInput + let (s,r) = LB.splitAt (fromIntegral size) i + setInput r + return s + +allowedValues :: (a -> Parser a) -> [(a,b)] -> Parser b +allowedValues fn = choice . map (\(val,res) -> fn val >> return res) + +parseFromFile :: Parser a -> FilePath -> IO (Either String a) +parseFromFile p fname + = do input <- LB.readFile fname + return $ case runP p () fname input of + Left err -> Left (show err) + Right x -> Right x + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +Copyright (c) 2008, Marko Lauronen +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,20 @@ + +This is the beginnings of a pure Haskell loader for PNG images. It +stores the uncompressed image in a StorableArray (Int,Int) Word8, so +it should be convenient to use as a texture loader in OpenGL +applications since you can get a Ptr Word8 to the image data easily. + +The performance is reasonable (the following run loads an 1.5megabyte +1024x768 24bit PNG image and writes out the raw bytes on a 2GHz +MacBook): + +Mars2:PNG marko$ time ./Test scenery_1 + +real 0m0.315s +user 0m0.267s +sys 0m0.027s + +Source for the test is in Test.hs. + +Note that the library has not been tested with every possible kind of +PNG images, so use at your own risk. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple + +> main = defaultMain diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -0,0 +1,78 @@ + +module Main where + +import Graphics.UI.GLUT +import Graphics.Rendering.OpenGL + +import Control.Monad + +import Data.ByteString.Unsafe +import qualified Data.ByteString as BS +import Codec.Image.PNG +import System.IO +import Data.Array.Storable +import System +import System.CPUTime + +main :: IO () +main = setupOpenGL + +(winWidth, winHeight) = (640,480) + +setupOpenGL :: IO () +setupOpenGL = do + (_, [fn]) <- getArgsAndInitialize + initialWindowSize $= Size winWidth winHeight + initialDisplayMode $= [RGBAMode, WithDepthBuffer] + win <- createWindow "PNGLoader test" + displayCallback $= displayFn + setupTexture fn + mainLoop + +displayFn :: IO () +displayFn = do + viewport $= (Position 0 0, Size winWidth winHeight) + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral winWidth) 0 (fromIntegral winHeight) + scale 1.0 (-1.0) (1.0::GLfloat) + translate (Vector3 0.0 (fromIntegral (-winHeight)) (0.0::GLfloat)) + matrixMode $= Modelview 0 + loadIdentity + + clearColor $= Color4 0 0 0 0 + clear [ColorBuffer, DepthBuffer] + texture Texture2D $= Enabled + textureBinding Texture2D $= Just (TextureObject 0) + renderTexture 0 0 640 480 + swapBuffers + +renderTexture :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO () +renderTexture x y w h = do + renderPrimitive Quads $ do texCoord (TexCoord2 0 (0::GLfloat)) + vertex (Vertex2 x y) + texCoord (TexCoord2 1 (0::GLfloat)) + vertex (Vertex2 (x+w) y) + texCoord (TexCoord2 1 (1::GLfloat)) + vertex (Vertex2 (x+w) (y+h)) + texCoord (TexCoord2 0 (1::GLfloat)) + vertex (Vertex2 x (y+h)) + +setupTexture :: FilePath -> IO () +setupTexture fn = do + startTime <- getCPUTime + x <- loadPNGFile fn + print x + stopTime <- getCPUTime + putStrLn $ "Loading took " ++ show ((stopTime - startTime) `div` 1000000000) ++ " milliseconds" + case x of + Left s -> (putStrLn $ "ERROR: " ++ s) >> exitWith (ExitFailure (-1)) + Right img -> do + texture Texture2D $= Enabled + textureBinding Texture2D $= Just (TextureObject 0) + let (w,h) = dimensions img + (a,b) = case hasAlphaChannel img of + True -> (RGBA8, RGBA) + False -> (RGB8, RGB) + withStorableArray (imageData img) $ \ptr -> + build2DMipmaps Texture2D a (fromIntegral w) (fromIntegral h) (PixelData b UnsignedByte ptr) diff --git a/pngload.cabal b/pngload.cabal new file mode 100644 --- /dev/null +++ b/pngload.cabal @@ -0,0 +1,23 @@ +name: pngload +version: 0.1 +copyright: (c) 2008 Marko Lauronen +license: BSD3 +license-file: LICENSE +author: Marko Lauronen +maintainer: Marko Lauronen +category: Codecs +synopsis: Pure Haskell loader for PNG images +description: This package provides a simple PNG loader for PNG images. It currently supports + 24bit RGB(A) images with no interlacing. +stability: experimental +build-type: Simple +cabal-version: >= 1.2.1 +extra-source-files: Test.hs +data-files: LICENSE, README, test_images/mustang.png + +library + exposed-modules: Codec.Image.PNG, Codec.Image.PNG.Internal.CRC, + Codec.Image.PNG.Internal.Filters, + Codec.Image.PNG.Internal.Parser + build-depends: base >= 3, zlib, parsec >= 3.0.0, bytestring, array, mtl, haskell98 + ghc-options: -Wall diff --git a/test_images/mustang.png b/test_images/mustang.png new file mode 100644 Binary files /dev/null and b/test_images/mustang.png differ