{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fspec-constr-count=5 #-}
-- | Module used for JPEG file loading and writing.

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 :: forall s.
MacroBlock Int16
-> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32)
quantize MacroBlock Int16
table MutableMacroBlock s Int32
block = Int -> ST s (MutableMacroBlock s Int32)
update Int
0
  where update :: Int -> ST s (MutableMacroBlock s Int32)
update Int
64 = forall (m :: * -> *) a. Monad m => a -> m a
return MutableMacroBlock s Int32
block
        update Int
idx = do
            Int32
val <- MutableMacroBlock s Int32
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
idx
            let q :: Int32
q = forall a b. (Integral a, Num b) => a -> b
fromIntegral (MacroBlock Int16
table forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` Int
idx)
                finalValue :: Int32
finalValue = (Int32
val forall a. Num a => a -> a -> a
+ (Int32
q forall a. Integral a => a -> a -> a
`div` Int32
2)) forall a. Integral a => a -> a -> a
`quot` Int32
q -- rounded integer division

            (MutableMacroBlock s Int32
block 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 forall a b. (a -> b) -> a -> b
$ Int
idx forall a. Num a => a -> a -> a
+ Int
1


powerOf :: Int32 -> Word32
powerOf :: Int32 -> Word32
powerOf Int32
0 = Word32
0
powerOf Int32
n = Int32 -> Word32 -> Word32
limit Int32
1 Word32
0
    where val :: Int32
val = forall a. Num a => a -> a
abs Int32
n
          limit :: Int32 -> Word32 -> Word32
limit Int32
range Word32
i | Int32
val forall a. Ord a => a -> a -> Bool
< Int32
range = Word32
i
          limit Int32
range Word32
i = Int32 -> Word32 -> Word32
limit (Int32
2 forall a. Num a => a -> a -> a
* Int32
range) (Word32
i forall a. Num a => a -> a -> a
+ Word32
1)

encodeInt :: BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
{-# INLINE encodeInt #-}
encodeInt :: forall s. BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
encodeInt BoolWriteStateRef s
st Word32
ssss Int32
n | Int32
n forall a. Ord a => a -> a -> Bool
> Int32
0 = forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ssss)
encodeInt BoolWriteStateRef s
st Word32
ssss Int32
n         = forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int32
n forall a. Num a => a -> a -> a
- Int32
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ssss)

-- | Assume the macro block is initialized with zeroes

acCoefficientsDecode :: HuffmanPackedTree -> MutableMacroBlock s Int16
                     -> BoolReader s (MutableMacroBlock s Int16)
acCoefficientsDecode :: forall s.
HuffmanPackedTree
-> MutableMacroBlock s Int16
-> BoolReader s (MutableMacroBlock s Int16)
acCoefficientsDecode HuffmanPackedTree
acTree MutableMacroBlock s Int16
mutableBlock = Int -> StateT BoolState (ST s) ()
parseAcCoefficient Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return MutableMacroBlock s Int16
mutableBlock
  where parseAcCoefficient :: Int -> StateT BoolState (ST s) ()
parseAcCoefficient Int
n | Int
n forall a. Ord a => a -> a -> Bool
>= Int
64 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
                             | Bool
otherwise = do
            (Int, Int)
rrrrssss <- forall s. HuffmanPackedTree -> BoolReader s (Int, Int)
decodeRrrrSsss HuffmanPackedTree
acTree
            case (Int, Int)
rrrrssss of
                (  Int
0, Int
0) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                (Int
0xF, Int
0) -> Int -> StateT BoolState (ST s) ()
parseAcCoefficient (Int
n forall a. Num a => a -> a -> a
+ Int
16)
                (Int
rrrr, Int
ssss) -> do
                    Int16
decoded <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Int -> BoolReader s Int32
decodeInt Int
ssss
                    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (MutableMacroBlock s Int16
mutableBlock forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
n forall a. Num a => a -> a -> a
+ Int
rrrr)) Int16
decoded
                    Int -> StateT BoolState (ST s) ()
parseAcCoefficient (Int
n forall a. Num a => a -> a -> a
+ Int
rrrr forall a. Num a => a -> a -> a
+ Int
1)

-- | Decompress a macroblock from a bitstream given the current configuration

-- from the frame.

decompressMacroBlock :: HuffmanPackedTree   -- ^ Tree used for DC coefficient

                     -> HuffmanPackedTree   -- ^ Tree used for Ac coefficient

                     -> MacroBlock Int16    -- ^ Current quantization table

                     -> MutableMacroBlock s Int16    -- ^ A zigzag table, to avoid allocation

                     -> DcCoefficient       -- ^ Previous dc value

                     -> BoolReader s (DcCoefficient, MutableMacroBlock s Int16)
decompressMacroBlock :: forall s.
HuffmanPackedTree
-> HuffmanPackedTree
-> MacroBlock Int16
-> MutableMacroBlock s Int16
-> Int16
-> BoolReader s (Int16, MutableMacroBlock s Int16)
decompressMacroBlock HuffmanPackedTree
dcTree HuffmanPackedTree
acTree MacroBlock Int16
quantizationTable MutableMacroBlock s Int16
zigzagBlock Int16
previousDc = do
    Int16
dcDeltaCoefficient <- forall s. HuffmanPackedTree -> BoolReader s Int16
dcCoefficientDecode HuffmanPackedTree
dcTree
    MutableMacroBlock s Int16
block <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
    let neoDcCoefficient :: Int16
neoDcCoefficient = Int16
previousDc forall a. Num a => a -> a -> a
+ Int16
dcDeltaCoefficient
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
0) Int16
neoDcCoefficient
    MutableMacroBlock s Int16
fullBlock <- forall s.
HuffmanPackedTree
-> MutableMacroBlock s Int16
-> BoolReader s (MutableMacroBlock s Int16)
acCoefficientsDecode HuffmanPackedTree
acTree MutableMacroBlock s Int16
block
    MutableMacroBlock s Int16
decodedBlock <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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
    forall (m :: * -> *) a. Monad m => a -> m a
return (Int16
neoDcCoefficient, MutableMacroBlock s Int16
decodedBlock)

pixelClamp :: Int16 -> Word8
pixelClamp :: Int16 -> Pixel8
pixelClamp Int16
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min Int16
255 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Int16
0 Int16
n

unpack444Y :: Int -- ^ component index

           -> Int -- ^ x

           -> Int -- ^ y

           -> MutableImage s PixelYCbCr8
           -> MutableMacroBlock s Int16
           -> ST s ()
unpack444Y :: forall s.
Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack444Y Int
_ Int
x 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 })
                 MutableMacroBlock s Int16
block = Int -> Int -> Int -> ST s ()
blockVert Int
baseIdx Int
0 Int
zero
  where zero :: Int
zero = Int
0 :: Int
        baseIdx :: Int
baseIdx = Int
x forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
+ Int
y forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
* Int
imgWidth

        blockVert :: Int -> Int -> Int -> ST s ()
blockVert        Int
_       Int
_ Int
j | Int
j forall a. Ord a => a -> a -> Bool
>= forall a. Num a => a
dctBlockSize = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        blockVert Int
writeIdx Int
readingIdx Int
j = Int -> Int -> Int -> ST s ()
blockHoriz Int
writeIdx Int
readingIdx Int
zero
          where blockHoriz :: Int -> Int -> Int -> ST s ()
blockHoriz   Int
_ Int
readIdx Int
i | Int
i forall a. Ord a => a -> a -> Bool
>= forall a. Num a => a
dctBlockSize = Int -> Int -> Int -> ST s ()
blockVert (Int
writeIdx forall a. Num a => a -> a -> a
+ Int
imgWidth) Int
readIdx forall a b. (a -> b) -> a -> b
$ Int
j forall a. Num a => a -> a -> a
+ Int
1
                blockHoriz Int
idx Int
readIdx Int
i = do
                    Pixel8
val <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
readIdx)
                    (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) Pixel8
val
                    Int -> Int -> Int -> ST s ()
blockHoriz (Int
idx forall a. Num a => a -> a -> a
+ Int
1) (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
+ Int
1

unpack444Ycbcr :: Int -- ^ Component index

              -> Int -- ^ x

              -> Int -- ^ y

              -> MutableImage s PixelYCbCr8
              -> MutableMacroBlock s Int16
              -> ST s ()
unpack444Ycbcr :: forall s.
Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack444Ycbcr Int
compIdx Int
x 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 })
                 MutableMacroBlock s Int16
block = Int -> Int -> Int -> ST s ()
blockVert Int
baseIdx Int
0 Int
zero
  where zero :: Int
zero = Int
0 :: Int
        baseIdx :: Int
baseIdx = (Int
x forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
+ Int
y forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
* Int
imgWidth) forall a. Num a => a -> a -> a
* Int
3 forall a. Num a => a -> a -> a
+ Int
compIdx

        blockVert :: Int -> Int -> Int -> ST s ()
blockVert   Int
_       Int
_ Int
j | Int
j forall a. Ord a => a -> a -> Bool
>= forall a. Num a => a
dctBlockSize = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        blockVert Int
idx Int
readIdx Int
j = do
            Pixel8
val0 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
readIdx)
            Pixel8
val1 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1))
            Pixel8
val2 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
2))
            Pixel8
val3 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
3))
            Pixel8
val4 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
4))
            Pixel8
val5 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
5))
            Pixel8
val6 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
6))
            Pixel8
val7 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
7))

            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) Pixel8
val0
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+  Int
3     )) Pixel8
val1
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ (Int
3 forall a. Num a => a -> a -> a
* Int
2))) Pixel8
val2
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ (Int
3 forall a. Num a => a -> a -> a
* Int
3))) Pixel8
val3
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ (Int
3 forall a. Num a => a -> a -> a
* Int
4))) Pixel8
val4
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ (Int
3 forall a. Num a => a -> a -> a
* Int
5))) Pixel8
val5
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ (Int
3 forall a. Num a => a -> a -> a
* Int
6))) Pixel8
val6
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ (Int
3 forall a. Num a => a -> a -> a
* Int
7))) Pixel8
val7

            Int -> Int -> Int -> ST s ()
blockVert (Int
idx forall a. Num a => a -> a -> a
+ Int
3 forall a. Num a => a -> a -> a
* Int
imgWidth) (Int
readIdx forall a. Num a => a -> a -> a
+ forall a. Num a => a
dctBlockSize) forall a b. (a -> b) -> a -> b
$ Int
j forall a. Num a => a -> a -> a
+ Int
1


          {-where blockHoriz   _ readIdx i | i >= 8 = blockVert (writeIdx + imgWidth * 3) readIdx $ j + 1-}
                {-blockHoriz idx readIdx i = do-}
                    {-val <- pixelClamp <$> (block `M.unsafeRead` readIdx) -}
                    {-(img `M.unsafeWrite` idx) val-}
                    {-blockHoriz (idx + 3) (readIdx + 1) $ i + 1-}

unpack421Ycbcr :: Int -- ^ Component index

               -> Int -- ^ x

               -> Int -- ^ y

               -> MutableImage s PixelYCbCr8
               -> MutableMacroBlock s Int16
               -> ST s ()
unpack421Ycbcr :: forall s.
Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack421Ycbcr Int
compIdx Int
x Int
y
                 (MutableImage { mutableImageWidth :: forall s a. MutableImage s a -> Int
mutableImageWidth = Int
imgWidth,
                                 mutableImageHeight :: forall s a. MutableImage s a -> Int
mutableImageHeight = Int
_, mutableImageData :: forall s a. MutableImage s a -> STVector s (PixelBaseComponent a)
mutableImageData = STVector s (PixelBaseComponent PixelYCbCr8)
img })
                 MutableMacroBlock s Int16
block = Int -> Int -> Int -> ST s ()
blockVert Int
baseIdx Int
0 Int
zero
  where zero :: Int
zero = Int
0 :: Int
        baseIdx :: Int
baseIdx = (Int
x forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
+ Int
y forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
* Int
imgWidth) forall a. Num a => a -> a -> a
* Int
3 forall a. Num a => a -> a -> a
+ Int
compIdx
        lineOffset :: Int
lineOffset = Int
imgWidth forall a. Num a => a -> a -> a
* Int
3

        blockVert :: Int -> Int -> Int -> ST s ()
blockVert        Int
_       Int
_ Int
j | Int
j forall a. Ord a => a -> a -> Bool
>= forall a. Num a => a
dctBlockSize = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        blockVert Int
idx Int
readIdx Int
j = do
            Pixel8
v0 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
readIdx)
            Pixel8
v1 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
1))
            Pixel8
v2 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
2))
            Pixel8
v3 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
3))
            Pixel8
v4 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
4))
            Pixel8
v5 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
5))
            Pixel8
v6 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
6))
            Pixel8
v7 <- Int16 -> Pixel8
pixelClamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` (Int
readIdx forall a. Num a => a -> a -> a
+ Int
7))

            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx)       Pixel8
