{-# 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

    GifEncode -> Int
geWidth      :: Int
  , -- | Screen height

    GifEncode -> Int
geHeight     :: Int
  , -- | Global palette, optional

    GifEncode -> Maybe Palette
gePalette    :: Maybe Palette
  , -- | Background color index, optional. If given, a global palette is also required

    GifEncode -> Maybe Int
geBackground :: Maybe Int
  , -- | Looping behaviour

    GifEncode -> GifLooping
geLooping    :: GifLooping
  , -- | Image frames

    GifEncode -> [GifFrame]
geFrames     :: [GifFrame]
  }

-- | An individual image frame in a GIF image

data GifFrame = GifFrame
  { -- | Image X offset in GIF canvas

    GifFrame -> Int
gfXOffset     :: Int
  , -- | Image Y offset in GIF canvas

    GifFrame -> Int
gfYOffset     :: Int
  , -- | Image local palette, optional if a global palette is given

    GifFrame -> Maybe Palette
gfPalette     :: Maybe Palette
  , -- | Transparent color index, optional

    GifFrame -> Maybe Int
gfTransparent :: Maybe Int
  , -- | Frame transition delay, in 1/100ths of a second

    GifFrame -> Int
gfDelay       :: GifDelay
  , -- | Frame disposal method

    GifFrame -> GifDisposalMethod
gfDisposal    :: GifDisposalMethod
  , -- | Image pixels

    GifFrame -> Image Word8
gfPixels      :: Image Pixel8
  }


{-
   <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 :: ByteString
gif87aSignature = [Word8] -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) String
"GIF87a"
gif89aSignature :: ByteString
gif89aSignature = [Word8] -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) String
"GIF89a"

instance Binary GifVersion where
    put :: GifVersion -> Put
put GifVersion
GIF87a = ByteString -> Put
putByteString ByteString
gif87aSignature
    put GifVersion
GIF89a = ByteString -> Put
putByteString ByteString
gif89aSignature

    get :: Get GifVersion
get = do
        ByteString
sig <- Int -> Get ByteString
getByteString (ByteString -> Int
B.length ByteString
gif87aSignature)
        case (ByteString
sig forall a. Eq a => a -> a -> Bool
== ByteString
gif87aSignature, ByteString
sig forall a. Eq a => a -> a -> Bool
== ByteString
gif89aSignature) of
            (Bool
True, Bool
_)  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GifVersion
GIF87a
            (Bool
_ , Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GifVersion
GIF89a
            (Bool, Bool)
_          -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid Gif signature : " forall a. [a] -> [a] -> [a]
++ (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [Word8]
B.unpack ByteString
sig)


--------------------------------------------------

----         LogicalScreenDescriptor

--------------------------------------------------

-- | Section 18 of spec-gif89a

data LogicalScreenDescriptor = LogicalScreenDescriptor
  { -- | Stored on 16 bits

    LogicalScreenDescriptor -> Word16
screenWidth           :: !Word16
    -- | Stored on 16 bits

  , LogicalScreenDescriptor -> Word16
screenHeight          :: !Word16
    -- | Stored on 8 bits

  , LogicalScreenDescriptor -> Word8
backgroundIndex       :: !Word8

  -- | Stored on 1 bit

  , LogicalScreenDescriptor -> Bool
hasGlobalMap          :: !Bool
  -- | Stored on 3 bits

  , LogicalScreenDescriptor -> Word8
colorResolution       :: !Word8
  -- | Stored on 1 bit

  , LogicalScreenDescriptor -> Bool
isColorTableSorted    :: !Bool
  -- | Stored on 3 bits

  , LogicalScreenDescriptor -> Word8
colorTableSize        :: !Word8
  }

instance Binary LogicalScreenDescriptor where
    put :: LogicalScreenDescriptor -> Put
put LogicalScreenDescriptor
v = do
      Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ LogicalScreenDescriptor -> Word16
screenWidth LogicalScreenDescriptor
v
      Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ LogicalScreenDescriptor -> Word16
screenHeight LogicalScreenDescriptor
v
      let globalMapField :: Word8
globalMapField
            | LogicalScreenDescriptor -> Bool
hasGlobalMap LogicalScreenDescriptor
v = Word8
0x80
            | Bool
otherwise = Word8
0

          colorTableSortedField :: Word8
colorTableSortedField
            | LogicalScreenDescriptor -> Bool
isColorTableSorted LogicalScreenDescriptor
v = Word8
0x08
            | Bool
otherwise = Word8
0

          tableSizeField :: Word8
tableSizeField = (LogicalScreenDescriptor -> Word8
colorTableSize LogicalScreenDescriptor
v forall a. Num a => a -> a -> a
- Word8
1) forall a. Bits a => a -> a -> a
.&. Word8
7

          colorResolutionField :: Word8
colorResolutionField =
            ((LogicalScreenDescriptor -> Word8
colorResolution LogicalScreenDescriptor
v forall a. Num a => a -> a -> a
- Word8
1) forall a. Bits a => a -> a -> a
.&. Word8
7) forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
4

          packedField :: Word8
packedField = Word8
globalMapField
                     forall a. Bits a => a -> a -> a
.|. Word8
colorTableSortedField
                     forall a. Bits a => a -> a -> a
.|. Word8
tableSizeField
                     forall a. Bits a => a -> a -> a
.|. Word8
colorResolutionField

      Word8 -> Put
putWord8 Word8
packedField
      Word8 -> Put
putWord8 Word8
0 -- aspect ratio

      Word8 -> Put
putWord8 forall a b. (a -> b) -> a -> b
$ LogicalScreenDescriptor -> Word8
backgroundIndex LogicalScreenDescriptor
v

    get :: Get LogicalScreenDescriptor
get = do
        Word16
w <- Get Word16
getWord16le
        Word16
h <- Get Word16
getWord16le
        Word8
packedField  <- Get Word8
getWord8
        Word8
backgroundColorIndex  <- Get Word8
getWord8
        Word8
_aspectRatio  <- Get Word8
getWord8
        forall (m :: * -> *) a. Monad m => a -> m a
return LogicalScreenDescriptor
            { screenWidth :: Word16
screenWidth           = Word16
w
            , screenHeight :: Word16
screenHeight          = Word16
h
            , hasGlobalMap :: Bool
hasGlobalMap          = Word8
packedField forall a. Bits a => a -> Int -> Bool
`testBit` Int
7
            , colorResolution :: Word8
colorResolution       = (Word8
packedField forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) forall a. Bits a => a -> a -> a
.&. Word8
0x7 forall a. Num a => a -> a -> a
+ Word8
1
            , isColorTableSorted :: Bool
isColorTableSorted    = Word8
packedField forall a. Bits a => a -> Int -> Bool
`testBit` Int
3
            , colorTableSize :: Word8
colorTableSize        = (Word8
packedField forall a. Bits a => a -> a -> a
.&. Word8
0x7) forall a. Num a => a -> a -> a
+ Word8
1
            , backgroundIndex :: Word8
backgroundIndex       = Word8
backgroundColorIndex
            }


--------------------------------------------------

----            ImageDescriptor

--------------------------------------------------

-- | Section 20 of spec-gif89a

data ImageDescriptor = ImageDescriptor
  { ImageDescriptor -> Word16
gDescPixelsFromLeft         :: !Word16
  , ImageDescriptor -> Word16
gDescPixelsFromTop          :: !Word16
  , ImageDescriptor -> Word16
gDescImageWidth             :: !Word16
  , ImageDescriptor -> Word16
gDescImageHeight            :: !Word16
  , ImageDescriptor -> Bool
gDescHasLocalMap            :: !Bool
  , ImageDescriptor -> Bool
gDescIsInterlaced           :: !Bool
  , ImageDescriptor -> Bool
gDescIsImgDescriptorSorted  :: !Bool
  , ImageDescriptor -> Word8
gDescLocalColorTableSize    :: !Word8
  }

imageSeparator, extensionIntroducer, gifTrailer :: Word8
imageSeparator :: Word8
imageSeparator      = Word8
0x2C
extensionIntroducer :: Word8
extensionIntroducer = Word8
0x21
gifTrailer :: Word8
gifTrailer          = Word8
0x3B

graphicControlLabel, commentLabel, plainTextLabel, applicationLabel :: Word8
plainTextLabel :: Word8
plainTextLabel = Word8
0x01
graphicControlLabel :: Word8
graphicControlLabel = Word8
0xF9
commentLabel :: Word8
commentLabel = Word8
0xFE
applicationLabel :: Word8
applicationLabel    = Word8
0xFF


parseDataBlocks :: Get B.ByteString
parseDataBlocks :: Get ByteString
parseDataBlocks = [ByteString] -> ByteString
B.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get Word8
getWord8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get [ByteString]
aux)
 where aux :: Word8 -> Get [ByteString]
aux    Word8
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
       aux Word8
size = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
size) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Get Word8
getWord8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get [ByteString]
aux)

putDataBlocks :: B.ByteString -> Put
putDataBlocks :: ByteString -> Put
putDataBlocks ByteString
wholeString = ByteString -> Put
putSlices ByteString
wholeString forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8 Word8
0
  where putSlices :: ByteString -> Put
