diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.1.5.2 +Version: 3.1.6 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tiff and radiance) Description: <> @@ -13,7 +13,7 @@ Maintainer: vincent.berthoux@gmail.com Category: Codec, Graphics, Image Build-type: Simple - +Stability: Stable -- Constraint on the version of Cabal needed to build this package. Cabal-version: >= 1.10 @@ -27,7 +27,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.1.5.2 + Tag: v3.1.6 Flag Mmap Description: Enable the file loading via mmap (memory map) @@ -54,9 +54,9 @@ mtl >= 1.1 && < 2.3, binary >= 0.5 && < 0.8, zlib >= 0.5.3.1 && < 0.6, - transformers >= 0.2.2 && < 0.5, + transformers >= 0.4, vector >= 0.9 && < 0.11, - primitive >= 0.5 && < 0.6, + primitive >= 0.4 && < 0.6, deepseq >= 1.1 && < 1.4, containers >= 0.4.2 && < 0.6 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,13 @@ -*-change-log-*- +v3.1.6 August 2014 + * Fix bad disposal handling in GIF animations. + * Added ColorConvertible instance for PixelRGB8 -> PixelRGBA16 (KaiHa) + * Fixing a bad handling of tRNS causing bad transprency decoding in + some circonstances. + * Adding the concept of Packeable pixel for faster pixel filling + using mutable array. + v3.1.5.2 May 2014 * Bumping the transformers dependency diff --git a/src/Codec/Picture/Gif.hs b/src/Codec/Picture/Gif.hs --- a/src/Codec/Picture/Gif.hs +++ b/src/Codec/Picture/Gif.hs @@ -214,9 +214,31 @@ putSlices str = putWord8 (fromIntegral $ B.length str) >> putByteString str +data DisposalMethod + = DisposalAny + | DisposalDoNot + | DisposalRestoreBackground + | DisposalRestorePrevious + | DisposalUnknown Word8 +disposalMethodOfCode :: Word8 -> DisposalMethod +disposalMethodOfCode v = case v of + 0 -> DisposalAny + 1 -> DisposalDoNot + 2 -> DisposalRestoreBackground + 3 -> DisposalRestorePrevious + n -> DisposalUnknown n + +codeOfDisposalMethod :: DisposalMethod -> Word8 +codeOfDisposalMethod v = case v of + DisposalAny -> 0 + DisposalDoNot -> 1 + DisposalRestoreBackground -> 2 + DisposalRestorePrevious -> 3 + DisposalUnknown n -> n + data GraphicControlExtension = GraphicControlExtension - { gceDisposalMethod :: !Word8 -- ^ Stored on 3 bits + { gceDisposalMethod :: !DisposalMethod -- ^ Stored on 3 bits , gceUserInputFlag :: !Bool , gceTransparentFlag :: !Bool , gceDelay :: !Word16 @@ -228,8 +250,9 @@ putWord8 extensionIntroducer putWord8 graphicControlLabel putWord8 0x4 -- size - let disposalField = - (gceDisposalMethod v .&. 0x7) `unsafeShiftL` 2 + let disposalCode = codeOfDisposalMethod $ gceDisposalMethod v + disposalField = + (disposalCode .&. 0x7) `unsafeShiftL` 2 userInputField | gceUserInputFlag v = 0 `setBit` 1 @@ -257,7 +280,9 @@ idx <- getWord8 _blockTerminator <- getWord8 return GraphicControlExtension - { gceDisposalMethod = (packedFields `unsafeShiftR` 2) .&. 0x07 + { gceDisposalMethod = + disposalMethodOfCode $ + (packedFields `unsafeShiftR` 2) .&. 0x07 , gceUserInputFlag = packedFields `testBit` 1 , gceTransparentFlag = packedFields `testBit` 0 , gceDelay = delay @@ -501,18 +526,23 @@ 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 + , gifImages = (firstControl, firstImage) : rest } = map paletteApplyer $ + scanl generator initState rest + where initState = (paletteOf palette firstImage, firstControl, decodeImage firstImage) + globalWidth = fromIntegral $ screenWidth wholeDescriptor globalHeight = fromIntegral $ screenHeight wholeDescriptor - {-background = backgroundIndex wholeDescriptor-} + background = backgroundIndex wholeDescriptor + backgroundImage = generateImage (\_ _ -> background) globalWidth globalHeight - paletteApplyer (pal, img) = substituteColors pal img + 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 + generator (_, prevControl, img1) + (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = + (thisPalette, controlExt, thisImage) + where thisPalette = paletteOf palette img2 + thisImage = generateImage pixeler globalWidth globalHeight + localWidth = fromIntegral $ gDescImageWidth descriptor localHeight = fromIntegral $ gDescImageHeight descriptor left = fromIntegral $ gDescPixelsFromLeft descriptor @@ -530,10 +560,18 @@ then fromIntegral $ gceTransparentColorIndex ext else 300 + oldImage = case gceDisposalMethod <$> prevControl of + Nothing -> img1 + Just DisposalAny -> img1 + Just DisposalDoNot -> img1 + Just DisposalRestoreBackground -> backgroundImage + Just DisposalRestorePrevious -> img1 + Just (DisposalUnknown _) -> img1 + 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 + pixeler x y = pixelAt oldImage x y decodeFirstGifImage :: GifFile -> Either String (Image PixelRGB8) decodeFirstGifImage @@ -631,7 +669,7 @@ controlExtension 0 = Nothing controlExtension delay = Just GraphicControlExtension - { gceDisposalMethod = 0 + { gceDisposalMethod = DisposalAny , gceUserInputFlag = False , gceTransparentFlag = False , gceDelay = fromIntegral delay diff --git a/src/Codec/Picture/HDR.hs b/src/Codec/Picture/HDR.hs --- a/src/Codec/Picture/HDR.hs +++ b/src/Codec/Picture/HDR.hs @@ -9,7 +9,7 @@ import Control.Applicative( pure, (<$>), (<*>) ) import Control.Monad( when, foldM, foldM_, forM, forM_ ) import Control.Monad.Trans.Class( lift ) -import Control.Monad.Trans.Error( ErrorT, throwError, runErrorT ) +import Control.Monad.Trans.Except( ExceptT, throwE, runExceptT ) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as BC @@ -40,7 +40,7 @@ (.<-.) = M.write {-M.unsafeWrite-} -type HDRReader s a = ErrorT String (ST s) a +type HDRReader s a = ExceptT String (ST s) a data RGBE = RGBE !Word8 !Word8 !Word8 !Word8 @@ -144,9 +144,9 @@ -- * PixelRGBF -- decodeHDR :: B.ByteString -> Either String DynamicImage -decodeHDR str = runST $ runErrorT $ do +decodeHDR str = runST $ runExceptT $ do case runGet decodeHeader $ L.fromChunks [str] of - Left err -> throwError err + Left err -> throwE err Right rez -> ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage) @@ -214,7 +214,7 @@ -> HDRReader s Int newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3] where dataAt idx - | fromIntegral idx >= maxInput = throwError $ "Read index out of bound (" ++ show idx ++ ")" + | fromIntegral idx >= maxInput = throwE $ "Read index out of bound (" ++ show idx ++ ")" | otherwise = pure $ L.index inputData (fromIntegral idx) maxOutput = M.length scanline @@ -223,7 +223,7 @@ strideSet count destIndex _ | endIndex > maxOutput + stride = - throwError $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")" + throwE $ "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 @@ -233,7 +233,7 @@ strideCopy _ count destIndex - | writeEndBound > maxOutput + stride = throwError "Out of bound HDR scanline" + | writeEndBound > maxOutput + stride = throwE "Out of bound HDR scanline" where writeEndBound = destIndex + count * stride strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count where aux _ j 0 = pure j @@ -443,7 +443,7 @@ inner | isNewRunLengthMarker color = do let calcSize = checkLineLength color when (calcSize /= width) - (throwError "Invalid sanline size") + (throwE "Invalid sanline size") pure $ \idx -> newStyleRLE packedData (idx + 4) | otherwise = pure $ oldStyleRLE packedData f <- inner diff --git a/src/Codec/Picture/Png.hs b/src/Codec/Picture/Png.hs --- a/src/Codec/Picture/Png.hs +++ b/src/Codec/Picture/Png.hs @@ -407,12 +407,17 @@ pixels = concat [[r, g, b] | ipx <- V.toList img , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0] -applyPaletteWithTransparency :: PngPalette -> Word8 -> V.Vector Word8 -> V.Vector Word8 -applyPaletteWithTransparency pal transp img = V.fromListN ((initSize + 1) * 4) pixels +applyPaletteWithTransparency :: PngPalette -> Lb.ByteString -> V.Vector Word8 + -> V.Vector Word8 +applyPaletteWithTransparency pal transpBuffer img = V.fromListN ((initSize + 1) * 4) pixels where (_, initSize) = bounds img - pixels = concat [ if ipx == transp then [0, 0, 0, 0] else [r, g, b, 255] - | ipx <- V.toList img - , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0] + maxi = Lb.length transpBuffer + pixels = concat + [ [r, g, b, opacity] + | ipx <- V.toList img + , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0 + opacity | fromIntegral ipx < maxi = Lb.index transpBuffer $ fromIntegral ipx + | otherwise = 255] -- | Transform a raw png image to an image, without modifying the -- underlying pixel type. If the image is greyscale and < 8 bits, @@ -454,7 +459,7 @@ toImage _const1 const2 (Right a) = Right . const2 $ Image (fromIntegral w) (fromIntegral h) a - palette8 palette [(Lb.uncons -> Just (c,_))] (Left img) = + palette8 palette [c] (Left img) = Right . ImageRGBA8 . Image (fromIntegral w) (fromIntegral h) $ applyPaletteWithTransparency palette c img @@ -494,7 +499,7 @@ if Lb.length compressedImageData <= zlibHeaderSize then Left "Invalid data size" else let imgData = Z.decompress compressedImageData - parseableData = B.concat $ Lb.toChunks imgData + parseableData = B.concat $ Lb.toChunks imgData palette = case find (\c -> pLTESignature == chunkType c) $ chunks rawImg of Nothing -> Nothing Just p -> case parsePalette p of diff --git a/src/Codec/Picture/Types.hs b/src/Codec/Picture/Types.hs --- a/src/Codec/Picture/Types.hs +++ b/src/Codec/Picture/Types.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -- | Module providing the basic types for image manipulation in the library. -- Defining the types used to store all those _Juicy Pixels_ @@ -78,15 +79,22 @@ , extractComponent , unsafeExtractComponent + + -- * Packeable writing (unsafe but faster) + , PackeablePixel( .. ) + , fillImageWith + , unsafeWritePixelBetweenAt + , writePackedPixelAt ) where import Control.Monad( foldM, liftM, ap ) import Control.DeepSeq( NFData( .. ) ) import Control.Monad.ST( runST ) import Control.Monad.Primitive ( PrimMonad, PrimState ) +import Foreign.ForeignPtr( castForeignPtr ) import Foreign.Storable ( Storable ) -import Data.Bits( unsafeShiftL, unsafeShiftR ) -import Data.Word( Word8, Word16, Word32 ) +import Data.Bits( unsafeShiftL, unsafeShiftR, (.|.) ) +import Data.Word( Word8, Word16, Word32, Word64 ) import Data.List( foldl' ) import Data.Vector.Storable ( (!) ) import qualified Data.Vector.Storable as V @@ -796,7 +804,6 @@ -- pixelMap :: forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b -{-# RULES "pixelMap fusion" forall g f. pixelMap g . pixelMap f = pixelMap (g . f) #-} {-# SPECIALIZE INLINE pixelMap :: (PixelYCbCr8 -> PixelRGB8) -> Image PixelYCbCr8 -> Image PixelRGB8 #-} {-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelYCbCr8) -> Image PixelRGB8 -> Image PixelYCbCr8 #-} {-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGB8) -> Image PixelRGB8 -> Image PixelRGB8 #-} @@ -1466,6 +1473,14 @@ promotePixel (PixelRGB8 r g b) = PixelRGBF (toF r) (toF g) (toF b) where toF v = fromIntegral v / 255.0 +instance ColorConvertible PixelRGB8 PixelRGB16 where + {-# INLINE promotePixel #-} + promotePixel (PixelRGB8 r g b) = PixelRGB16 (promotePixel r) (promotePixel g) (promotePixel b) + +instance ColorConvertible PixelRGB8 PixelRGBA16 where + {-# INLINE promotePixel #-} + promotePixel (PixelRGB8 r g b) = PixelRGBA16 (promotePixel r) (promotePixel g) (promotePixel b) maxBound + instance ColorPlane PixelRGB8 PlaneRed where toComponentIndex _ _ = 0 @@ -1548,6 +1563,10 @@ >> M.unsafeWrite v (idx + 2) b >> M.unsafeWrite v (idx + 3) a +instance ColorConvertible PixelRGBA8 PixelRGBA16 where + {-# INLINE promotePixel #-} + promotePixel (PixelRGBA8 r g b a) = PixelRGBA16 (promotePixel r) (promotePixel g) (promotePixel b) (promotePixel a) + instance ColorPlane PixelRGBA8 PlaneRed where toComponentIndex _ _ = 0 @@ -2031,3 +2050,152 @@ 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 + +-------------------------------------------------- +---- Packable pixel +-------------------------------------------------- + +-- | This typeclass exist for performance reason, it allow +-- to pack a pixel value to a simpler "primitive" data +-- type to allow faster writing to moemory. +class PackeablePixel a where + -- | Primitive type asociated to the current pixel + -- It's Word32 for PixelRGBA8 for instance + type PackedRepresentation a + + -- | The packing function, allowing to transform + -- to a primitive. + packPixel :: a -> PackedRepresentation a + +instance PackeablePixel Pixel8 where + type PackedRepresentation Pixel8 = Pixel8 + packPixel = id + {-# INLINE packPixel #-} + +instance PackeablePixel Pixel16 where + type PackedRepresentation Pixel16 = Pixel16 + packPixel = id + {-# INLINE packPixel #-} + +instance PackeablePixel Pixel32 where + type PackedRepresentation Pixel32 = Pixel32 + packPixel = id + {-# INLINE packPixel #-} + +instance PackeablePixel PixelF where + type PackedRepresentation PixelF = PixelF + packPixel = id + {-# INLINE packPixel #-} + + +instance PackeablePixel PixelRGBA8 where + type PackedRepresentation PixelRGBA8 = Word32 + packPixel (PixelRGBA8 r g b a) = + (fi r `unsafeShiftL` (0 * bitCount)) .|. + (fi g `unsafeShiftL` (1 * bitCount)) .|. + (fi b `unsafeShiftL` (2 * bitCount)) .|. + (fi a `unsafeShiftL` (3 * bitCount)) + where fi = fromIntegral + bitCount = 8 + +instance PackeablePixel PixelRGBA16 where + type PackedRepresentation PixelRGBA16 = Word64 + packPixel (PixelRGBA16 r g b a) = + (fi r `unsafeShiftL` (0 * bitCount)) .|. + (fi g `unsafeShiftL` (1 * bitCount)) .|. + (fi b `unsafeShiftL` (2 * bitCount)) .|. + (fi a `unsafeShiftL` (3 * bitCount)) + where fi = fromIntegral + bitCount = 16 + +instance PackeablePixel PixelCMYK8 where + type PackedRepresentation PixelCMYK8 = Word32 + packPixel (PixelCMYK8 c m y k) = + (fi c `unsafeShiftL` (0 * bitCount)) .|. + (fi m `unsafeShiftL` (1 * bitCount)) .|. + (fi y `unsafeShiftL` (2 * bitCount)) .|. + (fi k `unsafeShiftL` (3 * bitCount)) + where fi = fromIntegral + bitCount = 8 + +instance PackeablePixel PixelCMYK16 where + type PackedRepresentation PixelCMYK16 = Word64 + packPixel (PixelCMYK16 c m y k) = + (fi c `unsafeShiftL` (0 * bitCount)) .|. + (fi m `unsafeShiftL` (1 * bitCount)) .|. + (fi y `unsafeShiftL` (2 * bitCount)) .|. + (fi k `unsafeShiftL` (3 * bitCount)) + where fi = fromIntegral + bitCount = 16 + +instance PackeablePixel PixelYA16 where + type PackedRepresentation PixelYA16 = Word32 + packPixel (PixelYA16 y a) = + (fi y `unsafeShiftL` (0 * bitCount)) .|. + (fi a `unsafeShiftL` (1 * bitCount)) + where fi = fromIntegral + bitCount = 16 + +instance PackeablePixel PixelYA8 where + type PackedRepresentation PixelYA8 = Word16 + packPixel (PixelYA8 y a) = + (fi y `unsafeShiftL` (0 * bitCount)) .|. + (fi a `unsafeShiftL` (1 * bitCount)) + where fi = fromIntegral + bitCount = 8 + +-- | This function will fill an image with a simple packeable +-- pixel. It will be faster than any unsafeWritePixel. +fillImageWith :: ( Pixel px, PackeablePixel px + , PrimMonad m + , M.Storable (PackedRepresentation px)) + => MutableImage (PrimState m) px -> px -> m () +fillImageWith img px = M.set converted $ packPixel px + where + (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img + !packedPtr = castForeignPtr ptr + !converted = + M.unsafeFromForeignPtr packedPtr s (s2 `div` componentCount px) + +-- | Fill a packeable pixel between two bounds. +unsafeWritePixelBetweenAt + :: ( PrimMonad m + , Pixel px, PackeablePixel px + , M.Storable (PackedRepresentation px)) + => MutableImage (PrimState m) px -- ^ Image to write into + -> px -- ^ Pixel to write + -> Int -- ^ Start index in pixel base component + -> Int -- ^ pixel count of pixel to write + -> m () +unsafeWritePixelBetweenAt img px start count = M.set converted packed + where + !packed = packPixel px + !pixelData = mutableImageData img + + !toSet = M.slice start count pixelData + (ptr, s, s2) = M.unsafeToForeignPtr toSet + !packedPtr = castForeignPtr ptr + !converted = + M.unsafeFromForeignPtr packedPtr s s2 + +-- | Write a packeable pixel into an image. equivalent to unsafeWritePixel. +writePackedPixelAt :: ( Pixel px, PackeablePixel px + , M.Storable (PackedRepresentation px) + , PrimMonad m + ) + => MutableImage (PrimState m) px -- ^ Image to write into + -> Int -- ^ Index in (PixelBaseComponent px) count + -> px -- ^ Pixel to write + -> m () +{-# INLINE writePackedPixelAt #-} +writePackedPixelAt img idx px = + M.unsafeWrite converted (idx `div` compCount) packed + where + !packed = packPixel px + !compCount = componentCount px + + (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img + !packedPtr = castForeignPtr ptr + !converted = + M.unsafeFromForeignPtr packedPtr s s2 +