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

            (MutableMacroBlock s Int32
MVector (PrimState (ST s)) Int32
block MVector (PrimState (ST s)) Int32 -> Int -> Int32 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
idx) Int32
finalValue
            Int -> ST s (MutableMacroBlock s Int32)
update (Int -> ST s (MutableMacroBlock s Int32))
-> Int -> ST s (MutableMacroBlock s Int32)
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 = Int32 -> Int32
forall a. Num a => a -> a
abs Int32
n
          limit :: Int32 -> Word32 -> Word32
limit Int32
range Word32
i | Int32
val Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
range = Word32
i
          limit Int32
range Word32
i = Int32 -> Word32 -> Word32
limit (Int32
2 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
range) (Word32
i Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1)

encodeInt :: BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
{-# INLINE encodeInt #-}
encodeInt :: BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
encodeInt BoolWriteStateRef s
st Word32
ssss Int32
n | Int32
n Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
0 = BoolWriteStateRef s -> Word32 -> Int -> ST s ()
forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ssss)
encodeInt BoolWriteStateRef s
st Word32
ssss Int32
n         = BoolWriteStateRef s -> Word32 -> Int -> ST s ()
forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Word32) -> Int32 -> Word32
forall a b. (a -> b) -> a -> b
$ Int32
n Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1) (Word32 -> Int
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 :: HuffmanPackedTree
-> MutableMacroBlock s Int16
-> BoolReader s (MutableMacroBlock s Int16)
acCoefficientsDecode HuffmanPackedTree
acTree MutableMacroBlock s Int16
mutableBlock = Int -> StateT BoolState (ST s) ()
parseAcCoefficient Int
1 StateT BoolState (ST s) ()
-> BoolReader s (MutableMacroBlock s Int16)
-> BoolReader s (MutableMacroBlock s Int16)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MutableMacroBlock s Int16
-> BoolReader s (MutableMacroBlock s Int16)
forall (m :: * -> *) a. Monad m => a -> m a
return MutableMacroBlock s Int16
mutableBlock
  where parseAcCoefficient :: Int -> StateT BoolState (ST s) ()
parseAcCoefficient Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
64 = () -> StateT BoolState (ST s) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                             | Bool
otherwise = do
            (Int, Int)
rrrrssss <- HuffmanPackedTree -> BoolReader s (Int, Int)
forall s. HuffmanPackedTree -> BoolReader s (Int, Int)
decodeRrrrSsss HuffmanPackedTree
acTree
            case (Int, Int)
rrrrssss of
                (  Int
0, Int
0) -> () -> StateT BoolState (ST s) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                (Int
0xF, Int
0) -> Int -> StateT BoolState (ST s) ()
parseAcCoefficient (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
16)
                (Int
rrrr, Int
ssss) -> do
                    Int16
decoded <- Int32 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int16)
-> StateT BoolState (ST s) Int32 -> StateT BoolState (ST s) Int16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT BoolState (ST s) Int32
forall s. Int -> BoolReader s Int32
decodeInt Int
ssss
                    ST s () -> StateT BoolState (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT BoolState (ST s) ())
-> ST s () -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ (MutableMacroBlock s Int16
MVector (PrimState (ST s)) Int16
mutableBlock MVector (PrimState (ST s)) Int16 -> Int -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rrrr)) Int16
decoded
                    Int -> StateT BoolState (ST s) ()
parseAcCoefficient (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rrrr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 :: 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 <- HuffmanPackedTree -> BoolReader s Int16
forall s. HuffmanPackedTree -> BoolReader s Int16
dcCoefficientDecode HuffmanPackedTree
dcTree
    MutableMacroBlock s Int16
block <- ST s (MutableMacroBlock s Int16)
-> StateT BoolState (ST s) (MutableMacroBlock s Int16)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ST s (MutableMacroBlock s Int16)
forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
    let neoDcCoefficient :: Int16
neoDcCoefficient = Int16
previousDc Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
dcDeltaCoefficient
    ST s () -> StateT BoolState (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT BoolState (ST s) ())
-> ST s () -> StateT BoolState (ST s) ()
forall a b. (a -> b) -> a -> b
$ (MutableMacroBlock s Int16
MVector (PrimState (ST s)) Int16
block MVector (PrimState (ST s)) Int16 -> Int -> Int16 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
0) Int16
neoDcCoefficient
    MutableMacroBlock s Int16
fullBlock <- HuffmanPackedTree
-> MutableMacroBlock s Int16
-> StateT BoolState (ST s) (MutableMacroBlock s Int16)
forall s.
HuffmanPackedTree
-> MutableMacroBlock s Int16
-> BoolReader s (MutableMacroBlock s Int16)
acCoefficientsDecode HuffmanPackedTree
acTree MutableMacroBlock s Int16
block
    MutableMacroBlock s Int16
decodedBlock <- ST s (MutableMacroBlock s Int16)
-> StateT BoolState (ST s) (MutableMacroBlock s Int16)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (MutableMacroBlock s Int16)
 -> StateT BoolState (ST s) (MutableMacroBlock s Int16))