putSlices ByteString
str | ByteString -> Int
B.length ByteString
str forall a. Eq a => a -> a -> Bool
== Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                      | ByteString -> Int
B.length ByteString
str forall a. Ord a => a -> a -> Bool
> Int
0xFF =
            let (ByteString
before, ByteString
after) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
0xFF ByteString
str in
            Word8 -> Put
putWord8 Word8
0xFF forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
putByteString ByteString
before forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
putSlices ByteString
after
        putSlices ByteString
str =
            Word8 -> Put
putWord8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
str) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
putByteString ByteString
str

data GifDisposalMethod
    = DisposalAny
    | DisposalDoNot
    | DisposalRestoreBackground
    | DisposalRestorePrevious
    | DisposalUnknown Word8

disposalMethodOfCode :: Word8 -> GifDisposalMethod
disposalMethodOfCode :: Word8 -> GifDisposalMethod
disposalMethodOfCode Word8
v = case Word8
v of
    Word8
0 -> GifDisposalMethod
DisposalAny
    Word8
1 -> GifDisposalMethod
DisposalDoNot
    Word8
2 -> GifDisposalMethod
DisposalRestoreBackground
    Word8
3 -> GifDisposalMethod
DisposalRestorePrevious
    Word8
n -> Word8 -> GifDisposalMethod
DisposalUnknown Word8
n

codeOfDisposalMethod :: GifDisposalMethod -> Word8
codeOfDisposalMethod :: GifDisposalMethod -> Word8
codeOfDisposalMethod GifDisposalMethod
v = case GifDisposalMethod
v of
    GifDisposalMethod
DisposalAny -> Word8
0
    GifDisposalMethod
DisposalDoNot -> Word8
1
    GifDisposalMethod
DisposalRestoreBackground -> Word8
2
    GifDisposalMethod
DisposalRestorePrevious -> Word8
3
    DisposalUnknown Word8
n -> Word8
n

data GraphicControlExtension = GraphicControlExtension
    { GraphicControlExtension -> GifDisposalMethod
gceDisposalMethod        :: !GifDisposalMethod -- ^ Stored on 3 bits

    , GraphicControlExtension -> Bool
gceUserInputFlag         :: !Bool
    , GraphicControlExtension -> Bool
gceTransparentFlag       :: !Bool
    , GraphicControlExtension -> Word16
gceDelay                 :: !Word16
    , GraphicControlExtension -> Word8
gceTransparentColorIndex :: !Word8
    }

instance Binary GraphicControlExtension where
    put :: GraphicControlExtension -> Put
put GraphicControlExtension
v = do
        Word8 -> Put
putWord8 Word8
extensionIntroducer
        Word8 -> Put
putWord8 Word8
graphicControlLabel
        Word8 -> Put
putWord8 Word8
0x4  -- size

        let disposalCode :: Word8
disposalCode = GifDisposalMethod -> Word8
codeOfDisposalMethod forall a b. (a -> b) -> a -> b
$ GraphicControlExtension -> GifDisposalMethod
gceDisposalMethod GraphicControlExtension
v
            disposalField :: Word8
disposalField =
                (Word8
disposalCode forall a. Bits a => a -> a -> a
.&. Word8
0x7) forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
2

            userInputField :: Word8
userInputField
                | GraphicControlExtension -> Bool
gceUserInputFlag GraphicControlExtension
v = Word8
0 forall a. Bits a => a -> Int -> a
`setBit` Int
1
                | Bool
otherwise = Word8
0

            transparentField :: Word8
transparentField
                | GraphicControlExtension -> Bool
gceTransparentFlag GraphicControlExtension
v = Word8
0 forall a. Bits a => a -> Int -> a
`setBit` Int
0
                | Bool
otherwise = Word8
0

            packedFields :: Word8
packedFields =  Word8
disposalField
                        forall a. Bits a => a -> a -> a
.|. Word8
userInputField
                        forall a. Bits a => a -> a -> a
.|. Word8
transparentField

        Word8 -> Put
putWord8 Word8
packedFields
        Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ GraphicControlExtension -> Word16
gceDelay GraphicControlExtension
v
        Word8 -> Put
putWord8 forall a b. (a -> b) -> a -> b
$ GraphicControlExtension -> Word8
gceTransparentColorIndex GraphicControlExtension
v
        Word8 -> Put
putWord8 Word8
0 -- blockTerminator


    get :: Get GraphicControlExtension
get = do
        -- due to missing lookahead

        {-_extensionLabel  <- getWord8-}
        Word8
_size            <- Get Word8
getWord8
        Word8
packedFields     <- Get Word8
getWord8
        Word16
delay            <- Get Word16
getWord16le
        Word8
idx              <- Get Word8
getWord8
        Word8
_blockTerminator <- Get Word8
getWord8
        forall (m :: * -> *) a. Monad m => a -> m a
return GraphicControlExtension
            { gceDisposalMethod :: GifDisposalMethod
gceDisposalMethod        = 
                Word8 -> GifDisposalMethod
disposalMethodOfCode forall a b. (a -> b) -> a -> b
$
                    (Word8
packedFields forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
2) forall a. Bits a => a -> a -> a
.&. Word8
0x07
            , gceUserInputFlag :: Bool
gceUserInputFlag         = Word8
packedFields forall a. Bits a => a -> Int -> Bool
`testBit` Int
1
            , gceTransparentFlag :: Bool
gceTransparentFlag       = Word8
packedFields forall a. Bits a => a -> Int -> Bool
`testBit` Int
0
            , gceDelay :: Word16
gceDelay                 = Word16
delay
            , gceTransparentColorIndex :: Word8
gceTransparentColorIndex = Word8
idx
            }

data GifImage = GifImage
    { GifImage -> ImageDescriptor
imgDescriptor   :: !ImageDescriptor
    , GifImage -> Maybe Palette
imgLocalPalette :: !(Maybe Palette)
    , GifImage -> Word8
imgLzwRootSize  :: !Word8
    , GifImage -> ByteString
imgData         :: B.ByteString
    }

instance Binary GifImage where
    put :: GifImage -> Put
put GifImage
img = do
        let descriptor :: ImageDescriptor
descriptor = GifImage -> ImageDescriptor
imgDescriptor GifImage
img
        forall t. Binary t => t -> Put
put ImageDescriptor
descriptor
        case ( GifImage -> Maybe Palette
imgLocalPalette GifImage
img
             , ImageDescriptor -> Bool
gDescHasLocalMap forall a b. (a -> b) -> a -> b
$ GifImage -> ImageDescriptor
imgDescriptor GifImage
img) of
          (Maybe Palette
Nothing, Bool
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          (Just Palette
_, Bool
False) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          (Just Palette
p, Bool
True) ->
              Int -> Palette -> Put
putPalette (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word8
gDescLocalColorTableSize ImageDescriptor
descriptor) Palette
p
        Word8 -> Put
putWord8 forall a b. (a -> b) -> a -> b
$ GifImage -> Word8
imgLzwRootSize GifImage
img
        ByteString -> Put
putDataBlocks forall a b. (a -> b) -> a -> b
$ GifImage -> ByteString
imgData GifImage
img

    get :: Get GifImage
get = do
        ImageDescriptor
desc <- forall t. Binary t => Get t
get
        let hasLocalColorTable :: Bool
hasLocalColorTable = ImageDescriptor -> Bool
gDescHasLocalMap ImageDescriptor
desc
        Maybe Palette
palette <- if Bool
hasLocalColorTable
           then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Get Palette
getPalette (ImageDescriptor -> Word8
gDescLocalColorTableSize ImageDescriptor
desc)
           else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

        ImageDescriptor -> Maybe Palette -> Word8 -> ByteString -> GifImage
GifImage ImageDescriptor
desc Maybe Palette
palette forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
parseDataBlocks

data Block = BlockImage GifImage
           | BlockGraphicControl GraphicControlExtension

skipSubDataBlocks :: Get ()
skipSubDataBlocks :: Get ()
skipSubDataBlocks = do
  Int
s <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
s forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$
    Int -> Get ()
skip Int
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get ()
skipSubDataBlocks

parseGifBlocks :: Get [Block]
parseGifBlocks :: Get [Block]
parseGifBlocks = Get Word8
getWord8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get [Block]
blockParse
  where
    blockParse :: Word8 -> Get [Block]
blockParse Word8
v
      | Word8
v forall a. Eq a => a -> a -> Bool
== Word8
gifTrailer = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      | Word8
v forall a. Eq a => a -> a -> Bool
== Word8
imageSeparator = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GifImage -> Block
BlockImage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [Block]
parseGifBlocks
      | Word8
v forall a. Eq a => a -> a -> Bool
== Word8
extensionIntroducer = Get Word8
getWord8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get [Block]
extensionParse

    blockParse Word8
v = do
      Int64
readPosition <- Get Int64
bytesRead
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unrecognized gif block " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
v forall a. [a] -> [a] -> [a]
++ String
" @" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
readPosition)

    extensionParse :: Word8 -> Get [Block]
extensionParse Word8
code
     | Word8
