diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.2.9.1 +Version: 3.2.9.2 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description: <> @@ -28,7 +28,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.2.9.1 + Tag: v3.2.9.2 Flag Mmap Description: Enable the file loading via mmap (memory map) @@ -52,7 +52,7 @@ Codec.Picture.ColorQuant Ghc-options: -O3 -Wall - Build-depends: base >= 4.5 && < 5, + Build-depends: base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, mtl >= 1.1 && < 2.3, binary >= 0.5 && < 0.9, diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,6 +1,12 @@ Change log ========== +v3.2.9.2 December 2017 +---------------------- + + * Fix: Progressive jpeg decoding when number of blocks of the MCU + is below line size + v3.2.9.1 November 2017 ---------------------- diff --git a/src/Codec/Picture/Jpg/Common.hs b/src/Codec/Picture/Jpg/Common.hs --- a/src/Codec/Picture/Jpg/Common.hs +++ b/src/Codec/Picture/Jpg/Common.hs @@ -1,240 +1,240 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -module Codec.Picture.Jpg.Common - ( DctCoefficients - , JpgUnpackerParameter( .. ) - , decodeInt - , dcCoefficientDecode - , deQuantize - , decodeRrrrSsss - , zigZagReorderForward - , zigZagReorderForwardv - , zigZagReorder - , inverseDirectCosineTransform - , unpackInt - , unpackMacroBlock - , rasterMap - , decodeMacroBlock - , decodeRestartInterval - , toBlockSize - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure, (<$>) ) -#endif - -import Control.Monad( when ) -import Control.Monad.ST( ST, runST ) -import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) ) -import Data.Int( Int16, Int32 ) -import Data.Maybe( fromMaybe ) -import Data.Word( Word8 ) -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Mutable as M -import Foreign.Storable ( Storable ) - -import Codec.Picture.Types -import Codec.Picture.BitWriter -import Codec.Picture.Jpg.Types -import Codec.Picture.Jpg.FastIdct -import Codec.Picture.Jpg.DefaultTable - --- | Same as for DcCoefficient, to provide nicer type signatures -type DctCoefficients = DcCoefficient - -data JpgUnpackerParameter = JpgUnpackerParameter - { dcHuffmanTree :: !HuffmanPackedTree - , acHuffmanTree :: !HuffmanPackedTree - , componentIndex :: {-# UNPACK #-} !Int - , restartInterval :: {-# UNPACK #-} !Int - , componentWidth :: {-# UNPACK #-} !Int - , componentHeight :: {-# UNPACK #-} !Int - , subSampling :: !(Int, Int) - , coefficientRange :: !(Int, Int) - , successiveApprox :: !(Int, Int) - , readerIndex :: {-# UNPACK #-} !Int - -- | When in progressive mode, we can have many - -- color in a scan are only one. The indices changes - -- on this fact, when mixed, there is whole - -- MCU for all color components, spanning multiple - -- block lines. With only one color component we use - -- the normal raster order. - , indiceVector :: {-# UNPACK #-} !Int - , blockIndex :: {-# UNPACK #-} !Int - , blockMcuX :: {-# UNPACK #-} !Int - , blockMcuY :: {-# UNPACK #-} !Int - } - deriving Show - -toBlockSize :: Int -> Int -toBlockSize v = (v + 7) `div` 8 - -decodeRestartInterval :: BoolReader s Int32 -decodeRestartInterval = return (-1) {- do - bits <- replicateM 8 getNextBitJpg - if bits == replicate 8 True - then do - marker <- replicateM 8 getNextBitJpg - return $ packInt marker - else return (-1) - -} - -{-# INLINE decodeInt #-} -decodeInt :: Int -> BoolReader s Int32 -decodeInt ssss = do - signBit <- getNextBitJpg - let dataRange = 1 `unsafeShiftL` fromIntegral (ssss - 1) - leftBitCount = ssss - 1 - -- First following bits store the sign of the coefficient, and counted in - -- SSSS, so the bit count for the int, is ssss - 1 - if signBit - then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount - else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount - -decodeRrrrSsss :: HuffmanPackedTree -> BoolReader s (Int, Int) -decodeRrrrSsss tree = do - rrrrssss <- huffmanPackedDecode tree - let rrrr = (rrrrssss `unsafeShiftR` 4) .&. 0xF - ssss = rrrrssss .&. 0xF - pure (fromIntegral rrrr, fromIntegral ssss) - -dcCoefficientDecode :: HuffmanPackedTree -> BoolReader s DcCoefficient -dcCoefficientDecode dcTree = do - ssss <- huffmanPackedDecode dcTree - if ssss == 0 - then return 0 - else fromIntegral <$> decodeInt (fromIntegral ssss) - --- | Apply a quantization matrix to a macroblock -{-# INLINE deQuantize #-} -deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -deQuantize table block = update 0 - where update 64 = return block - update i = do - val <- block `M.unsafeRead` i - let finalValue = val * (table `VS.unsafeIndex` i) - (block `M.unsafeWrite` i) finalValue - update $ i + 1 - -inverseDirectCosineTransform :: MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -inverseDirectCosineTransform mBlock = - fastIdct mBlock >>= mutableLevelShift - -zigZagOrder :: MacroBlock Int -zigZagOrder = makeMacroBlock $ concat - [[ 0, 1, 5, 6,14,15,27,28] - ,[ 2, 4, 7,13,16,26,29,42] - ,[ 3, 8,12,17,25,30,41,43] - ,[ 9,11,18,24,31,40,44,53] - ,[10,19,23,32,39,45,52,54] - ,[20,22,33,38,46,51,55,60] - ,[21,34,37,47,50,56,59,61] - ,[35,36,48,49,57,58,62,63] - ] - -zigZagReorderForwardv :: (Storable a, Num a) => VS.Vector a -> VS.Vector a -zigZagReorderForwardv vec = runST $ do - v <- M.new 64 - mv <- VS.thaw vec - zigZagReorderForward v mv >>= VS.freeze - -zigZagOrderForward :: MacroBlock Int -zigZagOrderForward = VS.generate 64 inv - where inv i = fromMaybe 0 $ VS.findIndex (i ==) zigZagOrder - -zigZagReorderForward :: (Storable a) - => MutableMacroBlock s a - -> MutableMacroBlock s a - -> ST s (MutableMacroBlock s a) -{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int32 - -> MutableMacroBlock s Int32 - -> ST s (MutableMacroBlock s Int32) #-} -{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int16 - -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) #-} -{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Word8 - -> MutableMacroBlock s Word8 - -> ST s (MutableMacroBlock s Word8) #-} -zigZagReorderForward zigzaged block = ordering zigZagOrderForward >> return zigzaged - where ordering !table = reorder (0 :: Int) - where reorder !i | i >= 64 = return () - reorder i = do - let idx = table `VS.unsafeIndex` i - v <- block `M.unsafeRead` idx - (zigzaged `M.unsafeWrite` i) v - reorder (i + 1) - -zigZagReorder :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -zigZagReorder zigzaged block = do - let update i = do - let idx = zigZagOrder `VS.unsafeIndex` i - v <- block `M.unsafeRead` idx - (zigzaged `M.unsafeWrite` i) v - - reorder 63 = update 63 - reorder i = update i >> reorder (i + 1) - - reorder (0 :: Int) - return zigzaged - --- | Unpack an int of the given size encoded from MSB to LSB. -unpackInt :: Int -> BoolReader s Int32 -unpackInt = getNextIntJpg - -{-# INLINE rasterMap #-} -rasterMap :: (Monad m) - => Int -> Int -> (Int -> Int -> m ()) - -> m () -rasterMap width height f = liner 0 - where liner y | y >= height = return () - liner y = columner 0 - where columner x | x >= width = liner (y + 1) - columner x = f x y >> columner (x + 1) - -pixelClamp :: Int16 -> Word8 -pixelClamp n = fromIntegral . min 255 $ max 0 n - --- | Given a size coefficient (how much a pixel span horizontally --- and vertically), the position of the macroblock, return a list --- of indices and value to be stored in an array (like the final --- image) -unpackMacroBlock :: Int -- ^ Component count - -> Int -- ^ Width coefficient - -> Int -- ^ Height coefficient - -> Int -- ^ Component index - -> Int -- ^ x - -> Int -- ^ y - -> MutableImage s PixelYCbCr8 - -> MutableMacroBlock s Int16 - -> ST s () -unpackMacroBlock compCount wCoeff hCoeff compIdx x y - (MutableImage { mutableImageWidth = imgWidth, - mutableImageHeight = imgHeight, mutableImageData = img }) - block = rasterMap dctBlockSize dctBlockSize unpacker - where unpacker i j = do - let yBase = y * dctBlockSize + j * hCoeff - compVal <- pixelClamp <$> (block `M.unsafeRead` (i + j * dctBlockSize)) - rasterMap wCoeff hCoeff $ \wDup hDup -> do - let xBase = x * dctBlockSize + i * wCoeff - xPos = xBase + wDup - yPos = yBase + hDup - - when (xPos < imgWidth && yPos < imgHeight) - (do let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx - (img `M.unsafeWrite` mutableIdx) compVal) - --- | This is one of the most important function of the decoding, --- it form the barebone decoding pipeline for macroblock. It's all --- there is to know for macro block transformation -decodeMacroBlock :: MacroBlock DctCoefficients - -> MutableMacroBlock s Int16 - -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -decodeMacroBlock quantizationTable zigZagBlock block = - deQuantize quantizationTable block >>= zigZagReorder zigZagBlock - >>= inverseDirectCosineTransform - +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +module Codec.Picture.Jpg.Common + ( DctCoefficients + , JpgUnpackerParameter( .. ) + , decodeInt + , dcCoefficientDecode + , deQuantize + , decodeRrrrSsss + , zigZagReorderForward + , zigZagReorderForwardv + , zigZagReorder + , inverseDirectCosineTransform + , unpackInt + , unpackMacroBlock + , rasterMap + , decodeMacroBlock + , decodeRestartInterval + , toBlockSize + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<$>) ) +#endif + +import Control.Monad( when ) +import Control.Monad.ST( ST, runST ) +import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) ) +import Data.Int( Int16, Int32 ) +import Data.Maybe( fromMaybe ) +import Data.Word( Word8 ) +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as M +import Foreign.Storable ( Storable ) + +import Codec.Picture.Types +import Codec.Picture.BitWriter +import Codec.Picture.Jpg.Types +import Codec.Picture.Jpg.FastIdct +import Codec.Picture.Jpg.DefaultTable + +-- | Same as for DcCoefficient, to provide nicer type signatures +type DctCoefficients = DcCoefficient + +data JpgUnpackerParameter = JpgUnpackerParameter + { dcHuffmanTree :: !HuffmanPackedTree + , acHuffmanTree :: !HuffmanPackedTree + , componentIndex :: {-# UNPACK #-} !Int + , restartInterval :: {-# UNPACK #-} !Int + , componentWidth :: {-# UNPACK #-} !Int + , componentHeight :: {-# UNPACK #-} !Int + , subSampling :: !(Int, Int) + , coefficientRange :: !(Int, Int) + , successiveApprox :: !(Int, Int) + , readerIndex :: {-# UNPACK #-} !Int + -- | When in progressive mode, we can have many + -- color in a scan or only one. The indices changes + -- on this fact, when mixed, there is whole + -- MCU for all color components, spanning multiple + -- block lines. With only one color component we use + -- the normal raster order. + , indiceVector :: {-# UNPACK #-} !Int + , blockIndex :: {-# UNPACK #-} !Int + , blockMcuX :: {-# UNPACK #-} !Int + , blockMcuY :: {-# UNPACK #-} !Int + } + deriving Show + +toBlockSize :: Int -> Int +toBlockSize v = (v + 7) `div` 8 + +decodeRestartInterval :: BoolReader s Int32 +decodeRestartInterval = return (-1) {- do + bits <- replicateM 8 getNextBitJpg + if bits == replicate 8 True + then do + marker <- replicateM 8 getNextBitJpg + return $ packInt marker + else return (-1) + -} + +{-# INLINE decodeInt #-} +decodeInt :: Int -> BoolReader s Int32 +decodeInt ssss = do + signBit <- getNextBitJpg + let dataRange = 1 `unsafeShiftL` fromIntegral (ssss - 1) + leftBitCount = ssss - 1 + -- First following bits store the sign of the coefficient, and counted in + -- SSSS, so the bit count for the int, is ssss - 1 + if signBit + then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount + else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount + +decodeRrrrSsss :: HuffmanPackedTree -> BoolReader s (Int, Int) +decodeRrrrSsss tree = do + rrrrssss <- huffmanPackedDecode tree + let rrrr = (rrrrssss `unsafeShiftR` 4) .&. 0xF + ssss = rrrrssss .&. 0xF + pure (fromIntegral rrrr, fromIntegral ssss) + +dcCoefficientDecode :: HuffmanPackedTree -> BoolReader s DcCoefficient +dcCoefficientDecode dcTree = do + ssss <- huffmanPackedDecode dcTree + if ssss == 0 + then return 0 + else fromIntegral <$> decodeInt (fromIntegral ssss) + +-- | Apply a quantization matrix to a macroblock +{-# INLINE deQuantize #-} +deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +deQuantize table block = update 0 + where update 64 = return block + update i = do + val <- block `M.unsafeRead` i + let finalValue = val * (table `VS.unsafeIndex` i) + (block `M.unsafeWrite` i) finalValue + update $ i + 1 + +inverseDirectCosineTransform :: MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +inverseDirectCosineTransform mBlock = + fastIdct mBlock >>= mutableLevelShift + +zigZagOrder :: MacroBlock Int +zigZagOrder = makeMacroBlock $ concat + [[ 0, 1, 5, 6,14,15,27,28] + ,[ 2, 4, 7,13,16,26,29,42] + ,[ 3, 8,12,17,25,30,41,43] + ,[ 9,11,18,24,31,40,44,53] + ,[10,19,23,32,39,45,52,54] + ,[20,22,33,38,46,51,55,60] + ,[21,34,37,47,50,56,59,61] + ,[35,36,48,49,57,58,62,63] + ] + +zigZagReorderForwardv :: (Storable a, Num a) => VS.Vector a -> VS.Vector a +zigZagReorderForwardv vec = runST $ do + v <- M.new 64 + mv <- VS.thaw vec + zigZagReorderForward v mv >>= VS.freeze + +zigZagOrderForward :: MacroBlock Int +zigZagOrderForward = VS.generate 64 inv + where inv i = fromMaybe 0 $ VS.findIndex (i ==) zigZagOrder + +zigZagReorderForward :: (Storable a) + => MutableMacroBlock s a + -> MutableMacroBlock s a + -> ST s (MutableMacroBlock s a) +{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int32 + -> MutableMacroBlock s Int32 + -> ST s (MutableMacroBlock s Int32) #-} +{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int16 + -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) #-} +{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Word8 + -> MutableMacroBlock s Word8 + -> ST s (MutableMacroBlock s Word8) #-} +zigZagReorderForward zigzaged block = ordering zigZagOrderForward >> return zigzaged + where ordering !table = reorder (0 :: Int) + where reorder !i | i >= 64 = return () + reorder i = do + let idx = table `VS.unsafeIndex` i + v <- block `M.unsafeRead` idx + (zigzaged `M.unsafeWrite` i) v + reorder (i + 1) + +zigZagReorder :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +zigZagReorder zigzaged block = do + let update i = do + let idx = zigZagOrder `VS.unsafeIndex` i + v <- block `M.unsafeRead` idx + (zigzaged `M.unsafeWrite` i) v + + reorder 63 = update 63 + reorder i = update i >> reorder (i + 1) + + reorder (0 :: Int) + return zigzaged + +-- | Unpack an int of the given size encoded from MSB to LSB. +unpackInt :: Int -> BoolReader s Int32 +unpackInt = getNextIntJpg + +{-# INLINE rasterMap #-} +rasterMap :: (Monad m) + => Int -> Int -> (Int -> Int -> m ()) + -> m () +rasterMap width height f = liner 0 + where liner y | y >= height = return () + liner y = columner 0 + where columner x | x >= width = liner (y + 1) + columner x = f x y >> columner (x + 1) + +pixelClamp :: Int16 -> Word8 +pixelClamp n = fromIntegral . min 255 $ max 0 n + +-- | Given a size coefficient (how much a pixel span horizontally +-- and vertically), the position of the macroblock, return a list +-- of indices and value to be stored in an array (like the final +-- image) +unpackMacroBlock :: Int -- ^ Component count + -> Int -- ^ Width coefficient + -> Int -- ^ Height coefficient + -> Int -- ^ Component index + -> Int -- ^ x + -> Int -- ^ y + -> MutableImage s PixelYCbCr8 + -> MutableMacroBlock s Int16 + -> ST s () +unpackMacroBlock compCount wCoeff hCoeff compIdx x y + (MutableImage { mutableImageWidth = imgWidth, + mutableImageHeight = imgHeight, mutableImageData = img }) + block = rasterMap dctBlockSize dctBlockSize unpacker + where unpacker i j = do + let yBase = y * dctBlockSize + j * hCoeff + compVal <- pixelClamp <$> (block `M.unsafeRead` (i + j * dctBlockSize)) + rasterMap wCoeff hCoeff $ \wDup hDup -> do + let xBase = x * dctBlockSize + i * wCoeff + xPos = xBase + wDup + yPos = yBase + hDup + + when (xPos < imgWidth && yPos < imgHeight) + (do let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx + (img `M.unsafeWrite` mutableIdx) compVal) + +-- | This is one of the most important function of the decoding, +-- it form the barebone decoding pipeline for macroblock. It's all +-- there is to know for macro block transformation +decodeMacroBlock :: MacroBlock DctCoefficients + -> MutableMacroBlock s Int16 + -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +decodeMacroBlock quantizationTable zigZagBlock block = + deQuantize quantizationTable block >>= zigZagReorder zigZagBlock + >>= inverseDirectCosineTransform + diff --git a/src/Codec/Picture/Jpg/Progressive.hs b/src/Codec/Picture/Jpg/Progressive.hs --- a/src/Codec/Picture/Jpg/Progressive.hs +++ b/src/Codec/Picture/Jpg/Progressive.hs @@ -1,324 +1,332 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -module Codec.Picture.Jpg.Progressive - ( JpgUnpackerParameter( .. ) - , progressiveUnpack - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure, (<$>) ) -#endif - -import Control.Monad( when, unless, forM_ ) -import Control.Monad.ST( ST ) -import Control.Monad.Trans( lift ) -import Data.Bits( (.&.), (.|.), unsafeShiftL ) -import Data.Int( Int16, Int32 ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.Vector as V -import qualified Data.Vector.Storable as VS -import Data.Vector( (!) ) -import qualified Data.Vector.Mutable as M -import qualified Data.Vector.Storable.Mutable as MS - -import Codec.Picture.Types -import Codec.Picture.BitWriter -import Codec.Picture.Jpg.Common -import Codec.Picture.Jpg.Types -import Codec.Picture.Jpg.DefaultTable - -createMcuLineIndices :: JpgComponent -> Int -> Int -> V.Vector (VS.Vector Int) -createMcuLineIndices param imgWidth mcuWidth = - V.fromList $ VS.fromList <$> [indexSolo, indexMulti] - where compW = fromIntegral $ horizontalSamplingFactor param - compH = fromIntegral $ verticalSamplingFactor param - imageBlockSize = toBlockSize imgWidth - - indexSolo = take (imageBlockSize * compH) [0 ..] - indexMulti = - [(mcu + y * mcuWidth) * compW + x - | mcu <- [0 .. mcuWidth - 1] - , y <- [0 .. compH - 1] - , x <- [0 .. compW - 1] ] - -decodeFirstDC :: JpgUnpackerParameter - -> MS.STVector s Int16 - -> MutableMacroBlock s Int16 - -> Int32 - -> BoolReader s Int32 -decodeFirstDC params dcCoeffs block eobrun = unpack >> pure eobrun - where unpack = do - (dcDeltaCoefficient) <- dcCoefficientDecode $ dcHuffmanTree params - previousDc <- lift $ dcCoeffs `MS.unsafeRead` componentIndex params - let neoDcCoefficient = previousDc + dcDeltaCoefficient - approxLow = fst $ successiveApprox params - scaledDc = neoDcCoefficient `unsafeShiftL` approxLow - lift $ (block `MS.unsafeWrite` 0) scaledDc - lift $ (dcCoeffs `MS.unsafeWrite` componentIndex params) neoDcCoefficient - -decodeRefineDc :: JpgUnpackerParameter - -> a - -> MutableMacroBlock s Int16 - -> Int32 - -> BoolReader s Int32 -decodeRefineDc params _ block eobrun = unpack >> pure eobrun - where approxLow = fst $ successiveApprox params - plusOne = 1 `unsafeShiftL` approxLow - unpack = do - bit <- getNextBitJpg - when bit . lift $ do - v <- block `MS.unsafeRead` 0 - (block `MS.unsafeWrite` 0) $ v .|. plusOne - -decodeFirstAc :: JpgUnpackerParameter - -> a - -> MutableMacroBlock s Int16 - -> Int32 - -> BoolReader s Int32 -decodeFirstAc _params _ _block eobrun | eobrun > 0 = pure $ eobrun - 1 -decodeFirstAc params _ block _ = unpack startIndex - where (startIndex, maxIndex) = coefficientRange params - (low, _) = successiveApprox params - unpack n | n > maxIndex = pure 0 - unpack n = do - rrrrssss <- decodeRrrrSsss $ acHuffmanTree params - case rrrrssss of - (0xF, 0) -> unpack $ n + 16 - ( 0, 0) -> return 0 - ( r, 0) -> eobrun <$> unpackInt r - where eobrun lowBits = (1 `unsafeShiftL` r) - 1 + lowBits - ( r, s) -> do - let n' = n + r - val <- (`unsafeShiftL` low) <$> decodeInt s - lift . (block `MS.unsafeWrite` n') $ fromIntegral val - unpack $ n' + 1 - -decodeRefineAc :: forall a s. JpgUnpackerParameter - -> a - -> MutableMacroBlock s Int16 - -> Int32 - -> BoolReader s Int32 -decodeRefineAc params _ block eobrun - | eobrun == 0 = unpack startIndex - | otherwise = performEobRun startIndex >> return (eobrun - 1) - where (startIndex, maxIndex) = coefficientRange params - (low, _) = successiveApprox params - plusOne = 1 `unsafeShiftL` low - minusOne = (-1) `unsafeShiftL` low - - getBitVal = do - v <- getNextBitJpg - pure $ if v then plusOne else minusOne - - performEobRun idx | idx > maxIndex = pure () - performEobRun idx = do - coeff <- lift $ block `MS.unsafeRead` idx - if coeff /= 0 then do - bit <- getNextBitJpg - case (bit, (coeff .&. plusOne) == 0) of - (False, _) -> performEobRun $ idx + 1 - (True, False) -> performEobRun $ idx + 1 - (True, True) -> do - let newVal | coeff >= 0 = coeff + plusOne - | otherwise = coeff + minusOne - lift $ (block `MS.unsafeWrite` idx) newVal - performEobRun $ idx + 1 - else - performEobRun $ idx + 1 - - unpack idx | idx > maxIndex = pure 0 - unpack idx = do - rrrrssss <- decodeRrrrSsss $ acHuffmanTree params - case rrrrssss of - (0xF, 0) -> do - idx' <- updateCoeffs 0xF idx - unpack $ idx' + 1 - - ( r, 0) -> do - lowBits <- unpackInt r - let newEobRun = (1 `unsafeShiftL` r) + lowBits - 1 - performEobRun idx - pure newEobRun - - ( r, _) -> do - val <- getBitVal - idx' <- updateCoeffs (fromIntegral r) idx - when (idx' <= maxIndex) $ - lift $ (block `MS.unsafeWrite` idx') val - unpack $ idx' + 1 - - updateCoeffs :: Int -> Int -> BoolReader s Int - updateCoeffs r idx - | r < 0 = pure $ idx - 1 - | idx > maxIndex = pure idx - updateCoeffs r idx = do - coeff <- lift $ block `MS.unsafeRead` idx - if coeff /= 0 then do - bit <- getNextBitJpg - when (bit && coeff .&. plusOne == 0) $ do - let writeCoeff | coeff >= 0 = coeff + plusOne - | otherwise = coeff + minusOne - lift $ (block `MS.unsafeWrite` idx) writeCoeff - updateCoeffs r $ idx + 1 - else - updateCoeffs (r - 1) $ idx + 1 - -type Unpacker s = - JpgUnpackerParameter -> MS.STVector s Int16 -> MutableMacroBlock s Int16 -> Int32 - -> BoolReader s Int32 - - -prepareUnpacker :: [([(JpgUnpackerParameter, a)], L.ByteString)] - -> ST s ( V.Vector (V.Vector (JpgUnpackerParameter, Unpacker s)) - , M.STVector s BoolState) -prepareUnpacker lst = do - let boolStates = V.fromList $ map snd infos - vec <- V.unsafeThaw boolStates - return (V.fromList $ map fst infos, vec) - where infos = map prepare lst - prepare ([], _) = error "progressiveUnpack, no component" - prepare (whole@((param, _) : _) , byteString) = - (V.fromList $ map (\(p,_) -> (p, unpacker)) whole, boolReader) - where unpacker = selection (successiveApprox param) (coefficientRange param) - boolReader = initBoolStateJpg . B.concat $ L.toChunks byteString - - selection (_, 0) (0, _) = decodeFirstDC - selection (_, 0) _ = decodeFirstAc - selection _ (0, _) = decodeRefineDc - selection _ _ = decodeRefineAc - -data ComponentData s = ComponentData - { componentIndices :: V.Vector (VS.Vector Int) - , componentBlocks :: V.Vector (MutableMacroBlock s Int16) - , componentId :: !Int - , componentBlockCount :: !Int - } - --- | Iteration from 0 to n in monadic context, without data --- keeping. -lineMap :: (Monad m) => Int -> (Int -> m ()) -> m () -{-# INLINE lineMap #-} -lineMap count f = go 0 - where go n | n >= count = return () - go n = f n >> go (n + 1) - -progressiveUnpack :: (Int, Int) - -> JpgFrameHeader - -> V.Vector (MacroBlock Int16) - -> [([(JpgUnpackerParameter, a)], L.ByteString)] - -> ST s (MutableImage s PixelYCbCr8) -progressiveUnpack (maxiW, maxiH) frame quants lst = do - (unpackers, readers) <- prepareUnpacker lst - allBlocks <- mapM allocateWorkingBlocks . zip [0..] $ jpgComponents frame - :: ST s [ComponentData s] - let scanCount = length lst - restartIntervalValue = case lst of - ((p,_):_,_): _ -> restartInterval p - _ -> -1 - dcCoeffs <- MS.replicate imgComponentCount 0 - eobRuns <- MS.replicate (length lst) 0 - workBlock <- createEmptyMutableMacroBlock - writeIndices <- MS.replicate imgComponentCount (0 :: Int) - restartIntervals <- MS.replicate scanCount restartIntervalValue - let elementCount = imgWidth * imgHeight * fromIntegral imgComponentCount - img <- MutableImage imgWidth imgHeight <$> MS.replicate elementCount 128 - - let processRestartInterval = - forM_ [0 .. scanCount - 1] $ \ix -> do - v <- restartIntervals `MS.read` ix - if v == 0 then do - -- reset DC prediction - when (ix == 0) (MS.set dcCoeffs 0) - reader <- readers `M.read` ix - (_, updated) <- runBoolReaderWith reader $ - byteAlignJpg >> decodeRestartInterval - (readers `M.write` ix) updated - (eobRuns `MS.unsafeWrite` ix) 0 - (restartIntervals `MS.unsafeWrite` ix) $ restartIntervalValue - 1 - else - (restartIntervals `MS.unsafeWrite` ix) $ v - 1 - - - lineMap imageMcuHeight $ \mmY -> do - -- Reset all blocks to 0 - forM_ allBlocks $ V.mapM_ (`MS.set` 0) . componentBlocks - MS.set writeIndices 0 - - lineMap imageMcuWidth $ \_mmx -> do - processRestartInterval - V.forM_ unpackers $ V.mapM_ $ \(unpackParam, unpacker) -> do - boolState <- readers `M.read` readerIndex unpackParam - eobrun <- eobRuns `MS.read` readerIndex unpackParam - let componentNumber = componentIndex unpackParam - writeIndex <- writeIndices `MS.read` componentNumber - let componentData = allBlocks !! componentNumber - -- We get back the correct block indices for the number of component - -- in the current scope (precalculated) - indexVector = - componentIndices componentData ! indiceVector unpackParam - maxIndexLength = VS.length indexVector - unless (writeIndex + blockIndex unpackParam >= maxIndexLength) $ do - let realIndex = indexVector VS.! (writeIndex + blockIndex unpackParam) - writeBlock = componentBlocks componentData ! realIndex - (eobrun', state) <- - runBoolReaderWith boolState $ - unpacker unpackParam dcCoeffs writeBlock eobrun - - (readers `M.write` readerIndex unpackParam) state - (eobRuns `MS.write` readerIndex unpackParam) eobrun' - - -- Update the write indices - forM_ allBlocks $ \comp -> do - writeIndex <- writeIndices `MS.read` componentId comp - let newIndex = writeIndex + componentBlockCount comp - (writeIndices `MS.write` componentId comp) newIndex - - forM_ allBlocks $ \compData -> do - let compBlocks = componentBlocks compData - cId = componentId compData - comp = jpgComponents frame !! cId - quantId = - fromIntegral $ quantizationTableDest comp - table = quants ! min 3 quantId - compW = fromIntegral $ horizontalSamplingFactor comp - compH = fromIntegral $ verticalSamplingFactor comp - cw8 = maxiW - fromIntegral (horizontalSamplingFactor comp) + 1 - ch8 = maxiH - fromIntegral (verticalSamplingFactor comp) + 1 - - rasterMap (imageMcuWidth * compW) compH $ \rx y -> do - let ry = mmY * maxiH + y - block = compBlocks ! (y * imageMcuWidth * compW + rx) - transformed <- decodeMacroBlock table workBlock block - unpackMacroBlock imgComponentCount - cw8 ch8 cId (rx * cw8) ry - img transformed - - return img - - where imgComponentCount = length $ jpgComponents frame - - imgWidth = fromIntegral $ jpgWidth frame - imgHeight = fromIntegral $ jpgHeight frame - - imageBlockWidth = toBlockSize imgWidth - imageBlockHeight = toBlockSize imgHeight - - imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW - imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH - - allocateWorkingBlocks (ix, comp) = do - let blockCount = hSample * vSample * imageMcuWidth * 2 - blocks <- V.replicateM blockCount createEmptyMutableMacroBlock - return ComponentData - { componentBlocks = blocks - , componentIndices = createMcuLineIndices comp imgWidth imageMcuWidth - , componentBlockCount = hSample * vSample - , componentId = ix - } - where hSample = fromIntegral $ horizontalSamplingFactor comp - vSample = fromIntegral $ verticalSamplingFactor comp - +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +module Codec.Picture.Jpg.Progressive + ( JpgUnpackerParameter( .. ) + , progressiveUnpack + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<$>) ) +#endif + +import Control.Monad( when, unless, forM_ ) +import Control.Monad.ST( ST ) +import Control.Monad.Trans( lift ) +import Data.Bits( (.&.), (.|.), unsafeShiftL ) +import Data.Int( Int16, Int32 ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import Data.Vector( (!) ) +import qualified Data.Vector.Mutable as M +import qualified Data.Vector.Storable.Mutable as MS + +import Codec.Picture.Types +import Codec.Picture.BitWriter +import Codec.Picture.Jpg.Common +import Codec.Picture.Jpg.Types +import Codec.Picture.Jpg.DefaultTable + +createMcuLineIndices :: JpgComponent -> Int -> Int -> V.Vector (VS.Vector Int) +createMcuLineIndices param imgWidth mcuWidth = + V.fromList $ VS.fromList <$> [indexSolo, indexMulti] + where compW = fromIntegral $ horizontalSamplingFactor param + compH = fromIntegral $ verticalSamplingFactor param + imageBlockSize = toBlockSize imgWidth + + -- if the displayed MCU block is only displayed in half (like with + -- width 500 then we loose one macroblock of the MCU at the end of + -- the line. Previous implementation which naïvely used full mcu + -- was wrong. Only taking into account visible macroblocks + indexSolo = [base + x + | y <- [0 .. compH - 1] + , let base = y * mcuWidth * compW + , x <- [0 .. imageBlockSize - 1]] + + indexMulti = + [(mcu + y * mcuWidth) * compW + x + | mcu <- [0 .. mcuWidth - 1] + , y <- [0 .. compH - 1] + , x <- [0 .. compW - 1] ] + +decodeFirstDC :: JpgUnpackerParameter + -> MS.STVector s Int16 + -> MutableMacroBlock s Int16 + -> Int32 + -> BoolReader s Int32 +decodeFirstDC params dcCoeffs block eobrun = unpack >> pure eobrun + where unpack = do + (dcDeltaCoefficient) <- dcCoefficientDecode $ dcHuffmanTree params + previousDc <- lift $ dcCoeffs `MS.unsafeRead` componentIndex params + let neoDcCoefficient = previousDc + dcDeltaCoefficient + approxLow = fst $ successiveApprox params + scaledDc = neoDcCoefficient `unsafeShiftL` approxLow + lift $ (block `MS.unsafeWrite` 0) scaledDc + lift $ (dcCoeffs `MS.unsafeWrite` componentIndex params) neoDcCoefficient + +decodeRefineDc :: JpgUnpackerParameter + -> a + -> MutableMacroBlock s Int16 + -> Int32 + -> BoolReader s Int32 +decodeRefineDc params _ block eobrun = unpack >> pure eobrun + where approxLow = fst $ successiveApprox params + plusOne = 1 `unsafeShiftL` approxLow + unpack = do + bit <- getNextBitJpg + when bit . lift $ do + v <- block `MS.unsafeRead` 0 + (block `MS.unsafeWrite` 0) $ v .|. plusOne + +decodeFirstAc :: JpgUnpackerParameter + -> a + -> MutableMacroBlock s Int16 + -> Int32 + -> BoolReader s Int32 +decodeFirstAc _params _ _block eobrun | eobrun > 0 = pure $ eobrun - 1 +decodeFirstAc params _ block _ = unpack startIndex + where (startIndex, maxIndex) = coefficientRange params + (low, _) = successiveApprox params + unpack n | n > maxIndex = pure 0 + unpack n = do + rrrrssss <- decodeRrrrSsss $ acHuffmanTree params + case rrrrssss of + (0xF, 0) -> unpack $ n + 16 + ( 0, 0) -> return 0 + ( r, 0) -> eobrun <$> unpackInt r + where eobrun lowBits = (1 `unsafeShiftL` r) - 1 + lowBits + ( r, s) -> do + let n' = n + r + val <- (`unsafeShiftL` low) <$> decodeInt s + lift . (block `MS.unsafeWrite` n') $ fromIntegral val + unpack $ n' + 1 + +decodeRefineAc :: forall a s. JpgUnpackerParameter + -> a + -> MutableMacroBlock s Int16 + -> Int32 + -> BoolReader s Int32 +decodeRefineAc params _ block eobrun + | eobrun == 0 = unpack startIndex + | otherwise = performEobRun startIndex >> return (eobrun - 1) + where (startIndex, maxIndex) = coefficientRange params + (low, _) = successiveApprox params + plusOne = 1 `unsafeShiftL` low + minusOne = (-1) `unsafeShiftL` low + + getBitVal = do + v <- getNextBitJpg + pure $ if v then plusOne else minusOne + + performEobRun idx | idx > maxIndex = pure () + performEobRun idx = do + coeff <- lift $ block `MS.unsafeRead` idx + if coeff /= 0 then do + bit <- getNextBitJpg + case (bit, (coeff .&. plusOne) == 0) of + (False, _) -> performEobRun $ idx + 1 + (True, False) -> performEobRun $ idx + 1 + (True, True) -> do + let newVal | coeff >= 0 = coeff + plusOne + | otherwise = coeff + minusOne + lift $ (block `MS.unsafeWrite` idx) newVal + performEobRun $ idx + 1 + else + performEobRun $ idx + 1 + + unpack idx | idx > maxIndex = pure 0 + unpack idx = do + rrrrssss <- decodeRrrrSsss $ acHuffmanTree params + case rrrrssss of + (0xF, 0) -> do + idx' <- updateCoeffs 0xF idx + unpack $ idx' + 1 + + ( r, 0) -> do + lowBits <- unpackInt r + let newEobRun = (1 `unsafeShiftL` r) + lowBits - 1 + performEobRun idx + pure newEobRun + + ( r, _) -> do + val <- getBitVal + idx' <- updateCoeffs (fromIntegral r) idx + when (idx' <= maxIndex) $ + lift $ (block `MS.unsafeWrite` idx') val + unpack $ idx' + 1 + + updateCoeffs :: Int -> Int -> BoolReader s Int + updateCoeffs r idx + | r < 0 = pure $ idx - 1 + | idx > maxIndex = pure idx + updateCoeffs r idx = do + coeff <- lift $ block `MS.unsafeRead` idx + if coeff /= 0 then do + bit <- getNextBitJpg + when (bit && coeff .&. plusOne == 0) $ do + let writeCoeff | coeff >= 0 = coeff + plusOne + | otherwise = coeff + minusOne + lift $ (block `MS.unsafeWrite` idx) writeCoeff + updateCoeffs r $ idx + 1 + else + updateCoeffs (r - 1) $ idx + 1 + +type Unpacker s = + JpgUnpackerParameter -> MS.STVector s Int16 -> MutableMacroBlock s Int16 -> Int32 + -> BoolReader s Int32 + + +prepareUnpacker :: [([(JpgUnpackerParameter, a)], L.ByteString)] + -> ST s ( V.Vector (V.Vector (JpgUnpackerParameter, Unpacker s)) + , M.STVector s BoolState) +prepareUnpacker lst = do + let boolStates = V.fromList $ map snd infos + vec <- V.unsafeThaw boolStates + return (V.fromList $ map fst infos, vec) + where infos = map prepare lst + prepare ([], _) = error "progressiveUnpack, no component" + prepare (whole@((param, _) : _) , byteString) = + (V.fromList $ map (\(p,_) -> (p, unpacker)) whole, boolReader) + where unpacker = selection (successiveApprox param) (coefficientRange param) + boolReader = initBoolStateJpg . B.concat $ L.toChunks byteString + + selection (_, 0) (0, _) = decodeFirstDC + selection (_, 0) _ = decodeFirstAc + selection _ (0, _) = decodeRefineDc + selection _ _ = decodeRefineAc + +data ComponentData s = ComponentData + { componentIndices :: V.Vector (VS.Vector Int) + , componentBlocks :: V.Vector (MutableMacroBlock s Int16) + , componentId :: !Int + , componentBlockCount :: !Int + } + +-- | Iteration from 0 to n in monadic context, without data +-- keeping. +lineMap :: (Monad m) => Int -> (Int -> m ()) -> m () +{-# INLINE lineMap #-} +lineMap count f = go 0 + where go n | n >= count = return () + go n = f n >> go (n + 1) + +progressiveUnpack :: (Int, Int) + -> JpgFrameHeader + -> V.Vector (MacroBlock Int16) + -> [([(JpgUnpackerParameter, a)], L.ByteString)] + -> ST s (MutableImage s PixelYCbCr8) +progressiveUnpack (maxiW, maxiH) frame quants lst = do + (unpackers, readers) <- prepareUnpacker lst + allBlocks <- mapM allocateWorkingBlocks . zip [0..] $ jpgComponents frame + :: ST s [ComponentData s] + let scanCount = length lst + restartIntervalValue = case lst of + ((p,_):_,_): _ -> restartInterval p + _ -> -1 + dcCoeffs <- MS.replicate imgComponentCount 0 + eobRuns <- MS.replicate (length lst) 0 + workBlock <- createEmptyMutableMacroBlock + writeIndices <- MS.replicate imgComponentCount (0 :: Int) + restartIntervals <- MS.replicate scanCount restartIntervalValue + let elementCount = imgWidth * imgHeight * fromIntegral imgComponentCount + img <- MutableImage imgWidth imgHeight <$> MS.replicate elementCount 128 + + let processRestartInterval = + forM_ [0 .. scanCount - 1] $ \ix -> do + v <- restartIntervals `MS.read` ix + if v == 0 then do + -- reset DC prediction + when (ix == 0) (MS.set dcCoeffs 0) + reader <- readers `M.read` ix + (_, updated) <- runBoolReaderWith reader $ + byteAlignJpg >> decodeRestartInterval + (readers `M.write` ix) updated + (eobRuns `MS.unsafeWrite` ix) 0 + (restartIntervals `MS.unsafeWrite` ix) $ restartIntervalValue - 1 + else + (restartIntervals `MS.unsafeWrite` ix) $ v - 1 + + + lineMap imageMcuHeight $ \mmY -> do + -- Reset all blocks to 0 + forM_ allBlocks $ V.mapM_ (`MS.set` 0) . componentBlocks + MS.set writeIndices 0 + + lineMap imageMcuWidth $ \_mmx -> do + processRestartInterval + V.forM_ unpackers $ V.mapM_ $ \(unpackParam, unpacker) -> do + boolState <- readers `M.read` readerIndex unpackParam + eobrun <- eobRuns `MS.read` readerIndex unpackParam + let componentNumber = componentIndex unpackParam + writeIndex <- writeIndices `MS.read` componentNumber + let componentData = allBlocks !! componentNumber + -- We get back the correct block indices for the number of component + -- in the current scope (precalculated) + indexVector = + componentIndices componentData ! indiceVector unpackParam + maxIndexLength = VS.length indexVector + unless (writeIndex + blockIndex unpackParam >= maxIndexLength) $ do + let realIndex = indexVector VS.! (writeIndex + blockIndex unpackParam) + writeBlock = componentBlocks componentData ! realIndex + (eobrun', state) <- + runBoolReaderWith boolState $ + unpacker unpackParam dcCoeffs writeBlock eobrun + + (readers `M.write` readerIndex unpackParam) state + (eobRuns `MS.write` readerIndex unpackParam) eobrun' + + -- Update the write indices + forM_ allBlocks $ \comp -> do + writeIndex <- writeIndices `MS.read` componentId comp + let newIndex = writeIndex + componentBlockCount comp + (writeIndices `MS.write` componentId comp) newIndex + + forM_ allBlocks $ \compData -> do + let compBlocks = componentBlocks compData + cId = componentId compData + comp = jpgComponents frame !! cId + quantId = + fromIntegral $ quantizationTableDest comp + table = quants ! min 3 quantId + compW = fromIntegral $ horizontalSamplingFactor comp + compH = fromIntegral $ verticalSamplingFactor comp + cw8 = maxiW - fromIntegral (horizontalSamplingFactor comp) + 1 + ch8 = maxiH - fromIntegral (verticalSamplingFactor comp) + 1 + + rasterMap (imageMcuWidth * compW) compH $ \rx y -> do + let ry = mmY * maxiH + y + block = compBlocks ! (y * imageMcuWidth * compW + rx) + transformed <- decodeMacroBlock table workBlock block + unpackMacroBlock imgComponentCount + cw8 ch8 cId (rx * cw8) ry + img transformed + + return img + + where imgComponentCount = length $ jpgComponents frame + + imgWidth = fromIntegral $ jpgWidth frame + imgHeight = fromIntegral $ jpgHeight frame + + imageBlockWidth = toBlockSize imgWidth + imageBlockHeight = toBlockSize imgHeight + + imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW + imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH + + allocateWorkingBlocks (ix, comp) = do + let blockCount = hSample * vSample * imageMcuWidth * 2 + blocks <- V.replicateM blockCount createEmptyMutableMacroBlock + return ComponentData + { componentBlocks = blocks + , componentIndices = createMcuLineIndices comp imgWidth imageMcuWidth + , componentBlockCount = hSample * vSample + , componentId = ix + } + where hSample = fromIntegral $ horizontalSamplingFactor comp + vSample = fromIntegral $ verticalSamplingFactor comp +