-> ST s (MutableMacroBlock s Int16)
-> StateT BoolState (ST s) (MutableMacroBlock s Int16)
forall a b. (a -> b) -> a -> b
$ MacroBlock Int16
-> MutableMacroBlock s Int16
-> MutableMacroBlock s Int16
-> ST s (MutableMacroBlock s Int16)
forall s.
MacroBlock Int16
-> MutableMacroBlock s Int16
-> MutableMacroBlock s Int16
-> ST s (MutableMacroBlock s Int16)
decodeMacroBlock MacroBlock Int16
quantizationTable MutableMacroBlock s Int16
zigzagBlock MutableMacroBlock s Int16
fullBlock
    (Int16, MutableMacroBlock s Int16)
-> BoolReader s (Int16, MutableMacroBlock s Int16)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int16
neoDcCoefficient, MutableMacroBlock s Int16
decodedBlock)

pixelClamp :: Int16 -> Word8
pixelClamp :: Int16 -> Word8
pixelClamp Int16
n = Int16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int16 -> Word8) -> (Int16 -> Int16) -> Int16 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Int16 -> Int16
forall a. Ord a => a -> a -> a
min Int16
255 (Int16 -> Word8) -> Int16 -> Word8
forall a b. (a -> b) -> a -> b
$ Int16 -> Int16 -> Int16
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 :: 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth

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

unpack444Ycbcr :: Int -- ^ Component index

              -> Int -- ^ x

              -> Int -- ^ y

              -> MutableImage s PixelYCbCr8
              -> MutableMacroBlock s Int16
              -> ST s ()
unpack444Ycbcr :: 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
compIdx

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

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

            Int -> Int -> Int -> ST s ()
blockVert (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth) (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
forall a. Num a => a
dctBlockSize) (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 :: 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
forall a. Num a => a
dctBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
imgWidth) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
compIdx
        lineOffset :: Int
lineOffset = Int
imgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3

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

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

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

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

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

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

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

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

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

            Int -> Int -> Int -> ST s ()
blockVert (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lineOffset) (Int
readIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
forall a. Num a => a
dctBlockSize) (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 -> [(Word8, Int)]
componentIndexMapping :: ![(Word8, Int)]
    , JpgDecoderState -> Bool
isProgressive         :: !Bool
    , JpgDecoderState -> Int
maximumHorizontalResolution :: !Int
    , JpgDecoderState -> Int
maximumVerticalResolution   :: !Int
    , JpgDecoderState -> Int
seenBlobs                   :: !Int
    }