v0
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
3)) Pixel8
v0

            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6    ))      Pixel8
v1
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6     forall a. Num a => a -> a -> a
+ Int
3))  Pixel8
v1

            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Int
2))      Pixel8
v2
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Int
2 forall a. Num a => a -> a -> a
+ Int
3))  Pixel8
v2

            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Int
3))      Pixel8
v3
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Int
3 forall a. Num a => a -> a -> a
+ Int
3))  Pixel8
v3

            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Int
4))      Pixel8
v4
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Int
4 forall a. Num a => a -> a -> a
+ Int
3))  Pixel8
v4

            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Int
5))      Pixel8
v5
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Int
5 forall a. Num a => a -> a -> a
+ Int
3))  Pixel8
v5

            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Int
6))      Pixel8
v6
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Int
6 forall a. Num a => a -> a -> a
+ Int
3))  Pixel8
v6

            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Int
7))      Pixel8
v7
            (STVector s (PixelBaseComponent PixelYCbCr8)
img forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
idx forall a. Num a => a -> a -> a
+ Int
6 forall a. Num a => a -> a -> a
* Int
7 forall a. Num a => a -> a -> a
+ Int
3))  Pixel8
v7

            Int -> Int -> Int -> ST s ()
blockVert (Int
idx forall a. Num a => a -> a -> a
+ Int
lineOffset) (Int
readIdx forall a. Num a => a -> a -> a
+ forall a. Num a => a
dctBlockSize) forall a b. (a -> b) -> a -> b
$ Int
j forall a. Num a => a -> a -> a
+ Int
1

type Unpacker s = Int -- ^ component index

               -> Int -- ^ x

               -> Int -- ^ y

               -> 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 -> [(Pixel8, 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 = JpgDecoderState
    { dcDecoderTables :: Vector HuffmanPackedTree
dcDecoderTables =
        let (JpgHuffmanTableSpec
_, HuffmanPackedTree
dcLuma) = DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Pixel8
0 HuffmanTable
defaultDcLumaHuffmanTable
            (JpgHuffmanTableSpec
_, HuffmanPackedTree
dcChroma) = DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Pixel8
1 HuffmanTable
defaultDcChromaHuffmanTable
        in
        forall a. [a] -> Vector a
V.fromList [ HuffmanPackedTree
dcLuma, HuffmanPackedTree
dcChroma, HuffmanPackedTree
dcLuma, HuffmanPackedTree
dcChroma ]

    , acDecoderTables :: Vector HuffmanPackedTree
acDecoderTables =
        let (JpgHuffmanTableSpec
_, HuffmanPackedTree
acLuma) = DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent Pixel8
0 HuffmanTable
defaultAcLumaHuffmanTable
            (JpgHuffmanTableSpec
_, HuffmanPackedTree
acChroma) = DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent Pixel8
1 HuffmanTable
defaultAcChromaHuffmanTable
        in
        forall a. [a] -> Vector a
V.fromList [HuffmanPackedTree
acLuma, HuffmanPackedTree
acChroma, HuffmanPackedTree
acLuma, HuffmanPackedTree
acChroma]

    , quantizationMatrices :: Vector (MacroBlock Int16)
quantizationMatrices = forall a. Int -> a -> Vector a
V.replicate Int
4 (forall a. Storable a => Int -> a -> Vector a
VS.replicate (Int
8 forall a. Num a => a -> a -> a
* Int
8) Int16
1)
    , currentRestartInterv :: Int
currentRestartInterv = -Int
1
    , currentFrame :: Maybe JpgFrameHeader
currentFrame         = forall a. Maybe a
Nothing
    , componentIndexMapping :: [(Pixel8, Int)]
componentIndexMapping = []
    , app14Marker :: Maybe JpgAdobeApp14
app14Marker = forall a. Maybe a
Nothing
    , app0JFifMarker :: Maybe JpgJFIFApp0
app0JFifMarker = forall a. Maybe a
Nothing
    , app1ExifMarker :: Maybe [ImageFileDirectory]
app1ExifMarker = forall a. Maybe a
Nothing
    , isProgressive :: Bool
isProgressive        = Bool
False
    , maximumHorizontalResolution :: Int
maximumHorizontalResolution = Int
0
    , maximumVerticalResolution :: Int
maximumVerticalResolution   = Int
0
    , seenBlobs :: Int
seenBlobs = Int
0
    }

-- | This pseudo interpreter interpret the Jpg frame for the huffman,

-- quant table and restart interval parameters.

jpgMachineStep :: JpgFrame -> JpgScripter s ()
jpgMachineStep :: forall s. JpgFrame -> JpgScripter s ()
jpgMachineStep (JpgAdobeAPP14 JpgAdobeApp14
app14) = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify forall a b. (a -> b) -> a -> b
$ \JpgDecoderState
s ->
    JpgDecoderState
s { app14Marker :: Maybe JpgAdobeApp14
app14Marker = forall a. a -> Maybe a
Just JpgAdobeApp14
app14 }
jpgMachineStep (JpgExif [ImageFileDirectory]
exif) = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify forall a b. (a -> b) -> a -> b
$ \JpgDecoderState
s ->
    JpgDecoderState
s { app1ExifMarker :: Maybe [ImageFileDirectory]
app1ExifMarker = forall a. a -> Maybe a
Just [ImageFileDirectory]
exif }
jpgMachineStep (JpgJFIF JpgJFIFApp0
app0) = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify forall a b. (a -> b) -> a -> b
$ \JpgDecoderState
s ->
    JpgDecoderState
s { app0JFifMarker :: Maybe JpgJFIFApp0
app0JFifMarker = forall a. a -> Maybe a
Just JpgJFIFApp0
app0 }
jpgMachineStep (JpgAppFrame Pixel8
_ ByteString
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
jpgMachineStep (JpgExtension Pixel8
_ ByteString
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
jpgMachineStep (JpgScanBlob JpgScanHeader
hdr ByteString
raw_data) = do
    let scanCount :: Int
scanCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> [JpgScanSpecification]
scans JpgScanHeader
hdr
    [(JpgUnpackerParameter, Unpacker s)]
params <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)

    forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify forall a b. (a -> b) -> a -> b
$ \JpgDecoderState
st -> JpgDecoderState
st { seenBlobs :: Int
seenBlobs = JpgDecoderState -> Int
seenBlobs JpgDecoderState
st forall a. Num a => a -> a -> a
+ Int
1 }
    forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
tell [([(JpgUnpackerParameter, Unpacker s)]
params, ByteString
raw_data)  ]
  where (Pixel8
selectionLow, Pixel8
selectionHigh) = JpgScanHeader -> (Pixel8, Pixel8)
spectralSelection JpgScanHeader
hdr
        approxHigh :: Int
approxHigh = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> Pixel8
successiveApproxHigh JpgScanHeader
hdr
        approxLow :: Int
approxLow = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> Pixel8
successiveApproxLow JpgScanHeader
hdr

        
        scanSpecifier :: Int
-> JpgScanSpecification
-> RWST
     ()
     [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
     JpgDecoderState
     Identity
     [(JpgUnpackerParameter, Unpacker s)]
scanSpecifier Int
scanCount JpgScanSpecification
scanSpec = do
            [(Pixel8, Int)]
compMapping <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets JpgDecoderState -> [(Pixel8, Int)]
componentIndexMapping
            Int
comp <- case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (JpgScanSpecification -> Pixel8
componentSelector JpgScanSpecification
scanSpec) [(Pixel8, Int)]
compMapping of
                Maybe Int
Nothing -> forall a. HasCallStack => String -> a
error String
"Jpg decoding error - bad component selector in blob."
                Just Int
v -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
v
            let maximumHuffmanTable :: Int
maximumHuffmanTable = Int
4
                dcIndex :: Int
dcIndex = forall a. Ord a => a -> a -> a
min (Int
maximumHuffmanTable forall a. Num a => a -> a -> a
- Int
1) 
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgScanSpecification -> Pixel8
dcEntropyCodingTable JpgScanSpecification
scanSpec
                acIndex :: Int
acIndex = forall a. Ord a => a -> a -> a
min (Int
maximumHuffmanTable forall a. Num a => a -> a -> a
- Int
1)
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgScanSpecification -> Pixel8
acEntropyCodingTable JpgScanSpecification
scanSpec

            HuffmanPackedTree
dcTree <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall a b. (a -> b) -> a -> b
$ (forall a. Vector a -> Int -> a
V.! Int
dcIndex) forall b c a. (b -> c) -> (a -> b) -> a -> c
. JpgDecoderState -> Vector HuffmanPackedTree
dcDecoderTables
            HuffmanPackedTree
acTree <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall a b. (a -> b) -> a -> b
$ (forall a. Vector a -> Int -> a
V.! Int
acIndex) forall b c a. (b -> c) -> (a -> b) -> a -> c
. JpgDecoderState -> Vector HuffmanPackedTree
acDecoderTables
            Bool
isProgressiveImage <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets JpgDecoderState -> Bool
isProgressive
            Int
maxiW <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets JpgDecoderState -> Int
maximumHorizontalResolution 
            Int
maxiH <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets JpgDecoderState -> Int
maximumVerticalResolution
            Int
restart <- 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 <- 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 <- 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
              Maybe JpgFrameHeader
Nothing -> forall a. HasCallStack => String -> a
error String
"Jpg decoding error - no previous frame"
              Just JpgFrameHeader
v -> do
                 let compDesc :: JpgComponent
compDesc = JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
v forall a. [a] -> Int -> a
!! Int
comp
                     compCount :: Int
compCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
v
                     xSampling :: Int
xSampling = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgComponent -> Pixel8
horizontalSamplingFactor JpgComponent
compDesc
                     ySampling :: Int
ySampling = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgComponent -> Pixel8
verticalSamplingFactor JpgComponent
compDesc
                     componentSubSampling :: (Int, Int)
componentSubSampling =
                        (Int
maxiW forall a. Num a => a -> a -> a
- Int
xSampling forall a. Num a => a -> a -> a
+ Int
1, Int
maxiH forall a. Num a => a -> a -> a
- Int
ySampling forall a. Num a => a -> a -> a
+ Int
1)
                     (Int
xCount, Int
yCount)
                        | Int
scanCount forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| Bool
isProgressiveImage = (Int
xSampling, Int
ySampling)
                        | Bool
otherwise = (Int
1, Int
1)

                 forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (JpgUnpackerParameter
                         { dcHuffmanTree :: HuffmanPackedTree
dcHuffmanTree = HuffmanPackedTree
dcTree
                         , acHuffmanTree :: HuffmanPackedTree
acHuffmanTree = HuffmanPackedTree
acTree
                         , componentIndex :: Int
componentIndex = Int
comp
                         , restartInterval :: Int
restartInterval = 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 forall a. Eq a => a -> a -> Bool
== Int
1 then Int
0 else Int
1
                         , coefficientRange :: (Int, Int)
coefficientRange =
                             ( forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
selectionLow
                             , forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
selectionHigh )
                         , blockIndex :: Int
blockIndex = Int
y forall a. Num a => a -> a -> a
* Int
xSampling forall a. Num a => a -> a -> a
+ Int
x
                         , blockMcuX :: Int
blockMcuX = Int
x
                         , blockMcuY :: Int
blockMcuY = Int
y
                         }, forall s. Int -> (Int, Int) -> Unpacker s
unpackerDecision Int
compCount (Int, Int)
componentSubSampling)
                             | Int
y <- [Int
0 .. Int
yCount forall a. Num a => a -> a -> a
- Int
1]
                             , Int
x <- [Int
0 .. Int
xCount forall a. Num a => a -> a -> a
- Int
1] ]

jpgMachineStep (JpgScans JpgFrameKind
kind JpgFrameHeader
hdr) = forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify forall a b. (a -> b) -> a -> b
$ \JpgDecoderState
s ->
   JpgDecoderState
s { currentFrame :: Maybe JpgFrameHeader
currentFrame = forall a. a -> Maybe a
Just JpgFrameHeader
hdr
     , componentIndexMapping :: [(Pixel8, Int)]
componentIndexMapping =
          [(JpgComponent -> Pixel8
componentIdentifier JpgComponent
comp, Int
ix) | (Int
ix, JpgComponent
comp) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
hdr]
     , isProgressive :: Bool
isProgressive = case JpgFrameKind
kind of
            JpgFrameKind
JpgProgressiveDCTHuffman -> Bool
True
            JpgFrameKind
_ -> Bool
False
     , maximumHorizontalResolution :: Int
maximumHorizontalResolution =
         forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Pixel8]
horizontalResolutions
     , maximumVerticalResolution :: Int
maximumVerticalResolution =
         forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Pixel8]
verticalResolutions
     }
    where components :: [JpgComponent]
components = JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
hdr
          horizontalResolutions :: [Pixel8]
horizontalResolutions = forall a b. (a -> b) -> [a] -> [b]
map JpgComponent -> Pixel8
horizontalSamplingFactor [JpgComponent]
components
          verticalResolutions :: [Pixel8]
verticalResolutions = forall a b. (a -> b) -> [a] -> [b]
map JpgComponent -> Pixel8
verticalSamplingFactor [JpgComponent]
components
jpgMachineStep (JpgIntervalRestart Word16
restart) =
    forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify forall a b. (a -> b) -> a -> b
$ \JpgDecoderState
s -> JpgDecoderState
s { currentRestartInterv :: Int
currentRestartInterv = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
restart }
jpgMachineStep (JpgHuffmanTable [(JpgHuffmanTableSpec, HuffmanPackedTree)]
tables) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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 (JpgHuffmanTableSpec
spec, HuffmanPackedTree
tree) = case JpgHuffmanTableSpec -> DctComponent
huffmanTableClass JpgHuffmanTableSpec
spec of
            DctComponent
DcComponent -> forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify forall a b. (a -> b) -> a -> b
$ \JpgDecoderState
s ->
              if Int
idx forall a. Ord a => a -> a -> Bool
>= 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 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Pixel8
huffmanTableDest JpgHuffmanTableSpec
spec
                          
            DctComponent
AcComponent -> forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify forall a b. (a -> b) -> a -> b
$ \JpgDecoderState
s ->
              if Int
idx forall a. Ord a => a -> a -> Bool
>= 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 forall a. Vector a -> [(Int, a)] -> Vector a
// [(Int
idx, HuffmanPackedTree
tree)] }
                    where idx :: Int