code forall a. Eq a => a -> a -> Bool
== Word8
graphicControlLabel =
        (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GraphicControlExtension -> Block
BlockGraphicControl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [Block]
parseGifBlocks
     | Word8
code forall a. Eq a => a -> a -> Bool
== Word8
commentLabel = Get ()
skipSubDataBlocks forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get [Block]
parseGifBlocks
     | Word8
code forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word8
plainTextLabel, Word8
applicationLabel] =
        forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get ()
skip forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get ()
skipSubDataBlocks forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get [Block]
parseGifBlocks
     | Bool
otherwise = Get ByteString
parseDataBlocks forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get [Block]
parseGifBlocks


instance Binary ImageDescriptor where
    put :: ImageDescriptor -> Put
put ImageDescriptor
v = do
        Word8 -> Put
putWord8 Word8
imageSeparator
        Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescPixelsFromLeft ImageDescriptor
v
        Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescPixelsFromTop ImageDescriptor
v
        Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescImageWidth ImageDescriptor
v
        Word16 -> Put
putWord16le forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescImageHeight ImageDescriptor
v
        let localMapField :: Word8
localMapField
                | ImageDescriptor -> Bool
gDescHasLocalMap ImageDescriptor
v = Word8
0 forall a. Bits a => a -> Int -> a
`setBit` Int
7
                | Bool
otherwise = Word8
0

            isInterlacedField :: Word8
isInterlacedField
                | ImageDescriptor -> Bool
gDescIsInterlaced ImageDescriptor
v = Word8
0 forall a. Bits a => a -> Int -> a
`setBit` Int
6
                | Bool
otherwise = Word8
0

            isImageDescriptorSorted :: Word8
isImageDescriptorSorted
                | ImageDescriptor -> Bool
gDescIsImgDescriptorSorted ImageDescriptor
v = Word8
0 forall a. Bits a => a -> Int -> a
`setBit` Int
5
                | Bool
otherwise = Word8
0

            localSize :: Word8
localSize = ImageDescriptor -> Word8
gDescLocalColorTableSize ImageDescriptor
v
            tableSizeField :: Word8
tableSizeField
                | Word8
localSize forall a. Ord a => a -> a -> Bool
> Word8
0 = (Word8
localSize forall a. Num a => a -> a -> a
- Word8
1) forall a. Bits a => a -> a -> a
.&. Word8
0x7
                | Bool
otherwise = Word8
0

            packedFields :: Word8
packedFields = Word8
localMapField
                        forall a. Bits a => a -> a -> a
.|. Word8
isInterlacedField
                        forall a. Bits a => a -> a -> a
.|. Word8
isImageDescriptorSorted
                        forall a. Bits a => a -> a -> a
.|. Word8
tableSizeField
        Word8 -> Put
putWord8 Word8
packedFields

    get :: Get ImageDescriptor
get = do
        -- due to missing lookahead

        {-_imageSeparator <- getWord8-}
        Word16
imgLeftPos <- Get Word16
getWord16le
        Word16
imgTopPos  <- Get Word16
getWord16le
        Word16
imgWidth   <- Get Word16
getWord16le
        Word16
imgHeight  <- Get Word16
getWord16le
        Word8
packedFields <- Get Word8
getWord8
        forall (m :: * -> *) a. Monad m => a -> m a
return ImageDescriptor
            { gDescPixelsFromLeft :: Word16
gDescPixelsFromLeft = Word16
imgLeftPos
            , gDescPixelsFromTop :: Word16
gDescPixelsFromTop  = Word16
imgTopPos
            , gDescImageWidth :: Word16
gDescImageWidth     = Word16
imgWidth
            , gDescImageHeight :: Word16
gDescImageHeight    = Word16
imgHeight
            , gDescHasLocalMap :: Bool
gDescHasLocalMap    = Word8
packedFields forall a. Bits a => a -> Int -> Bool
`testBit` Int
7
            , gDescIsInterlaced :: Bool
gDescIsInterlaced     = Word8
packedFields forall a. Bits a => a -> Int -> Bool
`testBit` Int
6
            , gDescIsImgDescriptorSorted :: Bool
gDescIsImgDescriptorSorted = Word8
packedFields forall a. Bits a => a -> Int -> Bool
`testBit` Int
5
            , gDescLocalColorTableSize :: Word8
gDescLocalColorTableSize = (Word8
packedFields forall a. Bits a => a -> a -> a
.&. Word8
0x7) forall a. Num a => a -> a -> a
+ Word8
1
            }


--------------------------------------------------

----            Palette

--------------------------------------------------

getPalette :: Word8 -> Get Palette
getPalette :: Word8 -> Get Palette
getPalette Word8
bitDepth = 
    forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
size Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
V.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
size forall a. Num a => a -> a -> a
* Int
3) forall t. Binary t => Get t
get
  where size :: Int
size = Int
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
bitDepth :: Int)

putPalette :: Int -> Palette -> Put
putPalette :: Int -> Palette -> Put
putPalette Int
size Palette
pal = do
    forall (m :: * -> *) a b.
(Monad m, Storable a) =>
(a -> m b) -> Vector a -> m ()
V.mapM_ Word8 -> Put
putWord8 (forall a. Image a -> Vector (PixelBaseComponent a)
imageData Palette
pal)
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
missingColorComponent (Word8 -> Put
putWord8 Word8
0)
  where elemCount :: Int
elemCount = Int
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
size
        missingColorComponent :: Int
missingColorComponent = (Int
elemCount forall a. Num a => a -> a -> a
- forall a. Image a -> Int
imageWidth Palette
pal) forall a. Num a => a -> a -> a
* Int
3

--------------------------------------------------

----            GifImage

--------------------------------------------------

data GifHeader = GifHeader
  { GifHeader -> GifVersion
gifVersion          :: GifVersion
  , GifHeader -> LogicalScreenDescriptor
gifScreenDescriptor :: LogicalScreenDescriptor
  , GifHeader -> Maybe Palette
gifGlobalMap        :: Maybe Palette
  }

instance Binary GifHeader where
    put :: GifHeader -> Put
put GifHeader
v = do
      forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ GifHeader -> GifVersion
gifVersion GifHeader
v
      let descr :: LogicalScreenDescriptor
descr = GifHeader -> LogicalScreenDescriptor
gifScreenDescriptor GifHeader
v
      forall t. Binary t => t -> Put
put LogicalScreenDescriptor
descr
      case GifHeader -> Maybe Palette
gifGlobalMap GifHeader
v of
        Just Palette
palette -> Int -> Palette -> Put
putPalette (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ LogicalScreenDescriptor -> Word8
colorTableSize LogicalScreenDescriptor
descr) Palette
palette
        Maybe Palette
Nothing      -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    get :: Get GifHeader
get = do
        GifVersion
version    <- forall t. Binary t => Get t
get
        LogicalScreenDescriptor
screenDesc <- forall t. Binary t => Get t
get
        
        Maybe Palette
palette <- 
          if LogicalScreenDescriptor -> Bool
hasGlobalMap LogicalScreenDescriptor
screenDesc then
            forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Get Palette
getPalette (LogicalScreenDescriptor -> Word8
colorTableSize LogicalScreenDescriptor
screenDesc)
          else
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

        forall (m :: * -> *) a. Monad m => a -> m a
return GifHeader
            { gifVersion :: GifVersion
gifVersion = GifVersion
version
            , gifScreenDescriptor :: LogicalScreenDescriptor
gifScreenDescriptor = LogicalScreenDescriptor
screenDesc
            , gifGlobalMap :: Maybe Palette
gifGlobalMap = Maybe Palette
palette
            }

data GifFile = GifFile
    { GifFile -> GifHeader
gifHeader      :: !GifHeader
    , GifFile -> [(Maybe GraphicControlExtension, GifImage)]
gifImages      :: [(Maybe GraphicControlExtension, GifImage)]
    , GifFile -> GifLooping
gifLoopingBehaviour :: GifLooping
    }

putLooping :: GifLooping -> Put
putLooping :: GifLooping -> Put
putLooping GifLooping
LoopingNever = forall (m :: * -> *) a. Monad m => a -> m a
return ()
putLooping GifLooping
LoopingForever = GifLooping -> Put
putLooping forall a b. (a -> b) -> a -> b
$ Word16 -> GifLooping
LoopingRepeat Word16
0
putLooping (LoopingRepeat Word16
count) = do
    Word8 -> Put
putWord8 Word8
extensionIntroducer
    Word8 -> Put
putWord8 Word8
applicationLabel
    Word8 -> Put
putWord8 Word8
11 -- the size

    ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack String
"NETSCAPE2.0"
    Word8 -> Put
putWord8 Word8
3 -- size of sub block

    Word8 -> Put
putWord8 Word8
1
    Word16 -> Put
putWord16le Word16
count
    Word8 -> Put
putWord8 Word8
0

associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)]
associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)]
associateDescr [] = []
associateDescr [BlockGraphicControl GraphicControlExtension
_] = []
associateDescr (BlockGraphicControl GraphicControlExtension
_ : rest :: [Block]
rest@(BlockGraphicControl GraphicControlExtension
_ : [Block]
_)) =
    [Block] -> [(Maybe GraphicControlExtension, GifImage)]
