Hello community, here is the log from the commit of package ghc-JuicyPixels for openSUSE:Factory checked in at 2016-01-28 17:23:56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-JuicyPixels (Old) and /work/SRC/openSUSE:Factory/.ghc-JuicyPixels.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-JuicyPixels" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-JuicyPixels/ghc-JuicyPixels.changes 2015-12-09 22:16:50.000000000 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-JuicyPixels.new/ghc-JuicyPixels.changes 2016-01-28 17:24:47.000000000 +0100 @@ -1,0 +2,11 @@ +Tue Jan 26 09:39:22 UTC 2016 - [email protected] + +- update to 3.2.7 +* Addition: convertRGB8 and convertRGBA8 helper functions +* Addition: new output colorspace for JPEG format: Y, RGB & CMYK +* Addition: RGBA8 bitmap reading (thanks to mtolly) +* Enhancement: Optimized JPG & Tiff reading (thanks to Calvin Beck) +* Enhancement: INLINE SPECIALIZE for pixelMap (Pixel8 -> Pixel8) (thx to Calvin Beck) +* Fix: GHC 8.0 compilation (thanks to phadej) + +------------------------------------------------------------------- Old: ---- JuicyPixels-3.2.6.4.tar.gz New: ---- JuicyPixels-3.2.7.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-JuicyPixels.spec ++++++ --- /var/tmp/diff_new_pack.bDE1ez/_old 2016-01-28 17:24:49.000000000 +0100 +++ /var/tmp/diff_new_pack.bDE1ez/_new 2016-01-28 17:24:49.000000000 +0100 @@ -20,7 +20,7 @@ # no useful debuginfo for Haskell packages without C sources %global debug_package %{nil} Name: ghc-JuicyPixels -Version: 3.2.6.4 +Version: 3.2.7 Release: 0 Summary: Picture loading/serialization License: BSD-3-Clause ++++++ JuicyPixels-3.2.6.4.tar.gz -> JuicyPixels-3.2.7.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/JuicyPixels.cabal new/JuicyPixels-3.2.7/JuicyPixels.cabal --- old/JuicyPixels-3.2.6.4/JuicyPixels.cabal 2015-12-02 22:38:14.000000000 +0100 +++ new/JuicyPixels-3.2.7/JuicyPixels.cabal 2016-01-25 23:33:57.000000000 +0100 @@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.2.6.4 +Version: 3.2.7 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description: <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>> @@ -28,7 +28,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.2.6.4 + Tag: v3.2.7 Flag Mmap Description: Enable the file loading via mmap (memory map) @@ -52,11 +52,10 @@ Codec.Picture.ColorQuant Ghc-options: -O3 -Wall - Ghc-prof-options: -rtsopts -Wall -prof -auto-all Build-depends: base >= 4.5 && < 5, bytestring >= 0.9 && < 0.11, mtl >= 1.1 && < 2.3, - binary >= 0.5 && < 0.8, + binary >= 0.5 && < 0.9, zlib >= 0.5.3.1 && < 0.7, transformers >= 0.2, vector >= 0.9 && < 0.12, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/README.md new/JuicyPixels-3.2.7/README.md --- old/JuicyPixels-3.2.6.4/README.md 2015-12-02 22:38:14.000000000 +0100 +++ new/JuicyPixels-3.2.7/README.md 2016-01-25 23:33:57.000000000 +0100 @@ -52,6 +52,7 @@ - Bitmap (.bmp) (mainly used as a debug output format) * Reading + - 32bits (RGBA) images - 24bits (RGB) images - 8bits (greyscale & paletted) images @@ -62,10 +63,12 @@ * Metadata (reading/writing): DPI information - - Jpeg (.jpg, .jpeg) + - Jpeg (.jpg, .jpeg) * Reading normal and interlaced baseline DCT image - YCbCr (default) CMYK/YCbCrK/RGB colorspaces + * Writing non-interlaced JPG + - YCbCr (favored), Y, RGB & CMYK colorspaces * Metadata: - Reading and writing DpiX & DpiY from JFIF header. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/changelog new/JuicyPixels-3.2.7/changelog --- old/JuicyPixels-3.2.6.4/changelog 2015-12-02 22:38:14.000000000 +0100 +++ new/JuicyPixels-3.2.7/changelog 2016-01-25 23:33:57.000000000 +0100 @@ -1,7 +1,20 @@ Change log ========== -v3.2.6.3 December 2015 +v3.2.7 January 2016 +------------------- + * Addition: convertRGB8 and convertRGBA8 helper functions + * Addition: new output colorspace for JPEG format: Y, RGB & CMYK + * Addition: RGBA8 bitmap reading (thanks to mtolly) + * Enhancement: Optimized JPG & Tiff reading (thanks to Calvin Beck) + * Enhancement: INLINE SPECIALIZE for pixelMap (Pixel8 -> Pixel8) (thx to Calvin Beck) + * Fix: GHC 8.0 compilation (thanks to phadej) + +v3.2.6.5 December 2015 +---------------------- + * Fix: Compilation on GHC 7.6/7.8 + +v3.2.6.4 December 2015 ---------------------- * Fix: previous broken bugfix. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/BitWriter.hs new/JuicyPixels-3.2.7/src/Codec/Picture/BitWriter.hs --- old/JuicyPixels-3.2.6.4/src/Codec/Picture/BitWriter.hs 2015-12-02 22:38:14.000000000 +0100 +++ new/JuicyPixels-3.2.7/src/Codec/Picture/BitWriter.hs 2016-01-25 23:33:57.000000000 +0100 @@ -1,4 +1,5 @@ {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -- | This module implement helper functions to read & write data -- at bits level. @@ -9,7 +10,9 @@ , getNextBitsLSBFirst , getNextBitsMSBFirst , getNextBitJpg + , getNextIntJpg , setDecodedString + , setDecodedStringMSB , setDecodedStringJpg , runBoolReader @@ -33,6 +36,7 @@ import Control.Monad( when ) import Control.Monad.ST( ST ) import qualified Control.Monad.Trans.State.Strict as S +import Data.Int ( Int32 ) import Data.Word( Word8, Word32 ) import Data.Bits( (.&.), (.|.), unsafeShiftR, unsafeShiftL ) @@ -42,6 +46,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L + -------------------------------------------------- ---- Reader -------------------------------------------------- @@ -93,8 +98,8 @@ BoolState idx _ chain <- S.get when (idx /= 7) (setDecodedStringJpg chain) -{-# INLINE getNextBitJpg #-} getNextBitJpg :: BoolReader s Bool +{-# INLINE getNextBitJpg #-} getNextBitJpg = do BoolState idx v chain <- S.get let val = (v .&. (1 `unsafeShiftL` idx)) /= 0 @@ -103,25 +108,51 @@ else S.put $ BoolState (idx - 1) v chain return val -{-# INLINE getNextBitMSB #-} -getNextBitMSB :: BoolReader s Bool -getNextBitMSB = do +getNextIntJpg :: Int -> BoolReader s Int32 +{-# INLINE getNextIntJpg #-} +getNextIntJpg = go 0 where + go !acc !0 = return acc + go !acc !n = do BoolState idx v chain <- S.get - let val = (v .&. (1 `unsafeShiftL` (7 - idx))) /= 0 - if idx == 7 - then setDecodedString chain - else S.put $ BoolState (idx + 1) v chain - return val + let !leftBits = 1 + fromIntegral idx + if n >= leftBits then do + setDecodedStringJpg chain + let !remaining = n - leftBits + !mask = (1 `unsafeShiftL` leftBits) - 1 + !finalV = fromIntegral v .&. mask + !theseBits = finalV `unsafeShiftL` remaining + go (acc .|. theseBits) remaining + else do + let !remaining = leftBits - n + !mask = (1 `unsafeShiftL` n) - 1 + !finalV = fromIntegral v `unsafeShiftR` remaining + S.put $ BoolState (fromIntegral remaining - 1) v chain + return $ (finalV .&. mask) .|. acc + + +setDecodedStringMSB :: B.ByteString -> BoolReader s () +setDecodedStringMSB str = case B.uncons str of + Nothing -> S.put $ BoolState 8 0 B.empty + Just (v, rest) -> S.put $ BoolState 8 v rest + {-# INLINE getNextBitsMSBFirst #-} getNextBitsMSBFirst :: Int -> BoolReader s Word32 -getNextBitsMSBFirst = aux 0 - where aux acc 0 = return acc - aux acc n = do - bit <- getNextBitMSB - let nextVal | bit = (acc `unsafeShiftL` 1) .|. 1 - | otherwise = acc `unsafeShiftL` 1 - aux nextVal (n - 1) +getNextBitsMSBFirst requested = go 0 requested where + go :: Word32 -> Int -> BoolReader s Word32 + go !acc !0 = return acc + go !acc !n = do + BoolState idx v chain <- S.get + let !leftBits = fromIntegral idx + if n >= leftBits then do + setDecodedStringMSB chain + let !theseBits = fromIntegral v `unsafeShiftL` (n - leftBits) + go (acc .|. theseBits) (n - leftBits) + else do + let !remaining = leftBits - n + !mask = (1 `unsafeShiftL` remaining) - 1 + S.put $ BoolState (fromIntegral remaining) (v .&. mask) chain + return $ (fromIntegral v `unsafeShiftR` remaining) .|. acc {-# INLINE getNextBitsLSBFirst #-} getNextBitsLSBFirst :: Int -> BoolReader s Word32 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Bitmap.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Bitmap.hs --- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Bitmap.hs 2015-12-02 22:38:14.000000000 +0100 +++ new/JuicyPixels-3.2.7/src/Codec/Picture/Bitmap.hs 2016-01-25 23:33:56.000000000 +0100 @@ -41,6 +41,7 @@ , getWord8 , getWord16le , getWord32le + , getWord32be , bytesRead , skip ) @@ -253,6 +254,34 @@ inner 0 0 initialIndex VS.unsafeFreeze buff +decodeImageRGBA8 :: BmpInfoHeader -> (Int, Int, Int, Int) -> B.ByteString -> Image PixelRGBA8 +decodeImageRGBA8 (BmpInfoHeader { width = w, height = h }) (posR, posG, posB, posA) str = Image wi hi stArray where + wi = fromIntegral w + hi = abs $ fromIntegral h + stArray = runST $ do + arr <- M.new (fromIntegral $ w * abs h * 4) + if h > 0 then + foldM_ (readLine arr) 0 [0 .. hi - 1] + else + foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0] + VS.unsafeFreeze arr + + stride = linePadding 32 wi -- will be 0 + + readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int + readLine arr readIndex line = inner readIndex writeIndex where + lastIndex = wi * (hi - 1 - line + 1) * 4 + writeIndex = wi * (hi - 1 - line) * 4 + + inner readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + stride + inner readIdx writeIdx = do + -- 32-bit BMP pixels are BGRA + (arr `M.unsafeWrite` writeIdx ) (str `B.index` (readIdx + posR)) + (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + posG)) + (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index` (readIdx + posB)) + (arr `M.unsafeWrite` (writeIdx + 3)) (str `B.index` (readIdx + posA)) + inner (readIdx + 4) (writeIdx + 4) + decodeImageRGB8 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8 decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray where wi = fromIntegral w @@ -322,6 +351,8 @@ -- | Try to decode a bitmap image. -- Right now this function can output the following pixel types : -- +-- * PixelRGBA8 +-- -- * PixelRGB8 -- -- * Pixel8 @@ -349,27 +380,49 @@ paletteColorCount | colorCount bmpHeader == 0 = 2 ^ bpp | otherwise = fromIntegral $ colorCount bmpHeader + getData = do + readed' <- bytesRead + skip . fromIntegral $ dataOffset hdr - fromIntegral readed' + getRemainingBytes + addMetadata i = (i, metadataOfHeader bmpHeader) - table <- if bpp > 8 - then return V.empty - else V.replicateM paletteColorCount pixelGet - - readed' <- bytesRead - - skip . fromIntegral $ dataOffset hdr - fromIntegral readed' - rest <- getRemainingBytes - let addMetadata i = (i, metadataOfHeader bmpHeader) case (bitPerPixel bmpHeader, planes bmpHeader, bitmapCompression bmpHeader) of - -- (32, 1, 0) -> {- ImageRGBA8 <$>-} fail "Meuh" - (24, 1, 0) -> return . addMetadata . ImageRGB8 $ decodeImageRGB8 bmpHeader rest - ( 8, 1, 0) -> - let indexer v = table V.! fromIntegral v in - return . addMetadata . ImageRGB8 . pixelMap indexer $ decodeImageY8 bmpHeader rest + (32, 1, 0) -> do + rest <- getData + return . addMetadata . ImageRGBA8 $ decodeImageRGBA8 bmpHeader (2, 1, 0, 3) rest + -- (2, 1, 0, 3) means BGRA pixel order + (32, 1, 3) -> do + posRed <- getBitfield + posGreen <- getBitfield + posBlue <- getBitfield + posAlpha <- getBitfield + rest <- getData + return . addMetadata . ImageRGBA8 $ + decodeImageRGBA8 bmpHeader (posRed, posGreen, posBlue, posAlpha) rest + (24, 1, 0) -> do + rest <- getData + return . addMetadata . ImageRGB8 $ decodeImageRGB8 bmpHeader rest + ( 8, 1, 0) -> do + table <- V.replicateM paletteColorCount pixelGet + rest <- getData + let indexer v = table V.! fromIntegral v + return . addMetadata . ImageRGB8 . pixelMap indexer $ decodeImageY8 bmpHeader rest a -> fail $ "Can't handle BMP file " ++ show a +getBitfield :: Get Int +getBitfield = do + w32 <- getWord32be + case w32 of + 0xFF000000 -> return 0 + 0x00FF0000 -> return 1 + 0x0000FF00 -> return 2 + 0x000000FF -> return 3 + _ -> fail $ + "Codec.Picture.Bitmap.getBitfield: unsupported bitfield of " ++ show w32 + -- | Write an image in a file use the bitmap format. writeBitmap :: (BmpEncodable pixel) => FilePath -> Image pixel -> IO () diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Gif/LZW.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Gif/LZW.hs --- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Gif/LZW.hs 2015-12-02 22:38:14.000000000 +0100 +++ new/JuicyPixels-3.2.7/src/Codec/Picture/Gif/LZW.hs 2016-01-25 23:33:57.000000000 +0100 @@ -1,191 +1,194 @@ -{-# LANGUAGE CPP #-} -module Codec.Picture.Gif.LZW( decodeLzw, decodeLzwTiff ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>) ) -#endif - -import Data.Word( Word8 ) -import Control.Monad( when, unless ) - -import Data.Bits( (.&.) ) - -import Control.Monad.ST( ST ) -import Control.Monad.Trans.Class( MonadTrans, lift ) - -import Foreign.Storable ( Storable ) - -import qualified Data.ByteString as B -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.BitWriter - -{-# INLINE (.!!!.) #-} -(.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a -(.!!!.) = M.unsafeRead - {-M.read-} - -{-# INLINE (..!!!..) #-} -(..!!!..) :: (MonadTrans t, Storable a) - => M.STVector s a -> Int -> t (ST s) a -(..!!!..) v idx = lift $ v .!!!. idx - -{-# INLINE (.<-.) #-} -(.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s () -(.<-.) = M.unsafeWrite - {-M.write-} - -{-# INLINE (..<-..) #-} -(..<-..) :: (MonadTrans t, Storable a) - => M.STVector s a -> Int -> a -> t (ST s) () -(..<-..) v idx = lift . (v .<-. idx) - - -duplicateData :: (Show a, MonadTrans t, Storable a) - => M.STVector s a -> M.STVector s a - -> Int -> Int -> Int -> t (ST s) () -duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex - where endIndex = sourceIndex + size - aux i _ | i == endIndex = return () - aux i j = do - src .!!!. i >>= (dest .<-. j) - aux (i + 1) (j + 1) - -rangeSetter :: (Storable a, Num a) - => Int -> M.STVector s a - -> ST s (M.STVector s a) -rangeSetter count vec = aux 0 - where aux n | n == count = return vec - aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1) - -decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8 - -> BoolReader s () -decodeLzw str maxBitKey initialKey outVec = do - setDecodedString str - lzw GifVariant maxBitKey initialKey 0 outVec - -isOldTiffLZW :: B.ByteString -> Bool -isOldTiffLZW str = firstByte == 0 && secondByte == 1 - where firstByte = str `B.index` 0 - secondByte = (str `B.index` 1) .&. 1 - -decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int - -> BoolReader s() -decodeLzwTiff str outVec initialWriteIdx = do - setDecodedString str - let variant | isOldTiffLZW str = OldTiffVariant - | otherwise = TiffVariant - lzw variant 12 9 initialWriteIdx outVec - -data TiffVariant = - GifVariant - | TiffVariant - | OldTiffVariant - deriving Eq - --- | Gif image constraint from spec-gif89a, code size max : 12 bits. -lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8 - -> BoolReader s () -lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do - -- Allocate buffer of maximum size. - lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray - lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray - lzwSizeTable <- lift $ M.replicate tableEntryCount 0 - lift $ lzwSizeTable `M.set` 1 - - let firstVal code = do - dataOffset <- lzwOffsetTable ..!!!.. code - lzwData ..!!!.. dataOffset - - writeString at code = do - dataOffset <- lzwOffsetTable ..!!!.. code - dataSize <- lzwSizeTable ..!!!.. code - - when (at + dataSize <= maxWrite) $ - duplicateData lzwData outVec dataOffset dataSize at - - return dataSize - - addString pos at code val = do - dataOffset <- lzwOffsetTable ..!!!.. code - dataSize <- lzwSizeTable ..!!!.. code - - when (pos < tableEntryCount) $ do - (lzwOffsetTable ..<-.. pos) at - (lzwSizeTable ..<-.. pos) $ dataSize + 1 - - when (at + dataSize + 1 <= maxDataSize) $ do - duplicateData lzwData lzwData dataOffset dataSize at - (lzwData ..<-.. (at + dataSize)) val - - return $ dataSize + 1 - - maxWrite = M.length outVec - loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code - | outWriteIdx >= maxWrite = return () - | code == endOfInfo = return () - | code == clearCode = do - toOutput <- getNextCode startCodeSize - unless (toOutput == endOfInfo) $ do - dataSize <- writeString outWriteIdx toOutput - getNextCode startCodeSize >>= - loop (outWriteIdx + dataSize) - firstFreeIndex firstFreeIndex startCodeSize toOutput - - | otherwise = do - (written, dicAdd) <- - if code >= writeIdx then do - c <- firstVal oldCode - wroteSize <- writeString outWriteIdx oldCode - (outVec ..<-.. (outWriteIdx + wroteSize)) c - addedSize <- addString writeIdx dicWriteIdx oldCode c - return (wroteSize + 1, addedSize) - else do - wroteSize <- writeString outWriteIdx code - c <- firstVal code - addedSize <- addString writeIdx dicWriteIdx oldCode c - return (wroteSize, addedSize) - - let new_code_size = updateCodeSize codeSize $ writeIdx + 1 - getNextCode new_code_size >>= - loop (outWriteIdx + written) - (writeIdx + 1) - (dicWriteIdx + dicAdd) - new_code_size - code - - getNextCode startCodeSize >>= - loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0 - - where tableEntryCount = 2 ^ min 12 nMaxBitKeySize - maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1 - - isNewTiff = variant == TiffVariant - (switchOffset, isTiffVariant) = case variant of - GifVariant -> (0, False) - TiffVariant -> (1, True) - OldTiffVariant -> (0, True) - - initialElementCount = 2 ^ initialKeySize :: Int - clearCode | isTiffVariant = 256 - | otherwise = initialElementCount - - endOfInfo | isTiffVariant = 257 - | otherwise = clearCode + 1 - - startCodeSize - | isTiffVariant = initialKeySize - | otherwise = initialKeySize + 1 - - firstFreeIndex = endOfInfo + 1 - - resetArray a = lift $ rangeSetter initialElementCount a - - updateCodeSize codeSize writeIdx - | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1 - | otherwise = codeSize - - getNextCode s - | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s - | otherwise = fromIntegral <$> getNextBitsLSBFirst s - +{-# LANGUAGE CPP #-} +module Codec.Picture.Gif.LZW( decodeLzw, decodeLzwTiff ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +#endif + +import Data.Word( Word8 ) +import Control.Monad( when, unless ) + +import Data.Bits( (.&.) ) + +import Control.Monad.ST( ST ) +import Control.Monad.Trans.Class( MonadTrans, lift ) + +import Foreign.Storable ( Storable ) + +import qualified Data.ByteString as B +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.BitWriter + +{-# INLINE (.!!!.) #-} +(.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a +(.!!!.) = M.unsafeRead + {-M.read-} + +{-# INLINE (..!!!..) #-} +(..!!!..) :: (MonadTrans t, Storable a) + => M.STVector s a -> Int -> t (ST s) a +(..!!!..) v idx = lift $ v .!!!. idx + +{-# INLINE (.<-.) #-} +(.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s () +(.<-.) = M.unsafeWrite + {-M.write-} + +{-# INLINE (..<-..) #-} +(..<-..) :: (MonadTrans t, Storable a) + => M.STVector s a -> Int -> a -> t (ST s) () +(..<-..) v idx = lift . (v .<-. idx) + + +duplicateData :: (Show a, MonadTrans t, Storable a) + => M.STVector s a -> M.STVector s a + -> Int -> Int -> Int -> t (ST s) () +duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex + where endIndex = sourceIndex + size + aux i _ | i == endIndex = return () + aux i j = do + src .!!!. i >>= (dest .<-. j) + aux (i + 1) (j + 1) + +rangeSetter :: (Storable a, Num a) + => Int -> M.STVector s a + -> ST s (M.STVector s a) +rangeSetter count vec = aux 0 + where aux n | n == count = return vec + aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1) + +decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8 + -> BoolReader s () +decodeLzw str maxBitKey initialKey outVec = do + setDecodedString str + lzw GifVariant maxBitKey initialKey 0 outVec + +isOldTiffLZW :: B.ByteString -> Bool +isOldTiffLZW str = firstByte == 0 && secondByte == 1 + where firstByte = str `B.index` 0 + secondByte = (str `B.index` 1) .&. 1 + +decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int + -> BoolReader s() +decodeLzwTiff str outVec initialWriteIdx = do + if isOldTiffLZW str then + setDecodedString str + else + setDecodedStringMSB str + let variant | isOldTiffLZW str = OldTiffVariant + | otherwise = TiffVariant + lzw variant 12 9 initialWriteIdx outVec + +data TiffVariant = + GifVariant + | TiffVariant + | OldTiffVariant + deriving Eq + +-- | Gif image constraint from spec-gif89a, code size max : 12 bits. +lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8 + -> BoolReader s () +lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do + -- Allocate buffer of maximum size. + lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray + lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray + lzwSizeTable <- lift $ M.replicate tableEntryCount 0 + lift $ lzwSizeTable `M.set` 1 + + let firstVal code = do + dataOffset <- lzwOffsetTable ..!!!.. code + lzwData ..!!!.. dataOffset + + writeString at code = do + dataOffset <- lzwOffsetTable ..!!!.. code + dataSize <- lzwSizeTable ..!!!.. code + + when (at + dataSize <= maxWrite) $ + duplicateData lzwData outVec dataOffset dataSize at + + return dataSize + + addString pos at code val = do + dataOffset <- lzwOffsetTable ..!!!.. code + dataSize <- lzwSizeTable ..!!!.. code + + when (pos < tableEntryCount) $ do + (lzwOffsetTable ..<-.. pos) at + (lzwSizeTable ..<-.. pos) $ dataSize + 1 + + when (at + dataSize + 1 <= maxDataSize) $ do + duplicateData lzwData lzwData dataOffset dataSize at + (lzwData ..<-.. (at + dataSize)) val + + return $ dataSize + 1 + + maxWrite = M.length outVec + loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code + | outWriteIdx >= maxWrite = return () + | code == endOfInfo = return () + | code == clearCode = do + toOutput <- getNextCode startCodeSize + unless (toOutput == endOfInfo) $ do + dataSize <- writeString outWriteIdx toOutput + getNextCode startCodeSize >>= + loop (outWriteIdx + dataSize) + firstFreeIndex firstFreeIndex startCodeSize toOutput + + | otherwise = do + (written, dicAdd) <- + if code >= writeIdx then do + c <- firstVal oldCode + wroteSize <- writeString outWriteIdx oldCode + (outVec ..<-.. (outWriteIdx + wroteSize)) c + addedSize <- addString writeIdx dicWriteIdx oldCode c + return (wroteSize + 1, addedSize) + else do + wroteSize <- writeString outWriteIdx code + c <- firstVal code + addedSize <- addString writeIdx dicWriteIdx oldCode c + return (wroteSize, addedSize) + + let new_code_size = updateCodeSize codeSize $ writeIdx + 1 + getNextCode new_code_size >>= + loop (outWriteIdx + written) + (writeIdx + 1) + (dicWriteIdx + dicAdd) + new_code_size + code + + getNextCode startCodeSize >>= + loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0 + + where tableEntryCount = 2 ^ min 12 nMaxBitKeySize + maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1 + + isNewTiff = variant == TiffVariant + (switchOffset, isTiffVariant) = case variant of + GifVariant -> (0, False) + TiffVariant -> (1, True) + OldTiffVariant -> (0, True) + + initialElementCount = 2 ^ initialKeySize :: Int + clearCode | isTiffVariant = 256 + | otherwise = initialElementCount + + endOfInfo | isTiffVariant = 257 + | otherwise = clearCode + 1 + + startCodeSize + | isTiffVariant = initialKeySize + | otherwise = initialKeySize + 1 + + firstFreeIndex = endOfInfo + 1 + + resetArray a = lift $ rangeSetter initialElementCount a + + updateCodeSize codeSize writeIdx + | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1 + | otherwise = codeSize + + getNextCode s + | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s + | otherwise = fromIntegral <$> getNextBitsLSBFirst s + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Jpg/Common.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Jpg/Common.hs --- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Jpg/Common.hs 2015-12-02 22:38:14.000000000 +0100 +++ new/JuicyPixels-3.2.7/src/Codec/Picture/Jpg/Common.hs 2016-01-25 23:33:57.000000000 +0100 @@ -23,11 +23,10 @@ import Control.Applicative( pure, (<$>) ) #endif -import Control.Monad( replicateM, when ) +import Control.Monad( when ) import Control.Monad.ST( ST, runST ) import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) ) import Data.Int( Int16, Int32 ) -import Data.List( foldl' ) import Data.Maybe( fromMaybe ) import Data.Word( Word8 ) import qualified Data.Vector.Storable as VS @@ -174,8 +173,7 @@ -- | Unpack an int of the given size encoded from MSB to LSB. unpackInt :: Int -> BoolReader s Int32 -unpackInt bitCount = packInt <$> replicateM bitCount getNextBitJpg - +unpackInt = getNextIntJpg {-# INLINE rasterMap #-} rasterMap :: (Monad m) @@ -187,11 +185,6 @@ where columner x | x >= width = liner (y + 1) columner x = f x y >> columner (x + 1) -packInt :: [Bool] -> Int32 -packInt = foldl' bitStep 0 - where bitStep acc True = (acc `unsafeShiftL` 1) + 1 - bitStep acc False = acc `unsafeShiftL` 1 - pixelClamp :: Int16 -> Word8 pixelClamp n = fromIntegral . min 255 $ max 0 n diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Jpg/Types.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Jpg/Types.hs --- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Jpg/Types.hs 2015-12-02 22:38:14.000000000 +0100 +++ new/JuicyPixels-3.2.7/src/Codec/Picture/Jpg/Types.hs 2016-01-25 23:33:57.000000000 +0100 @@ -427,7 +427,8 @@ getByteString (fromIntegral size - 2) putFrame :: JpgFrame -> Put -putFrame (JpgAdobeAPP14 _adobe) = return () +putFrame (JpgAdobeAPP14 adobe) = + put (JpgAppSegment 14) >> putWord16be 14 >> put adobe putFrame (JpgJFIF jfif) = put (JpgAppSegment 0) >> putWord16be (14+2) >> put jfif putFrame (JpgExif _exif) = diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Jpg.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Jpg.hs --- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Jpg.hs 2015-12-02 22:38:14.000000000 +0100 +++ new/JuicyPixels-3.2.7/src/Codec/Picture/Jpg.hs 2016-01-25 23:33:56.000000000 +0100 @@ -11,7 +11,9 @@ , decodeJpegWithMetadata , encodeJpegAtQuality , encodeJpegAtQualityWithMetadata + , encodeDirectJpegAtQualityWithMetadata , encodeJpeg + , JpgEncodable ) where #if !MIN_VERSION_base(4,8,0) @@ -546,6 +548,8 @@ -- -- * PixelRGB8 -- +-- * PixelCMYK8 +-- -- * PixelYCbCr8 -- decodeJpeg :: B.ByteString -> Either String DynamicImage @@ -623,7 +627,8 @@ frozen <- unsafeFreezeImage fImg return (st, imageData frozen) -extractBlock :: Image PixelYCbCr8 -- ^ Source image +extractBlock :: forall s px. (PixelBaseComponent px ~ Word8) + => Image px -- ^ Source image -> MutableMacroBlock s Int16 -- ^ Mutable block where to put extracted block -> Int -- ^ Plane -> Int -- ^ X sampling factor @@ -741,6 +746,22 @@ , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable ] +lumaQuantTableAtQuality :: Int -> QuantificationTable +lumaQuantTableAtQuality qual = scaleQuantisationMatrix qual defaultLumaQuantizationTable + +chromaQuantTableAtQuality :: Int -> QuantificationTable +chromaQuantTableAtQuality qual = + scaleQuantisationMatrix qual defaultChromaQuantizationTable + +zigzaggedQuantificationSpec :: Int -> [JpgQuantTableSpec] +zigzaggedQuantificationSpec qual = + [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0, quantTable = luma } + , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1, quantTable = chroma } + ] + where + luma = zigZagReorderForwardv $ lumaQuantTableAtQuality qual + chroma = zigZagReorderForwardv $ chromaQuantTableAtQuality qual + -- | Function to call to encode an image to jpeg. -- The quality factor should be between 0 and 100 (100 being -- the best quality). @@ -749,6 +770,203 @@ -> L.ByteString -- ^ Encoded JPEG encodeJpegAtQuality quality = encodeJpegAtQualityWithMetadata quality mempty +-- | Record gathering all information to encode a component +-- from the source image. Previously was a huge tuple +-- burried in the code +data EncoderState = EncoderState + { _encComponentIndex :: !Int + , _encBlockWidth :: !Int + , _encBlockHeight :: !Int + , _encQuantTable :: !QuantificationTable + , _encDcHuffman :: !HuffmanWriterCode + , _encAcHuffman :: !HuffmanWriterCode + } + + +-- | Helper type class describing all JPG-encodable pixel types +class (Pixel px, PixelBaseComponent px ~ Word8) => JpgEncodable px where + additionalBlocks :: Image px -> [JpgFrame] + additionalBlocks _ = [] + + componentsOfColorSpace :: Image px -> [JpgComponent] + + encodingState :: Int -> Image px -> V.Vector EncoderState + + imageHuffmanTables :: Image px -> [(JpgHuffmanTableSpec, HuffmanPackedTree)] + imageHuffmanTables _ = defaultHuffmanTables + + scanSpecificationOfColorSpace :: Image px -> [JpgScanSpecification] + + quantTableSpec :: Image px -> Int -> [JpgQuantTableSpec] + quantTableSpec _ qual = take 1 $ zigzaggedQuantificationSpec qual + + maximumSubSamplingOf :: Image px -> Int + maximumSubSamplingOf _ = 1 + +instance JpgEncodable Pixel8 where + scanSpecificationOfColorSpace _ = + [ JpgScanSpecification { componentSelector = 1 + , dcEntropyCodingTable = 0 + , acEntropyCodingTable = 0 + } + ] + + componentsOfColorSpace _ = + [ JpgComponent { componentIdentifier = 1 + , horizontalSamplingFactor = 1 + , verticalSamplingFactor = 1 + , quantizationTableDest = 0 + } + ] + + imageHuffmanTables _ = + [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable + , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable + ] + + encodingState qual _ = V.singleton EncoderState + { _encComponentIndex = 0 + , _encBlockWidth = 1 + , _encBlockHeight = 1 + , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual + , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree + , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree + } + + +instance JpgEncodable PixelYCbCr8 where + maximumSubSamplingOf _ = 2 + quantTableSpec _ qual = zigzaggedQuantificationSpec qual + scanSpecificationOfColorSpace _ = + [ JpgScanSpecification { componentSelector = 1 + , dcEntropyCodingTable = 0 + , acEntropyCodingTable = 0 + } + , JpgScanSpecification { componentSelector = 2 + , dcEntropyCodingTable = 1 + , acEntropyCodingTable = 1 + } + , JpgScanSpecification { componentSelector = 3 + , dcEntropyCodingTable = 1 + , acEntropyCodingTable = 1 + } + ] + + componentsOfColorSpace _ = + [ JpgComponent { componentIdentifier = 1 + , horizontalSamplingFactor = 2 + , verticalSamplingFactor = 2 + , quantizationTableDest = 0 + } + , JpgComponent { componentIdentifier = 2 + , horizontalSamplingFactor = 1 + , verticalSamplingFactor = 1 + , quantizationTableDest = 1 + } + , JpgComponent { componentIdentifier = 3 + , horizontalSamplingFactor = 1 + , verticalSamplingFactor = 1 + , quantizationTableDest = 1 + } + ] + + encodingState qual _ = V.fromListN 3 [lumaState, chromaState, chromaState { _encComponentIndex = 2 }] + where + lumaState = EncoderState + { _encComponentIndex = 0 + , _encBlockWidth = 2 + , _encBlockHeight = 2 + , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual + , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree + , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree + } + chromaState = EncoderState + { _encComponentIndex = 1 + , _encBlockWidth = 1 + , _encBlockHeight = 1 + , _encQuantTable = zigZagReorderForwardv $ chromaQuantTableAtQuality qual + , _encDcHuffman = makeInverseTable defaultDcChromaHuffmanTree + , _encAcHuffman = makeInverseTable defaultAcChromaHuffmanTree + } + +instance JpgEncodable PixelRGB8 where + additionalBlocks _ = [] where + _adobe14 = JpgAdobeApp14 + { _adobeDctVersion = 100 + , _adobeFlag0 = 0 + , _adobeFlag1 = 0 + , _adobeTransform = AdobeUnknown + } + + imageHuffmanTables _ = + [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable + , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable + ] + + scanSpecificationOfColorSpace _ = fmap build "RGB" where + build c = JpgScanSpecification + { componentSelector = fromIntegral $ fromEnum c + , dcEntropyCodingTable = 0 + , acEntropyCodingTable = 0 + } + + componentsOfColorSpace _ = fmap build "RGB" where + build c = JpgComponent + { componentIdentifier = fromIntegral $ fromEnum c + , horizontalSamplingFactor = 1 + , verticalSamplingFactor = 1 + , quantizationTableDest = 0 + } + + encodingState qual _ = V.fromListN 3 $ fmap build [0 .. 2] where + build ix = EncoderState + { _encComponentIndex = ix + , _encBlockWidth = 1 + , _encBlockHeight = 1 + , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual + , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree + , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree + } + +instance JpgEncodable PixelCMYK8 where + additionalBlocks _ = [] where + _adobe14 = JpgAdobeApp14 + { _adobeDctVersion = 100 + , _adobeFlag0 = 32768 + , _adobeFlag1 = 0 + , _adobeTransform = AdobeYCck + } + + imageHuffmanTables _ = + [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable + , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable + ] + + scanSpecificationOfColorSpace _ = fmap build "CMYK" where + build c = JpgScanSpecification + { componentSelector = fromIntegral $ fromEnum c + , dcEntropyCodingTable = 0 + , acEntropyCodingTable = 0 + } + + componentsOfColorSpace _ = fmap build "CMYK" where + build c = JpgComponent + { componentIdentifier = fromIntegral $ fromEnum c + , horizontalSamplingFactor = 1 + , verticalSamplingFactor = 1 + , quantizationTableDest = 0 + } + + encodingState qual _ = V.fromListN 4 $ fmap build [0 .. 3] where + build ix = EncoderState + { _encComponentIndex = ix + , _encBlockWidth = 1 + , _encBlockHeight = 1 + , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual + , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree + , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree + } + -- | Equivalent to 'encodeJpegAtQuality', but will store the following -- metadatas in the file using a JFIF block: -- @@ -759,121 +977,86 @@ -> Metadatas -> Image PixelYCbCr8 -- ^ Image to encode -> L.ByteString -- ^ Encoded JPEG -encodeJpegAtQualityWithMetadata quality metas img@(Image { imageWidth = w, imageHeight = h }) = encode finalImage - where finalImage = JpgImage $ - encodeMetadatas metas ++ - [ JpgQuantTable quantTables - , JpgScans JpgBaselineDCTHuffman hdr - , JpgHuffmanTable defaultHuffmanTables - , JpgScanBlob scanHeader encodedImage - ] - - outputComponentCount = 3 - - scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' } - scanHeader' = JpgScanHeader - { scanLength = 0 - , scanComponentCount = outputComponentCount - , scans = [ JpgScanSpecification { componentSelector = 1 - , dcEntropyCodingTable = 0 - , acEntropyCodingTable = 0 - } - , JpgScanSpecification { componentSelector = 2 - , dcEntropyCodingTable = 1 - , acEntropyCodingTable = 1 - } - , JpgScanSpecification { componentSelector = 3 - , dcEntropyCodingTable = 1 - , acEntropyCodingTable = 1 - } - ] - - , spectralSelection = (0, 63) - , successiveApproxHigh = 0 - , successiveApproxLow = 0 - } - - hdr = hdr' { jpgFrameHeaderLength = fromIntegral $ calculateSize hdr' } - hdr' = JpgFrameHeader { jpgFrameHeaderLength = 0 - , jpgSamplePrecision = 8 - , jpgHeight = fromIntegral h - , jpgWidth = fromIntegral w - , jpgImageComponentCount = outputComponentCount - , jpgComponents = [ - JpgComponent { componentIdentifier = 1 - , horizontalSamplingFactor = 2 - , verticalSamplingFactor = 2 - , quantizationTableDest = 0 - } - , JpgComponent { componentIdentifier = 2 - , horizontalSamplingFactor = 1 - , verticalSamplingFactor = 1 - , quantizationTableDest = 1 - } - , JpgComponent { componentIdentifier = 3 - , horizontalSamplingFactor = 1 - , verticalSamplingFactor = 1 - , quantizationTableDest = 1 - } - ] - } - - lumaQuant = scaleQuantisationMatrix (fromIntegral quality) - defaultLumaQuantizationTable - chromaQuant = scaleQuantisationMatrix (fromIntegral quality) - defaultChromaQuantizationTable - - zigzagedLumaQuant = zigZagReorderForwardv lumaQuant - zigzagedChromaQuant = zigZagReorderForwardv chromaQuant - quantTables = [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0 - , quantTable = zigzagedLumaQuant } - , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1 - , quantTable = zigzagedChromaQuant } - ] - - encodedImage = runST $ do - let horizontalMetaBlockCount = - w `divUpward` (dctBlockSize * maxSampling) - verticalMetaBlockCount = - h `divUpward` (dctBlockSize * maxSampling) - maxSampling = 2 - lumaSamplingSize = ( maxSampling, maxSampling, zigzagedLumaQuant - , makeInverseTable defaultDcLumaHuffmanTree - , makeInverseTable defaultAcLumaHuffmanTree) - chromaSamplingSize = ( maxSampling - 1, maxSampling - 1, zigzagedChromaQuant - , makeInverseTable defaultDcChromaHuffmanTree - , makeInverseTable defaultAcChromaHuffmanTree) - componentDef = [lumaSamplingSize, chromaSamplingSize, chromaSamplingSize] - - imageComponentCount = length componentDef - - dc_table <- M.replicate 3 0 - block <- createEmptyMutableMacroBlock - workData <- createEmptyMutableMacroBlock - zigzaged <- createEmptyMutableMacroBlock - writeState <- newWriteStateRef - - -- It's ugly, I know, be avoid allocation - let blockDecoder mx my = component $ zip [0..] componentDef - where component [] = return () - component ((comp, (sizeX, sizeY, table, dc, ac)) : comp_rest) = - rasterMap sizeX sizeY decoder >> component comp_rest - where xSamplingFactor = maxSampling - sizeX + 1 - ySamplingFactor = maxSampling - sizeY + 1 - extractor = extractBlock img block xSamplingFactor ySamplingFactor imageComponentCount - - decoder subX subY = do - let blockY = my * sizeY + subY - blockX = mx * sizeX + subX - prev_dc <- dc_table `M.unsafeRead` comp - (dc_coeff, neo_block) <- extractor comp blockX blockY >>= - encodeMacroBlock table workData zigzaged prev_dc - (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff - serializeMacroBlock writeState dc ac neo_block - - rasterMap - horizontalMetaBlockCount verticalMetaBlockCount - blockDecoder +encodeJpegAtQualityWithMetadata = encodeDirectJpegAtQualityWithMetadata + +-- | Equivalent to 'encodeJpegAtQuality', but will store the following +-- metadatas in the file using a JFIF block: +-- +-- * 'Codec.Picture.Metadata.DpiX' +-- * 'Codec.Picture.Metadata.DpiY' +-- +-- This function also allow to create JPEG files with the following color +-- space: +-- +-- * Y (Pixel8) for greyscale. +-- * RGB (PixelRGB8) with no color downsampling on any plane +-- * CMYK (PixelCMYK8) with no color downsampling on any plane +-- +encodeDirectJpegAtQualityWithMetadata :: forall px. (JpgEncodable px) + => Word8 -- ^ Quality factor + -> Metadatas + -> Image px -- ^ Image to encode + -> L.ByteString -- ^ Encoded JPEG +encodeDirectJpegAtQualityWithMetadata quality metas img = encode finalImage where + !w = imageWidth img + !h = imageHeight img + finalImage = JpgImage $ + encodeMetadatas metas ++ + additionalBlocks img ++ + [ JpgQuantTable $ quantTableSpec img (fromIntegral quality) + , JpgScans JpgBaselineDCTHuffman hdr + , JpgHuffmanTable $ imageHuffmanTables img + , JpgScanBlob scanHeader encodedImage + ] + + !outputComponentCount = componentCount (undefined :: px) + + scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' } + scanHeader' = JpgScanHeader + { scanLength = 0 + , scanComponentCount = fromIntegral outputComponentCount + , scans = scanSpecificationOfColorSpace img + , spectralSelection = (0, 63) + , successiveApproxHigh = 0 + , successiveApproxLow = 0 + } + + hdr = hdr' { jpgFrameHeaderLength = fromIntegral $ calculateSize hdr' } + hdr' = JpgFrameHeader + { jpgFrameHeaderLength = 0 + , jpgSamplePrecision = 8 + , jpgHeight = fromIntegral h + , jpgWidth = fromIntegral w + , jpgImageComponentCount = fromIntegral outputComponentCount + , jpgComponents = componentsOfColorSpace img + } + + !maxSampling = maximumSubSamplingOf img + !horizontalMetaBlockCount = w `divUpward` (dctBlockSize * maxSampling) + !verticalMetaBlockCount = h `divUpward` (dctBlockSize * maxSampling) + !componentDef = encodingState (fromIntegral quality) img + + encodedImage = runST $ do + dc_table <- M.replicate outputComponentCount 0 + block <- createEmptyMutableMacroBlock + workData <- createEmptyMutableMacroBlock + zigzaged <- createEmptyMutableMacroBlock + writeState <- newWriteStateRef + + rasterMap horizontalMetaBlockCount verticalMetaBlockCount $ \mx my -> + V.forM_ componentDef $ \(EncoderState comp sizeX sizeY table dc ac) -> + let !xSamplingFactor = maxSampling - sizeX + 1 + !ySamplingFactor = maxSampling - sizeY + 1 + !extractor = extractBlock img block xSamplingFactor ySamplingFactor outputComponentCount + in + rasterMap sizeX sizeY $ \subX subY -> do + let !blockY = my * sizeY + subY + !blockX = mx * sizeX + subX + prev_dc <- dc_table `M.unsafeRead` comp + extracted <- extractor comp blockX blockY + (dc_coeff, neo_block) <- encodeMacroBlock table workData zigzaged prev_dc extracted + (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff + serializeMacroBlock writeState dc ac neo_block - finalizeBoolWriter writeState + finalizeBoolWriter writeState diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Saving.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Saving.hs --- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Saving.hs 2015-12-02 22:38:14.000000000 +0100 +++ new/JuicyPixels-3.2.7/src/Codec/Picture/Saving.hs 2016-01-25 23:33:57.000000000 +0100 @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} -- | Helper functions to save dynamic images to other file format -- with automatic color space/sample format conversion done automatically. module Codec.Picture.Saving( imageToJpg @@ -10,6 +11,10 @@ , imageToTga ) where +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +#endif + import Data.Bits( unsafeShiftR ) import Data.Word( Word8, Word16 ) import qualified Data.ByteString.Lazy as L @@ -94,9 +99,13 @@ -- | 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 +-- Save Y or YCbCr Jpeg only, all other colorspaces are converted. +-- To save a RGB or CMYK JPEG file, use the +-- 'Codec.Picture.Jpg.encodeDirectJpegAtQualityWithMetadata' function imageToJpg :: Int -> DynamicImage -> L.ByteString imageToJpg quality dynImage = let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality) + encodeWithMeta = encodeDirectJpegAtQualityWithMetadata (fromIntegral quality) mempty in case dynImage of ImageYCbCr8 img -> encodeAtQuality img ImageCMYK8 img -> imageToJpg quality . ImageRGB8 $ convertImage img @@ -105,10 +114,8 @@ 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) + ImageY8 img -> encodeWithMeta img + ImageYA8 img -> encodeWithMeta $ dropAlphaLayer img ImageY16 img -> imageToJpg quality . ImageY8 $ from16to8 img ImageYA16 img -> imageToJpg quality . ImageYA8 $ from16to8 img ImageRGB16 img -> imageToJpg quality . ImageRGB8 $ from16to8 img diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture/Types.hs new/JuicyPixels-3.2.7/src/Codec/Picture/Types.hs --- old/JuicyPixels-3.2.6.4/src/Codec/Picture/Types.hs 2015-12-02 22:38:14.000000000 +0100 +++ new/JuicyPixels-3.2.7/src/Codec/Picture/Types.hs 2016-01-25 23:33:57.000000000 +0100 @@ -739,7 +739,7 @@ -> Int -- ^ Height in pixels -> m (MutableImage (PrimState m) px) {-# INLINE generateMutableImage #-} -generateMutableImage f w h = MutableImage w h <$> generated where +generateMutableImage f w h = MutableImage w h `liftM` generated where compCount = componentCount (undefined :: px) generated = do @@ -897,6 +897,7 @@ {-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGBA8) -> Image PixelRGB8 -> Image PixelRGBA8 #-} {-# SPECIALIZE INLINE pixelMap :: (PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8 #-} {-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> PixelRGB8) -> Image Pixel8 -> Image PixelRGB8 #-} +{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> Pixel8) -> Image Pixel8 -> Image Pixel8 #-} pixelMap f Image { imageWidth = w, imageHeight = h, imageData = vec } = Image w h pixels where sourceComponentCount = componentCount (undefined :: a) @@ -1105,9 +1106,10 @@ instance LumaPlaneExtractable PixelRGBA8 where {-# INLINE computeLuma #-} - computeLuma (PixelRGBA8 r g b _) = floor $ 0.3 * toRational r + - 0.59 * toRational g + - 0.11 * toRational b + computeLuma (PixelRGBA8 r g b _) = + floor $ (0.3 :: Double) * fromIntegral r + + 0.59 * fromIntegral g + + 0.11 * fromIntegral b instance LumaPlaneExtractable PixelYCbCr8 where {-# INLINE computeLuma #-} @@ -1570,9 +1572,11 @@ instance LumaPlaneExtractable PixelRGB16 where {-# INLINE computeLuma #-} - computeLuma (PixelRGB16 r g b) = floor $ 0.3 * toRational r + - 0.59 * toRational g + - 0.11 * toRational b + computeLuma (PixelRGB16 r g b) = + floor $ (0.3 :: Double) * fromIntegral r + + 0.59 * fromIntegral g + + 0.11 * fromIntegral b + -------------------------------------------------- ---- PixelRGB8 instances -------------------------------------------------- @@ -1654,9 +1658,10 @@ instance LumaPlaneExtractable PixelRGB8 where {-# INLINE computeLuma #-} - computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r + - 0.59 * toRational g + - 0.11 * toRational b + computeLuma (PixelRGB8 r g b) = + floor $ (0.3 :: Double) * fromIntegral r + + 0.59 * fromIntegral g + + 0.11 * fromIntegral b -------------------------------------------------- ---- PixelRGBA8 instances diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.6.4/src/Codec/Picture.hs new/JuicyPixels-3.2.7/src/Codec/Picture.hs --- old/JuicyPixels-3.2.6.4/src/Codec/Picture.hs 2015-12-02 22:38:14.000000000 +0100 +++ new/JuicyPixels-3.2.7/src/Codec/Picture.hs 2016-01-25 23:33:56.000000000 +0100 @@ -1,7 +1,10 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} -- | Main module for image import/export into various image formats. -- -- To use the library without thinking about it, look after 'decodeImage' and @@ -23,6 +26,10 @@ , generateFoldImage , withImage + -- * RGB helper functions + , convertRGB8 + , convertRGBA8 + -- * Lens compatibility , Traversal , imagePixels @@ -138,6 +145,7 @@ import Control.Applicative( (<$>) ) #endif +import Data.Bits( unsafeShiftR ) import Control.DeepSeq( NFData, deepseq ) import qualified Control.Exception as Exc ( catch, IOException ) import Codec.Picture.Metadata( Metadatas ) @@ -200,6 +208,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import qualified Data.Vector.Storable as VS -- | Return the first Right thing, accumulating error eitherLoad :: c -> [(String, c -> Either String b)] -> Either String b @@ -263,6 +272,7 @@ readImageWithMetadata :: FilePath -> IO (Either String (DynamicImage, Metadatas)) readImageWithMetadata = withImageDecoder decodeImageWithMetadata + -- | 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 -- to decode in each known format and if one decoding succeeds, it will return @@ -270,6 +280,85 @@ decodeImage :: B.ByteString -> Either String DynamicImage decodeImage = fmap fst . decodeImageWithMetadata +class Decimable px1 px2 where + decimateBitDepth :: Image px1 -> Image px2 + +decimateWord16 :: ( Pixel px1, Pixel px2 + , PixelBaseComponent px1 ~ Pixel16 + , PixelBaseComponent px2 ~ Pixel8 + ) => Image px1 -> Image px2 +decimateWord16 (Image w h da) = + Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 8) da + +decimateFloat :: ( Pixel px1, Pixel px2 + , PixelBaseComponent px1 ~ PixelF + , PixelBaseComponent px2 ~ Pixel8 + ) => Image px1 -> Image px2 +decimateFloat (Image w h da) = + Image w h $ VS.map (floor . (255*) . max 0 . min 1) da + +instance Decimable Pixel16 Pixel8 where + decimateBitDepth = decimateWord16 + +instance Decimable PixelYA16 PixelYA8 where + decimateBitDepth = decimateWord16 + +instance Decimable PixelRGB16 PixelRGB8 where + decimateBitDepth = decimateWord16 + +instance Decimable PixelRGBA16 PixelRGBA8 where + decimateBitDepth = decimateWord16 + +instance Decimable PixelCMYK16 PixelCMYK8 where + decimateBitDepth = decimateWord16 + +instance Decimable PixelF Pixel8 where + decimateBitDepth = decimateFloat + +instance Decimable PixelRGBF PixelRGB8 where + decimateBitDepth = decimateFloat + +-- | Convert by any mean possible a dynamic image to an image +-- in RGBA. The process can lose precision while converting from +-- 16bits pixels or Floating point pixels. +convertRGBA8 :: DynamicImage -> Image PixelRGBA8 +convertRGBA8 dynImage = case dynImage of + ImageY8 img -> promoteImage img + ImageY16 img -> promoteImage (decimateBitDepth img :: Image Pixel8) + ImageYF img -> promoteImage (decimateBitDepth img :: Image Pixel8) + ImageYA8 img -> promoteImage img + ImageYA16 img -> promoteImage (decimateBitDepth img :: Image PixelYA8) + ImageRGB8 img -> promoteImage img + ImageRGB16 img -> promoteImage (decimateBitDepth img :: Image PixelRGB8) + ImageRGBF img -> promoteImage (decimateBitDepth img :: Image PixelRGB8) + ImageRGBA8 img -> promoteImage img + ImageRGBA16 img -> decimateBitDepth img + ImageYCbCr8 img -> promoteImage (convertImage img :: Image PixelRGB8) + ImageCMYK8 img -> promoteImage (convertImage img :: Image PixelRGB8) + ImageCMYK16 img -> + promoteImage (convertImage (decimateBitDepth img :: Image PixelCMYK8) :: Image PixelRGB8) + +-- | Convert by any mean possible a dynamic image to an image +-- in RGB. The process can lose precision while converting from +-- 16bits pixels or Floating point pixels. Any alpha layer will +-- be dropped +convertRGB8 :: DynamicImage -> Image PixelRGB8 +convertRGB8 dynImage = case dynImage of + ImageY8 img -> promoteImage img + ImageY16 img -> promoteImage (decimateBitDepth img :: Image Pixel8) + ImageYF img -> promoteImage (decimateBitDepth img :: Image Pixel8) + ImageYA8 img -> promoteImage img + ImageYA16 img -> promoteImage (decimateBitDepth img :: Image PixelYA8) + ImageRGB8 img -> img + ImageRGB16 img -> decimateBitDepth img + ImageRGBF img -> decimateBitDepth img :: Image PixelRGB8 + ImageRGBA8 img -> dropAlphaLayer img + ImageRGBA16 img -> dropAlphaLayer (decimateBitDepth img :: Image PixelRGBA8) + ImageYCbCr8 img -> convertImage img + ImageCMYK8 img -> convertImage img + ImageCMYK16 img -> convertImage (decimateBitDepth img :: Image PixelCMYK8) + + -- | Equivalent to 'decodeImage', but also provide potential metadatas -- present in the given file. decodeImageWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) @@ -306,7 +395,7 @@ readJpeg :: FilePath -> IO (Either String DynamicImage) readJpeg = withImageDecoder decodeJpeg --- | Try to load a .bmp file. The colorspace would be RGB or Y. +-- | Try to load a .bmp file. The colorspace would be RGB, RGBA or Y. readBitmap :: FilePath -> IO (Either String DynamicImage) readBitmap = withImageDecoder decodeBitmap
