JuicyPixels 2.0.2 → 3.0
raw patch · 13 files changed
+1357/−771 lines, 13 filesdep +binarydep −cerealdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: binary
Dependencies removed: cereal
Dependency ranges changed: base
API changes (from Hackage documentation)
- Codec.Picture: canPromoteTo :: Pixel a => a -> PixelType -> Bool
- Codec.Picture: promotionType :: Pixel a => a -> PixelType
- Codec.Picture.Bitmap: instance Serialize BmpHeader
- Codec.Picture.Bitmap: instance Serialize BmpInfoHeader
- Codec.Picture.Gif: instance Serialize GifFile
- Codec.Picture.Gif: instance Serialize GifHeader
- Codec.Picture.Gif: instance Serialize GifImage
- Codec.Picture.Gif: instance Serialize GifVersion
- Codec.Picture.Gif: instance Serialize GraphicControlExtension
- Codec.Picture.Gif: instance Serialize ImageDescriptor
- Codec.Picture.Gif: instance Serialize LogicalScreenDescriptor
- Codec.Picture.Jpg: instance (SizeCalculable a, Serialize a) => Serialize (TableList a)
- Codec.Picture.Jpg: instance Serialize JpgComponent
- Codec.Picture.Jpg: instance Serialize JpgFrameHeader
- Codec.Picture.Jpg: instance Serialize JpgFrameKind
- Codec.Picture.Jpg: instance Serialize JpgHuffmanTableSpec
- Codec.Picture.Jpg: instance Serialize JpgImage
- Codec.Picture.Jpg: instance Serialize JpgQuantTableSpec
- Codec.Picture.Jpg: instance Serialize JpgScanHeader
- Codec.Picture.Jpg: instance Serialize JpgScanSpecification
- Codec.Picture.Jpg: instance Serialize RestartInterval
- Codec.Picture.Types: PixelGreyscale :: PixelType
- Codec.Picture.Types: PixelGreyscaleAlpha :: PixelType
- Codec.Picture.Types: PixelMonochromatic :: PixelType
- Codec.Picture.Types: PixelRedGreenBlue8 :: PixelType
- Codec.Picture.Types: PixelRedGreenBlueAlpha8 :: PixelType
- Codec.Picture.Types: PixelYChromaRChromaB8 :: PixelType
- Codec.Picture.Types: canConvertTo :: (Pixel a, Pixel b) => a -> b -> Bool
- Codec.Picture.Types: canPromoteTo :: Pixel a => a -> PixelType -> Bool
- Codec.Picture.Types: data PixelType
- Codec.Picture.Types: instance Eq PixelType
- Codec.Picture.Types: instance Serialize PixelRGB8
- Codec.Picture.Types: instance Serialize PixelRGBA8
- Codec.Picture.Types: instance Serialize PixelYA8
- Codec.Picture.Types: instance Serialize PixelYCbCr8
- Codec.Picture.Types: instance Storable PixelRGB8
- Codec.Picture.Types: instance Storable PixelRGBA8
- Codec.Picture.Types: instance Storable PixelYA8
- Codec.Picture.Types: instance Storable PixelYCbCr8
- Codec.Picture.Types: promotionType :: Pixel a => a -> PixelType
+ Codec.Picture: ImageRGBF :: (Image PixelRGBF) -> DynamicImage
+ Codec.Picture: ImageYF :: (Image PixelF) -> DynamicImage
+ Codec.Picture: colorMap :: Pixel a => (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
+ Codec.Picture: decodeHDR :: ByteString -> Either String DynamicImage
+ Codec.Picture: encodeHDR :: Image PixelRGBF -> ByteString
+ Codec.Picture: readHDR :: FilePath -> IO (Either String DynamicImage)
+ Codec.Picture: saveRadianceImage :: String -> DynamicImage -> IO ()
+ Codec.Picture: writeHDR :: FilePath -> Image PixelRGBF -> IO ()
+ Codec.Picture.Bitmap: instance Binary BmpHeader
+ Codec.Picture.Bitmap: instance Binary BmpInfoHeader
+ Codec.Picture.Gif: instance Binary GifFile
+ Codec.Picture.Gif: instance Binary GifHeader
+ Codec.Picture.Gif: instance Binary GifImage
+ Codec.Picture.Gif: instance Binary GifVersion
+ Codec.Picture.Gif: instance Binary GraphicControlExtension
+ Codec.Picture.Gif: instance Binary ImageDescriptor
+ Codec.Picture.Gif: instance Binary LogicalScreenDescriptor
+ Codec.Picture.HDR: decodeHDR :: ByteString -> Either String DynamicImage
+ Codec.Picture.HDR: encodeHDR :: Image PixelRGBF -> ByteString
+ Codec.Picture.HDR: instance Binary RGBE
+ Codec.Picture.HDR: instance Binary RadianceFormat
+ Codec.Picture.HDR: instance Binary RadianceHeader
+ Codec.Picture.HDR: writeHDR :: FilePath -> Image PixelRGBF -> IO ()
+ Codec.Picture.Jpg: instance (SizeCalculable a, Binary a) => Binary (TableList a)
+ Codec.Picture.Jpg: instance Binary JpgComponent
+ Codec.Picture.Jpg: instance Binary JpgFrameHeader
+ Codec.Picture.Jpg: instance Binary JpgFrameKind
+ Codec.Picture.Jpg: instance Binary JpgHuffmanTableSpec
+ Codec.Picture.Jpg: instance Binary JpgImage
+ Codec.Picture.Jpg: instance Binary JpgQuantTableSpec
+ Codec.Picture.Jpg: instance Binary JpgScanHeader
+ Codec.Picture.Jpg: instance Binary JpgScanSpecification
+ Codec.Picture.Jpg: instance Binary RestartInterval
+ Codec.Picture.Saving: imageToRadiance :: DynamicImage -> ByteString
+ Codec.Picture.Types: ImageRGBF :: (Image PixelRGBF) -> DynamicImage
+ Codec.Picture.Types: ImageYF :: (Image PixelF) -> DynamicImage
+ Codec.Picture.Types: PixelRGBF :: {-# UNPACK #-} !PixelF -> {-# UNPACK #-} !PixelF -> {-# UNPACK #-} !PixelF -> PixelRGBF
+ Codec.Picture.Types: colorMap :: Pixel a => (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
+ Codec.Picture.Types: data PixelRGBF
+ Codec.Picture.Types: freezeImage :: Storable (PixelBaseComponent a) => MutableImage s a -> ST s (Image a)
+ Codec.Picture.Types: gammaCorrection :: PixelF -> Image PixelRGBF -> Image PixelRGBF
+ Codec.Picture.Types: instance ColorConvertible Pixel8 PixelF
+ Codec.Picture.Types: instance ColorConvertible PixelF PixelRGBF
+ Codec.Picture.Types: instance ColorConvertible PixelRGB8 PixelRGBF
+ Codec.Picture.Types: instance ColorPlane PixelRGBF PlaneBlue
+ Codec.Picture.Types: instance ColorPlane PixelRGBF PlaneGreen
+ Codec.Picture.Types: instance ColorPlane PixelRGBF PlaneRed
+ Codec.Picture.Types: instance LumaPlaneExtractable PixelF
+ Codec.Picture.Types: instance LumaPlaneExtractable PixelRGBF
+ Codec.Picture.Types: instance Pixel PixelF
+ Codec.Picture.Types: instance Pixel PixelRGBF
+ Codec.Picture.Types: pixelFold :: Pixel pixel => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc
+ Codec.Picture.Types: toneMapping :: PixelF -> Image PixelRGBF -> Image PixelRGBF
+ Codec.Picture.Types: type PixelF = Float
+ Codec.Picture.Types: unsafeFreezeImage :: Storable (PixelBaseComponent a) => MutableImage s a -> ST s (Image a)
- Codec.Picture: Image :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> Vector Word8 -> Image a
+ Codec.Picture: Image :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> Vector (PixelBaseComponent a) -> Image a
- Codec.Picture: class Serialize a => Pixel a where pixelBaseIndex (Image {imageWidth = w}) x y = (x + y * w) * componentCount (undefined :: a) mutablePixelBaseIndex (MutableImage {mutableImageWidth = w}) x y = (x + y * w) * componentCount (undefined :: a)
+ Codec.Picture: class (Storable (PixelBaseComponent a), Num (PixelBaseComponent a)) => Pixel a where type family PixelBaseComponent a :: * pixelBaseIndex (Image {imageWidth = w}) x y = (x + y * w) * componentCount (undefined :: a) mutablePixelBaseIndex (MutableImage {mutableImageWidth = w}) x y = (x + y * w) * componentCount (undefined :: a)
- Codec.Picture: imageData :: Image a -> Vector Word8
+ Codec.Picture: imageData :: Image a -> Vector (PixelBaseComponent a)
- Codec.Picture.Types: Image :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> Vector Word8 -> Image a
+ Codec.Picture.Types: Image :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> Vector (PixelBaseComponent a) -> Image a
- Codec.Picture.Types: MutableImage :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> STVector s Word8 -> MutableImage s a
+ Codec.Picture.Types: MutableImage :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> STVector s (PixelBaseComponent a) -> MutableImage s a
- Codec.Picture.Types: class Pixel a => LumaPlaneExtractable a where extractLumaPlane = pixelMap computeLuma
+ Codec.Picture.Types: class (Pixel a, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where extractLumaPlane = pixelMap computeLuma
- Codec.Picture.Types: class Serialize a => Pixel a where pixelBaseIndex (Image {imageWidth = w}) x y = (x + y * w) * componentCount (undefined :: a) mutablePixelBaseIndex (MutableImage {mutableImageWidth = w}) x y = (x + y * w) * componentCount (undefined :: a)
+ Codec.Picture.Types: class (Storable (PixelBaseComponent a), Num (PixelBaseComponent a)) => Pixel a where type family PixelBaseComponent a :: * pixelBaseIndex (Image {imageWidth = w}) x y = (x + y * w) * componentCount (undefined :: a) mutablePixelBaseIndex (MutableImage {mutableImageWidth = w}) x y = (x + y * w) * componentCount (undefined :: a)
- Codec.Picture.Types: computeLuma :: LumaPlaneExtractable a => a -> Pixel8
+ Codec.Picture.Types: computeLuma :: LumaPlaneExtractable a => a -> (PixelBaseComponent a)
- Codec.Picture.Types: extractComponent :: (Pixel px, ColorPlane px plane) => plane -> Image px -> Image Pixel8
+ Codec.Picture.Types: extractComponent :: (Pixel px, Pixel (PixelBaseComponent px), PixelBaseComponent (PixelBaseComponent px) ~ PixelBaseComponent px, ColorPlane px plane) => plane -> Image px -> Image (PixelBaseComponent px)
- Codec.Picture.Types: extractLumaPlane :: LumaPlaneExtractable a => Image a -> Image Pixel8
+ Codec.Picture.Types: extractLumaPlane :: LumaPlaneExtractable a => Image a -> Image (PixelBaseComponent a)
- Codec.Picture.Types: imageData :: Image a -> Vector Word8
+ Codec.Picture.Types: imageData :: Image a -> Vector (PixelBaseComponent a)
- Codec.Picture.Types: mutableImageData :: MutableImage s a -> STVector s Word8
+ Codec.Picture.Types: mutableImageData :: MutableImage s a -> STVector s (PixelBaseComponent a)
- Codec.Picture.Types: unsafeExtractComponent :: Pixel a => Int -> Image a -> Image Pixel8
+ Codec.Picture.Types: unsafeExtractComponent :: (Pixel a, Pixel (PixelBaseComponent a), PixelBaseComponent (PixelBaseComponent a) ~ PixelBaseComponent a) => Int -> Image a -> Image (PixelBaseComponent a)
Files
- Codec/Picture.hs +34/−9
- Codec/Picture/Bitmap.hs +24/−14
- Codec/Picture/ConvGraph.hs +9/−0
- Codec/Picture/Gif.hs +380/−389
- Codec/Picture/HDR.hs +449/−0
- Codec/Picture/InternalHelper.hs +29/−0
- Codec/Picture/Jpg.hs +57/−41
- Codec/Picture/Png.hs +8/−10
- Codec/Picture/Png/Export.hs +8/−6
- Codec/Picture/Png/Type.hs +25/−15
- Codec/Picture/Saving.hs +88/−46
- Codec/Picture/Types.hs +234/−205
- JuicyPixels.cabal +12/−36
Codec/Picture.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} --- | Main module exporting import/export functions into various --- image formats. +{-# LANGUAGE CPP #-} +-- | Main module for image import/export into various image formats. -- -- To use the library without thinking about it, look after 'decodeImage' and -- 'readImage'. @@ -20,8 +20,9 @@ -- * Generic image writing , saveBmpImage - , saveJpgImage - , savePngImage + , saveJpgImage + , savePngImage + , saveRadianceImage -- * Specific image format functions -- ** Bitmap handling @@ -53,12 +54,19 @@ , encodeDynamicPng , writeDynamicPng + -- ** HDR (Radiance/RGBE) handling + , readHDR + , decodeHDR + , encodeHDR + , writeHDR + -- * Image types and pixel types -- ** Image , Image( .. ) , DynamicImage( .. ) -- ** Pixels , Pixel( .. ) + -- $graph , Pixel8 , PixelYA8( .. ) , PixelRGB8( .. ) @@ -76,13 +84,20 @@ import Codec.Picture.Png( PngSavable( .. ), decodePng, writePng , encodeDynamicPng , writeDynamicPng ) import Codec.Picture.Gif( decodeGif, decodeGifImages ) +import Codec.Picture.HDR( decodeHDR + , encodeHDR + , writeHDR + ) import Codec.Picture.Saving import Codec.Picture.Types import System.IO ( withFile, IOMode(ReadMode) ) import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +#include "ConvGraph.hs" + -- | Return the first Right thing, accumulating error eitherLoad :: c -> [(String, c -> Either String b)] -> Either String b eitherLoad v = inner "" @@ -105,7 +120,7 @@ -- | Load an image file without even thinking about it, it does everything -- as 'decodeImage' readImage :: FilePath -> IO (Either String DynamicImage) -readImage = withImageDecoder decodeImage +readImage = withImageDecoder decodeImage -- | If you want to decode an image in a bytestring without even thinking -- in term of format or whatever, this is the function to use. It will try @@ -114,8 +129,9 @@ decodeImage :: B.ByteString -> Either String DynamicImage decodeImage str = eitherLoad str [("Jpeg", decodeJpeg) ,("PNG", decodePng) - ,("GIF", decodeGif) ,("Bitmap", decodeBitmap) + ,("GIF", decodeGif) + ,("HDR", decodeHDR) ] -- | Helper function trying to load a png file from a file on disk. @@ -141,10 +157,19 @@ readBitmap :: FilePath -> IO (Either String DynamicImage) readBitmap = withImageDecoder decodeBitmap +-- | Try to load a .pic file. The colorspace can only be +-- RGB with floating point precision. +readHDR :: FilePath -> IO (Either String DynamicImage) +readHDR = withImageDecoder decodeHDR + -- | Save an image to a '.jpg' file, will do everything it can to save an image. saveJpgImage :: Int -> String -> DynamicImage -> IO () -saveJpgImage quality path img = B.writeFile path $ imageToJpg quality img +saveJpgImage quality path img = L.writeFile path $ imageToJpg quality img +-- | Save an image to a '.hdr' file, will do everything it can to save an image. +saveRadianceImage :: String -> DynamicImage -> IO () +saveRadianceImage path = L.writeFile path . imageToRadiance + -- | Save an image to a '.png' file, will do everything it can to save an image. -- For example, a simple transcoder to png -- @@ -156,9 +181,9 @@ -- > Right img -> savePngImage img -- savePngImage :: String -> DynamicImage -> IO () -savePngImage path img = B.writeFile path $ imageToPng img +savePngImage path img = L.writeFile path $ imageToPng img -- | Save an image to a '.bmp' file, will do everything it can to save an image. saveBmpImage :: String -> DynamicImage -> IO () -saveBmpImage path img = B.writeFile path $ imageToBitmap img +saveBmpImage path img = L.writeFile path $ imageToBitmap img
Codec/Picture/Bitmap.hs view
@@ -18,14 +18,24 @@ import Control.Monad.Primitive ( PrimMonad, PrimState ) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as M -import Data.Serialize( Serialize( .. ) - , putWord16le, putWord32le - , getWord16le, getWord32le - , Get, Put, runGet, runPut - , remaining, getBytes, putByteString ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Put( Put + , runPut + , putWord16le + , putWord32le + , putByteString + ) + +import Data.Binary.Get( Get + , getWord16le + , getWord32le + ) + import Data.Word( Word32, Word16, Word8 ) import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Codec.Picture.InternalHelper import Codec.Picture.BitWriter import Codec.Picture.Types @@ -40,7 +50,7 @@ bitmapMagicIdentifier :: Word16 bitmapMagicIdentifier = 0x4D42 -instance Serialize BmpHeader where +instance Binary BmpHeader where put hdr = do putWord16le $ magicIdentifier hdr putWord32le $ fileSize hdr @@ -83,7 +93,7 @@ sizeofBmpHeader = 2 + 4 + 2 + 2 + 4 sizeofBmpInfo = 3 * 4 + 2 * 2 + 6 * 4 -instance Serialize BmpInfoHeader where +instance Binary BmpInfoHeader where put hdr = do putWord32le $ size hdr putWord32le $ width hdr @@ -232,14 +242,14 @@ -- * PixelRGB8 -- decodeBitmap :: B.ByteString -> Either String DynamicImage -decodeBitmap str = flip runGet str $ do +decodeBitmap str = flip runGetStrict str $ do _hdr <- get :: Get BmpHeader bmpHeader <- get :: Get BmpInfoHeader case (bitPerPixel bmpHeader, planes bmpHeader, bitmapCompression bmpHeader) of -- (32, 1, 0) -> {- ImageRGBA8 <$>-} fail "Meuh" (24, 1, 0) -> do - rest <- remaining >>= getBytes + rest <- getRemainingBytes return . ImageRGB8 $ decodeImageRGB8 bmpHeader rest _ -> fail "Can't handle BMP file" @@ -247,7 +257,7 @@ -- | Write an image in a file use the bitmap format. writeBitmap :: (BmpEncodable pixel) => FilePath -> Image pixel -> IO () -writeBitmap filename img = B.writeFile filename $ encodeBitmap img +writeBitmap filename img = L.writeFile filename $ encodeBitmap img linePadding :: Int -> Int -> Int linePadding bpp imgWidth = (4 - (bytesPerLine `mod` 4)) `mod` 4 @@ -255,7 +265,7 @@ -- | Encode an image into a bytestring in .bmp format ready to be written -- on disk. -encodeBitmap :: forall pixel. (BmpEncodable pixel) => Image pixel -> B.ByteString +encodeBitmap :: forall pixel. (BmpEncodable pixel) => Image pixel -> L.ByteString encodeBitmap = encodeBitmapWithPalette (defaultPalette (undefined :: pixel)) @@ -264,7 +274,7 @@ writeDynamicBitmap :: FilePath -> DynamicImage -> IO (Either String Bool) writeDynamicBitmap path img = case encodeDynamicBitmap img of Left err -> return $ Left err - Right b -> B.writeFile path b >> return (Right True) + Right b -> L.writeFile path b >> return (Right True) -- | Encode a dynamic image in bmp if possible, supported pixel type are : -- @@ -274,7 +284,7 @@ -- -- - Y8 -- -encodeDynamicBitmap :: DynamicImage -> Either String B.ByteString +encodeDynamicBitmap :: DynamicImage -> Either String L.ByteString encodeDynamicBitmap (ImageRGB8 img) = Right $ encodeBitmap img encodeDynamicBitmap (ImageRGBA8 img) = Right $ encodeBitmap img encodeDynamicBitmap (ImageY8 img) = Right $ encodeBitmap img @@ -283,7 +293,7 @@ -- | Convert an image to a bytestring ready to be serialized. encodeBitmapWithPalette :: forall pixel. (BmpEncodable pixel) - => BmpPalette -> Image pixel -> B.ByteString + => BmpPalette -> Image pixel -> L.ByteString encodeBitmapWithPalette pal@(BmpPalette palette) img = runPut $ put hdr >> put info >> putPalette pal >> bmpEncode img where imgWidth = fromIntegral $ imageWidth img
+ Codec/Picture/ConvGraph.hs view
@@ -0,0 +1,9 @@+-- $graph+--+-- The following graph describe the differents way to convert between pixel types,+--+-- * Nodes describe pixel type+--+-- * Arrows describe functions+--+-- <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAr8AAAJrAQMAAADTeGmUAAAABlBMVEUAAAD///+l2Z/dAAAcaUlEQVR4Xu3dX4zcxnkAcB6uybXIn23Rh8aRHT70qQ9JGgSNXDjNAA3QlzRtgQJNasGxAyNNDEWSnUY6F7Y856j1vUQ4oCnSII5D9CFKi0qy5caSc2drTxGgQ90mDOJWUnQ+cdVFwrqnO+6asJY0Z/l1eUfucOeb4ZBLCshDDMNa88jfDb/5ZrgzHIoG3J5/4l8k+JdwYBgztwNmIzWYvQ3wagL0SOMwM3eAY43DN9JA06bhFv+zUZhlJe02DPczIGgYXhsfQJqFzTGw1CjMeDK4jcIh+tgQ7HOANQPj849pk7CdA0iTsIU+14ZxKe0m4XxcvQbhOA8MmoUvOPDcxz5qPk4bhRnAdYBzGxvbK23wG4SHI/jKg+fWtxI4ahi+tnFufXgb4AvXNp6756vveo02DTsbF849tnVzT7tx+JpzbmVra715eBTjlzc2N5uHR1lx/aN7bjYbY4b65l/4Jk1zgBuT2wN7RnPwap5abQ4OWlYOWDBoU/DMxFXj7sbgHpm4Sj9htJqB4zmACxwIwHiANgJ3KBhGvn2s0tlaMC9wbLydl3ENetAzG4A7yU65tLAgAFioD8dJTRkm/35sQgzAWrXhDiQw6WVAbyYNvB7WFxgMykgW4gUzjbwW1heYGQCLWSRWZ9LkrgfvFKx/YQSlkYDVNNdma8E9mhjuxeTc0wh0UjEgdeAdDZbcJCgJtEqhl0X3yRpwQHJfYo1W8i8EGRyY08MX81e82EhcYLOAiiyF9SP+MIXTjXcAKnJV+AYf2eQKfiegIleFWxNjg2EKfIzyM5oODlLBEkaOFipyRfji5CU6wqObgEwDx+ZEbMGXjCaPTQP3hMHzQDL+DcgU8KLguLJh+rHqMCMC6MmG6T1aGb4h1pUtHabPVYZbmdNOCUc6AO5UhfkEG0WwlQdaFeEuOnFLPky/UBFuoapqy6eFGFHAukiEOLI+SsvycBcrVDHf1KsE8ypxcZINJ4lWBZhxxcvgHDVpXNDDuHXwLGPKiSxGysNLXLEk5y9Ii6XhmOQRXGNt1A+WhHuSeaZIPUMWm2XhNUk8/YIZsotaGJeAyUa6HjpDHYxntYeyduyikpSDu7IJXq9onH5RDeNk43UWsb3g/Ch3HfLROZaCYyLCQwec67lCh4gxy8D9/IY3vnlp8TeO//dV5+9PPrR9ZvG9j5z87CVvCCgWZeC1PHzroeV7Nw9fPnf/yadPbB9cfv3006eXPYYzvwxsTsCby9c2f2Xvw/d/YOX0dm/lnude/ED7/lgSPj3MKIKPDuadgyN4e2X99Mr2CKZIXkRwcYjh5/tH8OFb5z7zxZUT2zeXXz+5cnqlDRju6+G1SfjpS+t3HH/z6vU3Xnpo+42V937ppYNrbWgjmBEtbE7CvGl7WVfUBkuS/DqYUSk8zMEUHAx3RVgTLFfaJmwMBzp4TQ5HE4ona68a2JTDPtqKg4xhdYhhwP/UzG92i+E+YBiXMZLAQTHsIlgW1RA0QcbwEoJleTAEWZARjOsWR9PBE8o4yBhWXwoi6RU/lsFBEewrYLF3oJogIxg1qVAuEc1dPwSbIjyU39Bsy+A1NcyoCsaFw3Afw+r8ZPI0cGQwU8Nd1Q2FuwDXhbr2MLykmvf/NcHwoKj2MExUt0tnUctX1x6Gcd3xuTF5g0RbBRjVHUosg+J2g+FQBXdVcYsNIiVwhXBYV9f2Lkyl6Y3jxmG0XVb/8QxKWXVaYJhR1UKFWMyKWA7bcjhU1nQ8h6Op2JnDeDOufzzZL4dDOWwr98WTjUQKMzlsKffF0beU+YbhmEj3hY5h3IkIR5FvHNam0OOzAAuoxLYy3zDcl8MzsqwAT5lvGHYLpr17oOneuIFhWz0nggdyAzk8kMFm0ZzIxVL9JkQSOKZFl5sAC/KsxzBDaB6MNf0mRxDcL56As0r1mzGHNfVsK37MFDDFsF28gs4v1W+CBLaKG39Qqt+ENoLlezKlVBpmuusuKdNvgoPgUPdNoY2KVg72dUvznDIdMtgIlieFhw7RdMieAKMSYM3DP9HDuDJwuQZIUMWOw+q8tKDjwVXzfS1ThN2SMFOlpUdhfXv7lgd+lQ6Zw6ES3n9mfevWCI5QIuph9ZkR8A4cXN+KMRyVhG0V3Nk6ePWuS3OmKIUlYUtZ4u3O+suSUAxLwkQJbx1a35DATA+rs627Ax9cv76N4VgPq7OtY7bB2zyz7o3yGMG0FBzKYaPNpZ4wJCsH+wrYzB3SmRHCXwZ2FfD9+cbaM1CHrIFVY2NjZrJ3C/JltnSweq+Fh+eE/jgvOxpYHbBVs2cOhBJyWQsrc6fXgh71xcriz5rYZWCG3Xgk9CEU85YvjvHKwKEkwDTZi+Em3GnxRNLCPg6EKQQ/5HVKOKGDXRwIXmWoCfHCaGEbZQRNkTVUV9mKnkgP4zQOWhnym5lminHSw7x54lUvwaN8ZkA4obAMnB6FV5B0s+FSH1XBUAvjTpt3kEtZkBdR0rASMEMrQPmQpie/qf0kxFoYhetYfswUt6S34VmrDOwrIgzddF0im0PCakz1sKsoMLR2diGPzkgmPVslYBuNyvM59p+GQTuY6BA97KBReT7HnJgm8cBFLoZRw2uJk6BWTKSrYRf0MEGrV/LNuM1G8Bw2vmXq4In6vYgm+EgCz2LDuaCDGb51nW/GlJkQGBKYEQ08RDeY8yGOIRjBM9iwYVEDhwjLh5jtwJJQeNDTwH4eQyEeJr0za8ng2CyG3XxOoBCH0BvBc9IB0sVi2ONYF0fF34H3gswIimGbY0s4KoMkiePHpHBsFsIWnt7kIQYXOnPSC5Ev1DWGuRYACjHYOzCTz7H1C2HKCyFJPGcHjuUwowVwTAuyGMDa3YHKZ1/MAphhLN+BkF2YIHgoFAXBwzyGw013YUsO9wvgUDoo7PKSx4ngyGFG1bCfixrOaJZWnK2YOiNqeJBrpDijhynsKuYxl9Qw52zAUYlSYaCAXTXMOQs3D/BTIVLAvgoWFr2ijHZTIVTMe4ZqmJeTSjLaTuGhYuaVqWGSKwL+6KRwrICBKmEqSeOAxz2DqQJuK+DdIxwvO9ube8FJq+TWHvCAJDBO2GwLfcqOVDBkcJgAW04C2zuwB15MM7gtnSumK54KZt3j79r7zkPLi2a09p6Dl/5utLYNwOx+de+Df/h/Nw8xyGALwV/79I//50PL/7ZHAYcbX/7elX3PLt/r+cubp5cPjNa2QUw3Dl+57yOb+54Nx7F3EHx87yfuO7j8k00FHDmHX7jy6Q8ur7cG5zdf+MrN0do2CME5fO3CkT0vfjAawx6Cn5nfd98DT/3vOxSwn8D7vOVrnjuCz28N5h3oJrBzJFrxBmPYlcKHzt9UxdjdOPy9y/ueff6a7S1vrixv3RqFwoaNwxsbR6J9z3pjeIDgH47gg+cv71fAXvf4C7//xw+8sv5Be23PyqWfvXnVARO6xze6X3rr5iF73Oh8BL/66PqDHzq/oqo8OzsSHEkTtMZwqJq1bitgB8MBB8gYHqpgSwHz7Y7kvjUdkwzBNvdlMD8TC38LYLyssQr2FDDhTRR3+FEOpgrYVcCUw/gbnMth3At53NLCYjTtHNxWwL4cjvMw2tPKJZqlgCMFnE8tMWgxycGOAg71MPr2zfJFshXwUA4zDlN0se7nYU+E3UJ4iGDGo76Yh10FzPSwGDNG8vBAAcd6WBw5dSAPR9XgEMG2OK0X5c8EIzGVwpEI83ydmczroQKGcjAvQI9MwqwmzHhKTMJxTbjPWx2KpRwmejifrgEC6sGOzQNQEm6XgpeyCKxhoBb8bvysmNsIzG9UI9iqAfNZ/xg/M+VUh3kZ2UwGA4LtSnCogIcY9hSwVQLmM3chht06cM+g6Ipqc6gCzE951TD4k+FcqQ13WiO71THVa0H8KeBsGn51lQcWwZEAu4UwywIBk+sobQyHleB4cmL8BtcQPJwG7vELM9rbmg6maV8mXDfaGGYC7JWBTXEGhEqWQVWCdwU2dhhtCia8nLmyxzKYVoLbQnOwUelIJlWEhZ+5vKJEj1SCLeGQEKUWVSxQsIthR4ge43x9mKFZr0jYILvoOcWwLfYCRIS5VAn2eIeYi6RfH3aT/0X7DxCMr6ZWMTwQL5O2ADOeX5Vgf8did8Fb0RJdCgC8cTZHw3Hm0acgEq+mbQXs9Rx4woBoJ1pDD6L5eTo/oLumJ8IrFeABTeBwF946cs+R6E+iT9HdKHjskX86ceP44M+6MHx1Z35tZQ8M9PAb+9975x/t/dSDIzgpkDWCT62fho/A3hS2o9Nf/+bm4cEn7oPwhzvza5c3xaspkcD9E6/vP3Xl3o0RzHZgdtep9etwBB5N4+9E22eXN9822PdZiDZ25te23yFeTakE9k9v7j/56xsXRnC8W+Lha3sSeJ7m4aODffftwofOb0dl4VODDSeB6S58KroeHYk4fPrsN//j8K19fwl+Or+2CaEe7ifwlWtJKICOmARed+b3zmewxR45+93f+eod+z4H/nh+bYim0nHlHdrzxb/aeyWpPCC78JF7nKU/Xcpi3Oa1PnBSQIRBFgreQKAtdAKeEmbVYCu1EIwnXDQwvl2B+wrCAU8BMx3sCb2bpYZpHh7qYFfWH+cIe1p4IFxBqAA7igWKoQ720TWvHBzp4GgyeENOoONIJXg4eYQv/4aFr/++DmaTVzNXhIkCHujgePKe/5KQsYqoALhamObTIiZKGDV9DQwkPzsYgADH08Pt/CKeLoJVi+dtLWzlg9wSNaaCHS1s55aCBFSEhyis3CuCs93nJpYJsRJwWwu7/G9fCkwEh6rl/kQL+3wmcwYQHKlgqoGzQwODBgbBsI8OKw2HkMqJi+CBAo5BCzPcKwzlcfWrwXEh7IE83qwETHkCYdhWwEM9DKQIdhRwWAK2imALYbz0OtgpgtsK2NfAwhATwwTFlRM62OXhxAJVwF4J2C+AYxVsl4DDIlj1dIlTAmaoEENkod9ilYDjAniogttamFeQJ+EiFUzKwEQN+6rnYagW5j9yJfBAAcdQBrblMN+Gi8n0MBcHEthTwMNSsK+GHQUc6mG+ly+BLQXs62EesEiA8ZQYEQQdHFMBZgKFYVcP8wNCDgsJhstvl4MtVQ8RgwJ2ysGeCh6qYKsc7KccKmiogkk5OOQch3l9SgxaDma8pmKgOXiA4fZFOoS4HJzth2EXT2e2N2AIDLRwPmTkzi889OKDR//r7lgxnfnvJ7/wyHs27jsOQz2cXwVyfvM7J5Y3jv7kyhOKCdhLT3/n9Ln79h+GSA/nT/nb0anTyxeOXr76hGIu+kcrp04/9/H5t4FfEk53vJ7AztHLvMQEw+ec+aPgloXD3eM2T514fuPo1y8/QaUtGi4l8P2jUHhlYbYjeHce+JdXHnz7X/x0DINQeS8dOPMNZ1R5TlkYSBrptCiU57dqNKqH+Z4DEQ5Vz6iT0rDLG3AO9hVwTMvAnAhFeKCCoTQcJAATYVcBD0vCvAMSYmgr4LA8DGam52FLAft6WDGl2ea+DHYrwF2+D4ep4sauXQEOxwdwOFbBVgWYJYg7CTNQwKQCDCae/QsVMIMqsI1nWH3FKqmwEtzNJ77DCyiBu5XgIGshHPYUsF0JjkmuVq5yXgKblWCwcjsZ/BAMM1oNXuMnGezCRA73oRrcz+WTwdsHhtcqwowC+HgojGGzIgwmfyXBDE9XBDNaFV7jZ78D+3L4BpSHeZBJDnblb49bqgDzIFu5R7E9KcxIZRjMcY1fyNoHhvtQGU5UPwdbUnhxCrgHEOQWIhEZzMgUcEyytOin7QPDF6AqnFa4mQqKpwhjcyq4m/UWHWMWQhncganggEI3ff6+R3wZPDcdDCYEaS3CMVcC9+iU8EWIqbWbUoGNjbfmYEo4ADCXICaKv7S9Q6eEE21tMeFRn5CGvjyMYtGfha7i3aWr0fRwQFn2cq0Q/axVA45NZqS7xhQFogYMF5mRDcaIEAhaCw4eNz4qHe/2WlALhl817pAN/dks1ICzbgIPbWID6sJBAqPBmEFrwz3j83hCyCDQANxCgy7DhCbhoeDWhYmwZjUeuxDWgNHS0p5BoDE4uAcG5m6bXjAANHC6Hk4PE4gcuOUlcGDMQSl4pSR87eYRD+AJw6Cghb+WrofTwxSi9X1nvTQbtPDxdD1cGTi4Z985M/lQBn4mXQ9XqsTRix/xSsPperhy8L5bMngoDUW6Hq4kfLY0/DX+vKk+K966OW/K4FoNJCbZh4bhhTEMlWG3AF41rdsC91r8/UHVYU8Js1n0cEIzsIGm7SrBtgruEPSStEqwI4XTNxCyD/PcaQDmI90bIQ9YVdjiMAoELGWH29XhNoL5gzGMZC1usTpMpPBqNnYk6Q9JZZjKYNZKy5nuyjozVeEYZPCTu5vGUwBhz6gKMwTzBV7BeObAxTDTwEMOiwWG7njWZymYqQpHGE4KzAdhZoIQVhn2JfCFfC9/MWknEFeGXQwzM78KMiAAcwCVY2xjuDP5CgSjvUABniIVYQfDrckH0gMj2bBkVYTbCO5R2XMC9ppgxBqYIvgYn3pDc+nl4RgEmE8hhJOhCarBQwT3hHzJ4JhWgn0ELwr5ksFAKsGuCPOHrs2JrhnArgTbAswjEVMBdivBlgiv4W5vlketNBwTEebjOBEOqsAMBJhRFH2WwjGtAIcifANHf9xjkgpwV4A5BxaCrUmYFsG2CBO8MiUw0M562BRgRnEnMr4queXhmApwH4UQPXJcCg5BgHmhGIbD8nBXhG0ArNjyPCiCbRHmdRdhGGhp2BTgWLqIzUNXGx3MqAAL67lF2CkL90GAQ665EtgrC68JMDp/IX/dsrApwm4x7JeEGRVhm2u2JNxhSbgPIuwUv+2AlYTXEGxJYV/e2IgSNhFM0jVsCZy9vTRtK15SbhpB3NLCAUUwTdewZfDQmYRJlGslbRXcBRGOH8rWsAFcz95eChD2Lz319FN7Nz6+ZL1y5rvLl+586NKZxT1tJbyE4Z+na9gSOHt7KcBwe/ne0WOSG++ft58/+PT3lzdPLB9c3lTCjGB4O1vDBvCj9O2lCeyNPp78rY0Di97y9srKD25u/6CzPKSWAu4Dgtl2toYNYDt7eykAS+BTg40D824CL3sHl70CeFEC/zxdw5bA6dtL7weIt5ev7X//lZ8e+Lz//PbTK89vnnh+e3kbHDkcEwwPX8/WsPG3lzoj+JFL17514nc/d+Afo1f631155eZDr/RX3qeCeyCBPb7h1kQbi8dtup32I7EKXtTAb+RgksFDDg9BHuOYyGDFgyRt2fBAAfdAA4cCgTsLeR4vymHdA2hU1wkxIoOZYiTgSTEqg2+ABE4xfNau7PRjKdzSwkCkz9RohgrfoHKYaqYewNEMeY+BFAaKakz9VEEoMZipgIn84TAmgyOJccOSwujBJVxPA44MJERLBTuKRCYSzcVEj6pgW/EeTkv2HRQTcyCHhVIs5REMYyMgCliImyv5GBZ1FcdACUeKt6j6sue9cIHV8FBY3IQKygpa9JOggsW9TUBerG54gamExa5wDRePlzPEBVbC4g96RX95jo8KXAjbIM9kG/0GFxW4EO4qXqXuoiSzUYHVMIocvxz4CCbodR+FMFO8Sj3Ao3DhlrsGBiLEQnBUN7VmQQcvTRYE5bQtzbYO1cKuuAZJAD3J8B5YC7RwX1yDJECeLCkWQA8zOrF6JSDCqS8Ys0jomTqYBzOegx7JVx+jmdExxbcxz0IZeG0XyC7lPTpRe3PpdobeCaSF++M8CzKK/0JG0mFcH70TSAszmp1pTPJF9nlTNCeSZwb0cHYYX+TG52IDnuUXOcADoYcvxpQvcuOtNTbHVRZCTFAg9HAQm5OL3GbHQWZZhgTjg2agNBzf2eKL3HJp2ud9nOnz12WVh+Fv51IRSL5hMcofqLBTp2NCBbg3y4TJrrm0VjPPJfwOcwU4MEKhQ+ikt8naKdDjAa4GPyZekIyd7ZROdhwGrQrvRZNBswDxE++bHFGtmlAN7hlZ6KJ8B8bM1YnrSacFlWG8yA0WCJvj/0uTKoaqsHxRhfH4DD8BwifuK8GW5IrJDOOvx0CbGVAVxovcUJ0CfNugU8LBPXCrNTnuY8ZcsvnNweNU6NK0sLDIDTCcbN5eaYMN1WG+yE0Yhwcz3s7maWG+yE2EiZdsPveZEexVh/kit7NoAZaXbD738mu0KiwscgMEJ5v3vrSnXQved0sK7xu8vF4TPiuHz61s1sqKt3hWcDjZPL9yk6rhdsmWRxUv9nXqwujxnZqwpYOtqnDxeMBHxyOEVOuP0QWFqGBaBONFbuj30ClhF527fKiODRUsgAPFYUwJQzGsWuTGByRTwqpFbhYOkVALGjimeQjPObnTwkDQBFkKatpHpIMt+Vs1Q10a+zp4Tf4tlVH+hxQeFMJ8kZshAib/qRT2CmG+yG2hJQBr/L9S2C6E+SK3hVkB6KXjJxXsFMJ8kdsqCrKZ6fpeE8N8kRv+CnwBku1KmGphMGCBSmA2wwcIEqIY5ovceq2iV25jgoEejnEi6z+EZWH24WqwXxr+m2qwWxaOWTXYLgEz3L/pYasUrN5Vn2162K4CMygPu/WyTQ37VeBuBTislxRqmNVLCjUc01pJoYaB1E0KDFdOZL8kXDmR10rBMVROZKskXDWRY1ISrprIAVSCWd12h+GqibxUDQZSL8QYphUTmUFF2KkVYgxDBnv1QqyG3XohVsN+9SzWw4PgEHw/AYbxtCHGMEngqA0vl4NbpeGXf+/4u397z7+eeSm++8evPnwp+udHilxGS8MvvfrlFy5vnjp4/uiVT3zy8HL0ndNFcB9Kw89cOfzC5V892Gkn7z04/JXo1HNF8GJ5eCOBo22v/QcJfD46dXqqZMPwawm8uXWw/cyVfZ/83HL0/pMFcA/Kwz/ce/zsh/dsnmlfv3v9z//h0jtPPV8Ar1WAtzLA1vcXsVkB/lkGeHq4BxXgAZTvLBarwD6U7iwYqQJH/IMOvgFV4JB/0MGtSjDLgKHODWglONZezPiAvhpMsw+1khjDQDKY1kliDuO5Bw08VxV2eNHrVB2GbVR0KXAMqsIulPkuxMzKsI9iIgMuQGU45DGpU2AMMyjxJasD1eG4xJesuFUd5mk2qFVgDuNp6HoFxrCthTswFezqenrWmg72dT39KlSEBXBYr8AYjmlxT/8kTAkDKezpA3Nq2CqEZ2Fq2C26hHTI9LBfcAlhczA9zMYvC8HKKtSAY5KtrVklqObqwGCNFyIeQzVXC17zs44mIJOBoPXgfn9EUjx6CVpQD2YPAFxE460k6jVhMCiYeIS4SmvDq2QM8jTotaA+bPbRwIjNQn14oYWfJlyAJuBZW5yQ6JhNwMYMEXrn3hw0Aa8aPAEIWDzANWCUZVbc4vvUhkMO2EELFkhTcMQBt9NaNaEp2OfAYMFoQWOwy4E3jDloDvaEe5INwr15uNlamptrGLZh0IatwfxjFIadJmEHBi9c3boVJTDMNQufPXfgFoxgBtAo3Dty7ovv7s62GocHg4cPXE9C0Th869zW9m2CD3jztwN+8+rWYGmOwrBRGD+k13yTDm8XHDUKD3AP2nx/3AyMA+s1CjOUILVhNLCxGoWB8E/NwhYKSj0YRzZsBsb51m0YDlDR68H41glpGIYlXvJm4RsoxHVgfMug1SjMh4492jzcI/ypqUZhWDCZQW8HHBsGgWZgDPyCw7+E/x/lljzSQxVrCwAAAABJRU5ErkJggg==>>
Codec/Picture/Gif.hs view
@@ -1,389 +1,380 @@--- | Module implementing GIF decoding. -module Codec.Picture.Gif ( decodeGif - , decodeGifImages - ) where - -import Control.Applicative( pure, (<$>), (<*>) ) -import Control.Monad( replicateM ) -import Control.Monad.ST( runST ) -import Control.Monad.Trans.Class( lift ) - -import Data.Bits( (.&.), shiftR, testBit ) -import Data.Word( Word8, Word16 ) - -import qualified Data.ByteString as B -import qualified Data.Vector.Storable as V -import qualified Data.Vector.Storable.Mutable as M - -import Data.Serialize( Serialize(..) - , Get - , decode - , getWord8 - , getWord16le - , getBytes - , lookAhead - {-, decode-} - , remaining - - {-, Put-} - {-, putWord8-} - {-, putWord16be-} - {-, encode-} - {-, putByteString -} - ) - -import Codec.Picture.Types -import Codec.Picture.Gif.LZW -import Codec.Picture.BitWriter - -{- - <GIF Data Stream> ::= Header <Logical Screen> <Data>* Trailer - - <Logical Screen> ::= Logical Screen Descriptor [Global Color Table] - - <Data> ::= <Graphic Block> | - <Special-Purpose Block> - - <Graphic Block> ::= [Graphic Control Extension] <Graphic-Rendering Block> - - <Graphic-Rendering Block> ::= <Table-Based Image> | - Plain Text Extension - - <Table-Based Image> ::= Image Descriptor [Local Color Table] Image Data - - <Special-Purpose Block> ::= Application Extension | - Comment Extension - -} - --------------------------------------------------- ----- GifVersion --------------------------------------------------- -data GifVersion = GIF87a | GIF89a - -gif87aSignature, gif89aSignature :: B.ByteString -gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a" -gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a" - -instance Serialize GifVersion where - put GIF87a = put gif87aSignature - put GIF89a = put gif89aSignature - - get = do - sig <- getBytes (B.length gif87aSignature) - case (sig == gif87aSignature, sig == gif89aSignature) of - (True, _) -> pure GIF87a - (_ , True) -> pure GIF89a - _ -> fail "Invalid Gif signature" - - --------------------------------------------------- ----- LogicalScreenDescriptor --------------------------------------------------- --- | Section 18 of spec-gif89a -data LogicalScreenDescriptor = LogicalScreenDescriptor - { -- | Stored on 16 bits - screenWidth :: !Word16 - -- | Stored on 16 bits - , screenHeight :: !Word16 - -- | Stored on 8 bits - , backgroundIndex :: !Word8 - - -- | Stored on 1 bit - , hasGlobalMap :: !Bool - -- | Stored on 3 bits - , colorResolution :: !Word8 - -- | Stored on 1 bit - , isColorTableSorted :: !Bool - -- | Stored on 3 bits - , colorTableSize :: !Word8 - } - -instance Serialize LogicalScreenDescriptor where - put _ = undefined - get = do - w <- getWord16le - h <- getWord16le - packedField <- getWord8 - backgroundColorIndex <- getWord8 - _aspectRatio <- getWord8 - return LogicalScreenDescriptor - { screenWidth = w - , screenHeight = h - , hasGlobalMap = packedField `testBit` 7 - , colorResolution = (packedField `shiftR` 5) .&. 0x7 + 1 - , isColorTableSorted = packedField `testBit` 3 - , colorTableSize = (packedField .&. 0x7) + 1 - , backgroundIndex = backgroundColorIndex - } - - --------------------------------------------------- ----- ImageDescriptor --------------------------------------------------- --- | Section 20 of spec-gif89a -data ImageDescriptor = ImageDescriptor - { gDescPixelsFromLeft :: !Word16 - , gDescPixelsFromTop :: !Word16 - , gDescImageWidth :: !Word16 - , gDescImageHeight :: !Word16 - , gDescHasLocalMap :: !Bool - , gDescIsInterlaced :: !Bool - , gDescIsImgDescriptorSorted :: !Bool - , gDescLocalColorTableSize :: !Word8 - } - -imageSeparator, extensionIntroducer, gifTrailer :: Word8 -imageSeparator = 0x2C -extensionIntroducer = 0x21 -gifTrailer = 0x3B - -graphicControlLabel :: Word8 -graphicControlLabel = 0xF9 - ---commentLabel, graphicControlLabel, applicationLabel --- -{-commentLabel = 0xFE-} -{-plainTextLabel = 0x01-} -{-applicationLabel = 0xFF-} - -parseDataBlocks :: Get B.ByteString -parseDataBlocks = B.concat <$> (getWord8 >>= aux) - where aux 0 = pure [] - aux size = (:) <$> getBytes (fromIntegral size) <*> (getWord8 >>= aux) - -data GraphicControlExtension = GraphicControlExtension - { gceDisposalMethod :: !Word8 -- ^ Stored on 3 bits - , gceUserInputFlag :: !Bool - , gceTransparentFlag :: !Bool - , gceDelay :: !Word16 - , gceTransparentColorIndex :: !Word8 - } - -instance Serialize GraphicControlExtension where - put _ = undefined - get = do - _extensionLabel <- getWord8 - _size <- getWord8 - packedFields <- getWord8 - delay <- getWord16le - idx <- getWord8 - _blockTerminator <- getWord8 - return GraphicControlExtension - { gceDisposalMethod = (packedFields `shiftR` 2) .&. 0x07 - , gceUserInputFlag = packedFields `testBit` 1 - , gceTransparentFlag = packedFields `testBit` 0 - , gceDelay = delay - , gceTransparentColorIndex = idx - } - -data GifImage = GifImage - { imgDescriptor :: !ImageDescriptor - , imgLocalPalette :: !(Maybe Palette) - , imgLzwRootSize :: !Word8 - , imgData :: B.ByteString - } - -instance Serialize GifImage where - put _ = undefined - get = do - desc <- get - let hasLocalColorTable = gDescHasLocalMap desc - palette <- if hasLocalColorTable - then Just <$> getPalette (gDescLocalColorTableSize desc) - else pure Nothing - - GifImage desc palette <$> getWord8 <*> parseDataBlocks - -data Block = BlockImage GifImage - | BlockGraphicControl GraphicControlExtension - -parseGifBlocks :: Get [Block] -parseGifBlocks = lookAhead getWord8 >>= blockParse - where blockParse v - | v == gifTrailer = getWord8 >> pure [] - | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks - | v == extensionIntroducer = do - _ <- getWord8 - extensionCode <- lookAhead getWord8 - if extensionCode /= graphicControlLabel - then getWord8 >> parseDataBlocks >> parseGifBlocks - else (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks - - blockParse v = do - remain <- remaining - fail ("Unrecognized gif block " ++ show v ++ " remaining: " ++ show remain) - -instance Serialize ImageDescriptor where - put _ = undefined - get = do - _imageSeparator <- getWord8 - imgLeftPos <- getWord16le - imgTopPos <- getWord16le - imgWidth <- getWord16le - imgHeight <- getWord16le - packedFields <- getWord8 - let tableSize = packedFields .&. 0x7 - return ImageDescriptor - { gDescPixelsFromLeft = imgLeftPos - , gDescPixelsFromTop = imgTopPos - , gDescImageWidth = imgWidth - , gDescImageHeight = imgHeight - , gDescHasLocalMap = packedFields `testBit` 7 - , gDescIsInterlaced = packedFields `testBit` 6 - , gDescIsImgDescriptorSorted = packedFields `testBit` 5 - , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0 - } - - --------------------------------------------------- ----- Palette --------------------------------------------------- -type Palette = V.Vector PixelRGB8 - -getPalette :: Word8 -> Get Palette -getPalette bitDepth = replicateM size get >>= return . V.fromList - where size = 2 ^ (fromIntegral bitDepth :: Int) - --------------------------------------------------- ----- GifImage --------------------------------------------------- -data GifHeader = GifHeader - { gifVersion :: GifVersion - , gifScreenDescriptor :: LogicalScreenDescriptor - , gifGlobalMap :: !Palette - } - -instance Serialize GifHeader where - put _ = undefined - get = do - version <- get - screenDesc <- get - palette <- getPalette $ colorTableSize screenDesc - return GifHeader - { gifVersion = version - , gifScreenDescriptor = screenDesc - , gifGlobalMap = palette - } - -data GifFile = GifFile - { gifHeader :: !GifHeader - , gifImages :: [(Maybe GraphicControlExtension, GifImage)] - } - -associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)] -associateDescr [] = [] -associateDescr [BlockGraphicControl _] = [] -associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = associateDescr rest -associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs -associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) = - (Just ctrl, img) : associateDescr xs - -instance Serialize GifFile where - put _ = undefined - get = do - hdr <- get - blocks <- parseGifBlocks - return GifFile { gifHeader = hdr - , gifImages = associateDescr blocks } - -substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8 -substituteColors palette = pixelMap swaper - where swaper n = palette V.! (fromIntegral n) - -decodeImage :: GifImage -> Image Pixel8 -decodeImage img = runST $ runBoolReader $ do - outputVector <- lift . M.new $ width * height - decodeLzw (imgData img) 12 lzwRoot outputVector - frozenData <- lift $ V.unsafeFreeze outputVector - return . deinterlaceGif $ Image - { imageWidth = width - , imageHeight = height - , imageData = frozenData - } - where lzwRoot = fromIntegral $ imgLzwRootSize img - width = fromIntegral $ gDescImageWidth descriptor - height = fromIntegral $ gDescImageHeight descriptor - isInterlaced = gDescIsInterlaced descriptor - descriptor = imgDescriptor img - - deinterlaceGif | not isInterlaced = id - | otherwise = deinterlaceGifImage - -deinterlaceGifImage :: Image Pixel8 -> Image Pixel8 -deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h - where lineIndices = gifInterlacingIndices h - generator x y = pixelAt img x y' - where y' = lineIndices V.! y - -gifInterlacingIndices :: Int -> V.Vector Int -gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices - where indices = flip zip [0..] $ - concat [ [0, 8 .. height - 1] - , [4, 4 + 8 .. height - 1] - , [2, 2 + 4 .. height - 1] - , [1, 1 + 2 .. height - 1] - ] - -paletteOf :: Palette -> GifImage -> Palette -paletteOf global GifImage { imgLocalPalette = Nothing } = global -paletteOf _ GifImage { imgLocalPalette = Just p } = p - -decodeAllGifImages :: GifFile -> [Image PixelRGB8] -decodeAllGifImages GifFile { gifImages = [] } = [] -decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette - , gifScreenDescriptor = wholeDescriptor - } - , gifImages = (_, firstImage) : rest } = map paletteApplyer $ - scanl generator (paletteOf palette firstImage, decodeImage firstImage) rest - where globalWidth = fromIntegral $ screenWidth wholeDescriptor - globalHeight = fromIntegral $ screenHeight wholeDescriptor - - {-background = backgroundIndex wholeDescriptor-} - - paletteApplyer (pal, img) = substituteColors pal img - - generator (_, img1) (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = - (paletteOf palette img2, generateImage pixeler globalWidth globalHeight) - where localWidth = fromIntegral $ gDescImageWidth descriptor - localHeight = fromIntegral $ gDescImageHeight descriptor - - left = fromIntegral $ gDescPixelsFromLeft descriptor - top = fromIntegral $ gDescPixelsFromTop descriptor - - isPixelInLocalImage x y = - x >= left && x < left + localWidth && y >= top && y < top + localHeight - - decoded = decodeImage img2 - - transparent :: Int - transparent = case controlExt of - Nothing -> 300 - Just ext -> if gceTransparentFlag ext - then fromIntegral $ gceTransparentColorIndex ext - else 300 - - pixeler x y - | isPixelInLocalImage x y && fromIntegral val /= transparent = val - where val = pixelAt decoded (x - left) (y - top) - pixeler x y = pixelAt img1 x y - -decodeFirstGifImage :: GifFile -> Either String (Image PixelRGB8) -decodeFirstGifImage - GifFile { gifHeader = GifHeader { gifGlobalMap = palette} - , gifImages = ((_, gif):_) } = Right . substituteColors palette $ decodeImage gif -decodeFirstGifImage _ = Left "No image in gif file" - --- | Transform a raw gif image to an image, witout --- modifying the pixels. --- This function can output the following pixel types : --- --- * PixelRGB8 --- -decodeGif :: B.ByteString -> Either String DynamicImage -decodeGif img = ImageRGB8 <$> (decode img >>= decodeFirstGifImage) - --- | Transform a raw gif to a list of images, representing --- all the images of an animation. -decodeGifImages :: B.ByteString -> Either String [Image PixelRGB8] -decodeGifImages img = decodeAllGifImages <$> decode img - +-- | Module implementing GIF decoding.+module Codec.Picture.Gif ( decodeGif+ , decodeGifImages+ ) where++import Control.Applicative( pure, (<$>), (<*>) )+import Control.Monad( replicateM )+import Control.Monad.ST( runST )+import Control.Monad.Trans.Class( lift )++import Data.Bits( (.&.), shiftR, testBit )+import Data.Word( Word8, Word16 )++import qualified Data.ByteString as B+import qualified Data.Vector.Storable as V+import qualified Data.Vector.Storable.Mutable as M++import Data.Binary( Binary(..) )+import Data.Binary.Get( Get+ , getWord8+ , getWord16le+ , getByteString+ )++import Codec.Picture.InternalHelper+import Codec.Picture.Types+import Codec.Picture.Gif.LZW+import Codec.Picture.BitWriter++{-+ <GIF Data Stream> ::= Header <Logical Screen> <Data>* Trailer++ <Logical Screen> ::= Logical Screen Descriptor [Global Color Table]++ <Data> ::= <Graphic Block> |+ <Special-Purpose Block>++ <Graphic Block> ::= [Graphic Control Extension] <Graphic-Rendering Block>++ <Graphic-Rendering Block> ::= <Table-Based Image> |+ Plain Text Extension++ <Table-Based Image> ::= Image Descriptor [Local Color Table] Image Data++ <Special-Purpose Block> ::= Application Extension |+ Comment Extension+ -}++--------------------------------------------------+---- GifVersion+--------------------------------------------------+data GifVersion = GIF87a | GIF89a++gif87aSignature, gif89aSignature :: B.ByteString+gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a"+gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a"++instance Binary GifVersion where+ put GIF87a = put gif87aSignature+ put GIF89a = put gif89aSignature++ get = do+ sig <- getByteString (B.length gif87aSignature)+ case (sig == gif87aSignature, sig == gif89aSignature) of+ (True, _) -> pure GIF87a+ (_ , True) -> pure GIF89a+ _ -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig)+++--------------------------------------------------+---- LogicalScreenDescriptor+--------------------------------------------------+-- | Section 18 of spec-gif89a+data LogicalScreenDescriptor = LogicalScreenDescriptor+ { -- | Stored on 16 bits+ screenWidth :: !Word16+ -- | Stored on 16 bits+ , screenHeight :: !Word16+ -- | Stored on 8 bits+ , backgroundIndex :: !Word8++ -- | Stored on 1 bit+ , hasGlobalMap :: !Bool+ -- | Stored on 3 bits+ , colorResolution :: !Word8+ -- | Stored on 1 bit+ , isColorTableSorted :: !Bool+ -- | Stored on 3 bits+ , colorTableSize :: !Word8+ }++instance Binary LogicalScreenDescriptor where+ put _ = undefined+ get = do+ w <- getWord16le+ h <- getWord16le+ packedField <- getWord8+ backgroundColorIndex <- getWord8+ _aspectRatio <- getWord8+ return LogicalScreenDescriptor+ { screenWidth = w+ , screenHeight = h+ , hasGlobalMap = packedField `testBit` 7+ , colorResolution = (packedField `shiftR` 5) .&. 0x7 + 1+ , isColorTableSorted = packedField `testBit` 3+ , colorTableSize = (packedField .&. 0x7) + 1+ , backgroundIndex = backgroundColorIndex+ }+++--------------------------------------------------+---- ImageDescriptor+--------------------------------------------------+-- | Section 20 of spec-gif89a+data ImageDescriptor = ImageDescriptor+ { gDescPixelsFromLeft :: !Word16+ , gDescPixelsFromTop :: !Word16+ , gDescImageWidth :: !Word16+ , gDescImageHeight :: !Word16+ , gDescHasLocalMap :: !Bool+ , gDescIsInterlaced :: !Bool+ , gDescIsImgDescriptorSorted :: !Bool+ , gDescLocalColorTableSize :: !Word8+ }++imageSeparator, extensionIntroducer, gifTrailer :: Word8+imageSeparator = 0x2C+extensionIntroducer = 0x21+gifTrailer = 0x3B++graphicControlLabel :: Word8+graphicControlLabel = 0xF9++--commentLabel, graphicControlLabel, applicationLabel+--+{-commentLabel = 0xFE-}+{-plainTextLabel = 0x01-}+{-applicationLabel = 0xFF-}++parseDataBlocks :: Get B.ByteString+parseDataBlocks = B.concat <$> (getWord8 >>= aux)+ where aux 0 = pure []+ aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux)++data GraphicControlExtension = GraphicControlExtension+ { gceDisposalMethod :: !Word8 -- ^ Stored on 3 bits+ , gceUserInputFlag :: !Bool+ , gceTransparentFlag :: !Bool+ , gceDelay :: !Word16+ , gceTransparentColorIndex :: !Word8+ }++instance Binary GraphicControlExtension where+ put _ = undefined+ get = do+ -- due to missing lookahead+ {-_extensionLabel <- getWord8-}+ _size <- getWord8+ packedFields <- getWord8+ delay <- getWord16le+ idx <- getWord8+ _blockTerminator <- getWord8+ return GraphicControlExtension+ { gceDisposalMethod = (packedFields `shiftR` 2) .&. 0x07+ , gceUserInputFlag = packedFields `testBit` 1+ , gceTransparentFlag = packedFields `testBit` 0+ , gceDelay = delay+ , gceTransparentColorIndex = idx+ }++data GifImage = GifImage+ { imgDescriptor :: !ImageDescriptor+ , imgLocalPalette :: !(Maybe Palette)+ , imgLzwRootSize :: !Word8+ , imgData :: B.ByteString+ }++instance Binary GifImage where+ put _ = undefined+ get = do+ desc <- get+ let hasLocalColorTable = gDescHasLocalMap desc+ palette <- if hasLocalColorTable+ then Just <$> getPalette (gDescLocalColorTableSize desc)+ else pure Nothing++ GifImage desc palette <$> getWord8 <*> parseDataBlocks++data Block = BlockImage GifImage+ | BlockGraphicControl GraphicControlExtension++parseGifBlocks :: Get [Block]+parseGifBlocks = getWord8 >>= blockParse+ where blockParse v+ | v == gifTrailer = pure []+ | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks+ | v == extensionIntroducer = do+ extensionCode <- getWord8+ if extensionCode /= graphicControlLabel+ then parseDataBlocks >> parseGifBlocks+ else (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks++ blockParse v = do+ fail ("Unrecognized gif block " ++ show v)++instance Binary ImageDescriptor where+ put _ = undefined+ get = do+ -- due to missing lookahead+ {-_imageSeparator <- getWord8-}+ imgLeftPos <- getWord16le+ imgTopPos <- getWord16le+ imgWidth <- getWord16le+ imgHeight <- getWord16le+ packedFields <- getWord8+ let tableSize = packedFields .&. 0x7+ return ImageDescriptor+ { gDescPixelsFromLeft = imgLeftPos+ , gDescPixelsFromTop = imgTopPos+ , gDescImageWidth = imgWidth+ , gDescImageHeight = imgHeight+ , gDescHasLocalMap = packedFields `testBit` 7+ , gDescIsInterlaced = packedFields `testBit` 6+ , gDescIsImgDescriptorSorted = packedFields `testBit` 5+ , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0+ }+++--------------------------------------------------+---- Palette+--------------------------------------------------+type Palette = Image PixelRGB8++getPalette :: Word8 -> Get Palette+getPalette bitDepth = replicateM (size * 3) get >>= return . Image size 1 . V.fromList+ where size = 2 ^ (fromIntegral bitDepth :: Int)++--------------------------------------------------+---- GifImage+--------------------------------------------------+data GifHeader = GifHeader+ { gifVersion :: GifVersion+ , gifScreenDescriptor :: LogicalScreenDescriptor+ , gifGlobalMap :: !Palette+ }++instance Binary GifHeader where+ put _ = undefined+ get = do+ version <- get+ screenDesc <- get+ palette <- getPalette $ colorTableSize screenDesc+ return GifHeader+ { gifVersion = version+ , gifScreenDescriptor = screenDesc+ , gifGlobalMap = palette+ }++data GifFile = GifFile+ { gifHeader :: !GifHeader+ , gifImages :: [(Maybe GraphicControlExtension, GifImage)]+ }++associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)]+associateDescr [] = []+associateDescr [BlockGraphicControl _] = []+associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = associateDescr rest+associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs+associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) =+ (Just ctrl, img) : associateDescr xs++instance Binary GifFile where+ put _ = undefined+ get = do+ hdr <- get+ blocks <- parseGifBlocks+ return GifFile { gifHeader = hdr+ , gifImages = associateDescr blocks }++substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8+substituteColors palette = pixelMap swaper+ where swaper n = pixelAt palette (fromIntegral n) 0++decodeImage :: GifImage -> Image Pixel8+decodeImage img = runST $ runBoolReader $ do+ outputVector <- lift . M.new $ width * height+ decodeLzw (imgData img) 12 lzwRoot outputVector+ frozenData <- lift $ V.unsafeFreeze outputVector+ return . deinterlaceGif $ Image+ { imageWidth = width+ , imageHeight = height+ , imageData = frozenData+ }+ where lzwRoot = fromIntegral $ imgLzwRootSize img+ width = fromIntegral $ gDescImageWidth descriptor+ height = fromIntegral $ gDescImageHeight descriptor+ isInterlaced = gDescIsInterlaced descriptor+ descriptor = imgDescriptor img++ deinterlaceGif | not isInterlaced = id+ | otherwise = deinterlaceGifImage++deinterlaceGifImage :: Image Pixel8 -> Image Pixel8+deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h+ where lineIndices = gifInterlacingIndices h+ generator x y = pixelAt img x y'+ where y' = lineIndices V.! y++gifInterlacingIndices :: Int -> V.Vector Int+gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices+ where indices = flip zip [0..] $+ concat [ [0, 8 .. height - 1]+ , [4, 4 + 8 .. height - 1]+ , [2, 2 + 4 .. height - 1]+ , [1, 1 + 2 .. height - 1]+ ]++paletteOf :: Palette -> GifImage -> Palette+paletteOf global GifImage { imgLocalPalette = Nothing } = global+paletteOf _ GifImage { imgLocalPalette = Just p } = p++decodeAllGifImages :: GifFile -> [Image PixelRGB8]+decodeAllGifImages GifFile { gifImages = [] } = []+decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette+ , gifScreenDescriptor = wholeDescriptor+ }+ , gifImages = (_, firstImage) : rest } = map paletteApplyer $+ scanl generator (paletteOf palette firstImage, decodeImage firstImage) rest+ where globalWidth = fromIntegral $ screenWidth wholeDescriptor+ globalHeight = fromIntegral $ screenHeight wholeDescriptor++ {-background = backgroundIndex wholeDescriptor-}++ paletteApplyer (pal, img) = substituteColors pal img++ generator (_, img1) (controlExt, img2@(GifImage { imgDescriptor = descriptor })) =+ (paletteOf palette img2, generateImage pixeler globalWidth globalHeight)+ where localWidth = fromIntegral $ gDescImageWidth descriptor+ localHeight = fromIntegral $ gDescImageHeight descriptor++ left = fromIntegral $ gDescPixelsFromLeft descriptor+ top = fromIntegral $ gDescPixelsFromTop descriptor++ isPixelInLocalImage x y =+ x >= left && x < left + localWidth && y >= top && y < top + localHeight++ decoded = decodeImage img2++ transparent :: Int+ transparent = case controlExt of+ Nothing -> 300+ Just ext -> if gceTransparentFlag ext+ then fromIntegral $ gceTransparentColorIndex ext+ else 300++ pixeler x y+ | isPixelInLocalImage x y && fromIntegral val /= transparent = val+ where val = pixelAt decoded (x - left) (y - top)+ pixeler x y = pixelAt img1 x y++decodeFirstGifImage :: GifFile -> Either String (Image PixelRGB8)+decodeFirstGifImage+ GifFile { gifHeader = GifHeader { gifGlobalMap = palette}+ , gifImages = ((_, gif):_) } = Right . substituteColors palette $ decodeImage gif+decodeFirstGifImage _ = Left "No image in gif file"++-- | Transform a raw gif image to an image, witout+-- modifying the pixels.+-- This function can output the following pixel types :+--+-- * PixelRGB8+--+decodeGif :: B.ByteString -> Either String DynamicImage+decodeGif img = ImageRGB8 <$> (decode img >>= decodeFirstGifImage)++-- | Transform a raw gif to a list of images, representing+-- all the images of an animation.+decodeGifImages :: B.ByteString -> Either String [Image PixelRGB8]+decodeGifImages img = decodeAllGifImages <$> decode img+
+ Codec/Picture/HDR.hs view
@@ -0,0 +1,449 @@+-- | Module dedicated of Radiance file decompression (.hdr or .pic) file.+-- Radiance file format is used for High dynamic range imaging.+module Codec.Picture.HDR( decodeHDR, encodeHDR, writeHDR ) where++import Data.Bits( Bits, (.&.), (.|.), shiftL, shiftR )+import Data.Char( ord, chr, isDigit )+import Data.Word( Word8 )+import Data.Monoid( (<>) )+import Control.Applicative( pure, (<$>), (<*>) )+import Control.Monad( when, foldM, foldM_, forM_ )+import Control.Monad.Trans.Class( lift )+import Control.Monad.Trans.Error( ErrorT, throwError, runErrorT )+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Char8 as BC++import Data.List( partition )+import Data.Binary( Binary( .. ), encode )+import Data.Binary.Get( Get, getByteString, getWord8 )+import Data.Binary.Put( putByteString )++import Control.Monad.ST( ST, runST )+import Foreign.Storable ( Storable )+import Control.Monad.Primitive ( PrimState, PrimMonad )+import qualified Data.Vector.Storable.Mutable as M++import Codec.Picture.InternalHelper+import Codec.Picture.BitWriter+import Codec.Picture.Types++import Debug.Trace+import Text.Printf( printf )++{-# INLINE (.<<.) #-}+(.<<.), (.>>.) :: (Bits a) => a -> Int -> a+(.<<.) = shiftL+(.>>.) = shiftR++{-# INLINE (.!!!.) #-}+(.!!!.) :: (PrimMonad m, Storable a)+ => M.STVector (PrimState m) a -> Int -> m a+(.!!!.) = M.read+ {-M.unsafeRead-}++{-# INLINE (.<-.) #-}+(.<-.) :: (PrimMonad m, Storable a)+ => M.STVector (PrimState m) a -> Int -> a -> m ()+(.<-.) = M.write + {-M.unsafeWrite-}++type HDRReader s a = ErrorT String (ST s) a++data RGBE = RGBE !Word8 !Word8 !Word8 !Word8++instance Binary RGBE where+ put (RGBE r g b e) = put r >> put g >> put b >> put e+ get = RGBE <$> get <*> get <*> get <*> get++checkLineLength :: RGBE -> Int+checkLineLength (RGBE _ _ a b) =+ (fromIntegral a .<<. 8) .|. fromIntegral b++isNewRunLengthMarker :: RGBE -> Bool+isNewRunLengthMarker (RGBE 2 2 _ _) = True+isNewRunLengthMarker _ = False++data RadianceFormat =+ FormatRGBE+ | FormatXYZE++radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString+radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe"+radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze"++instance Binary RadianceFormat where+ put FormatRGBE = putByteString radiance32bitRleRGBEFormat+ put FormatXYZE = putByteString radiance32bitRleXYZEFromat++ get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format+ where format sig+ | sig == radiance32bitRleRGBEFormat = pure FormatRGBE+ | sig == radiance32bitRleXYZEFromat = pure FormatXYZE+ | otherwise = fail "Unrecognized Radiance format"++toRGBE :: PixelRGBF -> RGBE+toRGBE (PixelRGBF r g b)+ | d <= 1e-32 = RGBE 0 0 0 0+ | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128)+ where d = maximum [r, g, b]+ e = exponent d+ coeff = significand d * 255.9999 / d+ fix v = truncate $ v * coeff+++dropUntil :: Word8 -> Get ()+dropUntil c = getWord8 >>= inner+ where inner val | val == c = pure ()+ inner _ = getWord8 >>= inner++getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString+getUntil f initialAcc = getWord8 >>= inner initialAcc+ where inner acc c | f c = pure acc+ inner acc c = getWord8 >>= inner (B.snoc acc c)++data RadianceHeader = RadianceHeader+ { radianceInfos :: [(B.ByteString, B.ByteString)]+ , radianceFormat :: RadianceFormat+ , radianceHeight :: !Int+ , radianceWidth :: !Int+ , radianceData :: B.ByteString+ }++radianceFileSignature :: B.ByteString+radianceFileSignature = BC.pack "#?RADIANCE\n"++unpackColor :: B.ByteString -> Int -> RGBE+unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3)+ where at n = B.index str $ idx + n++storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s ()+storeColor vec idx (RGBE r g b e) = do+ (vec .<-. (idx + 0)) r+ (vec .<-. (idx + 1)) g+ (vec .<-. (idx + 2)) b+ (vec .<-. (idx + 3)) e++parsePair :: Char -> Get (B.ByteString, B.ByteString)+parsePair firstChar = do+ let eol c = c == fromIntegral (ord '\n')+ line <- getUntil eol B.empty+ case BC.split '=' line of+ [] -> pure (BC.singleton firstChar, B.empty)+ [val] -> pure (BC.singleton firstChar, val)+ [key, val] -> pure (BC.singleton firstChar <> key, val)+ (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals)++decodeInfos :: Get [(B.ByteString, B.ByteString)]+decodeInfos = do+ char <- getChar8+ case char of+ -- comment+ '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos+ -- end of header, no more information+ '\n' -> pure []+ -- Classical parsing+ c -> (:) <$> parsePair c <*> decodeInfos+++-- | Decode an HDR (radiance) image, the resulting pixel+-- type can be :+--+-- * PixelRGBF+--+decodeHDR :: B.ByteString -> Either String DynamicImage+decodeHDR str = runST $ runErrorT $ do+ case runGet decodeHeader $ L.fromChunks [str] of+ Left err -> throwError err+ Right rez ->+ ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage)++getChar8 :: Get Char+getChar8 = chr . fromIntegral <$> getWord8++isSign :: Char -> Bool+isSign c = c == '+' || c == '-'++isAxisLetter :: Char -> Bool+isAxisLetter c = c == 'X' || c == 'Y'++decodeNum :: Get Int+decodeNum = do+ sign <- getChar8+ letter <- getChar8+ space <- getChar8++ when (not $ isSign sign && isAxisLetter letter && space == ' ')+ (fail "Invalid radiance size declaration")++ let numDec acc c | isDigit c =+ getChar8 >>= numDec (acc * 10 + ord c - (ord '0'))+ numDec acc _+ | sign == '-' = pure $ negate acc+ | otherwise = pure acc++ getChar8 >>= numDec 0++copyPrevColor :: M.STVector s Word8 -> Int -> ST s ()+copyPrevColor scanLine idx = do+ r <- scanLine .!!!. (idx - 4)+ g <- scanLine .!!!. (idx - 3)+ b <- scanLine .!!!. (idx - 2)+ e <- scanLine .!!!. (idx - 1)++ (scanLine .<-. (idx + 0)) r+ (scanLine .<-. (idx + 1)) g+ (scanLine .<-. (idx + 2)) b+ (scanLine .<-. (idx + 3)) e++oldStyleRLE :: B.ByteString -> Int -> M.STVector s Word8+ -> HDRReader s Int+oldStyleRLE inputData initialIdx scanLine = trace "oldStyleRLE" $ inner initialIdx 0 0+ where maxOutput = M.length scanLine+ maxInput = B.length inputData++ inner readIdx writeIdx _+ | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx+ inner readIdx writeIdx shift = trace (printf "r:%d w:%d (mi:%d mo:%d)" readIdx writeIdx maxInput maxOutput) $ do+ let color@(RGBE r g b e) = unpackColor inputData readIdx+ isRun = r == 1 && g == 1 && b == 1++ if not isRun+ then do+ lift $ storeColor scanLine writeIdx color+ inner (readIdx + 4) (writeIdx + 4) 0+ + else do+ let count = fromIntegral e .<<. shift+ lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine (writeIdx + 4 * i)+ inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8)++newStyleRLE :: B.ByteString -> Int -> M.STVector s Word8+ -> HDRReader s Int+newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3]+ where dataAt idx+ | idx >= maxInput = throwError $ "Read index out of bound (" ++ show idx ++ ")"+ | otherwise = pure $ B.index inputData idx++ maxOutput = M.length scanline+ maxInput = B.length inputData+ stride = 4+++ strideSet count destIndex _ | endIndex > maxOutput + stride =+ throwError $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")"+ where endIndex = destIndex + count * stride+ strideSet count destIndex val = aux destIndex count+ where aux i 0 = pure i+ aux i c = do+ lift $ (scanline .<-. i) val+ aux (i + stride) (c - 1)+++ strideCopy _ count destIndex+ | writeEndBound > maxOutput + stride = throwError "Out of bound HDR scanline"+ where writeEndBound = destIndex + count * stride+ strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count+ where aux _ j 0 = pure j+ aux i j c = do+ val <- dataAt i+ lift $ (scanline .<-. j) val+ aux (i + 1) (j + stride) (c - 1)++ inner readIdx writeIdx+ | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx+ inner readIdx writeIdx = do+ code <- dataAt readIdx+ if code > 128+ then do+ let repeatCount = fromIntegral code .&. 0x7F+ newVal <- dataAt $ readIdx + 1+ endIndex <- strideSet repeatCount writeIdx newVal+ inner (readIdx + 2) endIndex ++ else do+ let iCode = fromIntegral code+ endIndex <- strideCopy (readIdx + 1) iCode writeIdx+ inner (readIdx + iCode + 1) endIndex++instance Binary RadianceHeader where+ get = decodeHeader+ put hdr = do+ putByteString radianceFileSignature+ putByteString $ BC.pack "FORMAT="+ put $ radianceFormat hdr+ let sizeString =+ BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr)+ ++ " +X " ++ show (radianceWidth hdr) ++ "\n"+ putByteString sizeString+ putByteString $ radianceData hdr+++decodeHeader :: Get RadianceHeader+decodeHeader = do+ sig <- getByteString $ B.length radianceFileSignature+ when (sig /= radianceFileSignature)+ (fail "Invalid radiance file signature")++ infos <- decodeInfos+ let formatKey = BC.pack "FORMAT"+ case partition (\(k,_) -> k /= formatKey) infos of+ (_, []) -> fail "No radiance format specified"+ (info, [(_, formatString)]) ->+ case runGet get $ L.fromChunks [formatString] of+ Left err -> fail err+ Right format ->+ RadianceHeader info format <$> decodeNum+ <*> decodeNum+ <*> getRemainingBytes++ _ -> fail "Multiple radiance format specified"++toFloat :: RGBE -> PixelRGBF+toFloat (RGBE r g b e) = PixelRGBF rf gf bf+ where f = encodeFloat 1 $ fromIntegral e - (128 + 8)+ rf = (fromIntegral r + 0.0) * f+ gf = (fromIntegral g + 0.0) * f+ bf = (fromIntegral b + 0.0) * f++encodeScanlineColor :: M.MVector s Word8 -> BoolWriter s ()+encodeScanlineColor vec = do+ val <- lift $ vec .!!!. 0+ runLength 1 0 val 1+ where maxIndex = M.length vec++ pushRun len val = do+ pushByte . fromIntegral $ len .|. 0x80+ pushByte val++ pushData start len = do+ pushByte $ fromIntegral len+ forM_ [start - len .. start - 1] $ \i ->+ lift (vec .!!!. i) >>= pushByte++ -- End of scanline, empty the thing+ runLength run cpy prev idx | idx >= maxIndex =+ case (run, cpy) of+ (0, 0) -> pure ()+ (0, n) -> pushData idx n+ (n, 0) -> pushRun n prev+ (_, _) -> error "HDR - Run length algorithm is wrong"++ -- full runlength, we must write the packet+ runLength r@127 _ prev idx = do+ pushRun r prev+ val <- lift $ vec .!!!. idx+ runLength 1 0 val $ idx + 1++ -- full copy, we must write the packet+ runLength _ c@127 _ idx = do+ pushData idx c+ val <- lift $ vec .!!!. idx+ runLength 1 0 val $ idx + 1++ runLength n 0 prev idx = do+ val <- lift $ vec .!!!. idx+ case val == prev of+ True -> runLength (n + 1) 0 prev $ idx + 1+ False | n < 4 -> runLength 0 (n + 1) val $ idx + 1+ False -> do+ pushRun n prev+ runLength 1 0 val $ idx + 1++ runLength 0 n prev idx = do+ val <- lift $ vec .!!!. idx+ if val /= prev+ then runLength 0 (n + 1) val $ idx + 1+ else do+ pushData (idx - 1) $ n - 1+ runLength (2 :: Int) 0 val $ idx + 1++ runLength _ _ _ _ =+ error "HDR RLE inconsistent state"++-- | Write an High dynamic range image into a radiance+-- image file on disk.+writeHDR :: FilePath -> Image PixelRGBF -> IO ()+writeHDR filename img = L.writeFile filename $ encodeHDR img++-- | Encode an High dynamic range image into a radiance image+-- file format.+encodeHDR :: Image PixelRGBF -> L.ByteString+encodeHDR pic = encode $ runST $ do+ let w = imageWidth pic+ h = imageHeight pic++ scanLineR <- M.new w+ scanLineG <- M.new w+ scanLineB <- M.new w+ scanLineE <- M.new w++ encoded <- runBoolWriter $ do+ forM_ [0 .. h - 1] $ \line -> do+ forM_ [0 .. w - 1] $ \i -> do+ let RGBE r g b e = toRGBE $ pixelAt pic i line+ lift $ (scanLineR .<-. i) r+ lift $ (scanLineG .<-. i) g+ lift $ (scanLineB .<-. i) b+ lift $ (scanLineE .<-. i) e++ mapM_ pushByte [2, 2+ , fromIntegral ((w .>>. 8) .&. 0xFF)+ , fromIntegral (w .&. 0xFF)]+ encodeScanlineColor scanLineR+ encodeScanlineColor scanLineG+ encodeScanlineColor scanLineB+ encodeScanlineColor scanLineE++ pure $ RadianceHeader+ { radianceInfos = []+ , radianceFormat = FormatRGBE+ , radianceHeight = h+ , radianceWidth = w+ , radianceData = encoded + }+ ++decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s (PixelRGBF))+decodeRadiancePicture hdr = do+ let width = abs $ radianceWidth hdr+ height = abs $ radianceHeight hdr+ packedData = radianceData hdr++ scanLine <- lift $ M.new $ width * 4+ resultBuffer <- lift $ M.new $ width * height * 3++ let scanLineImage = MutableImage+ { mutableImageWidth = width+ , mutableImageHeight = 1+ , mutableImageData = scanLine+ }++ finalImage = MutableImage+ { mutableImageWidth = width+ , mutableImageHeight = height+ , mutableImageData = resultBuffer+ }++ let scanLineExtractor readIdx line = do+ let color = unpackColor packedData readIdx+ inner | isNewRunLengthMarker color = do+ let calcSize = checkLineLength color+ when (calcSize /= width)+ (throwError "Invalid sanline size")+ pure $ \idx -> newStyleRLE packedData (idx + 4)+ | otherwise = pure $ oldStyleRLE packedData+ f <- inner+ newRead <- f readIdx scanLine+ forM_ [0 .. width - 1] $ \i -> do+ -- mokay, it's a hack, but I don't want to define a+ -- pixel instance of RGBE...+ PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0+ lift $ writePixel finalImage i line . toFloat $ RGBE r g b e++ return newRead++ foldM_ scanLineExtractor 0 [0 .. height - 1]++ return finalImage+
+ Codec/Picture/InternalHelper.hs view
@@ -0,0 +1,29 @@+module Codec.Picture.InternalHelper ( runGet+ , runGetStrict+ , decode+ , getRemainingBytes ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Binary( Binary( get ) )+import Data.Binary.Get( Get, runGetOrFail, getRemainingLazyByteString )++decode :: (Binary a) => B.ByteString -> Either String a+decode = runGetStrict get++runGet :: Get a -> L.ByteString -> Either String a+runGet act = unpack . runGetOrFail act+ where unpack (Left (_, _, str)) = Left str+ unpack (Right (_, _, element)) = Right element++runGetStrict :: Get a -> B.ByteString -> Either String a+runGetStrict act buffer = runGet act $ L.fromChunks [buffer]++getRemainingBytes :: Get B.ByteString+getRemainingBytes = do+ rest <- getRemainingLazyByteString + return $ case L.toChunks rest of+ [] -> B.empty+ [a] -> a+ lst -> B.concat lst+
Codec/Picture/Jpg.hs view
@@ -17,13 +17,22 @@ import Data.Bits( (.|.), (.&.), shiftL, shiftR ) import Data.Int( Int16, Int32 ) import Data.Word(Word8, Word16, Word32) -import Data.Serialize( Serialize(..), Get, Put - , getWord8, putWord8 - , getWord16be, putWord16be - , remaining, lookAhead, skip - , getBytes, decode - , encode, putByteString - ) +import Data.Binary( Binary(..), encode ) + +import Data.Binary.Get( Get + , getWord8 + , getWord16be + , getByteString + , skip + , bytesRead + ) + +import Data.Binary.Put( Put + , putWord8 + , putWord16be + , putByteString + ) + import Data.Maybe( fromJust ) import qualified Data.Vector as V import Data.Vector.Unboxed( (!) ) @@ -32,8 +41,10 @@ import qualified Data.Vector.Storable.Mutable as M -- import Data.Array.Unboxed( Array, UArray, elems, listArray, (!) ) import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L import Foreign.Storable ( Storable ) +import Codec.Picture.InternalHelper import Codec.Picture.BitWriter import Codec.Picture.Types import Codec.Picture.Jpg.Types @@ -161,7 +172,7 @@ class SizeCalculable a where calculateSize :: a -> Int -instance (SizeCalculable a, Serialize a) => Serialize (TableList a) where +instance (SizeCalculable a, Binary a) => Binary (TableList a) where put (TableList lst) = do putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + 2 mapM_ put lst @@ -170,16 +181,16 @@ where innerParse :: Int -> Get [a] innerParse 0 = return [] innerParse size = do - onStart <- fromIntegral <$> remaining + onStart <- fromIntegral <$> bytesRead table <- get - onEnd <- fromIntegral <$> remaining - (table :) <$> innerParse (size - (onStart - onEnd)) + onEnd <- fromIntegral <$> bytesRead + (table :) <$> innerParse (size - (onEnd - onStart)) instance SizeCalculable JpgQuantTableSpec where calculateSize table = 1 + (fromIntegral (quantPrecision table) + 1) * 64 -instance Serialize JpgQuantTableSpec where +instance Binary JpgQuantTableSpec where put table = do let precision = quantPrecision table put4BitsOfEach precision (quantDestination table) @@ -238,14 +249,13 @@ eatUntilCode :: Get () eatUntilCode = do - code <- lookAhead getWord8 - unless (code == 0xFF) - (skip 1 >> eatUntilCode) + code <- getWord8 + unless (code == 0xFF) eatUntilCode instance SizeCalculable JpgHuffmanTableSpec where calculateSize table = 1 + 16 + sum [fromIntegral e | e <- VU.toList $ huffSizes table] -instance Serialize JpgHuffmanTableSpec where +instance Binary JpgHuffmanTableSpec where put table = do let classVal = if huffmanTableClass table == DcComponent then 0 else 1 @@ -269,7 +279,7 @@ , huffCodes = V.fromListN 16 codes } -instance Serialize JpgImage where +instance Binary JpgImage where put (JpgImage { jpgFrame = frames }) = putWord8 0xFF >> putWord8 0xD8 >> mapM_ putFrame frames >> putWord8 0xFF >> putWord8 0xD9 @@ -286,7 +296,7 @@ takeCurrentFrame :: Get B.ByteString takeCurrentFrame = do size <- getWord16be - getBytes (fromIntegral size - 2) + getByteString (fromIntegral size - 2) putFrame :: JpgFrame -> Put putFrame (JpgAppFrame appCode str) = @@ -307,24 +317,32 @@ parseFrames :: Get [JpgFrame] parseFrames = do kind <- get + let parseNextFrame = do + word <- getWord8 + when (word /= 0xFF) $ do + readedData <- bytesRead + fail $ "Invalid Frame marker (" ++ show word + ++ ", bytes read : " ++ show readedData ++ ")" + parseFrames + case kind of JpgAppSegment c -> - (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseFrames + (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseNextFrame JpgExtensionSegment c -> - (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseFrames + (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseNextFrame JpgQuantizationTable -> - (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseFrames + (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseNextFrame JpgRestartInterval -> - (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseFrames + (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseNextFrame JpgHuffmanTableMarker -> (\(TableList huffTables) lst -> JpgHuffmanTable [(t, buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst) - <$> get <*> parseFrames + <$> get <*> parseNextFrame JpgStartOfScan -> (\frm imgData -> [JpgScanBlob frm imgData]) - <$> get <*> (remaining >>= getBytes) + <$> get <*> getRemainingBytes - _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseFrames + _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseNextFrame secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8 secondStartOfFrameByteOfKind JpgBaselineDCTHuffman = 0xC0 @@ -347,14 +365,12 @@ secondStartOfFrameByteOfKind (JpgAppSegment a) = a secondStartOfFrameByteOfKind (JpgExtensionSegment a) = a -instance Serialize JpgFrameKind where +instance Binary JpgFrameKind where put v = putWord8 0xFF >> put (secondStartOfFrameByteOfKind v) get = do - word <- getWord8 + -- no lookahead :( + {-word <- getWord8-} word2 <- getWord8 - when (word /= 0xFF) (do leftData <- remaining - fail $ "Invalid Frame marker (" ++ show word - ++ ", remaining : " ++ show leftData ++ ")") return $ case word2 of 0xC0 -> JpgBaselineDCTHuffman 0xC1 -> JpgExtendedSequentialDCTHuffman @@ -387,14 +403,14 @@ newtype RestartInterval = RestartInterval Word16 -instance Serialize RestartInterval where +instance Binary RestartInterval where put (RestartInterval i) = putWord16be 4 >> putWord16be i get = do size <- getWord16be when (size /= 4) (fail "Invalid jpeg restart interval size") RestartInterval <$> getWord16be -instance Serialize JpgComponent where +instance Binary JpgComponent where get = do ident <- getWord8 (horiz, vert) <- get4BitOfEach @@ -410,18 +426,18 @@ put4BitsOfEach (horizontalSamplingFactor v) $ verticalSamplingFactor v put $ quantizationTableDest v -instance Serialize JpgFrameHeader where +instance Binary JpgFrameHeader where get = do - beginOffset <- remaining + beginOffset <- fromIntegral <$> bytesRead frmHLength <- getWord16be samplePrec <- getWord8 h <- getWord16be w <- getWord16be compCount <- getWord8 components <- replicateM (fromIntegral compCount) get - endOffset <- remaining + endOffset <- fromIntegral <$> bytesRead when (beginOffset - endOffset < fromIntegral frmHLength) - (skip $ fromIntegral frmHLength - (beginOffset - endOffset)) + (skip $ fromIntegral frmHLength - (endOffset - beginOffset)) return JpgFrameHeader { jpgFrameHeaderLength = frmHLength , jpgSamplePrecision = samplePrec @@ -439,7 +455,7 @@ putWord8 $ jpgImageComponentCount v mapM_ put $ jpgComponents v -instance Serialize JpgScanSpecification where +instance Binary JpgScanSpecification where put v = do put $ componentSelector v put4BitsOfEach (dcEntropyCodingTable v) $ acEntropyCodingTable v @@ -453,7 +469,7 @@ , acEntropyCodingTable = ac } -instance Serialize JpgScanHeader where +instance Binary JpgScanHeader where get = do thisScanLength <- getWord16be compCount <- getWord8 @@ -833,7 +849,7 @@ -- * PixelYCbCr8 -- decodeJpeg :: B.ByteString -> Either String DynamicImage -decodeJpeg file = case decode file of +decodeJpeg file = case runGetStrict get file of Left err -> Left err Right img -> case compCount of 1 -> Right . ImageY8 $ Image imgWidth imgHeight pixelData @@ -962,7 +978,7 @@ -- | Encode an image in jpeg at a reasonnable quality level. -- If you want better quality or reduced file size, you should -- use `encodeJpegAtQuality` -encodeJpeg :: Image PixelYCbCr8 -> B.ByteString +encodeJpeg :: Image PixelYCbCr8 -> L.ByteString encodeJpeg = encodeJpegAtQuality 50 -- | Function to call to encode an image to jpeg. @@ -970,7 +986,7 @@ -- the best quality). encodeJpegAtQuality :: Word8 -- ^ Quality factor -> Image PixelYCbCr8 -- ^ Image to encode - -> B.ByteString -- ^ Encoded JPEG + -> L.ByteString -- ^ Encoded JPEG encodeJpegAtQuality quality img@(Image { imageWidth = w, imageHeight = h }) = encode finalImage where finalImage = JpgImage [ JpgQuantTable quantTables
Codec/Picture/Png.hs view
@@ -23,7 +23,7 @@ import Control.Monad.Trans( lift ) import Control.Monad.Primitive ( PrimState, PrimMonad ) import qualified Control.Monad.Trans.State.Strict as S -import Data.Serialize( Serialize, runGet, get) +import Data.Binary( Binary( get) ) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as M @@ -38,6 +38,7 @@ import Codec.Picture.Types import Codec.Picture.Png.Type import Codec.Picture.Png.Export +import Codec.Picture.InternalHelper -- | Simple structure used to hold information about Adam7 deinterlacing. -- A structure is used to avoid pollution of the module namespace. @@ -78,10 +79,6 @@ Just (v, rest) -> S.put rest >> return v Nothing -> return 0 -{-# INLINE (!!!) #-} -(!!!) :: (Storable e) => V.Vector e -> Int -> e -(!!!) = V.unsafeIndex - {-# INLINE (.!!!.) #-} (.!!!.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> m a (.!!!.) = M.unsafeRead @@ -371,10 +368,11 @@ return imgArray generateGreyscalePalette :: Word8 -> PngPalette -generateGreyscalePalette times = V.fromListN (fromIntegral possibilities + 1) pixels +generateGreyscalePalette times = Image possibilities 0 vec where possibilities = 2 ^ times - 1 - pixels = [PixelRGB8 i i i | n <- [0..possibilities] - , let i = n * (255 `div` possibilities)] + vec = V.fromListN ((fromIntegral possibilities + 1) * 3) $ concat pixels + pixels = [[i, i, i] | n <- [0 .. possibilities] + , let i = fromIntegral $ n * (255 `div` possibilities)] sampleCountOfImageType :: PngImageType -> Word32 sampleCountOfImageType PngGreyscale = 1 @@ -396,7 +394,7 @@ applyPalette pal img = V.fromListN ((initSize + 1) * 3) pixels where (_, initSize) = bounds img pixels = concat [[r, g, b] | ipx <- V.toList img - , let PixelRGB8 r g b = pal !!! fromIntegral ipx] + , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0] -- | Transform a raw png image to an image, without modifying the -- underlying pixel type. If the image is greyscale and < 8 bits, @@ -416,7 +414,7 @@ -- decodePng :: B.ByteString -> Either String DynamicImage decodePng byte = do - rawImg <- runGet get byte + rawImg <- runGetStrict get byte let ihdr@(PngIHdr { width = w, height = h }) = header rawImg compressedImageData = B.concat [chunkData chunk | chunk <- chunks rawImg
Codec/Picture/Png/Export.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} -- | Module implementing a basic png export, no filtering is applyed, but -- export at least valid images. module Codec.Picture.Png.Export( PngSavable( .. ) @@ -8,7 +9,7 @@ , writeDynamicPng ) where -import Data.Serialize(encode) +import Data.Binary( encode ) import Data.Vector.Storable ( (!) ) import Data.Word(Word8) import qualified Codec.Compression.Zlib as Z @@ -22,7 +23,7 @@ class PngSavable a where -- | Transform an image into a png encoded bytestring, ready -- to be writte as a file. - encodePng :: Image a -> B.ByteString + encodePng :: Image a -> Lb.ByteString preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr preparePngHeader (Image { imageWidth = w, imageHeight = h }) imgType depth = PngIHdr @@ -37,7 +38,7 @@ -- | Helper function to directly write an image as a png on disk. writePng :: (PngSavable pixel) => FilePath -> Image pixel -> IO () -writePng path img = B.writeFile path $ encodePng img +writePng path img = Lb.writeFile path $ encodePng img endChunk :: PngRawChunk endChunk = PngRawChunk { chunkLength = 0 @@ -55,7 +56,8 @@ , chunkData = imgData } -genericEncodePng :: PngImageType -> Int -> Image a -> B.ByteString +genericEncodePng :: (PixelBaseComponent a ~ Word8) + => PngImageType -> Int -> Image a -> Lb.ByteString genericEncodePng imgKind compCount image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = encode PngRawImage { header = hdr, chunks = [prepareIDatChunk strictEncoded, endChunk]} @@ -85,7 +87,7 @@ writeDynamicPng :: FilePath -> DynamicImage -> IO (Either String Bool) writeDynamicPng path img = case encodeDynamicPng img of Left err -> return $ Left err - Right b -> B.writeFile path b >> return (Right True) + Right b -> Lb.writeFile path b >> return (Right True) -- | Encode a dynamic image in bmp if possible, supported pixel type are : -- @@ -97,7 +99,7 @@ -- -- - RGBA8 -- -encodeDynamicPng :: DynamicImage -> Either String B.ByteString +encodeDynamicPng :: DynamicImage -> Either String Lb.ByteString encodeDynamicPng (ImageRGB8 img) = Right $ encodePng img encodeDynamicPng (ImageRGBA8 img) = Right $ encodePng img encodeDynamicPng (ImageY8 img) = Right $ encodePng img
Codec/Picture/Png/Type.hs view
@@ -20,17 +20,25 @@ import Control.Applicative( (<$>) ) import Control.Monad( when, replicateM ) import Data.Bits( xor, (.&.), shiftR ) -import Data.Serialize( Serialize(..), Get, get, runGet, runPut - , putWord8, getWord8 - , putWord32be, getWord32be - , getByteString, putByteString ) +import Data.Binary( Binary(..), Get, get ) +import Data.Binary.Get( getWord8 + , getWord32be + , getByteString + ) +import Data.Binary.Put( runPut + , putWord8 + , putWord32be + , putByteString + ) import Data.Vector.Unboxed( Vector, fromListN, (!) ) import qualified Data.Vector.Storable as V import Data.List( foldl' ) import Data.Word( Word32, Word8 ) import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L import Codec.Picture.Types +import Codec.Picture.InternalHelper -------------------------------------------------- ---- Types @@ -68,15 +76,16 @@ } -- | Palette with indices beginning at 0 to elemcount - 1 -type PngPalette = V.Vector PixelRGB8 +type PngPalette = Image PixelRGB8 -- | Parse a palette from a png chunk. parsePalette :: PngRawChunk -> Either String PngPalette parsePalette plte | chunkLength plte `mod` 3 /= 0 = Left "Invalid palette size" - | otherwise = V.fromListN pixelCount <$> runGet pixelUnpacker (chunkData plte) - where pixelUnpacker = replicateM (fromIntegral pixelCount) get + | otherwise = Image pixelCount 1 . V.fromListN (3 * pixelCount) <$> pixels + where pixelUnpacker = replicateM (fromIntegral pixelCount * 3) get pixelCount = fromIntegral $ chunkLength plte `div` 3 + pixels = runGetStrict pixelUnpacker (chunkData plte) -- | Data structure during real png loading/parsing data PngRawChunk = PngRawChunk @@ -133,7 +142,7 @@ -------------------------------------------------- ---- Instances -------------------------------------------------- -instance Serialize PngFilter where +instance Binary PngFilter where put = putWord8 . toEnum . fromEnum get = getWord8 >>= \w -> case w of 0 -> return FilterNone @@ -143,7 +152,7 @@ 4 -> return FilterPaeth _ -> fail "Invalid scanline filter" -instance Serialize PngRawImage where +instance Binary PngRawImage where put img = do putByteString pngSignature put $ header img @@ -151,7 +160,7 @@ get = parseRawPngImage -instance Serialize PngRawChunk where +instance Binary PngRawChunk where put chunk = do putWord32be $ chunkLength chunk putByteString $ chunkType chunk @@ -178,7 +187,7 @@ chunkType = chunkSig } -instance Serialize PngIHdr where +instance Binary PngIHdr where put hdr = do putWord32be 13 let inner = runPut $ do @@ -190,8 +199,9 @@ put $ compressionMethod hdr put $ filterMethod hdr put $ interlaceMethod hdr - crc = pngComputeCrc [inner] - putByteString inner + strictList = L.toChunks inner + crc = pngComputeCrc strictList + mapM_ putByteString strictList putWord32be crc get = do @@ -227,7 +237,7 @@ else (chunk:) <$> parseChunks -instance Serialize PngInterlaceMethod where +instance Binary PngInterlaceMethod where get = getWord8 >>= \w -> case w of 0 -> return PngNoInterlace 1 -> return PngInterlaceAdam7 @@ -280,7 +290,7 @@ iENDSignature :: ChunkSignature iENDSignature = signature [73, 69, 78, 68] -instance Serialize PngImageType where +instance Binary PngImageType where put PngGreyscale = putWord8 0 put PngTrueColour = putWord8 2 put PngIndexedColor = putWord8 3
Codec/Picture/Saving.hs view
@@ -1,46 +1,88 @@-module Codec.Picture.Saving( imageToJpg - , imageToPng - , imageToBitmap - ) where - -import qualified Data.ByteString as B -import Codec.Picture.Bitmap -import Codec.Picture.Jpg -import Codec.Picture.Png -import Codec.Picture.Types - --- | This function will try to do anything to encode an image --- as JPEG, make all color conversion and such. Equivalent --- of 'decodeImage' for jpeg encoding -imageToJpg :: Int -> DynamicImage -> B.ByteString -imageToJpg quality dynImage = - let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality) - in case dynImage of - ImageYCbCr8 img -> encodeAtQuality img - ImageRGB8 img -> encodeAtQuality (convertImage img) - ImageRGBA8 img -> encodeAtQuality (convertImage $ dropAlphaLayer img) - ImageY8 img -> encodeAtQuality . convertImage - $ (promoteImage img :: Image PixelRGB8) - ImageYA8 img -> encodeAtQuality $ - convertImage (promoteImage $ dropAlphaLayer img :: Image PixelRGB8) - --- | This function will try to do anything to encode an image --- as PNG, make all color conversion and such. Equivalent --- of 'decodeImage' for PNG encoding -imageToPng :: DynamicImage -> B.ByteString -imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8) -imageToPng (ImageRGB8 img) = encodePng img -imageToPng (ImageRGBA8 img) = encodePng img -imageToPng (ImageY8 img) = encodePng img -imageToPng (ImageYA8 img) = encodePng (promoteImage img :: Image PixelRGBA8) - --- | This function will try to do anything to encode an image --- as bitmap, make all color conversion and such. Equivalent --- of 'decodeImage' for Bitmap encoding -imageToBitmap :: DynamicImage -> B.ByteString -imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) -imageToBitmap (ImageRGB8 img) = encodeBitmap img -imageToBitmap (ImageRGBA8 img) = encodeBitmap img -imageToBitmap (ImageY8 img) = encodeBitmap img -imageToBitmap (ImageYA8 img) = encodeBitmap (promoteImage img :: Image PixelRGBA8) - +-- | Helper functions to save dynamic images to other file format+-- with automatic color space/sample format conversion done automatically.+module Codec.Picture.Saving( imageToJpg+ , imageToPng+ , imageToBitmap+ , imageToRadiance+ ) where++import Data.Word( Word8 )+import qualified Data.ByteString.Lazy as L+import Codec.Picture.Bitmap+import Codec.Picture.Jpg+import Codec.Picture.Png+import Codec.Picture.HDR+import Codec.Picture.Types++componentToLDR :: Float -> Word8+componentToLDR = truncate . (255 *) . min 1.0 . max 0.0++toStandardDef :: Image PixelRGBF -> Image PixelRGB8+toStandardDef img = pixelMap pixelConverter img+ where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b+ where r = componentToLDR rf+ g = componentToLDR gf+ b = componentToLDR bf++greyScaleToStandardDef :: Image PixelF -> Image Pixel8+greyScaleToStandardDef = pixelMap componentToLDR++-- | This function will try to do anything to encode an image+-- as RADIANCE, make all color conversion and such. Equivalent+-- of 'decodeImage' for radiance encoding+imageToRadiance :: DynamicImage -> L.ByteString+imageToRadiance (ImageYCbCr8 img) =+ imageToRadiance . ImageRGB8 $ convertImage img+imageToRadiance (ImageRGB8 img) =+ imageToRadiance . ImageRGBF $ promoteImage img+imageToRadiance (ImageRGBF img) = encodeHDR img+imageToRadiance (ImageRGBA8 img) =+ imageToRadiance . ImageRGBF . promoteImage $ dropAlphaLayer img+imageToRadiance (ImageY8 img) =+ imageToRadiance . ImageRGB8 $ promoteImage img+imageToRadiance (ImageYF img) =+ imageToRadiance . ImageRGBF $ promoteImage img+imageToRadiance (ImageYA8 img) =+ imageToRadiance . ImageRGB8 . promoteImage $ dropAlphaLayer img++-- | This function will try to do anything to encode an image+-- as JPEG, make all color conversion and such. Equivalent+-- of 'decodeImage' for jpeg encoding+imageToJpg :: Int -> DynamicImage -> L.ByteString+imageToJpg quality dynImage =+ let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality)+ in case dynImage of+ ImageYCbCr8 img -> encodeAtQuality img+ ImageRGB8 img -> encodeAtQuality (convertImage img)+ ImageRGBF img -> imageToJpg quality . ImageRGB8 $ toStandardDef img+ ImageRGBA8 img -> encodeAtQuality (convertImage $ dropAlphaLayer img)+ ImageYF img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img+ ImageY8 img -> encodeAtQuality . convertImage+ $ (promoteImage img :: Image PixelRGB8)+ ImageYA8 img -> encodeAtQuality $+ convertImage (promoteImage $ dropAlphaLayer img :: Image PixelRGB8)++-- | This function will try to do anything to encode an image+-- as PNG, make all color conversion and such. Equivalent+-- of 'decodeImage' for PNG encoding+imageToPng :: DynamicImage -> L.ByteString+imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8)+imageToPng (ImageRGB8 img) = encodePng img+imageToPng (ImageRGBF img) = encodePng $ toStandardDef img+imageToPng (ImageRGBA8 img) = encodePng img+imageToPng (ImageY8 img) = encodePng img+imageToPng (ImageYF img) = encodePng $ greyScaleToStandardDef img+imageToPng (ImageYA8 img) = encodePng (promoteImage img :: Image PixelRGBA8)++-- | This function will try to do anything to encode an image+-- as bitmap, make all color conversion and such. Equivalent+-- of 'decodeImage' for Bitmap encoding+imageToBitmap :: DynamicImage -> L.ByteString+imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8)+imageToBitmap (ImageRGBF img) = encodeBitmap $ toStandardDef img+imageToBitmap (ImageRGB8 img) = encodeBitmap img+imageToBitmap (ImageRGBA8 img) = encodeBitmap img+imageToBitmap (ImageY8 img) = encodeBitmap img+imageToBitmap (ImageYF img) = encodeBitmap $ greyScaleToStandardDef img+imageToBitmap (ImageYA8 img) = encodeBitmap (promoteImage img :: Image PixelRGBA8)+
Codec/Picture/Types.hs view
@@ -3,6 +3,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} -- | Module providing the basic types for image manipulation in the library. -- Defining the types used to store all those _Juicy Pixels_ module Codec.Picture.Types( -- * Types @@ -10,27 +13,36 @@ Image( .. ) , MutableImage( .. ) , DynamicImage( .. ) - , PixelType( .. ) + + -- ** Image functions + , freezeImage + , unsafeFreezeImage + -- ** Pixel types , Pixel8 + , PixelF , PixelYA8( .. ) , PixelRGB8( .. ) + , PixelRGBF( .. ) , PixelRGBA8( .. ) , PixelYCbCr8( .. ) -- * Type classes , ColorConvertible( .. ) , Pixel(..) + -- $graph , ColorSpaceConvertible( .. ) , LumaPlaneExtractable( .. ) , TransparentPixel( .. ) -- * Helper functions - , canConvertTo , pixelMap + , pixelFold , dropAlphaLayer , generateImage , generateFoldImage + , gammaCorrection + , toneMapping -- * Color plane extraction , ColorPlane ( ) @@ -48,18 +60,18 @@ ) where import Control.Monad( forM_, foldM ) -import Control.Applicative( (<$>), (<*>) ) +import Control.Applicative( (<$>) ) import Control.DeepSeq( NFData( .. ) ) import Control.Monad.ST( ST, runST ) import Control.Monad.Primitive ( PrimMonad, PrimState ) -import Foreign.Storable ( Storable, sizeOf, alignment, peek, poke ) -import Foreign.Ptr ( plusPtr ) +import Foreign.Storable ( Storable ) import Data.Word( Word8 ) +import Data.List( foldl' ) import Data.Vector.Storable ( (!) ) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as M -import Data.Serialize( Serialize, put, get ) +#include "ConvGraph.hs" -- | Image or pixel buffer, the coordinates are assumed to start -- from the upper-left corner of the image, with the horizontal @@ -72,7 +84,7 @@ -- | The real image, to extract pixels at some position -- you should use the helpers functions. - , imageData :: V.Vector Word8 + , imageData :: V.Vector (PixelBaseComponent a) } {-# INLINE (!!!) #-} @@ -100,7 +112,7 @@ data PlaneAlpha = PlaneAlpha -- | Define the plane for the luma component -data PlaneLuma = PlaneLuma +data PlaneLuma = PlaneLuma -- | Define the plane for the Cr component data PlaneCr = PlaneCr @@ -122,7 +134,7 @@ instance ColorPlane PixelYA8 PlaneAlpha where toComponentIndex _ _ = 1 - + instance ColorPlane PixelRGB8 PlaneRed where toComponentIndex _ _ = 0 @@ -132,6 +144,15 @@ instance ColorPlane PixelRGB8 PlaneBlue where toComponentIndex _ _ = 2 +instance ColorPlane PixelRGBF PlaneRed where + toComponentIndex _ _ = 0 + +instance ColorPlane PixelRGBF PlaneGreen where + toComponentIndex _ _ = 1 + +instance ColorPlane PixelRGBF PlaneBlue where + toComponentIndex _ _ = 2 + instance ColorPlane PixelRGBA8 PlaneRed where toComponentIndex _ _ = 0 @@ -152,8 +173,12 @@ -- extractRedPlane = extractComponent PlaneRed -- @ -- -extractComponent :: forall px plane. (Pixel px, ColorPlane px plane) - => plane -> Image px -> Image Pixel8 +extractComponent :: forall px plane. ( Pixel px + , Pixel (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) + ~ PixelBaseComponent px + , ColorPlane px plane ) + => plane -> Image px -> Image (PixelBaseComponent px) extractComponent plane = unsafeExtractComponent idx where idx = toComponentIndex (undefined :: px) plane @@ -161,12 +186,16 @@ -- can be represented by a gray scale image. -- If you ask a component out of bound, the `error` function will -- be called -unsafeExtractComponent :: forall a. (Pixel a) +unsafeExtractComponent :: forall a + . ( Pixel a + , Pixel (PixelBaseComponent a) + , PixelBaseComponent (PixelBaseComponent a) + ~ PixelBaseComponent a) => Int -- ^ The component index, beginning at 0 ending at (componentCount - 1) -> Image a -- ^ Source image - -> Image Pixel8 + -> Image (PixelBaseComponent a) unsafeExtractComponent comp img@(Image { imageWidth = w, imageHeight = h }) - | comp >= padd = error $ "extractComponent : invalid component index (" + | comp >= padd = error $ "extractComponent : invalid component index (" ++ show comp ++ ", max:" ++ show padd ++ ")" | otherwise = Image { imageWidth = w, imageHeight = h, imageData = plane } where plane = stride img 1 padd comp @@ -191,7 +220,8 @@ {-# INLINE dropTransparency #-} dropTransparency (PixelRGBA8 r g b _) = PixelRGB8 r g b -stride :: Image a -> Int -> Int -> Int -> V.Vector Word8 +stride :: (Storable (PixelBaseComponent a)) + => Image a -> Int -> Int -> Int -> V.Vector (PixelBaseComponent a) stride Image { imageWidth = w, imageHeight = h, imageData = array } run padd firstComponent = runST $ do let cell_count = w * h * run @@ -202,7 +232,7 @@ forM_ [0 .. run - 1] $ \i -> (outArray .<-. (write_idx + i)) $ array !!! (read_idx + i) strideWrite (write_idx + run) (read_idx + padd) - + strideWrite 0 firstComponent V.unsafeFreeze outArray @@ -215,7 +245,7 @@ -- | Image or pixel buffer, the coordinates are assumed to start -- from the upper-left corner of the image, with the horizontal -- position first, then the vertical one. The image can be transformed in place. -data MutableImage s a = MutableImage +data MutableImage s a = MutableImage { -- | Width of the image in pixels mutableImageWidth :: {-# UNPACK #-} !Int @@ -224,9 +254,20 @@ -- | The real image, to extract pixels at some position -- you should use the helpers functions. - , mutableImageData :: M.STVector s Word8 + , mutableImageData :: M.STVector s (PixelBaseComponent a) } +-- | `O(n)` Yield an immutable copy of an image by making a copy of it +freezeImage :: (Storable (PixelBaseComponent a)) + => MutableImage s a -> ST s (Image a) +freezeImage (MutableImage w h d) = Image w h <$> V.freeze d + +-- | `O(1)` Unsafe convert a mutable image to an immutable one without copying. +-- The mutable image may not be used after this operation. +unsafeFreezeImage :: (Storable (PixelBaseComponent a)) + => MutableImage s a -> ST s (Image a) +unsafeFreezeImage (MutableImage w h d) = Image w h <$> V.unsafeFreeze d + instance NFData (MutableImage s a) where rnf (MutableImage width height dat) = width `seq` height `seq` @@ -238,10 +279,14 @@ data DynamicImage = -- | A greyscale image. ImageY8 (Image Pixel8) + -- | A greyscale HDR image + | ImageYF (Image PixelF) -- | An image in greyscale with an alpha channel. | ImageYA8 (Image PixelYA8) -- | An image in true color. | ImageRGB8 (Image PixelRGB8) + -- | An image with HDR pixels + | ImageRGBF (Image PixelRGBF) -- | An image in true color and an alpha channel. | ImageRGBA8 (Image PixelRGBA8) -- | An image in the colorspace used by Jpeg images. @@ -249,14 +294,20 @@ instance NFData DynamicImage where rnf (ImageY8 img) = rnf img + rnf (ImageYF img) = rnf img rnf (ImageYA8 img) = rnf img rnf (ImageRGB8 img) = rnf img + rnf (ImageRGBF img) = rnf img rnf (ImageRGBA8 img) = rnf img rnf (ImageYCbCr8 img) = rnf img -- | Simple alias for greyscale value in 8 bits. type Pixel8 = Word8 +-- | Floating greyscale value, the 0 to 255 8 bit range maps +-- to 0 to 1 in this floating version +type PixelF = Float + -- | Pixel type storing Luminance (Y) and alpha information -- on 8 bits. -- Value are stored in the following order : @@ -281,6 +332,19 @@ {-# UNPACK #-} !Word8 -- Green {-# UNPACK #-} !Word8 -- Blue +-- | Pixel type storing HDR pixel on 32 bits float +-- Value are stored in the following order : +-- +-- * Red +-- +-- * Green +-- +-- * Blue +-- +data PixelRGBF = PixelRGBF {-# UNPACK #-} !PixelF -- Red + {-# UNPACK #-} !PixelF -- Green + {-# UNPACK #-} !PixelF -- Blue + -- | Pixel storing data in the YCbCr colorspace, -- value are stored in the following order : -- @@ -310,150 +374,20 @@ {-# UNPACK #-} !Word8 -- Blue {-# UNPACK #-} !Word8 -- Alpha -instance Serialize PixelYA8 where - {-# INLINE put #-} - put (PixelYA8 y a) = put y >> put a - {-# INLINE get #-} - get = PixelYA8 <$> get <*> get - -instance Storable PixelYA8 where - {-# INLINE sizeOf #-} - sizeOf _ = sizeOf (undefined :: Word8) * 2 - {-# INLINE alignment #-} - alignment _ = alignment (undefined :: Word8) - {-# INLINE peek #-} - peek ptr = do - let __ = undefined :: Word8 - yOff = sizeOf __ * 0 - aOff = sizeOf __ * 1 - y <- peek $ ptr `plusPtr` yOff - a <- peek $ ptr `plusPtr` aOff - return (PixelYA8 y a) - {-# INLINE poke #-} - poke ptr (PixelYA8 y a) = do - let __ = undefined :: Word8 - yOff = sizeOf __ * 0 - aOff = sizeOf __ * 1 - poke (ptr `plusPtr` yOff) y - poke (ptr `plusPtr` aOff) a - -instance Serialize PixelRGB8 where - {-# INLINE put #-} - put (PixelRGB8 r g b) = put r >> put g >> put b - {-# INLINE get #-} - get = PixelRGB8 <$> get <*> get <*> get - -instance Storable PixelRGB8 where - {-# INLINE sizeOf #-} - sizeOf _ = sizeOf (undefined :: Word8) * 3 - {-# INLINE alignment #-} - alignment _ = alignment (undefined :: Word8) - {-# INLINE peek #-} - peek ptr = do - let __ = undefined :: Word8 - rOff = sizeOf __ * 0 - gOff = sizeOf __ * 1 - bOff = sizeOf __ * 2 - r <- peek $ ptr `plusPtr` rOff - g <- peek $ ptr `plusPtr` gOff - b <- peek $ ptr `plusPtr` bOff - return (PixelRGB8 r g b) - {-# INLINE poke #-} - poke ptr (PixelRGB8 r g b) = do - let __ = undefined :: Word8 - rOff = sizeOf __ * 0 - gOff = sizeOf __ * 1 - bOff = sizeOf __ * 2 - poke (ptr `plusPtr` rOff) r - poke (ptr `plusPtr` gOff) g - poke (ptr `plusPtr` bOff) b - -instance Serialize PixelYCbCr8 where - {-# INLINE put #-} - put (PixelYCbCr8 y cb cr) = put y >> put cb >> put cr - {-# INLINE get #-} - get = PixelYCbCr8 <$> get <*> get <*> get - -instance Storable PixelYCbCr8 where - {-# INLINE sizeOf #-} - sizeOf _ = sizeOf (undefined :: Word8) * 3 - {-# INLINE alignment #-} - alignment _ = alignment (undefined :: Word8) - {-# INLINE peek #-} - peek ptr = do - let __ = undefined :: Word8 - yOff = sizeOf __ * 0 - cbOff = sizeOf __ * 1 - crOff = sizeOf __ * 2 - y <- peek $ ptr `plusPtr` yOff - cb <- peek $ ptr `plusPtr` cbOff - cr <- peek $ ptr `plusPtr` crOff - return (PixelYCbCr8 y cb cr) - {-# INLINE poke #-} - poke ptr (PixelYCbCr8 y cb cr) = do - let __ = undefined :: Word8 - yOff = sizeOf __ * 0 - cbOff = sizeOf __ * 1 - crOff = sizeOf __ * 2 - poke (ptr `plusPtr` yOff) y - poke (ptr `plusPtr` cbOff) cb - poke (ptr `plusPtr` crOff) cr - -instance Serialize PixelRGBA8 where - {-# INLINE put #-} - put (PixelRGBA8 r g b a) = put r >> put g >> put b >> put a - {-# INLINE get #-} - get = PixelRGBA8 <$> get <*> get <*> get <*> get - -instance Storable PixelRGBA8 where - {-# INLINE sizeOf #-} - sizeOf _ = sizeOf (undefined :: Word8) * 4 - {-# INLINE alignment #-} - alignment _ = alignment (undefined :: Word8) - {-# INLINE peek #-} - peek ptr = do - let __ = undefined :: Word8 - rOff = sizeOf __ * 0 - gOff = sizeOf __ * 1 - bOff = sizeOf __ * 2 - aOff = sizeOf __ * 3 - r <- peek $ ptr `plusPtr` rOff - g <- peek $ ptr `plusPtr` gOff - b <- peek $ ptr `plusPtr` bOff - a <- peek $ ptr `plusPtr` aOff - return (PixelRGBA8 r g b a) - {-# INLINE poke #-} - poke ptr (PixelRGBA8 r g b a) = do - let __ = undefined :: Word8 - rOff = sizeOf __ * 0 - gOff = sizeOf __ * 1 - bOff = sizeOf __ * 2 - aOff = sizeOf __ * 3 - poke (ptr `plusPtr` rOff) r - poke (ptr `plusPtr` gOff) g - poke (ptr `plusPtr` bOff) b - poke (ptr `plusPtr` aOff) a - --- | Describe pixel kind at runtime -data PixelType = PixelMonochromatic -- ^ For 2 bits pixels - | PixelGreyscale - | PixelGreyscaleAlpha - | PixelRedGreenBlue8 - | PixelRedGreenBlueAlpha8 - | PixelYChromaRChromaB8 - deriving Eq - --- | Typeclass used to query a type about it's properties --- regarding casting to other pixel types -class (Serialize a) => Pixel a where - -- | Tell if a pixel can be converted to another pixel, - -- the first value should not be used, and 'undefined' can - -- be used as a valid value. - canPromoteTo :: a -> PixelType -> Bool +-- | Definition of pixels used in images. Each pixel has a color space, and a representative +-- component (Word8 or Float). +class ( Storable (PixelBaseComponent a), Num (PixelBaseComponent a) ) => Pixel a where + -- | Type of the pixel component, "classical" images + -- would have Word8 type as their PixelBaseComponent, + -- HDR image would have Float for instance + type PixelBaseComponent a :: * -- | Return the number of component of the pixel componentCount :: a -> Int + -- | Apply a function to all color component of a pixel. + colorMap :: (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a + -- | Calculate the index for the begining of the pixel pixelBaseIndex :: Image a -> Int -> Int -> Int pixelBaseIndex (Image { imageWidth = w }) x y = @@ -464,10 +398,6 @@ mutablePixelBaseIndex (MutableImage { mutableImageWidth = w }) x y = (x + y * w) * componentCount (undefined :: a) - -- | Return the constructor associated to the type, again - -- the value in the first parameter is not used, so you can use undefined - promotionType :: a -> PixelType - -- | Extract a pixel at a given position, (x, y), the origin -- is assumed to be at the corner top left, positive y to the -- bottom of the image @@ -479,11 +409,6 @@ -- | Write a pixel in a mutable image at position x y writePixel :: MutableImage s a -> Int -> Int -> a -> ST s () --- | Tell if you can convert between two pixel types, both arguments --- are unused. -canConvertTo :: (Pixel a, Pixel b) => a -> b -> Bool -canConvertTo a b = canPromoteTo a $ promotionType b - -- | Implement upcasting for pixel types -- Minimal declaration declaration `promotePixel` -- It is strongly recommanded to overload promoteImage to keep @@ -566,11 +491,23 @@ let (acc', px) = f acc x y writePixel mutImage x y px return acc') intialAcc [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]] - + frozen <- V.unsafeFreeze arr return (foldResult, frozen) +-- | Fold over the pixel of an image with a raster scan order : +-- from top to bottom, left to right +{-# INLINE pixelFold #-} +pixelFold :: (Pixel pixel) + => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc +pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) = + lineFold + where pixelFolder y acc x = f acc x y $ pixelAt img x y + columnFold lineAcc y = foldl' (pixelFolder y) lineAcc [0 .. w - 1] + lineFold = foldl' columnFold initialAccumulator [0 .. h - 1] + {-# INLINE pixelMap #-} +{-# RULES "pixelMap fusion" forall g f. pixelMap g . pixelMap f = pixelMap (g . f) #-} -- | `map` equivalent for an image, working at the pixel level. -- Little example : a brightness function for an rgb image -- @@ -580,31 +517,32 @@ -- > brightFunction (PixelRGB8 r g b) = -- > PixelRGB8 (up r) (up g) (up b) -- -pixelMap :: forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b +pixelMap :: forall a b. (Pixel a, Pixel b) + => (a -> b) -> Image a -> Image b pixelMap f image@(Image { imageWidth = w, imageHeight = h }) = - Image w h pixels - where pixels = runST $ do - newArr <- M.replicate (w * h * componentCount (undefined :: b)) 0 - let wrapped = MutableImage w h newArr - promotedPixel :: Int -> Int -> b - promotedPixel x y = f $ pixelAt image x y - sequence_ [writePixel wrapped x y $ promotedPixel x y - | y <- [0 .. h - 1], x <- [0 .. w - 1] ] - -- unsafeFreeze avoids making a second copy and it will be - -- safe because newArray can't be referenced as a mutable array - -- outside of this where block - V.unsafeFreeze newArr + Image w h pixels + where pixels = runST $ do + newArr <- M.replicate (w * h * componentCount (undefined :: b)) 0 + let wrapped = MutableImage w h newArr + promotedPixel :: Int -> Int -> b + promotedPixel x y = f $ pixelAt image x y + sequence_ [writePixel wrapped x y $ promotedPixel x y + | y <- [0 .. h - 1], x <- [0 .. w - 1] ] + -- unsafeFreeze avoids making a second copy and it will be + -- safe because newArray can't be referenced as a mutable array + -- outside of this where block + V.unsafeFreeze newArr -- | Helper class to help extract a luma plane out -- of an image or a pixel -class (Pixel a) => LumaPlaneExtractable a where +class (Pixel a, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where -- | Compute the luminance part of a pixel - computeLuma :: a -> Pixel8 + computeLuma :: a -> (PixelBaseComponent a) -- | Extract a luma plane out of an image. This -- method is in the typeclass to help performant -- implementation. - extractLumaPlane :: Image a -> Image Pixel8 + extractLumaPlane :: Image a -> Image (PixelBaseComponent a) extractLumaPlane = pixelMap computeLuma instance LumaPlaneExtractable Pixel8 where @@ -612,15 +550,25 @@ computeLuma = id extractLumaPlane = id +instance LumaPlaneExtractable PixelF where + {-# INLINE computeLuma #-} + computeLuma = id + extractLumaPlane = id + instance LumaPlaneExtractable PixelRGB8 where {-# INLINE computeLuma #-} - computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r + + computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r + 0.59 * toRational g + 0.11 * toRational b +instance LumaPlaneExtractable PixelRGBF where + {-# INLINE computeLuma #-} + computeLuma (PixelRGBF r g b) = + 0.3 * r + 0.59 * g + 0.11 * b + instance LumaPlaneExtractable PixelRGBA8 where {-# INLINE computeLuma #-} - computeLuma (PixelRGBA8 r g b _) = floor $ 0.3 * toRational r + + computeLuma (PixelRGBA8 r g b _) = floor $ 0.3 * toRational r + 0.59 * toRational g + 0.11 * toRational b @@ -654,21 +602,42 @@ ---- Pixel8 instances -------------------------------------------------- instance Pixel Pixel8 where - canPromoteTo _ a = a /= PixelMonochromatic - promotionType _ = PixelGreyscale + type PixelBaseComponent Pixel8 = Word8 + + {-# INLINE colorMap #-} + colorMap f = f + componentCount _ = 1 pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) readPixel image@(MutableImage { mutableImageData = arr }) x y = arr .!!!. mutablePixelBaseIndex image x y - + writePixel image@(MutableImage { mutableImageData = arr }) x y = arr .<-. mutablePixelBaseIndex image x y +instance Pixel PixelF where + type PixelBaseComponent PixelF = Float + + {-# INLINE colorMap #-} + colorMap f = f + componentCount _ = 1 + pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) + + readPixel image@(MutableImage { mutableImageData = arr }) x y = + arr .!!!. mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y = + arr .<-. mutablePixelBaseIndex image x y + instance ColorConvertible Pixel8 PixelYA8 where {-# INLINE promotePixel #-} promotePixel c = PixelYA8 c 255 +instance ColorConvertible Pixel8 PixelF where + {-# INLINE promotePixel #-} + promotePixel c = fromIntegral c / 255.0 + instance ColorConvertible Pixel8 PixelRGB8 where {-# INLINE promotePixel #-} promotePixel c = PixelRGB8 c c c @@ -677,12 +646,18 @@ {-# INLINE promotePixel #-} promotePixel c = PixelRGBA8 c c c 255 +instance ColorConvertible PixelF PixelRGBF where + {-# INLINE promotePixel #-} + promotePixel c = PixelRGBF c c c-- (c / 0.3) (c / 0.59) (c / 0.11) + -------------------------------------------------- ---- PixelYA8 instances -------------------------------------------------- instance Pixel PixelYA8 where - canPromoteTo _ a = a == PixelRedGreenBlueAlpha8 - promotionType _ = PixelGreyscaleAlpha + type PixelBaseComponent PixelYA8 = Word8 + + {-# INLINE colorMap #-} + colorMap f (PixelYA8 y a) = PixelYA8 (f y) (f a) componentCount _ = 2 pixelAt image@(Image { imageData = arr }) x y = PixelYA8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) @@ -693,7 +668,7 @@ av <- arr .!!!. (baseIdx + 1) return $ PixelYA8 yv av where baseIdx = mutablePixelBaseIndex image x y - + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA8 yv av) = do let baseIdx = mutablePixelBaseIndex image x y (arr .<-. (baseIdx + 0)) yv @@ -709,16 +684,44 @@ promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a -------------------------------------------------- +---- PixelRGBF instances +-------------------------------------------------- +instance Pixel PixelRGBF where + type PixelBaseComponent PixelRGBF = PixelF + + {-# INLINE colorMap #-} + colorMap f (PixelRGBF r g b) = PixelRGBF (f r) (f g) (f b) + + componentCount _ = 3 + + pixelAt image@(Image { imageData = arr }) x y = PixelRGBF (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + rv <- arr .!!!. baseIdx + gv <- arr .!!!. (baseIdx + 1) + bv <- arr .!!!. (baseIdx + 2) + return $ PixelRGBF rv gv bv + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBF rv gv bv) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) rv + (arr .<-. (baseIdx + 1)) gv + (arr .<-. (baseIdx + 2)) bv + +-------------------------------------------------- ---- PixelRGB8 instances -------------------------------------------------- instance Pixel PixelRGB8 where - canPromoteTo _ PixelMonochromatic = False - canPromoteTo _ PixelGreyscale = False - canPromoteTo _ _ = True + type PixelBaseComponent PixelRGB8 = Word8 - componentCount _ = 3 + {-# INLINE colorMap #-} + colorMap f (PixelRGB8 r g b) = PixelRGB8 (f r) (f g) (f b) - promotionType _ = PixelRedGreenBlue8 + componentCount _ = 3 pixelAt image@(Image { imageData = arr }) x y = PixelRGB8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) @@ -731,7 +734,7 @@ bv <- arr .!!!. (baseIdx + 2) return $ PixelRGB8 rv gv bv where baseIdx = mutablePixelBaseIndex image x y - + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB8 rv gv bv) = do let baseIdx = mutablePixelBaseIndex image x y (arr .<-. (baseIdx + 0)) rv @@ -742,14 +745,19 @@ {-# INLINE promotePixel #-} promotePixel (PixelRGB8 r g b) = PixelRGBA8 r g b 255 +instance ColorConvertible PixelRGB8 PixelRGBF where + {-# INLINE promotePixel #-} + promotePixel (PixelRGB8 r g b) = PixelRGBF (toF r) (toF g) (toF b) + where toF v = fromIntegral v / 255 + -------------------------------------------------- ---- PixelRGBA8 instances -------------------------------------------------- instance Pixel PixelRGBA8 where - canPromoteTo _ PixelRedGreenBlueAlpha8 = True - canPromoteTo _ _ = False + type PixelBaseComponent PixelRGBA8 = Word8 - promotionType _ = PixelRedGreenBlueAlpha8 + {-# INLINE colorMap #-} + colorMap f (PixelRGBA8 r g b a) = PixelRGBA8 (f r) (f g) (f b) (f a) componentCount _ = 4 @@ -766,7 +774,7 @@ av <- arr .!!!. (baseIdx + 3) return $ PixelRGBA8 rv gv bv av where baseIdx = mutablePixelBaseIndex image x y - + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA8 rv gv bv av) = do let baseIdx = mutablePixelBaseIndex image x y (arr .<-. (baseIdx + 0)) rv @@ -778,8 +786,10 @@ ---- PixelYCbCr8 instances -------------------------------------------------- instance Pixel PixelYCbCr8 where - canPromoteTo _ _ = False - promotionType _ = PixelYChromaRChromaB8 + type PixelBaseComponent PixelYCbCr8 = Word8 + + {-# INLINE colorMap #-} + colorMap f (PixelYCbCr8 y cb cr) = PixelYCbCr8 (f y) (f cb) (f cr) componentCount _ = 3 pixelAt image@(Image { imageData = arr }) x y = PixelYCbCr8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) @@ -792,7 +802,7 @@ crv <- arr .!!!. (baseIdx + 2) return $ PixelYCbCr8 yv cbv crv where baseIdx = mutablePixelBaseIndex image x y - + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCr8 yv cbv crv) = do let baseIdx = mutablePixelBaseIndex image x y (arr .<-. (baseIdx + 0)) yv @@ -834,4 +844,23 @@ r = cr * (2 - 2 * cred) + y b = cb * (2 - 2 * cblue) + y g = (y - cblue * b - cred * r) / cgreen + +-- | Perform a gamma correction for an image with HDR pixels. +gammaCorrection :: PixelF -- ^ Gamma value, should be between 0.5 and 3.0 + -> Image PixelRGBF -- ^ Image to treat. + -> Image PixelRGBF +gammaCorrection gammaVal = pixelMap gammaCorrector + where gammaExponent = 1.0 / gammaVal + fixVal v = v ** gammaExponent + gammaCorrector (PixelRGBF r g b) = + PixelRGBF (fixVal r) (fixVal g) (fixVal b) + +-- | Perform a tone mapping operation on an High dynamic range image. +toneMapping :: PixelF -- ^ Exposure parameter + -> Image PixelRGBF -- ^ Image to treat. + -> Image PixelRGBF +toneMapping exposure img = Image (imageWidth img) (imageHeight img) scaledData + where coeff = exposure * (exposure / maxBrightness + 1.0) / (exposure + 1.0); + maxBrightness = pixelFold (\luma _ _ px -> max luma $ computeLuma px) 0 img + scaledData = V.map (* coeff) $ imageData img
JuicyPixels.cabal view
@@ -1,37 +1,11 @@ Name: JuicyPixels -Version: 2.0.2 -Synopsis: Picture loading/serialization (in png, jpeg, bitmap and gif) +Version: 3.0 +Synopsis: Picture loading/serialization (in png, jpeg, bitmap, radiance and gif) Description: - This library can load and store images in PNG/Bitmap and Jpeg, and - read Gif images. - . - Version 2.0.2 changelog: - . - * Decoding of interleaved gif image, and delta coded gif animation. - . - * Bumping dependencies. - . - Version 2.0.1 changelog: - . - * Documentation enhancements. - . - * Fixing some huge gif file loading. - . - * Fixing performance problem of Bitmap and Jpeg savings. - . - Version 2.0 changelog: - . - * New extractComponent version with type safe plane - extraction - . - * Gif file reading - . - Version 1.3 changelog: - . - * Fix extractComponent function - . - * Adding saving for YA8 functions + <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>> . + This library can load and store images in PNG,Bitmap, Jpeg, Radiance and + read Gif images. homepage: https://github.com/Twinside/Juicy.Pixels License: BSD3 @@ -41,8 +15,6 @@ Category: Codec, Graphics Build-type: Simple --- Extra-source-files: - -- Constraint on the version of Cabal needed to build this package. Cabal-version: >= 1.10 @@ -53,7 +25,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v2.0.2 + Tag: v3.0 Library Default-Language: Haskell2010 @@ -62,6 +34,7 @@ Codec.Picture.Gif, Codec.Picture.Png, Codec.Picture.Jpg, + Codec.Picture.HDR, Codec.Picture.Saving, Codec.Picture.Types @@ -69,7 +42,7 @@ Build-depends: base >= 4 && < 5, bytestring >= 0.9 && < 0.11, mtl >= 1.1 && < 2.2, - cereal >= 0.3.3.0 && < 0.4, + binary >= 0.6.4.0 && < 0.7, zlib >= 0.5.3.1 && < 0.6, transformers >= 0.2.2 && < 0.4, vector >= 0.10 && < 0.11, @@ -84,5 +57,8 @@ Codec.Picture.Gif.LZW, Codec.Picture.Png.Export, Codec.Picture.Png.Type, - Codec.Picture.BitWriter + Codec.Picture.BitWriter, + Codec.Picture.InternalHelper + Install-Includes: Codec/Picture/ConvGraph.hs + Include-Dirs: Codec/Picture