diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.2.9.5 +Version: 3.3 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description: <> @@ -28,7 +28,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.2.9.5 + Tag: v3.3 Flag Mmap Description: Enable the file loading via mmap (memory map) diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,6 +1,15 @@ Change log ========== +v3.3 July 2018 +-------------- + + * New: Eq instances for image + * Fix: color gif resolution offset + * New: support for Float Tiff + * Breaking change: New `ImageY32` constructor for `Dynamic` + hence the version bump. + v3.2.9.5 March 2018 ------------------- diff --git a/src/Codec/Picture.hs b/src/Codec/Picture.hs --- a/src/Codec/Picture.hs +++ b/src/Codec/Picture.hs @@ -293,6 +293,13 @@ decimateWord16 (Image w h da) = Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 8) da +decimateWord32 :: ( Pixel px1, Pixel px2 + , PixelBaseComponent px1 ~ Pixel32 + , PixelBaseComponent px2 ~ Pixel8 + ) => Image px1 -> Image px2 +decimateWord32 (Image w h da) = + Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 24) da + decimateFloat :: ( Pixel px1, Pixel px2 , PixelBaseComponent px1 ~ PixelF , PixelBaseComponent px2 ~ Pixel8 @@ -303,6 +310,9 @@ instance Decimable Pixel16 Pixel8 where decimateBitDepth = decimateWord16 +instance Decimable Pixel32 Pixel8 where + decimateBitDepth = decimateWord32 + instance Decimable PixelYA16 PixelYA8 where decimateBitDepth = decimateWord16 @@ -321,13 +331,14 @@ instance Decimable PixelRGBF PixelRGB8 where decimateBitDepth = decimateFloat --- | Convert by any mean possible a dynamic image to an image +-- | Convert by any means 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) + ImageY32 img -> promoteImage (decimateBitDepth img :: Image Pixel8) ImageYF img -> promoteImage (decimateBitDepth img :: Image Pixel8) ImageYA8 img -> promoteImage img ImageYA16 img -> promoteImage (decimateBitDepth img :: Image PixelYA8) @@ -341,7 +352,7 @@ ImageCMYK16 img -> promoteImage (convertImage (decimateBitDepth img :: Image PixelCMYK8) :: Image PixelRGB8) --- | Convert by any mean possible a dynamic image to an image +-- | Convert by any means 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 @@ -349,6 +360,7 @@ convertRGB8 dynImage = case dynImage of ImageY8 img -> promoteImage img ImageY16 img -> promoteImage (decimateBitDepth img :: Image Pixel8) + ImageY32 img -> promoteImage (decimateBitDepth img :: Image Pixel8) ImageYF img -> promoteImage (decimateBitDepth img :: Image Pixel8) ImageYA8 img -> promoteImage img ImageYA16 img -> promoteImage (decimateBitDepth img :: Image PixelYA8) diff --git a/src/Codec/Picture/Gif.hs b/src/Codec/Picture/Gif.hs --- a/src/Codec/Picture/Gif.hs +++ b/src/Codec/Picture/Gif.hs @@ -1,859 +1,859 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} --- | Module implementing GIF decoding. -module Codec.Picture.Gif ( -- * Reading - decodeGif - , decodeGifWithMetadata - , decodeGifWithPaletteAndMetadata - , decodeGifImages - , getDelaysGifImages - - -- * Writing - , GifDelay - , GifLooping( .. ) - , encodeGifImage - , encodeGifImageWithPalette - , encodeGifImages - - , writeGifImage - , writeGifImageWithPalette - , writeGifImages - , greyPalette - ) where - -#if !MIN_VERSION_base(4,8,0) -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 ) - -import Data.Bits( (.&.), (.|.) - , unsafeShiftR - , unsafeShiftL - , testBit, setBit ) -import Data.Word( Word8, Word16 ) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as L -import qualified Data.Vector.Storable as V -import qualified Data.Vector.Storable.Mutable as M - -import Data.Binary( Binary(..), encode ) -import Data.Binary.Get( Get - , getWord8 - , getWord16le - , getByteString - , bytesRead - , skip - ) - -import Data.Binary.Put( Put - , putWord8 - , putWord16le - , putByteString - ) - -import Codec.Picture.InternalHelper -import Codec.Picture.Types -import Codec.Picture.Metadata( Metadatas - , SourceFormat( SourceGif ) - , basicMetadata ) -import Codec.Picture.Gif.LZW -import Codec.Picture.Gif.LZWEncoding -import Codec.Picture.BitWriter - --- | Delay to wait before showing the next Gif image. --- The delay is expressed in 100th of seconds. -type GifDelay = Int - --- | Help to control the behaviour of GIF animation looping. -data GifLooping = - -- | The animation will stop once the end is reached - LoopingNever - -- | The animation will restart once the end is reached - | LoopingForever - -- | The animation will repeat n times before stoping - | LoopingRepeat Word16 - -{- - ::= Header * Trailer - - ::= Logical Screen Descriptor [Global Color Table] - - ::= | - - - ::= [Graphic Control Extension] - - ::= | - Plain Text Extension - - ::= Image Descriptor [Local Color Table] Image Data - - ::= Application Extension | - Comment Extension - -} - --------------------------------------------------- ----- GifVersion --------------------------------------------------- -data GifVersion = GIF87a | GIF89a - -gif87aSignature, gif89aSignature :: B.ByteString -gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a" -gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a" - -instance Binary GifVersion where - put GIF87a = putByteString gif87aSignature - put GIF89a = putByteString gif89aSignature - - get = do - sig <- getByteString (B.length gif87aSignature) - case (sig == gif87aSignature, sig == gif89aSignature) of - (True, _) -> pure GIF87a - (_ , True) -> pure GIF89a - _ -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig) - - --------------------------------------------------- ----- LogicalScreenDescriptor --------------------------------------------------- --- | Section 18 of spec-gif89a -data LogicalScreenDescriptor = LogicalScreenDescriptor - { -- | Stored on 16 bits - screenWidth :: !Word16 - -- | Stored on 16 bits - , screenHeight :: !Word16 - -- | Stored on 8 bits - , backgroundIndex :: !Word8 - - -- | Stored on 1 bit - , hasGlobalMap :: !Bool - -- | Stored on 3 bits - , colorResolution :: !Word8 - -- | Stored on 1 bit - , isColorTableSorted :: !Bool - -- | Stored on 3 bits - , colorTableSize :: !Word8 - } - -instance Binary LogicalScreenDescriptor where - put v = do - putWord16le $ screenWidth v - putWord16le $ screenHeight v - let globalMapField - | hasGlobalMap v = 0x80 - | otherwise = 0 - - colorTableSortedField - | isColorTableSorted v = 0x08 - | otherwise = 0 - - tableSizeField = (colorTableSize v - 1) .&. 7 - - colorResolutionField = - ((colorResolution v - 1) .&. 7) `unsafeShiftL` 5 - - packedField = globalMapField - .|. colorTableSortedField - .|. tableSizeField - .|. colorResolutionField - - putWord8 packedField - putWord8 0 -- aspect ratio - putWord8 $ backgroundIndex v - - get = do - w <- getWord16le - h <- getWord16le - packedField <- getWord8 - backgroundColorIndex <- getWord8 - _aspectRatio <- getWord8 - return LogicalScreenDescriptor - { screenWidth = w - , screenHeight = h - , hasGlobalMap = packedField `testBit` 7 - , colorResolution = (packedField `unsafeShiftR` 5) .&. 0x7 + 1 - , isColorTableSorted = packedField `testBit` 3 - , colorTableSize = (packedField .&. 0x7) + 1 - , backgroundIndex = backgroundColorIndex - } - - --------------------------------------------------- ----- ImageDescriptor --------------------------------------------------- --- | Section 20 of spec-gif89a -data ImageDescriptor = ImageDescriptor - { gDescPixelsFromLeft :: !Word16 - , gDescPixelsFromTop :: !Word16 - , gDescImageWidth :: !Word16 - , gDescImageHeight :: !Word16 - , gDescHasLocalMap :: !Bool - , gDescIsInterlaced :: !Bool - , gDescIsImgDescriptorSorted :: !Bool - , gDescLocalColorTableSize :: !Word8 - } - -imageSeparator, extensionIntroducer, gifTrailer :: Word8 -imageSeparator = 0x2C -extensionIntroducer = 0x21 -gifTrailer = 0x3B - -graphicControlLabel, commentLabel, plainTextLabel, applicationLabel :: Word8 -plainTextLabel = 0x01 -graphicControlLabel = 0xF9 -commentLabel = 0xFE -applicationLabel = 0xFF - - -parseDataBlocks :: Get B.ByteString -parseDataBlocks = B.concat <$> (getWord8 >>= aux) - where aux 0 = pure [] - aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux) - -putDataBlocks :: B.ByteString -> Put -putDataBlocks wholeString = putSlices wholeString >> putWord8 0 - where putSlices str | B.length str == 0 = pure () - | B.length str > 0xFF = - let (before, after) = B.splitAt 0xFF str in - putWord8 0xFF >> putByteString before >> putSlices after - putSlices str = - putWord8 (fromIntegral $ B.length str) >> putByteString str - -data DisposalMethod - = DisposalAny - | DisposalDoNot - | DisposalRestoreBackground - | DisposalRestorePrevious - | DisposalUnknown Word8 - -disposalMethodOfCode :: Word8 -> DisposalMethod -disposalMethodOfCode v = case v of - 0 -> DisposalAny - 1 -> DisposalDoNot - 2 -> DisposalRestoreBackground - 3 -> DisposalRestorePrevious - n -> DisposalUnknown n - -codeOfDisposalMethod :: DisposalMethod -> Word8 -codeOfDisposalMethod v = case v of - DisposalAny -> 0 - DisposalDoNot -> 1 - DisposalRestoreBackground -> 2 - DisposalRestorePrevious -> 3 - DisposalUnknown n -> n - -data GraphicControlExtension = GraphicControlExtension - { gceDisposalMethod :: !DisposalMethod -- ^ Stored on 3 bits - , gceUserInputFlag :: !Bool - , gceTransparentFlag :: !Bool - , gceDelay :: !Word16 - , gceTransparentColorIndex :: !Word8 - } - -instance Binary GraphicControlExtension where - put v = do - putWord8 extensionIntroducer - putWord8 graphicControlLabel - putWord8 0x4 -- size - let disposalCode = codeOfDisposalMethod $ gceDisposalMethod v - disposalField = - (disposalCode .&. 0x7) `unsafeShiftL` 2 - - userInputField - | gceUserInputFlag v = 0 `setBit` 1 - | otherwise = 0 - - transparentField - | gceTransparentFlag v = 0 `setBit` 0 - | otherwise = 0 - - packedFields = disposalField - .|. userInputField - .|. transparentField - - putWord8 packedFields - putWord16le $ gceDelay v - putWord8 $ gceTransparentColorIndex v - putWord8 0 -- blockTerminator - - get = do - -- due to missing lookahead - {-_extensionLabel <- getWord8-} - _size <- getWord8 - packedFields <- getWord8 - delay <- getWord16le - idx <- getWord8 - _blockTerminator <- getWord8 - return GraphicControlExtension - { gceDisposalMethod = - disposalMethodOfCode $ - (packedFields `unsafeShiftR` 2) .&. 0x07 - , gceUserInputFlag = packedFields `testBit` 1 - , gceTransparentFlag = packedFields `testBit` 0 - , gceDelay = delay - , gceTransparentColorIndex = idx - } - -data GifImage = GifImage - { imgDescriptor :: !ImageDescriptor - , imgLocalPalette :: !(Maybe Palette) - , imgLzwRootSize :: !Word8 - , imgData :: B.ByteString - } - -instance Binary GifImage where - put img = do - let descriptor = imgDescriptor img - put descriptor - case ( imgLocalPalette img - , gDescHasLocalMap $ imgDescriptor img) of - (Nothing, _) -> return () - (Just _, False) -> return () - (Just p, True) -> - putPalette (fromIntegral $ gDescLocalColorTableSize descriptor) p - putWord8 $ imgLzwRootSize img - putDataBlocks $ imgData img - - get = do - desc <- get - let hasLocalColorTable = gDescHasLocalMap desc - palette <- if hasLocalColorTable - then Just <$> getPalette (gDescLocalColorTableSize desc) - else pure Nothing - - GifImage desc palette <$> getWord8 <*> parseDataBlocks - -data Block = BlockImage GifImage - | BlockGraphicControl GraphicControlExtension - -skipSubDataBlocks :: Get () -skipSubDataBlocks = do - s <- fromIntegral <$> getWord8 - unless (s == 0) $ - skip s >> skipSubDataBlocks - -parseGifBlocks :: Get [Block] -parseGifBlocks = getWord8 >>= blockParse - where - blockParse v - | v == gifTrailer = pure [] - | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks - | v == extensionIntroducer = getWord8 >>= extensionParse - - blockParse v = do - readPosition <- bytesRead - fail ("Unrecognized gif block " ++ show v ++ " @" ++ show readPosition) - - extensionParse code - | code == graphicControlLabel = - (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks - | code == commentLabel = skipSubDataBlocks >> parseGifBlocks - | code `elem` [plainTextLabel, applicationLabel] = - fromIntegral <$> getWord8 >>= skip >> skipSubDataBlocks >> parseGifBlocks - | otherwise = parseDataBlocks >> parseGifBlocks - - -instance Binary ImageDescriptor where - put v = do - putWord8 imageSeparator - putWord16le $ gDescPixelsFromLeft v - putWord16le $ gDescPixelsFromTop v - putWord16le $ gDescImageWidth v - putWord16le $ gDescImageHeight v - let localMapField - | gDescHasLocalMap v = 0 `setBit` 7 - | otherwise = 0 - - isInterlacedField - | gDescIsInterlaced v = 0 `setBit` 6 - | otherwise = 0 - - isImageDescriptorSorted - | gDescIsImgDescriptorSorted v = 0 `setBit` 5 - | otherwise = 0 - - localSize = gDescLocalColorTableSize v - tableSizeField - | localSize > 0 = (localSize - 1) .&. 0x7 - | otherwise = 0 - - packedFields = localMapField - .|. isInterlacedField - .|. isImageDescriptorSorted - .|. tableSizeField - putWord8 packedFields - - get = do - -- due to missing lookahead - {-_imageSeparator <- getWord8-} - imgLeftPos <- getWord16le - imgTopPos <- getWord16le - imgWidth <- getWord16le - imgHeight <- getWord16le - packedFields <- getWord8 - let tableSize = packedFields .&. 0x7 - return ImageDescriptor - { gDescPixelsFromLeft = imgLeftPos - , gDescPixelsFromTop = imgTopPos - , gDescImageWidth = imgWidth - , gDescImageHeight = imgHeight - , gDescHasLocalMap = packedFields `testBit` 7 - , gDescIsInterlaced = packedFields `testBit` 6 - , gDescIsImgDescriptorSorted = packedFields `testBit` 5 - , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0 - } - - --------------------------------------------------- ----- Palette --------------------------------------------------- -getPalette :: Word8 -> Get Palette -getPalette bitDepth = - Image size 1 . V.fromList <$> replicateM (size * 3) get - where size = 2 ^ (fromIntegral bitDepth :: Int) - -putPalette :: Int -> Palette -> Put -putPalette size pal = do - V.mapM_ putWord8 (imageData pal) - replicateM_ missingColorComponent (putWord8 0) - where elemCount = 2 ^ size - missingColorComponent = (elemCount - imageWidth pal) * 3 - --------------------------------------------------- ----- GifImage --------------------------------------------------- -data GifHeader = GifHeader - { gifVersion :: GifVersion - , gifScreenDescriptor :: LogicalScreenDescriptor - , gifGlobalMap :: !Palette - } - -instance Binary GifHeader where - put v = do - put $ gifVersion v - let descr = gifScreenDescriptor v - put descr - putPalette (fromIntegral $ colorTableSize descr) $ gifGlobalMap v - - get = do - version <- get - screenDesc <- get - - palette <- - if hasGlobalMap screenDesc then - getPalette $ colorTableSize screenDesc - else - return greyPalette - - return GifHeader - { gifVersion = version - , gifScreenDescriptor = screenDesc - , gifGlobalMap = palette - } - -data GifFile = GifFile - { gifHeader :: !GifHeader - , gifImages :: [(Maybe GraphicControlExtension, GifImage)] - , gifLoopingBehaviour :: GifLooping - } - -putLooping :: GifLooping -> Put -putLooping LoopingNever = return () -putLooping LoopingForever = putLooping $ LoopingRepeat 0 -putLooping (LoopingRepeat count) = do - putWord8 extensionIntroducer - putWord8 applicationLabel - putWord8 11 -- the size - putByteString $ BC.pack "NETSCAPE2.0" - putWord8 3 -- size of sub block - putWord8 1 - putWord16le count - putWord8 0 - -associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)] -associateDescr [] = [] -associateDescr [BlockGraphicControl _] = [] -associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = - associateDescr rest -associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs -associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) = - (Just ctrl, img) : associateDescr xs - -instance Binary GifFile where - put v = do - put $ gifHeader v - let putter (Nothing, i) = put i - putter (Just a, i) = put a >> put i - putLooping $ gifLoopingBehaviour v - mapM_ putter $ gifImages v - put gifTrailer - - get = do - hdr <- get - blocks <- parseGifBlocks - return GifFile { gifHeader = hdr - , gifImages = associateDescr blocks - , gifLoopingBehaviour = LoopingNever - } - -substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8 -substituteColors palette = pixelMap swaper - where swaper n = pixelAt palette (fromIntegral n) 0 - -substituteColorsWithTransparency :: Int -> Image PixelRGBA8 -> Image Pixel8 -> Image PixelRGBA8 -substituteColorsWithTransparency transparent palette = pixelMap swaper where - swaper n | ix == transparent = PixelRGBA8 0 0 0 0 - | otherwise = promotePixel $ pixelAt palette ix 0 - where ix = fromIntegral n - - -decodeImage :: GifImage -> Image Pixel8 -decodeImage img = runST $ runBoolReader $ do - outputVector <- lift . M.new $ width * height - decodeLzw (imgData img) 12 lzwRoot outputVector - frozenData <- lift $ V.unsafeFreeze outputVector - return . deinterlaceGif $ Image - { imageWidth = width - , imageHeight = height - , imageData = frozenData - } - where lzwRoot = fromIntegral $ imgLzwRootSize img - width = fromIntegral $ gDescImageWidth descriptor - height = fromIntegral $ gDescImageHeight descriptor - isInterlaced = gDescIsInterlaced descriptor - descriptor = imgDescriptor img - - deinterlaceGif | not isInterlaced = id - | otherwise = deinterlaceGifImage - -deinterlaceGifImage :: Image Pixel8 -> Image Pixel8 -deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h - where lineIndices = gifInterlacingIndices h - generator x y = pixelAt img x y' - where y' = lineIndices V.! y - -gifInterlacingIndices :: Int -> V.Vector Int -gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices - where indices = flip zip [0..] $ - concat [ [0, 8 .. height - 1] - , [4, 4 + 8 .. height - 1] - , [2, 2 + 4 .. height - 1] - , [1, 1 + 2 .. height - 1] - ] - -paletteOf :: (ColorConvertible PixelRGB8 px) - => Image px -> GifImage -> Image px -paletteOf global GifImage { imgLocalPalette = Nothing } = global -paletteOf _ GifImage { imgLocalPalette = Just p } = promoteImage p - -getFrameDelays :: GifFile -> [GifDelay] -getFrameDelays GifFile { gifImages = [] } = [] -getFrameDelays GifFile { gifImages = imgs } = map extractDelay imgs - where extractDelay (ext, _) = - case ext of - Nothing -> 0 - Just e -> fromIntegral $ gceDelay e - -transparentColorOf :: Maybe GraphicControlExtension -> Int -transparentColorOf Nothing = 300 -transparentColorOf (Just ext) - | gceTransparentFlag ext = fromIntegral $ gceTransparentColorIndex ext - | otherwise = 300 - -hasTransparency :: Maybe GraphicControlExtension -> Bool -hasTransparency Nothing = False -hasTransparency (Just control) = gceTransparentFlag control - -decodeAllGifImages :: GifFile -> [PalettedImage] -decodeAllGifImages GifFile { gifImages = [] } = [] -decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette - , gifScreenDescriptor = wholeDescriptor } - , gifImages = (firstControl, firstImage) : rest } - | not (hasTransparency firstControl) = - let backImage = - generateImage (\_ _ -> backgroundColor) globalWidth globalHeight - thisPalette = paletteOf palette firstImage - baseImage = decodeImage firstImage - initState = - (thisPalette, firstControl, substituteColors thisPalette baseImage) - scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage - palette' = Palette' - { _paletteSize = imageWidth thisPalette - , _paletteData = imageData thisPalette - } - in - PalettedRGB8 baseImage palette' : - [TrueColorImage $ ImageRGB8 img | (_, _, img) <- tail $ scanl scanner initState rest] - - | otherwise = - let backImage :: Image PixelRGBA8 - backImage = - generateImage (\_ _ -> transparentBackground) globalWidth globalHeight - - thisPalette :: Image PixelRGBA8 - thisPalette = paletteOf (promoteImage palette) firstImage - - transparentCode = transparentColorOf firstControl - decoded = - substituteColorsWithTransparency transparentCode thisPalette $ - decodeImage firstImage - - initState = (thisPalette, firstControl, decoded) - scanner = - gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in - [TrueColorImage $ ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest] - - where - globalWidth = fromIntegral $ screenWidth wholeDescriptor - globalHeight = fromIntegral $ screenHeight wholeDescriptor - - transparentBackground = PixelRGBA8 r g b 0 - where PixelRGB8 r g b = backgroundColor - - backgroundColor - | hasGlobalMap wholeDescriptor = - pixelAt palette (fromIntegral $ backgroundIndex wholeDescriptor) 0 - | otherwise = PixelRGB8 0 0 0 - -gifAnimationApplyer :: forall px. (ColorConvertible PixelRGB8 px) - => (Int, Int) -> Image px -> Image px - -> (Image px, Maybe GraphicControlExtension, Image px) - -> (Maybe GraphicControlExtension, GifImage) - -> (Image px, Maybe GraphicControlExtension, Image px) -gifAnimationApplyer (globalWidth, globalHeight) globalPalette backgroundImage - (_, prevControl, img1) - (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = - (thisPalette, controlExt, thisImage) - where - thisPalette :: Image px - thisPalette = paletteOf globalPalette img2 - - thisImage = generateImage pixeler globalWidth globalHeight - localWidth = fromIntegral $ gDescImageWidth descriptor - localHeight = fromIntegral $ gDescImageHeight descriptor - - left = fromIntegral $ gDescPixelsFromLeft descriptor - top = fromIntegral $ gDescPixelsFromTop descriptor - - isPixelInLocalImage x y = - x >= left && x < left + localWidth && y >= top && y < top + localHeight - - decoded :: Image Pixel8 - decoded = decodeImage img2 - - transparent :: Int - transparent = case controlExt of - Nothing -> 300 - Just ext -> if gceTransparentFlag ext - then fromIntegral $ gceTransparentColorIndex ext - else 300 - - oldImage = case gceDisposalMethod <$> prevControl of - Nothing -> img1 - Just DisposalAny -> img1 - Just DisposalDoNot -> img1 - Just DisposalRestoreBackground -> backgroundImage - Just DisposalRestorePrevious -> img1 - Just (DisposalUnknown _) -> img1 - - pixeler x y - | isPixelInLocalImage x y && code /= transparent = val where - code = fromIntegral $ pixelAt decoded (x - left) (y - top) - val = pixelAt thisPalette (fromIntegral code) 0 - pixeler x y = pixelAt oldImage x y - -decodeFirstGifImage :: GifFile -> Either String (PalettedImage, Metadatas) -decodeFirstGifImage img@GifFile { gifImages = (firstImage:_) } = - case decodeAllGifImages img { gifImages = [firstImage] } of - [] -> Left "No image after decoding" - (i:_) -> Right (i, basicMetadata SourceGif (screenWidth hdr) (screenHeight hdr)) - where hdr = gifScreenDescriptor $ gifHeader img -decodeFirstGifImage _ = Left "No image in gif file" - --- | Transform a raw gif image to an image, without modifying the pixels. This --- function can output the following images: --- --- * 'ImageRGB8' --- --- * 'ImageRGBA8' --- -decodeGif :: B.ByteString -> Either String DynamicImage -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: --- --- * 'ImageRGB8' --- --- * 'ImageRGBA8' --- --- Metadatas include Width & Height information. --- -decodeGifWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) -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 = fmap palettedToTrueColor . decodeAllGifImages <$> decode img - --- | Extract a list of frame delays from a raw gif. -getDelaysGifImages :: B.ByteString -> Either String [GifDelay] -getDelaysGifImages img = getFrameDelays <$> decode img - --- | Default palette to produce greyscale images. -greyPalette :: Palette -greyPalette = generateImage toGrey 256 1 - where toGrey x _ = PixelRGB8 ix ix ix - where ix = fromIntegral x - -checkGifImageSizes :: [(a, b, Image px)] -> Bool -checkGifImageSizes [] = False -checkGifImageSizes ((_, _, img) : rest) = all checkDimension rest - where width = imageWidth img - height = imageHeight img - - checkDimension (_,_,Image { imageWidth = w, imageHeight = h }) = - w == width && h == height - -checkPaletteValidity :: [(Palette, a, b)] -> Bool -checkPaletteValidity [] = False -checkPaletteValidity lst = - and [h == 1 && w > 0 && w <= 256 | (p, _, _) <- lst - , let w = imageWidth p - h = imageHeight p ] - -areIndexAbsentFromPalette :: (Palette, a, Image Pixel8) -> Bool -areIndexAbsentFromPalette (palette, _, img) = V.any isTooBig $ imageData img - where paletteElemCount = imageWidth palette - isTooBig v = fromIntegral v >= paletteElemCount - -computeMinimumLzwKeySize :: Palette -> Int -computeMinimumLzwKeySize Image { imageWidth = itemCount } = go 2 - where go k | 2 ^ k >= itemCount = k - | otherwise = go $ k + 1 - --- | Encode a gif animation to a bytestring. --- --- * Every image must have the same size --- --- * Every palette must have between one and 256 colors. --- -encodeGifImages :: GifLooping -> [(Palette, GifDelay, Image Pixel8)] - -> Either String L.ByteString -encodeGifImages _ [] = Left "No image in list" -encodeGifImages _ imageList - | not $ checkGifImageSizes imageList = Left "Gif images have different size" - | not $ checkPaletteValidity imageList = - Left $ "Invalid palette size " ++ concat [show (imageWidth pal) ++ " "| (pal, _, _) <- imageList ] - | any areIndexAbsentFromPalette imageList = Left "Image contains indexes absent from the palette" -encodeGifImages looping imageList@((firstPalette, _,firstImage):_) = Right $ encode allFile - where - version = case imageList of - [] -> GIF87a - [_] -> GIF87a - _:_:_ -> GIF89a - - allFile = GifFile - { gifHeader = GifHeader - { gifVersion = version - , gifScreenDescriptor = logicalScreen - , gifGlobalMap = firstPalette - } - , gifImages = toSerialize - , gifLoopingBehaviour = looping - } - - logicalScreen = LogicalScreenDescriptor - { screenWidth = fromIntegral $ imageWidth firstImage - , screenHeight = fromIntegral $ imageHeight firstImage - , backgroundIndex = 0 - , hasGlobalMap = True - , colorResolution = 8 - , isColorTableSorted = False - , colorTableSize = 8 - } - - paletteEqual p = imageData firstPalette == imageData p - - controlExtension 0 = Nothing - controlExtension delay = Just GraphicControlExtension - { gceDisposalMethod = DisposalAny - , gceUserInputFlag = False - , gceTransparentFlag = False - , gceDelay = fromIntegral delay - , gceTransparentColorIndex = 0 - } - - toSerialize = [(controlExtension delay, GifImage - { imgDescriptor = imageDescriptor lzwKeySize (paletteEqual palette) img - , imgLocalPalette = Just palette - , imgLzwRootSize = fromIntegral lzwKeySize - , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img - }) | (palette, delay, img) <- imageList - , let lzwKeySize = computeMinimumLzwKeySize palette - ] - - imageDescriptor paletteSize palEqual img = ImageDescriptor - { gDescPixelsFromLeft = 0 - , gDescPixelsFromTop = 0 - , gDescImageWidth = fromIntegral $ imageWidth img - , gDescImageHeight = fromIntegral $ imageHeight img - , gDescHasLocalMap = paletteSize > 0 && not palEqual - , gDescIsInterlaced = False - , gDescIsImgDescriptorSorted = False - , gDescLocalColorTableSize = if palEqual then 0 else fromIntegral paletteSize - } - --- | Encode a greyscale image to a bytestring. -encodeGifImage :: Image Pixel8 -> L.ByteString -encodeGifImage img = case encodeGifImages LoopingNever [(greyPalette, 0, img)] of - Left err -> error $ "Impossible:" ++ err - Right v -> v - --- | Encode an image with a given palette. --- Can return errors if the palette is ill-formed. --- --- * A palette must have between 1 and 256 colors --- -encodeGifImageWithPalette :: Image Pixel8 -> Palette -> Either String L.ByteString -encodeGifImageWithPalette img palette = - encodeGifImages LoopingNever [(palette, 0, img)] - --- | Write a greyscale in a gif file on the disk. -writeGifImage :: FilePath -> Image Pixel8 -> IO () -writeGifImage file = L.writeFile file . encodeGifImage - --- | Write a list of images as a gif animation in a file. --- --- * Every image must have the same size --- --- * Every palette must have between one and 256 colors. --- -writeGifImages :: FilePath -> GifLooping -> [(Palette, GifDelay, Image Pixel8)] - -> Either String (IO ()) -writeGifImages file looping lst = L.writeFile file <$> encodeGifImages looping lst - --- | Write a gif image with a palette to a file. --- --- * A palette must have between 1 and 256 colors --- -writeGifImageWithPalette :: FilePath -> Image Pixel8 -> Palette - -> Either String (IO ()) -writeGifImageWithPalette file img palette = - L.writeFile file <$> encodeGifImageWithPalette img palette - +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +-- | Module implementing GIF decoding. +module Codec.Picture.Gif ( -- * Reading + decodeGif + , decodeGifWithMetadata + , decodeGifWithPaletteAndMetadata + , decodeGifImages + , getDelaysGifImages + + -- * Writing + , GifDelay + , GifLooping( .. ) + , encodeGifImage + , encodeGifImageWithPalette + , encodeGifImages + + , writeGifImage + , writeGifImageWithPalette + , writeGifImages + , greyPalette + ) where + +#if !MIN_VERSION_base(4,8,0) +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 ) + +import Data.Bits( (.&.), (.|.) + , unsafeShiftR + , unsafeShiftL + , testBit, setBit ) +import Data.Word( Word8, Word16 ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as M + +import Data.Binary( Binary(..), encode ) +import Data.Binary.Get( Get + , getWord8 + , getWord16le + , getByteString + , bytesRead + , skip + ) + +import Data.Binary.Put( Put + , putWord8 + , putWord16le + , putByteString + ) + +import Codec.Picture.InternalHelper +import Codec.Picture.Types +import Codec.Picture.Metadata( Metadatas + , SourceFormat( SourceGif ) + , basicMetadata ) +import Codec.Picture.Gif.LZW +import Codec.Picture.Gif.LZWEncoding +import Codec.Picture.BitWriter + +-- | Delay to wait before showing the next Gif image. +-- The delay is expressed in 100th of seconds. +type GifDelay = Int + +-- | Help to control the behaviour of GIF animation looping. +data GifLooping = + -- | The animation will stop once the end is reached + LoopingNever + -- | The animation will restart once the end is reached + | LoopingForever + -- | The animation will repeat n times before stoping + | LoopingRepeat Word16 + +{- + ::= Header * Trailer + + ::= Logical Screen Descriptor [Global Color Table] + + ::= | + + + ::= [Graphic Control Extension] + + ::= | + Plain Text Extension + + ::= Image Descriptor [Local Color Table] Image Data + + ::= Application Extension | + Comment Extension + -} + +-------------------------------------------------- +---- GifVersion +-------------------------------------------------- +data GifVersion = GIF87a | GIF89a + +gif87aSignature, gif89aSignature :: B.ByteString +gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a" +gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a" + +instance Binary GifVersion where + put GIF87a = putByteString gif87aSignature + put GIF89a = putByteString gif89aSignature + + get = do + sig <- getByteString (B.length gif87aSignature) + case (sig == gif87aSignature, sig == gif89aSignature) of + (True, _) -> pure GIF87a + (_ , True) -> pure GIF89a + _ -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig) + + +-------------------------------------------------- +---- LogicalScreenDescriptor +-------------------------------------------------- +-- | Section 18 of spec-gif89a +data LogicalScreenDescriptor = LogicalScreenDescriptor + { -- | Stored on 16 bits + screenWidth :: !Word16 + -- | Stored on 16 bits + , screenHeight :: !Word16 + -- | Stored on 8 bits + , backgroundIndex :: !Word8 + + -- | Stored on 1 bit + , hasGlobalMap :: !Bool + -- | Stored on 3 bits + , colorResolution :: !Word8 + -- | Stored on 1 bit + , isColorTableSorted :: !Bool + -- | Stored on 3 bits + , colorTableSize :: !Word8 + } + +instance Binary LogicalScreenDescriptor where + put v = do + putWord16le $ screenWidth v + putWord16le $ screenHeight v + let globalMapField + | hasGlobalMap v = 0x80 + | otherwise = 0 + + colorTableSortedField + | isColorTableSorted v = 0x08 + | otherwise = 0 + + tableSizeField = (colorTableSize v - 1) .&. 7 + + colorResolutionField = + ((colorResolution v - 1) .&. 7) `unsafeShiftL` 4 + + packedField = globalMapField + .|. colorTableSortedField + .|. tableSizeField + .|. colorResolutionField + + putWord8 packedField + putWord8 0 -- aspect ratio + putWord8 $ backgroundIndex v + + get = do + w <- getWord16le + h <- getWord16le + packedField <- getWord8 + backgroundColorIndex <- getWord8 + _aspectRatio <- getWord8 + return LogicalScreenDescriptor + { screenWidth = w + , screenHeight = h + , hasGlobalMap = packedField `testBit` 7 + , colorResolution = (packedField `unsafeShiftR` 4) .&. 0x7 + 1 + , isColorTableSorted = packedField `testBit` 3 + , colorTableSize = (packedField .&. 0x7) + 1 + , backgroundIndex = backgroundColorIndex + } + + +-------------------------------------------------- +---- ImageDescriptor +-------------------------------------------------- +-- | Section 20 of spec-gif89a +data ImageDescriptor = ImageDescriptor + { gDescPixelsFromLeft :: !Word16 + , gDescPixelsFromTop :: !Word16 + , gDescImageWidth :: !Word16 + , gDescImageHeight :: !Word16 + , gDescHasLocalMap :: !Bool + , gDescIsInterlaced :: !Bool + , gDescIsImgDescriptorSorted :: !Bool + , gDescLocalColorTableSize :: !Word8 + } + +imageSeparator, extensionIntroducer, gifTrailer :: Word8 +imageSeparator = 0x2C +extensionIntroducer = 0x21 +gifTrailer = 0x3B + +graphicControlLabel, commentLabel, plainTextLabel, applicationLabel :: Word8 +plainTextLabel = 0x01 +graphicControlLabel = 0xF9 +commentLabel = 0xFE +applicationLabel = 0xFF + + +parseDataBlocks :: Get B.ByteString +parseDataBlocks = B.concat <$> (getWord8 >>= aux) + where aux 0 = pure [] + aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux) + +putDataBlocks :: B.ByteString -> Put +putDataBlocks wholeString = putSlices wholeString >> putWord8 0 + where putSlices str | B.length str == 0 = pure () + | B.length str > 0xFF = + let (before, after) = B.splitAt 0xFF str in + putWord8 0xFF >> putByteString before >> putSlices after + putSlices str = + putWord8 (fromIntegral $ B.length str) >> putByteString str + +data DisposalMethod + = DisposalAny + | DisposalDoNot + | DisposalRestoreBackground + | DisposalRestorePrevious + | DisposalUnknown Word8 + +disposalMethodOfCode :: Word8 -> DisposalMethod +disposalMethodOfCode v = case v of + 0 -> DisposalAny + 1 -> DisposalDoNot + 2 -> DisposalRestoreBackground + 3 -> DisposalRestorePrevious + n -> DisposalUnknown n + +codeOfDisposalMethod :: DisposalMethod -> Word8 +codeOfDisposalMethod v = case v of + DisposalAny -> 0 + DisposalDoNot -> 1 + DisposalRestoreBackground -> 2 + DisposalRestorePrevious -> 3 + DisposalUnknown n -> n + +data GraphicControlExtension = GraphicControlExtension + { gceDisposalMethod :: !DisposalMethod -- ^ Stored on 3 bits + , gceUserInputFlag :: !Bool + , gceTransparentFlag :: !Bool + , gceDelay :: !Word16 + , gceTransparentColorIndex :: !Word8 + } + +instance Binary GraphicControlExtension where + put v = do + putWord8 extensionIntroducer + putWord8 graphicControlLabel + putWord8 0x4 -- size + let disposalCode = codeOfDisposalMethod $ gceDisposalMethod v + disposalField = + (disposalCode .&. 0x7) `unsafeShiftL` 2 + + userInputField + | gceUserInputFlag v = 0 `setBit` 1 + | otherwise = 0 + + transparentField + | gceTransparentFlag v = 0 `setBit` 0 + | otherwise = 0 + + packedFields = disposalField + .|. userInputField + .|. transparentField + + putWord8 packedFields + putWord16le $ gceDelay v + putWord8 $ gceTransparentColorIndex v + putWord8 0 -- blockTerminator + + get = do + -- due to missing lookahead + {-_extensionLabel <- getWord8-} + _size <- getWord8 + packedFields <- getWord8 + delay <- getWord16le + idx <- getWord8 + _blockTerminator <- getWord8 + return GraphicControlExtension + { gceDisposalMethod = + disposalMethodOfCode $ + (packedFields `unsafeShiftR` 2) .&. 0x07 + , gceUserInputFlag = packedFields `testBit` 1 + , gceTransparentFlag = packedFields `testBit` 0 + , gceDelay = delay + , gceTransparentColorIndex = idx + } + +data GifImage = GifImage + { imgDescriptor :: !ImageDescriptor + , imgLocalPalette :: !(Maybe Palette) + , imgLzwRootSize :: !Word8 + , imgData :: B.ByteString + } + +instance Binary GifImage where + put img = do + let descriptor = imgDescriptor img + put descriptor + case ( imgLocalPalette img + , gDescHasLocalMap $ imgDescriptor img) of + (Nothing, _) -> return () + (Just _, False) -> return () + (Just p, True) -> + putPalette (fromIntegral $ gDescLocalColorTableSize descriptor) p + putWord8 $ imgLzwRootSize img + putDataBlocks $ imgData img + + get = do + desc <- get + let hasLocalColorTable = gDescHasLocalMap desc + palette <- if hasLocalColorTable + then Just <$> getPalette (gDescLocalColorTableSize desc) + else pure Nothing + + GifImage desc palette <$> getWord8 <*> parseDataBlocks + +data Block = BlockImage GifImage + | BlockGraphicControl GraphicControlExtension + +skipSubDataBlocks :: Get () +skipSubDataBlocks = do + s <- fromIntegral <$> getWord8 + unless (s == 0) $ + skip s >> skipSubDataBlocks + +parseGifBlocks :: Get [Block] +parseGifBlocks = getWord8 >>= blockParse + where + blockParse v + | v == gifTrailer = pure [] + | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks + | v == extensionIntroducer = getWord8 >>= extensionParse + + blockParse v = do + readPosition <- bytesRead + fail ("Unrecognized gif block " ++ show v ++ " @" ++ show readPosition) + + extensionParse code + | code == graphicControlLabel = + (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks + | code == commentLabel = skipSubDataBlocks >> parseGifBlocks + | code `elem` [plainTextLabel, applicationLabel] = + fromIntegral <$> getWord8 >>= skip >> skipSubDataBlocks >> parseGifBlocks + | otherwise = parseDataBlocks >> parseGifBlocks + + +instance Binary ImageDescriptor where + put v = do + putWord8 imageSeparator + putWord16le $ gDescPixelsFromLeft v + putWord16le $ gDescPixelsFromTop v + putWord16le $ gDescImageWidth v + putWord16le $ gDescImageHeight v + let localMapField + | gDescHasLocalMap v = 0 `setBit` 7 + | otherwise = 0 + + isInterlacedField + | gDescIsInterlaced v = 0 `setBit` 6 + | otherwise = 0 + + isImageDescriptorSorted + | gDescIsImgDescriptorSorted v = 0 `setBit` 5 + | otherwise = 0 + + localSize = gDescLocalColorTableSize v + tableSizeField + | localSize > 0 = (localSize - 1) .&. 0x7 + | otherwise = 0 + + packedFields = localMapField + .|. isInterlacedField + .|. isImageDescriptorSorted + .|. tableSizeField + putWord8 packedFields + + get = do + -- due to missing lookahead + {-_imageSeparator <- getWord8-} + imgLeftPos <- getWord16le + imgTopPos <- getWord16le + imgWidth <- getWord16le + imgHeight <- getWord16le + packedFields <- getWord8 + let tableSize = packedFields .&. 0x7 + return ImageDescriptor + { gDescPixelsFromLeft = imgLeftPos + , gDescPixelsFromTop = imgTopPos + , gDescImageWidth = imgWidth + , gDescImageHeight = imgHeight + , gDescHasLocalMap = packedFields `testBit` 7 + , gDescIsInterlaced = packedFields `testBit` 6 + , gDescIsImgDescriptorSorted = packedFields `testBit` 5 + , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0 + } + + +-------------------------------------------------- +---- Palette +-------------------------------------------------- +getPalette :: Word8 -> Get Palette +getPalette bitDepth = + Image size 1 . V.fromList <$> replicateM (size * 3) get + where size = 2 ^ (fromIntegral bitDepth :: Int) + +putPalette :: Int -> Palette -> Put +putPalette size pal = do + V.mapM_ putWord8 (imageData pal) + replicateM_ missingColorComponent (putWord8 0) + where elemCount = 2 ^ size + missingColorComponent = (elemCount - imageWidth pal) * 3 + +-------------------------------------------------- +---- GifImage +-------------------------------------------------- +data GifHeader = GifHeader + { gifVersion :: GifVersion + , gifScreenDescriptor :: LogicalScreenDescriptor + , gifGlobalMap :: !Palette + } + +instance Binary GifHeader where + put v = do + put $ gifVersion v + let descr = gifScreenDescriptor v + put descr + putPalette (fromIntegral $ colorTableSize descr) $ gifGlobalMap v + + get = do + version <- get + screenDesc <- get + + palette <- + if hasGlobalMap screenDesc then + getPalette $ colorTableSize screenDesc + else + return greyPalette + + return GifHeader + { gifVersion = version + , gifScreenDescriptor = screenDesc + , gifGlobalMap = palette + } + +data GifFile = GifFile + { gifHeader :: !GifHeader + , gifImages :: [(Maybe GraphicControlExtension, GifImage)] + , gifLoopingBehaviour :: GifLooping + } + +putLooping :: GifLooping -> Put +putLooping LoopingNever = return () +putLooping LoopingForever = putLooping $ LoopingRepeat 0 +putLooping (LoopingRepeat count) = do + putWord8 extensionIntroducer + putWord8 applicationLabel + putWord8 11 -- the size + putByteString $ BC.pack "NETSCAPE2.0" + putWord8 3 -- size of sub block + putWord8 1 + putWord16le count + putWord8 0 + +associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)] +associateDescr [] = [] +associateDescr [BlockGraphicControl _] = [] +associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = + associateDescr rest +associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs +associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) = + (Just ctrl, img) : associateDescr xs + +instance Binary GifFile where + put v = do + put $ gifHeader v + let putter (Nothing, i) = put i + putter (Just a, i) = put a >> put i + putLooping $ gifLoopingBehaviour v + mapM_ putter $ gifImages v + put gifTrailer + + get = do + hdr <- get + blocks <- parseGifBlocks + return GifFile { gifHeader = hdr + , gifImages = associateDescr blocks + , gifLoopingBehaviour = LoopingNever + } + +substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8 +substituteColors palette = pixelMap swaper + where swaper n = pixelAt palette (fromIntegral n) 0 + +substituteColorsWithTransparency :: Int -> Image PixelRGBA8 -> Image Pixel8 -> Image PixelRGBA8 +substituteColorsWithTransparency transparent palette = pixelMap swaper where + swaper n | ix == transparent = PixelRGBA8 0 0 0 0 + | otherwise = promotePixel $ pixelAt palette ix 0 + where ix = fromIntegral n + + +decodeImage :: GifImage -> Image Pixel8 +decodeImage img = runST $ runBoolReader $ do + outputVector <- lift . M.new $ width * height + decodeLzw (imgData img) 12 lzwRoot outputVector + frozenData <- lift $ V.unsafeFreeze outputVector + return . deinterlaceGif $ Image + { imageWidth = width + , imageHeight = height + , imageData = frozenData + } + where lzwRoot = fromIntegral $ imgLzwRootSize img + width = fromIntegral $ gDescImageWidth descriptor + height = fromIntegral $ gDescImageHeight descriptor + isInterlaced = gDescIsInterlaced descriptor + descriptor = imgDescriptor img + + deinterlaceGif | not isInterlaced = id + | otherwise = deinterlaceGifImage + +deinterlaceGifImage :: Image Pixel8 -> Image Pixel8 +deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h + where lineIndices = gifInterlacingIndices h + generator x y = pixelAt img x y' + where y' = lineIndices V.! y + +gifInterlacingIndices :: Int -> V.Vector Int +gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices + where indices = flip zip [0..] $ + concat [ [0, 8 .. height - 1] + , [4, 4 + 8 .. height - 1] + , [2, 2 + 4 .. height - 1] + , [1, 1 + 2 .. height - 1] + ] + +paletteOf :: (ColorConvertible PixelRGB8 px) + => Image px -> GifImage -> Image px +paletteOf global GifImage { imgLocalPalette = Nothing } = global +paletteOf _ GifImage { imgLocalPalette = Just p } = promoteImage p + +getFrameDelays :: GifFile -> [GifDelay] +getFrameDelays GifFile { gifImages = [] } = [] +getFrameDelays GifFile { gifImages = imgs } = map extractDelay imgs + where extractDelay (ext, _) = + case ext of + Nothing -> 0 + Just e -> fromIntegral $ gceDelay e + +transparentColorOf :: Maybe GraphicControlExtension -> Int +transparentColorOf Nothing = 300 +transparentColorOf (Just ext) + | gceTransparentFlag ext = fromIntegral $ gceTransparentColorIndex ext + | otherwise = 300 + +hasTransparency :: Maybe GraphicControlExtension -> Bool +hasTransparency Nothing = False +hasTransparency (Just control) = gceTransparentFlag control + +decodeAllGifImages :: GifFile -> [PalettedImage] +decodeAllGifImages GifFile { gifImages = [] } = [] +decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette + , gifScreenDescriptor = wholeDescriptor } + , gifImages = (firstControl, firstImage) : rest } + | not (hasTransparency firstControl) = + let backImage = + generateImage (\_ _ -> backgroundColor) globalWidth globalHeight + thisPalette = paletteOf palette firstImage + baseImage = decodeImage firstImage + initState = + (thisPalette, firstControl, substituteColors thisPalette baseImage) + scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage + palette' = Palette' + { _paletteSize = imageWidth thisPalette + , _paletteData = imageData thisPalette + } + in + PalettedRGB8 baseImage palette' : + [TrueColorImage $ ImageRGB8 img | (_, _, img) <- tail $ scanl scanner initState rest] + + | otherwise = + let backImage :: Image PixelRGBA8 + backImage = + generateImage (\_ _ -> transparentBackground) globalWidth globalHeight + + thisPalette :: Image PixelRGBA8 + thisPalette = paletteOf (promoteImage palette) firstImage + + transparentCode = transparentColorOf firstControl + decoded = + substituteColorsWithTransparency transparentCode thisPalette $ + decodeImage firstImage + + initState = (thisPalette, firstControl, decoded) + scanner = + gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in + [TrueColorImage $ ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest] + + where + globalWidth = fromIntegral $ screenWidth wholeDescriptor + globalHeight = fromIntegral $ screenHeight wholeDescriptor + + transparentBackground = PixelRGBA8 r g b 0 + where PixelRGB8 r g b = backgroundColor + + backgroundColor + | hasGlobalMap wholeDescriptor = + pixelAt palette (fromIntegral $ backgroundIndex wholeDescriptor) 0 + | otherwise = PixelRGB8 0 0 0 + +gifAnimationApplyer :: forall px. (ColorConvertible PixelRGB8 px) + => (Int, Int) -> Image px -> Image px + -> (Image px, Maybe GraphicControlExtension, Image px) + -> (Maybe GraphicControlExtension, GifImage) + -> (Image px, Maybe GraphicControlExtension, Image px) +gifAnimationApplyer (globalWidth, globalHeight) globalPalette backgroundImage + (_, prevControl, img1) + (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = + (thisPalette, controlExt, thisImage) + where + thisPalette :: Image px + thisPalette = paletteOf globalPalette img2 + + thisImage = generateImage pixeler globalWidth globalHeight + localWidth = fromIntegral $ gDescImageWidth descriptor + localHeight = fromIntegral $ gDescImageHeight descriptor + + left = fromIntegral $ gDescPixelsFromLeft descriptor + top = fromIntegral $ gDescPixelsFromTop descriptor + + isPixelInLocalImage x y = + x >= left && x < left + localWidth && y >= top && y < top + localHeight + + decoded :: Image Pixel8 + decoded = decodeImage img2 + + transparent :: Int + transparent = case controlExt of + Nothing -> 300 + Just ext -> if gceTransparentFlag ext + then fromIntegral $ gceTransparentColorIndex ext + else 300 + + oldImage = case gceDisposalMethod <$> prevControl of + Nothing -> img1 + Just DisposalAny -> img1 + Just DisposalDoNot -> img1 + Just DisposalRestoreBackground -> backgroundImage + Just DisposalRestorePrevious -> img1 + Just (DisposalUnknown _) -> img1 + + pixeler x y + | isPixelInLocalImage x y && code /= transparent = val where + code = fromIntegral $ pixelAt decoded (x - left) (y - top) + val = pixelAt thisPalette (fromIntegral code) 0 + pixeler x y = pixelAt oldImage x y + +decodeFirstGifImage :: GifFile -> Either String (PalettedImage, Metadatas) +decodeFirstGifImage img@GifFile { gifImages = (firstImage:_) } = + case decodeAllGifImages img { gifImages = [firstImage] } of + [] -> Left "No image after decoding" + (i:_) -> Right (i, basicMetadata SourceGif (screenWidth hdr) (screenHeight hdr)) + where hdr = gifScreenDescriptor $ gifHeader img +decodeFirstGifImage _ = Left "No image in gif file" + +-- | Transform a raw gif image to an image, without modifying the pixels. This +-- function can output the following images: +-- +-- * 'ImageRGB8' +-- +-- * 'ImageRGBA8' +-- +decodeGif :: B.ByteString -> Either String DynamicImage +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: +-- +-- * 'ImageRGB8' +-- +-- * 'ImageRGBA8' +-- +-- Metadatas include Width & Height information. +-- +decodeGifWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +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 = fmap palettedToTrueColor . decodeAllGifImages <$> decode img + +-- | Extract a list of frame delays from a raw gif. +getDelaysGifImages :: B.ByteString -> Either String [GifDelay] +getDelaysGifImages img = getFrameDelays <$> decode img + +-- | Default palette to produce greyscale images. +greyPalette :: Palette +greyPalette = generateImage toGrey 256 1 + where toGrey x _ = PixelRGB8 ix ix ix + where ix = fromIntegral x + +checkGifImageSizes :: [(a, b, Image px)] -> Bool +checkGifImageSizes [] = False +checkGifImageSizes ((_, _, img) : rest) = all checkDimension rest + where width = imageWidth img + height = imageHeight img + + checkDimension (_,_,Image { imageWidth = w, imageHeight = h }) = + w == width && h == height + +checkPaletteValidity :: [(Palette, a, b)] -> Bool +checkPaletteValidity [] = False +checkPaletteValidity lst = + and [h == 1 && w > 0 && w <= 256 | (p, _, _) <- lst + , let w = imageWidth p + h = imageHeight p ] + +areIndexAbsentFromPalette :: (Palette, a, Image Pixel8) -> Bool +areIndexAbsentFromPalette (palette, _, img) = V.any isTooBig $ imageData img + where paletteElemCount = imageWidth palette + isTooBig v = fromIntegral v >= paletteElemCount + +computeMinimumLzwKeySize :: Palette -> Int +computeMinimumLzwKeySize Image { imageWidth = itemCount } = go 2 + where go k | 2 ^ k >= itemCount = k + | otherwise = go $ k + 1 + +-- | Encode a gif animation to a bytestring. +-- +-- * Every image must have the same size +-- +-- * Every palette must have between one and 256 colors. +-- +encodeGifImages :: GifLooping -> [(Palette, GifDelay, Image Pixel8)] + -> Either String L.ByteString +encodeGifImages _ [] = Left "No image in list" +encodeGifImages _ imageList + | not $ checkGifImageSizes imageList = Left "Gif images have different size" + | not $ checkPaletteValidity imageList = + Left $ "Invalid palette size " ++ concat [show (imageWidth pal) ++ " "| (pal, _, _) <- imageList ] + | any areIndexAbsentFromPalette imageList = Left "Image contains indexes absent from the palette" +encodeGifImages looping imageList@((firstPalette, _,firstImage):_) = Right $ encode allFile + where + version = case imageList of + [] -> GIF87a + [_] -> GIF87a + _:_:_ -> GIF89a + + allFile = GifFile + { gifHeader = GifHeader + { gifVersion = version + , gifScreenDescriptor = logicalScreen + , gifGlobalMap = firstPalette + } + , gifImages = toSerialize + , gifLoopingBehaviour = looping + } + + logicalScreen = LogicalScreenDescriptor + { screenWidth = fromIntegral $ imageWidth firstImage + , screenHeight = fromIntegral $ imageHeight firstImage + , backgroundIndex = 0 + , hasGlobalMap = True + , colorResolution = 8 + , isColorTableSorted = False + , colorTableSize = 8 + } + + paletteEqual p = imageData firstPalette == imageData p + + controlExtension 0 = Nothing + controlExtension delay = Just GraphicControlExtension + { gceDisposalMethod = DisposalAny + , gceUserInputFlag = False + , gceTransparentFlag = False + , gceDelay = fromIntegral delay + , gceTransparentColorIndex = 0 + } + + toSerialize = [(controlExtension delay, GifImage + { imgDescriptor = imageDescriptor lzwKeySize (paletteEqual palette) img + , imgLocalPalette = Just palette + , imgLzwRootSize = fromIntegral lzwKeySize + , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img + }) | (palette, delay, img) <- imageList + , let lzwKeySize = computeMinimumLzwKeySize palette + ] + + imageDescriptor paletteSize palEqual img = ImageDescriptor + { gDescPixelsFromLeft = 0 + , gDescPixelsFromTop = 0 + , gDescImageWidth = fromIntegral $ imageWidth img + , gDescImageHeight = fromIntegral $ imageHeight img + , gDescHasLocalMap = paletteSize > 0 && not palEqual + , gDescIsInterlaced = False + , gDescIsImgDescriptorSorted = False + , gDescLocalColorTableSize = if palEqual then 0 else fromIntegral paletteSize + } + +-- | Encode a greyscale image to a bytestring. +encodeGifImage :: Image Pixel8 -> L.ByteString +encodeGifImage img = case encodeGifImages LoopingNever [(greyPalette, 0, img)] of + Left err -> error $ "Impossible:" ++ err + Right v -> v + +-- | Encode an image with a given palette. +-- Can return errors if the palette is ill-formed. +-- +-- * A palette must have between 1 and 256 colors +-- +encodeGifImageWithPalette :: Image Pixel8 -> Palette -> Either String L.ByteString +encodeGifImageWithPalette img palette = + encodeGifImages LoopingNever [(palette, 0, img)] + +-- | Write a greyscale in a gif file on the disk. +writeGifImage :: FilePath -> Image Pixel8 -> IO () +writeGifImage file = L.writeFile file . encodeGifImage + +-- | Write a list of images as a gif animation in a file. +-- +-- * Every image must have the same size +-- +-- * Every palette must have between one and 256 colors. +-- +writeGifImages :: FilePath -> GifLooping -> [(Palette, GifDelay, Image Pixel8)] + -> Either String (IO ()) +writeGifImages file looping lst = L.writeFile file <$> encodeGifImages looping lst + +-- | Write a gif image with a palette to a file. +-- +-- * A palette must have between 1 and 256 colors +-- +writeGifImageWithPalette :: FilePath -> Image Pixel8 -> Palette + -> Either String (IO ()) +writeGifImageWithPalette file img palette = + L.writeFile file <$> encodeGifImageWithPalette img palette + diff --git a/src/Codec/Picture/Saving.hs b/src/Codec/Picture/Saving.hs --- a/src/Codec/Picture/Saving.hs +++ b/src/Codec/Picture/Saving.hs @@ -1,214 +1,239 @@ -{-# 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 - , imageToPng - , imageToGif - , imageToBitmap - , imageToTiff - , imageToRadiance - , 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 -import Codec.Picture.Bitmap -import Codec.Picture.Jpg -import Codec.Picture.Png -import Codec.Picture.Gif -import Codec.Picture.ColorQuant -import Codec.Picture.HDR -import Codec.Picture.Types -import Codec.Picture.Tiff -import Codec.Picture.Tga - -import qualified Data.Vector.Storable as V - -componentToLDR :: Float -> Word8 -componentToLDR = truncate . (255 *) . min 1.0 . max 0.0 - -toStandardDef :: Image PixelRGBF -> Image PixelRGB8 -toStandardDef = pixelMap pixelConverter - where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b - where r = componentToLDR rf - g = componentToLDR gf - b = componentToLDR bf - -greyScaleToStandardDef :: Image PixelF -> Image Pixel8 -greyScaleToStandardDef = pixelMap componentToLDR - -from16to8 :: ( PixelBaseComponent source ~ Word16 - , PixelBaseComponent dest ~ Word8 ) - => Image source -> Image dest -from16to8 Image { imageWidth = w, imageHeight = h - , imageData = arr } = Image w h transformed - where transformed = V.map toWord8 arr - toWord8 v = fromIntegral (v `unsafeShiftR` 8) - -from16toFloat :: ( PixelBaseComponent source ~ Word16 - , PixelBaseComponent dest ~ Float ) - => Image source -> Image dest -from16toFloat Image { imageWidth = w, imageHeight = h - , imageData = arr } = Image w h transformed - where transformed = V.map toWord8 arr - toWord8 v = fromIntegral v / 65536.0 - --- | This function will try to do anything to encode an image --- as RADIANCE, make all color conversion and such. Equivalent --- of 'decodeImage' for radiance encoding -imageToRadiance :: DynamicImage -> L.ByteString -imageToRadiance (ImageCMYK8 img) = - imageToRadiance . ImageRGB8 $ convertImage img -imageToRadiance (ImageCMYK16 img) = - imageToRadiance . ImageRGB16 $ convertImage img -imageToRadiance (ImageYCbCr8 img) = - imageToRadiance . ImageRGB8 $ convertImage img -imageToRadiance (ImageRGB8 img) = - imageToRadiance . ImageRGBF $ promoteImage img -imageToRadiance (ImageRGBF img) = encodeHDR img -imageToRadiance (ImageRGBA8 img) = - imageToRadiance . ImageRGBF . promoteImage $ dropAlphaLayer img -imageToRadiance (ImageY8 img) = - imageToRadiance . ImageRGB8 $ promoteImage img -imageToRadiance (ImageYF img) = - imageToRadiance . ImageRGBF $ promoteImage img -imageToRadiance (ImageYA8 img) = - imageToRadiance . ImageRGB8 . promoteImage $ dropAlphaLayer img -imageToRadiance (ImageY16 img) = - imageToRadiance . ImageRGBF $ pixelMap toRgbf img - where toRgbf v = PixelRGBF val val val - where val = fromIntegral v / 65536.0 - -imageToRadiance (ImageYA16 img) = - imageToRadiance . ImageRGBF $ pixelMap toRgbf img - where toRgbf (PixelYA16 v _) = PixelRGBF val val val - where val = fromIntegral v / 65536.0 -imageToRadiance (ImageRGB16 img) = - imageToRadiance . ImageRGBF $ from16toFloat img -imageToRadiance (ImageRGBA16 img) = - imageToRadiance . ImageRGBF $ pixelMap toRgbf img - where toRgbf (PixelRGBA16 r g b _) = PixelRGBF (f r) (f g) (f b) - where f v = fromIntegral v / 65536.0 - --- | 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 - ImageCMYK16 img -> imageToJpg quality . ImageRGB16 $ convertImage img - ImageRGB8 img -> encodeAtQuality (convertImage img) - ImageRGBF img -> imageToJpg quality . ImageRGB8 $ toStandardDef img - ImageRGBA8 img -> encodeAtQuality (convertImage $ dropAlphaLayer img) - ImageYF img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img - ImageY8 img -> 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 - ImageRGBA16 img -> imageToJpg quality . ImageRGBA8 $ from16to8 img - --- | This function will try to do anything to encode an image --- as PNG, make all color conversion and such. Equivalent --- of 'decodeImage' for PNG encoding -imageToPng :: DynamicImage -> L.ByteString -imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8) -imageToPng (ImageCMYK8 img) = encodePng (convertImage img :: Image PixelRGB8) -imageToPng (ImageCMYK16 img) = encodePng (convertImage img :: Image PixelRGB16) -imageToPng (ImageRGB8 img) = encodePng img -imageToPng (ImageRGBF img) = encodePng $ toStandardDef img -imageToPng (ImageRGBA8 img) = encodePng img -imageToPng (ImageY8 img) = encodePng img -imageToPng (ImageYF img) = encodePng $ greyScaleToStandardDef img -imageToPng (ImageYA8 img) = encodePng img -imageToPng (ImageY16 img) = encodePng img -imageToPng (ImageYA16 img) = encodePng img -imageToPng (ImageRGB16 img) = encodePng img -imageToPng (ImageRGBA16 img) = encodePng img - --- | This function will try to do anything to encode an image --- as a Tiff, make all color conversion and such. Equivalent --- of 'decodeImage' for Tiff encoding -imageToTiff :: DynamicImage -> L.ByteString -imageToTiff (ImageYCbCr8 img) = encodeTiff img -imageToTiff (ImageCMYK8 img) = encodeTiff img -imageToTiff (ImageCMYK16 img) = encodeTiff img -imageToTiff (ImageRGB8 img) = encodeTiff img -imageToTiff (ImageRGBF img) = encodeTiff $ toStandardDef img -imageToTiff (ImageRGBA8 img) = encodeTiff img -imageToTiff (ImageY8 img) = encodeTiff img -imageToTiff (ImageYF img) = encodeTiff $ greyScaleToStandardDef img -imageToTiff (ImageYA8 img) = encodeTiff $ dropAlphaLayer img -imageToTiff (ImageY16 img) = encodeTiff img -imageToTiff (ImageYA16 img) = encodeTiff $ dropAlphaLayer img -imageToTiff (ImageRGB16 img) = encodeTiff img -imageToTiff (ImageRGBA16 img) = encodeTiff img - --- | This function will try to do anything to encode an image --- as bitmap, make all color conversion and such. Equivalent --- of 'decodeImage' for Bitmap encoding -imageToBitmap :: DynamicImage -> L.ByteString -imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) -imageToBitmap (ImageCMYK8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) -imageToBitmap (ImageCMYK16 img) = imageToBitmap . ImageRGB16 $ convertImage img -imageToBitmap (ImageRGBF img) = encodeBitmap $ toStandardDef img -imageToBitmap (ImageRGB8 img) = encodeBitmap img -imageToBitmap (ImageRGBA8 img) = encodeBitmap img -imageToBitmap (ImageY8 img) = encodeBitmap img -imageToBitmap (ImageYF img) = encodeBitmap $ greyScaleToStandardDef img -imageToBitmap (ImageYA8 img) = encodeBitmap (promoteImage img :: Image PixelRGBA8) -imageToBitmap (ImageY16 img) = imageToBitmap . ImageY8 $ from16to8 img -imageToBitmap (ImageYA16 img) = imageToBitmap . ImageYA8 $ from16to8 img -imageToBitmap (ImageRGB16 img) = imageToBitmap . ImageRGB8 $ from16to8 img -imageToBitmap (ImageRGBA16 img) = imageToBitmap . ImageRGBA8 $ from16to8 img - - --- | This function will try to do anything to encode an image --- as a gif, make all color conversion and quantization. Equivalent --- of 'decodeImage' for gif encoding -imageToGif :: DynamicImage -> Either String L.ByteString -imageToGif (ImageYCbCr8 img) = imageToGif . ImageRGB8 $ convertImage img -imageToGif (ImageCMYK8 img) = imageToGif . ImageRGB8 $ convertImage img -imageToGif (ImageCMYK16 img) = imageToGif . ImageRGB16 $ convertImage img -imageToGif (ImageRGBF img) = imageToGif . ImageRGB8 $ toStandardDef img -imageToGif (ImageRGB8 img) = encodeGifImageWithPalette indexed pal - where (indexed, pal) = palettize defaultPaletteOptions img -imageToGif (ImageRGBA8 img) = imageToGif . ImageRGB8 $ dropAlphaLayer img -imageToGif (ImageY8 img) = Right $ encodeGifImage img -imageToGif (ImageYF img) = imageToGif . ImageY8 $ greyScaleToStandardDef img -imageToGif (ImageYA8 img) = imageToGif . ImageY8 $ dropAlphaLayer img -imageToGif (ImageY16 img) = imageToGif . ImageY8 $ from16to8 img -imageToGif (ImageYA16 img) = imageToGif . ImageYA8 $ from16to8 img -imageToGif (ImageRGB16 img) = imageToGif . ImageRGB8 $ from16to8 img -imageToGif (ImageRGBA16 img) = imageToGif . ImageRGBA8 $ from16to8 img - --- | This function will try to do anything to encode an image --- as a tga, make all color conversion and quantization. Equivalent --- of 'decodeImage' for tga encoding -imageToTga :: DynamicImage -> L.ByteString -imageToTga (ImageYCbCr8 img) = encodeTga (convertImage img :: Image PixelRGB8) -imageToTga (ImageCMYK8 img) = encodeTga (convertImage img :: Image PixelRGB8) -imageToTga (ImageCMYK16 img) = encodeTga (from16to8 img :: Image PixelRGB8) -imageToTga (ImageRGBF img) = encodeTga $ toStandardDef img -imageToTga (ImageRGB8 img) = encodeTga img -imageToTga (ImageRGBA8 img) = encodeTga img -imageToTga (ImageY8 img) = encodeTga img -imageToTga (ImageYF img) = encodeTga $ greyScaleToStandardDef img -imageToTga (ImageYA8 img) = encodeTga (promoteImage img :: Image PixelRGBA8) -imageToTga (ImageY16 img) = encodeTga (from16to8 img :: Image Pixel8) -imageToTga (ImageYA16 img) = encodeTga (from16to8 img :: Image PixelRGBA8) -imageToTga (ImageRGB16 img) = encodeTga (from16to8 img :: Image PixelRGB8) -imageToTga (ImageRGBA16 img) = encodeTga (from16to8 img :: Image PixelRGBA8) +{-# 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 + , imageToPng + , imageToGif + , imageToBitmap + , imageToTiff + , imageToRadiance + , imageToTga + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +#endif + +import Data.Bits( unsafeShiftR ) +import Data.Word( Word8, Word16, Word32 ) +import qualified Data.ByteString.Lazy as L +import Codec.Picture.Bitmap +import Codec.Picture.Jpg +import Codec.Picture.Png +import Codec.Picture.Gif +import Codec.Picture.ColorQuant +import Codec.Picture.HDR +import Codec.Picture.Types +import Codec.Picture.Tiff +import Codec.Picture.Tga + +import qualified Data.Vector.Storable as V + +componentToLDR :: Float -> Word8 +componentToLDR = truncate . (255 *) . min 1.0 . max 0.0 + +toStandardDef :: Image PixelRGBF -> Image PixelRGB8 +toStandardDef = pixelMap pixelConverter + where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b + where r = componentToLDR rf + g = componentToLDR gf + b = componentToLDR bf + +greyScaleToStandardDef :: Image PixelF -> Image Pixel8 +greyScaleToStandardDef = pixelMap componentToLDR + +from16to8 :: ( PixelBaseComponent source ~ Word16 + , PixelBaseComponent dest ~ Word8 ) + => Image source -> Image dest +from16to8 Image { imageWidth = w, imageHeight = h + , imageData = arr } = Image w h transformed + where transformed = V.map toWord8 arr + toWord8 v = fromIntegral (v `unsafeShiftR` 8) + +from32to8 :: ( PixelBaseComponent source ~ Word32 + , PixelBaseComponent dest ~ Word8 ) + => Image source -> Image dest +from32to8 Image { imageWidth = w, imageHeight = h + , imageData = arr } = Image w h transformed + where transformed = V.map toWord8 arr + toWord8 v = fromIntegral (v `unsafeShiftR` 24) + +from32to16 :: ( PixelBaseComponent source ~ Word32 + , PixelBaseComponent dest ~ Word16 ) + => Image source -> Image dest +from32to16 Image { imageWidth = w, imageHeight = h + , imageData = arr } = Image w h transformed + where transformed = V.map toWord16 arr + toWord16 v = fromIntegral (v `unsafeShiftR` 16) + +from16toFloat :: ( PixelBaseComponent source ~ Word16 + , PixelBaseComponent dest ~ Float ) + => Image source -> Image dest +from16toFloat Image { imageWidth = w, imageHeight = h + , imageData = arr } = Image w h transformed + where transformed = V.map toWord8 arr + toWord8 v = fromIntegral v / 65536.0 + +-- | This function will try to do anything to encode an image +-- as RADIANCE, make all color conversion and such. Equivalent +-- of 'decodeImage' for radiance encoding +imageToRadiance :: DynamicImage -> L.ByteString +imageToRadiance (ImageCMYK8 img) = + imageToRadiance . ImageRGB8 $ convertImage img +imageToRadiance (ImageCMYK16 img) = + imageToRadiance . ImageRGB16 $ convertImage img +imageToRadiance (ImageYCbCr8 img) = + imageToRadiance . ImageRGB8 $ convertImage img +imageToRadiance (ImageRGB8 img) = + imageToRadiance . ImageRGBF $ promoteImage img +imageToRadiance (ImageRGBF img) = encodeHDR img +imageToRadiance (ImageRGBA8 img) = + imageToRadiance . ImageRGBF . promoteImage $ dropAlphaLayer img +imageToRadiance (ImageY8 img) = + imageToRadiance . ImageRGB8 $ promoteImage img +imageToRadiance (ImageYF img) = + imageToRadiance . ImageRGBF $ promoteImage img +imageToRadiance (ImageYA8 img) = + imageToRadiance . ImageRGB8 . promoteImage $ dropAlphaLayer img +imageToRadiance (ImageY16 img) = + imageToRadiance . ImageRGBF $ pixelMap toRgbf img + where toRgbf v = PixelRGBF val val val + where val = fromIntegral v / 65536.0 +imageToRadiance (ImageY32 img) = + imageToRadiance . ImageRGBF $ pixelMap toRgbf img + where toRgbf v = PixelRGBF val val val + where val = fromIntegral v / 4294967296.0 +imageToRadiance (ImageYA16 img) = + imageToRadiance . ImageRGBF $ pixelMap toRgbf img + where toRgbf (PixelYA16 v _) = PixelRGBF val val val + where val = fromIntegral v / 65536.0 +imageToRadiance (ImageRGB16 img) = + imageToRadiance . ImageRGBF $ from16toFloat img +imageToRadiance (ImageRGBA16 img) = + imageToRadiance . ImageRGBF $ pixelMap toRgbf img + where toRgbf (PixelRGBA16 r g b _) = PixelRGBF (f r) (f g) (f b) + where f v = fromIntegral v / 65536.0 + +-- | 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 + ImageCMYK16 img -> imageToJpg quality . ImageRGB16 $ convertImage img + ImageRGB8 img -> encodeAtQuality (convertImage img) + ImageRGBF img -> imageToJpg quality . ImageRGB8 $ toStandardDef img + ImageRGBA8 img -> encodeAtQuality (convertImage $ dropAlphaLayer img) + ImageYF img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img + ImageY8 img -> encodeWithMeta img + ImageYA8 img -> encodeWithMeta $ dropAlphaLayer img + ImageY16 img -> imageToJpg quality . ImageY8 $ from16to8 img + ImageYA16 img -> imageToJpg quality . ImageYA8 $ from16to8 img + ImageY32 img -> imageToJpg quality . ImageY8 $ from32to8 img + ImageRGB16 img -> imageToJpg quality . ImageRGB8 $ from16to8 img + ImageRGBA16 img -> imageToJpg quality . ImageRGBA8 $ from16to8 img + +-- | This function will try to do anything to encode an image +-- as PNG, make all color conversion and such. Equivalent +-- of 'decodeImage' for PNG encoding +imageToPng :: DynamicImage -> L.ByteString +imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8) +imageToPng (ImageCMYK8 img) = encodePng (convertImage img :: Image PixelRGB8) +imageToPng (ImageCMYK16 img) = encodePng (convertImage img :: Image PixelRGB16) +imageToPng (ImageRGB8 img) = encodePng img +imageToPng (ImageRGBF img) = encodePng $ toStandardDef img +imageToPng (ImageRGBA8 img) = encodePng img +imageToPng (ImageY8 img) = encodePng img +imageToPng (ImageYF img) = encodePng $ greyScaleToStandardDef img +imageToPng (ImageYA8 img) = encodePng img +imageToPng (ImageY16 img) = encodePng img +imageToPng (ImageY32 img) = imageToPng . ImageY16 $ from32to16 img +imageToPng (ImageYA16 img) = encodePng img +imageToPng (ImageRGB16 img) = encodePng img +imageToPng (ImageRGBA16 img) = encodePng img + +-- | This function will try to do anything to encode an image +-- as a Tiff, make all color conversion and such. Equivalent +-- of 'decodeImage' for Tiff encoding +imageToTiff :: DynamicImage -> L.ByteString +imageToTiff (ImageYCbCr8 img) = encodeTiff img +imageToTiff (ImageCMYK8 img) = encodeTiff img +imageToTiff (ImageCMYK16 img) = encodeTiff img +imageToTiff (ImageRGB8 img) = encodeTiff img +imageToTiff (ImageRGBF img) = encodeTiff $ toStandardDef img +imageToTiff (ImageRGBA8 img) = encodeTiff img +imageToTiff (ImageY8 img) = encodeTiff img +imageToTiff (ImageYF img) = encodeTiff $ greyScaleToStandardDef img +imageToTiff (ImageYA8 img) = encodeTiff $ dropAlphaLayer img +imageToTiff (ImageY16 img) = encodeTiff img +imageToTiff (ImageY32 img) = encodeTiff img +imageToTiff (ImageYA16 img) = encodeTiff $ dropAlphaLayer img +imageToTiff (ImageRGB16 img) = encodeTiff img +imageToTiff (ImageRGBA16 img) = encodeTiff img + +-- | This function will try to do anything to encode an image +-- as bitmap, make all color conversion and such. Equivalent +-- of 'decodeImage' for Bitmap encoding +imageToBitmap :: DynamicImage -> L.ByteString +imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) +imageToBitmap (ImageCMYK8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) +imageToBitmap (ImageCMYK16 img) = imageToBitmap . ImageRGB16 $ convertImage img +imageToBitmap (ImageRGBF img) = encodeBitmap $ toStandardDef img +imageToBitmap (ImageRGB8 img) = encodeBitmap img +imageToBitmap (ImageRGBA8 img) = encodeBitmap img +imageToBitmap (ImageY8 img) = encodeBitmap img +imageToBitmap (ImageYF img) = encodeBitmap $ greyScaleToStandardDef img +imageToBitmap (ImageYA8 img) = encodeBitmap (promoteImage img :: Image PixelRGBA8) +imageToBitmap (ImageY16 img) = imageToBitmap . ImageY8 $ from16to8 img +imageToBitmap (ImageY32 img) = imageToBitmap . ImageY8 $ from32to8 img +imageToBitmap (ImageYA16 img) = imageToBitmap . ImageYA8 $ from16to8 img +imageToBitmap (ImageRGB16 img) = imageToBitmap . ImageRGB8 $ from16to8 img +imageToBitmap (ImageRGBA16 img) = imageToBitmap . ImageRGBA8 $ from16to8 img + + +-- | This function will try to do anything to encode an image +-- as a gif, make all color conversion and quantization. Equivalent +-- of 'decodeImage' for gif encoding +imageToGif :: DynamicImage -> Either String L.ByteString +imageToGif (ImageYCbCr8 img) = imageToGif . ImageRGB8 $ convertImage img +imageToGif (ImageCMYK8 img) = imageToGif . ImageRGB8 $ convertImage img +imageToGif (ImageCMYK16 img) = imageToGif . ImageRGB16 $ convertImage img +imageToGif (ImageRGBF img) = imageToGif . ImageRGB8 $ toStandardDef img +imageToGif (ImageRGB8 img) = encodeGifImageWithPalette indexed pal + where (indexed, pal) = palettize defaultPaletteOptions img +imageToGif (ImageRGBA8 img) = imageToGif . ImageRGB8 $ dropAlphaLayer img +imageToGif (ImageY8 img) = Right $ encodeGifImage img +imageToGif (ImageYF img) = imageToGif . ImageY8 $ greyScaleToStandardDef img +imageToGif (ImageYA8 img) = imageToGif . ImageY8 $ dropAlphaLayer img +imageToGif (ImageY16 img) = imageToGif . ImageY8 $ from16to8 img +imageToGif (ImageY32 img) = imageToGif . ImageY8 $ from32to8 img +imageToGif (ImageYA16 img) = imageToGif . ImageYA8 $ from16to8 img +imageToGif (ImageRGB16 img) = imageToGif . ImageRGB8 $ from16to8 img +imageToGif (ImageRGBA16 img) = imageToGif . ImageRGBA8 $ from16to8 img + +-- | This function will try to do anything to encode an image +-- as a tga, make all color conversion and quantization. Equivalent +-- of 'decodeImage' for tga encoding +imageToTga :: DynamicImage -> L.ByteString +imageToTga (ImageYCbCr8 img) = encodeTga (convertImage img :: Image PixelRGB8) +imageToTga (ImageCMYK8 img) = encodeTga (convertImage img :: Image PixelRGB8) +imageToTga (ImageCMYK16 img) = encodeTga (from16to8 img :: Image PixelRGB8) +imageToTga (ImageRGBF img) = encodeTga $ toStandardDef img +imageToTga (ImageRGB8 img) = encodeTga img +imageToTga (ImageRGBA8 img) = encodeTga img +imageToTga (ImageY8 img) = encodeTga img +imageToTga (ImageYF img) = encodeTga $ greyScaleToStandardDef img +imageToTga (ImageYA8 img) = encodeTga (promoteImage img :: Image PixelRGBA8) +imageToTga (ImageY16 img) = encodeTga (from16to8 img :: Image Pixel8) +imageToTga (ImageY32 img) = encodeTga (from32to8 img :: Image Pixel8) +imageToTga (ImageYA16 img) = encodeTga (from16to8 img :: Image PixelRGBA8) +imageToTga (ImageRGB16 img) = encodeTga (from16to8 img :: Image PixelRGB8) +imageToTga (ImageRGBA16 img) = encodeTga (from16to8 img :: Image PixelRGBA8) diff --git a/src/Codec/Picture/Tiff.hs b/src/Codec/Picture/Tiff.hs --- a/src/Codec/Picture/Tiff.hs +++ b/src/Codec/Picture/Tiff.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE CPP #-} -- | Module implementing TIFF decoding. -- @@ -88,6 +89,8 @@ } unLong :: String -> ExifData -> Get (V.Vector Word32) +unLong _ (ExifLong v) = pure $ V.singleton v +unLong _ (ExifShort v) = pure $ V.singleton (fromIntegral v) unLong _ (ExifShorts v) = pure $ V.map fromIntegral v unLong _ (ExifLongs v) = pure v unLong errMessage _ = fail errMessage @@ -304,6 +307,33 @@ looperBe (writeIndex + stride) (readIndex + 4) +instance Unpackable Float where + type StorageType Float = Float + + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + allocTempBuffer _ _ s = M.new $ s * 4 + mergeBackTempBuffer :: forall s. Float + -> Endianness + -> M.STVector s Word8 + -> Int + -> Int + -> Word32 + -> Int + -> M.STVector s (StorageType Float) + -> ST s () + mergeBackTempBuffer _ endianness tempVec lineSize index size stride outVec = + let outVecWord32 :: M.STVector s Word32 + outVecWord32 = M.unsafeCast outVec + in mergeBackTempBuffer (0 :: Word32) + endianness + tempVec + lineSize + index + size + stride + outVecWord32 + data Pack4 = Pack4 instance Unpackable Pack4 where @@ -584,6 +614,10 @@ $ tiffColorspace nfo ifdShort TagPlanarConfiguration . constantToPlaneConfiguration $ tiffPlaneConfiguration nfo + ifdMultiLong TagSampleFormat + . V.fromList + . map packSampleFormat + $ tiffSampleFormat nfo ifdShort TagCompression . packCompression $ tiffCompression nfo ifdMultiLong TagStripOffsets $ tiffOffsets nfo @@ -690,10 +724,12 @@ | lst == V.singleton 16 && all (TiffSampleUint ==) format = 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 . TrueColorImage . ImageY16 $ pixelMap toWord16 img + let img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32 + in pure $ TrueColorImage $ ImageY32 $ img + | lst == V.singleton 32 && all (TiffSampleFloat ==) format = + let img = gatherStrips (0 :: Float) file nfo :: Image PixelF + in pure $ TrueColorImage $ ImageYF $ img + | lst == V.singleton 64 = Left "Failure to unpack TIFF file, 64-bit samples unsupported." | lst == V.fromList [2, 2] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format = @@ -758,6 +794,10 @@ -- -- * 'ImageY16' -- +-- * 'ImageY32' +-- +-- * 'ImageYF' +-- -- * 'ImageYA8' -- -- * 'ImageYA16' @@ -803,12 +843,22 @@ subSamplingInfo :: px -> V.Vector Word32 subSamplingInfo _ = V.empty + sampleFormat :: px -> [TiffSampleFormat] + sampleFormat _ = [TiffSampleUint] + instance TiffSaveable Pixel8 where colorSpaceOfPixel _ = TiffMonochrome instance TiffSaveable Pixel16 where colorSpaceOfPixel _ = TiffMonochrome +instance TiffSaveable Pixel32 where + colorSpaceOfPixel _ = TiffMonochrome + +instance TiffSaveable PixelF where + colorSpaceOfPixel _ = TiffMonochrome + sampleFormat _ = [TiffSampleFloat] + instance TiffSaveable PixelYA8 where colorSpaceOfPixel _ = TiffMonochrome extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha @@ -871,7 +921,7 @@ , tiffSampleCount = fromIntegral sampleCount , tiffRowPerStrip = fromIntegral $ imageHeight img , tiffPlaneConfiguration = PlanarConfigContig - , tiffSampleFormat = [TiffSampleUint] + , tiffSampleFormat = sampleFormat (undefined :: px) , tiffBitsPerSample = V.replicate intSampleCount bitPerSample , tiffCompression = CompressionNone , tiffStripSize = V.singleton imageSize diff --git a/src/Codec/Picture/Tiff/Types.hs b/src/Codec/Picture/Tiff/Types.hs --- a/src/Codec/Picture/Tiff/Types.hs +++ b/src/Codec/Picture/Tiff/Types.hs @@ -18,6 +18,7 @@ , planarConfgOfConstant , constantToPlaneConfiguration , unpackSampleFormat + , packSampleFormat , word16OfTag , unpackPhotometricInterpretation , packPhotometricInterpretation @@ -368,7 +369,7 @@ data TiffSampleFormat = TiffSampleUint | TiffSampleInt - | TiffSampleDouble + | TiffSampleFloat | TiffSampleUnknown deriving Eq @@ -376,9 +377,15 @@ unpackSampleFormat v = case v of 1 -> pure TiffSampleUint 2 -> pure TiffSampleInt - 3 -> pure TiffSampleDouble + 3 -> pure TiffSampleFloat 4 -> pure TiffSampleUnknown vv -> fail $ "Undefined data format (" ++ show vv ++ ")" + +packSampleFormat :: TiffSampleFormat -> Word32 +packSampleFormat TiffSampleUint = 1 +packSampleFormat TiffSampleInt = 2 +packSampleFormat TiffSampleFloat = 3 +packSampleFormat TiffSampleUnknown = 4 data ImageFileDirectory = ImageFileDirectory { ifdIdentifier :: !ExifTag -- Word16 diff --git a/src/Codec/Picture/Types.hs b/src/Codec/Picture/Types.hs --- a/src/Codec/Picture/Types.hs +++ b/src/Codec/Picture/Types.hs @@ -1,15 +1,17 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -- | Module provides basic types for image manipulation in the library. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Defined types are used to store all of those __Juicy Pixels__ module Codec.Picture.Types( -- * Types -- ** Image types @@ -153,6 +155,12 @@ } deriving (Typeable) +instance (Eq (PixelBaseComponent a), Storable (PixelBaseComponent a)) + => Eq (Image a) where + a == b = imageWidth a == imageWidth b && + imageHeight a == imageHeight b && + imageData a == imageData b + -- | Type for the palette used in Gif & PNG files. type Palette = Image PixelRGB8 @@ -369,6 +377,8 @@ ImageY8 (Image Pixel8) -- | A greyscale image with 16bit components | ImageY16 (Image Pixel16) + -- | A greyscale image with 32bit components + | ImageY32 (Image Pixel32) -- | A greyscale HDR image | ImageYF (Image PixelF) -- | An image in greyscale with an alpha channel. @@ -391,7 +401,7 @@ | ImageCMYK8 (Image PixelCMYK8) -- | An image in the colorspace CMYK and 16 bits precision | ImageCMYK16 (Image PixelCMYK16) - deriving (Typeable) + deriving (Eq, Typeable) -- | Type used to expose a palette extracted during reading. -- Use palettedAsImage to convert it to a palette usable for @@ -442,6 +452,7 @@ -> DynamicImage -> a dynamicMap f (ImageY8 i) = f i dynamicMap f (ImageY16 i) = f i +dynamicMap f (ImageY32 i) = f i dynamicMap f (ImageYF i) = f i dynamicMap f (ImageYA8 i) = f i dynamicMap f (ImageYA16 i) = f i @@ -474,6 +485,7 @@ where aux (ImageY8 i) = ImageY8 (f i) aux (ImageY16 i) = ImageY16 (f i) + aux (ImageY32 i) = ImageY32 (f i) aux (ImageYF i) = ImageYF (f i) aux (ImageYA8 i) = ImageYA8 (f i) aux (ImageYA16 i) = ImageYA16 (f i) @@ -489,6 +501,7 @@ instance NFData DynamicImage where rnf (ImageY8 img) = rnf img rnf (ImageY16 img) = rnf img + rnf (ImageY32 img) = rnf img rnf (ImageYF img) = rnf img rnf (ImageYA8 img) = rnf img rnf (ImageYA16 img) = rnf img