{-# 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 Pixel8
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 = [Pixel8] -> ByteString
B.pack ([Pixel8] -> ByteString) -> [Pixel8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Pixel8) -> [Char] -> [Pixel8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pixel8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Pixel8) -> (Char -> Int) -> Char -> Pixel8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) [Char]
"GIF87a"
gif89aSignature :: ByteString
gif89aSignature = [Pixel8] -> ByteString
B.pack ([Pixel8] -> ByteString) -> [Pixel8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Pixel8) -> [Char] -> [Pixel8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pixel8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Pixel8) -> (Char -> Int) -> Char -> Pixel8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) [Char]
"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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
gif87aSignature, ByteString
sig ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
gif89aSignature) of
            (Bool
True, Bool
_)  -> GifVersion -> Get GifVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure GifVersion
GIF87a
            (Bool
_ , Bool
True) -> GifVersion -> Get GifVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure GifVersion
GIF89a
            (Bool, Bool)
_          -> [Char] -> Get GifVersion
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Get GifVersion) -> [Char] -> Get GifVersion
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid Gif signature : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Pixel8 -> Int) -> Pixel8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pixel8 -> Int
forall a. Enum a => a -> Int
fromEnum (Pixel8 -> Char) -> [Pixel8] -> [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [Pixel8]
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 -> Pixel8
backgroundIndex       :: !Word8

  -- | Stored on 1 bit

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

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

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

  , LogicalScreenDescriptor -> Pixel8
colorTableSize        :: !Word8
  }

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

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

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

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

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

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

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

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

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

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


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

putDataBlocks :: B.ByteString -> Put
putDataBlocks :: ByteString -> Put
putDataBlocks ByteString
wholeString = ByteString -> Put
putSlices ByteString
wholeString Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pixel8 -> Put
putWord8 Pixel8
0
  where putSlices :: ByteString -> Put
putSlices ByteString
str | ByteString -> Int
B.length ByteString
str Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = () -> Put
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                      | ByteString -> Int
B.length ByteString
str Int -> Int -> Bool
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
            Pixel8 -> Put
putWord8 Pixel8
0xFF Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
putByteString ByteString
before Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
putSlices ByteString
after
        putSlices ByteString
str =
            Pixel8 -> Put
putWord8 (Int -> Pixel8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Pixel8) -> Int -> Pixel8
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
str) Put -> Put -> Put
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 :: Pixel8 -> GifDisposalMethod
disposalMethodOfCode Pixel8
v = case Pixel8
v of
    Pixel8
0 -> GifDisposalMethod
DisposalAny
    Pixel8
1 -> GifDisposalMethod
DisposalDoNot
    Pixel8
2 -> GifDisposalMethod
DisposalRestoreBackground
    Pixel8
3 -> GifDisposalMethod
DisposalRestorePrevious
    Pixel8
n -> Pixel8 -> GifDisposalMethod
DisposalUnknown Pixel8
n

codeOfDisposalMethod :: GifDisposalMethod -> Word8
codeOfDisposalMethod :: GifDisposalMethod -> Pixel8
codeOfDisposalMethod GifDisposalMethod
v = case GifDisposalMethod
v of
    GifDisposalMethod
DisposalAny -> Pixel8
0
    GifDisposalMethod
DisposalDoNot -> Pixel8
1
    GifDisposalMethod
DisposalRestoreBackground -> Pixel8
2
    GifDisposalMethod
DisposalRestorePrevious -> Pixel8
3
    DisposalUnknown Pixel8
n -> Pixel8
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 -> Pixel8
gceTransparentColorIndex :: !Word8
    }

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

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

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

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

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

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


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

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

data GifImage = GifImage
    { GifImage -> ImageDescriptor
imgDescriptor   :: !ImageDescriptor
    , GifImage -> Maybe Palette
imgLocalPalette :: !(Maybe Palette)
    , GifImage -> Pixel8
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
        ImageDescriptor -> Put
forall t. Binary t => t -> Put
put ImageDescriptor
descriptor
        case ( GifImage -> Maybe Palette
imgLocalPalette GifImage
img
             , ImageDescriptor -> Bool
gDescHasLocalMap (ImageDescriptor -> Bool) -> ImageDescriptor -> Bool
forall a b. (a -> b) -> a -> b
$ GifImage -> ImageDescriptor
imgDescriptor GifImage
img) of
          (Maybe Palette
Nothing, Bool
_) -> () -> Put
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          (Just Palette
_, Bool
False) -> () -> Put
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          (Just Palette
p, Bool
True) ->
              Int -> Palette -> Put
putPalette (Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel8 -> Int) -> Pixel8 -> Int
forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Pixel8
gDescLocalColorTableSize ImageDescriptor
descriptor) Palette
p
        Pixel8 -> Put
putWord8 (Pixel8 -> Put) -> Pixel8 -> Put
forall a b. (a -> b) -> a -> b
$ GifImage -> Pixel8
imgLzwRootSize GifImage
img
        ByteString -> Put
