    {-# LANGUAGE CPP #-}
    module Codec.Picture.Gif.Internal.LZW( decodeLzw, decodeLzwTiff ) where

    #if !MIN_VERSION_base(4,8,0)
    import Control.Applicative( (<$>) )
    #endif

    import Data.Word( Word8 )
    import Control.Monad( when, unless )

    import Data.Bits( (.&.) )

    import Control.Monad.ST( ST )
    import Control.Monad.Trans.Class( MonadTrans, lift )

    import Foreign.Storable ( Storable )

    import qualified Data.ByteString as B
    import qualified Data.Vector.Storable.Mutable as M

    import Codec.Picture.BitWriter

    {-# INLINE (.!!!.) #-}
    (.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a
    .!!!. :: forall a s. Storable a => STVector s a -> Int -> ST s a
    (.!!!.) = MVector s a -> Int -> ST s a
    MVector (PrimState (ST s)) a -> Int -> ST s a
    forall (m :: * -> *) a.
    (PrimMonad m, Storable a) =>
    MVector (PrimState m) a -> Int -> m a
    M.unsafeRead
            {-M.read-}

    {-# INLINE (..!!!..) #-}
    (..!!!..) :: (MonadTrans t, Storable a)
              => M.STVector s a -> Int -> t (ST s) a
    ..!!!.. :: forall (t :: (* -> *) -> * -> *) a s.
    (MonadTrans t, Storable a) =>
    STVector s a -> Int -> t (ST s) a
    (..!!!..) STVector s a
    v Int
    idx = ST s a -> t (ST s) a
    forall (m :: * -> *) a. Monad m => m a -> t m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (ST s a -> t (ST s) a) -> ST s a -> t (ST s) a
    forall a b. (a -> b) -> a -> b
    $ STVector s a
    v STVector s a -> Int -> ST s a
    forall a s. Storable a => STVector s a -> Int -> ST s a
    .!!!. Int
    idx

    {-# INLINE (.<-.) #-}
    (.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s ()
    .<-. :: forall a s. Storable a => STVector s a -> Int -> a -> ST s ()
    (.<-.) = MVector s a -> Int -> a -> ST s ()
    MVector (PrimState (ST s)) a -> Int -> a -> ST s ()
    forall (m :: * -> *) a.
    (PrimMonad m, Storable a) =>
    MVector (PrimState m) a -> Int -> a -> m ()
    M.unsafeWrite
             {-M.write-}

    {-# INLINE (..<-..) #-}
    (..<-..) :: (MonadTrans t, Storable a)
             => M.STVector s a -> Int -> a -> t (ST s) ()
    ..<-.. :: forall (t :: (* -> *) -> * -> *) a s.
    (MonadTrans t, Storable a) =>
    STVector s a -> Int -> a -> t (ST s) ()
    (..<-..) STVector s a
    v Int
    idx = ST s () -> t (ST s) ()
    forall (m :: * -> *) a. Monad m => m a -> t m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (ST s () -> t (ST s) ()) -> (a -> ST s ()) -> a -> t (ST s) ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (STVector s a
    v STVector s a -> Int -> a -> ST s ()
    forall a s. Storable a => STVector s a -> Int -> a -> ST s ()
    .<-. Int
    idx)

    duplicateData :: (MonadTrans t, Storable a)
                  => M.STVector s a -> M.STVector s a
                  -> Int -> Int -> Int -> t (ST s) ()
    duplicateData :: forall (t :: (* -> *) -> * -> *) a s.
    (MonadTrans t, Storable a) =>
    STVector s a -> STVector s a -> Int -> Int -> Int -> t (ST s) ()
    duplicateData STVector s a
    src STVector s a
    dest Int
    sourceIndex Int
    size Int
    destIndex = ST s () -> t (ST s) ()
    forall (m :: * -> *) a. Monad m => m a -> t m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (ST s () -> t (ST s) ()) -> ST s () -> t (ST s) ()
    forall a b. (a -> b) -> a -> b
    $ Int -> Int -> ST s ()
    aux Int
    sourceIndex Int
    destIndex
      where endIndex :: Int
    endIndex = Int
    sourceIndex Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    size
            aux :: Int -> Int -> ST s ()
    aux Int
    i Int
    _ | Int
    i Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    endIndex  = () -> ST s ()
    forall a. a -> ST s a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            aux Int
    i Int
    j = do
              STVector s a
    src STVector s a -> Int -> ST s a
    forall a s. Storable a => STVector s a -> Int -> ST s a
    .!!!. Int
    i ST s a -> (a -> ST s ()) -> ST s ()
    forall a b. ST s a -> (a -> ST s b) -> ST s b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (STVector s a
    dest STVector s a -> Int -> a -> ST s ()
    forall a s. Storable a => STVector s a -> Int -> a -> ST s ()
    .<-. Int
    j)
              Int -> Int -> ST s ()
    aux (Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) (Int
    j Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1)

    rangeSetter :: (Storable a, Num a)
                => Int -> M.STVector s a
                -> ST s (M.STVector s a)
    rangeSetter :: forall a s.
    (Storable a, Num a) =>
    Int -> STVector s a -> ST s (STVector s a)
    rangeSetter Int
    count STVector s a
    vec = Int -> ST s (STVector s a)
    aux Int
    0
      where aux :: Int -> ST s (STVector s a)
    aux Int
    n | Int
    n Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    count = STVector s a -> ST s (STVector s a)
    forall a. a -> ST s a
    forall (m :: * -> *) a. Monad m => a -> m a
    return STVector s a
    vec
            aux Int
    n = (STVector s a
    vec STVector s a -> Int -> a -> ST s ()
    forall a s. Storable a => STVector s a -> Int -> a -> ST s ()
    .<-. Int
    n) (Int -> a
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    n) ST s () -> ST s (STVector s a) -> ST s (STVector s a)
    forall a b. ST s a -> ST s b -> ST s b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Int -> ST s (STVector s a)
    aux (Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1)

    decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8
              -> BoolReader s ()
    decodeLzw :: forall s.
    ByteString -> Int -> Int -> STVector s Word8 -> BoolReader s ()
    decodeLzw ByteString
    str Int
    maxBitKey Int
    initialKey STVector s Word8
    outVec = do
        ByteString -> BoolReader s ()
    forall s. ByteString -> BoolReader s ()
    setDecodedString ByteString
    str
        TiffVariant
    -> Int -> Int -> Int -> STVector s Word8 -> BoolReader s ()
    forall s.
    TiffVariant
    -> Int -> Int -> Int -> STVector s Word8 -> BoolReader s ()
    lzw TiffVariant
    GifVariant Int
    maxBitKey Int
    initialKey Int
    0 STVector s Word8
    outVec

    isOldTiffLZW :: B.ByteString -> Bool
    isOldTiffLZW :: ByteString -> Bool
    isOldTiffLZW ByteString
    str = Word8
    firstByte Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    0 Bool -> Bool -> Bool
    && Word8
    secondByte Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    1
        where firstByte :: Word8
    firstByte = ByteString
    str HasCallStack => ByteString -> Int -> Word8
    ByteString -> Int -> Word8
    `B.index` Int
    0
              secondByte :: Word8
    secondByte = (ByteString
    str HasCallStack => ByteString -> Int -> Word8
    ByteString -> Int -> Word8
    `B.index` Int
    1) Word8 -> Word8 -> Word8
    forall a. Bits a => a -> a -> a
    .&. Word8
    1

    decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int
                  -> BoolReader s()
    decodeLzwTiff :: forall s. ByteString -> STVector s Word8 -> Int -> BoolReader s ()
    decodeLzwTiff ByteString
    str STVector s Word8
    outVec Int
    initialWriteIdx = do
        if ByteString -> Bool
    isOldTiffLZW ByteString
    str then
          ByteString -> BoolReader s ()
    forall s. ByteString -> BoolReader s ()
    setDecodedString ByteString
    str
        else
          ByteString -> BoolReader s ()
    forall s. ByteString -> BoolReader s ()
    setDecodedStringMSB ByteString
    str
        let variant :: TiffVariant
    variant | ByteString -> Bool
    isOldTiffLZW ByteString
    str = TiffVariant
    OldTiffVariant
                    | Bool
    otherwise = TiffVariant
    TiffVariant
        TiffVariant
    -> Int -> Int -> Int -> STVector s Word8 -> BoolReader s ()
    forall s.
    TiffVariant
    -> Int -> Int -> Int -> STVector s Word8 -> BoolReader s ()
    lzw TiffVariant
    variant Int
    12 Int
    9 Int
    initialWriteIdx STVector s Word8
    outVec

    data TiffVariant =
          GifVariant
        | TiffVariant
        | OldTiffVariant
        deriving TiffVariant -> TiffVariant -> Bool
    (TiffVariant -> TiffVariant -> Bool)
    -> (TiffVariant -> TiffVariant -> Bool) -> Eq TiffVariant
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: TiffVariant -> TiffVariant -> Bool
    == :: TiffVariant -> TiffVariant -> Bool
    $c/= :: TiffVariant -> TiffVariant -> Bool
    /= :: TiffVariant -> TiffVariant -> Bool
    Eq

    -- | Gif image constraint from spec-gif89a, code size max : 12 bits.

    lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8
        -> BoolReader s ()
    lzw :: forall s.
    TiffVariant
    -> Int -> Int -> Int -> STVector s Word8 -> BoolReader s ()
    lzw TiffVariant
    variant Int
    nMaxBitKeySize Int
    initialKeySize Int
    initialWriteIdx STVector s Word8
    outVec = do
        -- Allocate buffer of maximum size.

        lzwData <- ST s (STVector s Word8)
    -> StateT BoolState (ST s) (STVector s Word8)
    forall (m :: * -> *) a. Monad m => m a -> StateT BoolState m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (Int -> Word8 -> ST s (MVector (PrimState (ST s)) Word8)
    forall (m :: * -> *) a.
    (PrimMonad m, Storable a) =>
    Int -> a -> m (MVector (PrimState m) a)
    M.replicate Int
    maxDataSize Word8
    0) StateT BoolState (ST s) (STVector s Word8)
    -> (STVector s Word8 -> StateT BoolState (ST s) (STVector s Word8))
    -> StateT BoolState (ST s) (STVector s Word8)
    forall a b.
    StateT BoolState (ST s) a
    -> (a -> StateT BoolState (ST s) b) -> StateT BoolState (ST s) b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= STVector s Word8 -> StateT BoolState (ST s) (STVector s Word8)
    forall {t :: (* -> *) -> * -> *} {a} {s}.
    (MonadTrans t, Storable a, Num a) =>
    STVector s a -> t (ST s) (STVector s a)
    resetArray
        lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray
        lzwSizeTable <- lift $ M.replicate tableEntryCount 0
        lift $ lzwSizeTable `M.set` 1

        let firstVal Int
    code = do
                dataOffset <- STVector s Int
    lzwOffsetTable STVector s Int -> Int -> t (ST s) Int
    forall (t :: (* -> *) -> * -> *) a s.
    (MonadTrans t, Storable a) =>
    STVector s a -> Int -> t (ST s) a
    ..!!!.. Int
    code
                lzwData ..!!!.. dataOffset

            writeString Int
    at Int
    code = do
                dataOffset <- STVector s Int
    lzwOffsetTable STVector s Int -> Int -> t (ST s) Int
    forall (t :: (* -> *) -> * -> *) a s.
    (MonadTrans t, Storable a) =>
    STVector s a -> Int -> t (ST s) a
    ..!!!.. Int
    code
                dataSize   <- lzwSizeTable   ..!!!.. code

                when (at + dataSize <= maxWrite) $
                     duplicateData lzwData outVec dataOffset dataSize at

                return dataSize

            addString Int
    pos Int
    at Int
    code Word8
    val = do
                dataOffset <- STVector s Int
    lzwOffsetTable STVector s Int -> Int -> t (ST s) Int
    forall (t :: (* -> *) -> * -> *) a s.
    (MonadTrans t, Storable a) =>
    STVector s a -> Int -> t (ST s) a
    ..!!!.. Int
    code
                dataSize   <- lzwSizeTable   ..!!!.. code

                when (pos < tableEntryCount) $ do
                  (lzwOffsetTable ..<-.. pos) at
                  (lzwSizeTable ..<-.. pos) $ dataSize + 1

                when (at + dataSize + 1 <= maxDataSize) $ do
                  duplicateData lzwData lzwData dataOffset dataSize at
                  (lzwData ..<-.. (at + dataSize)) val

                return $ dataSize + 1

            maxWrite = STVector s Word8 -> Int
    forall a s. Storable a => MVector s a -> Int
    M.length STVector s Word8
    outVec
            loop Int
    outWriteIdx Int
    writeIdx Int
    dicWriteIdx Int
    codeSize Int
    oldCode Int
    code
              | Int
    outWriteIdx Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    maxWrite = () -> StateT BoolState (ST s) ()
    forall a. a -> StateT BoolState (ST s) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
              | Int
    code Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    endOfInfo = () -> StateT BoolState (ST s) ()
    forall a. a -> StateT BoolState (ST s) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
              | Int
    code Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    clearCode = do
                  toOutput <- Int -> StateT BoolState (ST s) Int
    forall {b} {s}. Num b => Int -> StateT BoolState (ST s) b
    getNextCode Int
    startCodeSize
                  unless (toOutput == endOfInfo) $ do
                    dataSize <- writeString outWriteIdx toOutput
                    getNextCode startCodeSize >>=
                      loop (outWriteIdx + dataSize)
                           firstFreeIndex firstFreeIndex startCodeSize toOutput

              | Bool
    otherwise =  do
                  (written, dicAdd) <-
                       if Int
    code Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    writeIdx then do
                         c <- Int -> StateT BoolState (ST s) Word8
    forall {t :: (* -> *) -> * -> *}.
    (Monad (t (ST s)), MonadTrans t) =>
    Int -> t (ST s) Word8
    firstVal Int
    oldCode
                         wroteSize <- writeString outWriteIdx oldCode
                         (outVec ..<-.. (outWriteIdx + wroteSize)) c
                         addedSize <- addString writeIdx dicWriteIdx oldCode c
                         return (wroteSize + 1, addedSize)
                       else do
                         wroteSize <- Int -> Int -> StateT BoolState (ST s) Int
    forall {t :: (* -> *) -> * -> *}.
    (Monad (t (ST s)), MonadTrans t) =>
    Int -> Int -> t (ST s) Int
    writeString Int
    outWriteIdx Int
    code
                         c <- firstVal code
                         addedSize <- addString writeIdx dicWriteIdx oldCode c
                         return (wroteSize, addedSize)

                  let new_code_size = Int -> Int -> Int
    forall {a}. Integral a => a -> Int -> a
    updateCodeSize Int
    codeSize (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ Int
    writeIdx Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
                  getNextCode new_code_size >>=
                    loop (outWriteIdx + written)
                         (writeIdx + 1)
                         (dicWriteIdx + dicAdd)
                         new_code_size
                         code

        getNextCode startCodeSize >>=
            loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0

      where tableEntryCount :: Int
    tableEntryCount =  Int
    2 Int -> Int -> Int
    forall a b. (Num a, Integral b) => a -> b -> a
    ^ Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    12 Int
    nMaxBitKeySize
            maxDataSize :: Int
    maxDataSize = Int
    tableEntryCount Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    2 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * (Int
    1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    tableEntryCount) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1

            isNewTiff :: Bool
    isNewTiff = TiffVariant
    variant TiffVariant -> TiffVariant -> Bool
    forall a. Eq a => a -> a -> Bool
    == TiffVariant
    TiffVariant
            (Int
    switchOffset,  Bool
    isTiffVariant) = case TiffVariant
    variant of
                TiffVariant
    GifVariant -> (Int
    0, Bool
    False)
                TiffVariant
    TiffVariant -> (Int
    1, Bool
    True)
                TiffVariant
    OldTiffVariant -> (Int
    0, Bool
    True)

            initialElementCount :: Int
    initialElementCount = Int
    2 Int -> Int -> Int
    forall a b. (Num a, Integral b) => a -> b -> a
    ^ Int
    initialKeySize :: Int
            clearCode :: Int
    clearCode | Bool
    isTiffVariant = Int
    256
                      | Bool
    otherwise = Int
    initialElementCount

            endOfInfo :: Int
    endOfInfo | Bool
    isTiffVariant = Int
    257
                      | Bool
    otherwise = Int
    clearCode Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1

            startCodeSize :: Int
    startCodeSize
                      | Bool
    isTiffVariant = Int
    initialKeySize
                      | Bool
    otherwise = Int
    initialKeySize Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1

            firstFreeIndex :: Int
    firstFreeIndex = Int
    endOfInfo Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1

            resetArray :: STVector s a -> t (ST s) (STVector s a)
    resetArray STVector s a
    a = ST s (STVector s a) -> t (ST s) (STVector s a)
    forall (m :: * -> *) a. Monad m => m a -> t m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (ST s (STVector s a) -> t (ST s) (STVector s a))
    -> ST s (STVector s a) -> t (ST s) (STVector s a)
    forall a b. (a -> b) -> a -> b
    $ Int -> STVector s a -> ST s (STVector s a)
    forall a s.
    (Storable a, Num a) =>
    Int -> STVector s a -> ST s (STVector s a)
    rangeSetter Int
    initialElementCount STVector s a
    a

            updateCodeSize :: a -> Int -> a
    updateCodeSize a
    codeSize Int
    writeIdx
                | Int
    writeIdx Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    2 Int -> a -> Int
    forall a b. (Num a, Integral b) => a -> b -> a
    ^ a
    codeSize Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    switchOffset = a -> a -> a
    forall a. Ord a => a -> a -> a
    min a
    12 (a -> a) -> a -> a
    forall a b. (a -> b) -> a -> b
    $ a
    codeSize a -> a -> a
    forall a. Num a => a -> a -> a
    + a
    1
                | Bool
    otherwise = a
    codeSize

            getNextCode :: Int -> StateT BoolState (ST s) b
    getNextCode Int
    s
                | Bool
    isNewTiff = Word32 -> b
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word32 -> b)
    -> StateT BoolState (ST s) Word32 -> StateT BoolState (ST s) b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Int -> StateT BoolState (ST s) Word32
    forall s. Int -> BoolReader s Word32
    getNextBitsMSBFirst Int
    s
                | Bool
    otherwise = Word32 -> b
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Word32 -> b)
    -> StateT BoolState (ST s) Word32 -> StateT BoolState (ST s) b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Int -> StateT BoolState (ST s) Word32
    forall s. Int -> BoolReader s Word32
    getNextBitsLSBFirst Int
    s