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