associateDescr [Block]
rest
associateDescr (BlockImage GifImage
img:[Block]
xs) = (forall a. Maybe a
Nothing, GifImage
img) forall a. a -> [a] -> [a]
: [Block] -> [(Maybe GraphicControlExtension, GifImage)]
associateDescr [Block]
xs
associateDescr (BlockGraphicControl GraphicControlExtension
ctrl : BlockImage GifImage
img : [Block]
xs) =
    (forall a. a -> Maybe a
Just GraphicControlExtension
ctrl, GifImage
img) forall a. a -> [a] -> [a]
: [Block] -> [(Maybe GraphicControlExtension, GifImage)]
associateDescr [Block]
xs

instance Binary GifFile where
    put :: GifFile -> Put
put GifFile
v = do
        forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ GifFile -> GifHeader
gifHeader GifFile
v
        let putter :: (Maybe t, t) -> Put
putter (Maybe t
Nothing, t
i) = forall t. Binary t => t -> Put
put t
i
            putter (Just t
a, t
i) = forall t. Binary t => t -> Put
put t
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put t
i
        GifLooping -> Put
putLooping forall a b. (a -> b) -> a -> b
$ GifFile -> GifLooping
gifLoopingBehaviour GifFile
v
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {t} {t}. (Binary t, Binary t) => (Maybe t, t) -> Put
putter forall a b. (a -> b) -> a -> b
$ GifFile -> [(Maybe GraphicControlExtension, GifImage)]
gifImages GifFile
v
        forall t. Binary t => t -> Put
put Word8
gifTrailer

    get :: Get GifFile
get = do
        GifHeader
hdr <- forall t. Binary t => Get t
get
        [Block]
blocks <- Get [Block]
parseGifBlocks
        forall (m :: * -> *) a. Monad m => a -> m a
return GifFile { gifHeader :: GifHeader
gifHeader = GifHeader
hdr
                       , gifImages :: [(Maybe GraphicControlExtension, GifImage)]
gifImages = [Block] -> [(Maybe GraphicControlExtension, GifImage)]
associateDescr [Block]
blocks
                       , gifLoopingBehaviour :: GifLooping
gifLoopingBehaviour = GifLooping
LoopingNever
                       }

substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8
substituteColors :: Palette -> Image Word8 -> Palette
substituteColors Palette
palette = forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap Word8 -> PixelRGB8
swaper
  where swaper :: Word8 -> PixelRGB8
swaper Word8
n = forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Palette
palette (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) Int
0

substituteColorsWithTransparency :: Int -> Image PixelRGBA8 -> Image Pixel8 -> Image PixelRGBA8
substituteColorsWithTransparency :: Int -> Image PixelRGBA8 -> Image Word8 -> Image PixelRGBA8
substituteColorsWithTransparency Int
transparent Image PixelRGBA8
palette = forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap Word8 -> PixelRGBA8
swaper where
  swaper :: Word8 -> PixelRGBA8
swaper Word8
n | Int
ix forall a. Eq a => a -> a -> Bool
== Int
transparent = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
0 Word8
0 Word8
0 Word8
0
           | Bool
otherwise = forall a b. ColorConvertible a b => a -> b
promotePixel forall a b. (a -> b) -> a -> b
$ forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image PixelRGBA8
palette Int
ix Int
0
    where ix :: Int
ix = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n


decodeImage :: GifImage -> Image Pixel8
decodeImage :: GifImage -> Image Word8
decodeImage GifImage
img = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ forall s a. BoolReader s a -> ST s a
runBoolReader forall a b. (a -> b) -> a -> b
$ do
    STVector s Word8
outputVector <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new forall a b. (a -> b) -> a -> b
$ Int
width forall a. Num a => a -> a -> a
* Int
height
    forall s.
ByteString -> Int -> Int -> STVector s Word8 -> BoolReader s ()
decodeLzw (GifImage -> ByteString
imgData GifImage
img) Int
12 Int
lzwRoot STVector s Word8
outputVector
    Vector Word8
frozenData <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze STVector s Word8
outputVector
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Word8 -> Image Word8
deinterlaceGif forall a b. (a -> b) -> a -> b
$ Image
      { imageWidth :: Int
imageWidth = Int
width
      , imageHeight :: Int
imageHeight = Int
height
      , imageData :: Vector (PixelBaseComponent Word8)
imageData = Vector Word8
frozenData
      }
  where lzwRoot :: Int
lzwRoot = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ GifImage -> Word8
imgLzwRootSize GifImage
img
        width :: Int
width = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescImageWidth ImageDescriptor
descriptor
        height :: Int
height = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescImageHeight ImageDescriptor
descriptor
        isInterlaced :: Bool
isInterlaced = ImageDescriptor -> Bool
gDescIsInterlaced ImageDescriptor
descriptor
        descriptor :: ImageDescriptor
descriptor = GifImage -> ImageDescriptor
imgDescriptor GifImage
img

        deinterlaceGif :: Image Word8 -> Image Word8
deinterlaceGif | Bool -> Bool
not Bool
isInterlaced = forall a. a -> a
id
                       | Bool
otherwise = Image Word8 -> Image Word8
deinterlaceGifImage

deinterlaceGifImage :: Image Pixel8 -> Image Pixel8
deinterlaceGifImage :: Image Word8 -> Image Word8
deinterlaceGifImage img :: Image Word8
img@(Image { imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h }) = forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> Word8
generator Int
w Int
h
   where lineIndices :: Vector Int
lineIndices = Int -> Vector Int
gifInterlacingIndices Int
h
         generator :: Int -> Int -> Word8
generator Int
x Int
y = forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image Word8
img Int
x Int
y'
            where y' :: Int
y' = Vector Int
lineIndices forall a. Storable a => Vector a -> Int -> a
V.! Int
y

gifInterlacingIndices :: Int -> V.Vector Int
gifInterlacingIndices :: Int -> Vector Int
gifInterlacingIndices Int
height = forall a b.
Storable a =>
(a -> b -> a) -> Vector a -> [(Int, b)] -> Vector a
V.accum (\Int
_ Int
v -> Int
v) (forall a. Storable a => Int -> a -> Vector a
V.replicate Int
height Int
0) [(Int, Int)]
indices
    where indices :: [(Int, Int)]
indices = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall a b. (a -> b) -> a -> b
$
                forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Int
0,     Int
8 .. Int
height forall a. Num a => a -> a -> a
- Int
1]
                       , [Int
4, Int
4 forall a. Num a => a -> a -> a
+ Int
8 .. Int
height forall a. Num a => a -> a -> a
- Int
1]
                       , [Int
2, Int
2 forall a. Num a => a -> a -> a
+ Int
4 .. Int
height forall a. Num a => a -> a -> a
- Int
1]
                       , [Int
1, Int
1 forall a. Num a => a -> a -> a
+ Int
2 .. Int
height forall a. Num a => a -> a -> a
- Int
1]
                       ]

paletteOf :: (ColorConvertible PixelRGB8 px)
          => Image px -> GifImage -> Image px
paletteOf :: forall px.
ColorConvertible PixelRGB8 px =>
Image px -> GifImage -> Image px
paletteOf Image px
global GifImage { imgLocalPalette :: GifImage -> Maybe Palette
imgLocalPalette = Maybe Palette
Nothing } = Image px
global
paletteOf      Image px
_ GifImage { imgLocalPalette :: GifImage -> Maybe Palette
imgLocalPalette = Just Palette
p  } = forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Palette
p

getFrameDelays :: GifFile -> [GifDelay]
getFrameDelays :: GifFile -> [Int]
getFrameDelays GifFile { gifImages :: GifFile -> [(Maybe GraphicControlExtension, GifImage)]
gifImages = [] } = []
getFrameDelays GifFile { gifImages :: GifFile -> [(Maybe GraphicControlExtension, GifImage)]
gifImages = [(Maybe GraphicControlExtension, GifImage)]
imgs } = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b}. Num a => (Maybe GraphicControlExtension, b) -> a
extractDelay [(Maybe GraphicControlExtension, GifImage)]
imgs
    where extractDelay :: (Maybe GraphicControlExtension, b) -> a
extractDelay (Maybe GraphicControlExtension
ext, b
_) =
            case Maybe GraphicControlExtension
ext of
                Maybe GraphicControlExtension
Nothing -> a
0
                Just GraphicControlExtension
e -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ GraphicControlExtension -> Word16
gceDelay GraphicControlExtension
e

transparentColorOf :: Maybe GraphicControlExtension -> Int
transparentColorOf :: Maybe GraphicControlExtension -> Int
transparentColorOf Maybe GraphicControlExtension
Nothing = Int
300
transparentColorOf (Just GraphicControlExtension
ext)
  | GraphicControlExtension -> Bool
gceTransparentFlag GraphicControlExtension
ext = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ GraphicControlExtension -> Word8
gceTransparentColorIndex GraphicControlExtension
ext
  | Bool
otherwise = Int
300

hasTransparency :: Maybe GraphicControlExtension -> Bool
hasTransparency :: Maybe GraphicControlExtension -> Bool
hasTransparency Maybe GraphicControlExtension
Nothing = Bool
False
hasTransparency (Just GraphicControlExtension
control) = GraphicControlExtension -> Bool
gceTransparentFlag GraphicControlExtension
control

