{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Codec.Picture.Jpg.Internal.Progressive
( JpgUnpackerParameter( .. )
, progressiveUnpack
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( pure, (<$>) )
#endif
import Control.Monad( when, unless, forM_ )
import Control.Monad.ST( ST )
import Control.Monad.Trans( lift )
import Data.Bits( (.&.), (.|.), unsafeShiftL )
import Data.Int( Int16, Int32 )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import Data.Vector( (!) )
import qualified Data.Vector.Mutable as M
import qualified Data.Vector.Storable.Mutable as MS
import Codec.Picture.Types
import Codec.Picture.BitWriter
import Codec.Picture.Jpg.Internal.Common
import Codec.Picture.Jpg.Internal.Types
import Codec.Picture.Jpg.Internal.DefaultTable
createMcuLineIndices :: JpgComponent -> Int -> Int -> V.Vector (VS.Vector Int)
createMcuLineIndices :: JpgComponent -> Int -> Int -> Vector (Vector Int)
createMcuLineIndices param :: JpgComponent
param imgWidth :: Int
imgWidth mcuWidth :: Int
mcuWidth =
[Vector Int] -> Vector (Vector Int)
forall a. [a] -> Vector a
V.fromList ([Vector Int] -> Vector (Vector Int))
-> [Vector Int] -> Vector (Vector Int)
forall a b. (a -> b) -> a -> b
$ [Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
VS.fromList ([Int] -> Vector Int) -> [[Int]] -> [Vector Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Int]
indexSolo, [Int]
indexMulti]
where compW :: Int
compW = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
horizontalSamplingFactor JpgComponent
param
compH :: Int
compH = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
verticalSamplingFactor JpgComponent
param
imageBlockSize :: Int
imageBlockSize = Int -> Int
toBlockSize Int
imgWidth
indexSolo :: [Int]
indexSolo = [Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x
| Int
y <- [0 .. Int
compH Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]
, let base :: Int
base = Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mcuWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
compW
, Int
x <- [0 .. Int
imageBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]]
indexMulti :: [Int]
indexMulti =
[(Int
mcu Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
mcuWidth) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
compW Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x
| Int
mcu <- [0 .. Int
mcuWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]
, Int
y <- [0 .. Int
compH Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]
, Int
x <- [0 .. Int
compW Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ]
decodeFirstDC :: JpgUnpackerParameter
-> MS.STVector s Int16
-> MutableMacroBlock s Int16
-> Int32
-> BoolReader s Int32
decodeFirstDC :: JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32
decodeFirstDC params :: JpgUnpackerParameter
params dcCoeffs :: STVector s Int16
dcCoeffs block :: STVector s Int16
block eobrun :: Int32
eobrun = StateT BoolState (ST s) ()
unpack StateT BoolState (ST s) ()
-> BoolReader s Int32 -> BoolReader s Int32
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int32 -> BoolReader s Int32
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int32
eobrun
where unpack :: StateT BoolState (ST s) ()
unpack = do
(Int16
dcDeltaCoefficient) <- HuffmanPackedTree -> BoolReader s Int16
forall s. HuffmanPackedTree -> BoolReader s Int16
dcCoefficientDecode (HuffmanPackedTree -> BoolReader s Int16)
-> HuffmanPackedTree -> BoolReader s Int16
forall a b. (a -> b) -> a -> b
$ JpgUnpackerParameter -> HuffmanPackedTree
dcHuffmanTree JpgUnpackerParameter
params
Int16
previousDc <- ST s Int16 -> BoolReader s Int16
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s Int16 -> BoolReader s Int16)
-> ST s Int16 -> BoolReader s Int16
forall a b. (a -> b) -> a -> b
$ STVector s Int16
MVector (PrimState (ST s)) Int16
dcCoeffs MVector (PrimState (ST s)) Int16 -> Int -> ST s Int16
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`MS.unsafeRead` JpgUnpackerParameter -> Int
componentIndex JpgUnpackerParameter
params
let neoDcCoefficient :: Int16
neoDcCoefficient = Int16
previousDc Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
dcDeltaCoefficient
approxLow :: Int
approxLow = (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ JpgUnpackerParameter -> (Int, Int)
successiveApprox JpgUnpackerParameter
params
scaledDc :: Int16
scaledDc = Int16
neoDcCoefficient Int16 -> Int -> Int16
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
approxLow
ST s () -> StateT BoolState (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT BoolState (ST s) ())
-> ST s () -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ (STVector s Int16
MVector (PrimState (ST s)) Int16
block MVector (PrimState (ST s)) Int16 -> Int -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`MS.unsafeWrite` 0) Int16
scaledDc
ST s () -> StateT BoolState (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT BoolState (ST s) ())
-> ST s () -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ (STVector s Int16
MVector (PrimState (ST s)) Int16
dcCoeffs MVector (PrimState (ST s)) Int16 -> Int -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`MS.unsafeWrite` JpgUnpackerParameter -> Int
componentIndex JpgUnpackerParameter
params) Int16
neoDcCoefficient
decodeRefineDc :: JpgUnpackerParameter
-> a
-> MutableMacroBlock s Int16
-> Int32
-> BoolReader s Int32
decodeRefineDc :: JpgUnpackerParameter
-> a -> MutableMacroBlock s Int16 -> Int32 -> BoolReader s Int32
decodeRefineDc params :: JpgUnpackerParameter
params _ block :: MutableMacroBlock s Int16
block eobrun :: Int32
eobrun = StateT BoolState (ST s) ()
unpack StateT BoolState (ST s) ()
-> BoolReader s Int32 -> BoolReader s Int32
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int32 -> BoolReader s Int32
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int32
eobrun
where approxLow :: Int
approxLow = (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ JpgUnpackerParameter -> (Int, Int)
successiveApprox JpgUnpackerParameter
params
plusOne :: Int16
plusOne = 1 Int16 -> Int -> Int16
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
approxLow
unpack :: StateT BoolState (ST s) ()
unpack = do
Bool
bit <- BoolReader s Bool
forall s. BoolReader s Bool
getNextBitJpg
Bool -> StateT BoolState (ST s) () -> StateT BoolState (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
bit (StateT BoolState (ST s) () -> StateT BoolState (ST s) ())
-> (ST s () -> StateT BoolState (ST s) ())
-> ST s ()
-> StateT BoolState (ST s) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST s () -> StateT BoolState (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT BoolState (ST s) ())
-> ST s () -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
Int16
v <- MutableMacroBlock s Int16
MVector (PrimState (ST s)) Int16
block MVector (PrimState (ST s)) Int16 -> Int -> ST s Int16
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`MS.unsafeRead` 0
(MutableMacroBlock s Int16
MVector (PrimState (ST s)) Int16
block MVector (PrimState (ST s)) Int16 -> Int -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`MS.unsafeWrite` 0) (Int16 -> ST s ()) -> Int16 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int16
v Int16 -> Int16 -> Int16
forall a. Bits a => a -> a -> a
.|. Int16
plusOne
decodeFirstAc :: JpgUnpackerParameter
-> a
-> MutableMacroBlock s Int16
-> Int32
-> BoolReader s Int32
decodeFirstAc :: JpgUnpackerParameter
-> a -> MutableMacroBlock s Int16 -> Int32 -> BoolReader s Int32
decodeFirstAc _params :: JpgUnpackerParameter
_params _ _block :: MutableMacroBlock s Int16
_block eobrun :: Int32
eobrun | Int32
eobrun Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = Int32 -> BoolReader s Int32
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int32 -> BoolReader s Int32) -> Int32 -> BoolReader s Int32
forall a b. (a -> b) -> a -> b
$ Int32
eobrun Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- 1
decodeFirstAc params :: JpgUnpackerParameter
params _ block :: MutableMacroBlock s Int16
block _ = Int -> BoolReader s Int32
unpack Int
startIndex
where (startIndex :: Int
startIndex, maxIndex :: Int
maxIndex) = JpgUnpackerParameter -> (Int, Int)
coefficientRange JpgUnpackerParameter
params
(low :: Int
low, _) = JpgUnpackerParameter -> (Int, Int)
successiveApprox JpgUnpackerParameter
params
unpack :: Int -> BoolReader s Int32
unpack n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxIndex = Int32 -> BoolReader s Int32
forall (f :: * -> *) a. Applicative f => a -> f a
pure 0
unpack n :: Int
n = do
(Int, Int)
rrrrssss <- HuffmanPackedTree -> BoolReader s (Int, Int)
forall s. HuffmanPackedTree -> BoolReader s (Int, Int)
decodeRrrrSsss (HuffmanPackedTree -> BoolReader s (Int, Int))
-> HuffmanPackedTree -> BoolReader s (Int, Int)
forall a b. (a -> b) -> a -> b
$ JpgUnpackerParameter -> HuffmanPackedTree
acHuffmanTree JpgUnpackerParameter
params
case (Int, Int)
rrrrssss of
(0xF, 0) -> Int -> BoolReader s Int32
unpack (Int -> BoolReader s Int32) -> Int -> BoolReader s Int32
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 16
( 0, 0) -> Int32 -> BoolReader s Int32
forall (m :: * -> *) a. Monad m => a -> m a
return 0
( r :: Int
r, 0) -> Int32 -> Int32
forall a. (Num a, Bits a) => a -> a
eobrun (Int32 -> Int32) -> BoolReader s Int32 -> BoolReader s Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> BoolReader s Int32
forall s. Int -> BoolReader s Int32
unpackInt Int
r
where eobrun :: a -> a
eobrun lowBits :: a
lowBits = (1 a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
r) a -> a -> a
forall a. Num a => a -> a -> a
- 1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
lowBits
( r :: Int
r, s :: Int
s) -> do
let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r
Int32
val <- (Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
low) (Int32 -> Int32) -> BoolReader s Int32 -> BoolReader s Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> BoolReader s Int32
forall s. Int -> BoolReader s Int32
decodeInt Int
s
ST s () -> StateT BoolState (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT BoolState (ST s) ())
-> (Int16 -> ST s ()) -> Int16 -> StateT BoolState (ST s) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MutableMacroBlock s Int16
MVector (PrimState (ST s)) Int16
block MVector (PrimState (ST s)) Int16 -> Int -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`MS.unsafeWrite` Int
n') (Int16 -> StateT BoolState (ST s) ())
-> Int16 -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ Int32 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
val
Int -> BoolReader s Int32
unpack (Int -> BoolReader s Int32) -> Int -> BoolReader s Int32
forall a b. (a -> b) -> a -> b
$ Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
decodeRefineAc :: forall a s. JpgUnpackerParameter
-> a
-> MutableMacroBlock s Int16
-> Int32
-> BoolReader s Int32
decodeRefineAc :: JpgUnpackerParameter
-> a -> MutableMacroBlock s Int16 -> Int32 -> BoolReader s Int32
decodeRefineAc params :: JpgUnpackerParameter
params _ block :: MutableMacroBlock s Int16
block eobrun :: Int32
eobrun
| Int32
eobrun Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = Int -> BoolReader s Int32
unpack Int
startIndex
| Bool
otherwise = Int -> StateT BoolState (ST s) ()
performEobRun Int
startIndex StateT BoolState (ST s) ()
-> BoolReader s Int32 -> BoolReader s Int32
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int32 -> BoolReader s Int32
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
eobrun Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- 1)
where (startIndex :: Int
startIndex, maxIndex :: Int
maxIndex) = JpgUnpackerParameter -> (Int, Int)
coefficientRange JpgUnpackerParameter
params
(low :: Int
low, _) = JpgUnpackerParameter -> (Int, Int)
successiveApprox JpgUnpackerParameter
params
plusOne :: Int16
plusOne = 1 Int16 -> Int -> Int16
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
low
minusOne :: Int16
minusOne = (-1) Int16 -> Int -> Int16
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
low
getBitVal :: StateT BoolState (ST s) Int16
getBitVal = do
Bool
v <- BoolReader s Bool
forall s. BoolReader s Bool
getNextBitJpg
Int16 -> StateT BoolState (ST s) Int16
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int16 -> StateT BoolState (ST s) Int16)
-> Int16 -> StateT BoolState (ST s) Int16
forall a b. (a -> b) -> a -> b
$ if Bool
v then Int16
plusOne else Int16
minusOne
performEobRun :: Int -> StateT BoolState (ST s) ()
performEobRun idx :: Int
idx | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxIndex = () -> StateT BoolState (ST s) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
performEobRun idx :: Int
idx = do
Int16
coeff <- ST s Int16 -> StateT BoolState (ST s) Int16
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s Int16 -> StateT BoolState (ST s) Int16)
-> ST s Int16 -> StateT BoolState (ST s) Int16
forall a b. (a -> b) -> a -> b
$ MutableMacroBlock s Int16
MVector (PrimState (ST s)) Int16
block MVector (PrimState (ST s)) Int16 -> Int -> ST s Int16
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`MS.unsafeRead` Int
idx
if Int16
coeff Int16 -> Int16 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then do
Bool
bit <- BoolReader s Bool
forall s. BoolReader s Bool
getNextBitJpg
case (Bool
bit, (Int16
coeff Int16 -> Int16 -> Int16
forall a. Bits a => a -> a -> a
.&. Int16
plusOne) Int16 -> Int16 -> Bool
forall a. Eq a => a -> a -> Bool
== 0) of
(False, _) -> Int -> StateT BoolState (ST s) ()
performEobRun (Int -> StateT BoolState (ST s) ())
-> Int -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
(True, False) -> Int -> StateT BoolState (ST s) ()
performEobRun (Int -> StateT BoolState (ST s) ())
-> Int -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
(True, True) -> do
let newVal :: Int16
newVal | Int16
coeff Int16 -> Int16 -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 = Int16
coeff Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
plusOne
| Bool
otherwise = Int16
coeff Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
minusOne
ST s () -> StateT BoolState (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT BoolState (ST s) ())
-> ST s () -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ (MutableMacroBlock s Int16
MVector (PrimState (ST s)) Int16
block MVector (PrimState (ST s)) Int16 -> Int -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`MS.unsafeWrite` Int
idx) Int16
newVal
Int -> StateT BoolState (ST s) ()
performEobRun (Int -> StateT BoolState (ST s) ())
-> Int -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
else
Int -> StateT BoolState (ST s) ()
performEobRun (Int -> StateT BoolState (ST s) ())
-> Int -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
unpack :: Int -> BoolReader s Int32
unpack idx :: Int
idx | Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxIndex = Int32 -> BoolReader s Int32
forall (f :: * -> *) a. Applicative f => a -> f a
pure 0
unpack idx :: Int
idx = do
(Int, Int)
rrrrssss <- HuffmanPackedTree -> BoolReader s (Int, Int)
forall s. HuffmanPackedTree -> BoolReader s (Int, Int)
decodeRrrrSsss (HuffmanPackedTree -> BoolReader s (Int, Int))
-> HuffmanPackedTree -> BoolReader s (Int, Int)
forall a b. (a -> b) -> a -> b
$ JpgUnpackerParameter -> HuffmanPackedTree
acHuffmanTree JpgUnpackerParameter
params
case (Int, Int)
rrrrssss of
(0xF, 0) -> do
Int
idx' <- Int -> Int -> BoolReader s Int
updateCoeffs 0xF Int
idx
Int -> BoolReader s Int32
unpack (Int -> BoolReader s Int32) -> Int -> BoolReader s Int32
forall a b. (a -> b) -> a -> b
$ Int
idx' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
( r :: Int
r, 0) -> do
Int32
lowBits <- Int -> BoolReader s Int32
forall s. Int -> BoolReader s Int32
unpackInt Int
r
let newEobRun :: Int32
newEobRun = (1 Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
r) Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
lowBits Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- 1
Int -> StateT BoolState (ST s) ()
performEobRun Int
idx
Int32 -> BoolReader s Int32
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int32
newEobRun
( r :: Int
r, _) -> do
Int16
val <- StateT BoolState (ST s) Int16
forall s. StateT BoolState (ST s) Int16
getBitVal
Int
idx' <- Int -> Int -> BoolReader s Int
updateCoeffs (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r) Int
idx
Bool -> StateT BoolState (ST s) () -> StateT BoolState (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
idx' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxIndex) (StateT BoolState (ST s) () -> StateT BoolState (ST s) ())
-> StateT BoolState (ST s) () -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$
ST s () -> StateT BoolState (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT BoolState (ST s) ())
-> ST s () -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ (MutableMacroBlock s Int16
MVector (PrimState (ST s)) Int16
block MVector (PrimState (ST s)) Int16 -> Int -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`MS.unsafeWrite` Int
idx') Int16
val
Int -> BoolReader s Int32
unpack (Int -> BoolReader s Int32) -> Int -> BoolReader s Int32
forall a b. (a -> b) -> a -> b
$ Int
idx' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
updateCoeffs :: Int -> Int -> BoolReader s Int
updateCoeffs :: Int -> Int -> BoolReader s Int
updateCoeffs r :: Int
r idx :: Int
idx
| Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = Int -> BoolReader s Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> BoolReader s Int) -> Int -> BoolReader s Int
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
| Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxIndex = Int -> BoolReader s Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
idx
updateCoeffs r :: Int
r idx :: Int
idx = do
Int16
coeff <- ST s Int16 -> StateT BoolState (ST s) Int16
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s Int16 -> StateT BoolState (ST s) Int16)
-> ST s Int16 -> StateT BoolState (ST s) Int16
forall a b. (a -> b) -> a -> b
$ MutableMacroBlock s Int16
MVector (PrimState (ST s)) Int16
block MVector (PrimState (ST s)) Int16 -> Int -> ST s Int16
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`MS.unsafeRead` Int
idx
if Int16
coeff Int16 -> Int16 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then do
Bool
bit <- BoolReader s Bool
forall s. BoolReader s Bool
getNextBitJpg
Bool -> StateT BoolState (ST s) () -> StateT BoolState (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
bit Bool -> Bool -> Bool
&& Int16
coeff Int16 -> Int16 -> Int16
forall a. Bits a => a -> a -> a
.&. Int16
plusOne Int16 -> Int16 -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (StateT BoolState (ST s) () -> StateT BoolState (ST s) ())
-> StateT BoolState (ST s) () -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
let writeCoeff :: Int16
writeCoeff | Int16
coeff Int16 -> Int16 -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 = Int16
coeff Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
plusOne
| Bool
otherwise = Int16
coeff Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
minusOne
ST s () -> StateT BoolState (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT BoolState (ST s) ())
-> ST s () -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ (MutableMacroBlock s Int16
MVector (PrimState (ST s)) Int16
block MVector (PrimState (ST s)) Int16 -> Int -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`MS.unsafeWrite` Int
idx) Int16
writeCoeff
Int -> Int -> BoolReader s Int
updateCoeffs Int
r (Int -> BoolReader s Int) -> Int -> BoolReader s Int
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
else
Int -> Int -> BoolReader s Int
updateCoeffs (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Int -> BoolReader s Int) -> Int -> BoolReader s Int
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
type Unpacker s =
JpgUnpackerParameter -> MS.STVector s Int16 -> MutableMacroBlock s Int16 -> Int32
-> BoolReader s Int32
prepareUnpacker :: [([(JpgUnpackerParameter, a)], L.ByteString)]
-> ST s ( V.Vector (V.Vector (JpgUnpackerParameter, Unpacker s))
, M.STVector s BoolState)
prepareUnpacker :: [([(JpgUnpackerParameter, a)], ByteString)]
-> ST
s
(Vector (Vector (JpgUnpackerParameter, Unpacker s)),
STVector s BoolState)
prepareUnpacker lst :: [([(JpgUnpackerParameter, a)], ByteString)]
lst = do
let boolStates :: Vector BoolState
boolStates = [BoolState] -> Vector BoolState
forall a. [a] -> Vector a
V.fromList ([BoolState] -> Vector BoolState)
-> [BoolState] -> Vector BoolState
forall a b. (a -> b) -> a -> b
$ ((Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector Any Int16
-> STVector Any Int16
-> Int32
-> BoolReader Any Int32),
BoolState)
-> BoolState)
-> [(Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector Any Int16
-> STVector Any Int16
-> Int32
-> BoolReader Any Int32),
BoolState)]
-> [BoolState]
forall a b. (a -> b) -> [a] -> [b]
map (Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector Any Int16
-> STVector Any Int16
-> Int32
-> BoolReader Any Int32),
BoolState)
-> BoolState
forall a b. (a, b) -> b
snd [(Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector Any Int16
-> STVector Any Int16
-> Int32
-> BoolReader Any Int32),
BoolState)]
forall s.
[(Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32),
BoolState)]
infos
STVector s BoolState
vec <- Vector BoolState -> ST s (MVector (PrimState (ST s)) BoolState)
forall (m :: * -> *) a.
PrimMonad m =>
Vector a -> m (MVector (PrimState m) a)
V.unsafeThaw Vector BoolState
boolStates
(Vector (Vector (JpgUnpackerParameter, Unpacker s)),
STVector s BoolState)
-> ST
s
(Vector (Vector (JpgUnpackerParameter, Unpacker s)),
STVector s BoolState)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Vector (JpgUnpackerParameter, Unpacker s)]
-> Vector (Vector (JpgUnpackerParameter, Unpacker s))
forall a. [a] -> Vector a
V.fromList ([Vector (JpgUnpackerParameter, Unpacker s)]
-> Vector (Vector (JpgUnpackerParameter, Unpacker s)))
-> [Vector (JpgUnpackerParameter, Unpacker s)]
-> Vector (Vector (JpgUnpackerParameter, Unpacker s))
forall a b. (a -> b) -> a -> b
$ ((Vector (JpgUnpackerParameter, Unpacker s), BoolState)
-> Vector (JpgUnpackerParameter, Unpacker s))
-> [(Vector (JpgUnpackerParameter, Unpacker s), BoolState)]
-> [Vector (JpgUnpackerParameter, Unpacker s)]
forall a b. (a -> b) -> [a] -> [b]
map (Vector (JpgUnpackerParameter, Unpacker s), BoolState)
-> Vector (JpgUnpackerParameter, Unpacker s)
forall a b. (a, b) -> a
fst [(Vector (JpgUnpackerParameter, Unpacker s), BoolState)]
forall s.
[(Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32),
BoolState)]
infos, STVector s BoolState
vec)
where infos :: [(Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32),
BoolState)]
infos = (([(JpgUnpackerParameter, a)], ByteString)
-> (Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32),
BoolState))
-> [([(JpgUnpackerParameter, a)], ByteString)]
-> [(Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32),
BoolState)]
forall a b. (a -> b) -> [a] -> [b]
map ([(JpgUnpackerParameter, a)], ByteString)
-> (Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32),
BoolState)
forall b s.
([(JpgUnpackerParameter, b)], ByteString)
-> (Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32),
BoolState)
prepare [([(JpgUnpackerParameter, a)], ByteString)]
lst
prepare :: ([(JpgUnpackerParameter, b)], ByteString)
-> (Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32),
BoolState)
prepare ([], _) = [Char]
-> (Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32),
BoolState)
forall a. HasCallStack => [Char] -> a
error "progressiveUnpack, no component"
prepare (whole :: [(JpgUnpackerParameter, b)]
whole@((param :: JpgUnpackerParameter
param, _) : _) , byteString :: ByteString
byteString) =
([(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32)]
-> Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32)
forall a. [a] -> Vector a
V.fromList ([(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32)]
-> Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32))
-> [(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32)]
-> Vector
(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32)
forall a b. (a -> b) -> a -> b
$ ((JpgUnpackerParameter, b)
-> (JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32))
-> [(JpgUnpackerParameter, b)]
-> [(JpgUnpackerParameter,
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32)]
forall a b. (a -> b) -> [a] -> [b]
map (\(p :: JpgUnpackerParameter
p,_) -> (JpgUnpackerParameter
p, JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32
forall s.
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32
unpacker)) [(JpgUnpackerParameter, b)]
whole, BoolState
boolReader)
where unpacker :: JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32
unpacker = (Int, Int)
-> (Int, Int)
-> JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32
forall a a a b s.
(Eq a, Eq a, Num a, Num a) =>
(a, a)
-> (a, b)
-> JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32
selection (JpgUnpackerParameter -> (Int, Int)
successiveApprox JpgUnpackerParameter
param) (JpgUnpackerParameter -> (Int, Int)
coefficientRange JpgUnpackerParameter
param)
boolReader :: BoolState
boolReader = ByteString -> BoolState
initBoolStateJpg (ByteString -> BoolState)
-> ([ByteString] -> ByteString) -> [ByteString] -> BoolState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.concat ([ByteString] -> BoolState) -> [ByteString] -> BoolState
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks ByteString
byteString
selection :: (a, a)
-> (a, b)
-> JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32
selection (_, 0) (0, _) = JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32
forall s.
JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32
decodeFirstDC
selection (_, 0) _ = JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32
forall a s.
JpgUnpackerParameter
-> a -> MutableMacroBlock s Int16 -> Int32 -> BoolReader s Int32
decodeFirstAc
selection _ (0, _) = JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32
forall a s.
JpgUnpackerParameter
-> a -> MutableMacroBlock s Int16 -> Int32 -> BoolReader s Int32
decodeRefineDc
selection _ _ = JpgUnpackerParameter
-> STVector s Int16
-> STVector s Int16
-> Int32
-> BoolReader s Int32
forall a s.
JpgUnpackerParameter
-> a -> MutableMacroBlock s Int16 -> Int32 -> BoolReader s Int32
decodeRefineAc
data ComponentData s = ComponentData
{ ComponentData s -> Vector (Vector Int)
componentIndices :: V.Vector (VS.Vector Int)
, ComponentData s -> Vector (MutableMacroBlock s Int16)
componentBlocks :: V.Vector (MutableMacroBlock s Int16)
, ComponentData s -> Int
componentId :: !Int
, ComponentData s -> Int
componentBlockCount :: !Int
}
lineMap :: (Monad m) => Int -> (Int -> m ()) -> m ()
{-# INLINE lineMap #-}
lineMap :: Int -> (Int -> m ()) -> m ()
lineMap count :: Int
count f :: Int -> m ()
f = Int -> m ()
go 0
where go :: Int -> m ()
go n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
count = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go n :: Int
n = Int -> m ()
f Int
n m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> m ()
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
progressiveUnpack :: (Int, Int)
-> JpgFrameHeader
-> V.Vector (MacroBlock Int16)
-> [([(JpgUnpackerParameter, a)], L.ByteString)]
-> ST s (MutableImage s PixelYCbCr8)
progressiveUnpack :: (Int, Int)
-> JpgFrameHeader
-> Vector (MacroBlock Int16)
-> [([(JpgUnpackerParameter, a)], ByteString)]
-> ST s (MutableImage s PixelYCbCr8)
progressiveUnpack (maxiW :: Int
maxiW, maxiH :: Int
maxiH) frame :: JpgFrameHeader
frame quants :: Vector (MacroBlock Int16)
quants lst :: [([(JpgUnpackerParameter, a)], ByteString)]
lst = do
(unpackers :: Vector (Vector (JpgUnpackerParameter, Unpacker s))
unpackers, readers :: STVector s BoolState
readers) <- [([(JpgUnpackerParameter, a)], ByteString)]
-> ST
s
(Vector (Vector (JpgUnpackerParameter, Unpacker s)),
STVector s BoolState)
forall a s.
[([(JpgUnpackerParameter, a)], ByteString)]
-> ST
s
(Vector (Vector (JpgUnpackerParameter, Unpacker s)),
STVector s BoolState)
prepareUnpacker [([(JpgUnpackerParameter, a)], ByteString)]
lst
[ComponentData s]
allBlocks <- ((Int, JpgComponent) -> ST s (ComponentData s))
-> [(Int, JpgComponent)] -> ST s [ComponentData s]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, JpgComponent) -> ST s (ComponentData s)
forall s. (Int, JpgComponent) -> ST s (ComponentData s)
allocateWorkingBlocks ([(Int, JpgComponent)] -> ST s [ComponentData s])
-> ([JpgComponent] -> [(Int, JpgComponent)])
-> [JpgComponent]
-> ST s [ComponentData s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [JpgComponent] -> [(Int, JpgComponent)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] ([JpgComponent] -> ST s [ComponentData s])
-> [JpgComponent] -> ST s [ComponentData s]
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
frame
:: ST s [ComponentData s]
let scanCount :: Int
scanCount = [([(JpgUnpackerParameter, a)], ByteString)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([(JpgUnpackerParameter, a)], ByteString)]
lst
restartIntervalValue :: Int
restartIntervalValue = case [([(JpgUnpackerParameter, a)], ByteString)]
lst of
((p :: JpgUnpackerParameter
p,_):_,_): _ -> JpgUnpackerParameter -> Int
restartInterval JpgUnpackerParameter
p
_ -> -1
STVector s Int16
dcCoeffs <- Int -> Int16 -> ST s (MVector (PrimState (ST s)) Int16)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
MS.replicate Int
imgComponentCount 0
MVector s Int32
eobRuns <- Int -> Int32 -> ST s (MVector (PrimState (ST s)) Int32)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
MS.replicate ([([(JpgUnpackerParameter, a)], ByteString)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([(JpgUnpackerParameter, a)], ByteString)]
lst) 0
STVector s Int16
workBlock <- ST s (STVector s Int16)
forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
MVector s Int
writeIndices <- Int -> Int -> ST s (MVector (PrimState (ST s)) Int)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
MS.replicate Int
imgComponentCount (0 :: Int)
MVector s Int
restartIntervals <- Int -> Int -> ST s (MVector (PrimState (ST s)) Int)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
MS.replicate Int
scanCount Int
restartIntervalValue
let elementCount :: Int
elementCount = Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
imgComponentCount
MutableImage s PixelYCbCr8
img <- Int
-> Int
-> STVector s (PixelBaseComponent PixelYCbCr8)
-> MutableImage s PixelYCbCr8
forall s a.
Int -> Int -> STVector s (PixelBaseComponent a) -> MutableImage s a
MutableImage Int
imgWidth Int
imgHeight (MVector s Word8 -> MutableImage s PixelYCbCr8)
-> ST s (MVector s Word8) -> ST s (MutableImage s PixelYCbCr8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Word8 -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
MS.replicate Int
elementCount 128
let processRestartInterval :: ST s ()
processRestartInterval =
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [0 .. Int
scanCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \ix :: Int
ix -> do
Int
v <- MVector s Int
MVector (PrimState (ST s)) Int
restartIntervals MVector (PrimState (ST s)) Int -> Int -> ST s Int
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`MS.read` Int
ix
if Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then do
Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (MVector (PrimState (ST s)) Int16 -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> a -> m ()
MS.set STVector s Int16
MVector (PrimState (ST s)) Int16
dcCoeffs 0)
BoolState
reader <- STVector s BoolState
MVector (PrimState (ST s)) BoolState
readers MVector (PrimState (ST s)) BoolState -> Int -> ST s BoolState
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
`M.read` Int
ix
(_, updated :: BoolState
updated) <- BoolState -> BoolReader s Int32 -> ST s (Int32, BoolState)
forall s a. BoolState -> BoolReader s a -> ST s (a, BoolState)
runBoolReaderWith BoolState
reader (BoolReader s Int32 -> ST s (Int32, BoolState))
-> BoolReader s Int32 -> ST s (Int32, BoolState)
forall a b. (a -> b) -> a -> b
$
BoolReader s ()
forall s. BoolReader s ()
byteAlignJpg BoolReader s () -> BoolReader s Int32 -> BoolReader s Int32
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BoolReader s Int32
forall s. BoolReader s Int32
decodeRestartInterval
(STVector s BoolState
MVector (PrimState (ST s)) BoolState
readers MVector (PrimState (ST s)) BoolState -> Int -> BoolState -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` Int
ix) BoolState
updated
(MVector s Int32
MVector (PrimState (ST s)) Int32
eobRuns MVector (PrimState (ST s)) Int32 -> Int -> Int32 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`MS.unsafeWrite` Int
ix) 0
(MVector s Int
MVector (PrimState (ST s)) Int
restartIntervals MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`MS.unsafeWrite` Int
ix) (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int
restartIntervalValue Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
else
(MVector s Int
MVector (PrimState (ST s)) Int
restartIntervals MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`MS.unsafeWrite` Int
ix) (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
Int -> (Int -> ST s ()) -> ST s ()
forall (m :: * -> *). Monad m => Int -> (Int -> m ()) -> m ()
lineMap Int
imageMcuHeight ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \mmY :: Int
mmY -> do
[ComponentData s] -> (ComponentData s -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ComponentData s]
allBlocks ((ComponentData s -> ST s ()) -> ST s ())
-> (ComponentData s -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ (STVector s Int16 -> ST s ())
-> Vector (STVector s Int16) -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ (MVector (PrimState (ST s)) Int16 -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> a -> m ()
`MS.set` 0) (Vector (STVector s Int16) -> ST s ())
-> (ComponentData s -> Vector (STVector s Int16))
-> ComponentData s
-> ST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentData s -> Vector (STVector s Int16)
forall s. ComponentData s -> Vector (MutableMacroBlock s Int16)
componentBlocks
MVector (PrimState (ST s)) Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> a -> m ()
MS.set MVector s Int
MVector (PrimState (ST s)) Int
writeIndices 0
Int -> (Int -> ST s ()) -> ST s ()
forall (m :: * -> *). Monad m => Int -> (Int -> m ()) -> m ()
lineMap Int
imageMcuWidth ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \_mmx :: Int
_mmx -> do
ST s ()
processRestartInterval
Vector (Vector (JpgUnpackerParameter, Unpacker s))
-> (Vector (JpgUnpackerParameter, Unpacker s) -> ST s ())
-> ST s ()
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
V.forM_ Vector (Vector (JpgUnpackerParameter, Unpacker s))
unpackers ((Vector (JpgUnpackerParameter, Unpacker s) -> ST s ()) -> ST s ())
-> (Vector (JpgUnpackerParameter, Unpacker s) -> ST s ())
-> ST s ()
forall a b. (a -> b) -> a -> b
$ ((JpgUnpackerParameter, Unpacker s) -> ST s ())
-> Vector (JpgUnpackerParameter, Unpacker s) -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ (((JpgUnpackerParameter, Unpacker s) -> ST s ())
-> Vector (JpgUnpackerParameter, Unpacker s) -> ST s ())
-> ((JpgUnpackerParameter, Unpacker s) -> ST s ())
-> Vector (JpgUnpackerParameter, Unpacker s)
-> ST s ()
forall a b. (a -> b) -> a -> b
$ \(unpackParam :: JpgUnpackerParameter
unpackParam, unpacker :: Unpacker s
unpacker) -> do
BoolState
boolState <- STVector s BoolState
MVector (PrimState (ST s)) BoolState
readers MVector (PrimState (ST s)) BoolState -> Int -> ST s BoolState
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
`M.read` JpgUnpackerParameter -> Int
readerIndex JpgUnpackerParameter
unpackParam
Int32
eobrun <- MVector s Int32
MVector (PrimState (ST s)) Int32
eobRuns MVector (PrimState (ST s)) Int32 -> Int -> ST s Int32
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`MS.read` JpgUnpackerParameter -> Int
readerIndex JpgUnpackerParameter
unpackParam
let componentNumber :: Int
componentNumber = JpgUnpackerParameter -> Int
componentIndex JpgUnpackerParameter
unpackParam
Int
writeIndex <- MVector s Int
MVector (PrimState (ST s)) Int
writeIndices MVector (PrimState (ST s)) Int -> Int -> ST s Int
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`MS.read` Int
componentNumber
let componentData :: ComponentData s
componentData = [ComponentData s]
allBlocks [ComponentData s] -> Int -> ComponentData s
forall a. [a] -> Int -> a
!! Int
componentNumber
indexVector :: Vector Int
indexVector =
ComponentData s -> Vector (Vector Int)
forall s. ComponentData s -> Vector (Vector Int)
componentIndices ComponentData s
componentData Vector (Vector Int) -> Int -> Vector Int
forall a. Vector a -> Int -> a
! JpgUnpackerParameter -> Int
indiceVector JpgUnpackerParameter
unpackParam
maxIndexLength :: Int
maxIndexLength = Vector Int -> Int
forall a. Storable a => Vector a -> Int
VS.length Vector Int
indexVector
Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
writeIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ JpgUnpackerParameter -> Int
blockIndex JpgUnpackerParameter
unpackParam Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxIndexLength) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
let realIndex :: Int
realIndex = Vector Int
indexVector Vector Int -> Int -> Int
forall a. Storable a => Vector a -> Int -> a
VS.! (Int
writeIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ JpgUnpackerParameter -> Int
blockIndex JpgUnpackerParameter
unpackParam)
writeBlock :: STVector s Int16
writeBlock = ComponentData s -> Vector (STVector s Int16)
forall s. ComponentData s -> Vector (MutableMacroBlock s Int16)
componentBlocks ComponentData s
componentData Vector (STVector s Int16) -> Int -> STVector s Int16
forall a. Vector a -> Int -> a
! Int
realIndex
(eobrun' :: Int32
eobrun', state :: BoolState
state) <-
BoolState -> BoolReader s Int32 -> ST s (Int32, BoolState)
forall s a. BoolState -> BoolReader s a -> ST s (a, BoolState)
runBoolReaderWith BoolState
boolState (BoolReader s Int32 -> ST s (Int32, BoolState))
-> BoolReader s Int32 -> ST s (Int32, BoolState)
forall a b. (a -> b) -> a -> b
$
Unpacker s
unpacker JpgUnpackerParameter
unpackParam STVector s Int16
dcCoeffs STVector s Int16
writeBlock Int32
eobrun
(STVector s BoolState
MVector (PrimState (ST s)) BoolState
readers MVector (PrimState (ST s)) BoolState -> Int -> BoolState -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.write` JpgUnpackerParameter -> Int
readerIndex JpgUnpackerParameter
unpackParam) BoolState
state
(MVector s Int32
MVector (PrimState (ST s)) Int32
eobRuns MVector (PrimState (ST s)) Int32 -> Int -> Int32 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`MS.write` JpgUnpackerParameter -> Int
readerIndex JpgUnpackerParameter
unpackParam) Int32
eobrun'
[ComponentData s] -> (ComponentData s -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ComponentData s]
allBlocks ((ComponentData s -> ST s ()) -> ST s ())
-> (ComponentData s -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \comp :: ComponentData s
comp -> do
Int
writeIndex <- MVector s Int
MVector (PrimState (ST s)) Int
writeIndices MVector (PrimState (ST s)) Int -> Int -> ST s Int
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`MS.read` ComponentData s -> Int
forall s. ComponentData s -> Int
componentId ComponentData s
comp
let newIndex :: Int
newIndex = Int
writeIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ComponentData s -> Int
forall s. ComponentData s -> Int
componentBlockCount ComponentData s
comp
(MVector s Int
MVector (PrimState (ST s)) Int
writeIndices MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`MS.write` ComponentData s -> Int
forall s. ComponentData s -> Int
componentId ComponentData s
comp) Int
newIndex
[ComponentData s] -> (ComponentData s -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ComponentData s]
allBlocks ((ComponentData s -> ST s ()) -> ST s ())
-> (ComponentData s -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \compData :: ComponentData s
compData -> do
let compBlocks :: Vector (STVector s Int16)
compBlocks = ComponentData s -> Vector (STVector s Int16)
forall s. ComponentData s -> Vector (MutableMacroBlock s Int16)
componentBlocks ComponentData s
compData
cId :: Int
cId = ComponentData s -> Int
forall s. ComponentData s -> Int
componentId ComponentData s
compData
comp :: JpgComponent
comp = JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
frame [JpgComponent] -> Int -> JpgComponent
forall a. [a] -> Int -> a
!! Int
cId
quantId :: Int
quantId =
Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
quantizationTableDest JpgComponent
comp
table :: MacroBlock Int16
table = Vector (MacroBlock Int16)
quants Vector (MacroBlock Int16) -> Int -> MacroBlock Int16
forall a. Vector a -> Int -> a
! Int -> Int -> Int
forall a. Ord a => a -> a -> a
min 3 Int
quantId
compW :: Int
compW = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
horizontalSamplingFactor JpgComponent
comp
compH :: Int
compH = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
verticalSamplingFactor JpgComponent
comp
cw8 :: Int
cw8 = Int
maxiW Int -> Int -> Int
forall a. Num a => a -> a -> a
- Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (JpgComponent -> Word8
horizontalSamplingFactor JpgComponent
comp) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
ch8 :: Int
ch8 = Int
maxiH Int -> Int -> Int
forall a. Num a => a -> a -> a
- Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (JpgComponent -> Word8
verticalSamplingFactor JpgComponent
comp) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
Int -> Int -> (Int -> Int -> ST s ()) -> ST s ()
forall (m :: * -> *).
Monad m =>
Int -> Int -> (Int -> Int -> m ()) -> m ()
rasterMap (Int
imageMcuWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
compW) Int
compH ((Int -> Int -> ST s ()) -> ST s ())
-> (Int -> Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \rx :: Int
rx y :: Int
y -> do
let ry :: Int
ry = Int
mmY Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxiH Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y
block :: STVector s Int16
block = Vector (STVector s Int16)
compBlocks Vector (STVector s Int16) -> Int -> STVector s Int16
forall a. Vector a -> Int -> a
! (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imageMcuWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
compW Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rx)
STVector s Int16
transformed <- MacroBlock Int16
-> STVector s Int16 -> STVector s Int16 -> ST s (STVector s Int16)
forall s.
MacroBlock Int16
-> MutableMacroBlock s Int16
-> MutableMacroBlock s Int16
-> ST s (MutableMacroBlock s Int16)
decodeMacroBlock MacroBlock Int16
table STVector s Int16
workBlock STVector s Int16
block
Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> STVector s Int16
-> ST s ()
forall s.
Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpackMacroBlock Int
imgComponentCount
Int
cw8 Int
ch8 Int
cId (Int
rx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
cw8) Int
ry
MutableImage s PixelYCbCr8
img STVector s Int16
transformed
MutableImage s PixelYCbCr8 -> ST s (MutableImage s PixelYCbCr8)
forall (m :: * -> *) a. Monad m => a -> m a
return MutableImage s PixelYCbCr8
img
where imgComponentCount :: Int
imgComponentCount = [JpgComponent] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([JpgComponent] -> Int) -> [JpgComponent] -> Int
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
frame
imgWidth :: Int
imgWidth = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgWidth JpgFrameHeader
frame
imgHeight :: Int
imgHeight = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgHeight JpgFrameHeader
frame
imageBlockWidth :: Int
imageBlockWidth = Int -> Int
toBlockSize Int
imgWidth
imageBlockHeight :: Int
imageBlockHeight = Int -> Int
toBlockSize Int
imgHeight
imageMcuWidth :: Int
imageMcuWidth = (Int
imageBlockWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
maxiW Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
maxiW
imageMcuHeight :: Int
imageMcuHeight = (Int
imageBlockHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
maxiH Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
maxiH
allocateWorkingBlocks :: (Int, JpgComponent) -> ST s (ComponentData s)
allocateWorkingBlocks (ix :: Int
ix, comp :: JpgComponent
comp) = do
let blockCount :: Int
blockCount = Int
hSample Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
vSample Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imageMcuWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2
Vector (MutableMacroBlock s Int16)
blocks <- Int
-> ST s (MutableMacroBlock s Int16)
-> ST s (Vector (MutableMacroBlock s Int16))
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM Int
blockCount ST s (MutableMacroBlock s Int16)
forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
ComponentData s -> ST s (ComponentData s)
forall (m :: * -> *) a. Monad m => a -> m a
return $WComponentData :: forall s.
Vector (Vector Int)
-> Vector (MutableMacroBlock s Int16)
-> Int
-> Int
-> ComponentData s
ComponentData
{ componentBlocks :: Vector (MutableMacroBlock s Int16)
componentBlocks = Vector (MutableMacroBlock s Int16)
blocks
, componentIndices :: Vector (Vector Int)
componentIndices = JpgComponent -> Int -> Int -> Vector (Vector Int)
createMcuLineIndices JpgComponent
comp Int
imgWidth Int
imageMcuWidth
, componentBlockCount :: Int
componentBlockCount = Int
hSample Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
vSample
, componentId :: Int
componentId = Int
ix
}
where hSample :: Int
hSample = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
horizontalSamplingFactor JpgComponent
comp
vSample :: Int
vSample = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
verticalSamplingFactor JpgComponent
comp