idx = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Pixel8
huffmanTableDest JpgHuffmanTableSpec
spec

jpgMachineStep (JpgQuantTable [JpgQuantTableSpec]
tables) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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 JpgQuantTableSpec
table = do
            let idx :: Int
idx = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgQuantTableSpec -> Pixel8
quantDestination JpgQuantTableSpec
table
                tableData :: MacroBlock Int16
tableData = JpgQuantTableSpec -> MacroBlock Int16
quantTable JpgQuantTableSpec
table
            forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify forall a b. (a -> b) -> a -> b
$ \JpgDecoderState
s ->
                JpgDecoderState
s { quantizationMatrices :: Vector (MacroBlock Int16)
quantizationMatrices =  JpgDecoderState -> Vector (MacroBlock Int16)
quantizationMatrices JpgDecoderState
s forall a. Vector a -> [(Int, a)] -> Vector a
// [(Int
idx, MacroBlock Int16
tableData)] }

unpackerDecision :: Int -> (Int, Int) -> Unpacker s
unpackerDecision :: forall s. Int -> (Int, Int) -> Unpacker s
unpackerDecision Int
1 (Int
1, Int
1) = forall s.
Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack444Y
unpackerDecision Int
3 (Int
1, Int
1) = forall s.
Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack444Ycbcr
unpackerDecision Int
_ (Int
2, Int
1) = forall s.
Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack421Ycbcr
unpackerDecision Int
compCount (Int
xScalingFactor, Int
yScalingFactor) =
    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 -- ^ Result image to write into

            -> ST s (MutableImage s PixelYCbCr8)
decodeImage :: forall s.
JpgFrameHeader
-> Vector (MacroBlock Int16)
-> [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
-> MutableImage s PixelYCbCr8
-> ST s (MutableImage s PixelYCbCr8)
decodeImage JpgFrameHeader
frame Vector (MacroBlock Int16)
quants [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
lst MutableImage s PixelYCbCr8
outImage = do
  let compCount :: Int
compCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
frame
  MutableMacroBlock s Int16
zigZagArray <- forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
  MutableMacroBlock s Int16
dcArray <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate Int
compCount Int16
0  :: ST s (M.STVector s DcCoefficient)
  STRef s Int
resetCounter <- forall a s. a -> ST s (STRef s a)
newSTRef Int
restartIntervalValue

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
lst forall a b. (a -> b) -> a -> b
$ \([(JpgUnpackerParameter, Unpacker s)]
params, ByteString
str) -> do
    let componentsInfo :: Vector (JpgUnpackerParameter, Unpacker s)
componentsInfo = forall a. [a] -> Vector a
V.fromList [(JpgUnpackerParameter, Unpacker s)]
params
        compReader :: BoolState
compReader = ByteString -> BoolState
initBoolStateJpg forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.concat forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks ByteString
str
        maxiSubSampW :: Int
maxiSubSampW = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ JpgUnpackerParameter -> (Int, Int)
subSampling JpgUnpackerParameter
c | (JpgUnpackerParameter
c,Unpacker s
_) <- [(JpgUnpackerParameter, Unpacker s)]
params]
        maxiSubSampH :: Int
maxiSubSampH = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ JpgUnpackerParameter -> (Int, Int)
subSampling JpgUnpackerParameter
c | (JpgUnpackerParameter
c,Unpacker s
_) <- [(JpgUnpackerParameter, Unpacker s)]
params]

        (Int
maxiW, Int
maxiH) = 
            if forall (t :: * -> *) a. Foldable t => t a -> Int
length [(JpgUnpackerParameter, Unpacker s)]
params forall a. Ord a => a -> a -> Bool
> Int
1 then
                (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [JpgUnpackerParameter -> Int
componentWidth JpgUnpackerParameter
c | (JpgUnpackerParameter
c,Unpacker s
_) <- [(JpgUnpackerParameter, Unpacker s)]
params], 
                    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [JpgUnpackerParameter -> Int
componentHeight JpgUnpackerParameter
c | (JpgUnpackerParameter
c,Unpacker s
_) <- [(JpgUnpackerParameter, Unpacker s)]
params])
            else
                (Int
maxiSubSampW, Int
maxiSubSampH)

        imageBlockWidth :: Int
imageBlockWidth = Int -> Int
toBlockSize Int
imgWidth
        imageBlockHeight :: Int
imageBlockHeight = Int -> Int
toBlockSize Int
imgHeight

        imageMcuWidth :: Int
imageMcuWidth = (Int
imageBlockWidth forall a. Num a => a -> a -> a
+ (Int
maxiW forall a. Num a => a -> a -> a
- Int
1)) forall a. Integral a => a -> a -> a
`div` Int
maxiW
        imageMcuHeight :: Int
imageMcuHeight = (Int
imageBlockHeight forall a. Num a => a -> a -> a
+ (Int
maxiH forall a. Num a => a -> a -> a
- Int
1)) forall a. Integral a => a -> a -> a
`div` Int
maxiH

    forall s a. BoolState -> BoolReader s a -> ST s BoolState
execBoolReader BoolState
compReader forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
Int -> Int -> (Int -> Int -> m ()) -> m ()
rasterMap Int
imageMcuWidth Int
imageMcuHeight forall a b. (a -> b) -> a -> b
$ \Int
x Int
y -> do
      Int
resetLeft <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s Int
resetCounter
      if Int
resetLeft forall a. Eq a => a -> a -> Bool
== Int
0 then do
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> a -> m ()
M.set MutableMacroBlock s Int16
dcArray Int16
0
        forall s. BoolReader s ()