decodeAllGifImages :: GifFile -> [PalettedImage]
decodeAllGifImages :: GifFile -> [PalettedImage]
decodeAllGifImages GifFile { gifImages :: GifFile -> [(Maybe GraphicControlExtension, GifImage)]
gifImages = [] } = []
decodeAllGifImages GifFile { gifHeader :: GifFile -> GifHeader
gifHeader = GifHeader { gifGlobalMap :: GifHeader -> Maybe Palette
gifGlobalMap = Maybe Palette
palette
                                                   , gifScreenDescriptor :: GifHeader -> LogicalScreenDescriptor
gifScreenDescriptor = LogicalScreenDescriptor
wholeDescriptor }
                           , gifImages :: GifFile -> [(Maybe GraphicControlExtension, GifImage)]
gifImages = (Maybe GraphicControlExtension
firstControl, GifImage
firstImage) : [(Maybe GraphicControlExtension, GifImage)]
rest }
  | Bool -> Bool
not (Maybe GraphicControlExtension -> Bool
hasTransparency Maybe GraphicControlExtension
firstControl) =
      let backImage :: Palette
backImage =
              forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage (\Int
_ Int
_ -> PixelRGB8
backgroundColor) Int
globalWidth Int
globalHeight
          thisPalette :: Palette
thisPalette = forall px.
ColorConvertible PixelRGB8 px =>
Image px -> GifImage -> Image px
paletteOf Palette
globalPalette GifImage
firstImage
          baseImage :: Image Word8
baseImage = GifImage -> Image Word8
decodeImage GifImage
firstImage
          initState :: (Palette, Maybe GraphicControlExtension, Palette)
initState =
            (Palette
thisPalette, Maybe GraphicControlExtension
firstControl, Palette -> Image Word8 -> Palette
substituteColors Palette
thisPalette Image Word8
baseImage)
          scanner :: (Palette, Maybe GraphicControlExtension, Palette)
-> (Maybe GraphicControlExtension, GifImage)
-> (Palette, Maybe GraphicControlExtension, Palette)
scanner = 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 (Int
globalWidth, Int
globalHeight) Palette
thisPalette Palette
backImage
          palette' :: Palette' PixelRGB8
palette' = Palette'
            { _paletteSize :: Int
_paletteSize = forall a. Image a -> Int
imageWidth Palette
thisPalette
            , _paletteData :: Vector (PixelBaseComponent PixelRGB8)
_paletteData = forall a. Image a -> Vector (PixelBaseComponent a)
imageData Palette
thisPalette
            }
      in
      Image Word8 -> Palette' PixelRGB8 -> PalettedImage
PalettedRGB8 Image Word8
baseImage Palette' PixelRGB8
palette' forall a. a -> [a] -> [a]
:
        [DynamicImage -> PalettedImage
TrueColorImage forall a b. (a -> b) -> a -> b
$ Palette -> DynamicImage
ImageRGB8 Palette
img | (Palette
_, Maybe GraphicControlExtension
_, Palette
img) <- forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (Palette, Maybe GraphicControlExtension, Palette)
-> (Maybe GraphicControlExtension, GifImage)
-> (Palette, Maybe GraphicControlExtension, Palette)
scanner (Palette, Maybe GraphicControlExtension, Palette)
initState [(Maybe GraphicControlExtension, GifImage)]
rest]

  | Bool
otherwise =
      let backImage :: Image PixelRGBA8
          backImage :: Image PixelRGBA8
backImage =
            forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage (\Int
_ Int
_ -> PixelRGBA8
transparentBackground) Int
globalWidth Int
globalHeight

          thisPalette :: Image PixelRGBA8
          thisPalette :: Image PixelRGBA8
thisPalette = forall px.
ColorConvertible PixelRGB8 px =>
Image px -> GifImage -> Image px
paletteOf (forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Palette
globalPalette) GifImage
firstImage

          transparentCode :: Int
transparentCode = Maybe GraphicControlExtension -> Int
transparentColorOf Maybe GraphicControlExtension
firstControl
          decoded :: Image PixelRGBA8
decoded = 
            Int -> Image PixelRGBA8 -> Image Word8 -> Image PixelRGBA8
substituteColorsWithTransparency Int
transparentCode Image PixelRGBA8
thisPalette forall a b. (a -> b) -> a -> b
$
                GifImage -> Image Word8
decodeImage GifImage
firstImage

          initState :: (Image PixelRGBA8, Maybe GraphicControlExtension, Image PixelRGBA8)
initState = (Image PixelRGBA8
thisPalette, Maybe GraphicControlExtension
firstControl, Image PixelRGBA8
decoded)
          scanner :: (Image PixelRGBA8, Maybe GraphicControlExtension, Image PixelRGBA8)
-> (Maybe GraphicControlExtension, GifImage)
-> (Image PixelRGBA8, Maybe GraphicControlExtension,
    Image PixelRGBA8)
scanner =
            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 (Int
globalWidth, Int
globalHeight) Image PixelRGBA8
thisPalette Image PixelRGBA8
backImage in
      [DynamicImage -> PalettedImage
TrueColorImage forall a b. (a -> b) -> a -> b
$ Image PixelRGBA8 -> DynamicImage
ImageRGBA8 Image PixelRGBA8
img | (Image PixelRGBA8
_, Maybe GraphicControlExtension
_, Image PixelRGBA8
img) <- forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (Image PixelRGBA8, Maybe GraphicControlExtension, Image PixelRGBA8)
-> (Maybe GraphicControlExtension, GifImage)
-> (Image PixelRGBA8, Maybe GraphicControlExtension,
    Image PixelRGBA8)
scanner (Image PixelRGBA8, Maybe GraphicControlExtension, Image PixelRGBA8)
initState [(Maybe GraphicControlExtension, GifImage)]
rest]

    where
      globalWidth :: Int
globalWidth = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ LogicalScreenDescriptor -> Word16
screenWidth LogicalScreenDescriptor
wholeDescriptor
      globalHeight :: Int
globalHeight = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ LogicalScreenDescriptor -> Word16
screenHeight LogicalScreenDescriptor
wholeDescriptor
      globalPalette :: Palette
globalPalette = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Palette
greyPalette forall a. a -> a
id Maybe Palette
palette

      transparentBackground :: PixelRGBA8
transparentBackground = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
r Word8
g Word8
b Word8
0
          where PixelRGB8 Word8
r Word8
g Word8
b = PixelRGB8
backgroundColor

      backgroundColor :: PixelRGB8
backgroundColor
        | LogicalScreenDescriptor -> Bool
hasGlobalMap LogicalScreenDescriptor
wholeDescriptor =
            forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Palette
globalPalette (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ LogicalScreenDescriptor -> Word8
backgroundIndex LogicalScreenDescriptor
wholeDescriptor) Int
0
        | Bool
otherwise = Word8 -> Word8 -> Word8 -> PixelRGB8
PixelRGB8 Word8
0 Word8
0 Word8
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 :: 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 (Int
globalWidth, Int
globalHeight) Image px
globalPalette Image px
backgroundImage
          (Image px
_, Maybe GraphicControlExtension
prevControl, Image px
img1)
          (Maybe GraphicControlExtension
controlExt, img2 :: GifImage
img2@(GifImage { imgDescriptor :: GifImage -> ImageDescriptor
imgDescriptor = ImageDescriptor
descriptor })) =
            (Image px
thisPalette, Maybe GraphicControlExtension
controlExt, Image px
thisImage)
  where
    thisPalette :: Image px
    thisPalette :: Image px
thisPalette = forall px.
ColorConvertible PixelRGB8 px =>
Image px -> GifImage -> Image px
paletteOf Image px
globalPalette GifImage
img2

    thisImage :: Image px
thisImage = forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> px
pixeler Int
globalWidth Int
globalHeight
    localWidth :: Int
localWidth = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescImageWidth ImageDescriptor
descriptor
    localHeight :: Int
localHeight = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescImageHeight ImageDescriptor
descriptor

    left :: Int
left = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescPixelsFromLeft ImageDescriptor
descriptor
    top :: Int
top = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescPixelsFromTop ImageDescriptor
descriptor

    isPixelInLocalImage :: Int -> Int -> Bool
isPixelInLocalImage Int
x Int
y =
        Int
x forall a. Ord a => a -> a -> Bool
>= Int
left Bool -> Bool -> Bool
&& Int
x forall a. Ord a => a -> a -> Bool
< Int
left forall a. Num a => a -> a -> a
+ Int
localWidth Bool -> Bool -> Bool
&& Int
y forall a. Ord a => a -> a -> Bool
>= Int
top Bool -> Bool -> Bool
&& Int
y forall a. Ord a => a -> a -> Bool
< Int
top forall a. Num a => a -> a -> a
+ Int
localHeight

    decoded :: Image Pixel8
    decoded :: Image Word8
decoded = GifImage -> Image Word8
decodeImage GifImage
img2

    transparent :: Int
    transparent :: Int
transparent = case Maybe GraphicControlExtension
controlExt of
        Maybe GraphicControlExtension
Nothing  -> Int
300
        Just GraphicControlExtension
