JuicyPixels 3.2.9.5 → 3.3
raw patch · 8 files changed
+1212/−1096 lines, 8 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Codec.Picture: ImageY32 :: (Image Pixel32) -> DynamicImage
+ Codec.Picture: instance Codec.Picture.Decimable Codec.Picture.Types.Pixel32 Codec.Picture.Types.Pixel8
+ Codec.Picture.Metadata: instance GHC.Base.Semigroup Codec.Picture.Metadata.Metadatas
+ Codec.Picture.Tiff: instance Codec.Picture.Tiff.TiffSaveable Codec.Picture.Types.Pixel32
+ Codec.Picture.Tiff: instance Codec.Picture.Tiff.TiffSaveable Codec.Picture.Types.PixelF
+ Codec.Picture.Tiff: instance Codec.Picture.Tiff.Unpackable GHC.Types.Float
+ Codec.Picture.Types: ImageY32 :: (Image Pixel32) -> DynamicImage
+ Codec.Picture.Types: instance (GHC.Classes.Eq (Codec.Picture.Types.PixelBaseComponent a), Foreign.Storable.Storable (Codec.Picture.Types.PixelBaseComponent a)) => GHC.Classes.Eq (Codec.Picture.Types.Image a)
+ Codec.Picture.Types: instance GHC.Classes.Eq Codec.Picture.Types.DynamicImage
Files
- JuicyPixels.cabal +2/−2
- changelog +9/−0
- src/Codec/Picture.hs +14/−2
- src/Codec/Picture/Gif.hs +859/−859
- src/Codec/Picture/Saving.hs +239/−214
- src/Codec/Picture/Tiff.hs +55/−5
- src/Codec/Picture/Tiff/Types.hs +9/−2
- src/Codec/Picture/Types.hs +25/−12
JuicyPixels.cabal view
@@ -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: <<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.9.5 + Tag: v3.3 Flag Mmap Description: Enable the file loading via mmap (memory map)
changelog view
@@ -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 -------------------
src/Codec/Picture.hs view
@@ -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)
src/Codec/Picture/Gif.hs view
@@ -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--{-- <GIF Data Stream> ::= Header <Logical Screen> <Data>* Trailer-- <Logical Screen> ::= Logical Screen Descriptor [Global Color Table]-- <Data> ::= <Graphic Block> |- <Special-Purpose Block>-- <Graphic Block> ::= [Graphic Control Extension] <Graphic-Rendering Block>-- <Graphic-Rendering Block> ::= <Table-Based Image> |- Plain Text Extension-- <Table-Based Image> ::= Image Descriptor [Local Color Table] Image Data-- <Special-Purpose Block> ::= 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 + +{- + <GIF Data Stream> ::= Header <Logical Screen> <Data>* Trailer + + <Logical Screen> ::= Logical Screen Descriptor [Global Color Table] + + <Data> ::= <Graphic Block> | + <Special-Purpose Block> + + <Graphic Block> ::= [Graphic Control Extension] <Graphic-Rendering Block> + + <Graphic-Rendering Block> ::= <Table-Based Image> | + Plain Text Extension + + <Table-Based Image> ::= Image Descriptor [Local Color Table] Image Data + + <Special-Purpose Block> ::= 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 +
src/Codec/Picture/Saving.hs view
@@ -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)
src/Codec/Picture/Tiff.hs view
@@ -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
src/Codec/Picture/Tiff/Types.hs view
@@ -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
src/Codec/Picture/Types.hs view
@@ -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