byteAlignJpg
        Int32
_restartCode <- forall s. BoolReader s Int32
decodeRestartInterval
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ STRef s Int
resetCounter forall s a. STRef s a -> a -> ST s ()
`writeSTRef` (Int
restartIntervalValue forall a. Num a => a -> a -> a
- Int
1)
      else
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ STRef s Int
resetCounter forall s a. STRef s a -> a -> ST s ()
`writeSTRef` (Int
resetLeft forall a. Num a => a -> a -> a
- Int
1)

      forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
V.forM_ Vector (JpgUnpackerParameter, Unpacker s)
componentsInfo forall a b. (a -> b) -> a -> b
$ \(JpgUnpackerParameter
comp, 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
.  JpgComponent -> Pixel8
quantizationTableDest
                    forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
frame forall a. [a] -> Int -> a
!! Int
compIdx
            qTable :: MacroBlock Int16
qTable = Vector (MacroBlock Int16)
quants forall a. Vector a -> Int -> a
V.! forall a. Ord a => a -> a -> a
min Int
3 Int
quantId
            xd :: Int
xd = JpgUnpackerParameter -> Int
blockMcuX JpgUnpackerParameter
comp
            yd :: Int
yd = JpgUnpackerParameter -> Int
blockMcuY JpgUnpackerParameter
comp
            (Int
subX, Int
subY) = JpgUnpackerParameter -> (Int, Int)
subSampling JpgUnpackerParameter
comp
        Int16
dc <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ MutableMacroBlock s Int16
dcArray forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
compIdx
        (Int16
dcCoeff, MutableMacroBlock s Int16
block) <-
              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 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
dc
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (MutableMacroBlock s Int16
dcArray 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 forall a. Eq a => a -> a -> Bool
== Int
imageMcuHeight forall a. Num a => a -> a -> a
- Int
1
        if (Int
x forall a. Eq a => a -> a -> Bool
== Int
imageMcuWidth forall a. Num a => a -> a -> a
- Int
1) Bool -> Bool -> Bool
|| Bool
verticalLimited then
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 forall a. Num a => a -> a -> a
* Int
maxiW forall a. Num a => a -> a -> a
+ Int
xd) (Int
y forall a. Num a => a -> a -> a
* Int
maxiH forall a. Num a => a -> a -> a
+ Int
yd) MutableImage s PixelYCbCr8
outImage MutableMacroBlock s Int16
block
        else
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Unpacker s
unpack Int
compIdx (Int
x forall a. Num a => a -> a -> a
* Int
maxiW forall a. Num a => a -> a -> a
+ Int
xd) (Int
y forall a. Num a => a -> a -> a
* Int
maxiH forall a. Num a => a -> a -> a
+ Int
yd) MutableImage s PixelYCbCr8
outImage MutableMacroBlock s Int16
block

  forall (m :: * -> *) a. Monad m => a -> m a
return MutableImage s PixelYCbCr8
outImage

  where imgComponentCount :: Int
imgComponentCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
frame

        imgWidth :: Int
imgWidth = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgWidth JpgFrameHeader
frame
        imgHeight :: Int
imgHeight = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgHeight JpgFrameHeader
frame
        restartIntervalValue :: Int
restartIntervalValue = case [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
lst of
                ((JpgUnpackerParameter
p,Unpacker s
_):[(JpgUnpackerParameter, Unpacker s)]
_,ByteString
_): [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
_ -> JpgUnpackerParameter -> Int
restartInterval JpgUnpackerParameter
p
                [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
_ -> -Int
1

gatherImageKind :: [JpgFrame] -> Maybe JpgImageKind
gatherImageKind :: [JpgFrame] -> Maybe JpgImageKind
gatherImageKind [JpgFrame]
lst = case [JpgFrameKind
k | JpgScans JpgFrameKind
k JpgFrameHeader
_ <- [JpgFrame]
lst, JpgFrameKind -> Bool
isDctSpecifier JpgFrameKind
k] of
    [JpgFrameKind
JpgBaselineDCTHuffman] -> forall a. a -> Maybe a
Just JpgImageKind
BaseLineDCT
    [JpgFrameKind
JpgProgressiveDCTHuffman] -> forall a. a -> Maybe a
Just JpgImageKind
ProgressiveDCT
    [JpgFrameKind
JpgExtendedSequentialDCTHuffman] -> forall a. a -> Maybe a
Just JpgImageKind
BaseLineDCT
    [JpgFrameKind]
_ -> forall a. Maybe a
Nothing
  where isDctSpecifier :: JpgFrameKind -> Bool
isDctSpecifier JpgFrameKind
JpgProgressiveDCTHuffman = Bool
True
        isDctSpecifier JpgFrameKind
JpgBaselineDCTHuffman = Bool
True
        isDctSpecifier JpgFrameKind
JpgExtendedSequentialDCTHuffman = Bool
True
        isDctSpecifier JpgFrameKind
_ = Bool
False

gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader)
gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader)
gatherScanInfo JpgImage
img = forall a. [a] -> a
head [(JpgFrameKind
a, JpgFrameHeader
b) | JpgScans JpgFrameKind
a JpgFrameHeader
b <- JpgImage -> [JpgFrame]
jpgFrame JpgImage
img]

dynamicOfColorSpace :: Maybe JpgColorSpace -> Int -> Int -> VS.Vector Word8
                    -> Either String DynamicImage
dynamicOfColorSpace :: Maybe JpgColorSpace
-> Int -> Int -> Vector Pixel8 -> Either String DynamicImage
dynamicOfColorSpace Maybe JpgColorSpace
Nothing Int
_ Int
_ Vector Pixel8
_ = forall a b. a -> Either a b
Left String
"Unknown color space"
dynamicOfColorSpace (Just JpgColorSpace
color) Int
w Int
h Vector Pixel8
imgData = case JpgColorSpace
color of
  JpgColorSpace
JpgColorSpaceCMYK -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelCMYK8 -> DynamicImage
ImageCMYK8 forall a b. (a -> b) -> a -> b
$ forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Pixel8
imgData
  JpgColorSpace
JpgColorSpaceYCCK ->
     let ymg :: Image PixelYCbCrK8
ymg = forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h forall a b. (a -> b) -> a -> b
$ forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
VS.map (Pixel8
255forall a. Num a => a -> a -> a
-) Vector Pixel8
imgData :: Image PixelYCbCrK8 in
     forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelCMYK8 -> DynamicImage
ImageCMYK8 forall a b. (a -> b) -> a -> b
$ forall a b. ColorSpaceConvertible a b => Image a -> Image b
convertImage Image PixelYCbCrK8
ymg
  JpgColorSpace
JpgColorSpaceYCbCr -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYCbCr8 -> DynamicImage
ImageYCbCr8 forall a b. (a -> b) -> a -> b
$ forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Pixel8
imgData
  JpgColorSpace
JpgColorSpaceRGB -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 forall a b. (a -> b) -> a -> b
$ forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Pixel8
imgData
  JpgColorSpace
JpgColorSpaceYA -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYA8 -> DynamicImage
ImageYA8 forall a b. (a -> b) -> a -> b
$ forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Pixel8
imgData
  JpgColorSpace
JpgColorSpaceY -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Pixel8 -> DynamicImage
ImageY8 forall a b. (a -> b) -> a -> b
$ forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Pixel8
imgData
  JpgColorSpace
colorSpace -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Wrong color space : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show JpgColorSpace
colorSpace

colorSpaceOfAdobe :: Int -> JpgAdobeApp14 -> Maybe JpgColorSpace
colorSpaceOfAdobe :: Int -> JpgAdobeApp14 -> Maybe JpgColorSpace
colorSpaceOfAdobe Int
compCount JpgAdobeApp14
app = case (Int
compCount, JpgAdobeApp14 -> AdobeTransform
_adobeTransform JpgAdobeApp14
app) of
  (Int
3, AdobeTransform
AdobeYCbCr) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYCbCr
  (Int
1, AdobeTransform
AdobeUnknown) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceY
  (Int
3, AdobeTransform
AdobeUnknown) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceRGB
  (Int
4, AdobeTransform
AdobeYCck) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYCCK
  {-(4, AdobeUnknown) -> pure JpgColorSpaceCMYKInverted-}
  (Int, AdobeTransform)
_ -> forall a. Maybe a
Nothing

colorSpaceOfState :: JpgDecoderState -> Maybe JpgColorSpace
colorSpaceOfState :: JpgDecoderState -> Maybe JpgColorSpace
colorSpaceOfState JpgDecoderState
st = do
  JpgFrameHeader
hdr <- JpgDecoderState -> Maybe JpgFrameHeader
currentFrame JpgDecoderState
st
  let compStr :: String
compStr = [forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ JpgComponent -> Pixel8
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 (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
compStr) JpgAdobeApp14
marker
  Maybe JpgColorSpace
app14 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Maybe JpgColorSpace
colorSpaceOfComponentStr String
compStr


colorSpaceOfComponentStr :: String -> Maybe JpgColorSpace
colorSpaceOfComponentStr :: String -> Maybe JpgColorSpace
colorSpaceOfComponentStr String
s = case String
s of
  [Char
_] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceY
  [Char
_,Char
_] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceYA
  String
"\0\1\2" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceYCbCr
  String
"\1\2\3" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceYCbCr
  String
"RGB" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceRGB
  String
"YCc" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceYCC
  [Char
_,Char
_,Char
_] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceYCbCr

  String
"RGBA" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceRGBA
  String
"YCcA" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceYCCA
  String
"CMYK" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceCMYK
  String
"YCcK" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceYCCK
  [Char
_,Char
_,Char
_,Char
_] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceCMYK
  String
_ -> forall a. Maybe a
Nothing

-- | Try to decompress and decode a jpeg file. The colorspace is still

-- YCbCr if you want to perform computation on the luma part. You can convert it

-- to RGB using 'convertImage' from the 'ColorSpaceConvertible' typeclass.

--

-- This function can output the following images:

--

--  * 'ImageY8'

--

--  * 'ImageYA8'

--

--  * 'ImageRGB8'

--

--  * 'ImageCMYK8'

--

--  * 'ImageYCbCr8'

--

decodeJpeg :: B.ByteString -> Either String DynamicImage
decodeJpeg :: ByteString -> Either String DynamicImage
decodeJpeg = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String (DynamicImage, Metadatas)
decodeJpegWithMetadata

-- | Equivalent to 'decodeJpeg' but also extracts metadatas.

--

-- Extract the following metadatas from the JFIF block:

--

--  * 'Codec.Picture.Metadata.DpiX'

--  * 'Codec.Picture.Metadata.DpiY' 

--

-- Exif metadata are also extracted if present.

--

decodeJpegWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
decodeJpegWithMetadata :: ByteString -> Either String (DynamicImage, Metadatas)
decodeJpegWithMetadata ByteString
file = case forall a. Get a -> ByteString -> Either String a
runGetStrict forall t. Binary t => Get t
get ByteString
file of
  Left String
err -> forall a b. a -> Either a b
Left String
err
  Right JpgImage
img -> case Maybe JpgImageKind
imgKind of
     Just JpgImageKind
BaseLineDCT ->
       let (JpgDecoderState
st, Vector Pixel8
arr) = (JpgDecoderState, Vector Pixel8)
decodeBaseline
           jfifMeta :: Metadatas
jfifMeta = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap JpgJFIFApp0 -> Metadatas
extractMetadatas forall a b. (a -> b) -> a -> b
$ JpgDecoderState -> Maybe JpgJFIFApp0
app0JFifMarker JpgDecoderState
st
           exifMeta :: Metadatas
exifMeta = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [ImageFileDirectory] -> Metadatas
extractTiffMetadata forall a b. (a -> b) -> a -> b
$ JpgDecoderState -> Maybe [ImageFileDirectory]
app1ExifMarker JpgDecoderState
st
           meta :: Metadatas
meta = Metadatas
jfifMeta forall a. Semigroup a => a -> a -> a
<> Metadatas
exifMeta forall a. Semigroup a => a -> a -> a
<> Metadatas
sizeMeta
       in
       (, Metadatas
meta) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
           Maybe JpgColorSpace
-> Int -> Int -> Vector Pixel8 -> Either String DynamicImage
dynamicOfColorSpace (JpgDecoderState -> Maybe JpgColorSpace
colorSpaceOfState JpgDecoderState
st) Int
imgWidth Int
imgHeight Vector Pixel8
arr
     Just JpgImageKind
ProgressiveDCT ->
       let (JpgDecoderState
st, Vector Pixel8
arr) = (JpgDecoderState, Vector Pixel8)
decodeProgressive
           jfifMeta :: Metadatas
jfifMeta = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap JpgJFIFApp0 -> Metadatas
extractMetadatas forall a b. (a -> b) -> a -> b
$ JpgDecoderState -> Maybe JpgJFIFApp0
app0JFifMarker JpgDecoderState
st
           exifMeta :: Metadatas
exifMeta = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [ImageFileDirectory] -> Metadatas
extractTiffMetadata forall a b. (a -> b) -> a -> b
$ JpgDecoderState -> Maybe [ImageFileDirectory]
app1ExifMarker JpgDecoderState
st
           meta :: Metadatas
meta = Metadatas
jfifMeta forall a. Semigroup a => a -> a -> a
<> Metadatas
exifMeta forall a. Semigroup a => a -> a -> a
<> Metadatas
sizeMeta
       in
       (, Metadatas
meta) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
           Maybe JpgColorSpace
-> Int -> Int -> Vector Pixel8 -> Either String DynamicImage
dynamicOfColorSpace (JpgDecoderState -> Maybe JpgColorSpace
colorSpaceOfState JpgDecoderState
st) Int
imgWidth Int
imgHeight Vector Pixel8
arr
     Maybe JpgImageKind
_ -> forall a b. a -> Either a b
Left String
"Unknown JPG kind"
    where
      compCount :: Int
compCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
scanInfo
      (JpgFrameKind
_,JpgFrameHeader
scanInfo) = JpgImage -> (JpgFrameKind, JpgFrameHeader)
gatherScanInfo JpgImage
img

      imgKind :: Maybe JpgImageKind
imgKind = [JpgFrame] -> Maybe JpgImageKind
gatherImageKind forall a b. (a -> b) -> a -> b
$ JpgImage -> [JpgFrame]
jpgFrame JpgImage
img
      imgWidth :: Int
imgWidth = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgWidth JpgFrameHeader
scanInfo
      imgHeight :: Int
imgHeight = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgHeight JpgFrameHeader
scanInfo

      sizeMeta :: Metadatas
sizeMeta = forall nSize.
Integral nSize =>
SourceFormat -> nSize -> nSize -> Metadatas
basicMetadata SourceFormat
SourceJpeg Int
imgWidth Int
imgHeight

      imageSize :: Int
imageSize = Int
imgWidth forall a. Num a => a -> a -> a
* Int
imgHeight forall a. Num a => a -> a -> a
* Int
compCount


      decodeProgressive :: (JpgDecoderState, Vector Pixel8)
decodeProgressive = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
        let (JpgDecoderState
st, [([(JpgUnpackerParameter, Unpacker Any)], ByteString)]
wrotten) =
               forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall s. JpgFrame -> JpgScripter s ()
jpgMachineStep (JpgImage -> [JpgFrame]
jpgFrame JpgImage
img)) () JpgDecoderState
emptyDecoderState
            Just JpgFrameHeader
fHdr = JpgDecoderState -> Maybe JpgFrameHeader
currentFrame JpgDecoderState
st
        MutableImage s PixelYCbCr8
fimg <-
            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 <- forall a (m :: * -> *).
(Storable (PixelBaseComponent a), PrimMonad m) =>
MutableImage (PrimState m) a -> m (Image a)
unsafeFreezeImage MutableImage s PixelYCbCr8
fimg
        forall (m :: * -> *) a. Monad m => a -> m a
return (JpgDecoderState
st, forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image PixelYCbCr8
frozen)


      decodeBaseline :: (JpgDecoderState, Vector Pixel8)
decodeBaseline = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
        let (JpgDecoderState
st, [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
wrotten) =
              forall r w s a. RWS r w s a -> r -> s -> (s, w)
execRWS (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall s. JpgFrame -> JpgScripter s ()
jpgMachineStep (JpgImage -> [JpgFrame]
jpgFrame JpgImage
img)) () JpgDecoderState
emptyDecoderState
            Just JpgFrameHeader
fHdr = JpgDecoderState -> Maybe JpgFrameHeader
currentFrame JpgDecoderState
st
        MVector s Pixel8
resultImage <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
imageSize
        let wrapped :: MutableImage s PixelYCbCr8
wrapped = forall s a.
Int -> Int -> STVector s (PixelBaseComponent a) -> MutableImage s a
MutableImage Int
imgWidth Int
imgHeight MVector s Pixel8
resultImage
        MutableImage s PixelYCbCr8
fImg <- 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 <- forall a (m :: * -> *).
(Storable (PixelBaseComponent a), PrimMonad m) =>
MutableImage (PrimState m) a -> m (Image a)
unsafeFreezeImage MutableImage s PixelYCbCr8
fImg
        forall (m :: * -> *) a. Monad m => a -> m a
return (JpgDecoderState
st, forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image PixelYCbCr8
frozen)

extractBlock :: forall s px. (PixelBaseComponent px ~ Word8)
             => Image px       -- ^ Source image

             -> MutableMacroBlock s Int16      -- ^ Mutable block where to put extracted block

             -> Int                     -- ^ Plane

             -> Int                     -- ^ X sampling factor

             -> Int                     -- ^ Y sampling factor

             -> Int                     -- ^ Sample per pixel

             -> Int                     -- ^ Block x

             -> Int                     -- ^ Block y

             -> ST s (MutableMacroBlock s Int16)
extractBlock :: forall s px.
(PixelBaseComponent px ~ Pixel8) =>
Image px
-> MutableMacroBlock s Int16
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> ST s (MutableMacroBlock s Int16)
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 })
             MutableMacroBlock s Int16
block Int
1 Int
1 Int
sampCount Int
plane Int
bx Int
by | (Int
bx forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize) forall a. Num a => a -> a -> a
+ Int
7 forall a. Ord a => a -> a -> Bool
< Int
w Bool -> Bool -> Bool
&& (Int
by forall a. Num a => a -> a -> a
* Int
8) forall a. Num a => a -> a -> a
+ Int
7 forall a. Ord a => a -> a -> Bool
< Int
h = do
    let baseReadIdx :: Int
baseReadIdx = (Int
by forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
* Int
w) forall a. Num a => a -> a -> a
+ Int
bx forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [(MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
y forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
+ Int
x)) Int16
val
                        | Int
y <- [Int
0 .. forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
- Int
1]
                        , let blockReadIdx :: Int
blockReadIdx = Int
baseReadIdx forall a. Num a => a -> a -> a
+ Int
y forall a. Num a => a -> a -> a
* Int
w
                        , Int
x <- [Int
0 .. forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
- Int
1]
                        , let val :: Int16
val = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Vector (PixelBaseComponent px)
src forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` ((Int
blockReadIdx forall a. Num a => a -> a -> a
+ Int
x) forall a. Num a => a -> a -> a
* Int
sampCount forall a. Num a => a -> a -> a
+ Int
plane)
                        ]
    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 })
             MutableMacroBlock s Int16
block Int
sampWidth Int
sampHeight Int
sampCount Int
plane Int
bx Int
by = do
    let accessPixel :: Int -> Int -> Pixel8
accessPixel Int
x Int
y | Int
x forall a. Ord a => a -> a -> Bool
< Int
w Bool -> Bool -> Bool
&& Int
y forall a. Ord a => a -> a -> Bool
< Int
h = let idx :: Int
idx = (Int
y forall a. Num a => a -> a -> a
* Int
w forall a. Num a => a -> a -> a
+ Int
x) forall a. Num a => a -> a -> a
* Int
sampCount forall a. Num a => a -> a -> a
+ Int
plane in Vector (PixelBaseComponent px)
src forall a. Storable a => Vector a -> Int -> a
`VS.unsafeIndex` Int
idx
                        | Int
x forall a. Ord a => a -> a -> Bool
>= Int
w = Int -> Int -> Pixel8
accessPixel (Int
w forall a. Num a => a -> a -> a
- Int
1) Int
y
                        | Bool
otherwise = Int -> Int -> Pixel8
accessPixel Int
x (Int
h forall a. Num a => a -> a -> a
- Int
1)

        pixelPerCoeff :: Int16
pixelPerCoeff = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
sampWidth forall a. Num a => a -> a -> a
* Int
sampHeight

        blockVal :: Int -> Int -> Int16
blockVal Int
x Int
y = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int -> Int -> Pixel8
accessPixel (Int
xBase forall a. Num a => a -> a -> a
+ Int
dx) (Int
yBase forall a. Num a => a -> a -> a
+ Int
dy)
                                | Int
dy <- [Int
0 .. Int
sampHeight forall a. Num a => a -> a -> a
- Int
1]
                                , Int
dx <- [Int
0 .. Int
sampWidth forall a. Num a => a -> a -> a
- Int
1] ] forall a. Integral a => a -> a -> a
`div` Int16
pixelPerCoeff
            where xBase :: Int
xBase = Int
blockXBegin forall a. Num a => a -> a -> a
+ Int
x forall a. Num a => a -> a -> a
* Int
sampWidth
                  yBase :: Int
yBase = Int
blockYBegin forall a. Num a => a -> a -> a
+ Int
y forall a. Num a => a -> a -> a
* Int
sampHeight

        blockXBegin :: Int
blockXBegin = Int
bx forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
* Int
sampWidth
        blockYBegin :: Int
blockYBegin = Int
by forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
* Int
sampHeight

    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [(MutableMacroBlock s Int16
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
y forall a. Num a => a -> a -> a
* forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
+ Int
x)) forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int16
blockVal Int
x Int
y | Int
y <- [Int
0 .. Int
7], Int
x <- [Int
0 .. Int
7] ]
    forall (m :: * -> *) a. Monad m => a -> m a
return MutableMacroBlock s Int16
block

serializeMacroBlock :: BoolWriteStateRef s
                    -> HuffmanWriterCode -> HuffmanWriterCode
                    -> MutableMacroBlock s Int32
                    -> ST s ()
serializeMacroBlock :: forall s.
BoolWriteStateRef s
-> HuffmanWriterCode
-> HuffmanWriterCode
-> MutableMacroBlock s Int32
-> ST s ()
serializeMacroBlock !BoolWriteStateRef s
st !HuffmanWriterCode
dcCode !HuffmanWriterCode
acCode !MutableMacroBlock s Int32
blk =
 (MutableMacroBlock s Int32
blk forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
0) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b. (Integral a, Num b) => a -> b
fromIntegral 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) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Word32, Int) -> ST s ()
writeAcs (Word32
0, Int
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where writeAcs :: (Word32, Int) -> ST s ()
writeAcs acc :: (Word32, Int)
acc@(Word32
_, Int
63) =
            (MutableMacroBlock s Int32
blk forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
63) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b. (Integral a, Num b) => a -> b
fromIntegral 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) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        writeAcs acc :: (Word32, Int)
acc@(Word32
_, Int
i ) =
            (MutableMacroBlock s Int32
blk forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead`  Int
i) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a b. (Integral a, Num b) => a -> b
fromIntegral 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) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Word32, Int) -> ST s ()
writeAcs

        encodeDc :: Int32 -> ST s ()