emptyDecoderState :: JpgDecoderState
emptyDecoderState :: JpgDecoderState
emptyDecoderState = JpgDecoderState :: Vector HuffmanPackedTree
-> Vector HuffmanPackedTree
-> Vector (MacroBlock Int16)
-> Int
-> Maybe JpgFrameHeader
-> Maybe JpgAdobeApp14
-> Maybe JpgJFIFApp0
-> Maybe [ImageFileDirectory]
-> [(Word8, Int)]
-> Bool
-> Int
-> Int
-> Int
-> JpgDecoderState
JpgDecoderState
    { dcDecoderTables :: Vector HuffmanPackedTree
dcDecoderTables =
        let (JpgHuffmanTableSpec
_, HuffmanPackedTree
dcLuma) = DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Word8
0 HuffmanTable
defaultDcLumaHuffmanTable
            (JpgHuffmanTableSpec
_, HuffmanPackedTree
dcChroma) = DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Word8
1 HuffmanTable
defaultDcChromaHuffmanTable
        in
        [HuffmanPackedTree] -> Vector HuffmanPackedTree
forall a. [a] -> Vector a
V.fromList [ HuffmanPackedTree
dcLuma, HuffmanPackedTree
dcChroma, HuffmanPackedTree
dcLuma, HuffmanPackedTree
dcChroma ]

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

    , quantizationMatrices :: Vector (MacroBlock Int16)
quantizationMatrices = Int -> MacroBlock Int16 -> Vector (MacroBlock Int16)
forall a. Int -> a -> Vector a
V.replicate Int
4 (Int -> Int16 -> MacroBlock Int16
forall a. Storable a => Int -> a -> Vector a
VS.replicate (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8) Int16
1)
    , currentRestartInterv :: Int
currentRestartInterv = -Int
1
    , currentFrame :: Maybe JpgFrameHeader
currentFrame         = Maybe JpgFrameHeader
forall a. Maybe a
Nothing
    , componentIndexMapping :: [(Word8, Int)]
componentIndexMapping = []
    , app14Marker :: Maybe JpgAdobeApp14
app14Marker = Maybe JpgAdobeApp14
forall a. Maybe a
Nothing
    , app0JFifMarker :: Maybe JpgJFIFApp0
app0JFifMarker = Maybe JpgJFIFApp0
forall a. Maybe a
Nothing
    , app1ExifMarker :: Maybe [ImageFileDirectory]
app1ExifMarker = Maybe [ImageFileDirectory]
forall a. Maybe a
Nothing
    , isProgressive :: Bool
isProgressive        = Bool
False
    , maximumHorizontalResolution :: Int
maximumHorizontalResolution = 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 :: JpgFrame -> JpgScripter s ()
jpgMachineStep (JpgAdobeAPP14 JpgAdobeApp14
app14) = (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((JpgDecoderState -> JpgDecoderState) -> JpgScripter s ())
-> (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall a b. (a -> b) -> a -> b
$ \JpgDecoderState
s ->
    JpgDecoderState
s { app14Marker :: Maybe JpgAdobeApp14
app14Marker = JpgAdobeApp14 -> Maybe JpgAdobeApp14
forall a. a -> Maybe a
Just JpgAdobeApp14
app14 }
jpgMachineStep (JpgExif [ImageFileDirectory]
exif) = (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((JpgDecoderState -> JpgDecoderState) -> JpgScripter s ())
-> (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall a b. (a -> b) -> a -> b
$ \JpgDecoderState
s ->
    JpgDecoderState
s { app1ExifMarker :: Maybe [ImageFileDirectory]
app1ExifMarker = [ImageFileDirectory] -> Maybe [ImageFileDirectory]
forall a. a -> Maybe a
Just [ImageFileDirectory]
exif }
jpgMachineStep (JpgJFIF JpgJFIFApp0
app0) = (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify ((JpgDecoderState -> JpgDecoderState) -> JpgScripter s ())
-> (JpgDecoderState -> JpgDecoderState) -> JpgScripter s ()
forall a b. (a -> b) -> a -> b
$ \JpgDecoderState
s ->
    JpgDecoderState
s { app0JFifMarker :: Maybe JpgJFIFApp0
app0JFifMarker = JpgJFIFApp0 -> Maybe JpgJFIFApp0
forall a. a -> Maybe a
Just JpgJFIFApp0
app0 }
jpgMachineStep (JpgAppFrame Word8
_ ByteString
_) = () -> JpgScripter s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
jpgMachineStep (JpgExtension Word8
_ ByteString
_) = () -> JpgScripter s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
jpgMachineStep (JpgScanBlob JpgScanHeader
hdr ByteString
raw_data) = do
    let scanCount :: Int
scanCount = [JpgScanSpecification] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([JpgScanSpecification] -> Int) -> [JpgScanSpecification] -> Int
forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> [JpgScanSpecification]
scans JpgScanHeader
hdr
    [(JpgUnpackerParameter, Unpacker s)]
params <- [[(JpgUnpackerParameter, Unpacker s)]]
-> [(JpgUnpackerParameter, Unpacker s)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(JpgUnpackerParameter, Unpacker s)]]
 -> [(JpgUnpackerParameter, Unpacker s)])
-> RWST
     ()
     [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
     JpgDecoderState
     Identity
     [[(JpgUnpackerParameter, Unpacker s)]]
-> RWST
     ()
     [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
     JpgDecoderState
     Identity
     [(JpgUnpackerParameter, Unpacker s)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JpgScanSpecification
 -> RWST
      ()
      [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
      JpgDecoderState
      Identity
      [(JpgUnpackerParameter, Unpacker s)])
-> [JpgScanSpecification]
-> RWST
     ()
     [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
     JpgDecoderState
     Identity
     [[(JpgUnpackerParameter, Unpacker s)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int
-> JpgScanSpecification
-> RWST
     ()
     [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
     JpgDecoderState
     Identity
     [(JpgUnpackerParameter, Unpacker s)]
scanSpecifier Int
scanCount) (JpgScanHeader -> [JpgScanSpecification]
scans JpgScanHeader
hdr)

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

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

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

                 [(JpgUnpackerParameter, Unpacker s)]
-> RWST
     ()
     [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
     JpgDecoderState
     Identity
     [(JpgUnpackerParameter, Unpacker s)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (JpgUnpackerParameter :: HuffmanPackedTree
-> HuffmanPackedTree
-> Int
-> Int
-> Int
-> Int
-> (Int, Int)
-> (Int, Int)
-> (Int, Int)
-> Int
-> Int
-> Int
-> Int
-> Int
-> JpgUnpackerParameter
JpgUnpackerParameter
                         { dcHuffmanTree :: HuffmanPackedTree
dcHuffmanTree = HuffmanPackedTree
dcTree
                         , acHuffmanTree :: HuffmanPackedTree
acHuffmanTree = HuffmanPackedTree
acTree
                         , componentIndex :: Int
componentIndex = Int
comp
                         , restartInterval :: Int
restartInterval = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
restart
                         , componentWidth :: Int
componentWidth = Int
xSampling
                         , componentHeight :: Int
componentHeight = Int
ySampling
                         , subSampling :: (Int, Int)
subSampling = (Int, Int)
componentSubSampling
                         , successiveApprox :: (Int, Int)
successiveApprox = (Int
approxLow, Int
approxHigh)
                         , readerIndex :: Int
readerIndex = Int
blobId
                         , indiceVector :: Int
indiceVector =
                             if Int
scanCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Int
0 else Int
1
                         , coefficientRange :: (Int, Int)
coefficientRange =
                             ( Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
selectionLow
                             , Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
selectionHigh )
                         , blockIndex :: Int
blockIndex = Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
xSampling Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x
                         , blockMcuX :: Int
blockMcuX = Int
x
                         , blockMcuY :: Int
blockMcuY = Int
y
                         }, Int -> (Int, Int) -> Unpacker s
forall s. Int -> (Int, Int) -> Unpacker s
unpackerDecision Int
compCount (Int, Int)
componentSubSampling)
                             | Int
y <- [Int
0 .. Int
yCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                             , Int
x <- [Int
0 .. Int
xCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]

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

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

unpackerDecision :: Int -> (Int, Int) -> Unpacker s
unpackerDecision :: Int -> (Int, Int) -> Unpacker s
unpackerDecision Int
1 (Int
1, Int
1) = Unpacker s
forall s.
Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack444Y
unpackerDecision Int
3 (Int
1, Int
1) = Unpacker s
forall s.
Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack444Ycbcr
unpackerDecision Int
_ (Int
2, Int
1) = Unpacker s
forall s.
Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpack421Ycbcr
unpackerDecision Int
compCount (Int
xScalingFactor, Int
yScalingFactor) =
    Int -> Int -> Int -> Unpacker s
forall s.
Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> MutableImage s PixelYCbCr8
-> MutableMacroBlock s Int16
-> ST s ()
unpackMacroBlock Int
compCount Int
xScalingFactor Int
yScalingFactor

decodeImage :: JpgFrameHeader
            -> V.Vector (MacroBlock Int16)
            -> [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)]
            -> MutableImage s PixelYCbCr8 -- ^ Result image to write into

            -> ST s (MutableImage s PixelYCbCr8)
decodeImage :: 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 = [JpgComponent] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([JpgComponent] -> Int) -> [JpgComponent] -> Int
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
frame
  MutableMacroBlock s Int16
zigZagArray <- ST s (MutableMacroBlock s Int16)
forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock
  MutableMacroBlock s Int16
dcArray <- Int -> Int16 -> ST s (MVector (PrimState (ST s)) Int16)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate Int
compCount Int16
0  :: ST s (M.STVector s DcCoefficient)
  STRef s Int
resetCounter <- Int -> ST s (STRef s Int)
forall a s. a -> ST s (STRef s a)
newSTRef Int
restartIntervalValue

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

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

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

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

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

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

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

        imgWidth :: Int
imgWidth = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgWidth JpgFrameHeader
frame
        imgHeight :: Int
imgHeight = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgHeight JpgFrameHeader
frame
        restartIntervalValue :: Int
restartIntervalValue = case [([(JpgUnpackerParameter, Unpacker s)], ByteString)]
lst of
                ((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] -> JpgImageKind -> Maybe JpgImageKind
forall a. a -> Maybe a
Just JpgImageKind
BaseLineDCT
    [JpgFrameKind
JpgProgressiveDCTHuffman] -> JpgImageKind -> Maybe JpgImageKind
forall a. a -> Maybe a
Just JpgImageKind
ProgressiveDCT
    [JpgFrameKind
JpgExtendedSequentialDCTHuffman] -> JpgImageKind -> Maybe JpgImageKind
forall a. a -> Maybe a
Just JpgImageKind
BaseLineDCT
    [JpgFrameKind]
_ -> Maybe JpgImageKind
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 = [(JpgFrameKind, JpgFrameHeader)] -> (JpgFrameKind, JpgFrameHeader)
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 Word8 -> Either [Char] DynamicImage
dynamicOfColorSpace Maybe JpgColorSpace
Nothing Int
_ Int
_ Vector Word8
_ = [Char] -> Either [Char] DynamicImage
forall a b. a -> Either a b
Left [Char]
"Unknown color space"
dynamicOfColorSpace (Just JpgColorSpace
color) Int
w Int
h Vector Word8
imgData = case JpgColorSpace
color of
  JpgColorSpace
JpgColorSpaceCMYK -> DynamicImage -> Either [Char] DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either [Char] DynamicImage)
-> (Image PixelCMYK8 -> DynamicImage)
-> Image PixelCMYK8
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelCMYK8 -> DynamicImage
ImageCMYK8 (Image PixelCMYK8 -> Either [Char] DynamicImage)
-> Image PixelCMYK8 -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> Vector (PixelBaseComponent PixelCMYK8)
-> Image PixelCMYK8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent PixelCMYK8)
imgData
  JpgColorSpace
JpgColorSpaceYCCK ->
     let ymg :: Image PixelYCbCrK8
ymg = Int
-> Int
-> Vector (PixelBaseComponent PixelYCbCrK8)
-> Image PixelYCbCrK8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h (Vector (PixelBaseComponent PixelYCbCrK8) -> Image PixelYCbCrK8)
-> Vector (PixelBaseComponent PixelYCbCrK8) -> Image PixelYCbCrK8
forall a b. (a -> b) -> a -> b
$ (Word8 -> Word8) -> Vector Word8 -> Vector Word8
forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
VS.map (Word8
255Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
-) Vector Word8
imgData :: Image PixelYCbCrK8 in
     DynamicImage -> Either [Char] DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either [Char] DynamicImage)
-> (Image PixelCMYK8 -> DynamicImage)
-> Image PixelCMYK8
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelCMYK8 -> DynamicImage
ImageCMYK8 (Image PixelCMYK8 -> Either [Char] DynamicImage)
-> Image PixelCMYK8 -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ Image PixelYCbCrK8 -> Image PixelCMYK8
forall a b. ColorSpaceConvertible a b => Image a -> Image b
convertImage Image PixelYCbCrK8
ymg
  JpgColorSpace
JpgColorSpaceYCbCr -> DynamicImage -> Either [Char] DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either [Char] DynamicImage)
-> (Image PixelYCbCr8 -> DynamicImage)
-> Image PixelYCbCr8
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYCbCr8 -> DynamicImage
ImageYCbCr8 (Image PixelYCbCr8 -> Either [Char] DynamicImage)
-> Image PixelYCbCr8 -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> Vector (PixelBaseComponent PixelYCbCr8)
-> Image PixelYCbCr8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent PixelYCbCr8)
imgData
  JpgColorSpace
JpgColorSpaceRGB -> DynamicImage -> Either [Char] DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either [Char] DynamicImage)
-> (Image PixelRGB8 -> DynamicImage)
-> Image PixelRGB8
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelRGB8 -> DynamicImage
ImageRGB8 (Image PixelRGB8 -> Either [Char] DynamicImage)
-> Image PixelRGB8 -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ Int
-> Int -> Vector (PixelBaseComponent PixelRGB8) -> Image PixelRGB8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent PixelRGB8)
imgData
  JpgColorSpace
JpgColorSpaceYA -> DynamicImage -> Either [Char] DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either [Char] DynamicImage)
-> (Image PixelYA8 -> DynamicImage)
-> Image PixelYA8
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image PixelYA8 -> DynamicImage
ImageYA8 (Image PixelYA8 -> Either [Char] DynamicImage)
-> Image PixelYA8 -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ Int
-> Int -> Vector (PixelBaseComponent PixelYA8) -> Image PixelYA8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent PixelYA8)
imgData
  JpgColorSpace
JpgColorSpaceY -> DynamicImage -> Either [Char] DynamicImage
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicImage -> Either [Char] DynamicImage)
-> (Image Word8 -> DynamicImage)
-> Image Word8
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image Word8 -> DynamicImage
ImageY8 (Image Word8 -> Either [Char] DynamicImage)
-> Image Word8 -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector (PixelBaseComponent Word8) -> Image Word8
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image Int
w Int
h Vector Word8
Vector (PixelBaseComponent Word8)
imgData
  JpgColorSpace
colorSpace -> [Char] -> Either [Char] DynamicImage
forall a b. a -> Either a b
Left ([Char] -> Either [Char] DynamicImage)
-> [Char] -> Either [Char] DynamicImage
forall a b. (a -> b) -> a -> b
$ [Char]
"Wrong color space : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ JpgColorSpace -> [Char]
forall a. Show a => a -> [Char]
show JpgColorSpace
colorSpace

colorSpaceOfAdobe :: Int -> JpgAdobeApp14 -> Maybe JpgColorSpace
colorSpaceOfAdobe :: Int -> JpgAdobeApp14 -> Maybe JpgColorSpace
colorSpaceOfAdobe Int
compCount JpgAdobeApp14
app = case (Int
compCount, JpgAdobeApp14 -> AdobeTransform
_adobeTransform JpgAdobeApp14
app) of
  (Int
3, AdobeTransform
AdobeYCbCr) -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYCbCr
  (Int
1, AdobeTransform
AdobeUnknown) -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceY
  (Int
3, AdobeTransform
AdobeUnknown) -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceRGB
  (Int
4, AdobeTransform
AdobeYCck) -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure JpgColorSpace
JpgColorSpaceYCCK
  {-(4, AdobeUnknown) -> pure JpgColorSpaceCMYKInverted-}
  (Int, AdobeTransform)
_ -> Maybe JpgColorSpace
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 :: [Char]
compStr = [Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum (Word8 -> Char) -> Word8 -> Char
forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
componentIdentifier JpgComponent
comp
                        | JpgComponent
comp <- JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
hdr]
      app14 :: Maybe JpgColorSpace
app14 = do
        JpgAdobeApp14
marker <- JpgDecoderState -> Maybe JpgAdobeApp14
app14Marker JpgDecoderState
st
        Int -> JpgAdobeApp14 -> Maybe JpgColorSpace
colorSpaceOfAdobe ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
compStr) JpgAdobeApp14
marker
  Maybe JpgColorSpace
app14 Maybe JpgColorSpace -> Maybe JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Char] -> Maybe JpgColorSpace
colorSpaceOfComponentStr [Char]
compStr


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

  [Char]
"RGBA" -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceRGBA
  [Char]
"YCcA" -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceYCCA
  [Char]
"CMYK" -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceCMYK
  [Char]
"YCcK" -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceYCCK
  [Char
_,Char
_,Char
_,Char
_] -> JpgColorSpace -> Maybe JpgColorSpace
forall (f :: * -> *) a. Applicative f => a -> f a
pure  JpgColorSpace
JpgColorSpaceCMYK
  [Char]
_ -> Maybe JpgColorSpace
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 [Char] DynamicImage
decodeJpeg = ((DynamicImage, Metadatas) -> DynamicImage)
-> Either [Char] (DynamicImage, Metadatas)
-> Either [Char] DynamicImage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynamicImage, Metadatas) -> DynamicImage
forall a b. (a, b) -> a
fst (Either [Char] (DynamicImage, Metadatas)
 -> Either [Char] DynamicImage)
