{-# 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
(.!!!.) = 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ STVector s a
v 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 ()
(.<-.) = 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. (STVector s a
v 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Int -> Int -> ST s ()
aux Int
sourceIndex Int
destIndex
where endIndex :: Int
endIndex = Int
sourceIndex forall a. Num a => a -> a -> a
+ Int
size
aux :: Int -> Int -> ST s ()
aux Int
i Int
_ | Int
i forall a. Eq a => a -> a -> Bool
== Int
endIndex = forall (m :: * -> *) a. Monad m => a -> m a
return ()
aux Int
i Int
j = do
STVector s a
src forall a s. Storable a => STVector s a -> Int -> ST s a
.!!!. Int
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (STVector s a
dest forall a s. Storable a => STVector s a -> Int -> a -> ST s ()
.<-. Int
j)
Int -> Int -> ST s ()
aux (Int
i forall a. Num a => a -> a -> a
+ Int
1) (Int
j 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 forall a. Eq a => a -> a -> Bool
== Int
count = forall (m :: * -> *) a. Monad m => a -> m a
return STVector s a
vec
aux Int
n = (STVector s a
vec forall a s. Storable a => STVector s a -> Int -> a -> ST s ()
.<-. Int
n) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ST s (STVector s a)
aux (Int
n 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
forall s. ByteString -> BoolReader s ()
setDecodedString ByteString
str
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 forall a. Eq a => a -> a -> Bool
== Word8
0 Bool -> Bool -> Bool
&& Word8
secondByte forall a. Eq a => a -> a -> Bool
== Word8
1
where firstByte :: Word8
firstByte = ByteString
str HasCallStack => ByteString -> Int -> Word8
`B.index` Int
0
secondByte :: Word8
secondByte = (ByteString
str HasCallStack => ByteString -> Int -> Word8
`B.index` Int
1) 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
forall s. ByteString -> BoolReader s ()
setDecodedString ByteString
str
else
forall s. ByteString -> BoolReader s ()
setDecodedStringMSB ByteString
str
let variant :: TiffVariant
variant | ByteString -> Bool
isOldTiffLZW ByteString
str = TiffVariant
OldTiffVariant
| Bool
otherwise = TiffVariant
TiffVariant
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TiffVariant -> TiffVariant -> Bool
$c/= :: TiffVariant -> TiffVariant -> Bool
== :: TiffVariant -> TiffVariant -> Bool
$c== :: 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
STVector s Word8
lzwData <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate Int
maxDataSize Word8
0) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {t :: (* -> *) -> * -> *} {a} {s}.
(MonadTrans t, Storable a, Num a) =>
STVector s a -> t (ST s) (STVector s a)
resetArray
STVector s Int
lzwOffsetTable <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate Int
tableEntryCount Int
0) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {t :: (* -> *) -> * -> *} {a} {s}.
(MonadTrans t, Storable a, Num a) =>
STVector s a -> t (ST s) (STVector s a)
resetArray
STVector s Int
lzwSizeTable <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate Int
tableEntryCount Int
0
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ STVector s Int
lzwSizeTable forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> a -> m ()
`M.set` Int
1
let firstVal :: Int -> t (ST s) Word8
firstVal Int
code = do
Int
dataOffset <- STVector s Int
lzwOffsetTable forall (t :: (* -> *) -> * -> *) a s.
(MonadTrans t, Storable a) =>
STVector s a -> Int -> t (ST s) a
..!!!.. Int
code
STVector s Word8
lzwData forall (t :: (* -> *) -> * -> *) a s.
(MonadTrans t, Storable a) =>
STVector s a -> Int -> t (ST s) a
..!!!.. Int
dataOffset
writeString :: Int -> Int -> t (ST s) Int
writeString Int
at Int
code = do
Int
dataOffset <- STVector s Int
lzwOffsetTable forall (t :: (* -> *) -> * -> *) a s.
(MonadTrans t, Storable a) =>
STVector s a -> Int -> t (ST s) a
..!!!.. Int
code
Int
dataSize <- STVector s Int
lzwSizeTable forall (t :: (* -> *) -> * -> *) a s.
(MonadTrans t, Storable a) =>
STVector s a -> Int -> t (ST s) a
..!!!.. Int
code
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
at forall a. Num a => a -> a -> a
+ Int
dataSize forall a. Ord a => a -> a -> Bool
<= Int
maxWrite) forall a b. (a -> b) -> a -> b
$
forall (t :: (* -> *) -> * -> *) a s.
(MonadTrans t, Storable a) =>
STVector s a -> STVector s a -> Int -> Int -> Int -> t (ST s) ()
duplicateData STVector s Word8
lzwData STVector s Word8
outVec Int
dataOffset Int
dataSize Int
at
forall (m :: * -> *) a. Monad m => a -> m a
return Int
dataSize
addString :: Int -> Int -> Int -> Word8 -> t (ST s) Int
addString Int
pos Int
at Int
code Word8
val = do
Int
dataOffset <- STVector s Int
lzwOffsetTable forall (t :: (* -> *) -> * -> *) a s.
(MonadTrans t, Storable a) =>
STVector s a -> Int -> t (ST s) a
..!!!.. Int
code
Int
dataSize <- STVector s Int
lzwSizeTable forall (t :: (* -> *) -> * -> *) a s.
(MonadTrans t, Storable a) =>
STVector s a -> Int -> t (ST s) a
..!!!.. Int
code
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
pos forall a. Ord a => a -> a -> Bool
< Int
tableEntryCount) forall a b. (a -> b) -> a -> b
$ do
(STVector s Int
lzwOffsetTable forall (t :: (* -> *) -> * -> *) a s.
(MonadTrans t, Storable a) =>
STVector s a -> Int -> a -> t (ST s) ()
..<-.. Int
pos) Int
at
(STVector s Int
lzwSizeTable forall (t :: (* -> *) -> * -> *) a s.
(MonadTrans t, Storable a) =>
STVector s a -> Int -> a -> t (ST s) ()
..<-.. Int
pos) forall a b. (a -> b) -> a -> b
$ Int
dataSize forall a. Num a => a -> a -> a
+ Int
1
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
at forall a. Num a => a -> a -> a
+ Int
dataSize forall a. Num a => a -> a -> a
+ Int
1 forall a. Ord a => a -> a -> Bool
<= Int
maxDataSize) forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) a s.
(MonadTrans t, Storable a) =>
STVector s a -> STVector s a -> Int -> Int -> Int -> t (ST s) ()
duplicateData STVector s Word8
lzwData STVector s Word8
lzwData Int
dataOffset Int
dataSize Int
at
(STVector s Word8
lzwData forall (t :: (* -> *) -> * -> *) a s.
(MonadTrans t, Storable a) =>
STVector s a -> Int -> a -> t (ST s) ()
..<-.. (Int
at forall a. Num a => a -> a -> a
+ Int
dataSize)) Word8
val
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
dataSize forall a. Num a => a -> a -> a
+ Int
1
maxWrite :: Int
maxWrite = forall a s. Storable a => MVector s a -> Int
M.length STVector s Word8
outVec
loop :: Int -> Int -> Int -> Int -> Int -> Int -> BoolReader s ()
loop Int
outWriteIdx Int
writeIdx Int
dicWriteIdx Int
codeSize Int
oldCode Int
code
| Int
outWriteIdx forall a. Ord a => a -> a -> Bool
>= Int
maxWrite = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Int
code forall a. Eq a => a -> a -> Bool
== Int
endOfInfo = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Int
code forall a. Eq a => a -> a -> Bool
== Int
clearCode = do
Int
toOutput <- forall {b} {s}. Num b => Int -> StateT BoolState (ST s) b
getNextCode Int
startCodeSize
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
toOutput forall a. Eq a => a -> a -> Bool
== Int
endOfInfo) forall a b. (a -> b) -> a -> b
$ do
Int
dataSize <- forall {t :: (* -> *) -> * -> *}.
(Monad (t (ST s)), MonadTrans t) =>
Int -> Int -> t (ST s) Int
writeString Int
outWriteIdx Int
toOutput
forall {b} {s}. Num b => Int -> StateT BoolState (ST s) b
getNextCode Int
startCodeSize forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Int -> Int -> Int -> Int -> Int -> Int -> BoolReader s ()
loop (Int
outWriteIdx forall a. Num a => a -> a -> a
+ Int
dataSize)
Int
firstFreeIndex Int
firstFreeIndex Int
startCodeSize Int
toOutput
| Bool
otherwise = do
(Int
written, Int
dicAdd) <-
if Int
code forall a. Ord a => a -> a -> Bool
>= Int
writeIdx then do
Word8
c <- forall {t :: (* -> *) -> * -> *}.
(Monad (t (ST s)), MonadTrans t) =>
Int -> t (ST s) Word8
firstVal Int
oldCode
Int
wroteSize <- forall {t :: (* -> *) -> * -> *}.
(Monad (t (ST s)), MonadTrans t) =>
Int -> Int -> t (ST s) Int
writeString Int
outWriteIdx Int
oldCode
(STVector s Word8
outVec forall (t :: (* -> *) -> * -> *) a s.
(MonadTrans t, Storable a) =>
STVector s a -> Int -> a -> t (ST s) ()
..<-.. (Int
outWriteIdx forall a. Num a => a -> a -> a
+ Int
wroteSize)) Word8
c
Int
addedSize <- forall {t :: (* -> *) -> * -> *}.
(Monad (t (ST s)), MonadTrans t) =>
Int -> Int -> Int -> Word8 -> t (ST s) Int
addString Int
writeIdx Int
dicWriteIdx Int
oldCode Word8
c
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
wroteSize forall a. Num a => a -> a -> a
+ Int
1, Int
addedSize)
else do
Int
wroteSize <- forall {t :: (* -> *) -> * -> *}.
(Monad (t (ST s)), MonadTrans t) =>
Int -> Int -> t (ST s) Int
writeString Int
outWriteIdx Int
code
Word8
c <- forall {t :: (* -> *) -> * -> *}.
(Monad (t (ST s)), MonadTrans t) =>
Int -> t (ST s) Word8
firstVal Int
code
Int
addedSize <- forall {t :: (* -> *) -> * -> *}.
(Monad (t (ST s)), MonadTrans t) =>
Int -> Int -> Int -> Word8 -> t (ST s) Int
addString Int
writeIdx Int
dicWriteIdx Int
oldCode Word8
c
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
wroteSize, Int
addedSize)
let new_code_size :: Int
new_code_size = forall {a}. Integral a => a -> Int -> a
updateCodeSize Int
codeSize forall a b. (a -> b) -> a -> b
$ Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1
forall {b} {s}. Num b => Int -> StateT BoolState (ST s) b
getNextCode Int
new_code_size forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Int -> Int -> Int -> Int -> Int -> Int -> BoolReader s ()
loop (Int
outWriteIdx forall a. Num a => a -> a -> a
+ Int
written)
(Int
writeIdx forall a. Num a => a -> a -> a
+ Int
1)
(Int
dicWriteIdx forall a. Num a => a -> a -> a
+ Int
dicAdd)
Int
new_code_size
Int
code
forall {b} {s}. Num b => Int -> StateT BoolState (ST s) b
getNextCode Int
startCodeSize forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Int -> Int -> Int -> Int -> Int -> Int -> BoolReader s ()
loop Int
initialWriteIdx Int
firstFreeIndex Int
firstFreeIndex Int
startCodeSize Int
0
where tableEntryCount :: Int
tableEntryCount = Int
2 forall a b. (Num a, Integral b) => a -> b -> a
^ forall a. Ord a => a -> a -> a
min Int
12 Int
nMaxBitKeySize
maxDataSize :: Int
maxDataSize = Int
tableEntryCount forall a. Integral a => a -> a -> a
`div` Int
2 forall a. Num a => a -> a -> a
* (Int
1 forall a. Num a => a -> a -> a
+ Int
tableEntryCount) forall a. Num a => a -> a -> a
+ Int
1
isNewTiff :: Bool
isNewTiff = TiffVariant
variant 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 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 forall a. Num a => a -> a -> a
+ Int
1
startCodeSize :: Int
startCodeSize
| Bool
isTiffVariant = Int
initialKeySize
| Bool
otherwise = Int
initialKeySize forall a. Num a => a -> a -> a
+ Int
1
firstFreeIndex :: Int
firstFreeIndex = Int
endOfInfo forall a. Num a => a -> a -> a
+ Int
1
resetArray :: STVector s a -> t (ST s) (STVector s a)
resetArray STVector s a
a = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== Int
2 forall a b. (Num a, Integral b) => a -> b -> a
^ a
codeSize forall a. Num a => a -> a -> a
- Int
switchOffset = forall a. Ord a => a -> a -> a
min a
12 forall a b. (a -> b) -> a -> b
$ a
codeSize 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Int -> BoolReader s Word32
getNextBitsMSBFirst Int
s
| Bool
otherwise = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Int -> BoolReader s Word32
getNextBitsLSBFirst Int
s