encodeDc Int32
n = forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
code) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
bitCount)
                        forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
ssss forall a. Eq a => a -> a -> Bool
/= Word32
0) (forall s. BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
encodeInt BoolWriteStateRef s
st Word32
ssss Int32
n)
            where ssss :: Word32
ssss = Int32 -> Word32
powerOf forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n
                  (Pixel8
bitCount, Word16
code) = HuffmanWriterCode
dcCode forall a. Vector a -> Int -> a
`V.unsafeIndex` forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ssss

        encodeAc :: Word32 -> Int32 -> ST s ()
encodeAc Word32
0         Int32
0 = forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
code) forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
bitCount
            where (Pixel8
bitCount, Word16
code) = HuffmanWriterCode
acCode forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
0

        encodeAc Word32
zeroCount Int32
n | Word32
zeroCount forall a. Ord a => a -> a -> Bool
>= Word32
16 =
          forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
code) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
bitCount) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>  Word32 -> Int32 -> ST s ()
encodeAc (Word32
zeroCount forall a. Num a => a -> a -> a
- Word32
16) Int32
n
            where (Pixel8
bitCount, Word16
code) = HuffmanWriterCode
acCode forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
0xF0
        encodeAc Word32
zeroCount Int32
n =
          forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
code) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
bitCount) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
encodeInt BoolWriteStateRef s
st Word32
ssss Int32
n
            where rrrr :: Word32