-> (ByteString -> Either [Char] (DynamicImage, Metadatas))
-> ByteString
-> Either [Char] DynamicImage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] (DynamicImage, Metadatas)
decodeJpegWithMetadata

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

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

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

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


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


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

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

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

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

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

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

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

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

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

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

        encodeAcCoefs :: (Word32, Int) -> Int32 -> ST s (Word32, Int)
encodeAcCoefs (            Word32
_, Int
63) Int32
0 = Word32 -> Int32 -> ST s ()
encodeAc Word32
0 Int32
0 ST s () -> ST s (Word32, Int) -> ST s (Word32, Int)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Word32, Int) -> ST s (Word32, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
0, Int
64)
        encodeAcCoefs (Word32
zeroRunLength,  Int
i) Int32
0 = (Word32, Int) -> ST s (Word32, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
zeroRunLength Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1, Int
i Int -> Int -> Int
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 ST s () -> ST s (Word32, Int) -> ST s (Word32, Int)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Word32, Int) -> ST s (Word32, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
0, Int
i Int -> Int -> Int
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 :: 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 <- MutableMacroBlock s Int32
-> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int32)
forall s.
MutableMacroBlock s Int32
-> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int32)
fastDctLibJpeg MutableMacroBlock s Int32
workData MutableMacroBlock s Int16
block
        ST s (MutableMacroBlock s Int32)
