{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
module Codec.Picture.Jpg.Internal.Common
( DctCoefficients
, JpgUnpackerParameter( .. )
, decodeInt
, dcCoefficientDecode
, deQuantize
, decodeRrrrSsss
, zigZagReorderForward
, zigZagReorderForwardv
, zigZagReorder
, inverseDirectCosineTransform
, unpackInt
, unpackMacroBlock
, rasterMap
, decodeMacroBlock
, decodeRestartInterval
, toBlockSize
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( pure, (<$>) )
#endif
import Control.Monad( when )
import Control.Monad.ST( ST, runST )
import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) )
import Data.Int( Int16, Int32 )
import Data.Maybe( fromMaybe )
import Data.Word( Word8 )
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Storable.Mutable as M
import Foreign.Storable ( Storable )
import Codec.Picture.Types
import Codec.Picture.BitWriter
import Codec.Picture.Jpg.Internal.Types
import Codec.Picture.Jpg.Internal.FastIdct
import Codec.Picture.Jpg.Internal.DefaultTable
type DctCoefficients = DcCoefficient
data JpgUnpackerParameter = JpgUnpackerParameter
{ JpgUnpackerParameter -> HuffmanPackedTree
dcHuffmanTree :: !HuffmanPackedTree
, JpgUnpackerParameter -> HuffmanPackedTree
acHuffmanTree :: !HuffmanPackedTree
, JpgUnpackerParameter -> Int
componentIndex :: {-# UNPACK #-} !Int
, JpgUnpackerParameter -> Int
restartInterval :: {-# UNPACK #-} !Int
, JpgUnpackerParameter -> Int
componentWidth :: {-# UNPACK #-} !Int
, JpgUnpackerParameter -> Int
componentHeight :: {-# UNPACK #-} !Int
, JpgUnpackerParameter -> (Int, Int)
subSampling :: !(Int, Int)
, JpgUnpackerParameter -> (Int, Int)
coefficientRange :: !(Int, Int)
, JpgUnpackerParameter -> (Int, Int)
successiveApprox :: !(Int, Int)
, JpgUnpackerParameter -> Int
readerIndex :: {-# UNPACK #-} !Int
, JpgUnpackerParameter -> Int
indiceVector :: {-# UNPACK #-} !Int
, JpgUnpackerParameter -> Int
blockIndex :: {-# UNPACK #-} !Int
, JpgUnpackerParameter -> Int
blockMcuX :: {-# UNPACK #-} !Int
, JpgUnpackerParameter -> Int
blockMcuY :: {-# UNPACK #-} !Int
}
deriving Int -> JpgUnpackerParameter -> ShowS
[JpgUnpackerParameter] -> ShowS
JpgUnpackerParameter -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgUnpackerParameter] -> ShowS
$cshowList :: [JpgUnpackerParameter] -> ShowS
show :: JpgUnpackerParameter -> String
$cshow :: JpgUnpackerParameter -> String
showsPrec :: Int -> JpgUnpackerParameter -> ShowS
$cshowsPrec :: Int -> JpgUnpackerParameter -> ShowS
Show
toBlockSize :: Int -> Int
toBlockSize :: Int -> Int
toBlockSize Int
v = (Int
v forall a. Num a => a -> a -> a
+ Int
7) forall a. Integral a => a -> a -> a
`div` Int
8
decodeRestartInterval :: BoolReader s Int32
decodeRestartInterval :: forall s. BoolReader s Int32
decodeRestartInterval = forall (m :: * -> *) a. Monad m => a -> m a
return (-Int32
1)
{-# INLINE decodeInt #-}
decodeInt :: Int -> BoolReader s Int32
decodeInt :: forall s. Int -> BoolReader s Int32
decodeInt Int
ssss = do
Bool
signBit <- forall s. BoolReader s Bool
getNextBitJpg
let dataRange :: Int32
dataRange = Int32
1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
ssss forall a. Num a => a -> a -> a
- Int
1)
leftBitCount :: Int
leftBitCount = Int
ssss forall a. Num a => a -> a -> a
- Int
1
if Bool
signBit
then (\Int32
w -> Int32
dataRange forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Int -> BoolReader s Int32
unpackInt Int
leftBitCount
else (\Int32
w -> Int32
1 forall a. Num a => a -> a -> a
- Int32
dataRange forall a. Num a => a -> a -> a
* Int32
2 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Int -> BoolReader s Int32
unpackInt Int
leftBitCount
decodeRrrrSsss :: HuffmanPackedTree -> BoolReader s (Int, Int)
HuffmanPackedTree
tree = do
Word8
rrrrssss <- forall s. HuffmanPackedTree -> BoolReader s Word8
huffmanPackedDecode HuffmanPackedTree
tree
let rrrr :: Word8
rrrr = (Word8
rrrrssss forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) forall a. Bits a => a -> a -> a
.&. Word8
0xF
ssss :: Word8
ssss = Word8
rrrrssss forall a. Bits a => a -> a -> a
.&. Word8
0xF
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
rrrr, forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
ssss)
dcCoefficientDecode :: HuffmanPackedTree -> BoolReader s DcCoefficient
dcCoefficientDecode :: forall s. HuffmanPackedTree -> BoolReader s Int16
dcCoefficientDecode HuffmanPackedTree
dcTree = do
Word8
ssss <- forall s. HuffmanPackedTree -> BoolReader s Word8
huffmanPackedDecode HuffmanPackedTree
dcTree
if Word8
ssss forall a. Eq a => a -> a -> Bool
== Word8
0
then forall (m :: * -> *) a. Monad m => a -> m a
return Int16
0
else 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 Int32
decodeInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
ssss)
{-# INLINE deQuantize #-}
deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16
-> ST s (MutableMacroBlock s Int16)
deQuantize :: forall s.
MacroBlock Int16
-> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16)
deQuantize MacroBlock Int16
table MutableMacroBlock s Int16
block = Int -> ST s (MutableMacroBlock s Int16)
update Int
0
where update :: Int -> ST s (MutableMacroBlock s Int16)
update Int
64 = forall (m :: * -> *) a. Monad m => a -> m a
return MutableMacroBlock s Int16
block
update Int
i = do
Int16
val <- MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
i
let finalValue :: Int16
finalValue = Int16
val forall a. Num a => a -> a -> a
* (MacroBlock Int16
table forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` Int
i)
(MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
i) Int16
finalValue
Int -> ST s (MutableMacroBlock s Int16)
update forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
+ Int
1
inverseDirectCosineTransform :: MutableMacroBlock s Int16
-> ST s (MutableMacroBlock s Int16)
inverseDirectCosineTransform :: forall s.
MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16)
inverseDirectCosineTransform MutableMacroBlock s Int16
mBlock =
forall s.
MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16)
fastIdct MutableMacroBlock s Int16
mBlock forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s.
MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16)
mutableLevelShift
zigZagOrder :: MacroBlock Int
zigZagOrder :: MacroBlock Int
zigZagOrder = forall a. Storable a => [a] -> MacroBlock a
makeMacroBlock forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[[ Int
0, Int
1, Int
5, Int
6,Int
14,Int
15,Int
27,Int
28]
,[ Int
2, Int
4, Int
7,Int
13,Int
16,Int
26,Int
29,Int
42]
,[ Int
3, Int
8,Int
12,Int
17,Int
25,Int
30,Int
41,Int
43]
,[ Int
9,Int
11,Int
18,Int
24,Int
31,Int
40,Int
44,Int
53]
,[Int
10,Int
19,Int
23,Int
32,Int
39,Int
45,Int
52,Int
54]
,[Int
20,Int
22,Int
33,Int
38,Int
46,Int
51,Int
55,Int
60]
,[Int
21,Int
34,Int
37,Int
47,Int
50,Int
56,Int
59,Int
61]
,[Int
35,Int
36,Int
48,Int
49,Int
57,Int
58,Int
62,Int
63]
]
zigZagReorderForwardv :: (Storable a, Num a) => VS.Vector a -> VS.Vector a
zigZagReorderForwardv :: forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv Vector a
vec = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
MutableMacroBlock s a
v <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
64
MutableMacroBlock s a
mv <- forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
VS.thaw Vector a
vec
forall a s.
Storable a =>
MutableMacroBlock s a
-> MutableMacroBlock s a -> ST s (MutableMacroBlock s a)
zigZagReorderForward MutableMacroBlock s a
v MutableMacroBlock s a
mv forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.freeze
zigZagOrderForward :: MacroBlock Int
zigZagOrderForward :: MacroBlock Int
zigZagOrderForward = forall a. Storable a => Int -> (Int -> a) -> Vector a
VS.generate Int
64 Int -> Int
inv
where inv :: Int -> Int
inv Int
i = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall a. Storable a => (a -> Bool) -> Vector a -> Maybe Int
VS.findIndex (Int
i forall a. Eq a => a -> a -> Bool
==) MacroBlock Int
zigZagOrder
zigZagReorderForward :: (Storable a)
=> MutableMacroBlock s a
-> MutableMacroBlock s a
-> ST s (MutableMacroBlock s a)
{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int32
-> MutableMacroBlock s Int32
-> ST s (MutableMacroBlock s Int32) #-}
{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int16
-> MutableMacroBlock s Int16
-> ST s (MutableMacroBlock s Int16) #-}
{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Word8
-> MutableMacroBlock s Word8
-> ST s (MutableMacroBlock s Word8) #-}
zigZagReorderForward :: forall a s.
Storable a =>
MutableMacroBlock s a
-> MutableMacroBlock s a -> ST s (MutableMacroBlock s a)
zigZagReorderForward MutableMacroBlock s a
zigzaged MutableMacroBlock s a
block = MacroBlock Int -> ST s ()
ordering MacroBlock Int
zigZagOrderForward forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return MutableMacroBlock s a
zigzaged
where ordering :: MacroBlock Int -> ST s ()
ordering !MacroBlock Int
table = Int -> ST s ()
reorder (Int
0 :: Int)
where reorder :: Int -> ST s ()
reorder !Int
i | Int
i forall a. Ord a => a -> a -> Bool
>= Int
64 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
reorder Int
i = do
let idx :: Int
idx = MacroBlock Int
table forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` Int
i
a
v <- MutableMacroBlock s a
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
(MutableMacroBlock s a
zigzaged forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
i) a
v
Int -> ST s ()
reorder (Int
i forall a. Num a => a -> a -> a
+ Int
1)
zigZagReorder :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16
-> ST s (MutableMacroBlock s Int16)
zigZagReorder :: forall s.
MutableMacroBlock s Int16
-> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16)
zigZagReorder MutableMacroBlock s Int16
zigzaged MutableMacroBlock s Int16
block = do
let update :: Int -> ST s ()
update Int
i = do
let idx :: Int
idx = MacroBlock Int
zigZagOrder forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` Int
i
Int16
v <- MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
(MutableMacroBlock s Int16
zigzaged forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
i) Int16
v
reorder :: Int -> ST s ()
reorder Int
63 = Int -> ST s ()
update Int
63
reorder Int
i = Int -> ST s ()
update Int
i forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ST s ()
reorder (Int
i forall a. Num a => a -> a -> a
+ Int
1)
Int -> ST s ()
reorder (Int
0 :: Int)
forall (m :: * -> *) a. Monad m => a -> m a
return MutableMacroBlock s Int16
zigzaged
unpackInt :: Int -> BoolReader s Int32
unpackInt :: forall s. Int -> BoolReader s Int32
unpackInt = forall s. Int -> BoolReader s Int32
getNextIntJpg
{-# INLINE rasterMap #-}
rasterMap :: (Monad m)
=> Int -> Int -> (Int -> Int -> m ())
-> m ()
rasterMap :: forall (m :: * -> *).
Monad m =>
Int -> Int -> (Int -> Int -> m ()) -> m ()
rasterMap Int
width Int
height Int -> Int -> m ()
f = Int -> m ()
liner Int
0
where liner :: Int -> m ()
liner Int
y | Int
y forall a. Ord a => a -> a -> Bool
>= Int
height = forall (m :: * -> *) a. Monad m => a -> m a
return ()
liner Int
y = Int -> m ()
columner Int
0
where columner :: Int -> m ()
columner Int
x | Int
x forall a. Ord a => a -> a -> Bool
>= Int
width = Int -> m ()
liner (Int
y forall a. Num a => a -> a -> a
+ Int
1)
columner Int
x = Int -> Int -> m ()
f Int
x Int
y forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> m ()
columner (Int
x forall a. Num a => a -> a -> a
+ Int
1)
pixelClamp :: Int16 -> Word8
pixelClamp :: Int16 -> Word8
pixelClamp Int16
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min Int16
255 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Int16
0 Int16
n
unpackMacroBlock :: Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpackMacroBlock :: forall s.
Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpackMacroBlock Int
compCount Int
wCoeff Int
hCoeff Int
compIdx Int
x Int
y
(MutableImage { mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth,
mutableImageHeight :: forall s a. MutableImage s a -> Int
mutableImageHeight = Int
imgHeight, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent PixelYCbCr8)
img })
MutableMacroBlock s Int16
block = forall (m :: * -> *).
Monad m =>
Int -> Int -> (Int -> Int -> m ()) -> m ()
rasterMap forall a. Num a => a
dctBlockSize forall a. Num a => a
dctBlockSize Int -> Int -> ST s ()
unpacker
where unpacker :: Int -> Int -> ST s ()
unpacker Int
i Int
j = do
let yBase :: Int
yBase = Int
y forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
+ Int
j forall a. Num a => a -> a -> a
* Int
hCoeff
Word8
compVal <- Int16 -> Word8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
i forall a. Num a => a -> a -> a
+ Int
j forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize))
forall (m :: * -> *).
Monad m =>
Int -> Int -> (Int -> Int -> m ()) -> m ()
rasterMap Int
wCoeff Int
hCoeff forall a b. (a -> b) -> a -> b
$ \Int
wDup Int
hDup -> do
let xBase :: Int
xBase = Int
x forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
+ Int
i forall a. Num a => a -> a -> a
* Int
wCoeff
xPos :: Int
xPos = Int
xBase forall a. Num a => a -> a -> a
+ Int
wDup
yPos :: Int
yPos = Int
yBase forall a. Num a => a -> a -> a
+ Int
hDup
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
xPos forall a. Ord a => a -> a -> Bool
< Int
imgWidth Bool -> Bool -> Bool
&& Int
yPos forall a. Ord a => a -> a -> Bool
< Int
imgHeight)
(do let mutableIdx :: Int
mutableIdx = (Int
xPos forall a. Num a => a -> a -> a
+ Int
yPos forall a. Num a => a -> a -> a
* Int
imgWidth) forall a. Num a => a -> a -> a
* Int
compCount forall a. Num a => a -> a -> a
+ Int
compIdx
(STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
mutableIdx) Word8
compVal)
decodeMacroBlock :: MacroBlock DctCoefficients
-> MutableMacroBlock s Int16
-> MutableMacroBlock s Int16
-> ST s (MutableMacroBlock s Int16)
decodeMacroBlock :: forall s.
MacroBlock Int16
-> MutableMacroBlock s Int16
-> MutableMacroBlock s Int16
-> ST s (MutableMacroBlock s Int16)
decodeMacroBlock MacroBlock Int16
quantizationTable MutableMacroBlock s Int16
zigZagBlock MutableMacroBlock s Int16
block =
forall s.
MacroBlock Int16
-> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16)
deQuantize MacroBlock Int16
quantizationTable MutableMacroBlock s Int16
block forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s.
MutableMacroBlock s Int16
-> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16)
zigZagReorder MutableMacroBlock s Int16
zigZagBlock
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s.
MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16)
inverseDirectCosineTransform