rrrr = Word32
zeroCount forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
4
                  ssss :: Word32
ssss = Int32 -> Word32
powerOf forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n
                  rrrrssss :: Word32
rrrrssss = Word32
rrrr forall a. Bits a => a -> a -> a
.|. Word32
ssss
                  (Pixel8
bitCount, Word16
code) = HuffmanWriterCode
acCode forall a. Vector a -> Int -> a
`V.unsafeIndex` forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
rrrrssss

        encodeAcCoefs :: (Word32, Int) -> Int32 -> ST s (Word32, Int)
encodeAcCoefs (            Word32
_, Int
63) Int32
0 = Word32 -> Int32 -> ST s ()
encodeAc Word32
0 Int32
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
0, Int
64)
        encodeAcCoefs (Word32
zeroRunLength,  Int
i) Int32
0 = forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
zeroRunLength forall a. Num a => a -> a -> a
+ Word32
1, Int
i forall a. Num a => a -> a -> a
+ Int
1)
        encodeAcCoefs (Word32
zeroRunLength,  Int
i) Int32
n =
            Word32 -> Int32 -> ST s ()
encodeAc Word32
zeroRunLength Int32
n forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
0, Int
i forall a. Num a => a -> a -> a
+ Int
1)

encodeMacroBlock :: QuantificationTable
                 -> MutableMacroBlock s Int32
                 -> MutableMacroBlock s Int32
                 -> Int16
                 -> MutableMacroBlock s Int16
                 -> ST s (Int32, MutableMacroBlock s Int32)
encodeMacroBlock :: forall s.
MacroBlock Int16
-> MutableMacroBlock s Int32
-> MutableMacroBlock s Int32
-> Int16
-> MutableMacroBlock s Int16
-> ST s (Int32, MutableMacroBlock s Int32)
encodeMacroBlock MacroBlock Int16
quantTableOfComponent MutableMacroBlock s Int32
workData MutableMacroBlock s Int32
finalData Int16
prev_dc MutableMacroBlock s Int16
block = do
 -- the inverse level shift is performed internally by the fastDCT routine

 MutableMacroBlock s Int32
blk <- forall s.
MutableMacroBlock s Int32
-> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int32)
fastDctLibJpeg MutableMacroBlock s Int32
workData MutableMacroBlock s Int16
block
        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a s.
Storable a =>
MutableMacroBlock s a
-> MutableMacroBlock s a -> ST s (MutableMacroBlock s a)
zigZagReorderForward MutableMacroBlock s Int32
finalData
        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s.
MacroBlock Int16
-> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32)
quantize MacroBlock Int16
quantTableOfComponent
 Int32
dc <- MutableMacroBlock s Int32
blk forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
0
 (MutableMacroBlock s Int32
blk forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
0) forall a b. (a -> b) -> a -> b
$ Int32
dc forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
prev_dc
 forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
dc, MutableMacroBlock s Int32
blk)

divUpward :: (Integral a) => a -> a -> a
divUpward :: forall a. Integral a => a -> a -> a
divUpward a
n a
dividor = a
val forall a. Num a => a -> a -> a
+ (if a
rest forall a. Eq a => a -> a -> Bool
/= a
0 then a
1 else a
0)
    where (a
val, a
rest) = a
n forall a. Integral a => a -> a -> (a, a)
`divMod` a
dividor

prepareHuffmanTable :: DctComponent -> Word8 -> HuffmanTable
                    -> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable :: DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
classVal Pixel8
dest HuffmanTable
tableDef =
   (JpgHuffmanTableSpec { huffmanTableClass :: DctComponent
huffmanTableClass = DctComponent
classVal
                        , huffmanTableDest :: Pixel8
huffmanTableDest  = Pixel8
dest
                        , huffSizes :: Vector Pixel8
huffSizes = Vector Pixel8
sizes
                        , huffCodes :: Vector (Vector Pixel8)
huffCodes = forall a. Int -> [a] -> Vector a
V.fromListN Int
16
                            [forall a. Unbox a => Int -> [a] -> Vector a
VU.fromListN (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Vector Pixel8
sizes forall a. Unbox a => Vector a -> Int -> a
! Int
i) [Pixel8]
lst
                                                | (Int
i, [Pixel8]
lst) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] HuffmanTable
tableDef ]
                        }, forall a. Storable a => a -> Vector a
VS.singleton Word16
0)
      where sizes :: Vector Pixel8
sizes = forall a. Unbox a => Int -> [a] -> Vector a
VU.fromListN Int
16 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length) HuffmanTable
tableDef

-- | Encode an image in jpeg at a reasonnable quality level.

-- If you want better quality or reduced file size, you should

-- use `encodeJpegAtQuality`

encodeJpeg :: Image PixelYCbCr8 -> L.ByteString
encodeJpeg :: Image PixelYCbCr8 -> ByteString
encodeJpeg = Pixel8 -> Image PixelYCbCr8 -> ByteString
encodeJpegAtQuality Pixel8
50

defaultHuffmanTables :: [(JpgHuffmanTableSpec, HuffmanPackedTree)]
defaultHuffmanTables :: [(JpgHuffmanTableSpec, HuffmanPackedTree)]
defaultHuffmanTables =
    [ DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Pixel8
0 HuffmanTable
defaultDcLumaHuffmanTable
    , DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent Pixel8
0 HuffmanTable
defaultAcLumaHuffmanTable
    , DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Pixel8
1 HuffmanTable
defaultDcChromaHuffmanTable
    , DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent Pixel8
1 HuffmanTable
defaultAcChromaHuffmanTable
    ]

lumaQuantTableAtQuality :: Int -> QuantificationTable 
lumaQuantTableAtQuality :: Int -> MacroBlock Int16
lumaQuantTableAtQuality Int
qual = Int -> MacroBlock Int16 -> MacroBlock Int16
scaleQuantisationMatrix Int
qual MacroBlock Int16
defaultLumaQuantizationTable

chromaQuantTableAtQuality :: Int -> QuantificationTable
chromaQuantTableAtQuality :: Int -> MacroBlock Int16
chromaQuantTableAtQuality Int
qual =
  Int -> MacroBlock Int16 -> MacroBlock Int16
scaleQuantisationMatrix Int
qual MacroBlock Int16
defaultChromaQuantizationTable

zigzaggedQuantificationSpec :: Int -> [JpgQuantTableSpec]
zigzaggedQuantificationSpec :: Int -> [JpgQuantTableSpec]
zigzaggedQuantificationSpec Int
qual =
  [ JpgQuantTableSpec { quantPrecision :: Pixel8
quantPrecision = Pixel8
0, quantDestination :: Pixel8
quantDestination = Pixel8
0, quantTable :: MacroBlock Int16
quantTable = MacroBlock Int16
luma }
  , JpgQuantTableSpec { quantPrecision :: Pixel8
quantPrecision = Pixel8
0, quantDestination :: Pixel8
quantDestination = Pixel8
1, quantTable :: MacroBlock Int16
quantTable = MacroBlock Int16
chroma }
  ]
  where
    luma :: MacroBlock Int16
luma = forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
lumaQuantTableAtQuality Int
qual
    chroma :: MacroBlock Int16
chroma = forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
chromaQuantTableAtQuality Int
qual

-- | Function to call to encode an image to jpeg.

-- The quality factor should be between 0 and 100 (100 being

-- the best quality).

encodeJpegAtQuality :: Word8                -- ^ Quality factor

                    -> Image PixelYCbCr8    -- ^ Image to encode

                    -> L.ByteString         -- ^ Encoded JPEG

encodeJpegAtQuality :: Pixel8 -> Image PixelYCbCr8 -> ByteString
encodeJpegAtQuality Pixel8
quality = Pixel8 -> Metadatas -> Image PixelYCbCr8 -> ByteString
encodeJpegAtQualityWithMetadata Pixel8
quality forall a. Monoid a => a
mempty