putDataBlocks (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ GifImage -> ByteString
imgData GifImage
img

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

        ImageDescriptor
-> Maybe Palette -> Pixel8 -> ByteString -> GifImage
GifImage ImageDescriptor
desc Maybe Palette
palette (Pixel8 -> ByteString -> GifImage)
-> Get Pixel8 -> Get (ByteString -> GifImage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Pixel8
getWord8 Get (ByteString -> GifImage) -> Get ByteString -> Get GifImage
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 <- Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel8 -> Int) -> Get Pixel8 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Pixel8
getWord8
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
    Int -> Get ()
skip Int
s Get () -> Get () -> Get ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get ()
skipSubDataBlocks

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

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

    extensionParse :: Pixel8 -> Get [Block]
extensionParse Pixel8
code
     | Pixel8
code Pixel8 -> Pixel8 -> Bool
forall a. Eq a => a -> a -> Bool
== Pixel8
graphicControlLabel =
        (:) (Block -> [Block] -> [Block])
-> Get Block -> Get ([Block] -> [Block])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GraphicControlExtension -> Block
BlockGraphicControl (GraphicControlExtension -> Block)
-> Get GraphicControlExtension -> Get Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get GraphicControlExtension
forall t. Binary t => Get t
get) Get ([Block] -> [Block]) -> Get [Block] -> Get [Block]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [Block]
parseGifBlocks
     | Pixel8
code Pixel8 -> Pixel8 -> Bool
forall a. Eq a => a -> a -> Bool
== Pixel8
commentLabel = Get ()
skipSubDataBlocks Get () -> Get [Block] -> Get [Block]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get [Block]
parseGifBlocks
     | Pixel8
code Pixel8 -> [Pixel8] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Pixel8
plainTextLabel, Pixel8
applicationLabel] =
        Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel8 -> Int) -> Get Pixel8 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Pixel8
getWord8 Get Int -> (Int -> Get ()) -> Get ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get ()
skip Get () -> Get () -> Get ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get ()
skipSubDataBlocks Get () -> Get [Block] -> Get [Block]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get [Block]
parseGifBlocks
     | Bool
otherwise = Get ByteString
parseDataBlocks Get ByteString -> Get [Block] -> Get [Block]
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
        Pixel8 -> Put
putWord8 Pixel8
imageSeparator
        Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescPixelsFromLeft ImageDescriptor
v
        Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescPixelsFromTop ImageDescriptor
v
        Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescImageWidth ImageDescriptor
v
        Word16 -> Put