-> (MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32))
-> ST s (MutableMacroBlock s Int32)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableMacroBlock s Int32
-> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32)
forall a s.
Storable a =>
MutableMacroBlock s a
-> MutableMacroBlock s a -> ST s (MutableMacroBlock s a)
zigZagReorderForward MutableMacroBlock s Int32
finalData
        ST s (MutableMacroBlock s Int32)
-> (MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32))
-> ST s (MutableMacroBlock s Int32)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MacroBlock Int16
-> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32)
forall s.
MacroBlock Int16
-> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32)
quantize MacroBlock Int16
quantTableOfComponent
 Int32
dc <- MutableMacroBlock s Int32
MVector (PrimState (ST s)) Int32
blk MVector (PrimState (ST s)) Int32 -> Int -> ST s Int32
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
0
 (MutableMacroBlock s Int32
MVector (PrimState (ST s)) Int32
blk MVector (PrimState (ST s)) Int32 -> Int -> Int32 -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
`M.unsafeWrite` Int
0) (Int32 -> ST s ()) -> Int32 -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int32
dc Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
prev_dc
 (Int32, MutableMacroBlock s Int32)
-> ST s (Int32, MutableMacroBlock s Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
dc, MutableMacroBlock s Int32
blk)

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

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

-- | 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 = Word8 -> Image PixelYCbCr8 -> ByteString
encodeJpegAtQuality Word8
50

