Hello community, here is the log from the commit of package ghc-JuicyPixels for openSUSE:Factory checked in at 2016-10-19 13:02:34 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 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 2016-07-21 08:05:09.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-JuicyPixels.new/ghc-JuicyPixels.changes 2016-10-19 13:02:37.000000000 +0200 @@ -1,0 +2,5 @@ +Thu Sep 15 06:38:32 UTC 2016 - [email protected] + +- Update to version 3.2.8 revision 0 with cabal2obs. + +------------------------------------------------------------------- Old: ---- JuicyPixels-3.2.7.2.tar.gz New: ---- JuicyPixels-3.2.8.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-JuicyPixels.spec ++++++ --- /var/tmp/diff_new_pack.T2Vn2h/_old 2016-10-19 13:02:40.000000000 +0200 +++ /var/tmp/diff_new_pack.T2Vn2h/_new 2016-10-19 13:02:40.000000000 +0200 @@ -18,15 +18,14 @@ %global pkg_name JuicyPixels Name: ghc-%{pkg_name} -Version: 3.2.7.2 +Version: 3.2.8 Release: 0 Summary: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) License: BSD-3-Clause -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz BuildRequires: ghc-Cabal-devel -# Begin cabal-rpm deps: BuildRequires: ghc-binary-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-containers-devel @@ -38,7 +37,6 @@ BuildRequires: ghc-vector-devel BuildRequires: ghc-zlib-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build -# End cabal-rpm deps %description This library can load and store images in PNG,Bitmap, Jpeg, Radiance, Tiff and @@ -58,15 +56,12 @@ %prep %setup -q -n %{pkg_name}-%{version} - %build %ghc_lib_build - %install %ghc_lib_install - %post devel %ghc_pkg_recache ++++++ JuicyPixels-3.2.7.2.tar.gz -> JuicyPixels-3.2.8.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/JuicyPixels.cabal new/JuicyPixels-3.2.8/JuicyPixels.cabal --- old/JuicyPixels-3.2.7.2/JuicyPixels.cabal 2016-06-29 22:23:57.000000000 +0200 +++ new/JuicyPixels-3.2.8/JuicyPixels.cabal 2016-09-04 18:31:55.000000000 +0200 @@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.2.7.2 +Version: 3.2.8 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.7.2 + Tag: v3.2.8 Flag Mmap Description: Enable the file loading via mmap (memory map) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/changelog new/JuicyPixels-3.2.8/changelog --- old/JuicyPixels-3.2.7.2/changelog 2016-06-29 22:23:57.000000000 +0200 +++ new/JuicyPixels-3.2.8/changelog 2016-09-04 18:31:55.000000000 +0200 @@ -1,6 +1,12 @@ Change log ========== +v3.2.8 September 2016 +--------------------- + * Added: possibility to retrieve the parsed palette. + * Fix: Fixing problem of progressive Jpeg decoding when + block height is different of block width (#) + v3.2.7.2 June 2016 ------------------ * Fix: no more libjpeg warning when decoding Juicy.Pixels encoded images. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/Bitmap.hs new/JuicyPixels-3.2.8/src/Codec/Picture/Bitmap.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/Bitmap.hs 2016-05-30 12:34:56.000000000 +0200 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/Bitmap.hs 2016-09-04 18:31:55.000000000 +0200 @@ -11,6 +11,7 @@ , encodeBitmapWithMetadata , decodeBitmap , decodeBitmapWithMetadata + , decodeBitmapWithPaletteAndMetadata , encodeDynamicBitmap , encodeBitmapWithPaletteAndMetadata , writeDynamicBitmap @@ -23,10 +24,10 @@ import Control.Applicative( (<$>) ) #endif -import Control.Monad( when, foldM_, forM_ ) +import Control.Arrow( first ) +import Control.Monad( replicateM, when, foldM_, forM_ ) import Control.Monad.ST ( ST, runST ) import Data.Maybe( fromMaybe ) -import qualified Data.Vector as V import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M import Data.Binary( Binary( .. ) ) @@ -333,13 +334,13 @@ inner (readIdx + 1) (writeIdx + 1) -pixelGet :: Get PixelRGB8 +pixelGet :: Get [Word8] pixelGet = do b <- getWord8 g <- getWord8 r <- getWord8 _ <- getWord8 - return $ PixelRGB8 r g b + return $ [r, g, b] metadataOfHeader :: BmpInfoHeader -> Metadatas metadataOfHeader hdr = @@ -362,7 +363,12 @@ -- | Same as 'decodeBitmap' but also extracts metadata. decodeBitmapWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) -decodeBitmapWithMetadata str = flip runGetStrict str $ do +decodeBitmapWithMetadata byte = + first palettedToTrueColor <$> decodeBitmapWithPaletteAndMetadata byte + +-- | Same as 'decodeBitmap' but also extracts metadata and provide separated palette. +decodeBitmapWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodeBitmapWithPaletteAndMetadata str = flip runGetStrict str $ do hdr <- get :: Get BmpHeader bmpHeader <- get :: Get BmpInfoHeader @@ -390,7 +396,8 @@ bitmapCompression bmpHeader) of (32, 1, 0) -> do rest <- getData - return . addMetadata . ImageRGBA8 $ decodeImageRGBA8 bmpHeader (2, 1, 0, 3) rest + return . addMetadata . TrueColorImage . ImageRGBA8 + $ decodeImageRGBA8 bmpHeader (2, 1, 0, 3) rest -- (2, 1, 0, 3) means BGRA pixel order (32, 1, 3) -> do posRed <- getBitfield @@ -398,16 +405,20 @@ posBlue <- getBitfield posAlpha <- getBitfield rest <- getData - return . addMetadata . ImageRGBA8 $ + return . addMetadata . TrueColorImage . ImageRGBA8 $ decodeImageRGBA8 bmpHeader (posRed, posGreen, posBlue, posAlpha) rest (24, 1, 0) -> do rest <- getData - return . addMetadata . ImageRGB8 $ decodeImageRGB8 bmpHeader rest + return . addMetadata . TrueColorImage . ImageRGB8 $ + decodeImageRGB8 bmpHeader rest ( 8, 1, 0) -> do - table <- V.replicateM paletteColorCount pixelGet + table <- replicateM paletteColorCount pixelGet rest <- getData - let indexer v = table V.! fromIntegral v - return . addMetadata . ImageRGB8 . pixelMap indexer $ decodeImageY8 bmpHeader rest + let palette = Palette' + { _paletteSize = paletteColorCount + , _paletteData = VS.fromListN (paletteColorCount * 3) $ concat table + } + return . addMetadata $ PalettedRGB8 (decodeImageY8 bmpHeader rest) palette a -> fail $ "Can't handle BMP file " ++ show a diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/ConvGraph.hs new/JuicyPixels-3.2.8/src/Codec/Picture/ConvGraph.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/ConvGraph.hs 2014-02-25 23:15:03.000000000 +0100 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/ConvGraph.hs 2016-09-04 14:18:57.000000000 +0200 @@ -1,10 +1,10 @@ --- $graph --- --- The following graph describe the differents way to convert between pixel types, --- --- * Nodes describe pixel type --- --- * Arrows describe functions --- --- <<docimages/pixelgraph.svg>> --- +-- $graph +-- +-- The following graph describe the differents way to convert between pixel types, +-- +-- * Nodes describe pixel type +-- +-- * Arrows describe functions +-- +-- <<docimages/pixelgraph.svg>> +-- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/Gif/LZWEncoding.hs new/JuicyPixels-3.2.8/src/Codec/Picture/Gif/LZWEncoding.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/Gif/LZWEncoding.hs 2015-03-29 19:06:04.000000000 +0200 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/Gif/LZWEncoding.hs 2016-09-04 14:18:57.000000000 +0200 @@ -1,101 +1,101 @@ -{-# LANGUAGE BangPatterns, CPP #-} -module Codec.Picture.Gif.LZWEncoding( lzwEncode ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>) ) -import Data.Monoid( mempty ) -#endif - -import Control.Monad.ST( runST ) -import qualified Data.ByteString.Lazy as L -import Data.Maybe( fromMaybe ) -import Data.Word( Word8 ) - -#if MIN_VERSION_containers(0,5,0) -import qualified Data.IntMap.Strict as I -#else -import qualified Data.IntMap as I -#endif -import qualified Data.Vector.Storable as V - -import Codec.Picture.BitWriter - -type Trie = I.IntMap TrieNode - -data TrieNode = TrieNode - { trieIndex :: {-# UNPACK #-} !Int - , trieSub :: !Trie - } - -emptyNode :: TrieNode -emptyNode = TrieNode - { trieIndex = -1 - , trieSub = mempty - } - -initialTrie :: Trie -initialTrie = I.fromList - [(i, emptyNode { trieIndex = i }) | i <- [0 .. 255]] - -lookupUpdate :: V.Vector Word8 -> Int -> Int -> Trie -> (Int, Int, Trie) -lookupUpdate vector freeIndex firstIndex trie = - matchUpdate $ go trie 0 firstIndex - where - matchUpdate (lzwOutputIndex, nextReadIndex, sub) = - (lzwOutputIndex, nextReadIndex, fromMaybe trie sub) - - maxi = V.length vector - go !currentTrie !prevIndex !index - | index >= maxi = (prevIndex, index, Nothing) - | otherwise = case I.lookup val currentTrie of - Just (TrieNode ix subTable) -> - let (lzwOutputIndex, nextReadIndex, newTable) = - go subTable ix $ index + 1 - tableUpdater t = - I.insert val (TrieNode ix t) currentTrie - in - (lzwOutputIndex, nextReadIndex, tableUpdater <$> newTable) - - Nothing | index == maxi -> (prevIndex, index, Nothing) - | otherwise -> (prevIndex, index, Just $ I.insert val newNode currentTrie) - - where val = fromIntegral $ vector `V.unsafeIndex` index - newNode = emptyNode { trieIndex = freeIndex } - -lzwEncode :: Int -> V.Vector Word8 -> L.ByteString -lzwEncode initialKeySize vec = runST $ do - bitWriter <- newWriteStateRef - - let updateCodeSize 12 writeIdx _ - | writeIdx == 2 ^ (12 :: Int) - 1 = do - writeBitsGif bitWriter (fromIntegral clearCode) 12 - return (startCodeSize, firstFreeIndex, initialTrie) - - updateCodeSize codeSize writeIdx trie - | writeIdx == 2 ^ codeSize = - return (codeSize + 1, writeIdx + 1, trie) - | otherwise = return (codeSize, writeIdx + 1, trie) - - go readIndex (codeSize, _, _) | readIndex >= maxi = - writeBitsGif bitWriter (fromIntegral endOfInfo) codeSize - go !readIndex (!codeSize, !writeIndex, !trie) = do - let (indexToWrite, endIndex, trie') = - lookuper writeIndex readIndex trie - writeBitsGif bitWriter (fromIntegral indexToWrite) codeSize - updateCodeSize codeSize writeIndex trie' - >>= go endIndex - - writeBitsGif bitWriter (fromIntegral clearCode) startCodeSize - go 0 (startCodeSize, firstFreeIndex, initialTrie) - - finalizeBoolWriter bitWriter - where - maxi = V.length vec - - startCodeSize = initialKeySize + 1 - - clearCode = 2 ^ initialKeySize :: Int - endOfInfo = clearCode + 1 - firstFreeIndex = endOfInfo + 1 - - lookuper = lookupUpdate vec +{-# LANGUAGE BangPatterns, CPP #-} +module Codec.Picture.Gif.LZWEncoding( lzwEncode ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +import Data.Monoid( mempty ) +#endif + +import Control.Monad.ST( runST ) +import qualified Data.ByteString.Lazy as L +import Data.Maybe( fromMaybe ) +import Data.Word( Word8 ) + +#if MIN_VERSION_containers(0,5,0) +import qualified Data.IntMap.Strict as I +#else +import qualified Data.IntMap as I +#endif +import qualified Data.Vector.Storable as V + +import Codec.Picture.BitWriter + +type Trie = I.IntMap TrieNode + +data TrieNode = TrieNode + { trieIndex :: {-# UNPACK #-} !Int + , trieSub :: !Trie + } + +emptyNode :: TrieNode +emptyNode = TrieNode + { trieIndex = -1 + , trieSub = mempty + } + +initialTrie :: Trie +initialTrie = I.fromList + [(i, emptyNode { trieIndex = i }) | i <- [0 .. 255]] + +lookupUpdate :: V.Vector Word8 -> Int -> Int -> Trie -> (Int, Int, Trie) +lookupUpdate vector freeIndex firstIndex trie = + matchUpdate $ go trie 0 firstIndex + where + matchUpdate (lzwOutputIndex, nextReadIndex, sub) = + (lzwOutputIndex, nextReadIndex, fromMaybe trie sub) + + maxi = V.length vector + go !currentTrie !prevIndex !index + | index >= maxi = (prevIndex, index, Nothing) + | otherwise = case I.lookup val currentTrie of + Just (TrieNode ix subTable) -> + let (lzwOutputIndex, nextReadIndex, newTable) = + go subTable ix $ index + 1 + tableUpdater t = + I.insert val (TrieNode ix t) currentTrie + in + (lzwOutputIndex, nextReadIndex, tableUpdater <$> newTable) + + Nothing | index == maxi -> (prevIndex, index, Nothing) + | otherwise -> (prevIndex, index, Just $ I.insert val newNode currentTrie) + + where val = fromIntegral $ vector `V.unsafeIndex` index + newNode = emptyNode { trieIndex = freeIndex } + +lzwEncode :: Int -> V.Vector Word8 -> L.ByteString +lzwEncode initialKeySize vec = runST $ do + bitWriter <- newWriteStateRef + + let updateCodeSize 12 writeIdx _ + | writeIdx == 2 ^ (12 :: Int) - 1 = do + writeBitsGif bitWriter (fromIntegral clearCode) 12 + return (startCodeSize, firstFreeIndex, initialTrie) + + updateCodeSize codeSize writeIdx trie + | writeIdx == 2 ^ codeSize = + return (codeSize + 1, writeIdx + 1, trie) + | otherwise = return (codeSize, writeIdx + 1, trie) + + go readIndex (codeSize, _, _) | readIndex >= maxi = + writeBitsGif bitWriter (fromIntegral endOfInfo) codeSize + go !readIndex (!codeSize, !writeIndex, !trie) = do + let (indexToWrite, endIndex, trie') = + lookuper writeIndex readIndex trie + writeBitsGif bitWriter (fromIntegral indexToWrite) codeSize + updateCodeSize codeSize writeIndex trie' + >>= go endIndex + + writeBitsGif bitWriter (fromIntegral clearCode) startCodeSize + go 0 (startCodeSize, firstFreeIndex, initialTrie) + + finalizeBoolWriter bitWriter + where + maxi = V.length vec + + startCodeSize = initialKeySize + 1 + + clearCode = 2 ^ initialKeySize :: Int + endOfInfo = clearCode + 1 + firstFreeIndex = endOfInfo + 1 + + lookuper = lookupUpdate vec diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/Gif.hs new/JuicyPixels-3.2.8/src/Codec/Picture/Gif.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/Gif.hs 2016-05-30 12:34:56.000000000 +0200 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/Gif.hs 2016-09-04 18:31:55.000000000 +0200 @@ -6,6 +6,7 @@ module Codec.Picture.Gif ( -- * Reading decodeGif , decodeGifWithMetadata + , decodeGifWithPaletteAndMetadata , decodeGifImages , getDelaysGifImages @@ -26,6 +27,7 @@ import Control.Applicative( pure, (<*>), (<$>) ) #endif +import Control.Arrow( first ) import Control.Monad( replicateM, replicateM_, unless ) import Control.Monad.ST( runST ) import Control.Monad.Trans.Class( lift ) @@ -570,7 +572,7 @@ hasTransparency Nothing = False hasTransparency (Just control) = gceTransparentFlag control -decodeAllGifImages :: GifFile -> [DynamicImage] +decodeAllGifImages :: GifFile -> [PalettedImage] decodeAllGifImages GifFile { gifImages = [] } = [] decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette , gifScreenDescriptor = wholeDescriptor } @@ -579,11 +581,17 @@ let backImage = generateImage (\_ _ -> backgroundColor) globalWidth globalHeight thisPalette = paletteOf palette firstImage + baseImage = decodeImage firstImage initState = - (thisPalette, firstControl, substituteColors thisPalette $ decodeImage firstImage) + (thisPalette, firstControl, substituteColors thisPalette baseImage) scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage + palette' = Palette' + { _paletteSize = imageWidth thisPalette + , _paletteData = imageData thisPalette + } in - [ImageRGB8 img | (_, _, img) <- scanl scanner initState rest] + PalettedRGB8 baseImage palette' : + [TrueColorImage $ ImageRGB8 img | (_, _, img) <- tail $ scanl scanner initState rest] | otherwise = let backImage :: Image PixelRGBA8 @@ -601,7 +609,7 @@ initState = (thisPalette, firstControl, decoded) scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in - [ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest] + [TrueColorImage $ ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest] where globalWidth = fromIntegral $ screenWidth wholeDescriptor @@ -662,7 +670,7 @@ val = pixelAt thisPalette (fromIntegral code) 0 pixeler x y = pixelAt oldImage x y -decodeFirstGifImage :: GifFile -> Either String (DynamicImage, Metadatas) +decodeFirstGifImage :: GifFile -> Either String (PalettedImage, Metadatas) decodeFirstGifImage img@GifFile { gifImages = (firstImage:_) } = case decodeAllGifImages img { gifImages = [firstImage] } of [] -> Left "No image after decoding" @@ -678,7 +686,7 @@ -- * 'ImageRGBA8' -- decodeGif :: B.ByteString -> Either String DynamicImage -decodeGif img = decode img >>= (fmap fst . decodeFirstGifImage) +decodeGif img = decode img >>= (fmap (palettedToTrueColor . fst) . decodeFirstGifImage) -- | Transform a raw gif image to an image, without modifying the pixels. This -- function can output the following images: @@ -690,13 +698,18 @@ -- Metadatas include Width & Height information. -- decodeGifWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) -decodeGifWithMetadata img = decode img >>= decodeFirstGifImage +decodeGifWithMetadata img = first palettedToTrueColor <$> decodeGifWithPaletteAndMetadata img +-- | Return the gif image with metadata and palette. +-- The palette is only returned for the first image of an +-- animation and has no transparency. +decodeGifWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodeGifWithPaletteAndMetadata img = decode img >>= decodeFirstGifImage -- | Transform a raw gif to a list of images, representing -- all the images of an animation. decodeGifImages :: B.ByteString -> Either String [DynamicImage] -decodeGifImages img = decodeAllGifImages <$> decode img +decodeGifImages img = fmap palettedToTrueColor . decodeAllGifImages <$> decode img -- | Extract a list of frame delays from a raw gif. getDelaysGifImages :: B.ByteString -> Either String [GifDelay] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/InternalHelper.hs new/JuicyPixels-3.2.8/src/Codec/Picture/InternalHelper.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/InternalHelper.hs 2014-01-26 10:44:08.000000000 +0100 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/InternalHelper.hs 2016-09-04 14:18:57.000000000 +0200 @@ -1,51 +1,51 @@ -{-# LANGUAGE CPP #-} -module Codec.Picture.InternalHelper ( runGet - , runGetStrict - , decode - , getRemainingBytes - , getRemainingLazyBytes ) where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.Binary( Binary( get ) ) -import Data.Binary.Get( Get - , getRemainingLazyByteString - ) -import qualified Data.Binary.Get as G - -#if MIN_VERSION_binary(0,6,4) -#else -import Control.Applicative( (<$>) ) -import qualified Control.Exception as E --- I feel so dirty. :( -import System.IO.Unsafe( unsafePerformIO ) -#endif - -decode :: (Binary a) => B.ByteString -> Either String a -decode = runGetStrict get - -runGet :: Get a -> L.ByteString -> Either String a -#if MIN_VERSION_binary(0,6,4) -runGet act = unpack . G.runGetOrFail act - where unpack (Left (_, _, str)) = Left str - unpack (Right (_, _, element)) = Right element -#else -runGet act str = unsafePerformIO $ E.catch - (Right <$> E.evaluate (G.runGet act str)) - (\msg -> return . Left $ show (msg :: E.SomeException)) -#endif - -runGetStrict :: Get a -> B.ByteString -> Either String a -runGetStrict act buffer = runGet act $ L.fromChunks [buffer] - -getRemainingBytes :: Get B.ByteString -getRemainingBytes = do - rest <- getRemainingLazyByteString - return $ case L.toChunks rest of - [] -> B.empty - [a] -> a - lst -> B.concat lst - -getRemainingLazyBytes :: Get L.ByteString -getRemainingLazyBytes = getRemainingLazyByteString - +{-# LANGUAGE CPP #-} +module Codec.Picture.InternalHelper ( runGet + , runGetStrict + , decode + , getRemainingBytes + , getRemainingLazyBytes ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Binary( Binary( get ) ) +import Data.Binary.Get( Get + , getRemainingLazyByteString + ) +import qualified Data.Binary.Get as G + +#if MIN_VERSION_binary(0,6,4) +#else +import Control.Applicative( (<$>) ) +import qualified Control.Exception as E +-- I feel so dirty. :( +import System.IO.Unsafe( unsafePerformIO ) +#endif + +decode :: (Binary a) => B.ByteString -> Either String a +decode = runGetStrict get + +runGet :: Get a -> L.ByteString -> Either String a +#if MIN_VERSION_binary(0,6,4) +runGet act = unpack . G.runGetOrFail act + where unpack (Left (_, _, str)) = Left str + unpack (Right (_, _, element)) = Right element +#else +runGet act str = unsafePerformIO $ E.catch + (Right <$> E.evaluate (G.runGet act str)) + (\msg -> return . Left $ show (msg :: E.SomeException)) +#endif + +runGetStrict :: Get a -> B.ByteString -> Either String a +runGetStrict act buffer = runGet act $ L.fromChunks [buffer] + +getRemainingBytes :: Get B.ByteString +getRemainingBytes = do + rest <- getRemainingLazyByteString + return $ case L.toChunks rest of + [] -> B.empty + [a] -> a + lst -> B.concat lst + +getRemainingLazyBytes :: Get L.ByteString +getRemainingLazyBytes = getRemainingLazyByteString + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/Jpg/Common.hs new/JuicyPixels-3.2.8/src/Codec/Picture/Jpg/Common.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/Jpg/Common.hs 2016-05-30 12:34:56.000000000 +0200 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/Jpg/Common.hs 2016-09-04 18:31:55.000000000 +0200 @@ -17,6 +17,7 @@ , rasterMap , decodeMacroBlock , decodeRestartInterval + , toBlockSize ) where #if !MIN_VERSION_base(4,8,0) @@ -53,6 +54,12 @@ , coefficientRange :: !(Int, Int) , successiveApprox :: !(Int, Int) , readerIndex :: {-# UNPACK #-} !Int + -- | When in progressive mode, we can have many + -- color in a scan are only one. The indices changes + -- on this fact, when mixed, there is whole + -- MCU for all color components, spanning multiple + -- block lines. With only one color component we use + -- the normal raster order. , indiceVector :: {-# UNPACK #-} !Int , blockIndex :: {-# UNPACK #-} !Int , blockMcuX :: {-# UNPACK #-} !Int @@ -60,6 +67,9 @@ } deriving Show +toBlockSize :: Int -> Int +toBlockSize v = (v + 7) `div` 8 + decodeRestartInterval :: BoolReader s Int32 decodeRestartInterval = return (-1) {- do bits <- replicateM 8 getNextBitJpg @@ -195,9 +205,9 @@ unpackMacroBlock :: Int -- ^ Component count -> Int -- ^ Width coefficient -> Int -- ^ Height coefficient + -> Int -- ^ Component index -> Int -- ^ x -> Int -- ^ y - -> Int -- ^ Component index -> MutableImage s PixelYCbCr8 -> MutableMacroBlock s Int16 -> ST s () diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/Jpg/Progressive.hs new/JuicyPixels-3.2.8/src/Codec/Picture/Jpg/Progressive.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/Jpg/Progressive.hs 2015-08-17 18:51:43.000000000 +0200 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/Jpg/Progressive.hs 2016-09-04 18:31:55.000000000 +0200 @@ -36,12 +36,9 @@ V.fromList $ VS.fromList <$> [indexSolo, indexMulti] where compW = fromIntegral $ horizontalSamplingFactor param compH = fromIntegral $ verticalSamplingFactor param - imageBlockSize = (imgWidth + 7) `div` 8 - - indexSolo = - [y * mcuWidth * compW + x - | y <- [0 .. compH - 1], x <- [0 .. imageBlockSize - 1]] + imageBlockSize = toBlockSize imgWidth + indexSolo = take (imageBlockSize * compH) [0 ..] indexMulti = [(mcu + y * mcuWidth) * compW + x | mcu <- [0 .. mcuWidth - 1] @@ -195,13 +192,13 @@ selection _ _ = decodeRefineAc data ComponentData s = ComponentData - { componentIndices :: V.Vector (VS.Vector Int) - , componentBlocks :: V.Vector (MutableMacroBlock s Int16) - , componentId :: !Int - , componentBlockCount :: !Int - } + { componentIndices :: V.Vector (VS.Vector Int) + , componentBlocks :: V.Vector (MutableMacroBlock s Int16) + , componentId :: !Int + , componentBlockCount :: !Int + } --- | Iteration from to n in monadic context, without data +-- | Iteration from 0 to n in monadic context, without data -- keeping. lineMap :: (Monad m) => Int -> (Int -> m ()) -> m () {-# INLINE lineMap #-} @@ -259,6 +256,8 @@ let componentNumber = componentIndex unpackParam writeIndex <- writeIndices `MS.read` componentNumber let componentData = allBlocks !! componentNumber + -- We get back the correct block indices for the number of component + -- in the current scope (precalculated) indexVector = componentIndices componentData ! indiceVector unpackParam maxIndexLength = VS.length indexVector @@ -305,14 +304,14 @@ imgWidth = fromIntegral $ jpgWidth frame imgHeight = fromIntegral $ jpgHeight frame - imageBlockWidth = (imgWidth + 7) `div` 8 - imageBlockHeight = (imgHeight + 7) `div` 8 + imageBlockWidth = toBlockSize imgWidth + imageBlockHeight = toBlockSize imgHeight - imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW + imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH allocateWorkingBlocks (ix, comp) = do - let blockCount = hSample * vSample * imageMcuWidth + let blockCount = hSample * vSample * imageMcuWidth * 2 blocks <- V.replicateM blockCount createEmptyMutableMacroBlock return ComponentData { componentBlocks = blocks diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/Jpg.hs new/JuicyPixels-3.2.8/src/Codec/Picture/Jpg.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/Jpg.hs 2016-05-30 12:34:56.000000000 +0200 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/Jpg.hs 2016-09-04 18:31:55.000000000 +0200 @@ -353,7 +353,7 @@ , coefficientRange = ( fromIntegral selectionLow , fromIntegral selectionHigh ) - , blockIndex = y * ySampling + x + , blockIndex = y * xSampling + x , blockMcuX = x , blockMcuY = y }, unpackerDecision compCount componentSubSampling) @@ -423,8 +423,8 @@ maxiW = maximum [fst $ subSampling c | (c,_) <- params] maxiH = maximum [snd $ subSampling c | (c,_) <- params] - imageBlockWidth = (imgWidth + 7) `div` 8 - imageBlockHeight = (imgHeight + 7) `div` 8 + imageBlockWidth = toBlockSize imgWidth + imageBlockHeight = toBlockSize imgHeight imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/Png/Type.hs new/JuicyPixels-3.2.8/src/Codec/Picture/Png/Type.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/Png/Type.hs 2015-08-17 18:51:43.000000000 +0200 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/Png/Type.hs 2016-09-04 18:31:55.000000000 +0200 @@ -171,13 +171,13 @@ } -- | Palette with indices beginning at 0 to elemcount - 1 -type PngPalette = Image PixelRGB8 +type PngPalette = Palette' PixelRGB8 -- | Parse a palette from a png chunk. parsePalette :: PngRawChunk -> Either String PngPalette parsePalette plte | chunkLength plte `mod` 3 /= 0 = Left "Invalid palette size" - | otherwise = Image pixelCount 1 . V.fromListN (3 * pixelCount) <$> pixels + | otherwise = Palette' pixelCount . V.fromListN (3 * pixelCount) <$> pixels where pixelUnpacker = replicateM (fromIntegral pixelCount * 3) get pixelCount = fromIntegral $ chunkLength plte `div` 3 pixels = runGet pixelUnpacker (chunkData plte) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/Png.hs new/JuicyPixels-3.2.8/src/Codec/Picture/Png.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/Png.hs 2016-05-30 12:34:56.000000000 +0200 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/Png.hs 2016-09-04 18:31:55.000000000 +0200 @@ -21,6 +21,8 @@ , decodePng , decodePngWithMetadata + , decodePngWithPaletteAndMetadata + , writePng , encodeDynamicPng , encodePalettedPng @@ -32,6 +34,7 @@ import Control.Applicative( (<$>) ) #endif +import Control.Arrow( first ) import Control.Monad( forM_, foldM_, when, void ) import Control.Monad.ST( ST, runST ) import Data.Monoid( (<>) ) @@ -389,7 +392,7 @@ Right <$> V.unsafeFreeze imgArray generateGreyscalePalette :: Word8 -> PngPalette -generateGreyscalePalette bits = Image (maxValue+1) 1 vec +generateGreyscalePalette bits = Palette' (maxValue+1) vec where maxValue = 2 ^ bits - 1 vec = V.fromListN ((fromIntegral maxValue + 1) * 3) $ concat pixels pixels = [[i, i, i] | n <- [0 .. maxValue] @@ -407,43 +410,31 @@ paletteRGB2 = generateGreyscalePalette 2 paletteRGB4 = generateGreyscalePalette 4 -{-# INLINE bounds #-} -bounds :: Storable a => V.Vector a -> (Int, Int) -bounds v = (0, V.length v - 1) - -applyPalette :: PngPalette -> V.Vector Word8 -> V.Vector Word8 -applyPalette pal img = V.fromListN ((initSize + 1) * 3) pixels - where (_, initSize) = bounds img - pixels = concat [[r, g, b] | ipx <- V.toList img - , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0] - -applyPaletteWithTransparency :: PngPalette -> Lb.ByteString -> V.Vector Word8 - -> V.Vector Word8 -applyPaletteWithTransparency pal transpBuffer img = V.fromListN ((initSize + 1) * 4) pixels - where (_, initSize) = bounds img - 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] +addTransparencyToPalette :: PngPalette -> Lb.ByteString -> Palette' PixelRGBA8 +addTransparencyToPalette pal transpBuffer = + Palette' (_paletteSize pal) . imageData . pixelMapXY addOpacity $ palettedAsImage pal + where + maxi = fromIntegral $ Lb.length transpBuffer + addOpacity ix _ (PixelRGB8 r g b) | ix < maxi = + PixelRGBA8 r g b $ Lb.index transpBuffer (fromIntegral ix) + addOpacity _ _ (PixelRGB8 r g b) = PixelRGBA8 r g b 255 unparse :: PngIHdr -> Maybe PngPalette -> [Lb.ByteString] -> PngImageType - -> B.ByteString -> Either String DynamicImage + -> B.ByteString -> Either String PalettedImage unparse ihdr _ t PngGreyscale bytes - | bitDepth ihdr == 1 = unparse ihdr (Just paletteRGB1) t PngIndexedColor bytes - | bitDepth ihdr == 2 = unparse ihdr (Just paletteRGB2) t PngIndexedColor bytes - | bitDepth ihdr == 4 = unparse ihdr (Just paletteRGB4) t PngIndexedColor bytes - | otherwise = toImage ihdr ImageY8 ImageY16 $ runST $ deinterlacer ihdr bytes + | bitDepth ihdr == 1 = unparse ihdr (Just paletteRGB1) t PngIndexedColor bytes + | bitDepth ihdr == 2 = unparse ihdr (Just paletteRGB2) t PngIndexedColor bytes + | bitDepth ihdr == 4 = unparse ihdr (Just paletteRGB4) t PngIndexedColor bytes + | otherwise = + fmap TrueColorImage . toImage ihdr ImageY8 ImageY16 $ runST $ deinterlacer ihdr bytes unparse _ Nothing _ PngIndexedColor _ = Left "no valid palette found" unparse ihdr _ _ PngTrueColour bytes = - toImage ihdr ImageRGB8 ImageRGB16 $ runST $ deinterlacer ihdr bytes + fmap TrueColorImage . toImage ihdr ImageRGB8 ImageRGB16 $ runST $ deinterlacer ihdr bytes unparse ihdr _ _ PngGreyscaleWithAlpha bytes = - toImage ihdr ImageYA8 ImageYA16 $ runST $ deinterlacer ihdr bytes + fmap TrueColorImage . toImage ihdr ImageYA8 ImageYA16 $ runST $ deinterlacer ihdr bytes unparse ihdr _ _ PngTrueColourWithAlpha bytes = - toImage ihdr ImageRGBA8 ImageRGBA16 $ runST $ deinterlacer ihdr bytes + fmap TrueColorImage . toImage ihdr ImageRGBA8 ImageRGBA16 $ runST $ deinterlacer ihdr bytes unparse ihdr (Just plte) transparency PngIndexedColor bytes = palette8 ihdr plte transparency $ runST $ deinterlacer ihdr bytes @@ -461,13 +452,12 @@ h = fromIntegral $ height hdr palette8 :: PngIHdr -> PngPalette -> [Lb.ByteString] -> Either (V.Vector Word8) t - -> Either String DynamicImage + -> Either String PalettedImage palette8 hdr palette transparency eimg = case (transparency, eimg) of ([c], Left img) -> - Right . ImageRGBA8 . Image w h - $ applyPaletteWithTransparency palette c img + Right . PalettedRGBA8 (Image w h img) $ addTransparencyToPalette palette c (_, Left img) -> - Right . ImageRGB8 . Image w h $ applyPalette palette img + return $ PalettedRGB8 (Image w h img) palette (_, Right _) -> Left "Invalid bit depth for paleted image" where @@ -502,10 +492,14 @@ decodePng :: B.ByteString -> Either String DynamicImage decodePng = fmap fst . decodePngWithMetadata +-- | Decode a PNG file with, possibly, separated palette. +decodePngWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodePngWithMetadata b = first palettedToTrueColor <$> decodePngWithPaletteAndMetadata b + -- | Same as 'decodePng' but also extract meta datas present -- in the files. -decodePngWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) -decodePngWithMetadata byte = do +decodePngWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodePngWithPaletteAndMetadata byte = do rawImg <- runGetStrict get byte let ihdr = header rawImg metadatas = diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/Tga.hs new/JuicyPixels-3.2.8/src/Codec/Picture/Tga.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/Tga.hs 2016-05-30 12:34:56.000000000 +0200 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/Tga.hs 2016-09-04 18:31:55.000000000 +0200 @@ -10,6 +10,7 @@ -- Targa (*.tga) files. module Codec.Picture.Tga( decodeTga , decodeTgaWithMetadata + , decodeTgaWithPaletteAndMetadata , TgaSaveable , encodeTga , writeTga @@ -20,6 +21,7 @@ import Control.Applicative( (<*>), pure, (<$>) ) #endif +import Control.Arrow( first ) import Control.Monad.ST( ST, runST ) import Data.Bits( (.&.) , (.|.) @@ -267,16 +269,18 @@ 32 -> pure . ImageRGBA8 . flipper $ f Depth32 file n -> fail $ "Invalid bit depth (" ++ show n ++ ")" -applyPalette :: (Pixel px) - => (Image px -> DynamicImage) -> Image px - -> DynamicImage - -> Either String DynamicImage -applyPalette f palette (ImageY8 img) = - pure . f $ pixelMap (\v -> pixelAt palette (fromIntegral v) 0) img -applyPalette _ _ _ = - fail "Bad colorspace for image" +toPaletted :: (Pixel px) + => (Image Pixel8 -> Palette' px -> PalettedImage) -> Image px + -> DynamicImage + -> Either String PalettedImage +toPaletted f palette (ImageY8 img) = pure $ f img pal where + pal = Palette' + { _paletteSize = imageWidth palette + , _paletteData = imageData palette + } +toPaletted _ _ _ = fail "Bad colorspace for image" -unparse :: TgaFile -> Either String (DynamicImage, Metadatas) +unparse :: TgaFile -> Either String (PalettedImage, Metadatas) unparse file = let hdr = _tgaFileHeader file imageType = _tgaHdrImageType hdr @@ -300,18 +304,18 @@ case imageType of ImageTypeNoData _ -> fail "No data detected in TGA file" ImageTypeTrueColor _ -> - fmap (, metas) $ prepareUnpacker file unpacker + fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker ImageTypeMonochrome _ -> - fmap (, metas) $ prepareUnpacker file unpacker + fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker ImageTypeColorMapped _ -> case decodedPalette of Left str -> Left str - Right (ImageY8 img, _) -> - fmap (, metas) $ prepareUnpacker file unpacker >>= applyPalette ImageY8 img - Right (ImageRGB8 img, _) -> - fmap (, metas) $ prepareUnpacker file unpacker >>= applyPalette ImageRGB8 img - Right (ImageRGBA8 img, _) -> - fmap (, metas) $ prepareUnpacker file unpacker >>= applyPalette ImageRGBA8 img + Right (TrueColorImage (ImageY8 img), _) -> + fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedY8 img + Right (TrueColorImage (ImageRGB8 img), _) -> + fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedRGB8 img + Right (TrueColorImage (ImageRGBA8 img), _) -> + fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedRGBA8 img Right _ -> fail "Unknown pixel type" writeRun :: (Pixel px) @@ -450,11 +454,15 @@ -- * 'ImageRGBA8' -- decodeTga :: B.ByteString -> Either String DynamicImage -decodeTga byte = runGetStrict get byte >>= (fmap fst . unparse) +decodeTga byte = fst <$> decodeTgaWithMetadata byte -- | Equivalent to decodeTga but also provide metadata decodeTgaWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) -decodeTgaWithMetadata byte = runGetStrict get byte >>= unparse +decodeTgaWithMetadata byte = first palettedToTrueColor <$> decodeTgaWithPaletteAndMetadata byte + +-- | Equivalent to decodeTga but with metdata and palette if any +decodeTgaWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodeTgaWithPaletteAndMetadata byte = runGetStrict get byte >>= unparse -- | This typeclass determine if a pixel can be saved in the -- TGA format. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/Tiff.hs new/JuicyPixels-3.2.8/src/Codec/Picture/Tiff.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/Tiff.hs 2016-05-30 12:34:56.000000000 +0200 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/Tiff.hs 2016-09-04 18:31:55.000000000 +0200 @@ -27,6 +27,7 @@ -- module Codec.Picture.Tiff( decodeTiff , decodeTiffWithMetadata + , decodeTiffWithPaletteAndMetadata , TiffSaveable , encodeTiff , writeTiff @@ -37,6 +38,7 @@ import Data.Monoid( mempty ) #endif +import Control.Arrow( first ) import Control.Monad( when, foldM_, unless, forM_ ) import Control.Monad.ST( ST, runST ) import Control.Monad.Writer.Strict( execWriter, tell, Writer ) @@ -630,7 +632,13 @@ >>= predictorOfConstant) <*> pure (extractTiffMetadata cleaned) -unpack :: B.ByteString -> TiffInfo -> Either String DynamicImage +palette16Of :: Image PixelRGB16 -> Palette' PixelRGB16 +palette16Of p = Palette' + { _paletteSize = imageWidth p + , _paletteData = imageData p + } + +unpack :: B.ByteString -> TiffInfo -> Either String PalettedImage -- | while mandatory some images don't put correct -- rowperstrip. So replacing 0 with actual image height. unpack file nfo@TiffInfo { tiffRowPerStrip = 0 } = @@ -641,74 +649,60 @@ , tiffPalette = Just p } | lst == V.singleton 8 && format == [TiffSampleUint] = - let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0) - gathered :: Image Pixel8 - gathered = gatherStrips (0 :: Word8) file nfo - in - pure . ImageRGB16 $ applyPalette gathered - + pure . PalettedRGB16 (gatherStrips (0 :: Word8) file nfo) $ palette16Of p | lst == V.singleton 4 && format == [TiffSampleUint] = - let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0) - gathered :: Image Pixel8 - gathered = gatherStrips Pack4 file nfo - in - pure . ImageRGB16 $ applyPalette gathered - + pure . PalettedRGB16 (gatherStrips Pack4 file nfo) $ palette16Of p | lst == V.singleton 2 && format == [TiffSampleUint] = - let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0) - gathered :: Image Pixel8 - gathered = gatherStrips Pack2 file nfo - in - pure . ImageRGB16 $ applyPalette gathered + pure . PalettedRGB16 (gatherStrips Pack2 file nfo) $ palette16Of p unpack file nfo@TiffInfo { tiffColorspace = TiffCMYK , tiffBitsPerSample = lst , tiffSampleFormat = format } | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo + pure . TrueColorImage . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = - pure . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo + pure . TrueColorImage . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } = do img <- unpack file (nfo { tiffColorspace = TiffMonochrome }) case img of - ImageY8 i -> pure . ImageY8 $ pixelMap (maxBound -) i - ImageY16 i -> pure . ImageY16 $ pixelMap (maxBound -) i - ImageYA8 i -> let negative (PixelYA8 y a) = PixelYA8 (maxBound - y) a - in pure . ImageYA8 $ pixelMap negative i - ImageYA16 i -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a - in pure . ImageYA16 $ pixelMap negative i + TrueColorImage (ImageY8 i) -> pure . TrueColorImage . ImageY8 $ pixelMap (maxBound -) i + TrueColorImage (ImageY16 i) -> pure . TrueColorImage . ImageY16 $ pixelMap (maxBound -) i + TrueColorImage (ImageYA8 i) -> let negative (PixelYA8 y a) = PixelYA8 (maxBound - y) a + in pure . TrueColorImage . ImageYA8 $ pixelMap negative i + TrueColorImage (ImageYA16 i) -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a + in pure . TrueColorImage . ImageYA16 $ pixelMap negative i _ -> fail "Unsupported color type used with colorspace MonochromeWhite0" unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome , tiffBitsPerSample = lst , tiffSampleFormat = format } | lst == V.singleton 2 && all (TiffSampleUint ==) format = - pure . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo + pure . TrueColorImage . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.singleton 4 && all (TiffSampleUint ==) format = - pure . ImageY8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo + pure . TrueColorImage . ImageY8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo | lst == V.singleton 8 && all (TiffSampleUint ==) format = - pure . ImageY8 $ gatherStrips (0 :: Word8) file nfo + pure . TrueColorImage . ImageY8 $ gatherStrips (0 :: Word8) file nfo | lst == V.singleton 12 && all (TiffSampleUint ==) format = - pure . ImageY16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo + pure . TrueColorImage . ImageY16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo | lst == V.singleton 16 && all (TiffSampleUint ==) format = - pure . ImageY16 $ gatherStrips (0 :: Word16) file nfo + pure . TrueColorImage . ImageY16 $ gatherStrips (0 :: Word16) file nfo | lst == V.singleton 32 && all (TiffSampleUint ==) format = let toWord16 v = fromIntegral $ v `unsafeShiftR` 16 img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32 in - pure . ImageY16 $ pixelMap toWord16 img + pure . TrueColorImage . ImageY16 $ pixelMap toWord16 img | lst == V.fromList [2, 2] && all (TiffSampleUint ==) format = - pure . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo + pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format = - pure . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo + pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo | lst == V.fromList [8, 8] && all (TiffSampleUint ==) format = - pure . ImageYA8 $ gatherStrips (0 :: Word8) file nfo + pure . TrueColorImage . ImageYA8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [12, 12] && all (TiffSampleUint ==) format = - pure . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo + pure . TrueColorImage . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo | lst == V.fromList [16, 16] && all (TiffSampleUint ==) format = - pure . ImageYA16 $ gatherStrips (0 :: Word16) file nfo + pure . TrueColorImage . ImageYA16 $ gatherStrips (0 :: Word16) file nfo where expand12to16 x = x `unsafeShiftL` 4 + x `unsafeShiftR` (12 - 4) @@ -717,7 +711,7 @@ , tiffPlaneConfiguration = PlanarConfigContig , tiffSampleFormat = format } | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageYCbCr8 $ gatherStrips cbcrConf file nfo + pure . TrueColorImage . ImageYCbCr8 $ gatherStrips cbcrConf file nfo where defaulting 0 = 2 defaulting n = n @@ -734,23 +728,23 @@ , tiffBitsPerSample = lst , tiffSampleFormat = format } | lst == V.fromList [2, 2, 2] && all (TiffSampleUint ==) format = - pure . ImageRGB8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo + pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format = - pure . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo + pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo + pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo + pure . TrueColorImage . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [16, 16, 16] && all (TiffSampleUint ==) format = - pure . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo + pure . TrueColorImage . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = - pure . ImageRGBA16 $ gatherStrips (0 :: Word16) file nfo + pure . TrueColorImage . ImageRGBA16 $ gatherStrips (0 :: Word16) file nfo unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome , tiffBitsPerSample = lst , tiffSampleFormat = format } -- some files are a little bit borked... | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo + pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo unpack _ _ = fail "Failure to unpack TIFF file" @@ -788,7 +782,11 @@ -- The metadata extracted are the 'Codec.Picture.Metadata.DpiX' & -- 'Codec.Picture.Metadata.DpiY' information alongside the EXIF informations. decodeTiffWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) -decodeTiffWithMetadata file = runGetStrict (getP file) file >>= go +decodeTiffWithMetadata str = first palettedToTrueColor <$> decodeTiffWithPaletteAndMetadata str + +-- | Decode TIFF and provide separated palette and metadata +decodeTiffWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodeTiffWithPaletteAndMetadata file = runGetStrict (getP file) file >>= go where go tinfo = (, tiffMetadatas tinfo) <$> unpack file tinfo diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/Types.hs new/JuicyPixels-3.2.8/src/Codec/Picture/Types.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/Types.hs 2016-05-30 12:34:56.000000000 +0200 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/Types.hs 2016-09-04 18:31:55.000000000 +0200 @@ -16,7 +16,9 @@ Image( .. ) , MutableImage( .. ) , DynamicImage( .. ) + , PalettedImage( .. ) , Palette + , Palette'( .. ) -- ** Image functions , createMutableImage @@ -65,6 +67,8 @@ , dynamicMap , dynamicPixelMap + , palettedToTrueColor + , palettedAsImage , dropAlphaLayer , withImage , zipPixelComponent3 @@ -389,6 +393,44 @@ | ImageCMYK16 (Image PixelCMYK16) deriving (Typeable) +-- | Type used to expose a palette extracted during reading. +-- Use palettedAsImage to convert it to a palette usable for +-- writing. +data Palette' px = Palette' + { -- | Number of element in pixels. + _paletteSize :: !Int + -- | Real data used by the palette. + , _paletteData :: !(V.Vector (PixelBaseComponent px)) + } + deriving Typeable + +-- | Convert a palette to an image. Used mainly for +-- backward compatibility. +palettedAsImage :: Palette' px -> Image px +palettedAsImage p = Image (_paletteSize p) 1 $ _paletteData p + +-- | Describe an image and it's potential associated +-- palette. If no palette is present, fallback to a +-- DynamicImage +data PalettedImage + = TrueColorImage DynamicImage -- ^ Fallback + | PalettedY8 (Image Pixel8) (Palette' Pixel8) + | PalettedRGB8 (Image Pixel8) (Palette' PixelRGB8) + | PalettedRGBA8 (Image Pixel8) (Palette' PixelRGBA8) + | PalettedRGB16 (Image Pixel8) (Palette' PixelRGB16) + deriving (Typeable) + +-- | Flatten a PalettedImage to a DynamicImage +palettedToTrueColor :: PalettedImage -> DynamicImage +palettedToTrueColor img = case img of + TrueColorImage d -> d + PalettedY8 i p -> ImageY8 $ toTrueColor 1 (_paletteData p) i + PalettedRGB8 i p -> ImageRGB8 $ toTrueColor 3 (_paletteData p) i + PalettedRGBA8 i p -> ImageRGBA8 $ toTrueColor 4 (_paletteData p) i + PalettedRGB16 i p -> ImageRGB16 $ toTrueColor 3 (_paletteData p) i + where + toTrueColor c vec = pixelMap (unsafePixelAt vec . (c *) . fromIntegral) + -- | Helper function to help extract information from dynamic -- image. To get the width of a dynamic image, you can use -- the following snippet: diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture/VectorByteConversion.hs new/JuicyPixels-3.2.8/src/Codec/Picture/VectorByteConversion.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture/VectorByteConversion.hs 2015-01-07 23:27:49.000000000 +0100 +++ new/JuicyPixels-3.2.8/src/Codec/Picture/VectorByteConversion.hs 2016-09-04 14:18:57.000000000 +0200 @@ -1,45 +1,45 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -module Codec.Picture.VectorByteConversion( blitVector - , toByteString - , imageFromUnsafePtr ) where - -import Data.Word( Word8 ) -import Data.Vector.Storable( Vector, unsafeToForeignPtr, unsafeFromForeignPtr0 ) -import Foreign.Storable( Storable, sizeOf ) - -#if !MIN_VERSION_base(4,8,0) -import Foreign.ForeignPtr.Safe( ForeignPtr, castForeignPtr ) -#else -import Foreign.ForeignPtr( ForeignPtr, castForeignPtr ) -#endif - - -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as S - -import Codec.Picture.Types - -blitVector :: Vector Word8 -> Int -> Int -> B.ByteString -blitVector vec atIndex = S.PS ptr (offset + atIndex) - where (ptr, offset, _length) = unsafeToForeignPtr vec - -toByteString :: forall a. (Storable a) => Vector a -> B.ByteString -toByteString vec = S.PS (castForeignPtr ptr) offset (len * size) - where (ptr, offset, len) = unsafeToForeignPtr vec - size = sizeOf (undefined :: a) - --- | Import a image from an unsafe pointer --- The pointer must have a size of width * height * componentCount px -imageFromUnsafePtr :: forall px - . (Pixel px, (PixelBaseComponent px) ~ Word8) - => Int -- ^ Width in pixels - -> Int -- ^ Height in pixels - -> ForeignPtr Word8 -- ^ Pointer to the raw data - -> Image px -imageFromUnsafePtr width height ptr = - Image width height $ unsafeFromForeignPtr0 ptr size - where compCount = componentCount (undefined :: px) - size = width * height * compCount - +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +module Codec.Picture.VectorByteConversion( blitVector + , toByteString + , imageFromUnsafePtr ) where + +import Data.Word( Word8 ) +import Data.Vector.Storable( Vector, unsafeToForeignPtr, unsafeFromForeignPtr0 ) +import Foreign.Storable( Storable, sizeOf ) + +#if !MIN_VERSION_base(4,8,0) +import Foreign.ForeignPtr.Safe( ForeignPtr, castForeignPtr ) +#else +import Foreign.ForeignPtr( ForeignPtr, castForeignPtr ) +#endif + + +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as S + +import Codec.Picture.Types + +blitVector :: Vector Word8 -> Int -> Int -> B.ByteString +blitVector vec atIndex = S.PS ptr (offset + atIndex) + where (ptr, offset, _length) = unsafeToForeignPtr vec + +toByteString :: forall a. (Storable a) => Vector a -> B.ByteString +toByteString vec = S.PS (castForeignPtr ptr) offset (len * size) + where (ptr, offset, len) = unsafeToForeignPtr vec + size = sizeOf (undefined :: a) + +-- | Import a image from an unsafe pointer +-- The pointer must have a size of width * height * componentCount px +imageFromUnsafePtr :: forall px + . (Pixel px, (PixelBaseComponent px) ~ Word8) + => Int -- ^ Width in pixels + -> Int -- ^ Height in pixels + -> ForeignPtr Word8 -- ^ Pointer to the raw data + -> Image px +imageFromUnsafePtr width height ptr = + Image width height $ unsafeFromForeignPtr0 ptr size + where compCount = componentCount (undefined :: px) + size = width * height * compCount + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/JuicyPixels-3.2.7.2/src/Codec/Picture.hs new/JuicyPixels-3.2.8/src/Codec/Picture.hs --- old/JuicyPixels-3.2.7.2/src/Codec/Picture.hs 2016-05-30 12:34:56.000000000 +0200 +++ new/JuicyPixels-3.2.8/src/Codec/Picture.hs 2016-09-04 18:31:55.000000000 +0200 @@ -21,10 +21,12 @@ , readImageWithMetadata , decodeImage , decodeImageWithMetadata + , decodeImageWithPaletteAndMetadata , pixelMap , generateImage , generateFoldImage , withImage + , palettedToTrueColor -- * RGB helper functions , convertRGB8 @@ -145,13 +147,14 @@ import Control.Applicative( (<$>) ) #endif +import Control.Arrow( first ) import Data.Bits( unsafeShiftR ) import Control.DeepSeq( NFData, deepseq ) import qualified Control.Exception as Exc ( catch, IOException ) import Codec.Picture.Metadata( Metadatas ) import Codec.Picture.Bitmap( BmpEncodable , decodeBitmap - , decodeBitmapWithMetadata + , decodeBitmapWithPaletteAndMetadata , writeBitmap, encodeBitmap , encodeDynamicBitmap, writeDynamicBitmap ) import Codec.Picture.Jpg( decodeJpeg @@ -160,7 +163,7 @@ , encodeJpegAtQuality ) import Codec.Picture.Png( PngSavable( .. ) , decodePng - , decodePngWithMetadata + , decodePngWithPaletteAndMetadata , writePng , encodeDynamicPng , encodePalettedPng @@ -170,7 +173,7 @@ import Codec.Picture.Gif( GifDelay , GifLooping( .. ) , decodeGif - , decodeGifWithMetadata + , decodeGifWithPaletteAndMetadata , decodeGifImages , encodeGifImage , encodeGifImageWithPalette @@ -187,13 +190,13 @@ , writeHDR ) import Codec.Picture.Tiff( decodeTiff - , decodeTiffWithMetadata + , decodeTiffWithPaletteAndMetadata , TiffSaveable , encodeTiff , writeTiff ) import Codec.Picture.Tga( TgaSaveable , decodeTga - , decodeTgaWithMetadata + , decodeTgaWithPaletteAndMetadata , encodeTga , writeTga ) @@ -358,19 +361,24 @@ ImageCMYK8 img -> convertImage img ImageCMYK16 img -> convertImage (decimateBitDepth img :: Image PixelCMYK8) +-- | Equivalent to 'decodeImage', but also provide potential metadatas +-- present in the given file and the palettes if the format provides them. +decodeImageWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodeImageWithPaletteAndMetadata str = eitherLoad str + [ ("Jpeg", fmap (first TrueColorImage) . decodeJpegWithMetadata) + , ("PNG", decodePngWithPaletteAndMetadata) + , ("Bitmap", decodeBitmapWithPaletteAndMetadata) + , ("GIF", decodeGifWithPaletteAndMetadata) + , ("HDR", fmap (first TrueColorImage) . decodeHDRWithMetadata) + , ("Tiff", decodeTiffWithPaletteAndMetadata) + , ("TGA", decodeTgaWithPaletteAndMetadata) + ] -- | Equivalent to 'decodeImage', but also provide potential metadatas -- present in the given file. decodeImageWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) -decodeImageWithMetadata str = eitherLoad str - [ ("Jpeg", decodeJpegWithMetadata) - , ("PNG", decodePngWithMetadata) - , ("Bitmap", decodeBitmapWithMetadata) - , ("GIF", decodeGifWithMetadata) - , ("HDR", decodeHDRWithMetadata) - , ("Tiff", decodeTiffWithMetadata) - , ("TGA", decodeTgaWithMetadata) - ] +decodeImageWithMetadata = + fmap (first palettedToTrueColor) . decodeImageWithPaletteAndMetadata -- | Helper function trying to load a png file from a file on disk. readPng :: FilePath -> IO (Either String DynamicImage)