putWord16le (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ ImageDescriptor -> Word16
gDescImageHeight ImageDescriptor
v
        let localMapField :: Pixel8
localMapField
                | ImageDescriptor -> Bool
gDescHasLocalMap ImageDescriptor
v = Pixel8
0 Pixel8 -> Int -> Pixel8
forall a. Bits a => a -> Int -> a
`setBit` Int
7
                | Bool
otherwise = Pixel8
0

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

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

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

            packedFields :: Pixel8
packedFields = Pixel8
localMapField
                        Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.|. Pixel8
isInterlacedField
                        Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.|. Pixel8
isImageDescriptorSorted
                        Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.|. Pixel8
tableSizeField
        Pixel8 -> Put
putWord8 Pixel8
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
        Pixel8
packedFields <- Get Pixel8
getWord8
        ImageDescriptor -> Get ImageDescriptor
forall (m :: * -> *) a. Monad m => a -> m a
return ImageDescriptor :: Word16
-> Word16
-> Word16
-> Word16
-> Bool
-> Bool
-> Bool
-> Pixel8
-> ImageDescriptor
ImageDescriptor
            { gDescPixelsFromLeft :: Word16
gDescPixelsFromLeft = Word16
imgLeftPos
            , gDescPixelsFromTop :: Word16
gDescPixelsFromTop  = Word16
imgTopPos
            , gDescImageWidth :: Word16
gDescImageWidth     = Word16
imgWidth
            , gDescImageHeight :: Word16
gDescImageHeight    = Word16
imgHeight
            , gDescHasLocalMap :: Bool
gDescHasLocalMap    = Pixel8
packedFields Pixel8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7
            , gDescIsInterlaced :: Bool
gDescIsInterlaced     = Pixel8
packedFields Pixel8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
6
            , gDescIsImgDescriptorSorted :: Bool
gDescIsImgDescriptorSorted = Pixel8
packedFields Pixel8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
5
            , gDescLocalColorTableSize :: Pixel8
gDescLocalColorTableSize = (Pixel8
packedFields Pixel8 -> Pixel8 -> Pixel8
forall a. Bits a => a -> a -> a
.&. Pixel8
0x7) Pixel8 -> Pixel8 -> Pixel8
forall a. Num a => a -> a -> a
+ Pixel8
1
            }


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

----            Palette

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

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

putPalette :: Int -> Palette -> Put
putPalette :: Int -> Palette -> Put
putPalette Int
size Palette
pal = do
    (Pixel8 -> Put) -> Vector Pixel8 -> Put
forall (m :: * -> *) a b.
(Monad m, Storable a) =>
(a -> m b) -> Vector a -> m ()
V.mapM_ Pixel8 -> Put
putWord8 (Palette -> Vector (PixelBaseComponent PixelRGB8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Palette
pal)
    Int -> Put -> Put
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
missingColorComponent (Pixel8 -> Put
putWord8 Pixel8
0)
  where elemCount :: Int
elemCount = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
size
        missingColorComponent :: Int
missingColorComponent = (Int
elemCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Palette -> Int
forall a. Image a -> Int
imageWidth Palette
pal) Int -> Int -> Int
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
      GifVersion -> Put
forall t. Binary t => t -> Put
put (GifVersion -> Put) -> GifVersion -> Put
forall a b. (a -> b) -> a -> b
$ GifHeader -> GifVersion
gifVersion GifHeader
v
      let descr :: LogicalScreenDescriptor
descr = GifHeader -> LogicalScreenDescriptor
gifScreenDescriptor GifHeader
v
      LogicalScreenDescriptor -> Put
forall t. Binary t => t -> Put
put LogicalScreenDescriptor
descr
      case GifHeader -> Maybe Palette
gifGlobalMap GifHeader
v of
        Just Palette
palette -> Int -> Palette -> Put
putPalette (Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel8 -> Int) -> Pixel8 -> Int
forall a b. (a -> b) -> a -> b
$ LogicalScreenDescriptor -> Pixel8
colorTableSize LogicalScreenDescriptor
descr) Palette
palette
        Maybe Palette
Nothing      -> () -> Put
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

        GifHeader -> Get GifHeader
forall (m :: * -> *) a. Monad m => a -> m a
return GifHeader :: GifVersion -> LogicalScreenDescriptor -> Maybe Palette -> GifHeader
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 = () -> Put
forall (m :: * -> *) a. Monad m => a -> m a
return ()
putLooping GifLooping
LoopingForever = GifLooping -> Put
putLooping (GifLooping -> Put) -> GifLooping -> Put
forall a b. (a -> b) -> a -> b
$ Word16 -> GifLooping
LoopingRepeat Word16
0
putLooping (LoopingRepeat Word16
count) = do
    Pixel8 -> Put
putWord8 Pixel8
extensionIntroducer
    Pixel8 -> Put
putWord8 Pixel8
applicationLabel
    Pixel8 -> Put
putWord8 Pixel8
11 -- the size

    ByteString -> Put
putByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BC.pack [Char]
"NETSCAPE2.0"
    Pixel8 -> Put
putWord8 Pixel8
3 -- size of sub block

    Pixel8 -> Put
putWord8 Pixel8
1
    Word16 -> Put
putWord16le Word16
count
    Pixel8 -> Put
putWord8 Pixel8
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) = (Maybe GraphicControlExtension
forall a. Maybe a
Nothing, GifImage
img) (Maybe GraphicControlExtension, GifImage)
-> [(Maybe GraphicControlExtension, GifImage)]
-> [(Maybe GraphicControlExtension, GifImage)]
forall a. a -> [a] -> [a]
: [Block] -> [(Maybe GraphicControlExtension, GifImage)]
associateDescr [Block]
xs
associateDescr (BlockGraphicControl GraphicControlExtension
ctrl : BlockImage GifImage
img : [Block]
xs) =
    (GraphicControlExtension -> Maybe GraphicControlExtension
forall a. a -> Maybe a
Just GraphicControlExtension
ctrl, GifImage
img) (Maybe GraphicControlExtension, GifImage)
-> [(Maybe GraphicControlExtension, GifImage)]
-> [(Maybe GraphicControlExtension, GifImage)]
forall a. a -> [a] -> [a]
: [Block] -> [(Maybe GraphicControlExtension, GifImage)]
associateDescr [Block]
xs

instance Binary GifFile where
    put :: GifFile -> Put
put GifFile
v = do
        GifHeader -> Put
forall t. Binary t => t -> Put
put (GifHeader -> Put) -> GifHeader -> 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) = t -> Put
forall t. Binary t => t -> Put
put t
i
            putter (Just t
a, t
i) = t -> Put
forall t. Binary t => t -> Put
put t
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> t -> Put
forall t. Binary t => t -> Put
put t
i
        GifLooping -> Put
putLooping (GifLooping -> Put) -> GifLooping -> Put
forall a b. (a -> b) -> a -> b
$ GifFile -> GifLooping
gifLoopingBehaviour GifFile
v
        ((Maybe GraphicControlExtension, GifImage) -> Put)
-> [(Maybe GraphicControlExtension, GifImage)] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe GraphicControlExtension, GifImage) -> Put
forall t t. (Binary t, Binary t) => (Maybe t, t) -> Put
putter ([(Maybe GraphicControlExtension, GifImage)] -> Put)
-> [(Maybe GraphicControlExtension, GifImage)] -> Put
forall a b. (a -> b) -> a -> b
$ GifFile -> [(Maybe GraphicControlExtension, GifImage)]
gifImages GifFile
v
        Pixel8 -> Put