defaultHuffmanTables :: [(JpgHuffmanTableSpec, HuffmanPackedTree)]
defaultHuffmanTables :: [(JpgHuffmanTableSpec, HuffmanPackedTree)]
defaultHuffmanTables =
    [ DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Word8
0 HuffmanTable
defaultDcLumaHuffmanTable
    , DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent Word8
0 HuffmanTable
defaultAcLumaHuffmanTable
    , DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Word8
1 HuffmanTable
defaultDcChromaHuffmanTable
    , DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent Word8
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 :: Word8 -> Word8 -> MacroBlock Int16 -> JpgQuantTableSpec
JpgQuantTableSpec { quantPrecision :: Word8
quantPrecision = Word8
0, quantDestination :: Word8
quantDestination = Word8
0, quantTable :: MacroBlock Int16
quantTable = MacroBlock Int16
luma }
  , JpgQuantTableSpec :: Word8 -> Word8 -> MacroBlock Int16 -> JpgQuantTableSpec
JpgQuantTableSpec { quantPrecision :: Word8
quantPrecision = Word8
0, quantDestination :: Word8
quantDestination = Word8
1, quantTable :: MacroBlock Int16
quantTable = MacroBlock Int16
chroma }
  ]
  where
    luma :: MacroBlock Int16
luma = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
lumaQuantTableAtQuality Int
qual
    chroma :: MacroBlock Int16
chroma = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
chromaQuantTableAtQuality Int
qual

-- | 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 :: Word8 -> Image PixelYCbCr8 -> ByteString
encodeJpegAtQuality Word8
quality = Word8 -> Metadatas -> Image PixelYCbCr8 -> ByteString
encodeJpegAtQualityWithMetadata Word8
quality Metadatas
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 = Int -> [JpgQuantTableSpec] -> [JpgQuantTableSpec]
forall a. Int -> [a] -> [a]
take Int
1 ([JpgQuantTableSpec] -> [JpgQuantTableSpec])
-> [JpgQuantTableSpec] -> [JpgQuantTableSpec]
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 Word8 -> [JpgScanSpecification]
scanSpecificationOfColorSpace Image Word8
_ =
    [ JpgScanSpecification :: Word8 -> Word8 -> Word8 -> JpgScanSpecification
JpgScanSpecification { componentSelector :: Word8
componentSelector = Word8
1
                           , dcEntropyCodingTable :: Word8
dcEntropyCodingTable = Word8
0
                           , acEntropyCodingTable :: Word8
acEntropyCodingTable = Word8
0
                           }
    ]

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

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

  encodingState :: Int -> Image Word8 -> Vector EncoderState
