JuicyPixels 3.2.9.1 → 3.2.9.2
raw patch · 4 files changed
+581/−567 lines, 4 files
Files
- JuicyPixels.cabal +3/−3
- changelog +6/−0
- src/Codec/Picture/Jpg/Common.hs +240/−240
- src/Codec/Picture/Jpg/Progressive.hs +332/−324
JuicyPixels.cabal view
@@ -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: <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>> @@ -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,
changelog view
@@ -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 ----------------------
src/Codec/Picture/Jpg/Common.hs view
@@ -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 +
src/Codec/Picture/Jpg/Progressive.hs view
@@ -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 +