forall t. Binary t => t -> Put
put Pixel8
gifTrailer

    get :: Get GifFile
get = do
        GifHeader
hdr <- Get GifHeader
forall t. Binary t => Get t
get
        [Block]
blocks <- Get [Block]
parseGifBlocks
        GifFile -> Get GifFile
forall (m :: * -> *) a. Monad m => a -> m a
return GifFile :: GifHeader
-> [(Maybe GraphicControlExtension, GifImage)]
-> GifLooping
-> GifFile
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 Pixel8 -> Palette
substituteColors Palette
palette = (Pixel8 -> PixelRGB8) -> Image Pixel8 -> Palette
forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap Pixel8 -> PixelRGB8
swaper
  where swaper :: Pixel8 -> PixelRGB8
swaper Pixel8
n = Palette -> Int -> Int -> PixelRGB8
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Palette
palette (Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
n) Int
0

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


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

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

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

paletteOf :: (ColorConvertible PixelRGB8 px)
          => Image px -> GifImage -> Image px
paletteOf :: 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  } = Palette -> Image px
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 } = ((Maybe GraphicControlExtension, GifImage) -> Int)
-> [(Maybe GraphicControlExtension, GifImage)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe GraphicControlExtension, GifImage) -> Int
forall p b. Num p => (Maybe GraphicControlExtension, b) -> p
extractDelay [(Maybe GraphicControlExtension, GifImage)]
imgs
    where extractDelay :: (Maybe GraphicControlExtension, b) -> p
extractDelay (Maybe GraphicControlExtension
ext, b
_) =
            case Maybe GraphicControlExtension
ext of
                Maybe GraphicControlExtension
Nothing -> p
0
                Just GraphicControlExtension
e -> Word16 -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> p) -> Word16 -> p
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 = Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel8 -> Int) -> Pixel8 -> Int
forall a b. (a -> b) -> a -> b
$ GraphicControlExtension -> Pixel8
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 =
              (Int -> Int -> PixelRGB8) -> Int -> Int -> Palette
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage (\Int
_ Int
_ -> PixelRGB8
backgroundColor) Int
globalWidth Int
globalHeight
          thisPalette :: Palette
thisPalette = Palette -> GifImage -> Palette
forall px.
ColorConvertible PixelRGB8 px =>
Image px -> GifImage -> Image px
paletteOf Palette
globalPalette GifImage
firstImage
          baseImage :: Image Pixel8
baseImage = GifImage -> Image Pixel8
decodeImage GifImage
firstImage
          initState :: (Palette, Maybe GraphicControlExtension, Palette)
initState =
            (Palette
thisPalette, Maybe GraphicControlExtension
firstControl, Palette -> Image Pixel8 -> Palette
substituteColors Palette
thisPalette Image Pixel8
baseImage)
          scanner :: (Palette, Maybe GraphicControlExtension, Palette)