encodingState Int
qual Image Word8
_ = EncoderState -> Vector EncoderState
forall a. a -> Vector a
V.singleton EncoderState :: Int
-> Int
-> Int
-> MacroBlock Int16
-> HuffmanWriterCode
-> HuffmanWriterCode
-> EncoderState
EncoderState
     { _encComponentIndex :: Int
_encComponentIndex = Int
0
     , _encBlockWidth :: Int
_encBlockWidth     = Int
1
     , _encBlockHeight :: Int
_encBlockHeight    = Int
1
     , _encQuantTable :: MacroBlock Int16
_encQuantTable     = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
lumaQuantTableAtQuality Int
qual
     , _encDcHuffman :: HuffmanWriterCode
_encDcHuffman      = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultDcLumaHuffmanTree
     , _encAcHuffman :: HuffmanWriterCode
_encAcHuffman      = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultAcLumaHuffmanTree
     }


instance JpgEncodable PixelYCbCr8 where
  maximumSubSamplingOf :: Image PixelYCbCr8 -> Int
maximumSubSamplingOf 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 :: Word8 -> Word8 -> Word8 -> JpgScanSpecification
JpgScanSpecification { componentSelector :: Word8
componentSelector = Word8
1
                           , dcEntropyCodingTable :: Word8
dcEntropyCodingTable = Word8
0
                           , acEntropyCodingTable :: Word8
acEntropyCodingTable = Word8
0
                           }
    , JpgScanSpecification :: Word8 -> Word8 -> Word8 -> JpgScanSpecification
JpgScanSpecification { componentSelector :: Word8
componentSelector = Word8
2
                           , dcEntropyCodingTable :: Word8
dcEntropyCodingTable = Word8
1
                           , acEntropyCodingTable :: Word8
acEntropyCodingTable = Word8
1
                           }
    , JpgScanSpecification :: Word8 -> Word8 -> Word8 -> JpgScanSpecification
JpgScanSpecification { componentSelector :: Word8
componentSelector = Word8
3
                           , dcEntropyCodingTable :: Word8
dcEntropyCodingTable = Word8
1
                           , acEntropyCodingTable :: Word8
acEntropyCodingTable = Word8
1
                           }
    ]

  componentsOfColorSpace :: Image PixelYCbCr8 -> [JpgComponent]
componentsOfColorSpace Image PixelYCbCr8
_ =
    [ JpgComponent :: Word8 -> Word8 -> Word8 -> Word8 -> JpgComponent
JpgComponent { componentIdentifier :: Word8
componentIdentifier      = Word8
1
                   , horizontalSamplingFactor :: Word8
horizontalSamplingFactor = Word8
2
                   , verticalSamplingFactor :: Word8
verticalSamplingFactor   = Word8
2
                   , quantizationTableDest :: Word8
quantizationTableDest    = Word8
0
                   }
    , JpgComponent :: Word8 -> Word8 -> Word8 -> Word8 -> JpgComponent
JpgComponent { componentIdentifier :: Word8
componentIdentifier      = Word8
2
                   , horizontalSamplingFactor :: Word8
horizontalSamplingFactor = Word8
1
                   , verticalSamplingFactor :: Word8
verticalSamplingFactor   = Word8
1
                   , quantizationTableDest :: Word8
quantizationTableDest    = Word8
1
                   }
    , JpgComponent :: Word8 -> Word8 -> Word8 -> Word8 -> JpgComponent
JpgComponent { componentIdentifier :: Word8
componentIdentifier      = Word8
3
                   , horizontalSamplingFactor :: Word8
horizontalSamplingFactor = Word8
1
                   , verticalSamplingFactor :: Word8
verticalSamplingFactor   = Word8
1
                   , quantizationTableDest :: Word8
quantizationTableDest    = Word8
1
                   }
    ]
  
  encodingState :: Int -> Image PixelYCbCr8 -> Vector EncoderState
encodingState Int
qual Image PixelYCbCr8
_ = Int -> [EncoderState] -> Vector EncoderState
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 :: Int
-> Int
-> Int
-> MacroBlock Int16
-> HuffmanWriterCode
-> HuffmanWriterCode
-> EncoderState
EncoderState
        { _encComponentIndex :: Int
_encComponentIndex = Int
0
        , _encBlockWidth :: Int
_encBlockWidth     = Int
2
        , _encBlockHeight :: Int
_encBlockHeight    = Int
2
        , _encQuantTable :: MacroBlock Int16
_encQuantTable     = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
lumaQuantTableAtQuality Int
qual
        , _encDcHuffman :: HuffmanWriterCode
_encDcHuffman      = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultDcLumaHuffmanTree
        , _encAcHuffman :: HuffmanWriterCode
_encAcHuffman      = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultAcLumaHuffmanTree
        }
      chromaState :: EncoderState
