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