-> (Maybe GraphicControlExtension, GifImage)
-> (Palette, Maybe GraphicControlExtension, Palette)
scanner = (Int, Int)
-> Palette
-> Palette
-> (Palette, Maybe GraphicControlExtension, Palette)
-> (Maybe GraphicControlExtension, GifImage)
-> (Palette, Maybe GraphicControlExtension, Palette)
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' :: forall px. Int -> Vector (PixelBaseComponent px) -> Palette' px
Palette'
            { _paletteSize :: Int
_paletteSize = Palette -> Int
forall a. Image a -> Int
imageWidth Palette
thisPalette
            , _paletteData :: Vector (PixelBaseComponent PixelRGB8)
_paletteData = Palette -> Vector (PixelBaseComponent PixelRGB8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Palette
thisPalette
            }
      in
      Image Pixel8 -> Palette' PixelRGB8 -> PalettedImage
PalettedRGB8 Image Pixel8
baseImage Palette' PixelRGB8
palette' PalettedImage -> [PalettedImage] -> [PalettedImage]
forall a. a -> [a] -> [a]
:
        [DynamicImage -> PalettedImage
TrueColorImage (DynamicImage -> PalettedImage) -> DynamicImage -> PalettedImage
forall a b. (a -> b) -> a -> b
$ Palette -> DynamicImage
ImageRGB8 Palette
img | (Palette
_, Maybe GraphicControlExtension
_, Palette
img) <- [(Palette, Maybe GraphicControlExtension, Palette)]
-> [(Palette, Maybe GraphicControlExtension, Palette)]
forall a. [a] -> [a]
tail ([(Palette, Maybe GraphicControlExtension, Palette)]
 -> [(Palette, Maybe GraphicControlExtension, Palette)])
-> [(Palette, Maybe GraphicControlExtension, Palette)]
-> [(Palette, Maybe GraphicControlExtension, Palette)]
forall a b. (a -> b) -> a -> b
$ ((Palette, Maybe GraphicControlExtension, Palette)
 -> (Maybe GraphicControlExtension, GifImage)
 -> (Palette, Maybe GraphicControlExtension, Palette))
-> (Palette, Maybe GraphicControlExtension, Palette)
-> [(Maybe GraphicControlExtension, GifImage)]
-> [(Palette, Maybe GraphicControlExtension, Palette)]
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 =
            (Int -> Int -> PixelRGBA8) -> Int -> Int -> Image PixelRGBA8
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 = Image PixelRGBA8 -> GifImage -> Image PixelRGBA8
forall px.
ColorConvertible PixelRGB8 px =>
Image px -> GifImage -> Image px
paletteOf (Palette -> Image PixelRGBA8
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 Pixel8 -> Image PixelRGBA8
substituteColorsWithTransparency Int
transparentCode Image PixelRGBA8
thisPalette (Image Pixel8 -> Image PixelRGBA8)
-> Image Pixel8 -> Image PixelRGBA8
forall a b. (a -> b) -> a -> b
$
                GifImage -> Image Pixel8
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 =
            (Int, Int)
-> Image PixelRGBA8
-> Image PixelRGBA8
-> (Image PixelRGBA8, Maybe GraphicControlExtension,
    Image PixelRGBA8)
-> (Maybe GraphicControlExtension, GifImage)
-> (Image PixelRGBA8, Maybe GraphicControlExtension,
    Image PixelRGBA8)
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 (DynamicImage -> PalettedImage) -> DynamicImage -> PalettedImage
forall a b. (a -> b) -> a -> b
$ Image PixelRGBA8 -> DynamicImage
ImageRGBA8 Image PixelRGBA8
img | (Image PixelRGBA8
_, Maybe GraphicControlExtension
_, Image PixelRGBA8
img) <- ((Image PixelRGBA8, Maybe GraphicControlExtension,
  Image PixelRGBA8)
 -> (Maybe GraphicControlExtension, GifImage)
 -> (Image PixelRGBA8, Maybe GraphicControlExtension,
     Image PixelRGBA8))
-> (Image PixelRGBA8, Maybe GraphicControlExtension,
    Image PixelRGBA8)
-> [(Maybe GraphicControlExtension, GifImage)]
-> [(Image PixelRGBA8, Maybe GraphicControlExtension,
     Image PixelRGBA8)]
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 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ LogicalScreenDescriptor -> Word16
screenWidth LogicalScreenDescriptor
wholeDescriptor
      globalHeight :: Int
globalHeight = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ LogicalScreenDescriptor -> Word16
screenHeight LogicalScreenDescriptor
wholeDescriptor
      globalPalette :: Palette
globalPalette = Palette -> (Palette -> Palette) -> Maybe Palette -> Palette
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Palette
greyPalette Palette -> Palette
forall a. a -> a
id Maybe Palette
palette

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

      backgroundColor :: PixelRGB8
backgroundColor
        | LogicalScreenDescriptor -> Bool
hasGlobalMap LogicalScreenDescriptor
wholeDescriptor =
            Palette -> Int -> Int -> PixelRGB8
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Palette
globalPalette (Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel8 -> Int) -> Pixel8 -> Int
forall a b. (a -> b) -> a -> b
$ LogicalScreenDescriptor -> Pixel8
backgroundIndex LogicalScreenDescriptor
wholeDescriptor) Int
0
        | Bool
otherwise = Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
0 Pixel8
0 Pixel8
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 :: (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 = Image px -> GifImage -> Image px
forall px.
ColorConvertible PixelRGB8 px =>
Image px -> GifImage -> Image px
paletteOf Image px
globalPalette GifImage
img2

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

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

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

    decoded :: Image Pixel8
    decoded :: Image Pixel8
decoded = GifImage -> Image Pixel8
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 Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel8 -> Int) -> Pixel8 -> Int
forall a b. (a -> b) -> a -> b
$ GraphicControlExtension -> Pixel8
gceTransparentColorIndex GraphicControlExtension
ext
            else Int
300

    oldImage :: Image px
oldImage = case GraphicControlExtension -> GifDisposalMethod
gceDisposalMethod (GraphicControlExtension -> GifDisposalMethod)
-> Maybe GraphicControlExtension -> Maybe GifDisposalMethod
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 Pixel8
_) -> 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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
transparent = px
val where
          code :: Int
code = Pixel8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixel8 -> Int) -> Pixel8 -> Int
forall a b. (a -> b) -> a -> b
$ Image Pixel8 -> Int -> Int -> Pixel8
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image Pixel8
decoded (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
left) (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
top)
          val :: px
val = Image px -> Int -> Int -> px
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt Image px
thisPalette (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
code) Int
0
    pixeler Int