chromaState = EncoderState :: Int
-> Int
-> Int
-> MacroBlock Int16
-> HuffmanWriterCode
-> HuffmanWriterCode
-> EncoderState
EncoderState
        { _encComponentIndex :: Int
_encComponentIndex = Int
1
        , _encBlockWidth :: Int
_encBlockWidth     = Int
1
        , _encBlockHeight :: Int
_encBlockHeight    = Int
1
        , _encQuantTable :: MacroBlock Int16
_encQuantTable     = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
chromaQuantTableAtQuality Int
qual
        , _encDcHuffman :: HuffmanWriterCode
_encDcHuffman      = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultDcChromaHuffmanTree
        , _encAcHuffman :: HuffmanWriterCode
_encAcHuffman      = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultAcChromaHuffmanTree
        }

instance JpgEncodable PixelRGB8 where
  additionalBlocks :: Image PixelRGB8 -> [JpgFrame]
additionalBlocks Image PixelRGB8
_ = [JpgAdobeApp14 -> JpgFrame
JpgAdobeAPP14 JpgAdobeApp14
adobe14] where
    adobe14 :: JpgAdobeApp14
adobe14 = JpgAdobeApp14 :: Word16 -> Word16 -> Word16 -> AdobeTransform -> JpgAdobeApp14
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
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Word8
0 HuffmanTable
defaultDcLumaHuffmanTable
    , DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent Word8
0 HuffmanTable
defaultAcLumaHuffmanTable
    ]

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

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

  encodingState :: Int -> Image PixelRGB8 -> Vector EncoderState
encodingState Int
qual Image PixelRGB8
_ = Int -> [EncoderState] -> Vector EncoderState
forall a. Int -> [a] -> Vector a
V.fromListN Int
3 ([EncoderState] -> Vector EncoderState)
-> [EncoderState] -> Vector EncoderState
forall a b. (a -> b) -> a -> b
$ (Int -> EncoderState) -> [Int] -> [EncoderState]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> EncoderState
build [Int
0 .. Int
2] where
    build :: Int -> EncoderState
build Int
ix = EncoderState :: Int
-> Int
-> Int
-> MacroBlock Int16
-> HuffmanWriterCode
-> HuffmanWriterCode
-> EncoderState
EncoderState
      { _encComponentIndex :: Int
_encComponentIndex = Int
ix
      , _encBlockWidth :: Int
_encBlockWidth     = Int
1
      , _encBlockHeight :: Int
_encBlockHeight    = Int
1
      , _encQuantTable :: MacroBlock Int16
_encQuantTable     = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
lumaQuantTableAtQuality Int
qual
      , _encDcHuffman :: HuffmanWriterCode
_encDcHuffman      = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultDcLumaHuffmanTree
      , _encAcHuffman :: HuffmanWriterCode
_encAcHuffman      = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultAcLumaHuffmanTree
      }

instance JpgEncodable PixelCMYK8 where
  additionalBlocks :: Image PixelCMYK8 -> [JpgFrame]
additionalBlocks Image PixelCMYK8
_ = [] where
    _adobe14 :: JpgAdobeApp14
_adobe14 = JpgAdobeApp14 :: Word16 -> Word16 -> Word16 -> AdobeTransform -> JpgAdobeApp14
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
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
DcComponent Word8
0 HuffmanTable
defaultDcLumaHuffmanTable
    , DctComponent
-> Word8
-> HuffmanTable
-> (JpgHuffmanTableSpec, HuffmanPackedTree)
prepareHuffmanTable DctComponent
AcComponent Word8
0 HuffmanTable
defaultAcLumaHuffmanTable
    ]

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

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

  encodingState :: Int -> Image PixelCMYK8 -> Vector EncoderState
encodingState Int
qual Image PixelCMYK8
_ = Int -> [EncoderState] -> Vector EncoderState
forall a. Int -> [a] -> Vector a
V.fromListN Int
4 ([EncoderState] -> Vector EncoderState)
-> [EncoderState] -> Vector EncoderState
forall a b. (a -> b) -> a -> b
$ (Int -> EncoderState) -> [Int] -> [EncoderState]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> EncoderState
build [Int
0 .. Int
3] where
    build :: Int -> EncoderState
build Int
ix = EncoderState :: Int
-> Int
-> Int
-> MacroBlock Int16
-> HuffmanWriterCode
-> HuffmanWriterCode
-> EncoderState
EncoderState
      { _encComponentIndex :: Int
_encComponentIndex = Int
ix
      , _encBlockWidth :: Int
_encBlockWidth     = Int
1
      , _encBlockHeight :: Int
_encBlockHeight    = Int
1
      , _encQuantTable :: MacroBlock Int16
_encQuantTable     = MacroBlock Int16 -> MacroBlock Int16
forall a. (Storable a, Num a) => Vector a -> Vector a
zigZagReorderForwardv (MacroBlock Int16 -> MacroBlock Int16)
-> MacroBlock Int16 -> MacroBlock Int16
forall a b. (a -> b) -> a -> b
$ Int -> MacroBlock Int16
lumaQuantTableAtQuality Int
qual
      , _encDcHuffman :: HuffmanWriterCode
_encDcHuffman      = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultDcLumaHuffmanTree
      , _encAcHuffman :: HuffmanWriterCode
_encAcHuffman      = HuffmanTree -> HuffmanWriterCode
makeInverseTable HuffmanTree
defaultAcLumaHuffmanTree
      }

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

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

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

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

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

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

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

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