-- | Record gathering all information to encode a component

-- from the source image. Previously was a huge tuple

-- burried in the code

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
  }


-- | Helper type class describing all JPG-encodable pixel types

class (Pixel px, PixelBaseComponent px ~ Word8) => JpgEncodable px where
  additionalBlocks :: Image px -> [JpgFrame]
  additionalBlocks Image px
_ = []

  componentsOfColorSpace :: Image px -> [JpgComponent]

  encodingState :: Int -> Image px -> V.Vector EncoderState

  imageHuffmanTables :: Image px -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
  imageHuffmanTables Image px
_ = [(JpgHuffmanTableSpec, HuffmanPackedTree)]
defaultHuffmanTables 

  scanSpecificationOfColorSpace :: Image px -> [JpgScanSpecification]

  quantTableSpec :: Image px -> Int -> [JpgQuantTableSpec]
  quantTableSpec Image px
_ Int
qual = forall a. Int -> [a] -> [a]
take Int
1 forall a b. (a -> b) -> a -> b
$ Int -> [JpgQuantTableSpec]
zigzaggedQuantificationSpec Int
qual

  maximumSubSamplingOf :: Image px -> Int
  maximumSubSamplingOf Image px
_ = Int
1

instance JpgEncodable Pixel8 where
  scanSpecificationOfColorSpace :: Image Pixel8 -> [JpgScanSpecification]
scanSpecificationOfColorSpace Image Pixel8
_ =
    [ JpgScanSpecification { componentSelector :: Pixel8
componentSelector = Pixel8
1
                           , dcEntropyCodingTable :: Pixel8
dcEntropyCodingTable = Pixel8
0
                           , acEntropyCodingTable :: Pixel8
acEntropyCodingTable = Pixel8
0
                           }
    ]

  componentsOfColorSpace :: Image Pixel8 -> [JpgComponent]
componentsOfColorSpace Image Pixel8
_ =
    [ JpgComponent { componentIdentifier :: Pixel8
componentIdentifier      = Pixel8
1
                   , horizontalSamplingFactor :: Pixel8
horizontalSamplingFactor = Pixel8
1
                   , verticalSamplingFactor :: Pixel8
verticalSamplingFactor   = Pixel8
1
                   , quantizationTableDest :: Pixel8
quantizationTableDest    = Pixel8
0
                   }
    ]

  imageHuffmanTables :: Image Pixel8 -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
imageHuffmanTables Image Pixel8
_ =
    [ DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Pixel8
0 HuffmanTable
defaultDcLumaHuffmanTable
    , DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent Pixel8
0 HuffmanTable
defaultAcLumaHuffmanTable
    ]

  encodingState :: Int -> Image Pixel8 -> Vector EncoderState