x Int
y = Image px -> Int -> Int -> px
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 [Char] (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
      [] -> [Char] -> Either [Char] (PalettedImage, Metadatas)
forall a b. a -> Either a b
Left [Char]
"No image after decoding"
      (PalettedImage
i:[PalettedImage]
_) -> (PalettedImage, Metadatas)
-> Either [Char] (PalettedImage, Metadatas)
forall a b. b -> Either a b
Right (PalettedImage
i, SourceFormat -> Word16 -> Word16 -> Metadatas
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 (GifHeader -> LogicalScreenDescriptor)
-> GifHeader -> LogicalScreenDescriptor
forall a b. (a -> b) -> a -> b
$ GifFile -> GifHeader
gifHeader GifFile
img
decodeFirstGifImage GifFile
_ = [Char] -> Either [Char] (PalettedImage, Metadatas)
forall a b. a -> Either a b
Left [Char]
"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 [Char] DynamicImage
decodeGif ByteString
img = ByteString -> Either [Char] GifFile
forall a. Binary a => ByteString -> Either [Char] a
decode ByteString
img Either [Char] GifFile
-> (GifFile -> Either [Char] DynamicImage)
-> Either [Char] DynamicImage
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (((PalettedImage, Metadatas) -> DynamicImage)
-> Either [Char] (PalettedImage, Metadatas)
-> Either [Char] DynamicImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PalettedImage -> DynamicImage
palettedToTrueColor (PalettedImage -> DynamicImage)
-> ((PalettedImage, Metadatas) -> PalettedImage)
-> (PalettedImage, Metadatas)
-> DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PalettedImage, Metadatas) -> PalettedImage
forall a b. (a, b) -> a
fst) (Either [Char] (PalettedImage, Metadatas)
 -> Either [Char] DynamicImage)
-> (GifFile -> Either [Char] (PalettedImage, Metadatas))
-> GifFile
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GifFile -> Either [Char] (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 [Char] (DynamicImage, Metadatas)
decodeGifWithMetadata ByteString
img = (PalettedImage -> DynamicImage)
-> (PalettedImage, Metadatas) -> (DynamicImage, Metadatas)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first PalettedImage -> DynamicImage
palettedToTrueColor ((PalettedImage, Metadatas) -> (DynamicImage, Metadatas))
-> Either [Char] (PalettedImage, Metadatas)
-> Either [Char] (DynamicImage, Metadatas)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either [Char] (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 [Char] (PalettedImage, Metadatas)
decodeGifWithPaletteAndMetadata ByteString
img = ByteString -> Either [Char] GifFile
forall a. Binary a => ByteString -> Either [Char] a
decode ByteString
img Either [Char] GifFile
-> (GifFile -> Either [Char] (PalettedImage, Metadatas))
-> Either [Char] (PalettedImage, Metadatas)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GifFile -> Either [Char] (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 [Char] [DynamicImage]
decodeGifImages ByteString
img = (PalettedImage -> DynamicImage)
-> [PalettedImage] -> [DynamicImage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PalettedImage -> DynamicImage
palettedToTrueColor ([PalettedImage] -> [DynamicImage])
-> (GifFile -> [PalettedImage]) -> GifFile -> [DynamicImage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GifFile -> [PalettedImage]
decodeAllGifImages (GifFile -> [DynamicImage])
-> Either [Char] GifFile -> Either [Char] [DynamicImage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either [Char] GifFile
forall a. Binary a => ByteString -> Either [Char] a
decode ByteString
img

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

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

-- | Default palette to produce greyscale images.

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

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

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

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

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

checkBackground :: GifEncode -> Either String ()
checkBackground :: GifEncode -> Either [Char] ()
checkBackground GifEncode { geBackground :: GifEncode -> Maybe Int
geBackground = Maybe Int
Nothing } = () -> Either [Char] ()
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 Maybe Palette
forall a. Maybe a
Nothing Int
background
  then () -> Either [Char] ()
forall a b. b -> Either a b
Right ()
  else [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"GIF background index absent from global palette"

checkTransparencies :: GifEncode -> Either String ()
checkTransparencies :: GifEncode -> Either [Char] ()
checkTransparencies GifEncode { gePalette :: GifEncode -> Maybe Palette
gePalette = Maybe Palette
global, geFrames :: GifEncode -> [GifFrame]
geFrames = [GifFrame]
frames } =
  if [(GifFrame, Int)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(GifFrame, Int)]
missingTransparency
  then () -> Either [Char] ()
forall a b. b -> Either a b
Right ()
  else [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char] -> Either [Char] ()) -> [Char] -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ [Char]
"GIF transparent index absent from palettes for frames: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show (((GifFrame, Int) -> Int) -> [(GifFrame, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (GifFrame, Int) -> Int
forall a b. (a, b) -> b
snd [(GifFrame, Int)]
missingTransparency)
  where missingTransparency :: [(GifFrame, Int)]
missingTransparency = ((GifFrame, Int) -> Bool) -> [(GifFrame, Int)] -> [(GifFrame, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((GifFrame, Int) -> Bool) -> (GifFrame, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GifFrame -> Bool
transparencyOK (GifFrame -> Bool)
-> ((GifFrame, Int) -> GifFrame) -> (GifFrame, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GifFrame, Int) -> GifFrame
forall a b. (a, b) -> a
fst) ([(GifFrame, Int)] -> [(GifFrame, Int)])
-> [(GifFrame, Int)] -> [(GifFrame, Int)]
forall a b. (a -> b) -> a -> b
$ [GifFrame] -> [Int] -> [(GifFrame, Int)]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Palette -> Int
forall a. Image a -> Int
imageWidth Palette
local
checkIndexInPalette (Just Palette
global) Maybe Palette
_            Int
ix = Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Palette -> Int
forall a. Image a -> Int
imageWidth Palette
global

checkGifImageSizes :: [(a, b, Image px)] -> Bool
checkGifImageSizes :: [(a, b, Image px)] -> Bool
checkGifImageSizes [] = Bool
False
checkGifImageSizes ((a
_, b
_, Image px
img) : [(a, b, Image px)]
rest) = ((a, b, Image px) -> Bool) -> [(a, b, Image px)] -> Bool
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 = Image px -> Int
forall a. Image a -> Int
imageWidth Image px
img
         height :: Int
height = Image px -> Int
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
width Bool -> Bool -> Bool
&& Int
h Int -> Int -> Bool
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 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
itemCount = Int
k
             | Bool
otherwise = Int -> Int
go (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
k Int -> Int -> Int
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 [Char] ByteString
encodeComplexGifImage GifEncode
spec = do
  Bool -> Either [Char] () -> Either [Char] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([GifFrame] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([GifFrame] -> Bool) -> [GifFrame] -> Bool
forall a b. (a -> b) -> a -> b
$ GifEncode -> [GifFrame]
geFrames GifEncode
spec) (Either [Char] () -> Either [Char] ())
-> Either [Char] () -> Either [Char] ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"No GIF frames"
  GifEncode -> Either [Char] ()
checkImageSizes GifEncode
spec
  GifEncode -> Either [Char] ()
checkImagesInBounds GifEncode
spec
  GifEncode -> Either [Char] ()
checkPaletteValidity GifEncode
spec
  GifEncode -> Either [Char] ()
checkBackground GifEncode
spec
  GifEncode -> Either [Char] ()
checkTransparencies GifEncode
spec
  GifEncode -> Either [Char] ()
checkIndexAbsentFromPalette GifEncode
spec

  ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right (ByteString -> Either [Char] ByteString)
-> ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ GifFile -> ByteString
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
-> [(Maybe GraphicControlExtension, GifImage)]
-> GifLooping
-> GifFile
GifFile
      { gifHeader :: GifHeader
gifHeader = GifHeader :: GifVersion -> LogicalScreenDescriptor -> Maybe Palette -> 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 :: Word16
-> Word16
-> Pixel8
-> Bool
-> Pixel8
-> Bool
-> Pixel8
-> LogicalScreenDescriptor
LogicalScreenDescriptor
      { screenWidth :: Word16
screenWidth        = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width
      , screenHeight :: Word16
screenHeight       = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height
      , backgroundIndex :: Pixel8
backgroundIndex    = Pixel8 -> (Int -> Pixel8) -> Maybe Int -> Pixel8
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pixel8
0 Int -> Pixel8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Maybe Int
background
      , hasGlobalMap :: Bool
hasGlobalMap       = Bool -> (Palette -> Bool) -> Maybe Palette -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Palette -> Bool
forall a b. a -> b -> a
const Bool
True) Maybe Palette
globalPalette
      , colorResolution :: Pixel8
colorResolution    = Pixel8
8
      , isColorTableSorted :: Bool
isColorTableSorted = Bool
False
      -- Imply a 8 bit global palette size if there's no explicit global palette.

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

    toSerialize :: [(Maybe GraphicControlExtension, GifImage)]
toSerialize = [(Int
-> Maybe Int -> GifDisposalMethod -> Maybe GraphicControlExtension
forall a a.
(Integral a, Integral a) =>
a -> Maybe a -> GifDisposalMethod -> Maybe GraphicControlExtension
controlExtension Int
delay Maybe Int
transparent GifDisposalMethod
disposal, GifImage :: ImageDescriptor
-> Maybe Palette -> Pixel8 -> ByteString -> GifImage
GifImage
                     { imgDescriptor :: ImageDescriptor
imgDescriptor = Int -> Int -> Maybe Palette -> Image Pixel8 -> ImageDescriptor
forall a a a.
(Integral a, Integral a) =>
a -> a -> Maybe Palette -> Image a -> ImageDescriptor
imageDescriptor Int
left Int
top Maybe Palette
localPalette Image Pixel8
img
                     , imgLocalPalette :: Maybe Palette
imgLocalPalette = Maybe Palette
localPalette
                     , imgLzwRootSize :: Pixel8
imgLzwRootSize = Int -> Pixel8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lzwKeySize
                     , imgData :: ByteString
imgData = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (Vector Pixel8 -> [ByteString]) -> Vector Pixel8 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks (ByteString -> [ByteString])
-> (Vector Pixel8 -> ByteString) -> Vector Pixel8 -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Vector Pixel8 -> ByteString
lzwEncode Int
lzwKeySize (Vector Pixel8 -> ByteString) -> Vector Pixel8 -> ByteString
forall a b. (a -> b) -> a -> b
$ Image Pixel8 -> Vector (PixelBaseComponent Pixel8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image Pixel8
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 Pixel8
gfPixels      = Image Pixel8
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)     -> [Char] -> Palette
forall a. HasCallStack => [Char] -> a
error [Char]
"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 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
2 (Int -> Int) -> Int -> Int
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 = Maybe GraphicControlExtension
forall a. Maybe a
Nothing
    controlExtension a
delay Maybe a
transparent GifDisposalMethod
disposal    = GraphicControlExtension -> Maybe GraphicControlExtension
forall a. a -> Maybe a
Just GraphicControlExtension :: GifDisposalMethod
-> Bool -> Bool -> Word16 -> Pixel8 -> GraphicControlExtension
GraphicControlExtension
      { gceDisposalMethod :: GifDisposalMethod
gceDisposalMethod        = GifDisposalMethod
disposal
      , gceUserInputFlag :: Bool
gceUserInputFlag         = Bool
False
      , gceTransparentFlag :: Bool
gceTransparentFlag       = Bool -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True) Maybe a
transparent
      , gceDelay :: Word16
gceDelay                 = a -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
delay
      , gceTransparentColorIndex :: Pixel8
gceTransparentColorIndex = Pixel8 -> (a -> Pixel8) -> Maybe a -> Pixel8
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pixel8
0 a -> Pixel8
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 :: Word16
-> Word16
-> Word16
-> Word16
-> Bool
-> Bool
-> Bool
-> Pixel8
-> ImageDescriptor
ImageDescriptor
      { gDescPixelsFromLeft :: Word16
gDescPixelsFromLeft         = a -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
left
      , gDescPixelsFromTop :: Word16
gDescPixelsFromTop          = a -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
top
      , gDescImageWidth :: Word16
gDescImageWidth             = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Image a -> Int
forall a. Image a -> Int
imageWidth Image a
img
      , gDescImageHeight :: Word16
gDescImageHeight            = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Image a -> Int
forall a. Image a -> Int
imageHeight Image a
img
      , gDescHasLocalMap :: Bool
gDescHasLocalMap            = Bool -> (Palette -> Bool) -> Maybe Palette -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Palette -> Bool
forall a b. a -> b -> a
const Bool
True) Maybe Palette
localPalette
      , gDescIsInterlaced :: Bool
gDescIsInterlaced           = Bool
False
      , gDescIsImgDescriptorSorted :: Bool
gDescIsImgDescriptorSorted  = Bool
False
      , gDescLocalColorTableSize :: Pixel8
gDescLocalColorTableSize    = Pixel8 -> (Palette -> Pixel8) -> Maybe Palette -> Pixel8
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pixel8
0 (Int -> Pixel8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Pixel8) -> (Palette -> Int) -> Palette -> Pixel8
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 Pixel8)] -> Either [Char] ByteString
encodeGifImages GifLooping
_ [] = [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left [Char]
"No image in list"
encodeGifImages GifLooping
_ [(Palette, Int, Image Pixel8)]
imageList
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Palette, Int, Image Pixel8)] -> Bool
forall a b px. [(a, b, Image px)] -> Bool
checkGifImageSizes [(Palette, Int, Image Pixel8)]
imageList = [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left [Char]
"Gif images have different size"
encodeGifImages GifLooping
looping imageList :: [(Palette, Int, Image Pixel8)]
imageList@((Palette
firstPalette, Int
_,Image Pixel8
firstImage):[(Palette, Int, Image Pixel8)]
_) =
  GifEncode -> Either [Char] ByteString
encodeComplexGifImage (GifEncode -> Either [Char] ByteString)
-> GifEncode -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> Maybe Palette
-> Maybe Int
-> GifLooping
-> [GifFrame]
-> GifEncode
GifEncode (Image Pixel8 -> Int
forall a. Image a -> Int
imageWidth Image Pixel8
firstImage) (Image Pixel8 -> Int
forall a. Image a -> Int
imageHeight Image Pixel8
firstImage) (Palette -> Maybe Palette
forall a. a -> Maybe a
Just Palette
firstPalette) Maybe Int
forall a. Maybe a
Nothing GifLooping
looping [GifFrame]
frames
  where
    frames :: [GifFrame]
frames = [ Int
-> Int
-> Maybe Palette
-> Maybe Int
-> Int
-> GifDisposalMethod
-> Image Pixel8
-> GifFrame
GifFrame Int
0 Int
0 Maybe Palette
localPalette Maybe Int
forall a. Maybe a
Nothing Int
delay GifDisposalMethod
DisposalAny Image Pixel8
image
             | (Palette
palette, Int
delay, Image Pixel8
image) <- [(Palette, Int, Image Pixel8)]
imageList
             , let localPalette :: Maybe Palette
localPalette = if Palette -> Bool
paletteEqual Palette
palette then Maybe Palette
forall a. Maybe a
Nothing else Palette -> Maybe Palette
forall a. a -> Maybe a
Just Palette
palette ]

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

-- | Encode a greyscale image to a bytestring.

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

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

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

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