JuicyPixels 3.1.5.2 → 3.1.6

raw patch · 6 files changed

+256/−37 lines, 6 filesdep ~primitivedep ~transformersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: primitive, transformers

API changes (from Hackage documentation)

Files

• JuicyPixels.cabal +5/−5
• changelog +8/−0
• src/Codec/Picture/Gif.hs +52/−14
• src/Codec/Picture/HDR.hs +8/−8
• src/Codec/Picture/Png.hs +12/−7
• src/Codec/Picture/Types.hs +171/−3

@@ -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:
     <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>>
@@ -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
 

@@ -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
 

@@ -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

@@ -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

@@ -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

@@ -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
+