encodingState Int
qual Image Pixel8
_ = forall a. a -> Vector a
V.singleton EncoderState
     { _encComponentIndex :: Int
_encComponentIndex = Int
0
     , _encBlockWidth :: Int
_encBlockWidth     = Int
1
     , _encBlockHeight :: Int
_encBlockHeight    = Int
1
     , _encQuantTable :: MacroBlock Int16
_encQuantTable     = forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv 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 Image PixelYCbCr8
_ = Int
2
  quantTableSpec :: Image PixelYCbCr8 -> Int -> [JpgQuantTableSpec]
quantTableSpec Image PixelYCbCr8
_ Int
qual = Int -> [JpgQuantTableSpec]
zigzaggedQuantificationSpec Int
qual
  scanSpecificationOfColorSpace :: Image PixelYCbCr8 -> [JpgScanSpecification]
scanSpecificationOfColorSpace Image PixelYCbCr8
_ =
    [ JpgScanSpecification { componentSelector :: Pixel8
componentSelector = Pixel8
1
                           , dcEntropyCodingTable :: Pixel8
dcEntropyCodingTable = Pixel8
0
                           , acEntropyCodingTable :: Pixel8
acEntropyCodingTable = Pixel8
0
                           }
    , JpgScanSpecification { componentSelector :: Pixel8
componentSelector = Pixel8
2
                           , dcEntropyCodingTable :: Pixel8
dcEntropyCodingTable = Pixel8
1
                           , acEntropyCodingTable :: Pixel8
acEntropyCodingTable = Pixel8
1
                           }
    , JpgScanSpecification { componentSelector :: Pixel8
componentSelector = Pixel8
3
                           , dcEntropyCodingTable :: Pixel8
dcEntropyCodingTable = Pixel8
1
                           , acEntropyCodingTable :: Pixel8
acEntropyCodingTable = Pixel8
1
                           }
    ]

  componentsOfColorSpace :: Image PixelYCbCr8 -> [JpgComponent]
componentsOfColorSpace Image PixelYCbCr8
_ =
    [ JpgComponent { componentIdentifier :: Pixel8
componentIdentifier      = Pixel8
1
                   , horizontalSamplingFactor :: Pixel8
horizontalSamplingFactor = Pixel8
2
                   , verticalSamplingFactor :: Pixel8
verticalSamplingFactor   = Pixel8
2
                   , quantizationTableDest :: Pixel8
quantizationTableDest    = Pixel8
0
                   }
    , JpgComponent { componentIdentifier :: Pixel8
componentIdentifier      = Pixel8
2
                   , horizontalSamplingFactor :: Pixel8
horizontalSamplingFactor = Pixel8
1
                   , verticalSamplingFactor :: Pixel8
verticalSamplingFactor   = Pixel8
1
                   , quantizationTableDest :: Pixel8
quantizationTableDest    = Pixel8
1
                   }
    , JpgComponent { componentIdentifier :: Pixel8
componentIdentifier      = Pixel8
3
                   , horizontalSamplingFactor :: Pixel8
horizontalSamplingFactor = Pixel8
1
                   , verticalSamplingFactor :: Pixel8
verticalSamplingFactor   = Pixel8
1
                   , quantizationTableDest :: Pixel8
quantizationTableDest    = Pixel8
1
                   }
    ]
  
  encodingState :: Int -> Image PixelYCbCr8 -> Vector EncoderState
encodingState Int
qual Image PixelYCbCr8
_ = forall a. Int -> [a] -> Vector a
V.fromListN Int
3 [EncoderState
lumaState, EncoderState
chromaState, EncoderState
chromaState { _encComponentIndex :: Int
_encComponentIndex = Int
2 }]
    where
      lumaState :: EncoderState
lumaState = EncoderState
        { _encComponentIndex :: Int
_encComponentIndex = Int
0
        , _encBlockWidth :: Int
_encBlockWidth     = Int
2
        , _encBlockHeight :: Int
_encBlockHeight    = Int
2
        , _encQuantTable :: MacroBlock Int16
_encQuantTable     = forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv 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 = EncoderState
        { _encComponentIndex :: Int
_encComponentIndex = Int
1
        , _encBlockWidth :: Int
_encBlockWidth     = Int
1
        , _encBlockHeight :: Int
_encBlockHeight    = Int
1
        , _encQuantTable :: MacroBlock Int16
_encQuantTable     = forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv 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 Image PixelRGB8
_ = [JpgAdobeApp14 -> JpgFrame
JpgAdobeAPP14 JpgAdobeApp14
adobe14] where
    adobe14 :: JpgAdobeApp14
adobe14 = JpgAdobeApp14
        { _adobeDctVersion :: Word16
_adobeDctVersion = Word16
100
        , _adobeFlag0 :: Word16
_adobeFlag0      = Word16
0
        , _adobeFlag1 :: Word16
_adobeFlag1      = Word16
0
        , _adobeTransform :: AdobeTransform
_adobeTransform  = AdobeTransform
AdobeUnknown
        }

  imageHuffmanTables :: Image PixelRGB8 -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
imageHuffmanTables Image PixelRGB8
_ =
    [ DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Pixel8
0 HuffmanTable
defaultDcLumaHuffmanTable
    , DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent Pixel8
0 HuffmanTable
defaultAcLumaHuffmanTable
    ]

  scanSpecificationOfColorSpace :: Image PixelRGB8 -> [JpgScanSpecification]
scanSpecificationOfColorSpace Image PixelRGB8
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. Enum a => a -> JpgScanSpecification
build String
"RGB" where
    build :: a -> JpgScanSpecification
build a
c = JpgScanSpecification
      { componentSelector :: Pixel8
componentSelector = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum a
c
      , dcEntropyCodingTable :: Pixel8
dcEntropyCodingTable = Pixel8
0
      , acEntropyCodingTable :: Pixel8
acEntropyCodingTable = Pixel8
0
      }

  componentsOfColorSpace :: Image PixelRGB8 -> [JpgComponent]
componentsOfColorSpace Image PixelRGB8
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. Enum a => a -> JpgComponent
build String
"RGB" where
    build :: a -> JpgComponent
build a
c = JpgComponent
      { componentIdentifier :: Pixel8
componentIdentifier      = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum a
c
      , horizontalSamplingFactor :: Pixel8
horizontalSamplingFactor = Pixel8
1
      , verticalSamplingFactor :: Pixel8
verticalSamplingFactor   = Pixel8
1
      , quantizationTableDest :: Pixel8
quantizationTableDest    = Pixel8
0
      }

  encodingState :: Int -> Image PixelRGB8 -> Vector EncoderState
encodingState Int
qual Image PixelRGB8
_ = forall a. Int -> [a] -> Vector a
V.fromListN Int
3 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> EncoderState
build [Int
0 .. Int
2] where
    build :: Int -> EncoderState
build Int
ix = EncoderState
      { _encComponentIndex :: Int
_encComponentIndex = Int
ix
      , _encBlockWidth :: Int
_encBlockWidth     = Int
1
      , _encBlockHeight :: Int
_encBlockHeight    = Int
1
      , _encQuantTable :: MacroBlock Int16
_encQuantTable     = forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv 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 Image PixelCMYK8
_ = [] where
    _adobe14 :: JpgAdobeApp14
_adobe14 = JpgAdobeApp14
        { _adobeDctVersion :: Word16
_adobeDctVersion = Word16
100
        , _adobeFlag0 :: Word16
_adobeFlag0      = Word16
32768
        , _adobeFlag1 :: Word16
_adobeFlag1      = Word16
0
        , _adobeTransform :: AdobeTransform
_adobeTransform  = AdobeTransform
AdobeYCck
        }
    
  imageHuffmanTables :: Image PixelCMYK8 -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
imageHuffmanTables Image PixelCMYK8
_ =
    [ DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Pixel8
0 HuffmanTable
defaultDcLumaHuffmanTable
    , DctComponent
-> Pixel8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent Pixel8
0 HuffmanTable
defaultAcLumaHuffmanTable
    ]

  scanSpecificationOfColorSpace :: Image PixelCMYK8 -> [JpgScanSpecification]
scanSpecificationOfColorSpace Image PixelCMYK8
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. Enum a => a -> JpgScanSpecification
build String
"CMYK" where
    build :: a -> JpgScanSpecification
build a
c = JpgScanSpecification
      { componentSelector :: Pixel8
componentSelector = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum a
c
      , dcEntropyCodingTable :: Pixel8
dcEntropyCodingTable = Pixel8
0
      , acEntropyCodingTable :: Pixel8
acEntropyCodingTable = Pixel8
0
      }

  componentsOfColorSpace :: Image PixelCMYK8 -> [JpgComponent]
componentsOfColorSpace Image PixelCMYK8
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. Enum a => a -> JpgComponent
build String
"CMYK" where
    build :: a -> JpgComponent
build a
c = JpgComponent
      { componentIdentifier :: Pixel8
componentIdentifier      = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum a
c
      , horizontalSamplingFactor :: Pixel8
horizontalSamplingFactor = Pixel8
1
      , verticalSamplingFactor :: Pixel8
verticalSamplingFactor   = Pixel8
1
      , quantizationTableDest :: Pixel8
quantizationTableDest    = Pixel8
0
      }

  encodingState :: Int -> Image PixelCMYK8 -> Vector EncoderState
encodingState Int
qual Image PixelCMYK8
_ = forall a. Int -> [a] -> Vector a
V.fromListN Int
4 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> EncoderState
build [Int
0 .. Int
3] where
    build :: Int -> EncoderState
build Int
ix = EncoderState
      { _encComponentIndex :: Int
_encComponentIndex = Int
ix
      , _encBlockWidth :: Int
_encBlockWidth     = Int
1
      , _encBlockHeight :: Int
_encBlockHeight    = Int
1
      , _encQuantTable :: MacroBlock Int16
_encQuantTable     = forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv 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
      }

-- | Equivalent to 'encodeJpegAtQuality', but will store the following

-- metadatas in the file using a JFIF block:

--

--  * 'Codec.Picture.Metadata.DpiX'

--  * 'Codec.Picture.Metadata.DpiY' 

--

encodeJpegAtQualityWithMetadata :: Word8                -- ^ Quality factor

                                -> Metadatas
                                -> Image PixelYCbCr8    -- ^ Image to encode

                                -> L.ByteString         -- ^ Encoded JPEG

encodeJpegAtQualityWithMetadata :: Pixel8 -> Metadatas -> Image PixelYCbCr8 -> ByteString
encodeJpegAtQualityWithMetadata = forall px.
JpgEncodable px =>
Pixel8 -> Metadatas -> Image px -> ByteString
encodeDirectJpegAtQualityWithMetadata

-- | Equivalent to 'encodeJpegAtQuality', but will store the following

-- metadatas in the file using a JFIF block:

--

--  * 'Codec.Picture.Metadata.DpiX'

--  * 'Codec.Picture.Metadata.DpiY' 

--

-- This function also allow to create JPEG files with the following color

-- space:

--

--  * Y ('Pixel8') for greyscale.

--  * RGB ('PixelRGB8') with no color downsampling on any plane

--  * CMYK ('PixelCMYK8') with no color downsampling on any plane

--

encodeDirectJpegAtQualityWithMetadata :: forall px. (JpgEncodable px)
                                      => Word8                -- ^ Quality factor

                                      -> Metadatas
                                      -> Image px             -- ^ Image to encode

                                      -> L.ByteString         -- ^ Encoded JPEG

encodeDirectJpegAtQualityWithMetadata :: forall px.
JpgEncodable px =>
Pixel8 -> Metadatas -> Image px -> ByteString
encodeDirectJpegAtQualityWithMetadata Pixel8
quality Metadatas
metas Image px
img = forall a. Binary a => a -> ByteString
encode JpgImage
finalImage where
  !w :: Int
w = forall a. Image a -> Int
imageWidth Image px
img
  !h :: Int
h = forall a. Image a -> Int
imageHeight Image px
img
  !exifMeta :: [JpgFrame]
exifMeta = case Metadatas -> [ImageFileDirectory]
encodeTiffStringMetadata Metadatas
metas of
     [] -> []
     [ImageFileDirectory]
lst -> [[ImageFileDirectory] -> JpgFrame
JpgExif [ImageFileDirectory]
lst]
  finalImage :: JpgImage
finalImage = [JpgFrame] -> JpgImage
JpgImage forall a b. (a -> b) -> a -> b
$
      Metadatas -> [JpgFrame]
encodeMetadatas Metadatas
metas forall a. [a] -> [a] -> [a]
++
      [JpgFrame]
exifMeta forall a. [a] -> [a] -> [a]
++
      forall px. JpgEncodable px => Image px -> [JpgFrame]
additionalBlocks Image px
img forall a. [a] -> [a] -> [a]
++
      [ [JpgQuantTableSpec] -> JpgFrame
JpgQuantTable forall a b. (a -> b) -> a -> b
$ forall px.
JpgEncodable px =>
Image px -> Int -> [JpgQuantTableSpec]
quantTableSpec Image px
img (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
quality)
      , JpgFrameKind -> JpgFrameHeader -> JpgFrame
JpgScans JpgFrameKind
JpgBaselineDCTHuffman JpgFrameHeader
hdr
      , [(JpgHuffmanTableSpec, HuffmanPackedTree)] -> JpgFrame
JpgHuffmanTable forall a b. (a -> b) -> a -> b
$ forall px.
JpgEncodable px =>
Image px -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
imageHuffmanTables Image px
img
      , JpgScanHeader -> ByteString -> JpgFrame
JpgScanBlob JpgScanHeader
scanHeader ByteString
encodedImage
      ]

  !outputComponentCount :: Int
outputComponentCount = forall a. Pixel a => a -> Int
componentCount (forall a. HasCallStack => a
undefined :: px)

  scanHeader :: JpgScanHeader
scanHeader = JpgScanHeader
scanHeader'{ scanLength :: Word16
scanLength = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. SizeCalculable a => a -> Int
calculateSize JpgScanHeader
scanHeader' }
  scanHeader' :: JpgScanHeader
scanHeader' = JpgScanHeader
      { scanLength :: Word16
scanLength = Word16
0
      , scanComponentCount :: Pixel8
scanComponentCount = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
outputComponentCount
      , scans :: [JpgScanSpecification]
scans = forall px. JpgEncodable px => Image px -> [JpgScanSpecification]
scanSpecificationOfColorSpace Image px
img
      , spectralSelection :: (Pixel8, Pixel8)
spectralSelection = (Pixel8
0, Pixel8
63)
      , successiveApproxHigh :: Pixel8
successiveApproxHigh = Pixel8
0
      , successiveApproxLow :: Pixel8
successiveApproxLow  = Pixel8
0
      }

  hdr :: JpgFrameHeader
hdr = JpgFrameHeader
hdr' { jpgFrameHeaderLength :: Word16
jpgFrameHeaderLength   = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. SizeCalculable a => a -> Int
calculateSize JpgFrameHeader
hdr' }
  hdr' :: JpgFrameHeader
hdr' = JpgFrameHeader
    { jpgFrameHeaderLength :: Word16
jpgFrameHeaderLength   = Word16
0
    , jpgSamplePrecision :: Pixel8
jpgSamplePrecision     = Pixel8
8
    , jpgHeight :: Word16
jpgHeight              = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h
    , jpgWidth :: Word16
jpgWidth               = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w
    , jpgImageComponentCount :: Pixel8
jpgImageComponentCount = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
outputComponentCount
    , jpgComponents :: [JpgComponent]
jpgComponents          = forall px. JpgEncodable px => Image px -> [JpgComponent]
componentsOfColorSpace Image px
img
    }

  !maxSampling :: Int
maxSampling = forall px. JpgEncodable px => Image px -> Int
maximumSubSamplingOf Image px
img
  !horizontalMetaBlockCount :: Int
horizontalMetaBlockCount = Int
w forall a. Integral a => a -> a -> a
`divUpward` (forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
* Int
maxSampling)
  !verticalMetaBlockCount :: Int
verticalMetaBlockCount = Int
h forall a. Integral a => a -> a -> a
`divUpward` (forall a. Num a => a
dctBlockSize forall a. Num a => a -> a -> a
* Int
maxSampling)
  !componentDef :: Vector EncoderState
componentDef = forall px.
JpgEncodable px =>
Int -> Image px -> Vector EncoderState
encodingState (forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
quality) Image px
img

  encodedImage :: ByteString
encodedImage = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    MVector s Int16
dc_table <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate Int
outputComponentCount Int16
0
    MVector s Int16
block <- forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
    MutableMacroBlock s Int32
workData <- forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
    MutableMacroBlock s Int32
zigzaged <- forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
    BoolWriteStateRef s
writeState <- forall s. ST s (BoolWriteStateRef s)
newWriteStateRef

    forall (m :: * -> *).
Monad m =>
Int -> Int -> (Int -> Int -> m ()) -> m ()
rasterMap Int
horizontalMetaBlockCount Int
verticalMetaBlockCount forall a b. (a -> b) -> a -> b
$ \Int
mx Int
my ->
      forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
V.forM_ Vector EncoderState
componentDef forall a b. (a -> b) -> a -> b
$ \(EncoderState Int
comp Int
sizeX Int
sizeY MacroBlock Int16
table HuffmanWriterCode
dc HuffmanWriterCode
ac) -> 
        let !xSamplingFactor :: Int
xSamplingFactor = Int
maxSampling forall a. Num a => a -> a -> a
- Int
sizeX forall a. Num a => a -> a -> a
+ Int
1
            !ySamplingFactor :: Int
ySamplingFactor = Int
maxSampling forall a. Num a => a -> a -> a
- Int
sizeY forall a. Num a => a -> a -> a
+ Int
1
            !extractor :: Int -> Int -> Int -> ST s (MVector s Int16)
extractor = forall s px.
(PixelBaseComponent px ~ Pixel8) =>
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
        forall (m :: * -> *).
Monad m =>
Int -> Int -> (Int -> Int -> m ()) -> m ()
rasterMap Int
sizeX Int
sizeY forall a b. (a -> b) -> a -> b
$ \Int
subX Int
subY -> do
          let !blockY :: Int
blockY = Int
my forall a. Num a => a -> a -> a
* Int
sizeY forall a. Num a => a -> a -> a
+ Int
subY
              !blockX :: Int
blockX = Int
mx forall a. Num a => a -> a -> a
* Int
sizeX forall a. Num a => a -> a -> a
+ Int
subX
          Int16
prev_dc <- MVector s Int16
dc_table 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
          (Int32
dc_coeff, MutableMacroBlock s Int32
neo_block) <- 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
dc_table forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
comp) forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
dc_coeff
          forall s.
BoolWriteStateRef s
-> HuffmanWriterCode
-> HuffmanWriterCode
-> MutableMacroBlock s Int32
-> ST s ()
serializeMacroBlock BoolWriteStateRef s
writeState HuffmanWriterCode
dc HuffmanWriterCode
ac MutableMacroBlock s Int32
neo_block

    forall s. BoolWriteStateRef s -> ST s ByteString
finalizeBoolWriter BoolWriteStateRef s
writeState