ext -> if GraphicControlExtension -> Bool
gceTransparentFlag GraphicControlExtension
ext
            then forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ GraphicControlExtension -> Word8
gceTransparentColorIndex GraphicControlExtension
ext
            else Int
300

    oldImage :: Image px
oldImage = case GraphicControlExtension -> GifDisposalMethod
gceDisposalMethod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe GraphicControlExtension
prevControl of
        Maybe GifDisposalMethod
Nothing -> Image px
img1
        Just GifDisposalMethod
DisposalAny -> Image px
img1
        Just GifDisposalMethod
DisposalDoNot -> Image px
img1
        Just GifDisposalMethod
DisposalRestoreBackground -> Image px
backgroundImage
        Just GifDisposalMethod
DisposalRestorePrevious -> Image px
img1
        Just (DisposalUnknown Word8
_) -> Image px
img1

    pixeler :: Int -> Int -> px
pixeler Int
x Int
y
      | Int -> Int -> Bool
isPixelInLocalImage Int
x Int
y Bool -> Bool -> Bool
&& Int
code forall a. Eq a => a -> a -> Bool
/= Int
transparent = px
val where
          code :: Int
code = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image Word8
decoded (Int
x forall a. Num a => a -> a -> a
- Int
left) (Int
y forall a. Num a => a -> a -> a
- Int
top)
          val :: px
val = forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image px
thisPalette (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
code) Int
0
    pixeler Int
x Int
y = forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image px
oldImage Int
x Int
y

decodeFirstGifImage :: GifFile -> Either String (PalettedImage, Metadatas)
decodeFirstGifImage :: GifFile -> Either String (PalettedImage, Metadatas)
decodeFirstGifImage img :: GifFile
img@GifFile { gifImages :: GifFile -> [(Maybe GraphicControlExtension, GifImage)]
gifImages = ((Maybe GraphicControlExtension, GifImage)
firstImage:[(Maybe GraphicControlExtension, GifImage)]
_) } =
    case GifFile -> [PalettedImage]
decodeAllGifImages GifFile
img { gifImages :: [(Maybe GraphicControlExtension, GifImage)]
gifImages = [(Maybe GraphicControlExtension, GifImage)
firstImage] } of
      [] -> forall a b. a -> Either a b
Left String
"No image after decoding"
      (PalettedImage
i:[PalettedImage]
_) -> forall a b. b -> Either a b
Right (PalettedImage
i, forall nSize.
Integral nSize =>
SourceFormat -> nSize -> nSize -> Metadatas
basicMetadata SourceFormat
SourceGif (LogicalScreenDescriptor -> Word16
screenWidth LogicalScreenDescriptor
hdr) (LogicalScreenDescriptor -> Word16
screenHeight LogicalScreenDescriptor
hdr))
  where hdr :: LogicalScreenDescriptor
hdr = GifHeader -> LogicalScreenDescriptor
gifScreenDescriptor forall a b. (a -> b) -> a -> b
$ GifFile -> GifHeader
gifHeader GifFile
img
decodeFirstGifImage GifFile
_ = forall a b. a -> Either a b
Left String
"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 :: ByteString -> Either String DynamicImage
decodeGif ByteString
img = forall a. Binary a => ByteString -> Either String a
decode ByteString
img forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PalettedImage -> DynamicImage
palettedToTrueColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. GifFile -> Either String (PalettedImage, Metadatas)
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 :: ByteString -> Either String (DynamicImage, Metadatas)
decodeGifWithMetadata ByteString
img = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first PalettedImage -> DynamicImage
palettedToTrueColor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String (PalettedImage, Metadatas)
decodeGifWithPaletteAndMetadata ByteString
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 :: ByteString -> Either String (PalettedImage, Metadatas)
decodeGifWithPaletteAndMetadata ByteString
img = forall a. Binary a => ByteString -> Either String a
decode ByteString
img forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GifFile -> Either String (PalettedImage, Metadatas)
decodeFirstGifImage

-- | Transform a raw gif to a list of images, representing

-- all the images of an animation.

decodeGifImages :: B.ByteString -> Either String [DynamicImage]
decodeGifImages :: ByteString -> Either String [DynamicImage]
decodeGifImages ByteString
img = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PalettedImage -> DynamicImage
palettedToTrueColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. GifFile -> [PalettedImage]
decodeAllGifImages forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => ByteString -> Either String a
decode ByteString
img

-- | Extract a list of frame delays from a raw gif.

getDelaysGifImages :: B.ByteString -> Either String [GifDelay]
getDelaysGifImages :: ByteString -> Either String [Int]
getDelaysGifImages ByteString
img = GifFile -> [Int]
getFrameDelays forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => ByteString -> Either String a
decode ByteString
img

-- | Default palette to produce greyscale images.

greyPalette :: Palette
greyPalette :: Palette
greyPalette = forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage forall {a} {p}. Integral a => a -> p -> PixelRGB8
toGrey Int
256 Int
1
  where toGrey :: a -> p -> PixelRGB8
toGrey a
x p
_ = Word8 -> Word8 -> Word8 -> PixelRGB8
PixelRGB8 Word8
ix Word8
ix Word8
ix
           where ix :: Word8
ix = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x

checkImageSizes :: GifEncode -> Either String ()
checkImageSizes :: GifEncode -> Either String ()
checkImageSizes GifEncode { geWidth :: GifEncode -> Int
geWidth = Int
width, geHeight :: GifEncode -> Int
geHeight = Int
height, geFrames :: GifEncode -> [GifFrame]
geFrames = [GifFrame]
frames }
  | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall {a}. (Ord a, Num a) => a -> Bool
isInBounds Int
width Bool -> Bool -> Bool
&& forall {a}. (Ord a, Num a) => a -> Bool
isInBounds Int
height = forall a b. a -> Either a b
Left String
"Invalid screen bounds"
  | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(GifFrame, Int)]
outOfBounds = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"GIF frames with invalid bounds: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(GifFrame, Int)]
outOfBounds)
  | Bool
otherwise = forall a b. b -> Either a b
Right ()
  where isInBounds :: a -> Bool
isInBounds a
dim = a
dim forall a. Ord a => a -> a -> Bool
> a
0 Bool -> Bool -> Bool
&& a
dim forall a. Ord a => a -> a -> Bool
<= a
0xffff
        outOfBounds :: [(GifFrame, Int)]
outOfBounds = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. GifFrame -> Bool
isFrameInBounds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [GifFrame]
frames [Int
0 :: Int ..]
        isFrameInBounds :: GifFrame -> Bool
isFrameInBounds GifFrame { gfPixels :: GifFrame -> Image Word8
gfPixels = Image Word8
img } = forall {a}. (Ord a, Num a) => a -> Bool
isInBounds (forall a. Image a -> Int
imageWidth Image Word8
img) Bool -> Bool -> Bool
&& forall {a}. (Ord a, Num a) => a -> Bool
isInBounds (forall a. Image a -> Int
imageHeight Image Word8
img)

checkImagesInBounds :: GifEncode -> Either String ()
checkImagesInBounds :: GifEncode -> Either String ()
checkImagesInBounds GifEncode { geWidth :: GifEncode -> Int
geWidth = Int
width, geHeight :: GifEncode -> Int
geHeight = Int
height, geFrames :: GifEncode -> [GifFrame]
geFrames = [GifFrame]
frames } =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(GifFrame, Int)]
outOfBounds
  then forall a b. b -> Either a b
Right ()
  else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"GIF frames out of screen bounds: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(GifFrame, Int)]
outOfBounds)
  where outOfBounds :: [(GifFrame, Int)]
outOfBounds = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. GifFrame -> Bool
isInBounds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [GifFrame]
frames [Int
0 :: Int ..]
        isInBounds :: GifFrame -> Bool
isInBounds GifFrame { gfXOffset :: GifFrame -> Int
gfXOffset = Int
xOff, gfYOffset :: GifFrame -> Int
gfYOffset = Int
yOff, gfPixels :: GifFrame -> Image Word8
gfPixels = Image Word8
img } =
          Int
xOff forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
yOff forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&&
          Int
xOff forall a. Num a => a -> a -> a
+ forall a. Image a -> Int
imageWidth Image Word8
img forall a. Ord a => a -> a -> Bool
<= Int
width Bool -> Bool -> Bool
&& Int
yOff forall a. Num a => a -> a -> a
+ forall a. Image a -> Int
imageHeight Image Word8
img forall a. Ord a => a -> a -> Bool
<= Int
height

checkPaletteValidity :: GifEncode -> Either String ()
checkPaletteValidity :: GifEncode -> Either String ()
checkPaletteValidity GifEncode
spec
  | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall {a}. Maybe (Image a) -> Bool
isPaletteValid forall a b. (a -> b) -> a -> b
$ GifEncode -> Maybe Palette
gePalette GifEncode
spec = forall a b. a -> Either a b
Left String
"Invalid global palette size"
  | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(GifFrame, Int)]
invalidPalettes = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Invalid palette size in GIF frames: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(GifFrame, Int)]
invalidPalettes)
  | Bool
otherwise = forall a b. b -> Either a b
Right ()
  where invalidPalettes :: [(GifFrame, Int)]
