{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fspec-constr-count=5 #-}
module Codec.Picture.Jpg( decodeJpeg
, decodeJpegWithMetadata
, encodeJpegAtQuality
, encodeJpegAtQualityWithMetadata
, encodeDirectJpegAtQualityWithMetadata
, encodeJpeg
, JpgEncodable
) where
#if !MIN_VERSION_base(4,8,0)
import Data.Foldable( foldMap )
import Data.Monoid( mempty )
import Control.Applicative( pure, (<$>) )
#endif
import Control.Applicative( (<|>) )
import Control.Arrow( (>>>) )
import Control.Monad( when, forM_ )
import Control.Monad.ST( ST, runST )
import Control.Monad.Trans( lift )
import Control.Monad.Trans.RWS.Strict( RWS, modify, tell, gets, execRWS )
import Data.Bits( (.|.), unsafeShiftL )
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
#endif
import Data.Int( Int16, Int32 )
import Data.Word(Word8, Word32)
import Data.Binary( Binary(..), encode )
import Data.STRef( newSTRef, writeSTRef, readSTRef )
import Data.Vector( (//) )
import Data.Vector.Unboxed( (!) )
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Storable.Mutable as M
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Codec.Picture.InternalHelper
import Codec.Picture.BitWriter
import Codec.Picture.Types
import Codec.Picture.Metadata( Metadatas
, SourceFormat( SourceJpeg )
, basicMetadata )
import Codec.Picture.Tiff.Internal.Types
import Codec.Picture.Tiff.Internal.Metadata
import Codec.Picture.Jpg.Internal.Types
import Codec.Picture.Jpg.Internal.Common
import Codec.Picture.Jpg.Internal.Progressive
import Codec.Picture.Jpg.Internal.DefaultTable
import Codec.Picture.Jpg.Internal.FastDct
import Codec.Picture.Jpg.Internal.Metadata
quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32
-> ST s (MutableMacroBlock s Int32)
quantize :: MacroBlock Int16
-> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32)
quantize table :: MacroBlock Int16
table block :: MutableMacroBlock s Int32
block = Int -> ST s (MutableMacroBlock s Int32)
update 0
where update :: Int -> ST s (MutableMacroBlock s Int32)
update 64 = MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return MutableMacroBlock s Int32
block
update idx :: Int
idx = do
Int32
val <- MutableMacroBlock s Int32
MVector (PrimState (ST s)) Int32
block MVector (PrimState (ST s)) Int32 -> Int -> ST s Int32
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
let q :: Int32
q = Int16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (MacroBlock Int16
table MacroBlock Int16 -> Int -> Int16
forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` Int
idx)
finalValue :: Int32
finalValue = (Int32
val Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ (Int32
q Int32 -> Int32 -> Int32
forall a. Integral a => a -> a -> a
`div` 2)) Int32 -> Int32 -> Int32
forall a. Integral a => a -> a -> a
`quot` Int32
q
(MutableMacroBlock s Int32
MVector (PrimState (ST s)) Int32
block MVector (PrimState (ST s)) Int32 -> Int -> Int32 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) Int32
finalValue
Int -> ST s (MutableMacroBlock s Int32)
update (Int -> ST s (MutableMacroBlock s Int32))
-> Int -> ST s (MutableMacroBlock s Int32)
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
powerOf :: Int32 -> Word32
powerOf :: Int32 -> Word32
powerOf 0 = 0
powerOf n :: Int32
n = Int32 -> Word32 -> Word32
limit 1 0
where val :: Int32
val = Int32 -> Int32
forall a. Num a => a -> a
abs Int32
n
limit :: Int32 -> Word32 -> Word32
limit range :: Int32
range i :: Word32
i | Int32
val Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
range = Word32
i
limit range :: Int32
range i :: Word32
i = Int32 -> Word32 -> Word32
limit (2 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
range) (Word32
i Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ 1)
encodeInt :: BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
{-# INLINE encodeInt #-}
encodeInt :: BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
encodeInt st :: BoolWriteStateRef s
st ssss :: Word32
ssss n :: Int32
n | Int32
n Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = BoolWriteStateRef s -> Word32 -> Int -> ST s ()
forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ssss)
encodeInt st :: BoolWriteStateRef s
st ssss :: Word32
ssss n :: Int32
n = BoolWriteStateRef s -> Word32 -> Int -> ST s ()
forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Word32) -> Int32 -> Word32
forall a b. (a -> b) -> a -> b
$ Int32
n Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- 1) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ssss)
acCoefficientsDecode :: HuffmanPackedTree -> MutableMacroBlock s Int16
-> BoolReader s (MutableMacroBlock s Int16)
acCoefficientsDecode :: HuffmanPackedTree
-> MutableMacroBlock s Int16
-> BoolReader s (MutableMacroBlock s Int16)
acCoefficientsDecode acTree :: HuffmanPackedTree
acTree mutableBlock :: MutableMacroBlock s Int16
mutableBlock = Int -> StateT BoolState (ST s) ()
parseAcCoefficient 1 StateT BoolState (ST s) ()
-> BoolReader s (MutableMacroBlock s Int16)
-> BoolReader s (MutableMacroBlock s Int16)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MutableMacroBlock s Int16
-> BoolReader s (MutableMacroBlock s Int16)
forall (m :: * -> *) a. Monad m => a -> m a
return MutableMacroBlock s Int16
mutableBlock
where parseAcCoefficient :: Int -> StateT BoolState (ST s) ()
parseAcCoefficient n :: Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 64 = () -> StateT BoolState (ST s) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = do
(Int, Int)
rrrrssss <- HuffmanPackedTree -> BoolReader s (Int, Int)
forall s. HuffmanPackedTree -> BoolReader s (Int, Int)
decodeRrrrSsss HuffmanPackedTree
acTree
case (Int, Int)
rrrrssss of
( 0, 0) -> () -> StateT BoolState (ST s) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(0xF, 0) -> Int -> StateT BoolState (ST s) ()
parseAcCoefficient (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 16)
(rrrr :: Int
rrrr, ssss :: Int
ssss) -> do
Int16
decoded <- Int32 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int16)
-> StateT BoolState (ST s) Int32 -> StateT BoolState (ST s) Int16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT BoolState (ST s) Int32
forall s. Int -> BoolReader s Int32
decodeInt Int
ssss
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
mutableBlock MVector (PrimState (ST s)) Int16 -> Int -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rrrr)) Int16
decoded
Int -> StateT BoolState (ST s) ()
parseAcCoefficient (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rrrr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
decompressMacroBlock :: HuffmanPackedTree
-> HuffmanPackedTree
-> MacroBlock Int16
-> MutableMacroBlock s Int16
-> DcCoefficient
-> BoolReader s (DcCoefficient, MutableMacroBlock s Int16)
decompressMacroBlock :: HuffmanPackedTree
-> HuffmanPackedTree
-> MacroBlock Int16
-> MutableMacroBlock s Int16
-> Int16
-> BoolReader s (Int16, MutableMacroBlock s Int16)
decompressMacroBlock dcTree :: HuffmanPackedTree
dcTree acTree :: HuffmanPackedTree
acTree quantizationTable :: MacroBlock Int16
quantizationTable zigzagBlock :: MutableMacroBlock s Int16
zigzagBlock previousDc :: Int16
previousDc = do
Int16
dcDeltaCoefficient <- HuffmanPackedTree -> BoolReader s Int16
forall s. HuffmanPackedTree -> BoolReader s Int16
dcCoefficientDecode HuffmanPackedTree
dcTree
MutableMacroBlock s Int16
block <- ST s (MutableMacroBlock s Int16)
-> StateT BoolState (ST s) (MutableMacroBlock s Int16)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ST s (MutableMacroBlock s Int16)
forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
let neoDcCoefficient :: Int16
neoDcCoefficient = Int16
previousDc Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
dcDeltaCoefficient
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 ()
`M.unsafeWrite` 0) Int16
neoDcCoefficient
MutableMacroBlock s Int16
fullBlock <- HuffmanPackedTree
-> MutableMacroBlock s Int16
-> StateT BoolState (ST s) (MutableMacroBlock s Int16)
forall s.
HuffmanPackedTree
-> MutableMacroBlock s Int16
-> BoolReader s (MutableMacroBlock s Int16)
acCoefficientsDecode HuffmanPackedTree
acTree MutableMacroBlock s Int16
block
MutableMacroBlock s Int16
decodedBlock <- ST s (MutableMacroBlock s Int16)
-> StateT BoolState (ST s) (MutableMacroBlock s Int16)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (MutableMacroBlock s Int16)
-> StateT BoolState (ST s) (MutableMacroBlock s Int16))
-> ST s (MutableMacroBlock s Int16)
-> StateT BoolState (ST s) (MutableMacroBlock s Int16)
forall a b. (a -> b) -> a -> b
$ MacroBlock Int16
-> MutableMacroBlock s Int16
-> MutableMacroBlock s Int16
-> ST s (MutableMacroBlock s Int16)
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
fullBlock
(Int16, MutableMacroBlock s Int16)
-> BoolReader s (Int16, MutableMacroBlock s Int16)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int16
neoDcCoefficient, MutableMacroBlock s Int16
decodedBlock)
pixelClamp :: Int16 -> Word8
pixelClamp :: Int16 -> Word8
pixelClamp n :: Int16
n = Int16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int16 -> Word8) -> (Int16 -> Int16) -> Int16 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Int16 -> Int16
forall a. Ord a => a -> a -> a
min 255 (Int16 -> Word8) -> Int16 -> Word8
forall a b. (a -> b) -> a -> b
$ Int16 -> Int16 -> Int16
forall a. Ord a => a -> a -> a
max 0 Int16
n
unpack444Y :: Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack444Y :: Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack444Y _ x :: Int
x y :: Int
y (MutableImage { mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent PixelYCbCr8)
img })
block :: MutableMacroBlock s Int16
block = Int -> Int -> Int -> ST s ()
blockVert Int
baseIdx 0 Int
zero
where zero :: Int
zero = 0 :: Int
baseIdx :: Int
baseIdx = Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth
blockVert :: Int -> Int -> Int -> ST s ()
blockVert _ _ j :: Int
j | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
forall a. Num a => a
dctBlockSize = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
blockVert writeIdx :: Int
writeIdx readingIdx :: Int
readingIdx j :: Int
j = Int -> Int -> Int -> ST s ()
blockHoriz Int
writeIdx Int
readingIdx Int
zero
where blockHoriz :: Int -> Int -> Int -> ST s ()
blockHoriz _ readIdx :: Int
readIdx i :: Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
forall a. Num a => a
dctBlockSize = Int -> Int -> Int -> ST s ()
blockVert (Int
writeIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
imgWidth) Int
readIdx (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
blockHoriz idx :: Int
idx readIdx :: Int
readIdx i :: Int
i = do
Word8
val <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` Int
readIdx)
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) Word8
val
Int -> Int -> Int -> ST s ()
blockHoriz (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
unpack444Ycbcr :: Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack444Ycbcr :: Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack444Ycbcr compIdx :: Int
compIdx x :: Int
x y :: Int
y
(MutableImage { mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent PixelYCbCr8)
img })
block :: MutableMacroBlock s Int16
block = Int -> Int -> Int -> ST s ()
blockVert Int
baseIdx 0 Int
zero
where zero :: Int
zero = 0 :: Int
baseIdx :: Int
baseIdx = (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth) Int -> Int -> Int
forall a. Num a => a -> a -> a
* 3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
compIdx
blockVert :: Int -> Int -> Int -> ST s ()
blockVert _ _ j :: Int
j | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
forall a. Num a => a
dctBlockSize = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
blockVert idx :: Int
idx readIdx :: Int
readIdx j :: Int
j = do
Word8
val0 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` Int
readIdx)
Word8
val1 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1))
Word8
val2 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2))
Word8
val3 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3))
Word8
val4 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4))
Word8
val5 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 5))
Word8
val6 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6))
Word8
val7 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 7))
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) Word8
val0
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3 )) Word8
val1
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2))) Word8
val2
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 3))) Word8
val3
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4))) Word8
val4
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 5))) Word8
val5
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 6))) Word8
val6
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 7))) Word8
val7
Int -> Int -> Int -> ST s ()
blockVert (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth) (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
forall a. Num a => a
dctBlockSize) (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
unpack421Ycbcr :: Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack421Ycbcr :: Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack421Ycbcr compIdx :: Int
compIdx x :: Int
x y :: Int
y
(MutableImage { mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth,
mutableImageHeight :: forall s a. MutableImage s a -> Int
mutableImageHeight = Int
_, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent PixelYCbCr8)
img })
block :: MutableMacroBlock s Int16
block = Int -> Int -> Int -> ST s ()
blockVert Int
baseIdx 0 Int
zero
where zero :: Int
zero = 0 :: Int
baseIdx :: Int
baseIdx = (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth) Int -> Int -> Int
forall a. Num a => a -> a -> a
* 3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
compIdx
lineOffset :: Int
lineOffset = Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* 3
blockVert :: Int -> Int -> Int -> ST s ()
blockVert _ _ j :: Int
j | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
forall a. Num a => a
dctBlockSize = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
blockVert idx :: Int
idx readIdx :: Int
readIdx j :: Int
j = do
Word8
v0 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` Int
readIdx)
Word8
v1 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1))
Word8
v2 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2))
Word8
v3 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3))
Word8
v4 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4))
Word8
v5 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 5))
Word8
v6 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6))
Word8
v7 <- Int16 -> Word8
pixelClamp (Int16 -> Word8) -> ST s Int16 -> ST s Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
`M.unsafeRead` (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 7))
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) Word8
v0
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3)) Word8
v0
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 )) Word8
v1
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3)) Word8
v1
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2)) Word8
v2
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3)) Word8
v2
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 3)) Word8
v3
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3)) Word8
v3
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4)) Word8
v4
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3)) Word8
v4
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 5)) Word8
v5
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3)) Word8
v5
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 6)) Word8
v6
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3)) Word8
v6
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 7)) Word8
v7
(STVector s (PixelBaseComponent PixelYCbCr8)
MVector (PrimState (ST s)) Word8
img MVector (PrimState (ST s)) Word8 -> Int -> Word8 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 7 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3)) Word8
v7
Int -> Int -> Int -> ST s ()
blockVert (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lineOffset) (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
forall a. Num a => a
dctBlockSize) (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
type Unpacker s = Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
type JpgScripter s a =
RWS () [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)] JpgDecoderState a
data JpgDecoderState = JpgDecoderState
{ JpgDecoderState -> Vector HuffmanPackedTree
dcDecoderTables :: !(V.Vector HuffmanPackedTree)
, JpgDecoderState -> Vector HuffmanPackedTree
acDecoderTables :: !(V.Vector HuffmanPackedTree)
, JpgDecoderState -> Vector (MacroBlock Int16)
quantizationMatrices :: !(V.Vector (MacroBlock Int16))
, JpgDecoderState -> Int
currentRestartInterv :: !Int
, JpgDecoderState -> Maybe JpgFrameHeader
currentFrame :: Maybe JpgFrameHeader
, JpgDecoderState -> Maybe JpgAdobeApp14
app14Marker :: !(Maybe JpgAdobeApp14)
, JpgDecoderState -> Maybe JpgJFIFApp0
app0JFifMarker :: !(Maybe JpgJFIFApp0)
, JpgDecoderState -> Maybe [ImageFileDirectory]
app1ExifMarker :: !(Maybe [ImageFileDirectory])
, JpgDecoderState -> [(Word8, Int)]
componentIndexMapping :: ![(Word8, Int)]
, JpgDecoderState -> Bool
isProgressive :: !Bool
, JpgDecoderState -> Int
maximumHorizontalResolution :: !Int
, JpgDecoderState -> Int
maximumVerticalResolution :: !Int
, JpgDecoderState -> Int
seenBlobs :: !Int
}
emptyDecoderState :: JpgDecoderState
emptyDecoderState :: JpgDecoderState
emptyDecoderState = $WJpgDecoderState :: Vector HuffmanPackedTree
-> Vector HuffmanPackedTree
-> Vector (MacroBlock Int16)
-> Int
-> Maybe JpgFrameHeader
-> Maybe JpgAdobeApp14
-> Maybe JpgJFIFApp0
-> Maybe [ImageFileDirectory]
-> [(Word8, Int)]
-> Bool
-> Int
-> Int
-> Int
-> JpgDecoderState
JpgDecoderState
{ dcDecoderTables :: Vector HuffmanPackedTree
dcDecoderTables =
let (_, dcLuma :: HuffmanPackedTree
dcLuma) = DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent 0 HuffmanTable
defaultDcLumaHuffmanTable
(_, dcChroma :: HuffmanPackedTree
dcChroma) = DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent 1 HuffmanTable
defaultDcChromaHuffmanTable
in
[HuffmanPackedTree] -> Vector HuffmanPackedTree
forall a. [a] -> Vector a
V.fromList [ HuffmanPackedTree
dcLuma, HuffmanPackedTree
dcChroma, HuffmanPackedTree
dcLuma, HuffmanPackedTree
dcChroma ]
, acDecoderTables :: Vector HuffmanPackedTree
acDecoderTables =
let (_, acLuma :: HuffmanPackedTree
acLuma) = DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent 0 HuffmanTable
defaultAcLumaHuffmanTable
(_, acChroma :: HuffmanPackedTree
acChroma) = DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent 1 HuffmanTable
defaultAcChromaHuffmanTable
in
[HuffmanPackedTree] -> Vector HuffmanPackedTree
forall a. [a] -> Vector a
V.fromList [HuffmanPackedTree
acLuma, HuffmanPackedTree
acChroma, HuffmanPackedTree
acLuma, HuffmanPackedTree
acChroma]
, quantizationMatrices :: Vector (MacroBlock Int16)
quantizationMatrices = Int -> MacroBlock Int16 -> Vector (MacroBlock Int16)
forall a. Int -> a -> Vector a
V.replicate 4 (Int -> Int16 -> MacroBlock Int16
forall a. Storable a => Int -> a -> Vector a
VS.replicate (8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 8) 1)
, currentRestartInterv :: Int
currentRestartInterv = -1
, currentFrame :: Maybe JpgFrameHeader
currentFrame = Maybe JpgFrameHeader
forall a. Maybe a
Nothing
, componentIndexMapping :: [(Word8, Int)]
componentIndexMapping = []
, app14Marker :: Maybe JpgAdobeApp14
app14Marker = Maybe JpgAdobeApp14
forall a. Maybe a
Nothing
, app0JFifMarker :: Maybe JpgJFIFApp0
app0JFifMarker = Maybe JpgJFIFApp0
forall a. Maybe a
Nothing
, app1ExifMarker :: Maybe [ImageFileDirectory]
app1ExifMarker = Maybe [ImageFileDirectory]
forall a. Maybe a
Nothing
, isProgressive :: Bool
isProgressive = Bool
False
, maximumHorizontalResolution :: Int
maximumHorizontalResolution = 0
, maximumVerticalResolution :: Int
maximumVerticalResolution = 0
, seenBlobs :: Int
seenBlobs = 0
}
jpgMachineStep :: JpgFrame -> JpgScripter s ()
jpgMachineStep :: JpgFrame -> JpgScripter s ()
jpgMachineStep (JpgAdobeAPP14 app14 :: JpgAdobeApp14
app14) = (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((JpgDecoderState -> JpgDecoderState) -> JpgScripter s ())
-> (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall a b. (a -> b) -> a -> b
$ \s :: JpgDecoderState
s ->
JpgDecoderState
s { app14Marker :: Maybe JpgAdobeApp14
app14Marker = JpgAdobeApp14 -> Maybe JpgAdobeApp14
forall a. a -> Maybe a
Just JpgAdobeApp14
app14 }
jpgMachineStep (JpgExif exif :: [ImageFileDirectory]
exif) = (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((JpgDecoderState -> JpgDecoderState) -> JpgScripter s ())
-> (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall a b. (a -> b) -> a -> b
$ \s :: JpgDecoderState
s ->
JpgDecoderState
s { app1ExifMarker :: Maybe [ImageFileDirectory]
app1ExifMarker = [ImageFileDirectory] -> Maybe [ImageFileDirectory]
forall a. a -> Maybe a
Just [ImageFileDirectory]
exif }
jpgMachineStep (JpgJFIF app0 :: JpgJFIFApp0
app0) = (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((JpgDecoderState -> JpgDecoderState) -> JpgScripter s ())
-> (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall a b. (a -> b) -> a -> b
$ \s :: JpgDecoderState
s ->
JpgDecoderState
s { app0JFifMarker :: Maybe JpgJFIFApp0
app0JFifMarker = JpgJFIFApp0 -> Maybe JpgJFIFApp0
forall a. a -> Maybe a
Just JpgJFIFApp0
app0 }
jpgMachineStep (JpgAppFrame _ _) = () -> JpgScripter s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
jpgMachineStep (JpgExtension _ _) = () -> JpgScripter s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
jpgMachineStep (JpgScanBlob hdr :: JpgScanHeader
hdr raw_data :: ByteString
raw_data) = do
let scanCount :: Int
scanCount = [JpgScanSpecification] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([JpgScanSpecification] -> Int) -> [JpgScanSpecification] -> Int
forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> [JpgScanSpecification]
scans JpgScanHeader
hdr
[(JpgUnpackerParameter, Unpacker s)]
params <- [[(JpgUnpackerParameter, Unpacker s)]]
-> [(JpgUnpackerParameter, Unpacker s)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(JpgUnpackerParameter, Unpacker s)]]
-> [(JpgUnpackerParameter, Unpacker s)])
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
[[(JpgUnpackerParameter, Unpacker s)]]
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
[(JpgUnpackerParameter, Unpacker s)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JpgScanSpecification
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
[(JpgUnpackerParameter, Unpacker s)])
-> [JpgScanSpecification]
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
[[(JpgUnpackerParameter, Unpacker s)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int
-> JpgScanSpecification
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
[(JpgUnpackerParameter, Unpacker s)]
scanSpecifier Int
scanCount) (JpgScanHeader -> [JpgScanSpecification]
scans JpgScanHeader
hdr)
(JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((JpgDecoderState -> JpgDecoderState) -> JpgScripter s ())
-> (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall a b. (a -> b) -> a -> b
$ \st :: JpgDecoderState
st -> JpgDecoderState
st { seenBlobs :: Int
seenBlobs = JpgDecoderState -> Int
seenBlobs JpgDecoderState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 }
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
-> JpgScripter s ()
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
tell [([(JpgUnpackerParameter, Unpacker s)]
params, ByteString
raw_data) ]
where (selectionLow :: Word8
selectionLow, selectionHigh :: Word8
selectionHigh) = JpgScanHeader -> (Word8, Word8)
spectralSelection JpgScanHeader
hdr
approxHigh :: Int
approxHigh = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> Word8
successiveApproxHigh JpgScanHeader
hdr
approxLow :: Int
approxLow = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> Word8
successiveApproxLow JpgScanHeader
hdr
scanSpecifier :: Int
-> JpgScanSpecification
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
[(JpgUnpackerParameter, Unpacker s)]
scanSpecifier scanCount :: Int
scanCount scanSpec :: JpgScanSpecification
scanSpec = do
[(Word8, Int)]
compMapping <- (JpgDecoderState -> [(Word8, Int)])
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
[(Word8, Int)]
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets JpgDecoderState -> [(Word8, Int)]
componentIndexMapping
Int
comp <- case Word8 -> [(Word8, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (JpgScanSpecification -> Word8
componentSelector JpgScanSpecification
scanSpec) [(Word8, Int)]
compMapping of
Nothing -> [Char]
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
Int
forall a. HasCallStack => [Char] -> a
error "Jpg decoding error - bad component selector in blob."
Just v :: Int
v -> Int
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
v
let maximumHuffmanTable :: Int
maximumHuffmanTable = 4
dcIndex :: Int
dcIndex = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
maximumHuffmanTable Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
(Int -> Int) -> (Word8 -> Int) -> Word8 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgScanSpecification -> Word8
dcEntropyCodingTable JpgScanSpecification
scanSpec
acIndex :: Int
acIndex = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
maximumHuffmanTable Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
(Int -> Int) -> (Word8 -> Int) -> Word8 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgScanSpecification -> Word8
acEntropyCodingTable JpgScanSpecification
scanSpec
HuffmanPackedTree
dcTree <- (JpgDecoderState -> HuffmanPackedTree)
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
HuffmanPackedTree
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets ((JpgDecoderState -> HuffmanPackedTree)
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
HuffmanPackedTree)
-> (JpgDecoderState -> HuffmanPackedTree)
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
HuffmanPackedTree
forall a b. (a -> b) -> a -> b
$ (Vector HuffmanPackedTree -> Int -> HuffmanPackedTree
forall a. Vector a -> Int -> a
V.! Int
dcIndex) (Vector HuffmanPackedTree -> HuffmanPackedTree)
-> (JpgDecoderState -> Vector HuffmanPackedTree)
-> JpgDecoderState
-> HuffmanPackedTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JpgDecoderState -> Vector HuffmanPackedTree
dcDecoderTables
HuffmanPackedTree
acTree <- (JpgDecoderState -> HuffmanPackedTree)
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
HuffmanPackedTree
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets ((JpgDecoderState -> HuffmanPackedTree)
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
HuffmanPackedTree)
-> (JpgDecoderState -> HuffmanPackedTree)
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
HuffmanPackedTree
forall a b. (a -> b) -> a -> b
$ (Vector HuffmanPackedTree -> Int -> HuffmanPackedTree
forall a. Vector a -> Int -> a
V.! Int
acIndex) (Vector HuffmanPackedTree -> HuffmanPackedTree)
-> (JpgDecoderState -> Vector HuffmanPackedTree)
-> JpgDecoderState
-> HuffmanPackedTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JpgDecoderState -> Vector HuffmanPackedTree
acDecoderTables
Bool
isProgressiveImage <- (JpgDecoderState -> Bool)
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
Bool
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets JpgDecoderState -> Bool
isProgressive
Int
maxiW <- (JpgDecoderState -> Int)
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
Int
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets JpgDecoderState -> Int
maximumHorizontalResolution
Int
maxiH <- (JpgDecoderState -> Int)
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
Int
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets JpgDecoderState -> Int
maximumVerticalResolution
Int
restart <- (JpgDecoderState -> Int)
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
Int
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets JpgDecoderState -> Int
currentRestartInterv
Maybe JpgFrameHeader
frameInfo <- (JpgDecoderState -> Maybe JpgFrameHeader)
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
(Maybe JpgFrameHeader)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets JpgDecoderState -> Maybe JpgFrameHeader
currentFrame
Int
blobId <- (JpgDecoderState -> Int)
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
Int
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets JpgDecoderState -> Int
seenBlobs
case Maybe JpgFrameHeader
frameInfo of
Nothing -> [Char]
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
[(JpgUnpackerParameter, Unpacker s)]
forall a. HasCallStack => [Char] -> a
error "Jpg decoding error - no previous frame"
Just v :: JpgFrameHeader
v -> do
let compDesc :: JpgComponent
compDesc = JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
v [JpgComponent] -> Int -> JpgComponent
forall a. [a] -> Int -> a
!! Int
comp
compCount :: Int
compCount = [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
v
xSampling :: Int
xSampling = 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
compDesc
ySampling :: Int
ySampling = 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
compDesc
componentSubSampling :: (Int, Int)
componentSubSampling =
(Int
maxiW Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xSampling Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Int
maxiH Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ySampling Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
(xCount :: Int
xCount, yCount :: Int
yCount)
| Int
scanCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
|| Bool
isProgressiveImage = (Int
xSampling, Int
ySampling)
| Bool
otherwise = (1, 1)
[(JpgUnpackerParameter, Unpacker s)]
-> RWST
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
Identity
[(JpgUnpackerParameter, Unpacker s)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ ($WJpgUnpackerParameter :: HuffmanPackedTree
-> HuffmanPackedTree
-> Int
-> Int
-> Int
-> Int
-> (Int, Int)
-> (Int, Int)
-> (Int, Int)
-> Int
-> Int
-> Int
-> Int
-> Int
-> JpgUnpackerParameter
JpgUnpackerParameter
{ dcHuffmanTree :: HuffmanPackedTree
dcHuffmanTree = HuffmanPackedTree
dcTree
, acHuffmanTree :: HuffmanPackedTree
acHuffmanTree = HuffmanPackedTree
acTree
, componentIndex :: Int
componentIndex = Int
comp
, restartInterval :: Int
restartInterval = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
restart
, componentWidth :: Int
componentWidth = Int
xSampling
, componentHeight :: Int
componentHeight = Int
ySampling
, subSampling :: (Int, Int)
subSampling = (Int, Int)
componentSubSampling
, successiveApprox :: (Int, Int)
successiveApprox = (Int
approxLow, Int
approxHigh)
, readerIndex :: Int
readerIndex = Int
blobId
, indiceVector :: Int
indiceVector =
if Int
scanCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 then 0 else 1
, coefficientRange :: (Int, Int)
coefficientRange =
( Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
selectionLow
, Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
selectionHigh )
, blockIndex :: Int
blockIndex = Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
xSampling Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x
, blockMcuX :: Int
blockMcuX = Int
x
, blockMcuY :: Int
blockMcuY = Int
y
}, Int -> (Int, Int) -> Unpacker s
forall s. Int -> (Int, Int) -> Unpacker s
unpackerDecision Int
compCount (Int, Int)
componentSubSampling)
| Int
y <- [0 .. Int
yCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]
, Int
x <- [0 .. Int
xCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ]
jpgMachineStep (JpgScans kind :: JpgFrameKind
kind hdr :: JpgFrameHeader
hdr) = (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((JpgDecoderState -> JpgDecoderState) -> JpgScripter s ())
-> (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall a b. (a -> b) -> a -> b
$ \s :: JpgDecoderState
s ->
JpgDecoderState
s { currentFrame :: Maybe JpgFrameHeader
currentFrame = JpgFrameHeader -> Maybe JpgFrameHeader
forall a. a -> Maybe a
Just JpgFrameHeader
hdr
, componentIndexMapping :: [(Word8, Int)]
componentIndexMapping =
[(JpgComponent -> Word8
componentIdentifier JpgComponent
comp, Int
ix) | (ix :: Int
ix, comp :: JpgComponent
comp) <- [Int] -> [JpgComponent] -> [(Int, JpgComponent)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] ([JpgComponent] -> [(Int, JpgComponent)])
-> [JpgComponent] -> [(Int, JpgComponent)]
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
hdr]
, isProgressive :: Bool
isProgressive = case JpgFrameKind
kind of
JpgProgressiveDCTHuffman -> Bool
True
_ -> Bool
False
, maximumHorizontalResolution :: Int
maximumHorizontalResolution =
Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ [Word8] -> Word8
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Word8]
horizontalResolutions
, maximumVerticalResolution :: Int
maximumVerticalResolution =
Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ [Word8] -> Word8
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Word8]
verticalResolutions
}
where components :: [JpgComponent]
components = JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
hdr
horizontalResolutions :: [Word8]
horizontalResolutions = (JpgComponent -> Word8) -> [JpgComponent] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map JpgComponent -> Word8
horizontalSamplingFactor [JpgComponent]
components
verticalResolutions :: [Word8]
verticalResolutions = (JpgComponent -> Word8) -> [JpgComponent] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map JpgComponent -> Word8
verticalSamplingFactor [JpgComponent]
components
jpgMachineStep (JpgIntervalRestart restart :: Word16
restart) =
(JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((JpgDecoderState -> JpgDecoderState) -> JpgScripter s ())
-> (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall a b. (a -> b) -> a -> b
$ \s :: JpgDecoderState
s -> JpgDecoderState
s { currentRestartInterv :: Int
currentRestartInterv = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
restart }
jpgMachineStep (JpgHuffmanTable tables :: [(JpgHuffmanTableSpec, HuffmanPackedTree)]
tables) = ((JpgHuffmanTableSpec, HuffmanPackedTree) -> JpgScripter s ())
-> [(JpgHuffmanTableSpec, HuffmanPackedTree)] -> JpgScripter s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (JpgHuffmanTableSpec, HuffmanPackedTree) -> JpgScripter s ()
forall w (m :: * -> *) r.
(Monoid w, Monad m) =>
(JpgHuffmanTableSpec, HuffmanPackedTree)
-> RWST r w JpgDecoderState m ()
placeHuffmanTrees [(JpgHuffmanTableSpec, HuffmanPackedTree)]
tables
where placeHuffmanTrees :: (JpgHuffmanTableSpec, HuffmanPackedTree)
-> RWST r w JpgDecoderState m ()
placeHuffmanTrees (spec :: JpgHuffmanTableSpec
spec, tree :: HuffmanPackedTree
tree) = case JpgHuffmanTableSpec -> DctComponent
huffmanTableClass JpgHuffmanTableSpec
spec of
DcComponent -> (JpgDecoderState -> JpgDecoderState)
-> RWST r w JpgDecoderState m ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((JpgDecoderState -> JpgDecoderState)
-> RWST r w JpgDecoderState m ())
-> (JpgDecoderState -> JpgDecoderState)
-> RWST r w JpgDecoderState m ()
forall a b. (a -> b) -> a -> b
$ \s :: JpgDecoderState
s ->
if Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Vector HuffmanPackedTree -> Int
forall a. Vector a -> Int
V.length (JpgDecoderState -> Vector HuffmanPackedTree
dcDecoderTables JpgDecoderState
s) then JpgDecoderState
s
else
let neu :: Vector HuffmanPackedTree
neu = JpgDecoderState -> Vector HuffmanPackedTree
dcDecoderTables JpgDecoderState
s Vector HuffmanPackedTree
-> [(Int, HuffmanPackedTree)] -> Vector HuffmanPackedTree
forall a. Vector a -> [(Int, a)] -> Vector a
// [(Int
idx, HuffmanPackedTree
tree)] in
JpgDecoderState
s { dcDecoderTables :: Vector HuffmanPackedTree
dcDecoderTables = Vector HuffmanPackedTree
neu }
where idx :: Int
idx = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Word8
huffmanTableDest JpgHuffmanTableSpec
spec
AcComponent -> (JpgDecoderState -> JpgDecoderState)
-> RWST r w JpgDecoderState m ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((JpgDecoderState -> JpgDecoderState)
-> RWST r w JpgDecoderState m ())
-> (JpgDecoderState -> JpgDecoderState)
-> RWST r w JpgDecoderState m ()
forall a b. (a -> b) -> a -> b
$ \s :: JpgDecoderState
s ->
if Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Vector HuffmanPackedTree -> Int
forall a. Vector a -> Int
V.length (JpgDecoderState -> Vector HuffmanPackedTree
acDecoderTables JpgDecoderState
s) then JpgDecoderState
s
else
JpgDecoderState
s { acDecoderTables :: Vector HuffmanPackedTree
acDecoderTables = JpgDecoderState -> Vector HuffmanPackedTree
acDecoderTables JpgDecoderState
s Vector HuffmanPackedTree
-> [(Int, HuffmanPackedTree)] -> Vector HuffmanPackedTree
forall a. Vector a -> [(Int, a)] -> Vector a
// [(Int
idx, HuffmanPackedTree
tree)] }
where idx :: Int
idx = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Word8
huffmanTableDest JpgHuffmanTableSpec
spec
jpgMachineStep (JpgQuantTable tables :: [JpgQuantTableSpec]
tables) = (JpgQuantTableSpec -> JpgScripter s ())
-> [JpgQuantTableSpec] -> JpgScripter s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JpgQuantTableSpec -> JpgScripter s ()
forall w (m :: * -> *) r.
(Monoid w, Monad m) =>
JpgQuantTableSpec -> RWST r w JpgDecoderState m ()
placeQuantizationTables [JpgQuantTableSpec]
tables
where placeQuantizationTables :: JpgQuantTableSpec -> RWST r w JpgDecoderState m ()
placeQuantizationTables table :: JpgQuantTableSpec
table = do
let idx :: Int
idx = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ JpgQuantTableSpec -> Word8
quantDestination JpgQuantTableSpec
table
tableData :: MacroBlock Int16
tableData = JpgQuantTableSpec -> MacroBlock Int16
quantTable JpgQuantTableSpec
table
(JpgDecoderState -> JpgDecoderState)
-> RWST r w JpgDecoderState m ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((JpgDecoderState -> JpgDecoderState)
-> RWST r w JpgDecoderState m ())
-> (JpgDecoderState -> JpgDecoderState)
-> RWST r w JpgDecoderState m ()
forall a b. (a -> b) -> a -> b
$ \s :: JpgDecoderState
s ->
JpgDecoderState
s { quantizationMatrices :: Vector (MacroBlock Int16)
quantizationMatrices = JpgDecoderState -> Vector (MacroBlock Int16)
quantizationMatrices JpgDecoderState
s Vector (MacroBlock Int16)
-> [(Int, MacroBlock Int16)] -> Vector (MacroBlock Int16)
forall a. Vector a -> [(Int, a)] -> Vector a
// [(Int
idx, MacroBlock Int16
tableData)] }
unpackerDecision :: Int -> (Int, Int) -> Unpacker s
unpackerDecision :: Int -> (Int, Int) -> Unpacker s
unpackerDecision 1 (1, 1) = Unpacker s
forall s.
Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack444Y
unpackerDecision 3 (1, 1) = Unpacker s
forall s.
Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack444Ycbcr
unpackerDecision _ (2, 1) = Unpacker s
forall s.
Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack421Ycbcr
unpackerDecision compCount :: Int
compCount (xScalingFactor :: Int
xScalingFactor, yScalingFactor :: Int
yScalingFactor) =
Int -> Int -> Int -> Unpacker s
forall s.
Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpackMacroBlock Int
compCount Int
xScalingFactor Int
yScalingFactor
decodeImage :: JpgFrameHeader
-> V.Vector (MacroBlock Int16)
-> [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)]
-> MutableImage s PixelYCbCr8
-> ST s (MutableImage s PixelYCbCr8)
decodeImage :: JpgFrameHeader
-> Vector (MacroBlock Int16)
-> [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
-> MutableImage s PixelYCbCr8
-> ST s (MutableImage s PixelYCbCr8)
decodeImage frame :: JpgFrameHeader
frame quants :: Vector (MacroBlock Int16)
quants lst :: [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
lst outImage :: MutableImage s PixelYCbCr8
outImage = do
let compCount :: Int
compCount = [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
MutableMacroBlock s Int16
zigZagArray <- ST s (MutableMacroBlock s Int16)
forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
MutableMacroBlock s Int16
dcArray <- Int -> Int16 -> ST s (MVector (PrimState (ST s)) Int16)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate Int
compCount 0 :: ST s (M.STVector s DcCoefficient)
STRef s Int
resetCounter <- Int -> ST s (STRef s Int)
forall a s. a -> ST s (STRef s a)
newSTRef Int
restartIntervalValue
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
-> (([(JpgUnpackerParameter, Unpacker s)], ByteString)
-> ST s BoolState)
-> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
lst ((([(JpgUnpackerParameter, Unpacker s)], ByteString)
-> ST s BoolState)
-> ST s ())
-> (([(JpgUnpackerParameter, Unpacker s)], ByteString)
-> ST s BoolState)
-> ST s ()
forall a b. (a -> b) -> a -> b
$ \(params :: [(JpgUnpackerParameter, Unpacker s)]
params, str :: ByteString
str) -> do
let componentsInfo :: Vector (JpgUnpackerParameter, Unpacker s)
componentsInfo = [(JpgUnpackerParameter, Unpacker s)]
-> Vector (JpgUnpackerParameter, Unpacker s)
forall a. [a] -> Vector a
V.fromList [(JpgUnpackerParameter, Unpacker s)]
params
compReader :: BoolState
compReader = 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
str
maxiW :: Int
maxiW = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [(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)
subSampling JpgUnpackerParameter
c | (c :: JpgUnpackerParameter
c,_) <- [(JpgUnpackerParameter, Unpacker s)]
params]
maxiH :: Int
maxiH = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [(Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ JpgUnpackerParameter -> (Int, Int)
subSampling JpgUnpackerParameter
c | (c :: JpgUnpackerParameter
c,_) <- [(JpgUnpackerParameter, Unpacker s)]
params]
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
BoolState -> BoolReader s () -> ST s BoolState
forall s a. BoolState -> BoolReader s a -> ST s BoolState
execBoolReader BoolState
compReader (BoolReader s () -> ST s BoolState)
-> BoolReader s () -> ST s BoolState
forall a b. (a -> b) -> a -> b
$ Int -> Int -> (Int -> Int -> BoolReader s ()) -> BoolReader s ()
forall (m :: * -> *).
Monad m =>
Int -> Int -> (Int -> Int -> m ()) -> m ()
rasterMap Int
imageMcuWidth Int
imageMcuHeight ((Int -> Int -> BoolReader s ()) -> BoolReader s ())
-> (Int -> Int -> BoolReader s ()) -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ \x :: Int
x y :: Int
y -> do
Int
resetLeft <- ST s Int -> StateT BoolState (ST s) Int
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s Int -> StateT BoolState (ST s) Int)
-> ST s Int -> StateT BoolState (ST s) Int
forall a b. (a -> b) -> a -> b
$ STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
resetCounter
if Int
resetLeft Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then do
ST s () -> BoolReader s ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> BoolReader s ()) -> ST s () -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ MVector (PrimState (ST s)) Int16 -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> a -> m ()
M.set MutableMacroBlock s Int16
MVector (PrimState (ST s)) Int16
dcArray 0
BoolReader s ()
forall s. BoolReader s ()
byteAlignJpg
Int32
_restartCode <- BoolReader s Int32
forall s. BoolReader s Int32
decodeRestartInterval
ST s () -> BoolReader s ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> BoolReader s ()) -> ST s () -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ STRef s Int
resetCounter STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
`writeSTRef` (Int
restartIntervalValue Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
else
ST s () -> BoolReader s ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> BoolReader s ()) -> ST s () -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ STRef s Int
resetCounter STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
`writeSTRef` (Int
resetLeft Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
Vector (JpgUnpackerParameter, Unpacker s)
-> ((JpgUnpackerParameter, Unpacker s) -> BoolReader s ())
-> BoolReader s ()
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
V.forM_ Vector (JpgUnpackerParameter, Unpacker s)
componentsInfo (((JpgUnpackerParameter, Unpacker s) -> BoolReader s ())
-> BoolReader s ())
-> ((JpgUnpackerParameter, Unpacker s) -> BoolReader s ())
-> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ \(comp :: JpgUnpackerParameter
comp, unpack :: Unpacker s
unpack) -> do
let compIdx :: Int
compIdx = JpgUnpackerParameter -> Int
componentIndex JpgUnpackerParameter
comp
dcTree :: HuffmanPackedTree
dcTree = JpgUnpackerParameter -> HuffmanPackedTree
dcHuffmanTree JpgUnpackerParameter
comp
acTree :: HuffmanPackedTree
acTree = JpgUnpackerParameter -> HuffmanPackedTree
acHuffmanTree JpgUnpackerParameter
comp
quantId :: Int
quantId = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> (JpgComponent -> Word8) -> JpgComponent -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JpgComponent -> Word8
quantizationTableDest
(JpgComponent -> Int) -> JpgComponent -> Int
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
frame [JpgComponent] -> Int -> JpgComponent
forall a. [a] -> Int -> a
!! Int
compIdx
qTable :: MacroBlock Int16
qTable = Vector (MacroBlock Int16)
quants Vector (MacroBlock Int16) -> Int -> MacroBlock Int16
forall a. Vector a -> Int -> a
V.! Int -> Int -> Int
forall a. Ord a => a -> a -> a
min 3 Int
quantId
xd :: Int
xd = JpgUnpackerParameter -> Int
blockMcuX JpgUnpackerParameter
comp
yd :: Int
yd = JpgUnpackerParameter -> Int
blockMcuY JpgUnpackerParameter
comp
(subX :: Int
subX, subY :: Int
subY) = JpgUnpackerParameter -> (Int, Int)
subSampling JpgUnpackerParameter
comp
Int16
dc <- 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
dcArray MVector (PrimState (ST s)) Int16 -> Int -> ST s Int16
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
compIdx
(dcCoeff :: Int16
dcCoeff, block :: MutableMacroBlock s Int16
block) <-
HuffmanPackedTree
-> HuffmanPackedTree
-> MacroBlock Int16
-> MutableMacroBlock s Int16
-> Int16
-> BoolReader s (Int16, MutableMacroBlock s Int16)
forall s.
HuffmanPackedTree
-> HuffmanPackedTree
-> MacroBlock Int16
-> MutableMacroBlock s Int16
-> Int16
-> BoolReader s (Int16, MutableMacroBlock s Int16)
decompressMacroBlock HuffmanPackedTree
dcTree HuffmanPackedTree
acTree MacroBlock Int16
qTable MutableMacroBlock s Int16
zigZagArray (Int16 -> BoolReader s (Int16, MutableMacroBlock s Int16))
-> Int16 -> BoolReader s (Int16, MutableMacroBlock s Int16)
forall a b. (a -> b) -> a -> b
$ Int16 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
dc
ST s () -> BoolReader s ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> BoolReader s ()) -> ST s () -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ (MutableMacroBlock s Int16
MVector (PrimState (ST s)) Int16
dcArray MVector (PrimState (ST s)) Int16 -> Int -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
compIdx) Int16
dcCoeff
let verticalLimited :: Bool
verticalLimited = Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
imageMcuHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
if (Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
imageMcuWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Bool -> Bool -> Bool
|| Bool
verticalLimited then
ST s () -> BoolReader s ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> BoolReader s ()) -> ST s () -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Unpacker s
forall s.
Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpackMacroBlock Int
imgComponentCount
Int
subX Int
subY Int
compIdx
(Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxiW Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
xd) (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxiH Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
yd) MutableImage s PixelYCbCr8
outImage MutableMacroBlock s Int16
block
else
ST s () -> BoolReader s ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> BoolReader s ()) -> ST s () -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ Unpacker s
unpack Int
compIdx (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxiW Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
xd) (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxiH Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
yd) MutableImage s PixelYCbCr8
outImage MutableMacroBlock s Int16
block
MutableImage s PixelYCbCr8 -> ST s (MutableImage s PixelYCbCr8)
forall (m :: * -> *) a. Monad m => a -> m a
return MutableImage s PixelYCbCr8
outImage
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
restartIntervalValue :: Int
restartIntervalValue = case [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
lst of
((p :: JpgUnpackerParameter
p,_):_,_): _ -> JpgUnpackerParameter -> Int
restartInterval JpgUnpackerParameter
p
_ -> -1
gatherImageKind :: [JpgFrame] -> Maybe JpgImageKind
gatherImageKind :: [JpgFrame] -> Maybe JpgImageKind
gatherImageKind lst :: [JpgFrame]
lst = case [JpgFrameKind
k | JpgScans k :: JpgFrameKind
k _ <- [JpgFrame]
lst, JpgFrameKind -> Bool
isDctSpecifier JpgFrameKind
k] of
[JpgBaselineDCTHuffman] -> JpgImageKind -> Maybe JpgImageKind
forall a. a -> Maybe a
Just JpgImageKind
BaseLineDCT
[JpgProgressiveDCTHuffman] -> JpgImageKind -> Maybe JpgImageKind
forall a. a -> Maybe a
Just JpgImageKind
ProgressiveDCT
[JpgExtendedSequentialDCTHuffman] -> JpgImageKind -> Maybe JpgImageKind
forall a. a -> Maybe a
Just JpgImageKind
BaseLineDCT
_ -> Maybe JpgImageKind
forall a. Maybe a
Nothing
where isDctSpecifier :: JpgFrameKind -> Bool
isDctSpecifier JpgProgressiveDCTHuffman = Bool
True
isDctSpecifier JpgBaselineDCTHuffman = Bool
True
isDctSpecifier JpgExtendedSequentialDCTHuffman = Bool
True
isDctSpecifier _ = Bool
False
gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader)
gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader)
gatherScanInfo img :: JpgImage
img = [(JpgFrameKind, JpgFrameHeader)] -> (JpgFrameKind, JpgFrameHeader)
forall a. [a] -> a
head [(JpgFrameKind
a, JpgFrameHeader
b) | JpgScans a :: JpgFrameKind
a b :: JpgFrameHeader
b <- JpgImage -> [JpgFrame]
jpgFrame JpgImage
img]
dynamicOfColorSpace :: Maybe JpgColorSpace -> Int -> Int -> VS.Vector Word8
-> Either String DynamicImage
dynamicOfColorSpace :: Maybe JpgColorSpace
-> Int -> Int -> Vector Word8 -> Either [Char] DynamicImage
dynamicOfColorSpace Nothing _ _ _ = [Char] -> Either [Char] DynamicImage
forall a b. a -> Either a b
Left "Unknown color space"
dynamicOfColorSpace (Just color :: JpgColorSpace
color) w :: Int
w h :: Int
h imgData :: Vector Word8
imgData = case JpgColorSpace
color of
JpgColorSpaceCMYK -> DynamicImage -> Either [Char] DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either [Char] DynamicImage)
-> (Image PixelCMYK8 -> DynamicImage)
-> Image PixelCMYK8
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelCMYK8 -> DynamicImage
ImageCMYK8 (Image PixelCMYK8 -> Either [Char] DynamicImage)
-> Image PixelCMYK8 -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> Vector (PixelBaseComponent PixelCMYK8)
-> Image PixelCMYK8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent PixelCMYK8)
imgData
JpgColorSpaceYCCK ->
let ymg :: Image PixelYCbCrK8
ymg = Int
-> Int
-> Vector (PixelBaseComponent PixelYCbCrK8)
-> Image PixelYCbCrK8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h (Vector (PixelBaseComponent PixelYCbCrK8) -> Image PixelYCbCrK8)
-> Vector (PixelBaseComponent PixelYCbCrK8) -> Image PixelYCbCrK8
forall a b. (a -> b) -> a -> b
$ (Word8 -> Word8) -> Vector Word8 -> Vector Word8
forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
VS.map (255Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
-) Vector Word8
imgData :: Image PixelYCbCrK8 in
DynamicImage -> Either [Char] DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either [Char] DynamicImage)
-> (Image PixelCMYK8 -> DynamicImage)
-> Image PixelCMYK8
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelCMYK8 -> DynamicImage
ImageCMYK8 (Image PixelCMYK8 -> Either [Char] DynamicImage)
-> Image PixelCMYK8 -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ Image PixelYCbCrK8 -> Image PixelCMYK8
forall a b. ColorSpaceConvertible a b => Image a -> Image b
convertImage Image PixelYCbCrK8
ymg
JpgColorSpaceYCbCr -> DynamicImage -> Either [Char] DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either [Char] DynamicImage)
-> (Image PixelYCbCr8 -> DynamicImage)
-> Image PixelYCbCr8
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYCbCr8 -> DynamicImage
ImageYCbCr8 (Image PixelYCbCr8 -> Either [Char] DynamicImage)
-> Image PixelYCbCr8 -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> Vector (PixelBaseComponent PixelYCbCr8)
-> Image PixelYCbCr8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent PixelYCbCr8)
imgData
JpgColorSpaceRGB -> DynamicImage -> Either [Char] DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either [Char] DynamicImage)
-> (Image PixelRGB8 -> DynamicImage)
-> Image PixelRGB8
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 (Image PixelRGB8 -> Either [Char] DynamicImage)
-> Image PixelRGB8 -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ Int
-> Int -> Vector (PixelBaseComponent PixelRGB8) -> Image PixelRGB8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent PixelRGB8)
imgData
JpgColorSpaceYA -> DynamicImage -> Either [Char] DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either [Char] DynamicImage)
-> (Image PixelYA8 -> DynamicImage)
-> Image PixelYA8
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYA8 -> DynamicImage
ImageYA8 (Image PixelYA8 -> Either [Char] DynamicImage)
-> Image PixelYA8 -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ Int
-> Int -> Vector (PixelBaseComponent PixelYA8) -> Image PixelYA8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent PixelYA8)
imgData
JpgColorSpaceY -> DynamicImage -> Either [Char] DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either [Char] DynamicImage)
-> (Image Word8 -> DynamicImage)
-> Image Word8
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Word8 -> DynamicImage
ImageY8 (Image Word8 -> Either [Char] DynamicImage)
-> Image Word8 -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector (PixelBaseComponent Word8) -> Image Word8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent Word8)
imgData
colorSpace :: JpgColorSpace
colorSpace -> [Char] -> Either [Char] DynamicImage
forall a b. a -> Either a b
Left ([Char] -> Either [Char] DynamicImage)
-> [Char] -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ "Wrong color space : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ JpgColorSpace -> [Char]
forall a. Show a => a -> [Char]
show JpgColorSpace
colorSpace
colorSpaceOfAdobe :: Int -> JpgAdobeApp14 -> Maybe JpgColorSpace
colorSpaceOfAdobe :: Int -> JpgAdobeApp14 -> Maybe JpgColorSpace
colorSpaceOfAdobe compCount :: Int
compCount app :: JpgAdobeApp14
app = case (Int
compCount, JpgAdobeApp14 -> AdobeTransform
_adobeTransform JpgAdobeApp14
app) of
(3, AdobeYCbCr) -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYCbCr
(1, AdobeUnknown) -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceY
(3, AdobeUnknown) -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceRGB
(4, AdobeYCck) -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYCCK
_ -> Maybe JpgColorSpace
forall a. Maybe a
Nothing
colorSpaceOfState :: JpgDecoderState -> Maybe JpgColorSpace
colorSpaceOfState :: JpgDecoderState -> Maybe JpgColorSpace
colorSpaceOfState st :: JpgDecoderState
st = do
JpgFrameHeader
hdr <- JpgDecoderState -> Maybe JpgFrameHeader
currentFrame JpgDecoderState
st
let compStr :: [Char]
compStr = [Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8 -> Char) -> Word8 -> Char
forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
componentIdentifier JpgComponent
comp
| JpgComponent
comp <- JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
hdr]
app14 :: Maybe JpgColorSpace
app14 = do
JpgAdobeApp14
marker <- JpgDecoderState -> Maybe JpgAdobeApp14
app14Marker JpgDecoderState
st
Int -> JpgAdobeApp14 -> Maybe JpgColorSpace
colorSpaceOfAdobe ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
compStr) JpgAdobeApp14
marker
Maybe JpgColorSpace
app14 Maybe JpgColorSpace -> Maybe JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Char] -> Maybe JpgColorSpace
colorSpaceOfComponentStr [Char]
compStr
colorSpaceOfComponentStr :: String -> Maybe JpgColorSpace
colorSpaceOfComponentStr :: [Char] -> Maybe JpgColorSpace
colorSpaceOfComponentStr s :: [Char]
s = case [Char]
s of
[_] -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceY
[_,_] -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYA
"\0\1\2" -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYCbCr
"\1\2\3" -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYCbCr
"RGB" -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceRGB
"YCc" -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYCC
[_,_,_] -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYCbCr
"RGBA" -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceRGBA
"YCcA" -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYCCA
"CMYK" -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceCMYK
"YCcK" -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYCCK
[_,_,_,_] -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceCMYK
_ -> Maybe JpgColorSpace
forall a. Maybe a
Nothing
decodeJpeg :: B.ByteString -> Either String DynamicImage
decodeJpeg :: ByteString -> Either [Char] DynamicImage
decodeJpeg = ((DynamicImage, Metadatas) -> DynamicImage)
-> Either [Char] (DynamicImage, Metadatas)
-> Either [Char] DynamicImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynamicImage, Metadatas) -> DynamicImage
forall a b. (a, b) -> a
fst (Either [Char] (DynamicImage, Metadatas)
-> Either [Char] DynamicImage)
-> (ByteString -> Either [Char] (DynamicImage, Metadatas))
-> ByteString
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] (DynamicImage, Metadatas)
decodeJpegWithMetadata
decodeJpegWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
decodeJpegWithMetadata :: ByteString -> Either [Char] (DynamicImage, Metadatas)
decodeJpegWithMetadata file :: ByteString
file = case Get JpgImage -> ByteString -> Either [Char] JpgImage
forall a. Get a -> ByteString -> Either [Char] a
runGetStrict Get JpgImage
forall t. Binary t => Get t
get ByteString
file of
Left err :: [Char]
err -> [Char] -> Either [Char] (DynamicImage, Metadatas)
forall a b. a -> Either a b
Left [Char]
err
Right img :: JpgImage
img -> case Maybe JpgImageKind
imgKind of
Just BaseLineDCT ->
let (st :: JpgDecoderState
st, arr :: Vector Word8
arr) = (JpgDecoderState, Vector Word8)
decodeBaseline
jfifMeta :: Metadatas
jfifMeta = (JpgJFIFApp0 -> Metadatas) -> Maybe JpgJFIFApp0 -> Metadatas
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap JpgJFIFApp0 -> Metadatas
extractMetadatas (Maybe JpgJFIFApp0 -> Metadatas) -> Maybe JpgJFIFApp0 -> Metadatas
forall a b. (a -> b) -> a -> b
$ JpgDecoderState -> Maybe JpgJFIFApp0
app0JFifMarker JpgDecoderState
st
exifMeta :: Metadatas
exifMeta = ([ImageFileDirectory] -> Metadatas)
-> Maybe [ImageFileDirectory] -> Metadatas
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [ImageFileDirectory] -> Metadatas
extractTiffMetadata (Maybe [ImageFileDirectory] -> Metadatas)
-> Maybe [ImageFileDirectory] -> Metadatas
forall a b. (a -> b) -> a -> b
$ JpgDecoderState -> Maybe [ImageFileDirectory]
app1ExifMarker JpgDecoderState
st
meta :: Metadatas
meta = Metadatas
sizeMeta Metadatas -> Metadatas -> Metadatas
forall a. Semigroup a => a -> a -> a
<> Metadatas
jfifMeta Metadatas -> Metadatas -> Metadatas
forall a. Semigroup a => a -> a -> a
<> Metadatas
exifMeta
in
(, Metadatas
meta) (DynamicImage -> (DynamicImage, Metadatas))
-> Either [Char] DynamicImage
-> Either [Char] (DynamicImage, Metadatas)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Maybe JpgColorSpace
-> Int -> Int -> Vector Word8 -> Either [Char] DynamicImage
dynamicOfColorSpace (JpgDecoderState -> Maybe JpgColorSpace
colorSpaceOfState JpgDecoderState
st) Int
imgWidth Int
imgHeight Vector Word8
arr
Just ProgressiveDCT ->
let (st :: JpgDecoderState
st, arr :: Vector Word8
arr) = (JpgDecoderState, Vector Word8)
decodeProgressive
jfifMeta :: Metadatas
jfifMeta = (JpgJFIFApp0 -> Metadatas) -> Maybe JpgJFIFApp0 -> Metadatas
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap JpgJFIFApp0 -> Metadatas
extractMetadatas (Maybe JpgJFIFApp0 -> Metadatas) -> Maybe JpgJFIFApp0 -> Metadatas
forall a b. (a -> b) -> a -> b
$ JpgDecoderState -> Maybe JpgJFIFApp0
app0JFifMarker JpgDecoderState
st
exifMeta :: Metadatas
exifMeta = ([ImageFileDirectory] -> Metadatas)
-> Maybe [ImageFileDirectory] -> Metadatas
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [ImageFileDirectory] -> Metadatas
extractTiffMetadata (Maybe [ImageFileDirectory] -> Metadatas)
-> Maybe [ImageFileDirectory] -> Metadatas
forall a b. (a -> b) -> a -> b
$ JpgDecoderState -> Maybe [ImageFileDirectory]
app1ExifMarker JpgDecoderState
st
meta :: Metadatas
meta = Metadatas
sizeMeta Metadatas -> Metadatas -> Metadatas
forall a. Semigroup a => a -> a -> a
<> Metadatas
jfifMeta Metadatas -> Metadatas -> Metadatas
forall a. Semigroup a => a -> a -> a
<> Metadatas
exifMeta
in
(, Metadatas
meta) (DynamicImage -> (DynamicImage, Metadatas))
-> Either [Char] DynamicImage
-> Either [Char] (DynamicImage, Metadatas)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Maybe JpgColorSpace
-> Int -> Int -> Vector Word8 -> Either [Char] DynamicImage
dynamicOfColorSpace (JpgDecoderState -> Maybe JpgColorSpace
colorSpaceOfState JpgDecoderState
st) Int
imgWidth Int
imgHeight Vector Word8
arr
_ -> [Char] -> Either [Char] (DynamicImage, Metadatas)
forall a b. a -> Either a b
Left "Unknown JPG kind"
where
compCount :: Int
compCount = [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
scanInfo
(_,scanInfo :: JpgFrameHeader
scanInfo) = JpgImage -> (JpgFrameKind, JpgFrameHeader)
gatherScanInfo JpgImage
img
imgKind :: Maybe JpgImageKind
imgKind = [JpgFrame] -> Maybe JpgImageKind
gatherImageKind ([JpgFrame] -> Maybe JpgImageKind)
-> [JpgFrame] -> Maybe JpgImageKind
forall a b. (a -> b) -> a -> b
$ JpgImage -> [JpgFrame]
jpgFrame JpgImage
img
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
scanInfo
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
scanInfo
sizeMeta :: Metadatas
sizeMeta = SourceFormat -> Int -> Int -> Metadatas
forall nSize.
Integral nSize =>
SourceFormat -> nSize -> nSize -> Metadatas
basicMetadata SourceFormat
SourceJpeg Int
imgWidth Int
imgHeight
imageSize :: Int
imageSize = 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
compCount
decodeProgressive :: (JpgDecoderState, Vector Word8)
decodeProgressive = (forall s. ST s (JpgDecoderState, Vector Word8))
-> (JpgDecoderState, Vector Word8)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (JpgDecoderState, Vector Word8))
-> (JpgDecoderState, Vector Word8))
-> (forall s. ST s (JpgDecoderState, Vector Word8))
-> (JpgDecoderState, Vector Word8)
forall a b. (a -> b) -> a -> b
$ do
let (st :: JpgDecoderState
st, wrotten :: [([(JpgUnpackerParameter, Unpacker Any)], ByteString)]
wrotten) =
RWS
()
[([(JpgUnpackerParameter, Unpacker Any)], ByteString)]
JpgDecoderState
()
-> ()
-> JpgDecoderState
-> (JpgDecoderState,
[([(JpgUnpackerParameter, Unpacker Any)], ByteString)])
forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS ((JpgFrame
-> RWS
()
[([(JpgUnpackerParameter, Unpacker Any)], ByteString)]
JpgDecoderState
())
-> [JpgFrame]
-> RWS
()
[([(JpgUnpackerParameter, Unpacker Any)], ByteString)]
JpgDecoderState
()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JpgFrame
-> RWS
()
[([(JpgUnpackerParameter, Unpacker Any)], ByteString)]
JpgDecoderState
()
forall s. JpgFrame -> JpgScripter s ()
jpgMachineStep (JpgImage -> [JpgFrame]
jpgFrame JpgImage
img)) () JpgDecoderState
emptyDecoderState
Just fHdr :: JpgFrameHeader
fHdr = JpgDecoderState -> Maybe JpgFrameHeader
currentFrame JpgDecoderState
st
MutableImage s PixelYCbCr8
fimg <-
(Int, Int)
-> JpgFrameHeader
-> Vector (MacroBlock Int16)
-> [([(JpgUnpackerParameter, Unpacker Any)], ByteString)]
-> ST s (MutableImage s PixelYCbCr8)
forall a s.
(Int, Int)
-> JpgFrameHeader
-> Vector (MacroBlock Int16)
-> [([(JpgUnpackerParameter, a)], ByteString)]
-> ST s (MutableImage s PixelYCbCr8)
progressiveUnpack
(JpgDecoderState -> Int
maximumHorizontalResolution JpgDecoderState
st, JpgDecoderState -> Int
maximumVerticalResolution JpgDecoderState
st)
JpgFrameHeader
fHdr
(JpgDecoderState -> Vector (MacroBlock Int16)
quantizationMatrices JpgDecoderState
st)
[([(JpgUnpackerParameter, Unpacker Any)], ByteString)]
wrotten
Image PixelYCbCr8
frozen <- MutableImage (PrimState (ST s)) PixelYCbCr8
-> ST s (Image PixelYCbCr8)
forall a (m :: * -> *).
(Storable (PixelBaseComponent a), PrimMonad m) =>
MutableImage (PrimState m) a -> m (Image a)
unsafeFreezeImage MutableImage s PixelYCbCr8
MutableImage (PrimState (ST s)) PixelYCbCr8
fimg
(JpgDecoderState, Vector Word8)
-> ST s (JpgDecoderState, Vector Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (JpgDecoderState
st, Image PixelYCbCr8 -> Vector (PixelBaseComponent PixelYCbCr8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image PixelYCbCr8
frozen)
decodeBaseline :: (JpgDecoderState, Vector Word8)
decodeBaseline = (forall s. ST s (JpgDecoderState, Vector Word8))
-> (JpgDecoderState, Vector Word8)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (JpgDecoderState, Vector Word8))
-> (JpgDecoderState, Vector Word8))
-> (forall s. ST s (JpgDecoderState, Vector Word8))
-> (JpgDecoderState, Vector Word8)
forall a b. (a -> b) -> a -> b
$ do
let (st :: JpgDecoderState
st, wrotten :: [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
wrotten) =
RWS
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
()
-> ()
-> JpgDecoderState
-> (JpgDecoderState,
[([(JpgUnpackerParameter, Unpacker s)], ByteString)])
forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS ((JpgFrame
-> RWS
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
())
-> [JpgFrame]
-> RWS
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JpgFrame
-> RWS
()
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
JpgDecoderState
()
forall s. JpgFrame -> JpgScripter s ()
jpgMachineStep (JpgImage -> [JpgFrame]
jpgFrame JpgImage
img)) () JpgDecoderState
emptyDecoderState
Just fHdr :: JpgFrameHeader
fHdr = JpgDecoderState -> Maybe JpgFrameHeader
currentFrame JpgDecoderState
st
MVector s Word8
resultImage <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
imageSize
let wrapped :: MutableImage s PixelYCbCr8
wrapped = 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
STVector s (PixelBaseComponent PixelYCbCr8)
resultImage
MutableImage s PixelYCbCr8
fImg <- JpgFrameHeader
-> Vector (MacroBlock Int16)
-> [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
-> MutableImage s PixelYCbCr8
-> ST s (MutableImage s PixelYCbCr8)
forall s.
JpgFrameHeader
-> Vector (MacroBlock Int16)
-> [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
-> MutableImage s PixelYCbCr8
-> ST s (MutableImage s PixelYCbCr8)
decodeImage
JpgFrameHeader
fHdr
(JpgDecoderState -> Vector (MacroBlock Int16)
quantizationMatrices JpgDecoderState
st)
[([(JpgUnpackerParameter, Unpacker s)], ByteString)]
wrotten
MutableImage s PixelYCbCr8
wrapped
Image PixelYCbCr8
frozen <- MutableImage (PrimState (ST s)) PixelYCbCr8
-> ST s (Image PixelYCbCr8)
forall a (m :: * -> *).
(Storable (PixelBaseComponent a), PrimMonad m) =>
MutableImage (PrimState m) a -> m (Image a)
unsafeFreezeImage MutableImage s PixelYCbCr8
MutableImage (PrimState (ST s)) PixelYCbCr8
fImg
(JpgDecoderState, Vector Word8)
-> ST s (JpgDecoderState, Vector Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (JpgDecoderState
st, Image PixelYCbCr8 -> Vector (PixelBaseComponent PixelYCbCr8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image PixelYCbCr8
frozen)
extractBlock :: forall s px. (PixelBaseComponent px ~ Word8)
=> Image px
-> MutableMacroBlock s Int16
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> ST s (MutableMacroBlock s Int16)
(Image { imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h, imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData = Vector (PixelBaseComponent px)
src })
block :: MutableMacroBlock s Int16
block 1 1 sampCount :: Int
sampCount plane :: Int
plane bx :: Int
bx by :: Int
by | (Int
bx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 7 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w Bool -> Bool -> Bool
&& (Int
by Int -> Int -> Int
forall a. Num a => a -> a -> a
* 8) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 7 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
h = do
let baseReadIdx :: Int
baseReadIdx = (Int
by Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize
[ST s ()] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [(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 ()
`M.unsafeWrite` (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x)) Int16
val
| Int
y <- [0 .. Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]
, let blockReadIdx :: Int
blockReadIdx = Int
baseReadIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w
, Int
x <- [0 .. Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]
, let val :: Int16
val = Word8 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int16) -> Word8 -> Int16
forall a b. (a -> b) -> a -> b
$ Vector Word8
Vector (PixelBaseComponent px)
src Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` ((Int
blockReadIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
plane)
]
MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16)
forall (m :: * -> *) a. Monad m => a -> m a
return MutableMacroBlock s Int16
block
extractBlock (Image { imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h, imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
imageData = Vector (PixelBaseComponent px)
src })
block :: MutableMacroBlock s Int16
block sampWidth :: Int
sampWidth sampHeight :: Int
sampHeight sampCount :: Int
sampCount plane :: Int
plane bx :: Int
bx by :: Int
by = do
let accessPixel :: Int -> Int -> Word8
accessPixel x :: Int
x y :: Int
y | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
h = let idx :: Int
idx = (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
plane in Vector Word8
Vector (PixelBaseComponent px)
src Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` Int
idx
| Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
w = Int -> Int -> Word8
accessPixel (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int
y
| Bool
otherwise = Int -> Int -> Word8
accessPixel Int
x (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
pixelPerCoeff :: Int16
pixelPerCoeff = Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int16) -> Int -> Int16
forall a b. (a -> b) -> a -> b
$ Int
sampWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampHeight
blockVal :: Int -> Int -> Int16
blockVal x :: Int
x y :: Int
y = [Int16] -> Int16
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Word8 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int16) -> Word8 -> Int16
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Word8
accessPixel (Int
xBase Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dx) (Int
yBase Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dy)
| Int
dy <- [0 .. Int
sampHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]
, Int
dx <- [0 .. Int
sampWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1] ] Int16 -> Int16 -> Int16
forall a. Integral a => a -> a -> a
`div` Int16
pixelPerCoeff
where xBase :: Int
xBase = Int
blockXBegin Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampWidth
yBase :: Int
yBase = Int
blockYBegin Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampHeight
blockXBegin :: Int
blockXBegin = Int
bx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampWidth
blockYBegin :: Int
blockYBegin = Int
by Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sampHeight
[ST s ()] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [(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 ()
`M.unsafeWrite` (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x)) (Int16 -> ST s ()) -> Int16 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int16
blockVal Int
x Int
y | Int
y <- [0 .. 7], Int
x <- [0 .. 7] ]
MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16)
forall (m :: * -> *) a. Monad m => a -> m a
return MutableMacroBlock s Int16
block
serializeMacroBlock :: BoolWriteStateRef s
-> HuffmanWriterCode -> HuffmanWriterCode
-> MutableMacroBlock s Int32
-> ST s ()
serializeMacroBlock :: BoolWriteStateRef s
-> HuffmanWriterCode
-> HuffmanWriterCode
-> MutableMacroBlock s Int32
-> ST s ()
serializeMacroBlock !BoolWriteStateRef s
st !HuffmanWriterCode
dcCode !HuffmanWriterCode
acCode !MutableMacroBlock s Int32
blk =
(MutableMacroBlock s Int32
MVector (PrimState (ST s)) Int32
blk MVector (PrimState (ST s)) Int32 -> Int -> ST s Int32
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` 0) ST s Int32 -> (Int32 -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int32) -> (Int32 -> ST s ()) -> Int32 -> ST s ()
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Int32 -> ST s ()
encodeDc) ST s () -> ST s () -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Word32, Int) -> ST s ()
writeAcs (0, 1) ST s () -> ST s () -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where writeAcs :: (Word32, Int) -> ST s ()
writeAcs acc :: (Word32, Int)
acc@(_, 63) =
(MutableMacroBlock s Int32
MVector (PrimState (ST s)) Int32
blk MVector (PrimState (ST s)) Int32 -> Int -> ST s Int32
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` 63) ST s Int32 -> (Int32 -> ST s (Word32, Int)) -> ST s (Word32, Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int32)
-> (Int32 -> ST s (Word32, Int)) -> Int32 -> ST s (Word32, Int)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Word32, Int) -> Int32 -> ST s (Word32, Int)
encodeAcCoefs (Word32, Int)
acc) ST s (Word32, Int) -> ST s () -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
writeAcs acc :: (Word32, Int)
acc@(_, i :: Int
i ) =
(MutableMacroBlock s Int32
MVector (PrimState (ST s)) Int32
blk MVector (PrimState (ST s)) Int32 -> Int -> ST s Int32
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
i) ST s Int32 -> (Int32 -> ST s (Word32, Int)) -> ST s (Word32, Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int32)
-> (Int32 -> ST s (Word32, Int)) -> Int32 -> ST s (Word32, Int)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Word32, Int) -> Int32 -> ST s (Word32, Int)
encodeAcCoefs (Word32, Int)
acc) ST s (Word32, Int) -> ((Word32, Int) -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Word32, Int) -> ST s ()
writeAcs
encodeDc :: Int32 -> ST s ()
encodeDc n :: Int32
n = BoolWriteStateRef s -> Word32 -> Int -> ST s ()
forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
code) (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
bitCount)
ST s () -> ST s () -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
ssss Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) (BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
forall s. BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
encodeInt BoolWriteStateRef s
st Word32
ssss Int32
n)
where ssss :: Word32
ssss = Int32 -> Word32
powerOf (Int32 -> Word32) -> Int32 -> Word32
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n
(bitCount :: Word8
bitCount, code :: Word16
code) = HuffmanWriterCode
dcCode HuffmanWriterCode -> Int -> (Word8, Word16)
forall a. Vector a -> Int -> a
`V.unsafeIndex` Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ssss
encodeAc :: Word32 -> Int32 -> ST s ()
encodeAc 0 0 = BoolWriteStateRef s -> Word32 -> Int -> ST s ()
forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
code) (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
bitCount
where (bitCount :: Word8
bitCount, code :: Word16
code) = HuffmanWriterCode
acCode HuffmanWriterCode -> Int -> (Word8, Word16)
forall a. Vector a -> Int -> a
`V.unsafeIndex` 0
encodeAc zeroCount :: Word32
zeroCount n :: Int32
n | Word32
zeroCount Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= 16 =
BoolWriteStateRef s -> Word32 -> Int -> ST s ()
forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
code) (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
bitCount) ST s () -> ST s () -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Int32 -> ST s ()
encodeAc (Word32
zeroCount Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- 16) Int32
n
where (bitCount :: Word8
bitCount, code :: Word16
code) = HuffmanWriterCode
acCode HuffmanWriterCode -> Int -> (Word8, Word16)
forall a. Vector a -> Int -> a
`V.unsafeIndex` 0xF0
encodeAc zeroCount :: Word32
zeroCount n :: Int32
n =
BoolWriteStateRef s -> Word32 -> Int -> ST s ()
forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
code) (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
bitCount) ST s () -> ST s () -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
forall s. BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
encodeInt BoolWriteStateRef s
st Word32
ssss Int32
n
where rrrr :: Word32
rrrr = Word32
zeroCount Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 4
ssss :: Word32
ssss = Int32 -> Word32
powerOf (Int32 -> Word32) -> Int32 -> Word32
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n
rrrrssss :: Word32
rrrrssss = Word32
rrrr Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
ssss
(bitCount :: Word8
bitCount, code :: Word16
code) = HuffmanWriterCode
acCode HuffmanWriterCode -> Int -> (Word8, Word16)
forall a. Vector a -> Int -> a
`V.unsafeIndex` Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
rrrrssss
encodeAcCoefs :: (Word32, Int) -> Int32 -> ST s (Word32, Int)
encodeAcCoefs ( _, 63) 0 = Word32 -> Int32 -> ST s ()
encodeAc 0 0 ST s () -> ST s (Word32, Int) -> ST s (Word32, Int)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Word32, Int) -> ST s (Word32, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (0, 64)
encodeAcCoefs (zeroRunLength :: Word32
zeroRunLength, i :: Int
i) 0 = (Word32, Int) -> ST s (Word32, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
zeroRunLength Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ 1, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
encodeAcCoefs (zeroRunLength :: Word32
zeroRunLength, i :: Int
i) n :: Int32
n =
Word32 -> Int32 -> ST s ()
encodeAc Word32
zeroRunLength Int32
n ST s () -> ST s (Word32, Int) -> ST s (Word32, Int)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Word32, Int) -> ST s (Word32, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (0, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
encodeMacroBlock :: QuantificationTable
-> MutableMacroBlock s Int32
-> MutableMacroBlock s Int32
-> Int16
-> MutableMacroBlock s Int16
-> ST s (Int32, MutableMacroBlock s Int32)
encodeMacroBlock :: MacroBlock Int16
-> MutableMacroBlock s Int32
-> MutableMacroBlock s Int32
-> Int16
-> MutableMacroBlock s Int16
-> ST s (Int32, MutableMacroBlock s Int32)
encodeMacroBlock quantTableOfComponent :: MacroBlock Int16
quantTableOfComponent workData :: MutableMacroBlock s Int32
workData finalData :: MutableMacroBlock s Int32
finalData prev_dc :: Int16
prev_dc block :: MutableMacroBlock s Int16
block = do
MutableMacroBlock s Int32
blk <- MutableMacroBlock s Int32
-> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int32)
forall s.
MutableMacroBlock s Int32
-> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int32)
fastDctLibJpeg MutableMacroBlock s Int32
workData MutableMacroBlock s Int16
block
ST s (MutableMacroBlock s Int32)
-> (MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32))
-> ST s (MutableMacroBlock s Int32)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableMacroBlock s Int32
-> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32)
forall a s.
Storable a =>
MutableMacroBlock s a
-> MutableMacroBlock s a -> ST s (MutableMacroBlock s a)
zigZagReorderForward MutableMacroBlock s Int32
finalData
ST s (MutableMacroBlock s Int32)
-> (MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32))
-> ST s (MutableMacroBlock s Int32)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MacroBlock Int16
-> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32)
forall s.
MacroBlock Int16
-> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32)
quantize MacroBlock Int16
quantTableOfComponent
Int32
dc <- MutableMacroBlock s Int32
MVector (PrimState (ST s)) Int32
blk MVector (PrimState (ST s)) Int32 -> Int -> ST s Int32
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` 0
(MutableMacroBlock s Int32
MVector (PrimState (ST s)) Int32
blk MVector (PrimState (ST s)) Int32 -> Int -> Int32 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` 0) (Int32 -> ST s ()) -> Int32 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int32
dc Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
prev_dc
(Int32, MutableMacroBlock s Int32)
-> ST s (Int32, MutableMacroBlock s Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
dc, MutableMacroBlock s Int32
blk)
divUpward :: (Integral a) => a -> a -> a
divUpward :: a -> a -> a
divUpward n :: a
n dividor :: a
dividor = a
val a -> a -> a
forall a. Num a => a -> a -> a
+ (if a
rest a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then 1 else 0)
where (val :: a
val, rest :: a
rest) = a
n a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
`divMod` a
dividor
prepareHuffmanTable :: DctComponent -> Word8 -> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable :: DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable classVal :: DctComponent
classVal dest :: Word8
dest tableDef :: HuffmanTable
tableDef =
($WJpgHuffmanTableSpec :: DctComponent
-> Word8
-> Vector Word8
-> Vector (Vector Word8)
-> JpgHuffmanTableSpec
JpgHuffmanTableSpec { huffmanTableClass :: DctComponent
huffmanTableClass = DctComponent
classVal
, huffmanTableDest :: Word8
huffmanTableDest = Word8
dest
, huffSizes :: Vector Word8
huffSizes = Vector Word8
sizes
, huffCodes :: Vector (Vector Word8)
huffCodes = Int -> [Vector Word8] -> Vector (Vector Word8)
forall a. Int -> [a] -> Vector a
V.fromListN 16
[Int -> [Word8] -> Vector Word8
forall a. Unbox a => Int -> [a] -> Vector a
VU.fromListN (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ Vector Word8
sizes Vector Word8 -> Int -> Word8
forall a. Unbox a => Vector a -> Int -> a
! Int
i) [Word8]
lst
| (i :: Int
i, lst :: [Word8]
lst) <- [Int] -> HuffmanTable -> [(Int, [Word8])]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] HuffmanTable
tableDef ]
}, Word16 -> HuffmanPackedTree
forall a. Storable a => a -> Vector a
VS.singleton 0)
where sizes :: Vector Word8
sizes = Int -> [Word8] -> Vector Word8
forall a. Unbox a => Int -> [a] -> Vector a
VU.fromListN 16 ([Word8] -> Vector Word8) -> [Word8] -> Vector Word8
forall a b. (a -> b) -> a -> b
$ ([Word8] -> Word8) -> HuffmanTable -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> ([Word8] -> Int) -> [Word8] -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) HuffmanTable
tableDef
encodeJpeg :: Image PixelYCbCr8 -> L.ByteString
encodeJpeg :: Image PixelYCbCr8 -> ByteString
encodeJpeg = Word8 -> Image PixelYCbCr8 -> ByteString
encodeJpegAtQuality 50
defaultHuffmanTables :: [(JpgHuffmanTableSpec, HuffmanPackedTree)]
defaultHuffmanTables :: [(JpgHuffmanTableSpec, HuffmanPackedTree)]
defaultHuffmanTables =
[ DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent 0 HuffmanTable
defaultDcLumaHuffmanTable
, DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent 0 HuffmanTable
defaultAcLumaHuffmanTable
, DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent 1 HuffmanTable
defaultDcChromaHuffmanTable
, DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent 1 HuffmanTable
defaultAcChromaHuffmanTable
]
lumaQuantTableAtQuality :: Int -> QuantificationTable
lumaQuantTableAtQuality :: Int -> MacroBlock Int16
lumaQuantTableAtQuality qual :: Int
qual = Int -> MacroBlock Int16 -> MacroBlock Int16
scaleQuantisationMatrix Int
qual MacroBlock Int16
defaultLumaQuantizationTable
chromaQuantTableAtQuality :: Int -> QuantificationTable
chromaQuantTableAtQuality :: Int -> MacroBlock Int16
chromaQuantTableAtQuality qual :: Int
qual =
Int -> MacroBlock Int16 -> MacroBlock Int16
scaleQuantisationMatrix Int
qual MacroBlock Int16
defaultChromaQuantizationTable
zigzaggedQuantificationSpec :: Int -> [JpgQuantTableSpec]
zigzaggedQuantificationSpec :: Int -> [JpgQuantTableSpec]
zigzaggedQuantificationSpec qual :: Int
qual =
[ $WJpgQuantTableSpec :: Word8 -> Word8 -> MacroBlock Int16 -> JpgQuantTableSpec
JpgQuantTableSpec { quantPrecision :: Word8
quantPrecision = 0, quantDestination :: Word8
quantDestination = 0, quantTable :: MacroBlock Int16
quantTable = MacroBlock Int16
luma }
, $WJpgQuantTableSpec :: Word8 -> Word8 -> MacroBlock Int16 -> JpgQuantTableSpec
JpgQuantTableSpec { quantPrecision :: Word8
quantPrecision = 0, quantDestination :: Word8
quantDestination = 1, quantTable :: MacroBlock Int16
quantTable = MacroBlock Int16
chroma }
]
where
luma :: MacroBlock Int16
luma = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
lumaQuantTableAtQuality Int
qual
chroma :: MacroBlock Int16
chroma = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
chromaQuantTableAtQuality Int
qual
encodeJpegAtQuality :: Word8
-> Image PixelYCbCr8
-> L.ByteString
encodeJpegAtQuality :: Word8 -> Image PixelYCbCr8 -> ByteString
encodeJpegAtQuality quality :: Word8
quality = Word8 -> Metadatas -> Image PixelYCbCr8 -> ByteString
encodeJpegAtQualityWithMetadata Word8
quality Metadatas
forall a. Monoid a => a
mempty
data EncoderState = EncoderState
{ EncoderState -> Int
_encComponentIndex :: !Int
, EncoderState -> Int
_encBlockWidth :: !Int
, EncoderState -> Int
_encBlockHeight :: !Int
, EncoderState -> MacroBlock Int16
_encQuantTable :: !QuantificationTable
, EncoderState -> HuffmanWriterCode
_encDcHuffman :: !HuffmanWriterCode
, EncoderState -> HuffmanWriterCode
_encAcHuffman :: !HuffmanWriterCode
}
class (Pixel px, PixelBaseComponent px ~ Word8) => JpgEncodable px where
additionalBlocks :: Image px -> [JpgFrame]
additionalBlocks _ = []
componentsOfColorSpace :: Image px -> [JpgComponent]
encodingState :: Int -> Image px -> V.Vector EncoderState
imageHuffmanTables :: Image px -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
imageHuffmanTables _ = [(JpgHuffmanTableSpec, HuffmanPackedTree)]
defaultHuffmanTables
scanSpecificationOfColorSpace :: Image px -> [JpgScanSpecification]
quantTableSpec :: Image px -> Int -> [JpgQuantTableSpec]
quantTableSpec _ qual :: Int
qual = Int -> [JpgQuantTableSpec] -> [JpgQuantTableSpec]
forall a. Int -> [a] -> [a]
take 1 ([JpgQuantTableSpec] -> [JpgQuantTableSpec])
-> [JpgQuantTableSpec] -> [JpgQuantTableSpec]
forall a b. (a -> b) -> a -> b
$ Int -> [JpgQuantTableSpec]
zigzaggedQuantificationSpec Int
qual
maximumSubSamplingOf :: Image px -> Int
maximumSubSamplingOf _ = 1
instance JpgEncodable Pixel8 where
scanSpecificationOfColorSpace :: Image Word8 -> [JpgScanSpecification]
scanSpecificationOfColorSpace _ =
[ $WJpgScanSpecification :: Word8 -> Word8 -> Word8 -> JpgScanSpecification
JpgScanSpecification { componentSelector :: Word8
componentSelector = 1
, dcEntropyCodingTable :: Word8
dcEntropyCodingTable = 0
, acEntropyCodingTable :: Word8
acEntropyCodingTable = 0
}
]
componentsOfColorSpace :: Image Word8 -> [JpgComponent]
componentsOfColorSpace _ =
[ $WJpgComponent :: Word8 -> Word8 -> Word8 -> Word8 -> JpgComponent
JpgComponent { componentIdentifier :: Word8
componentIdentifier = 1
, horizontalSamplingFactor :: Word8
horizontalSamplingFactor = 1
, verticalSamplingFactor :: Word8
verticalSamplingFactor = 1
, quantizationTableDest :: Word8
quantizationTableDest = 0
}
]
imageHuffmanTables :: Image Word8 -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
imageHuffmanTables _ =
[ DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent 0 HuffmanTable
defaultDcLumaHuffmanTable
, DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent 0 HuffmanTable
defaultAcLumaHuffmanTable
]
encodingState :: Int -> Image Word8 -> Vector EncoderState
encodingState qual :: Int
qual _ = EncoderState -> Vector EncoderState
forall a. a -> Vector a
V.singleton $WEncoderState :: Int
-> Int
-> Int
-> MacroBlock Int16
-> HuffmanWriterCode
-> HuffmanWriterCode
-> EncoderState
EncoderState
{ _encComponentIndex :: Int
_encComponentIndex = 0
, _encBlockWidth :: Int
_encBlockWidth = 1
, _encBlockHeight :: Int
_encBlockHeight = 1
, _encQuantTable :: MacroBlock Int16
_encQuantTable = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
lumaQuantTableAtQuality Int
qual
, _encDcHuffman :: HuffmanWriterCode
_encDcHuffman = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultDcLumaHuffmanTree
, _encAcHuffman :: HuffmanWriterCode
_encAcHuffman = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultAcLumaHuffmanTree
}
instance JpgEncodable PixelYCbCr8 where
maximumSubSamplingOf :: Image PixelYCbCr8 -> Int
maximumSubSamplingOf _ = 2
quantTableSpec :: Image PixelYCbCr8 -> Int -> [JpgQuantTableSpec]
quantTableSpec _ qual :: Int
qual = Int -> [JpgQuantTableSpec]
zigzaggedQuantificationSpec Int
qual
scanSpecificationOfColorSpace :: Image PixelYCbCr8 -> [JpgScanSpecification]
scanSpecificationOfColorSpace _ =
[ $WJpgScanSpecification :: Word8 -> Word8 -> Word8 -> JpgScanSpecification
JpgScanSpecification { componentSelector :: Word8
componentSelector = 1
, dcEntropyCodingTable :: Word8
dcEntropyCodingTable = 0
, acEntropyCodingTable :: Word8
acEntropyCodingTable = 0
}
, $WJpgScanSpecification :: Word8 -> Word8 -> Word8 -> JpgScanSpecification
JpgScanSpecification { componentSelector :: Word8
componentSelector = 2
, dcEntropyCodingTable :: Word8
dcEntropyCodingTable = 1
, acEntropyCodingTable :: Word8
acEntropyCodingTable = 1
}
, $WJpgScanSpecification :: Word8 -> Word8 -> Word8 -> JpgScanSpecification
JpgScanSpecification { componentSelector :: Word8
componentSelector = 3
, dcEntropyCodingTable :: Word8
dcEntropyCodingTable = 1
, acEntropyCodingTable :: Word8
acEntropyCodingTable = 1
}
]
componentsOfColorSpace :: Image PixelYCbCr8 -> [JpgComponent]
componentsOfColorSpace _ =
[ $WJpgComponent :: Word8 -> Word8 -> Word8 -> Word8 -> JpgComponent
JpgComponent { componentIdentifier :: Word8
componentIdentifier = 1
, horizontalSamplingFactor :: Word8
horizontalSamplingFactor = 2
, verticalSamplingFactor :: Word8
verticalSamplingFactor = 2
, quantizationTableDest :: Word8
quantizationTableDest = 0
}
, $WJpgComponent :: Word8 -> Word8 -> Word8 -> Word8 -> JpgComponent
JpgComponent { componentIdentifier :: Word8
componentIdentifier = 2
, horizontalSamplingFactor :: Word8
horizontalSamplingFactor = 1
, verticalSamplingFactor :: Word8
verticalSamplingFactor = 1
, quantizationTableDest :: Word8
quantizationTableDest = 1
}
, $WJpgComponent :: Word8 -> Word8 -> Word8 -> Word8 -> JpgComponent
JpgComponent { componentIdentifier :: Word8
componentIdentifier = 3
, horizontalSamplingFactor :: Word8
horizontalSamplingFactor = 1
, verticalSamplingFactor :: Word8
verticalSamplingFactor = 1
, quantizationTableDest :: Word8
quantizationTableDest = 1
}
]
encodingState :: Int -> Image PixelYCbCr8 -> Vector EncoderState
encodingState qual :: Int
qual _ = Int -> [EncoderState] -> Vector EncoderState
forall a. Int -> [a] -> Vector a
V.fromListN 3 [EncoderState
lumaState, EncoderState
chromaState, EncoderState
chromaState { _encComponentIndex :: Int
_encComponentIndex = 2 }]
where
lumaState :: EncoderState
lumaState = $WEncoderState :: Int
-> Int
-> Int
-> MacroBlock Int16
-> HuffmanWriterCode
-> HuffmanWriterCode
-> EncoderState
EncoderState
{ _encComponentIndex :: Int
_encComponentIndex = 0
, _encBlockWidth :: Int
_encBlockWidth = 2
, _encBlockHeight :: Int
_encBlockHeight = 2
, _encQuantTable :: MacroBlock Int16
_encQuantTable = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
lumaQuantTableAtQuality Int
qual
, _encDcHuffman :: HuffmanWriterCode
_encDcHuffman = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultDcLumaHuffmanTree
, _encAcHuffman :: HuffmanWriterCode
_encAcHuffman = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultAcLumaHuffmanTree
}
chromaState :: EncoderState
chromaState = $WEncoderState :: Int
-> Int
-> Int
-> MacroBlock Int16
-> HuffmanWriterCode
-> HuffmanWriterCode
-> EncoderState
EncoderState
{ _encComponentIndex :: Int
_encComponentIndex = 1
, _encBlockWidth :: Int
_encBlockWidth = 1
, _encBlockHeight :: Int
_encBlockHeight = 1
, _encQuantTable :: MacroBlock Int16
_encQuantTable = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
chromaQuantTableAtQuality Int
qual
, _encDcHuffman :: HuffmanWriterCode
_encDcHuffman = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultDcChromaHuffmanTree
, _encAcHuffman :: HuffmanWriterCode
_encAcHuffman = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultAcChromaHuffmanTree
}
instance JpgEncodable PixelRGB8 where
additionalBlocks :: Image PixelRGB8 -> [JpgFrame]
additionalBlocks _ = [JpgAdobeApp14 -> JpgFrame
JpgAdobeAPP14 JpgAdobeApp14
adobe14] where
adobe14 :: JpgAdobeApp14
adobe14 = $WJpgAdobeApp14 :: Word16 -> Word16 -> Word16 -> AdobeTransform -> JpgAdobeApp14
JpgAdobeApp14
{ _adobeDctVersion :: Word16
_adobeDctVersion = 100
, _adobeFlag0 :: Word16
_adobeFlag0 = 0
, _adobeFlag1 :: Word16
_adobeFlag1 = 0
, _adobeTransform :: AdobeTransform
_adobeTransform = AdobeTransform
AdobeUnknown
}
imageHuffmanTables :: Image PixelRGB8 -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
imageHuffmanTables _ =
[ DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent 0 HuffmanTable
defaultDcLumaHuffmanTable
, DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent 0 HuffmanTable
defaultAcLumaHuffmanTable
]
scanSpecificationOfColorSpace :: Image PixelRGB8 -> [JpgScanSpecification]
scanSpecificationOfColorSpace _ = (Char -> JpgScanSpecification) -> [Char] -> [JpgScanSpecification]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> JpgScanSpecification
forall a. Enum a => a -> JpgScanSpecification
build "RGB" where
build :: a -> JpgScanSpecification
build c :: a
c = $WJpgScanSpecification :: Word8 -> Word8 -> Word8 -> JpgScanSpecification
JpgScanSpecification
{ componentSelector :: Word8
componentSelector = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Enum a => a -> Int
fromEnum a
c
, dcEntropyCodingTable :: Word8
dcEntropyCodingTable = 0
, acEntropyCodingTable :: Word8
acEntropyCodingTable = 0
}
componentsOfColorSpace :: Image PixelRGB8 -> [JpgComponent]
componentsOfColorSpace _ = (Char -> JpgComponent) -> [Char] -> [JpgComponent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> JpgComponent
forall a. Enum a => a -> JpgComponent
build "RGB" where
build :: a -> JpgComponent
build c :: a
c = $WJpgComponent :: Word8 -> Word8 -> Word8 -> Word8 -> JpgComponent
JpgComponent
{ componentIdentifier :: Word8
componentIdentifier = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Enum a => a -> Int
fromEnum a
c
, horizontalSamplingFactor :: Word8
horizontalSamplingFactor = 1
, verticalSamplingFactor :: Word8
verticalSamplingFactor = 1
, quantizationTableDest :: Word8
quantizationTableDest = 0
}
encodingState :: Int -> Image PixelRGB8 -> Vector EncoderState
encodingState qual :: Int
qual _ = Int -> [EncoderState] -> Vector EncoderState
forall a. Int -> [a] -> Vector a
V.fromListN 3 ([EncoderState] -> Vector EncoderState)
-> [EncoderState] -> Vector EncoderState
forall a b. (a -> b) -> a -> b
$ (Int -> EncoderState) -> [Int] -> [EncoderState]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> EncoderState
build [0 .. 2] where
build :: Int -> EncoderState
build ix :: Int
ix = $WEncoderState :: Int
-> Int
-> Int
-> MacroBlock Int16
-> HuffmanWriterCode
-> HuffmanWriterCode
-> EncoderState
EncoderState
{ _encComponentIndex :: Int
_encComponentIndex = Int
ix
, _encBlockWidth :: Int
_encBlockWidth = 1
, _encBlockHeight :: Int
_encBlockHeight = 1
, _encQuantTable :: MacroBlock Int16
_encQuantTable = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
lumaQuantTableAtQuality Int
qual
, _encDcHuffman :: HuffmanWriterCode
_encDcHuffman = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultDcLumaHuffmanTree
, _encAcHuffman :: HuffmanWriterCode
_encAcHuffman = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultAcLumaHuffmanTree
}
instance JpgEncodable PixelCMYK8 where
additionalBlocks :: Image PixelCMYK8 -> [JpgFrame]
additionalBlocks _ = [] where
_adobe14 :: JpgAdobeApp14
_adobe14 = $WJpgAdobeApp14 :: Word16 -> Word16 -> Word16 -> AdobeTransform -> JpgAdobeApp14
JpgAdobeApp14
{ _adobeDctVersion :: Word16
_adobeDctVersion = 100
, _adobeFlag0 :: Word16
_adobeFlag0 = 32768
, _adobeFlag1 :: Word16
_adobeFlag1 = 0
, _adobeTransform :: AdobeTransform
_adobeTransform = AdobeTransform
AdobeYCck
}
imageHuffmanTables :: Image PixelCMYK8 -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
imageHuffmanTables _ =
[ DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent 0 HuffmanTable
defaultDcLumaHuffmanTable
, DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent 0 HuffmanTable
defaultAcLumaHuffmanTable
]
scanSpecificationOfColorSpace :: Image PixelCMYK8 -> [JpgScanSpecification]
scanSpecificationOfColorSpace _ = (Char -> JpgScanSpecification) -> [Char] -> [JpgScanSpecification]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> JpgScanSpecification
forall a. Enum a => a -> JpgScanSpecification
build "CMYK" where
build :: a -> JpgScanSpecification
build c :: a
c = $WJpgScanSpecification :: Word8 -> Word8 -> Word8 -> JpgScanSpecification
JpgScanSpecification
{ componentSelector :: Word8
componentSelector = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Enum a => a -> Int
fromEnum a
c
, dcEntropyCodingTable :: Word8
dcEntropyCodingTable = 0
, acEntropyCodingTable :: Word8
acEntropyCodingTable = 0
}
componentsOfColorSpace :: Image PixelCMYK8 -> [JpgComponent]
componentsOfColorSpace _ = (Char -> JpgComponent) -> [Char] -> [JpgComponent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> JpgComponent
forall a. Enum a => a -> JpgComponent
build "CMYK" where
build :: a -> JpgComponent
build c :: a
c = $WJpgComponent :: Word8 -> Word8 -> Word8 -> Word8 -> JpgComponent
JpgComponent
{ componentIdentifier :: Word8
componentIdentifier = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Enum a => a -> Int
fromEnum a
c
, horizontalSamplingFactor :: Word8
horizontalSamplingFactor = 1
, verticalSamplingFactor :: Word8
verticalSamplingFactor = 1
, quantizationTableDest :: Word8
quantizationTableDest = 0
}
encodingState :: Int -> Image PixelCMYK8 -> Vector EncoderState
encodingState qual :: Int
qual _ = Int -> [EncoderState] -> Vector EncoderState
forall a. Int -> [a] -> Vector a
V.fromListN 4 ([EncoderState] -> Vector EncoderState)
-> [EncoderState] -> Vector EncoderState
forall a b. (a -> b) -> a -> b
$ (Int -> EncoderState) -> [Int] -> [EncoderState]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> EncoderState
build [0 .. 3] where
build :: Int -> EncoderState
build ix :: Int
ix = $WEncoderState :: Int
-> Int
-> Int
-> MacroBlock Int16
-> HuffmanWriterCode
-> HuffmanWriterCode
-> EncoderState
EncoderState
{ _encComponentIndex :: Int
_encComponentIndex = Int
ix
, _encBlockWidth :: Int
_encBlockWidth = 1
, _encBlockHeight :: Int
_encBlockHeight = 1
, _encQuantTable :: MacroBlock Int16
_encQuantTable = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
lumaQuantTableAtQuality Int
qual
, _encDcHuffman :: HuffmanWriterCode
_encDcHuffman = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultDcLumaHuffmanTree
, _encAcHuffman :: HuffmanWriterCode
_encAcHuffman = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultAcLumaHuffmanTree
}
encodeJpegAtQualityWithMetadata :: Word8
-> Metadatas
-> Image PixelYCbCr8
-> L.ByteString
encodeJpegAtQualityWithMetadata :: Word8 -> Metadatas -> Image PixelYCbCr8 -> ByteString
encodeJpegAtQualityWithMetadata = Word8 -> Metadatas -> Image PixelYCbCr8 -> ByteString
forall px.
JpgEncodable px =>
Word8 -> Metadatas -> Image px -> ByteString
encodeDirectJpegAtQualityWithMetadata
encodeDirectJpegAtQualityWithMetadata :: forall px. (JpgEncodable px)
=> Word8
-> Metadatas
-> Image px
-> L.ByteString
encodeDirectJpegAtQualityWithMetadata :: Word8 -> Metadatas -> Image px -> ByteString
encodeDirectJpegAtQualityWithMetadata quality :: Word8
quality metas :: Metadatas
metas img :: Image px
img = JpgImage -> ByteString
forall a. Binary a => a -> ByteString
encode JpgImage
finalImage where
!w :: Int
w = Image px -> Int
forall a. Image a -> Int
imageWidth Image px
img
!h :: Int
h = Image px -> Int
forall a. Image a -> Int
imageHeight Image px
img
!exifMeta :: [JpgFrame]
exifMeta = case Metadatas -> [ImageFileDirectory]
encodeTiffStringMetadata Metadatas
metas of
[] -> []
lst :: [ImageFileDirectory]
lst -> [[ImageFileDirectory] -> JpgFrame
JpgExif [ImageFileDirectory]
lst]
finalImage :: JpgImage
finalImage = [JpgFrame] -> JpgImage
JpgImage ([JpgFrame] -> JpgImage) -> [JpgFrame] -> JpgImage
forall a b. (a -> b) -> a -> b
$
Metadatas -> [JpgFrame]
encodeMetadatas Metadatas
metas [JpgFrame] -> [JpgFrame] -> [JpgFrame]
forall a. [a] -> [a] -> [a]
++
[JpgFrame]
exifMeta [JpgFrame] -> [JpgFrame] -> [JpgFrame]
forall a. [a] -> [a] -> [a]
++
Image px -> [JpgFrame]
forall px. JpgEncodable px => Image px -> [JpgFrame]
additionalBlocks Image px
img [JpgFrame] -> [JpgFrame] -> [JpgFrame]
forall a. [a] -> [a] -> [a]
++
[ [JpgQuantTableSpec] -> JpgFrame
JpgQuantTable ([JpgQuantTableSpec] -> JpgFrame)
-> [JpgQuantTableSpec] -> JpgFrame
forall a b. (a -> b) -> a -> b
$ Image px -> Int -> [JpgQuantTableSpec]
forall px.
JpgEncodable px =>
Image px -> Int -> [JpgQuantTableSpec]
quantTableSpec Image px
img (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
quality)
, JpgFrameKind -> JpgFrameHeader -> JpgFrame
JpgScans JpgFrameKind
JpgBaselineDCTHuffman JpgFrameHeader
hdr
, [(JpgHuffmanTableSpec, HuffmanPackedTree)] -> JpgFrame
JpgHuffmanTable ([(JpgHuffmanTableSpec, HuffmanPackedTree)] -> JpgFrame)
-> [(JpgHuffmanTableSpec, HuffmanPackedTree)] -> JpgFrame
forall a b. (a -> b) -> a -> b
$ Image px -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
forall px.
JpgEncodable px =>
Image px -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
imageHuffmanTables Image px
img
, JpgScanHeader -> ByteString -> JpgFrame
JpgScanBlob JpgScanHeader
scanHeader ByteString
encodedImage
]
!outputComponentCount :: Int
outputComponentCount = px -> Int
forall a. Pixel a => a -> Int
componentCount (px
forall a. HasCallStack => a
undefined :: px)
scanHeader :: JpgScanHeader
scanHeader = JpgScanHeader
scanHeader'{ scanLength :: Word16
scanLength = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> Int
forall a. SizeCalculable a => a -> Int
calculateSize JpgScanHeader
scanHeader' }
scanHeader' :: JpgScanHeader
scanHeader' = $WJpgScanHeader :: Word16
-> Word8
-> [JpgScanSpecification]
-> (Word8, Word8)
-> Word8
-> Word8
-> JpgScanHeader
JpgScanHeader
{ scanLength :: Word16
scanLength = 0
, scanComponentCount :: Word8
scanComponentCount = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
outputComponentCount
, scans :: [JpgScanSpecification]
scans = Image px -> [JpgScanSpecification]
forall px. JpgEncodable px => Image px -> [JpgScanSpecification]
scanSpecificationOfColorSpace Image px
img
, spectralSelection :: (Word8, Word8)
spectralSelection = (0, 63)
, successiveApproxHigh :: Word8
successiveApproxHigh = 0
, successiveApproxLow :: Word8
successiveApproxLow = 0
}
hdr :: JpgFrameHeader
hdr = JpgFrameHeader
hdr' { jpgFrameHeaderLength :: Word16
jpgFrameHeaderLength = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Int
forall a. SizeCalculable a => a -> Int
calculateSize JpgFrameHeader
hdr' }
hdr' :: JpgFrameHeader
hdr' = $WJpgFrameHeader :: Word16
-> Word8
-> Word16
-> Word16
-> Word8
-> [JpgComponent]
-> JpgFrameHeader
JpgFrameHeader
{ jpgFrameHeaderLength :: Word16
jpgFrameHeaderLength = 0
, jpgSamplePrecision :: Word8
jpgSamplePrecision = 8
, jpgHeight :: Word16
jpgHeight = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h
, jpgWidth :: Word16
jpgWidth = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w
, jpgImageComponentCount :: Word8
jpgImageComponentCount = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
outputComponentCount
, jpgComponents :: [JpgComponent]
jpgComponents = Image px -> [JpgComponent]
forall px. JpgEncodable px => Image px -> [JpgComponent]
componentsOfColorSpace Image px
img
}
!maxSampling :: Int
maxSampling = Image px -> Int
forall px. JpgEncodable px => Image px -> Int
maximumSubSamplingOf Image px
img
!horizontalMetaBlockCount :: Int
horizontalMetaBlockCount = Int
w Int -> Int -> Int
forall a. Integral a => a -> a -> a
`divUpward` (Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxSampling)
!verticalMetaBlockCount :: Int
verticalMetaBlockCount = Int
h Int -> Int -> Int
forall a. Integral a => a -> a -> a
`divUpward` (Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxSampling)
!componentDef :: Vector EncoderState
componentDef = Int -> Image px -> Vector EncoderState
forall px.
JpgEncodable px =>
Int -> Image px -> Vector EncoderState
encodingState (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
quality) Image px
img
encodedImage :: ByteString
encodedImage = (forall s. ST s ByteString) -> ByteString
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s ByteString) -> ByteString)
-> (forall s. ST s ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ do
MVector s Int16
dc_table <- Int -> Int16 -> ST s (MVector (PrimState (ST s)) Int16)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate Int
outputComponentCount 0
MVector s Int16
block <- ST s (MVector s Int16)
forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
MutableMacroBlock s Int32
workData <- ST s (MutableMacroBlock s Int32)
forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
MutableMacroBlock s Int32
zigzaged <- ST s (MutableMacroBlock s Int32)
forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
BoolWriteStateRef s
writeState <- ST s (BoolWriteStateRef s)
forall s. ST s (BoolWriteStateRef s)
newWriteStateRef
Int -> Int -> (Int -> Int -> ST s ()) -> ST s ()
forall (m :: * -> *).
Monad m =>
Int -> Int -> (Int -> Int -> m ()) -> m ()
rasterMap Int
horizontalMetaBlockCount Int
verticalMetaBlockCount ((Int -> Int -> ST s ()) -> ST s ())
-> (Int -> Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \mx :: Int
mx my :: Int
my ->
Vector EncoderState -> (EncoderState -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
V.forM_ Vector EncoderState
componentDef ((EncoderState -> ST s ()) -> ST s ())
-> (EncoderState -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(EncoderState comp :: Int
comp sizeX :: Int
sizeX sizeY :: Int
sizeY table :: MacroBlock Int16
table dc :: HuffmanWriterCode
dc ac :: HuffmanWriterCode
ac) ->
let !xSamplingFactor :: Int
xSamplingFactor = Int
maxSampling Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sizeX Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
!ySamplingFactor :: Int
ySamplingFactor = Int
maxSampling Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sizeY Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
!extractor :: Int -> Int -> Int -> ST s (MVector s Int16)
extractor = Image px
-> MVector s Int16
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> ST s (MVector s Int16)
forall s px.
(PixelBaseComponent px ~ Word8) =>
Image px
-> MutableMacroBlock s Int16
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> ST s (MutableMacroBlock s Int16)
extractBlock Image px
img MVector s Int16
block Int
xSamplingFactor Int
ySamplingFactor Int
outputComponentCount
in
Int -> Int -> (Int -> Int -> ST s ()) -> ST s ()
forall (m :: * -> *).
Monad m =>
Int -> Int -> (Int -> Int -> m ()) -> m ()
rasterMap Int
sizeX Int
sizeY ((Int -> Int -> ST s ()) -> ST s ())
-> (Int -> Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \subX :: Int
subX subY :: Int
subY -> do
let !blockY :: Int
blockY = Int
my Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sizeY Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
subY
!blockX :: Int
blockX = Int
mx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sizeX Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
subX
Int16
prev_dc <- MVector s Int16
MVector (PrimState (ST s)) Int16
dc_table MVector (PrimState (ST s)) Int16 -> Int -> ST s Int16
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
comp
MVector s Int16
extracted <- Int -> Int -> Int -> ST s (MVector s Int16)
extractor Int
comp Int
blockX Int
blockY
(dc_coeff :: Int32
dc_coeff, neo_block :: MutableMacroBlock s Int32
neo_block) <- MacroBlock Int16
-> MutableMacroBlock s Int32
-> MutableMacroBlock s Int32
-> Int16
-> MVector s Int16
-> ST s (Int32, MutableMacroBlock s Int32)
forall s.
MacroBlock Int16
-> MutableMacroBlock s Int32
-> MutableMacroBlock s Int32
-> Int16
-> MutableMacroBlock s Int16
-> ST s (Int32, MutableMacroBlock s Int32)
encodeMacroBlock MacroBlock Int16
table MutableMacroBlock s Int32
workData MutableMacroBlock s Int32
zigzaged Int16
prev_dc MVector s Int16
extracted
(MVector s Int16
MVector (PrimState (ST s)) Int16
dc_table MVector (PrimState (ST s)) Int16 -> Int -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
comp) (Int16 -> ST s ()) -> Int16 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int32 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
dc_coeff
BoolWriteStateRef s
-> HuffmanWriterCode
-> HuffmanWriterCode
-> MutableMacroBlock s Int32
-> ST s ()
forall s.
BoolWriteStateRef s
-> HuffmanWriterCode
-> HuffmanWriterCode
-> MutableMacroBlock s Int32
-> ST s ()
serializeMacroBlock BoolWriteStateRef s
writeState HuffmanWriterCode
dc HuffmanWriterCode
ac MutableMacroBlock s Int32
neo_block
BoolWriteStateRef s -> ST s ByteString
forall s. BoolWriteStateRef s -> ST s ByteString
finalizeBoolWriter BoolWriteStateRef s
writeState