{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} -- | Module implementing GIF decoding. module Codec.Picture.Gif ( -- * Reading decodeGif , decodeGifWithMetadata , decodeGifWithPaletteAndMetadata , decodeGifImages , getDelaysGifImages -- * Writing , GifDelay , GifDisposalMethod( .. ) , GifEncode( .. ) , GifFrame( .. ) , GifLooping( .. ) , encodeGifImage , encodeGifImageWithPalette , encodeGifImages , encodeComplexGifImage , writeGifImage , writeGifImageWithPalette , writeGifImages , writeComplexGifImage , greyPalette ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( pure, (<*>), (<$>) ) #endif import Control.Arrow( first ) import Control.Monad( replicateM, replicateM_, unless, when ) 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.Internal.LZW import Codec.Picture.Gif.Internal.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 image definition for encoding data GifEncode = GifEncode { -- | Screen width geWidth :: Int , -- | Screen height geHeight :: Int , -- | Global palette, optional gePalette :: Maybe Palette , -- | Background color index, optional. If given, a global palette is also required geBackground :: Maybe Int , -- | Looping behaviour geLooping :: GifLooping , -- | Image frames geFrames :: [GifFrame] } -- | An individual image frame in a GIF image data GifFrame = GifFrame { -- | Image X offset in GIF canvas gfXOffset :: Int , -- | Image Y offset in GIF canvas gfYOffset :: Int , -- | Image local palette, optional if a global palette is given gfPalette :: Maybe Palette , -- | Transparent color index, optional gfTransparent :: Maybe Int , -- | Frame transition delay, in 1/100ths of a second gfDelay :: GifDelay , -- | Frame disposal method gfDisposal :: GifDisposalMethod , -- | Image pixels gfPixels :: Image Pixel8 } {- ::= 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 GifDisposalMethod = DisposalAny | DisposalDoNot | DisposalRestoreBackground | DisposalRestorePrevious | DisposalUnknown Word8 disposalMethodOfCode :: Word8 -> GifDisposalMethod disposalMethodOfCode v = case v of 0 -> DisposalAny 1 -> DisposalDoNot 2 -> DisposalRestoreBackground 3 -> DisposalRestorePrevious n -> DisposalUnknown n codeOfDisposalMethod :: GifDisposalMethod -> Word8 codeOfDisposalMethod v = case v of DisposalAny -> 0 DisposalDoNot -> 1 DisposalRestoreBackground -> 2 DisposalRestorePrevious -> 3 DisposalUnknown n -> n data GraphicControlExtension = GraphicControlExtension { gceDisposalMethod :: !GifDisposalMethod -- ^ 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 return ImageDescriptor { gDescPixelsFromLeft = imgLeftPos , gDescPixelsFromTop = imgTopPos , gDescImageWidth = imgWidth , gDescImageHeight = imgHeight , gDescHasLocalMap = packedFields `testBit` 7 , gDescIsInterlaced = packedFields `testBit` 6 , gDescIsImgDescriptorSorted = packedFields `testBit` 5 , gDescLocalColorTableSize = (packedFields .&. 0x7) + 1 } -------------------------------------------------- ---- 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 :: Maybe Palette } instance Binary GifHeader where put v = do put $ gifVersion v let descr = gifScreenDescriptor v put descr case gifGlobalMap v of Just palette -> putPalette (fromIntegral $ colorTableSize descr) palette Nothing -> return () get = do version <- get screenDesc <- get palette <- if hasGlobalMap screenDesc then return <$> getPalette (colorTableSize screenDesc) else return Nothing 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 globalPalette 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 globalPalette) 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 globalPalette = maybe greyPalette id palette transparentBackground = PixelRGBA8 r g b 0 where PixelRGB8 r g b = backgroundColor backgroundColor | hasGlobalMap wholeDescriptor = pixelAt globalPalette (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 checkImageSizes :: GifEncode -> Either String () checkImageSizes GifEncode { geWidth = width, geHeight = height, geFrames = frames } | not $ isInBounds width && isInBounds height = Left "Invalid screen bounds" | not $ null outOfBounds = Left $ "GIF frames with invalid bounds: " ++ show (map snd outOfBounds) | otherwise = Right () where isInBounds dim = dim > 0 && dim <= 0xffff outOfBounds = filter (not . isFrameInBounds . fst) $ zip frames [0 :: Int ..] isFrameInBounds GifFrame { gfPixels = img } = isInBounds (imageWidth img) && isInBounds (imageHeight img) checkImagesInBounds :: GifEncode -> Either String () checkImagesInBounds GifEncode { geWidth = width, geHeight = height, geFrames = frames } = if null outOfBounds then Right () else Left $ "GIF frames out of screen bounds: " ++ show (map snd outOfBounds) where outOfBounds = filter (not . isInBounds . fst) $ zip frames [0 :: Int ..] isInBounds GifFrame { gfXOffset = xOff, gfYOffset = yOff, gfPixels = img } = xOff >= 0 && yOff >= 0 && xOff + imageWidth img <= width && yOff + imageHeight img <= height checkPaletteValidity :: GifEncode -> Either String () checkPaletteValidity spec | not $ isPaletteValid $ gePalette spec = Left "Invalid global palette size" | not $ null invalidPalettes = Left $ "Invalid palette size in GIF frames: " ++ show (map snd invalidPalettes) | otherwise = Right () where invalidPalettes = filter (not . isPaletteValid . gfPalette . fst) $ zip (geFrames spec) [0 :: Int ..] isPaletteValid Nothing = True isPaletteValid (Just p) = let w = imageWidth p h = imageHeight p in h == 1 && w > 0 && w <= 256 checkIndexAbsentFromPalette :: GifEncode -> Either String () checkIndexAbsentFromPalette GifEncode { gePalette = global, geFrames = frames } = if null missingPalette then Right () else Left $ "GIF image frames with color indexes missing from palette: " ++ show (map snd missingPalette) where missingPalette = filter (not . checkFrame . fst) $ zip frames [0 :: Int ..] checkFrame frame = V.all (checkIndexInPalette global (gfPalette frame) . fromIntegral) $ imageData $ gfPixels frame checkBackground :: GifEncode -> Either String () checkBackground GifEncode { geBackground = Nothing } = Right () checkBackground GifEncode { gePalette = global, geBackground = Just background } = if checkIndexInPalette global Nothing background then Right () else Left "GIF background index absent from global palette" checkTransparencies :: GifEncode -> Either String () checkTransparencies GifEncode { gePalette = global, geFrames = frames } = if null missingTransparency then Right () else Left $ "GIF transparent index absent from palettes for frames: " ++ show (map snd missingTransparency) where missingTransparency = filter (not . transparencyOK . fst) $ zip frames [0 :: Int ..] transparencyOK GifFrame { gfTransparent = Nothing } = True transparencyOK GifFrame { gfPalette = local, gfTransparent = Just transparent } = checkIndexInPalette global local transparent checkIndexInPalette :: Maybe Palette -> Maybe Palette -> Int -> Bool checkIndexInPalette Nothing Nothing _ = False checkIndexInPalette _ (Just local) ix = ix < imageWidth local checkIndexInPalette (Just global) _ ix = ix < imageWidth global 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 computeColorTableSize :: Palette -> Int computeColorTableSize Image { imageWidth = itemCount } = go 1 where go k | 2 ^ k >= itemCount = k | otherwise = go $ k + 1 -- | Encode a complex gif to a bytestring. -- -- * There must be at least one image. -- -- * The screen and every frame dimensions must be between 1 and 65535. -- -- * Every frame image must fit within the screen bounds. -- -- * Every palette must have between one and 256 colors. -- -- * There must be a global palette or every image must have a local palette. -- -- * The background color index must be present in the global palette. -- -- * Every frame's transparent color index, if set, must be present in the palette used by that frame. -- -- * Every color index used in an image must be present in the palette used by that frame. -- encodeComplexGifImage :: GifEncode -> Either String L.ByteString encodeComplexGifImage spec = do when (null $ geFrames spec) $ Left "No GIF frames" checkImageSizes spec checkImagesInBounds spec checkPaletteValidity spec checkBackground spec checkTransparencies spec checkIndexAbsentFromPalette spec Right $ encode allFile where GifEncode { geWidth = width , geHeight = height , gePalette = globalPalette , geBackground = background , geLooping = looping , geFrames = frames } = spec allFile = GifFile { gifHeader = GifHeader { gifVersion = version , gifScreenDescriptor = logicalScreen , gifGlobalMap = globalPalette } , gifImages = toSerialize , gifLoopingBehaviour = looping } version = case frames of [] -> GIF87a [_] -> GIF87a _:_:_ -> GIF89a logicalScreen = LogicalScreenDescriptor { screenWidth = fromIntegral width , screenHeight = fromIntegral height , backgroundIndex = maybe 0 fromIntegral background , hasGlobalMap = maybe False (const True) globalPalette , colorResolution = 8 , isColorTableSorted = False -- Imply a 8 bit global palette size if there's no explicit global palette. , colorTableSize = maybe 8 (fromIntegral . computeColorTableSize) globalPalette } toSerialize = [(controlExtension delay transparent disposal, GifImage { imgDescriptor = imageDescriptor left top localPalette img , imgLocalPalette = localPalette , imgLzwRootSize = fromIntegral lzwKeySize , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img }) | GifFrame { gfXOffset = left , gfYOffset = top , gfPalette = localPalette , gfTransparent = transparent , gfDelay = delay , gfDisposal = disposal , gfPixels = img } <- frames , let palette = case (globalPalette, localPalette) of (_, Just local) -> local (Just global, Nothing) -> global (Nothing, Nothing) -> error "No palette for image" -- redundant, we guard for this -- Some decoders (looking at you, GIMP) don't handle initial LZW key size of 1 correctly. -- We'll waste some space for the sake of interoperability , let lzwKeySize = max 2 $ computeColorTableSize palette ] controlExtension 0 Nothing DisposalAny = Nothing controlExtension delay transparent disposal = Just GraphicControlExtension { gceDisposalMethod = disposal , gceUserInputFlag = False , gceTransparentFlag = maybe False (const True) transparent , gceDelay = fromIntegral delay , gceTransparentColorIndex = maybe 0 fromIntegral transparent } imageDescriptor left top localPalette img = ImageDescriptor { gDescPixelsFromLeft = fromIntegral left , gDescPixelsFromTop = fromIntegral top , gDescImageWidth = fromIntegral $ imageWidth img , gDescImageHeight = fromIntegral $ imageHeight img , gDescHasLocalMap = maybe False (const True) localPalette , gDescIsInterlaced = False , gDescIsImgDescriptorSorted = False , gDescLocalColorTableSize = maybe 0 (fromIntegral . computeColorTableSize) localPalette } -- | 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" encodeGifImages looping imageList@((firstPalette, _,firstImage):_) = encodeComplexGifImage $ GifEncode (imageWidth firstImage) (imageHeight firstImage) (Just firstPalette) Nothing looping frames where frames = [ GifFrame 0 0 localPalette Nothing delay DisposalAny image | (palette, delay, image) <- imageList , let localPalette = if paletteEqual palette then Nothing else Just palette ] paletteEqual p = imageData firstPalette == imageData p -- | 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 writeComplexGifImage :: FilePath -> GifEncode -> Either String (IO ()) writeComplexGifImage file spec = L.writeFile file <$> encodeComplexGifImage spec