invalidPalettes = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Maybe (Image a) -> Bool
isPaletteValid forall b c a. (b -> c) -> (a -> b) -> a -> c
. GifFrame -> Maybe Palette
gfPalette forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (GifEncode -> [GifFrame]
geFrames GifEncode
spec) [Int
0 :: Int ..]
        isPaletteValid :: Maybe (Image a) -> Bool
isPaletteValid Maybe (Image a)
Nothing  = Bool
True
        isPaletteValid (Just Image a
p) = let w :: Int
w = forall a. Image a -> Int
imageWidth Image a
p
                                      h :: Int
h = forall a. Image a -> Int
imageHeight Image a
p
                                  in Int
h forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Int
w forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
w forall a. Ord a => a -> a -> Bool
<= Int
256

checkIndexAbsentFromPalette :: GifEncode -> Either String ()
checkIndexAbsentFromPalette :: GifEncode -> Either String ()
checkIndexAbsentFromPalette GifEncode { gePalette :: GifEncode -> Maybe Palette
gePalette = Maybe Palette
global, geFrames :: GifEncode -> [GifFrame]
geFrames = [GifFrame]
frames } =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(GifFrame, Int)]
missingPalette
  then forall a b. b -> Either a b
Right ()
  else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"GIF image frames with color indexes missing from palette: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(GifFrame, Int)]
missingPalette)
  where missingPalette :: [(GifFrame, Int)]
missingPalette = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. GifFrame -> Bool
checkFrame forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [GifFrame]
frames [Int
0 :: Int ..]
        checkFrame :: GifFrame -> Bool
checkFrame GifFrame
frame = forall a. Storable a => (a -> Bool) -> Vector a -> Bool
V.all (Maybe Palette -> Maybe Palette -> Int -> Bool
checkIndexInPalette Maybe Palette
global (GifFrame -> Maybe Palette
gfPalette GifFrame
frame) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) forall a b. (a -> b) -> a -> b
$
                           forall a. Image a -> Vector (PixelBaseComponent a)
imageData forall a b. (a -> b) -> a -> b
$ GifFrame -> Image Word8
gfPixels GifFrame
frame

checkBackground :: GifEncode -> Either String ()
checkBackground :: GifEncode -> Either String ()
checkBackground GifEncode { geBackground :: GifEncode -> Maybe Int
geBackground = Maybe Int
Nothing } = forall a b. b -> Either a b
Right ()
checkBackground GifEncode { gePalette :: GifEncode -> Maybe Palette
gePalette = Maybe Palette
global, geBackground :: GifEncode -> Maybe Int
geBackground = Just Int
background } =
  if Maybe Palette -> Maybe Palette -> Int -> Bool
checkIndexInPalette Maybe Palette
global forall a. Maybe a
Nothing Int
background
  then forall a b. b -> Either a b
Right ()
  else forall a b. a -> Either a b
Left String
"GIF background index absent from global palette"

checkTransparencies :: GifEncode -> Either String ()
checkTransparencies :: GifEncode -> Either String ()
checkTransparencies GifEncode { gePalette :: GifEncode -> Maybe Palette
gePalette = Maybe Palette
global, geFrames :: GifEncode -> [GifFrame]
geFrames = [GifFrame]
frames } =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(GifFrame, Int)]
missingTransparency
  then forall a b. b -> Either a b
Right ()
  else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"GIF transparent index absent from palettes for frames: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(GifFrame, Int)]
missingTransparency)
  where missingTransparency :: [(GifFrame, Int)]
missingTransparency = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. GifFrame -> Bool
transparencyOK forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [GifFrame]
frames [Int
0 :: Int ..]
        transparencyOK :: GifFrame -> Bool
transparencyOK GifFrame { gfTransparent :: GifFrame -> Maybe Int
gfTransparent = Maybe Int
Nothing } = Bool
True
        transparencyOK GifFrame { gfPalette :: GifFrame -> Maybe Palette
gfPalette = Maybe Palette
local, gfTransparent :: GifFrame -> Maybe Int
gfTransparent = Just Int
transparent } =
          Maybe Palette -> Maybe Palette -> Int -> Bool
checkIndexInPalette Maybe Palette
global Maybe Palette
local Int
transparent

checkIndexInPalette :: Maybe Palette -> Maybe Palette -> Int -> Bool
checkIndexInPalette :: Maybe Palette -> Maybe Palette -> Int -> Bool
checkIndexInPalette Maybe Palette
Nothing       Maybe Palette
Nothing      Int
_  = Bool
False
checkIndexInPalette Maybe Palette
_             (Just Palette
local) Int
ix = Int
ix forall a. Ord a => a -> a -> Bool
< forall a. Image a -> Int
imageWidth Palette
local
checkIndexInPalette (Just Palette
global) Maybe Palette
_            Int
ix = Int
ix forall a. Ord a => a -> a -> Bool
< forall a. Image a -> Int
imageWidth Palette
global

checkGifImageSizes :: [(a, b, Image px)] -> Bool
checkGifImageSizes :: forall a b px. [(a, b, Image px)] -> Bool
checkGifImageSizes [] = Bool
False
checkGifImageSizes ((a
_, b
_, Image px
img) : [(a, b, Image px)]
rest) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a, b, Image px) -> Bool
checkDimension [(a, b, Image px)]
rest
   where width :: Int
width = forall a. Image a -> Int
imageWidth Image px
img
         height :: Int
height = forall a. Image a -> Int
imageHeight Image px
img

         checkDimension :: (a, b, Image px) -> Bool
checkDimension (a
_,b
_,Image { imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h }) =
             Int
w forall a. Eq a => a -> a -> Bool
== Int
width Bool -> Bool -> Bool
&& Int
h forall a. Eq a => a -> a -> Bool
== Int
height

computeColorTableSize :: Palette -> Int
computeColorTableSize :: Palette -> Int
computeColorTableSize Image { imageWidth :: forall a. Image a -> Int
imageWidth = Int
itemCount } = Int -> Int
go Int
1
  where go :: Int -> Int
go Int
k | Int
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
k forall a. Ord a => a -> a -> Bool
>= Int
itemCount = Int
k
             | Bool
otherwise = Int -> Int
go forall a b. (a -> b) -> a -> b
$ Int
k forall a. Num a => a -> a -> a
+ Int
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 :: GifEncode -> Either String ByteString
encodeComplexGifImage GifEncode
spec = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ GifEncode -> [GifFrame]
geFrames GifEncode
spec) forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"No GIF frames"
  GifEncode -> Either String ()
checkImageSizes GifEncode
spec
  GifEncode -> Either String ()
checkImagesInBounds GifEncode
spec
  GifEncode -> Either String ()
checkPaletteValidity GifEncode
spec
  GifEncode -> Either String ()
checkBackground GifEncode
spec
  GifEncode -> Either String ()
checkTransparencies GifEncode
spec
  GifEncode -> Either String ()
checkIndexAbsentFromPalette GifEncode
spec

  forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Binary a => a -> ByteString
encode GifFile
allFile
  where
    GifEncode { geWidth :: GifEncode -> Int
geWidth      = Int
width
              , geHeight :: GifEncode -> Int
geHeight     = Int
height
              , gePalette :: GifEncode -> Maybe Palette
gePalette    = Maybe Palette
globalPalette
              , geBackground :: GifEncode -> Maybe Int
geBackground = Maybe Int
background
              , geLooping :: GifEncode -> GifLooping
geLooping    = GifLooping
looping
              , geFrames :: GifEncode -> [GifFrame]
geFrames     = [GifFrame]
frames
              } = GifEncode
spec
    allFile :: GifFile
allFile = GifFile
      { gifHeader :: GifHeader
gifHeader = GifHeader
        { gifVersion :: GifVersion
gifVersion          = GifVersion
version
        , gifScreenDescriptor :: LogicalScreenDescriptor
gifScreenDescriptor = LogicalScreenDescriptor
logicalScreen
        , gifGlobalMap :: Maybe Palette
gifGlobalMap        = Maybe Palette
globalPalette
        }
      , gifImages :: [(Maybe GraphicControlExtension, GifImage)]
gifImages           = [(Maybe GraphicControlExtension, GifImage)]
toSerialize
      , gifLoopingBehaviour :: GifLooping
gifLoopingBehaviour = GifLooping
looping
      }

    version :: GifVersion
version = case [GifFrame]
frames of
      [] -> GifVersion
GIF87a
      [GifFrame
_] -> GifVersion
GIF87a
      GifFrame
_:GifFrame
_:[GifFrame]
_ -> GifVersion
GIF89a

    logicalScreen :: LogicalScreenDescriptor
logicalScreen = LogicalScreenDescriptor
      { screenWidth :: Word16
screenWidth        = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width
      , screenHeight :: Word16
screenHeight       = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height
      , backgroundIndex :: Word8
backgroundIndex    = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word8
0 forall a b. (Integral a, Num b) => a -> b
fromIntegral Maybe Int
background
      , hasGlobalMap :: Bool
hasGlobalMap       = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a b. a -> b -> a
const Bool
True) Maybe Palette
globalPalette
      , colorResolution :: Word8
colorResolution    = Word8
8
      , isColorTableSorted :: Bool
isColorTableSorted = Bool
False
      -- Imply a 8 bit global palette size if there's no explicit global palette.

      , colorTableSize :: Word8
colorTableSize     = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word8
8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Palette -> Int
computeColorTableSize) Maybe Palette
globalPalette
      }

    toSerialize :: [(Maybe GraphicControlExtension, GifImage)]
toSerialize = [(forall {a} {a}.
(Integral a, Integral a) =>
a -> Maybe a -> GifDisposalMethod -> Maybe GraphicControlExtension
controlExtension Int
delay Maybe Int
transparent GifDisposalMethod
disposal, GifImage
                     { imgDescriptor :: ImageDescriptor
imgDescriptor = forall {a} {a} {a}.
(Integral a, Integral a) =>
a -> a -> Maybe Palette -> Image a -> ImageDescriptor
imageDescriptor Int
left Int
top Maybe Palette
localPalette Image Word8
img
                     , imgLocalPalette :: Maybe Palette
imgLocalPalette = Maybe Palette
localPalette
                     , imgLzwRootSize :: Word8
imgLzwRootSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lzwKeySize
                     , imgData :: ByteString
imgData = [ByteString] -> ByteString
B.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Vector Word8 -> ByteString
lzwEncode Int
lzwKeySize forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image Word8
img
                     })
                  | GifFrame { gfXOffset :: GifFrame -> Int
gfXOffset     = Int
left
                             , gfYOffset :: GifFrame -> Int
gfYOffset     = Int
top
                             , gfPalette :: GifFrame -> Maybe Palette
gfPalette     = Maybe Palette
localPalette
                             , gfTransparent :: GifFrame -> Maybe Int
gfTransparent = Maybe Int
transparent
                             , gfDelay :: GifFrame -> Int
gfDelay       = Int
delay
                             , gfDisposal :: GifFrame -> GifDisposalMethod
gfDisposal    = GifDisposalMethod
disposal
                             , gfPixels :: GifFrame -> Image Word8
gfPixels      = Image Word8
img } <- [GifFrame]
frames
                  , let palette :: Palette
palette = case (Maybe Palette
globalPalette, Maybe Palette
localPalette) of
                          (Maybe Palette
_, Just Palette
local)        -> Palette
local
                          (Just Palette
global, Maybe Palette
Nothing) -> Palette
global
                          (Maybe Palette
Nothing, Maybe Palette
Nothing)     -> forall a. HasCallStack => String -> a
error String
"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 :: Int
lzwKeySize = forall a. Ord a => a -> a -> a
max Int
2 forall a b. (a -> b) -> a -> b
$ Palette -> Int
computeColorTableSize Palette
palette
                  ]

    controlExtension :: a -> Maybe a -> GifDisposalMethod -> Maybe GraphicControlExtension
controlExtension a
0     Maybe a
Nothing     GifDisposalMethod
DisposalAny = forall a. Maybe a
Nothing
    controlExtension a
delay Maybe a
transparent GifDisposalMethod
disposal    = forall a. a -> Maybe a
Just GraphicControlExtension
      { gceDisposalMethod :: GifDisposalMethod
gceDisposalMethod        = GifDisposalMethod
disposal
      , gceUserInputFlag :: Bool
gceUserInputFlag         = Bool
False
      , gceTransparentFlag :: Bool
gceTransparentFlag       = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a b. a -> b -> a
const Bool
True) Maybe a
transparent
      , gceDelay :: Word16
gceDelay                 = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
delay
      , gceTransparentColorIndex :: Word8
gceTransparentColorIndex = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word8
0 forall a b. (Integral a, Num b) => a -> b
fromIntegral Maybe a
transparent
      }

    imageDescriptor :: a -> a -> Maybe Palette -> Image a -> ImageDescriptor
imageDescriptor a
left a
top Maybe Palette
localPalette Image a
img = ImageDescriptor
      { gDescPixelsFromLeft :: Word16
gDescPixelsFromLeft         = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
left
      , gDescPixelsFromTop :: Word16
gDescPixelsFromTop          = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
top
      , gDescImageWidth :: Word16
gDescImageWidth             = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Int
imageWidth Image a
img
      , gDescImageHeight :: Word16
gDescImageHeight            = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Int
imageHeight Image a
img
      , gDescHasLocalMap :: Bool
gDescHasLocalMap            = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a b. a -> b -> a
const Bool
True) Maybe Palette
localPalette
      , gDescIsInterlaced :: Bool
gDescIsInterlaced           = Bool
False
      , gDescIsImgDescriptorSorted :: Bool
gDescIsImgDescriptorSorted  = Bool
False
      , gDescLocalColorTableSize :: Word8
gDescLocalColorTableSize    = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word8
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Palette -> Int
computeColorTableSize) Maybe Palette
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 :: GifLooping
-> [(Palette, Int, Image Word8)] -> Either String ByteString
encodeGifImages GifLooping
_ [] = forall a b. a -> Either a b
Left String
"No image in list"
encodeGifImages GifLooping
_ [(Palette, Int, Image Word8)]
imageList
    | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a b px. [(a, b, Image px)] -> Bool
checkGifImageSizes [(Palette, Int, Image Word8)]
imageList = forall a b. a -> Either a b
Left String
"Gif images have different size"
encodeGifImages GifLooping
looping imageList :: [(Palette, Int, Image Word8)]
imageList@((Palette
firstPalette, Int
_,Image Word8
firstImage):[(Palette, Int, Image Word8)]
_) =
  GifEncode -> Either String ByteString
encodeComplexGifImage forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> Maybe Palette
-> Maybe Int
-> GifLooping
-> [GifFrame]
-> GifEncode
GifEncode (forall a. Image a -> Int
imageWidth Image Word8
firstImage) (forall a. Image a -> Int
imageHeight Image Word8
firstImage) (forall a. a -> Maybe a
Just Palette
firstPalette) forall a. Maybe a
Nothing GifLooping
looping [GifFrame]
frames
  where
    frames :: [GifFrame]
frames = [ Int
-> Int
-> Maybe Palette
-> Maybe Int
-> Int
-> GifDisposalMethod
-> Image Word8
-> GifFrame
GifFrame Int
0 Int
0 Maybe Palette
localPalette forall a. Maybe a
Nothing Int
delay GifDisposalMethod
DisposalAny Image Word8
image
             | (Palette
palette, Int
delay, Image Word8
image) <- [(Palette, Int, Image Word8)]
imageList
             , let localPalette :: Maybe Palette
localPalette = if Palette -> Bool
paletteEqual Palette
palette then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Palette
palette ]

    paletteEqual :: Palette -> Bool
paletteEqual Palette
p = forall a. Image a -> Vector (PixelBaseComponent a)
imageData Palette
firstPalette forall a. Eq a => a -> a -> Bool
== forall a. Image a -> Vector (PixelBaseComponent a)
imageData Palette
p

-- | Encode a greyscale image to a bytestring.

encodeGifImage :: Image Pixel8 -> L.ByteString
encodeGifImage :: Image Word8 -> ByteString
encodeGifImage Image Word8
img = case GifLooping
-> [(Palette, Int, Image Word8)] -> Either String ByteString
encodeGifImages GifLooping
LoopingNever [(Palette
greyPalette, Int
0, Image Word8
img)] of
    Left String
err -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Impossible:" forall a. [a] -> [a] -> [a]
++ String
err
    Right ByteString
v -> ByteString
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 :: Image Word8 -> Palette -> Either String ByteString
encodeGifImageWithPalette Image Word8
img Palette
palette =
    GifLooping
-> [(Palette, Int, Image Word8)] -> Either String ByteString
encodeGifImages GifLooping
LoopingNever [(Palette
palette, Int
0, Image Word8
img)]

-- | Write a greyscale in a gif file on the disk.

writeGifImage :: FilePath -> Image Pixel8 -> IO ()
writeGifImage :: String -> Image Word8 -> IO ()
writeGifImage String
file = String -> ByteString -> IO ()
L.writeFile String
file forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Word8 -> ByteString
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 :: String
-> GifLooping
-> [(Palette, Int, Image Word8)]
-> Either String (IO ())
writeGifImages String
file GifLooping
looping [(Palette, Int, Image Word8)]
lst = String -> ByteString -> IO ()
L.writeFile String
file forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GifLooping
-> [(Palette, Int, Image Word8)] -> Either String ByteString
encodeGifImages GifLooping
looping [(Palette, Int, Image Word8)]
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 :: String -> Image Word8 -> Palette -> Either String (IO ())
writeGifImageWithPalette String
file Image Word8
img Palette
palette =
    String -> ByteString -> IO ()
L.writeFile String
file forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Image Word8 -> Palette -> Either String ByteString
encodeGifImageWithPalette Image Word8
img Palette
palette

writeComplexGifImage :: FilePath -> GifEncode -> Either String (IO ())
writeComplexGifImage :: String -> GifEncode -> Either String (IO ())
writeComplexGifImage String
file GifEncode
spec = String -> ByteString -> IO ()
L.writeFile String
file forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GifEncode -> Either String ByteString
encodeComplexGifImage GifEncode
spec