JuicyPixels 1.1 → 1.2
raw patch · 10 files changed
+1077/−185 lines, 10 filesdep +deepseqPVP ok
version bump matches the API change (PVP)
Dependencies added: deepseq
API changes (from Hackage documentation)
- Codec.Picture.Jpg: readJpeg :: FilePath -> IO (Either String DynamicImage)
- Codec.Picture.Png: readPng :: FilePath -> IO (Either String DynamicImage)
+ Codec.Picture: encodeJpeg :: Image PixelYCbCr8 -> ByteString
+ Codec.Picture: encodeJpegAtQuality :: Word8 -> Image PixelYCbCr8 -> ByteString
+ Codec.Picture: generateImage :: Pixel a => (Int -> Int -> a) -> Int -> Int -> Image a
+ Codec.Picture: pixelMap :: (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
+ Codec.Picture: readBitmap :: FilePath -> IO (Either String DynamicImage)
+ Codec.Picture.Jpg: encodeJpeg :: Image PixelYCbCr8 -> ByteString
+ Codec.Picture.Jpg: encodeJpegAtQuality :: Word8 -> Image PixelYCbCr8 -> ByteString
+ Codec.Picture.Jpg: instance SizeCalculable JpgComponent
+ Codec.Picture.Jpg: instance SizeCalculable JpgFrameHeader
+ Codec.Picture.Jpg: instance SizeCalculable JpgScanHeader
+ Codec.Picture.Jpg: instance SizeCalculable JpgScanSpecification
+ Codec.Picture.Types: class Pixel a => LumaPlaneExtractable a where extractLumaPlane = pixelMap computeLuma
+ Codec.Picture.Types: class (Pixel a, Pixel b) => TransparentPixel a b | a -> b
+ Codec.Picture.Types: computeLuma :: LumaPlaneExtractable a => a -> Pixel8
+ Codec.Picture.Types: dropAlphaLayer :: TransparentPixel a b => Image a -> Image b
+ Codec.Picture.Types: dropTransparency :: TransparentPixel a b => a -> b
+ Codec.Picture.Types: extractComponent :: Pixel a => Int -> Image a -> Image Pixel8
+ Codec.Picture.Types: extractLumaPlane :: LumaPlaneExtractable a => Image a -> Image Pixel8
+ Codec.Picture.Types: generateImage :: Pixel a => (Int -> Int -> a) -> Int -> Int -> Image a
+ Codec.Picture.Types: instance ColorSpaceConvertible PixelRGB8 PixelYCbCr8
+ Codec.Picture.Types: instance LumaPlaneExtractable Pixel8
+ Codec.Picture.Types: instance LumaPlaneExtractable PixelRGB8
+ Codec.Picture.Types: instance LumaPlaneExtractable PixelRGBA8
+ Codec.Picture.Types: instance LumaPlaneExtractable PixelYA8
+ Codec.Picture.Types: instance LumaPlaneExtractable PixelYCbCr8
+ Codec.Picture.Types: instance NFData (Image a)
+ Codec.Picture.Types: instance NFData (MutableImage s a)
+ Codec.Picture.Types: instance NFData DynamicImage
+ Codec.Picture.Types: instance Pixel a => ColorSpaceConvertible a a
+ Codec.Picture.Types: instance TransparentPixel PixelRGBA8 PixelRGB8
+ Codec.Picture.Types: instance TransparentPixel PixelYA8 Pixel8
+ Codec.Picture.Types: pixelMap :: (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
- Codec.Picture.Types: class (Pixel a, Pixel b) => ColorConvertible a b where promoteImage image@(Image {imageWidth = w, imageHeight = h}) = Image w h pixels where pixels = runST $ do { newArr <- replicate (w * h * componentCount (undefined :: b)) 0; let wrapped = MutableImage w h newArr promotedPixel :: Int -> Int -> b promotedPixel x y = promotePixel $ pixelAt image x y; sequence_ [writePixel wrapped x y $ promotedPixel x y | y <- [0 .. h - 1], x <- [0 .. w - 1]]; unsafeFreeze newArr }
+ Codec.Picture.Types: class (Pixel a, Pixel b) => ColorConvertible a b where promoteImage = pixelMap promotePixel
- Codec.Picture.Types: class (Pixel a, Pixel b) => ColorSpaceConvertible a b where convertImage image@(Image {imageWidth = w, imageHeight = h}) = Image w h pixels where pixels = runST $ do { newArr <- replicate (w * h * componentCount (undefined :: b)) 0; let wrapped = MutableImage w h newArr promotedPixel :: Int -> Int -> b promotedPixel x y = convertPixel $ pixelAt image x y; sequence_ [writePixel wrapped x y $ promotedPixel x y | y <- [0 .. h - 1], x <- [0 .. w - 1]]; unsafeFreeze newArr }
+ Codec.Picture.Types: class (Pixel a, Pixel b) => ColorSpaceConvertible a b where convertImage = pixelMap convertPixel
Files
- Codec/Picture.hs +41/−4
- Codec/Picture/BitWriter.hs +145/−0
- Codec/Picture/Jpg.hs +338/−78
- Codec/Picture/Jpg/DefaultTable.hs +70/−18
- Codec/Picture/Jpg/FastDct.hs +209/−0
- Codec/Picture/Jpg/FastIdct.hs +18/−44
- Codec/Picture/Jpg/Types.hs +61/−0
- Codec/Picture/Png.hs +1/−6
- Codec/Picture/Types.hs +181/−27
- JuicyPixels.cabal +13/−8
Codec/Picture.hs view
@@ -13,11 +13,15 @@ -- * Generic functions readImage , decodeImage + , pixelMap + , generateImage + -- * Specific image format functions -- ** Bitmap handling , BmpEncodable , writeBitmap , encodeBitmap + , readBitmap , decodeBitmap , encodeDynamicBitmap , writeDynamicBitmap @@ -25,6 +29,8 @@ -- ** Jpeg handling , readJpeg , decodeJpeg + , encodeJpeg + , encodeJpegAtQuality -- ** Png handling , PngSavable( .. ) @@ -48,11 +54,17 @@ ) where import Control.Applicative( (<$>) ) -import Codec.Picture.Bitmap -import Codec.Picture.Jpg( readJpeg, decodeJpeg ) -import Codec.Picture.Png( PngSavable( .. ), readPng, decodePng, writePng +import Control.DeepSeq( NFData, deepseq ) +import Control.Exception( catch, IOException ) +import Codec.Picture.Bitmap( BmpEncodable, decodeBitmap + , writeBitmap, encodeBitmap + , encodeDynamicBitmap, writeDynamicBitmap ) +import Codec.Picture.Jpg( decodeJpeg, encodeJpeg, encodeJpegAtQuality ) +import Codec.Picture.Png( PngSavable( .. ), decodePng, writePng , encodeDynamicPng , writeDynamicPng ) import Codec.Picture.Types +import System.IO ( withFile, IOMode(ReadMode) ) +import Prelude hiding(catch) import qualified Data.ByteString as B @@ -64,10 +76,21 @@ Left err -> inner (errAcc ++ hdr ++ " " ++ err ++ "\n") rest Right rez -> Right rez +withImageDecoder :: (NFData a) + => (B.ByteString -> Either String a) -> FilePath + -> IO (Either String a) +withImageDecoder decoder path = catch doit + (\e -> return . Left $ show (e :: IOException)) + where doit = withFile path ReadMode $ \h -> + force . decoder <$> B.hGetContents h + -- force appeared in deepseq 1.3, Haskell Platform + -- provide 1.1 + force x = x `deepseq` x + -- | Load an image file without even thinking about it, it does everything -- as 'decodeImage' readImage :: FilePath -> IO (Either String DynamicImage) -readImage path = decodeImage <$> B.readFile path +readImage = withImageDecoder decodeImage -- | If you want to decode an image in a bytestring without even thinking -- in term of format or whatever, this is the function to use. It will try @@ -79,3 +102,17 @@ ,("Bitmap", decodeBitmap) ] +-- | Helper function trying to load a png file from a file on disk. +readPng :: FilePath -> IO (Either String DynamicImage) +readPng = withImageDecoder decodePng + +-- | Try to load a jpeg file and decompress. The colorspace is still +-- YCbCr if you want to perform computation on the luma part. You can +-- convert it to RGB using 'colorSpaceConversion' +readJpeg :: FilePath -> IO (Either String DynamicImage) +readJpeg = withImageDecoder decodeJpeg + +-- | Try to load a .bmp file. The colorspace would be RGB or RGBA +readBitmap :: FilePath -> IO (Either String DynamicImage) +readBitmap = withImageDecoder decodeBitmap +
+ Codec/Picture/BitWriter.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE Rank2Types #-}+-- | This module implement helper functions to read & write data+-- at bits level.+module Codec.Picture.BitWriter( BoolWriter+ , BoolReader+ , writeBits+ , byteAlign+ , getNextBit+ , setDecodedString+ , runBoolWriter+ ) where++import Control.Monad( when )+import Control.Monad.ST( ST+ -- , runST+ )+import qualified Control.Monad.Trans.State.Strict as S+import Control.Monad.Trans.Class( MonadTrans( .. ) )+import Data.Word( Word8, Word32 )+-- import Data.Serialize( Put, runPut )+import Data.Serialize.Builder( Builder, empty, append, singleton, toByteString )+import Data.Bits( Bits, (.&.), (.|.), shiftR, shiftL )++import qualified Data.ByteString as B++{-# INLINE (.>>.) #-}+{-# INLINE (.<<.) #-}+(.<<.), (.>>.) :: (Bits a) => a -> Int -> a+(.<<.) = shiftL+(.>>.) = shiftR+++--------------------------------------------------+---- Reader+--------------------------------------------------+-- | Current bit index, current value, string+type BoolState = (Int, Word8, B.ByteString)++-- | Type used to read bits+type BoolReader s a = S.StateT BoolState (ST s) a++-- | Drop all bit until the bit of indice 0, usefull to parse restart+-- marker, as they are byte aligned, but Huffman might not.+byteAlign :: BoolReader s ()+byteAlign = do+ (idx, _, chain) <- S.get+ when (idx /= 7) (setDecodedString chain)++-- | Return the next bit in the input stream.+{-# INLINE getNextBit #-}+getNextBit :: BoolReader s Bool+getNextBit = do+ (idx, v, chain) <- S.get+ let val = (v .&. (1 `shiftL` idx)) /= 0+ if idx == 0+ then setDecodedString chain+ else S.put (idx - 1, v, chain)+ return val++-- | Bitify a list of things to decode.+setDecodedString :: B.ByteString -> BoolReader s ()+setDecodedString str = case B.uncons str of+ Nothing -> S.put (maxBound, 0, B.empty)+ Just (0xFF, rest) -> case B.uncons rest of+ Nothing -> S.put (maxBound, 0, B.empty)+ Just (0x00, afterMarker) -> S.put (7, 0xFF, afterMarker)+ Just (_ , afterMarker) -> setDecodedString afterMarker+ Just (v, rest) -> S.put ( 7, v, rest)++--------------------------------------------------+---- Writer+--------------------------------------------------++-- | Run the writer and get the serialized data.+runBoolWriter :: BoolWriter s b -> ST s B.ByteString+runBoolWriter writer = do+ let finalWriter = writer >> flushWriter+ PairS _ (BoolWriteState builder _ _) <-+ run finalWriter (BoolWriteState (empty) 0 0)+ return $ toByteString builder++-- | Current serializer, bit buffer, bit count +data BoolWriteState = BoolWriteState !Builder+ {-# UNPACK #-} !Word8+ {-# UNPACK #-} !Int++data BoolWriterT m a = BitPut { run :: (BoolWriteState -> m (PairS a)) }++type BoolWriter s a = BoolWriterT (ST s) a++data PairS a = PairS a {-# UNPACK #-} !BoolWriteState++-- | If some bits are not serialized yet, write+-- them in the MSB of a word.+flushWriter :: BoolWriter s ()+flushWriter = BitPut $ \st@(BoolWriteState p val count) -> return . PairS () $+ let realVal = val `shiftL` (8 - count)+ new_context = BoolWriteState (append p (singleton realVal)) 0 0+ in if count == 0 then st else new_context++instance MonadTrans BoolWriterT where+ lift a = BitPut $ \s ->+ a >>= \b -> return $ PairS b s++instance Monad m => Monad (BoolWriterT m) where+ m >>= k = BitPut $ \s -> do+ PairS a s' <- run m s+ PairS b s'' <- run (k a) s'+ return $ PairS b s''+ return x = BitPut $ \s -> return $ PairS x s++-- | Append some data bits to a Put monad.+writeBits :: Word32 -- ^ The real data to be stored. Actual data should be in the LSB+ -> Int -- ^ Number of bit to write from 1 to 32+ -> BoolWriter s ()+writeBits = \d c -> BitPut (serialize d c)+ where dumpByte str 0xFF = append (append str (singleton 0xFF)) $ singleton 0x00+ dumpByte str i = append str (singleton i)++ serialize bitData bitCount (BoolWriteState str currentWord count)+ | bitCount + count == 8 =+ let newVal = fromIntegral $+ (currentWord .<<. bitCount) .|. fromIntegral cleanData+ in return . PairS () $ BoolWriteState (dumpByte str newVal) 0 0++ | bitCount + count < 8 =+ let newVal = currentWord .<<. bitCount+ in return . PairS () $ BoolWriteState str (newVal .|. fromIntegral cleanData)+ (count + bitCount)++ | otherwise =+ let leftBitCount = 8 - count :: Int+ highPart = cleanData .>>. (bitCount - leftBitCount) :: Word32+ prevPart = (fromIntegral currentWord) .<<. leftBitCount :: Word32++ nextMask = (1 .<<. (bitCount - leftBitCount)) - 1 :: Word32+ newData = cleanData .&. nextMask :: Word32+ newCount = bitCount - leftBitCount :: Int++ toWrite = fromIntegral $ prevPart .|. highPart :: Word8+ in serialize newData newCount (BoolWriteState (dumpByte str toWrite) 0 0)++ where cleanMask = (1 `shiftL` bitCount) - 1 :: Word32+ cleanData = bitData .&. cleanMask :: Word32+
Codec/Picture/Jpg.hs view
@@ -2,14 +2,15 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fspec-constr-count=5 #-} -- | Module used for JPEG file loading and writing. -module Codec.Picture.Jpg( readJpeg, decodeJpeg ) where +module Codec.Picture.Jpg( decodeJpeg, encodeJpegAtQuality, encodeJpeg ) where +import Control.Arrow( (>>>) ) import Control.Applicative( (<$>), (<*>)) import Control.Monad( when, replicateM, forM, forM_, foldM_, unless ) import Control.Monad.ST( ST, runST ) import Control.Monad.Trans( lift ) -import Control.Monad.Primitive ( PrimState, PrimMonad ) import qualified Control.Monad.Trans.State.Strict as S import Data.List( find, foldl' ) @@ -20,18 +21,23 @@ , getWord8, putWord8 , getWord16be, putWord16be , remaining, lookAhead, skip - , getBytes, decode ) + , getBytes, decode + , encode, putByteString + ) import Data.Maybe( fromJust ) -import qualified Data.Vector.Storable as V +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M -import Data.Array.Unboxed( Array, UArray, elems, listArray) +import Data.Array.Unboxed( Array, UArray, elems, listArray, (!) ) import qualified Data.ByteString as B import Foreign.Storable ( Storable ) +import Codec.Picture.BitWriter import Codec.Picture.Types +import Codec.Picture.Jpg.Types import Codec.Picture.Jpg.DefaultTable import Codec.Picture.Jpg.FastIdct - +import Codec.Picture.Jpg.FastDct -------------------------------------------------- ---- Types @@ -76,10 +82,14 @@ , jpgHeight :: !Word16 , jpgWidth :: !Word16 , jpgImageComponentCount :: !Word8 - , jpgComponents :: [JpgComponent] + , jpgComponents :: ![JpgComponent] } deriving Show +instance SizeCalculable JpgFrameHeader where + calculateSize hdr = 2 + 1 + 2 + 2 + 1 + + sum [calculateSize c | c <- jpgComponents hdr] + data JpgComponent = JpgComponent { componentIdentifier :: !Word8 -- | Stored with 4 bits @@ -90,6 +100,9 @@ } deriving Show +instance SizeCalculable JpgComponent where + calculateSize _ = 3 + data JpgImage = JpgImage { jpgFrame :: [JpgFrame]} deriving Show @@ -103,6 +116,9 @@ } deriving Show +instance SizeCalculable JpgScanSpecification where + calculateSize _ = 2 + data JpgScanHeader = JpgScanHeader { scanLength :: !Word16 , scanComponentCount :: !Word8 @@ -119,6 +135,12 @@ } deriving Show +instance SizeCalculable JpgScanHeader where + calculateSize hdr = 2 + 1 + + sum [calculateSize c | c <- scans hdr] + + 2 + + 1 + data JpgQuantTableSpec = JpgQuantTableSpec { -- | Stored on 4 bits quantPrecision :: !Word8 @@ -139,7 +161,7 @@ instance (SizeCalculable a, Serialize a) => Serialize (TableList a) where put (TableList lst) = do - putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + 2 mapM_ put lst get = TableList <$> (getWord16be >>= \s -> innerParse (fromIntegral s - 2)) @@ -159,7 +181,7 @@ put table = do let precision = quantPrecision table put4BitsOfEach precision (quantDestination table) - forM_ (V.toList $ quantTable table) $ \coeff -> + forM_ (VS.toList $ quantTable table) $ \coeff -> if precision == 0 then putWord8 $ fromIntegral coeff else putWord16be $ fromIntegral coeff @@ -171,7 +193,7 @@ return JpgQuantTableSpec { quantPrecision = precision , quantDestination = dest - , quantTable = V.fromListN 64 coeffs + , quantTable = VS.fromListN 64 coeffs } data JpgHuffmanTableSpec = JpgHuffmanTableSpec @@ -199,33 +221,6 @@ huffDecode (Branch _ r ) True = getNextBit >>= huffDecode r huffDecode (Leaf v) _ = return v --- | Drop all bit until the bit of indice 0, usefull to parse restart --- marker, as they are byte aligned, but Huffman might not. -byteAlign :: BoolReader s () -byteAlign = do - (idx, _, chain) <- S.get - when (idx /= 7) (setDecodedString chain) - --- | Bitify a list of things to decode. -setDecodedString :: B.ByteString -> BoolReader s () -setDecodedString str = case B.uncons str of - Nothing -> S.put (maxBound, 0, B.empty) - Just (0xFF, rest) -> case B.uncons rest of - Nothing -> S.put (maxBound, 0, B.empty) - Just (0x00, afterMarker) -> S.put (7, 0xFF, afterMarker) - Just (_ , afterMarker) -> setDecodedString afterMarker - Just (v, rest) -> S.put ( 7, v, rest) - -{-# INLINE getNextBit #-} -getNextBit :: BoolReader s Bool -getNextBit = do - (idx, v, chain) <- S.get - let val = (v .&. (1 `shiftL` idx)) /= 0 - if idx == 0 - then setDecodedString chain - else S.put (idx - 1, v, chain) - return val - -------------------------------------------------- ---- Serialization instances -------------------------------------------------- @@ -249,7 +244,16 @@ calculateSize table = 1 + 16 + sum [fromIntegral e | e <- elems $ huffSizes table] instance Serialize JpgHuffmanTableSpec where - put = error "Unimplemented" + put table = do + let classVal = if huffmanTableClass table == DcComponent + then 0 else 1 + put4BitsOfEach classVal $ huffmanTableDest table + mapM_ put {- . (\a -> trace ("sizes :" ++ show a) a) -}. elems $ huffSizes table + forM_ [0 .. 15] $ \i -> do + when (huffSizes table ! i /= 0) + (let elements = elems $ huffCodes table ! i + in mapM_ put {- . (\a -> trace (show a) a)-} $ elements) + get = do (huffClass, huffDest) <- get4BitOfEach sizes <- replicateM 16 getWord8 @@ -265,7 +269,10 @@ } instance Serialize JpgImage where - put = error "Unimplemented" + put (JpgImage { jpgFrame = frames }) = do + putWord8 0xFF >> putWord8 0xD8 >> mapM_ putFrame frames + >> putWord8 0xFF >> putWord8 0xD9 + get = do let startOfImageMarker = 0xD8 -- endOfImageMarker = 0xD9 @@ -280,6 +287,22 @@ size <- getWord16be getBytes (fromIntegral size - 2) +putFrame :: JpgFrame -> Put +putFrame (JpgAppFrame appCode str) = + put (JpgAppSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str +putFrame (JpgExtension appCode str) = + put (JpgExtensionSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str +putFrame (JpgQuantTable tables) = + put JpgQuantizationTable >> put (TableList tables) +putFrame (JpgHuffmanTable tables) = + put JpgHuffmanTableMarker >> put (TableList $ map fst tables) +putFrame (JpgIntervalRestart size) = + put JpgRestartInterval >> put (RestartInterval size) +putFrame (JpgScanBlob hdr blob) = + put JpgStartOfScan >> put hdr >> putByteString blob +putFrame (JpgScans kind hdr) = + put kind >> put hdr + parseFrames :: Get [JpgFrame] parseFrames = do kind <- get @@ -447,43 +470,22 @@ } put v = do - put $ scanLength v - put $ scanComponentCount v + putWord16be $ scanLength v + putWord8 $ scanComponentCount v mapM_ put $ scans v - put . fst $ spectralSelection v - put . snd $ spectralSelection v + putWord8 . fst $ spectralSelection v + putWord8 . snd $ spectralSelection v put4BitsOfEach (successiveApproxHigh v) $ successiveApproxLow v --- | Current bit index, current value, string -type BoolState = (Int, Word8, B.ByteString) - -type BoolReader s a = S.StateT BoolState (ST s) a - -{-# INLINE (!!!) #-} -(!!!) :: (Storable e) => V.Vector e -> Int -> e -(!!!) = V.unsafeIndex - -{-# INLINE (.!!!.) #-} -(.!!!.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> m a -(.!!!.) = M.unsafeRead - -{-# INLINE (.<-.) #-} -(.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m () -(.<-.) = M.unsafeWrite +quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32 + -> ST s (MutableMacroBlock s Int32) +quantize table = mutate (\idx val -> val `quot` (fromIntegral $ table !!! idx)) -- | Apply a quantization matrix to a macroblock {-# INLINE deQuantize #-} deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16) -deQuantize table block = dequant 0 >> return block - where updateVal i = do - val <- block .!!!. i - let quantCoeff = table !!! i - newVal = val * quantCoeff - (block .<-. i) newVal - - dequant 63 = updateVal 63 - dequant n = updateVal n >> dequant (n + 1) +deQuantize table = mutate (\ix val -> val * (table !!! ix)) inverseDirectCosineTransform :: MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16) @@ -502,7 +504,30 @@ ,[35,36,48,49,57,58,62,63] ] -zigZagReorder :: MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16) +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 + +zigZagReorderForward :: (Storable a, Num a) + => MutableMacroBlock s a + -> MutableMacroBlock s a + -> ST s (MutableMacroBlock s a) +zigZagReorderForward zigzaged block = do + let update i = do + let idx = zigZagOrder !!! i + v <- block .!!!. fromIntegral i + (zigzaged .<-. fromIntegral idx) v + + reorder 64 = return () + reorder i = update i >> reorder (i + 1) + + reorder (0 :: Int) + return zigzaged + +zigZagReorder :: (Storable a, Num a) + => MutableMacroBlock s a -> ST s (MutableMacroBlock s a) zigZagReorder block = do zigzaged <- M.replicate 64 0 let update i = do @@ -513,7 +538,7 @@ reorder 63 = update 63 reorder i = update i >> reorder (i + 1) - reorder 0 + reorder (0 :: Int) return zigzaged @@ -536,6 +561,17 @@ unpackInt :: Int32 -> BoolReader s Int32 unpackInt bitCount = packInt <$> replicateM (fromIntegral bitCount) getNextBit +powerOf :: Int32 -> Word32 +powerOf 0 = 0 +powerOf n = limit 1 0 + where val = abs n + limit range i | val < range = i + limit range i = limit (2 * range) (i + 1) + +encodeInt :: Word32 -> Int32 -> BoolWriter s () +encodeInt ssss n | n > 0 = writeBits (fromIntegral n) (fromIntegral ssss) +encodeInt ssss n = writeBits (fromIntegral $ n - 1) (fromIntegral ssss) + decodeInt :: Int32 -> BoolReader s Int32 decodeInt ssss = do signBit <- getNextBit @@ -779,12 +815,6 @@ xScalingFactor yScalingFactor ] --- | Try to load a jpeg file and decompress. The colorspace is still --- YCbCr if you want to perform computation on the luma part. You can --- convert it to RGB using 'colorSpaceConversion' -readJpeg :: FilePath -> IO (Either String DynamicImage) -readJpeg f = decodeJpeg <$> B.readFile f - -- | Try to decompress a jpeg file and decompress. The colorspace is still -- YCbCr if you want to perform computation on the luma part. You can -- convert it to RGB using 'colorSpaceConversion' @@ -812,10 +842,240 @@ imageSize = imgWidth * imgHeight * compCount - pixelData = runST $ V.unsafeFreeze =<< S.evalStateT (do + pixelData = runST $ VS.unsafeFreeze =<< S.evalStateT (do resultImage <- lift $ M.replicate imageSize 0 let wrapped = MutableImage imgWidth imgHeight resultImage - setDecodedString imgData + setDecodedString {- . (\a -> trace ("read " ++ show (map (printf "%02X" :: Word8 -> String) $ B.unpack a)) a) -}$ imgData decodeImage compCount (buildJpegImageDecoder img) wrapped return resultImage) (-1, 0, B.empty) + +extractBlock :: Image PixelYCbCr8 -- ^ Source image + -> MutableMacroBlock s Int16 -- ^ Mutable block where to put extracted block + -> Int -- ^ Plane + -> Int -- ^ X sampling factor + -> Int -- ^ Y sampling factor + -> Int -- ^ Sample per pixel + -> Int -- ^ Block x + -> Int -- ^ Block y + -> ST s (MutableMacroBlock s Int16) +extractBlock (Image { imageWidth = w, imageHeight = h, imageData = src }) + block 1 1 sampCount plane bx by | (bx * 8) + 7 < w && (by * 8) + 7 < h = do + let baseReadIdx = (by * 8 * w) + bx * 8 + sequence_ [(block .<-. (y * 8 + x)) val + | y <- [0 .. 7] + , let blockReadIdx = baseReadIdx + y * w + , x <- [0 .. 7] + , let val = fromIntegral $ src !!! ((blockReadIdx + x) * sampCount + plane) + ] + return block +extractBlock (Image { imageWidth = w, imageHeight = h, imageData = src }) + block sampWidth sampHeight sampCount plane bx by = do + let accessPixel x y | x < w && y < h = let idx = (y * w + x) * sampCount + plane in src !!! idx + | x >= w = accessPixel (w - 1) y + | otherwise = accessPixel x (h - 1) + + pixelPerCoeff = fromIntegral $ sampWidth * sampHeight + + blockVal x y = sum [fromIntegral $ accessPixel (xBase + dx) (yBase + dy) + | dy <- [0 .. sampHeight - 1] + , dx <- [0 .. sampWidth - 1] ] `div` pixelPerCoeff + where xBase = blockXBegin + x * sampWidth + yBase = blockYBegin + y * sampHeight + + blockXBegin = bx * 8 * sampWidth + blockYBegin = by * 8 * sampHeight + + sequence_ [(block .<-. (y * 8 + x)) $ blockVal x y | y <- [0 .. 7], x <- [0 .. 7] ] + return block + +serializeMacroBlock :: HuffmanWriterCode -> HuffmanWriterCode + -> MutableMacroBlock s Int32 + -> BoolWriter s () +serializeMacroBlock dcCode acCode blk = + lift (blk .!!!. 0) >>= (fromIntegral >>> encodeDc) >> writeAcs (0, 1) >> return () + where writeAcs acc@(_, 63) = + lift (blk .!!!. 63) >>= (fromIntegral >>> encodeAcCoefs acc) + writeAcs acc@(_, i ) = + lift (blk .!!!. i) >>= (fromIntegral >>> encodeAcCoefs acc) >>= writeAcs + + encodeDc n = writeBits (fromIntegral code) (fromIntegral bitCount) + >> when (ssss /= 0) (encodeInt ssss n) + where ssss = powerOf $ fromIntegral n + (bitCount, code) = dcCode V.! fromIntegral ssss + + encodeAc 0 0 = writeBits (fromIntegral code) $ fromIntegral bitCount + where (bitCount, code) = acCode V.! 0 + + encodeAc zeroCount n | zeroCount >= 16 = + writeBits (fromIntegral code) (fromIntegral bitCount) >> encodeAc (zeroCount - 16) n + where (bitCount, code) = acCode V.! 0xF0 + encodeAc zeroCount n = + writeBits (fromIntegral code) (fromIntegral bitCount) >> encodeInt ssss n + where rrrr = zeroCount `shiftL` 4 + ssss = powerOf $ fromIntegral n + rrrrssss = rrrr .|. ssss + (bitCount, code) = acCode V.! fromIntegral rrrrssss + + encodeAcCoefs ( _, 63) 0 = encodeAc 0 0 >> return (0, 64) + encodeAcCoefs (zeroRunLength, i) 0 = return (zeroRunLength + 1, i + 1) + encodeAcCoefs (zeroRunLength, i) n = + encodeAc zeroRunLength n >> return (0, i + 1) + +encodeMacroBlock :: QuantificationTable + -> MutableMacroBlock s Int32 + -> MutableMacroBlock s Int32 + -> Int16 + -> MutableMacroBlock s Int16 + -> ST s (Int32, MutableMacroBlock s Int32) +encodeMacroBlock quantTableOfComponent workData finalData prev_dc block = do + -- the inverse level shift is performed internally by the fastDCT routine + blk <- fastDctLibJpeg workData block + >>= zigZagReorderForward finalData + >>= quantize quantTableOfComponent + dc <- blk .!!!. 0 + (blk .<-. 0) $ dc - fromIntegral prev_dc + return (dc, blk) + +divUpward :: (Integral a) => a -> a -> a +divUpward n dividor = val + (if rest /= 0 then 1 else 0) + where (val, rest) = n `divMod` dividor + +prepareHuffmanTable :: DctComponent -> Word8 -> HuffmanTable + -> (JpgHuffmanTableSpec, HuffmanTree) +prepareHuffmanTable classVal dest tableDef = + (JpgHuffmanTableSpec { huffmanTableClass = classVal + , huffmanTableDest = dest + , huffSizes = sizes + , huffCodes = listArray (0, 15) + [listArray (0, fromIntegral $ (sizes ! i) - 1) lst + | (i, lst) <- zip [0..] tableDef ] + }, Empty) + where sizes = listArray (0,15) $ map (fromIntegral . length) tableDef + +-- | Encode an image in jpeg at a reasonnable quality level. +-- If you want better quality or reduced file size, you should +-- use `encodeJpegAtQuality` +encodeJpeg :: Image PixelYCbCr8 -> B.ByteString +encodeJpeg = encodeJpegAtQuality 50 + +-- | Function to call to encode an image to jpeg. +-- The quality factor should be between 0 and 100 (100 being +-- the best quality). +encodeJpegAtQuality :: Word8 -- ^ Quality factor + -> Image PixelYCbCr8 -- ^ Image to encode + -> B.ByteString -- ^ Encoded JPEG +encodeJpegAtQuality quality img@(Image { imageWidth = w, imageHeight = h }) = + encode finalImage + where finalImage = JpgImage [ JpgQuantTable quantTables + , JpgScans JpgBaselineDCTHuffman hdr + , JpgHuffmanTable huffTables + , JpgScanBlob scanHeader encodedImage + ] + + huffTables = [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable + , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable + , prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable + , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable + ] + + outputComponentCount = 3 + + scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' } + scanHeader' = JpgScanHeader + { scanLength = 0 + , scanComponentCount = outputComponentCount + , scans = [ JpgScanSpecification { componentSelector = 1 + , dcEntropyCodingTable = 0 + , acEntropyCodingTable = 0 + } + , JpgScanSpecification { componentSelector = 2 + , dcEntropyCodingTable = 1 + , acEntropyCodingTable = 1 + } + , JpgScanSpecification { componentSelector = 3 + , dcEntropyCodingTable = 1 + , acEntropyCodingTable = 1 + } + ] + + , spectralSelection = (0, 63) + , successiveApproxHigh = 0 + , successiveApproxLow = 0 + } + + hdr = hdr' { jpgFrameHeaderLength = fromIntegral $ calculateSize hdr' } + hdr' = (JpgFrameHeader{ jpgFrameHeaderLength = 0 + , jpgSamplePrecision = 8 + , jpgHeight = fromIntegral h + , jpgWidth = fromIntegral w + , jpgImageComponentCount = outputComponentCount + , jpgComponents = [ + JpgComponent { componentIdentifier = 1 + , horizontalSamplingFactor = 2 + , verticalSamplingFactor = 2 + , quantizationTableDest = 0 + } + , JpgComponent { componentIdentifier = 2 + , horizontalSamplingFactor = 1 + , verticalSamplingFactor = 1 + , quantizationTableDest = 1 + } + , JpgComponent { componentIdentifier = 3 + , horizontalSamplingFactor = 1 + , verticalSamplingFactor = 1 + , quantizationTableDest = 1 + } + ] + }) + + lumaQuant = scaleQuantisationMatrix (fromIntegral quality) + defaultLumaQuantizationTable + chromaQuant = scaleQuantisationMatrix (fromIntegral quality) + defaultChromaQuantizationTable + + zigzagedLumaQuant = zigZagReorderForwardv $ lumaQuant + zigzagedChromaQuant = zigZagReorderForwardv $ chromaQuant + quantTables = [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0 + , quantTable = zigzagedLumaQuant } + , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1 + , quantTable = zigzagedChromaQuant } + ] + + encodedImage = runST toExtract + toExtract = runBoolWriter $ do + let horizontalMetaBlockCount = w `divUpward` (8 * maxSampling) + verticalMetaBlockCount = h `divUpward` (8 * maxSampling) + maxSampling = 2 + lumaSamplingSize = ( maxSampling, maxSampling, zigzagedLumaQuant + , makeInverseTable defaultDcLumaHuffmanTree + , makeInverseTable defaultAcLumaHuffmanTree) + chromaSamplingSize = ( maxSampling - 1, maxSampling - 1, zigzagedChromaQuant + , makeInverseTable defaultDcChromaHuffmanTree + , makeInverseTable defaultAcChromaHuffmanTree) + componentDef = [lumaSamplingSize, chromaSamplingSize, chromaSamplingSize] + + imageComponentCount = length componentDef + block <- lift $ M.replicate 64 0 + dc_table <- lift $ M.replicate 3 0 + let blockList = [(comp, table, dc, ac, extractBlock img block xSamplingFactor ySamplingFactor + imageComponentCount comp blockX blockY) + | my <- [0 .. verticalMetaBlockCount - 1] + , mx <- [0 .. horizontalMetaBlockCount - 1] + , (comp, (sizeX, sizeY, table, dc, ac)) <- zip [0..] componentDef + , subY <- [0 .. sizeY - 1] + , subX <- [0 .. sizeX - 1] + , let blockX = mx * sizeX + subX + blockY = my * sizeY + subY + xSamplingFactor = maxSampling - sizeX + 1 + ySamplingFactor = maxSampling - sizeY + 1 + ] + + workData <- lift $ createEmptyMutableMacroBlock + zigzaged <- lift $ createEmptyMutableMacroBlock + forM_ blockList $ \(comp, table, dc, ac, extractor) -> do + prev_dc <- lift $ dc_table .!!!. comp + (dc_coeff, neo_block) <- lift (extractor >>= + encodeMacroBlock table workData zigzaged prev_dc) + lift . (dc_table .<-. comp) $ fromIntegral dc_coeff + serializeMacroBlock dc ac neo_block
Codec/Picture/Jpg/DefaultTable.hs view
@@ -4,22 +4,38 @@ -- in user code. module Codec.Picture.Jpg.DefaultTable( DctComponent( .. ) , HuffmanTree( .. ) + , HuffmanTable , MacroBlock + , QuantificationTable + , HuffmanWriterCode + , scaleQuantisationMatrix , makeMacroBlock + , makeInverseTable , buildHuffmanTree - {- + , defaultChromaQuantizationTable + , defaultLumaQuantizationTable + + , defaultAcChromaHuffmanTree , defaultAcChromaHuffmanTable + + , defaultAcLumaHuffmanTree , defaultAcLumaHuffmanTable + + , defaultDcChromaHuffmanTree , defaultDcChromaHuffmanTable + + , defaultDcLumaHuffmanTree , defaultDcLumaHuffmanTable - -} ) where import Foreign.Storable ( Storable ) -import qualified Data.Vector.Storable as V -import Data.Word( Word8 ) +import qualified Data.Vector.Storable as SV +import qualified Data.Vector as V +import Data.Bits( shiftL, (.|.) ) +import Data.Int( Int16 ) +import Data.Word( Word8, Word16 ) import Data.List( foldl' ) -- | Tree storing the code used for huffman encoding. @@ -28,14 +44,26 @@ | Empty -- ^ no value present deriving (Eq, Show) +type HuffmanWriterCode = V.Vector (Word8, Word16) + +makeInverseTable :: HuffmanTree -> HuffmanWriterCode +makeInverseTable t = V.replicate 255 (0,0) V.// inner 0 0 t + where inner _ _ Empty = [] + inner depth code (Leaf v) = [(fromIntegral v, (depth, code))] + inner depth code (Branch l r) = + inner (depth + 1) shifted l ++ inner (depth + 1) (shifted .|. 1) r + where shifted = code `shiftL` 1 + -- | Represent a compact array of 8 * 8 values. The size -- is not guarenteed by type system, but if makeMacroBlock is -- used, everything should be fine size-wise -type MacroBlock a = V.Vector a +type MacroBlock a = SV.Vector a +type QuantificationTable = MacroBlock Int16 + -- | Helper function to create pure macro block of the good size. makeMacroBlock :: (Storable a) => [a] -> MacroBlock a -makeMacroBlock = V.fromListN 64 +makeMacroBlock = SV.fromListN 64 -- | Enumeration used to search in the tables for different components. data DctComponent = DcComponent | AcComponent @@ -58,8 +86,17 @@ | otherwise = Branch (insertHuffmanVal l (d - 1, val)) r insertHuffmanVal (Leaf _) _ = error "Inserting in value, shouldn't happen" -{- -defaultLumaQuantizationTable :: MacroBlock Int16 +scaleQuantisationMatrix :: Int -> QuantificationTable -> QuantificationTable +scaleQuantisationMatrix quality + | quality < 50 = let qq = 5000 `div` quality + in SV.map (scale qq) + | otherwise = SV.map (scale q) + where q = 200 - quality * 2 + scale coeff i = fromIntegral . min 255 + . max 1 + $ fromIntegral i * coeff `div` 100 + +defaultLumaQuantizationTable :: QuantificationTable defaultLumaQuantizationTable = makeMacroBlock [16, 11, 10, 16, 24, 40, 51, 61 ,12, 12, 14, 19, 26, 58, 60, 55 @@ -71,7 +108,7 @@ ,72, 92, 95, 98, 112, 100, 103, 99 ] -defaultChromaQuantizationTable :: MacroBlock Int16 +defaultChromaQuantizationTable :: QuantificationTable defaultChromaQuantizationTable = makeMacroBlock [17, 18, 24, 47, 99, 99, 99, 99 ,18, 21, 26, 66, 99, 99, 99, 99 @@ -82,9 +119,13 @@ ,99, 99, 99, 99, 99, 99, 99, 99 ,99, 99, 99, 99, 99, 99, 99, 99 ] + +defaultDcLumaHuffmanTree :: HuffmanTree +defaultDcLumaHuffmanTree = buildHuffmanTree defaultDcLumaHuffmanTable + -- | From the Table K.3 of ITU-81 (p153) -defaultDcLumaHuffmanTable :: HuffmanTree -defaultDcLumaHuffmanTable = buildHuffmanTree +defaultDcLumaHuffmanTable :: HuffmanTable +defaultDcLumaHuffmanTable = [ [] , [0] , [1, 2, 3, 4, 5] @@ -103,9 +144,12 @@ , [] ] +defaultDcChromaHuffmanTree :: HuffmanTree +defaultDcChromaHuffmanTree = buildHuffmanTree defaultDcChromaHuffmanTable + -- | From the Table K.4 of ITU-81 (p153) -defaultDcChromaHuffmanTable :: HuffmanTree -defaultDcChromaHuffmanTable = buildHuffmanTree +defaultDcChromaHuffmanTable :: HuffmanTable +defaultDcChromaHuffmanTable = [ [] , [0, 1, 2] , [3] @@ -124,9 +168,12 @@ , [] ] +defaultAcLumaHuffmanTree :: HuffmanTree +defaultAcLumaHuffmanTree = buildHuffmanTree defaultAcLumaHuffmanTable + -- | From the Table K.5 of ITU-81 (p154) -defaultAcLumaHuffmanTable :: HuffmanTree -defaultAcLumaHuffmanTable = buildHuffmanTree +defaultAcLumaHuffmanTable :: HuffmanTable +defaultAcLumaHuffmanTable = [ [] , [0x01, 0x02] , [0x03] @@ -153,8 +200,13 @@ ,0xF6, 0xF7, 0xF8, 0xF9, 0xFA] ] -defaultAcChromaHuffmanTable :: HuffmanTree -defaultAcChromaHuffmanTable = buildHuffmanTree +type HuffmanTable = [[Word8]] + +defaultAcChromaHuffmanTree :: HuffmanTree +defaultAcChromaHuffmanTree = buildHuffmanTree defaultAcChromaHuffmanTable + +defaultAcChromaHuffmanTable :: HuffmanTable +defaultAcChromaHuffmanTable = [ [] , [0x00, 0x01] , [0x02] @@ -184,4 +236,4 @@ , 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA ] ] --} +
+ Codec/Picture/Jpg/FastDct.hs view
@@ -0,0 +1,209 @@+module Codec.Picture.Jpg.FastDct( referenceDct, fastDctLibJpeg ) where++import Control.Applicative( (<$>) )+import Data.Int( Int16, Int32 )+import Data.Bits( Bits, shiftR, shiftL )+import Control.Monad.ST( ST )++import qualified Data.Vector.Storable.Mutable as M++import Codec.Picture.Jpg.Types+import Control.Monad( forM, forM_ )++{-# INLINE (.>>.) #-}+{-# INLINE (.<<.) #-}+(.>>.), (.<<.) :: (Bits a) => a -> Int -> a+(.>>.) = shiftR+(.<<.) = shiftL++-- | Reference implementation of the DCT, directly implementing the formula+-- of ITU-81. It's slow as hell, perform to many operations, but is accurate+-- and a good reference point.+referenceDct :: MutableMacroBlock s Int32+ -> MutableMacroBlock s Int16+ -> ST s (MutableMacroBlock s Int32)+referenceDct workData block = forM_ [(u, v) | u <- [0 :: Int .. 7], v <- [0..7]] (\(u,v) -> do+ val <- at (u,v)+ (workData .<-. (v * 8 + u)) . truncate $ (1 / 4) * c u * c v * val)+ >> return workData+ where -- at :: (Int, Int) -> ST s Float+ at (u,v) = sum <$> (forM [(x,y) | x <- [0..7], y <- [0..7 :: Int]] $ \(x,y) -> do+ sample <- fromIntegral <$> (block .!!!. (y * 8 + x))+ return $ sample * cos ((2 * fromIntegral x + 1) * fromIntegral u * (pi :: Float)/ 16) + * cos ((2 * fromIntegral y + 1) * fromIntegral v * pi / 16))+ c 0 = 1 / sqrt 2+ c _ = 1++pASS1_BITS, cONST_BITS :: Int+cONST_BITS = 13+pASS1_BITS = 2+++fIX_0_298631336, fIX_0_390180644, fIX_0_541196100,+ fIX_0_765366865, fIX_0_899976223, fIX_1_175875602,+ fIX_1_501321110, fIX_1_847759065, fIX_1_961570560,+ fIX_2_053119869, fIX_2_562915447, fIX_3_072711026 :: Int32+fIX_0_298631336 =(2446) -- FIX(0.298631336) */+fIX_0_390180644 =(3196) -- FIX(0.390180644) */+fIX_0_541196100 =(4433) -- FIX(0.541196100) */+fIX_0_765366865 =(6270) -- FIX(0.765366865) */+fIX_0_899976223 =(7373) -- FIX(0.899976223) */+fIX_1_175875602 =(9633) -- FIX(1.175875602) */+fIX_1_501321110 =(12299) -- FIX(1.501321110) */+fIX_1_847759065 =(15137) -- FIX(1.847759065) */+fIX_1_961570560 =(16069) -- FIX(1.961570560) */+fIX_2_053119869 =(16819) -- FIX(2.053119869) */+fIX_2_562915447 =(20995) -- FIX(2.562915447) */+fIX_3_072711026 =(25172) -- FIX(3.072711026) */++cENTERJSAMPLE :: Int32+cENTERJSAMPLE = 128++-- | Fast DCT extracted from libjpeg+fastDctLibJpeg :: MutableMacroBlock s Int32+ -> MutableMacroBlock s Int16+ -> ST s (MutableMacroBlock s Int32)+fastDctLibJpeg workData sample_block = do+ firstPass workData 0+ secondPass workData 7+ {-_ <- mutate (\_ a -> a `quot` 8) workData-}+ return workData+ where -- Pass 1: process rows.+ -- Note results are scaled up by sqrt(8) compared to a true DCT;+ -- furthermore, we scale the results by 2**PASS1_BITS.+ firstPass _ 8 = return ()+ firstPass dataBlock i = do+ let baseIdx = i * 8+ readAt idx = fromIntegral <$> sample_block .!!!. (baseIdx + idx)+ mult = (*)+ writeAt idx n = (dataBlock .<-. (baseIdx + idx)) n+ writeAtPos idx n = (dataBlock .<-. (baseIdx + idx))+ (n .>>. (cONST_BITS - pASS1_BITS))++ blk0 <- readAt 0+ blk1 <- readAt 1+ blk2 <- readAt 2+ blk3 <- readAt 3+ blk4 <- readAt 4+ blk5 <- readAt 5+ blk6 <- readAt 6+ blk7 <- readAt 7++ let tmp0 = blk0 + blk7+ tmp1 = blk1 + blk6+ tmp2 = blk2 + blk5+ tmp3 = blk3 + blk4++ tmp10 = tmp0 + tmp3+ tmp12 = tmp0 - tmp3+ tmp11 = tmp1 + tmp2+ tmp13 = tmp1 - tmp2++ tmp0' = blk0 - blk7+ tmp1' = blk1 - blk6+ tmp2' = blk2 - blk5+ tmp3' = blk3 - blk4++ -- Stage 4 and output+ writeAt 0 $ (tmp10 + tmp11 - 8 * cENTERJSAMPLE) .<<. pASS1_BITS+ writeAt 4 $ (tmp10 - tmp11) .<<. pASS1_BITS++ let z1 = mult (tmp12 + tmp13) fIX_0_541196100+ + (1 .<<. (cONST_BITS - pASS1_BITS - 1))++ writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865+ writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065++ let tmp10' = tmp0' + tmp3'+ tmp11' = tmp1' + tmp2'+ tmp12' = tmp0' + tmp2'+ tmp13' = tmp1' + tmp3'+ z1' = mult (tmp12' + tmp13') fIX_1_175875602 -- c3 */+ -- Add fudge factor here for final descale. */+ + (1 .<<. (cONST_BITS - pASS1_BITS-1))+ tmp0'' = mult tmp0' fIX_1_501321110+ tmp1'' = mult tmp1' fIX_3_072711026+ tmp2'' = mult tmp2' fIX_2_053119869+ tmp3'' = mult tmp3' fIX_0_298631336++ tmp10'' = mult tmp10' (- fIX_0_899976223)+ tmp11'' = mult tmp11' (- fIX_2_562915447)+ tmp12'' = mult tmp12' (- fIX_0_390180644) + z1'+ tmp13'' = mult tmp13' (- fIX_1_961570560) + z1'++ writeAtPos 1 $ tmp0'' + tmp10'' + tmp12''+ writeAtPos 3 $ tmp1'' + tmp11'' + tmp13''+ writeAtPos 5 $ tmp2'' + tmp11'' + tmp12''+ writeAtPos 7 $ tmp3'' + tmp10'' + tmp13''++ firstPass dataBlock $ i + 1++ -- Pass 2: process columns.+ -- We remove the PASS1_BITS scaling, but leave the results scaled up+ -- by an overall factor of 8.+ secondPass :: M.STVector s Int32 -> Int -> ST s ()+ secondPass _ (-1) = return ()+ secondPass block i = do+ let readAt idx = block .!!!. ((7 - i) + idx * 8)+ mult = (*)+ writeAt idx n = (block .<-. (8 * idx + (7 - i))) n+ writeAtPos idx n = (block .<-. (8 * idx + (7 - i))) $ n .>>. (cONST_BITS + pASS1_BITS + 3)+ blk0 <- readAt 0+ blk1 <- readAt 1+ blk2 <- readAt 2+ blk3 <- readAt 3+ blk4 <- readAt 4+ blk5 <- readAt 5+ blk6 <- readAt 6+ blk7 <- readAt 7++ let tmp0 = blk0 + blk7+ tmp1 = blk1 + blk6+ tmp2 = blk2 + blk5+ tmp3 = blk3 + blk4++ -- Add fudge factor here for final descale. */+ tmp10 = tmp0 + tmp3 + (1 .<<. (pASS1_BITS-1))+ tmp12 = tmp0 - tmp3+ tmp11 = tmp1 + tmp2+ tmp13 = tmp1 - tmp2++ tmp0' = blk0 - blk7+ tmp1' = blk1 - blk6+ tmp2' = blk2 - blk5+ tmp3' = blk3 - blk4++ writeAt 0 $ (tmp10 + tmp11) .>>. (pASS1_BITS + 3)+ writeAt 4 $ (tmp10 - tmp11) .>>. (pASS1_BITS + 3)++ let z1 = mult (tmp12 + tmp13) fIX_0_541196100+ + (1 .<<. (cONST_BITS + pASS1_BITS - 1))++ writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865+ writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065++ let tmp10' = tmp0' + tmp3'+ tmp11' = tmp1' + tmp2'+ tmp12' = tmp0' + tmp2'+ tmp13' = tmp1' + tmp3'++ z1' = mult (tmp12' + tmp13') fIX_1_175875602+ -- Add fudge factor here for final descale. */+ + 1 .<<. (cONST_BITS+pASS1_BITS-1);++ tmp0'' = mult tmp0' fIX_1_501321110+ tmp1'' = mult tmp1' fIX_3_072711026+ tmp2'' = mult tmp2' fIX_2_053119869+ tmp3'' = mult tmp3' fIX_0_298631336+ tmp10'' = mult tmp10' (- fIX_0_899976223)+ tmp11'' = mult tmp11' (- fIX_2_562915447)+ tmp12'' = mult tmp12' (- fIX_0_390180644)+ + z1'+ tmp13'' = mult tmp13' (- fIX_1_961570560)+ + z1'+ writeAtPos 1 $ tmp0'' + tmp10'' + tmp12''+ writeAtPos 3 $ tmp1'' + tmp11'' + tmp13''+ writeAtPos 5 $ tmp2'' + tmp11'' + tmp12''+ writeAtPos 7 $ tmp3'' + tmp10'' + tmp13''++ secondPass block (i - 1)
Codec/Picture/Jpg/FastIdct.hs view
@@ -19,21 +19,12 @@ ) where import qualified Data.Vector.Storable as V -import qualified Data.Vector.Storable.Mutable as M import Control.Monad( forM_ ) import Control.Monad.ST( ST ) -import Control.Monad.Primitive ( PrimMonad, PrimState) import Data.Bits( shiftL, shiftR ) import Data.Int( Int16 ) -import Foreign.Storable ( Storable ) -{- -{-# INLINE iclip #-} -iclip :: Int -> Int16 -iclip i | fromIntegral i < (-256) = -256 - | fromIntegral i > 256 = 256 - | otherwise = fromIntegral i --} +import Codec.Picture.Jpg.Types iclip :: V.Vector Int16 iclip = V.fromListN 1024 [ val i| i <- [(-512) .. 511] ] @@ -41,6 +32,14 @@ | i > 255 = 255 | otherwise = i +{-# INLINE clip #-} +clip :: Int -> Int16 +clip i -- = iclip !!! (i + 512) + | i < 511 = if i > -512 then iclip !!! (i + 512) + else iclip !!! 0 + + | otherwise = iclip !!! 1023 + {-# INLINE (.<<.) #-} {-# INLINE (.>>.) #-} (.<<.), (.>>.) :: Int -> Int -> Int @@ -67,27 +66,6 @@ w6 = 1108 -- 2048*sqrt(2)*cos(6*pi/16) w7 = 565 -- 2048*sqrt(2)*cos(7*pi/16) - -{-# INLINE (!!!) #-} -(!!!) :: (Storable e) => V.Vector e -> Int -> e -(!!!) a i = V.unsafeIndex a (i + 512) - -{-# INLINE (.!!!.) #-} -(.!!!.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> m a -(.!!!.) = M.unsafeRead - -{-# INLINE (.<-.) #-} -(.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m () -(.<-.) = M.unsafeWrite - --- | Macroblock that can be transformed. -type MutableMacroBlock s a = M.STVector s a - -{-# INLINE createEmptyMutableMacroBlock #-} --- | Create a new macroblock with the good array size -createEmptyMutableMacroBlock :: ST s (MutableMacroBlock s Int16) -createEmptyMutableMacroBlock = M.replicate 64 0 - -- row (horizontal) IDCT -- -- 7 pi 1 @@ -224,14 +202,14 @@ } f = thirdStage . secondStage $ firstStage initialState - (blk .<-. (idx + 8*0)) $ iclip !!! ((x7 f + x1 f) .>>. 14) - (blk .<-. (idx + 8 )) $ iclip !!! ((x3 f + x2 f) .>>. 14) - (blk .<-. (idx + 8*2)) $ iclip !!! ((x0 f + x4 f) .>>. 14) - (blk .<-. (idx + 8*3)) $ iclip !!! ((x8 f + x6 f) .>>. 14) - (blk .<-. (idx + 8*4)) $ iclip !!! ((x8 f - x6 f) .>>. 14) - (blk .<-. (idx + 8*5)) $ iclip !!! ((x0 f - x4 f) .>>. 14) - (blk .<-. (idx + 8*6)) $ iclip !!! ((x3 f - x2 f) .>>. 14) - (blk .<-. (idx + 8*7)) $ iclip !!! ((x7 f - x1 f) .>>. 14) + (blk .<-. (idx + 8*0)) . clip $ (x7 f + x1 f) .>>. 14 + (blk .<-. (idx + 8 )) . clip $ (x3 f + x2 f) .>>. 14 + (blk .<-. (idx + 8*2)) . clip $ (x0 f + x4 f) .>>. 14 + (blk .<-. (idx + 8*3)) . clip $ (x8 f + x6 f) .>>. 14 + (blk .<-. (idx + 8*4)) . clip $ (x8 f - x6 f) .>>. 14 + (blk .<-. (idx + 8*5)) . clip $ (x0 f - x4 f) .>>. 14 + (blk .<-. (idx + 8*6)) . clip $ (x3 f - x2 f) .>>. 14 + (blk .<-. (idx + 8*7)) . clip $ (x7 f - x1 f) .>>. 14 {-# INLINE fastIdct #-} @@ -248,9 +226,5 @@ -- | Perform a Jpeg level shift in a mutable fashion. mutableLevelShift :: MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16) -mutableLevelShift block = do - forM_ [0..63] (\i -> do - v <- block .!!!. i - (block .<-. i) $ v + 128) - return block +mutableLevelShift = mutate (\_ v -> v + 128)
+ Codec/Picture/Jpg/Types.hs view
@@ -0,0 +1,61 @@+module Codec.Picture.Jpg.Types( MutableMacroBlock+ , createEmptyMutableMacroBlock+ , mutate+ , printMacroBlock+ , (!!!), (.!!!.), (.<-.)+ ) where++import Control.Monad.ST( ST )+import Foreign.Storable ( Storable )+import Control.Monad.Primitive ( PrimState, PrimMonad )+import qualified Data.Vector.Storable as V+import qualified Data.Vector.Storable.Mutable as M+-- import Data.Vector.Storable( (!) )++import Text.Printf++{-# INLINE (!!!) #-}+(!!!) :: (Storable e) => V.Vector e -> Int -> e+(!!!) = -- (!) + V.unsafeIndex++{-# INLINE (.!!!.) #-}+(.!!!.) :: (PrimMonad m, Storable a)+ => M.STVector (PrimState m) a -> Int -> m a+(.!!!.) = -- M.read+ M.unsafeRead++{-# INLINE (.<-.) #-}+(.<-.) :: (PrimMonad m, Storable a)+ => M.STVector (PrimState m) a -> Int -> a -> m ()+(.<-.) = -- M.write + M.unsafeWrite++-- | Macroblock that can be transformed.+type MutableMacroBlock s a = M.STVector s a++{-# INLINE createEmptyMutableMacroBlock #-}+-- | Create a new macroblock with the good array size+createEmptyMutableMacroBlock :: (Storable a, Num a) => ST s (MutableMacroBlock s a)+createEmptyMutableMacroBlock = M.replicate 64 0++{-# INLINE mutate #-}+-- | Return the transformed block+mutate :: Storable a+ => (Int -> a -> a) -- ^ The updating function+ -> MutableMacroBlock s a -> ST s (MutableMacroBlock s a)+mutate f block = update 0 >> return block+ where updateVal i = (block .!!!. i) >>= (block .<-. i) . f i++ update 63 = updateVal 63+ update n = updateVal n >> update (n + 1)++printMacroBlock :: (Storable a, PrintfArg a)+ => MutableMacroBlock s a -> ST s String+printMacroBlock block = pLn 0+ where pLn 64 = return "===============================\n"+ pLn i = do+ v <- block .!!!. i+ vn <- pLn (i+1)+ return $ printf (if i `mod` 8 == 0 then "\n%5d " else "%5d ") v ++ vn+
Codec/Picture/Png.hs view
@@ -11,7 +11,6 @@ module Codec.Picture.Png( -- * High level functions PngSavable( .. ) - , readPng , decodePng , writePng , encodeDynamicPng @@ -19,7 +18,7 @@ ) where -import Control.Monad( foldM_, forM_, when, liftM ) +import Control.Monad( foldM_, forM_, when ) import Control.Monad.ST( ST, runST ) import Control.Monad.Trans( lift ) import Control.Monad.Primitive ( PrimState, PrimMonad ) @@ -398,10 +397,6 @@ where (_, initSize) = bounds img pixels = concat [[r, g, b] | ipx <- V.toList img , let PixelRGB8 r g b = pal !!! fromIntegral ipx] - --- | Helper function trying to load a png file from a file on disk. -readPng :: FilePath -> IO (Either String DynamicImage) -readPng path = liftM decodePng (B.readFile path) -- | Transform a raw png image to an image, without modifying the -- underlying pixel type. If the image is greyscale and < 8 bits,
Codec/Picture/Types.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FunctionalDependencies #-} -- | Module providing the basic types for image manipulation in the library. -- Defining the types used to store all those _Juicy Pixels_ module Codec.Picture.Types( -- * Types @@ -21,11 +22,20 @@ , ColorConvertible( .. ) , Pixel(..) , ColorSpaceConvertible( .. ) + , LumaPlaneExtractable( .. ) + , TransparentPixel( .. ) + -- * Helper functions , canConvertTo + , extractComponent + , pixelMap + , dropAlphaLayer + , generateImage ) where +import Control.Monad( forM_ ) import Control.Applicative( (<$>), (<*>) ) +import Control.DeepSeq( NFData( .. ) ) import Control.Monad.ST( ST, runST ) import Control.Monad.Primitive ( PrimMonad, PrimState ) import Foreign.Storable ( Storable, sizeOf, alignment, peek, poke ) @@ -51,6 +61,61 @@ , imageData :: V.Vector Word8 } +{-# INLINE (!!!) #-} +(!!!) :: (Storable e) => V.Vector e -> Int -> e +(!!!) = V.unsafeIndex + +-- | Extract an image plane of an image, returning an image which +-- can be represented by a gray scale image. +extractComponent :: forall a. (Pixel a) + => Int -- ^ The component index, beginning at 0 ending at (componentCount - 1) + -> Image a -- ^ Source image + -> Image Pixel8 +extractComponent comp img@(Image { imageWidth = w, imageHeight = h }) = + Image { imageWidth = w, imageHeight = h, imageData = plane } + where plane = stride img 1 padd comp + padd = componentCount (undefined :: a) - 1 + +-- | For any image with an alpha component (transparency), +-- drop it, returning a pure opaque image. +dropAlphaLayer :: (TransparentPixel a b) => Image a -> Image b +dropAlphaLayer = pixelMap dropTransparency + +-- | Class modeling transparent pixel, should provide a method +-- to combine transparent pixels +class (Pixel a, Pixel b) => TransparentPixel a b | a -> b where + -- | Just return the opaque pixel value + dropTransparency :: a -> b + +instance TransparentPixel PixelYA8 Pixel8 where + {-# INLINE dropTransparency #-} + dropTransparency (PixelYA8 y _) = y + +instance TransparentPixel PixelRGBA8 PixelRGB8 where + {-# INLINE dropTransparency #-} + dropTransparency (PixelRGBA8 r g b _) = PixelRGB8 r g b + +stride :: Image a -> Int -> Int -> Int -> V.Vector Word8 +stride Image { imageWidth = w, imageHeight = h, imageData = array } + run padd firstComponent = runST $ do + let cell_count = w * h * run + outArray <- M.new cell_count + + let strideWrite write_idx _ | write_idx == cell_count = return () + strideWrite write_idx read_idx = do + forM_ [0 .. run - 1] $ \i -> + (outArray .<-. (write_idx + i)) $ array !!! (read_idx + i) + strideWrite (write_idx + run) (read_idx + padd) + + strideWrite 0 firstComponent + V.unsafeFreeze outArray + +instance NFData (Image a) where + rnf (Image width height dat) = width `seq` + height `seq` + dat `seq` + () + -- | Image or pixel buffer, the coordinates are assumed to start -- from the upper-left corner of the image, with the horizontal -- position first, then the vertical one. The image can be transformed in place. @@ -66,6 +131,12 @@ , mutableImageData :: M.STVector s Word8 } +instance NFData (MutableImage s a) where + rnf (MutableImage width height dat) = width `seq` + height `seq` + dat `seq` + () + -- | Type allowing the loading of an image with different pixel -- structures data DynamicImage = @@ -80,6 +151,13 @@ -- | An image in the colorspace used by Jpeg images. | ImageYCbCr8 (Image PixelYCbCr8) +instance NFData DynamicImage where + rnf (ImageY8 img) = rnf img + rnf (ImageYA8 img) = rnf img + rnf (ImageRGB8 img) = rnf img + rnf (ImageRGBA8 img) = rnf img + rnf (ImageYCbCr8 img) = rnf img + -- | Simple alias for greyscale value in 8 bits. type Pixel8 = Word8 @@ -129,7 +207,8 @@ -- -- * Blue -- --- * Alpha +-- * Alpha +-- data PixelRGBA8 = PixelRGBA8 {-# UNPACK #-} !Word8 -- Red {-# UNPACK #-} !Word8 -- Green {-# UNPACK #-} !Word8 -- Blue @@ -321,40 +400,97 @@ -- | Change the underlying pixel type of an image by performing a full copy -- of it. promoteImage :: Image a -> Image b - promoteImage image@(Image { imageWidth = w, imageHeight = h }) = - Image w h pixels - where pixels = runST $ do - newArr <- M.replicate (w * h * componentCount (undefined :: b)) 0 - let wrapped = MutableImage w h newArr - promotedPixel :: Int -> Int -> b - promotedPixel x y = promotePixel $ pixelAt image x y - sequence_ [writePixel wrapped x y $ promotedPixel x y - | y <- [0 .. h - 1], x <- [0 .. w - 1] ] - -- unsafeFreeze avoids making a second copy and it will be - -- safe because newArray can't be referenced as a mutable array - -- outside of this where block - V.unsafeFreeze newArr + promoteImage = pixelMap promotePixel -- | This class abstract colorspace conversion. This -- conversion can be lossy, which ColorConvertible cannot class (Pixel a, Pixel b) => ColorSpaceConvertible a b where + -- | Pass a pixel from a colorspace (say RGB) to the second one + -- (say YCbCr) convertPixel :: a -> b + -- | Helper function to convert a whole image by taking a + -- copy it. convertImage :: Image a -> Image b - convertImage image@(Image { imageWidth = w, imageHeight = h }) = - Image w h pixels - where pixels = runST $ do - newArr <- M.replicate (w * h * componentCount (undefined :: b)) 0 - let wrapped = MutableImage w h newArr - promotedPixel :: Int -> Int -> b - promotedPixel x y = convertPixel $ pixelAt image x y - sequence_ [writePixel wrapped x y $ promotedPixel x y - | y <- [0 .. h - 1], x <- [0 .. w - 1] ] - -- unsafeFreeze avoids making a second copy and it will be - -- safe because newArray can't be referenced as a mutable array - -- outside of this where block - V.unsafeFreeze newArr + convertImage = pixelMap convertPixel +-- | Create an image given a function to generate pixels. +-- The function will receive value from 0 to width-1 for the x parameter +-- and 0 to height-1 for the y parameter. The coordinate 0,0 is the upper +-- left corner of the image, and (width-1, height-1) the lower right corner. +generateImage :: forall a. (Pixel a) + => (Int -> Int -> a) -- ^ Generating function, with `x` and `y` params. + -> Int -- ^ Width in pixels + -> Int -- ^ Height in pixels + -> Image a +generateImage f w h = Image { imageWidth = w, imageHeight = h, imageData = generated } + where compCount = componentCount (undefined :: a) + generated = runST $ do + arr <- M.new (w * h * compCount) + let mutImage = MutableImage { + mutableImageWidth = w, + mutableImageHeight = h, + mutableImageData = arr } + forM_ [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]] $ \(x,y) -> + writePixel mutImage x y $ f x y + V.unsafeFreeze arr + +{-# INLINE pixelMap #-} +-- | `map` equivalent for an image, working at the pixel level. +pixelMap :: forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b +pixelMap f image@(Image { imageWidth = w, imageHeight = h }) = + Image w h pixels + where pixels = runST $ do + newArr <- M.replicate (w * h * componentCount (undefined :: b)) 0 + let wrapped = MutableImage w h newArr + promotedPixel :: Int -> Int -> b + promotedPixel x y = f $ pixelAt image x y + sequence_ [writePixel wrapped x y $ promotedPixel x y + | y <- [0 .. h - 1], x <- [0 .. w - 1] ] + -- unsafeFreeze avoids making a second copy and it will be + -- safe because newArray can't be referenced as a mutable array + -- outside of this where block + V.unsafeFreeze newArr + +-- | Helper class to help extract a luma plane out +-- of an image or a pixel +class (Pixel a) => LumaPlaneExtractable a where + -- | Compute the luminance part of a pixel + computeLuma :: a -> Pixel8 + + -- | Extract a luma plane out of an image. This + -- method is in the typeclass to help performant + -- implementation. + extractLumaPlane :: Image a -> Image Pixel8 + extractLumaPlane = pixelMap computeLuma + +instance LumaPlaneExtractable Pixel8 where + {-# INLINE computeLuma #-} + computeLuma = id + extractLumaPlane = id + +instance LumaPlaneExtractable PixelRGB8 where + {-# INLINE computeLuma #-} + computeLuma (PixelRGB8 r g b) = floor $ 0.3 * (toRational r) + + 0.59 * (toRational g) + + 0.11 * (toRational b) + +instance LumaPlaneExtractable PixelRGBA8 where + {-# INLINE computeLuma #-} + computeLuma (PixelRGBA8 r g b _) = floor $ 0.3 * (toRational r) + + 0.59 * (toRational g) + + 0.11 * (toRational b) + +instance LumaPlaneExtractable PixelYA8 where + {-# INLINE computeLuma #-} + computeLuma (PixelYA8 y _) = y + extractLumaPlane = extractComponent 0 + +instance LumaPlaneExtractable PixelYCbCr8 where + {-# INLINE computeLuma #-} + computeLuma (PixelYCbCr8 y _ _) = y + extractLumaPlane = extractComponent 0 + -- | Free promotion for identic pixel types instance (Pixel a) => ColorConvertible a a where {-# INLINE promotePixel #-} @@ -519,6 +655,24 @@ (arr .<-. (baseIdx + 0)) yv (arr .<-. (baseIdx + 1)) cbv (arr .<-. (baseIdx + 2)) crv + +instance (Pixel a) => ColorSpaceConvertible a a where + convertPixel = id + convertImage = id + +instance ColorSpaceConvertible PixelRGB8 PixelYCbCr8 where + {-# INLINE convertPixel #-} + convertPixel (PixelRGB8 r g b) = PixelYCbCr8 (truncate y) + (truncate cb) + (truncate cr) + where rf = fromIntegral r :: Float + gf = fromIntegral g + bf = fromIntegral b + + + y = 0.29900 * rf + 0.58700 * gf + 0.11400 * bf + cb = -0.16874 * rf - 0.33126 * gf + 0.50000 * bf + 128 + cr = 0.50000 * rf - 0.41869 * gf - 0.08131 * bf + 128 instance ColorSpaceConvertible PixelYCbCr8 PixelRGB8 where {-# INLINE convertPixel #-}
JuicyPixels.cabal view
@@ -1,10 +1,10 @@ Name: JuicyPixels -Version: 1.1 +Version: 1.2 Synopsis: Picture loading/serialization (in png, jpeg and bitmap) Description: This library can load and store images in various image formats, - for now mainly in PNG/Bitmap and Jpeg (jpeg writing not - implemented yet though) + for now mainly in PNG/Bitmap and Jpeg + homepage: https://github.com/Twinside/Juicy.Pixels License: BSD3 License-file: LICENSE @@ -16,7 +16,7 @@ -- Extra-source-files: -- Constraint on the version of Cabal needed to build this package. -Cabal-version: >=1.6 +Cabal-version: >= 1.10 Source-Repository head Type: git @@ -25,9 +25,10 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v1.1 + Tag: v1.2 Library + Default-Language: Haskell2010 Exposed-modules: Codec.Picture, Codec.Picture.Bitmap, Codec.Picture.Png, @@ -43,12 +44,16 @@ zlib >= 0.5.3.1, transformers >= 0.2.2 && < 0.3, vector >= 0.9 && < 1.0, - primitive >= 0.4 && < 0.5 + primitive >= 0.4 && < 0.5, + deepseq >= 1.1 && < 1.4 --- Modules not exported by this package. + -- Modules not exported by this package. Other-modules: Codec.Picture.Jpg.DefaultTable, Codec.Picture.Jpg.FastIdct, + Codec.Picture.Jpg.FastDct, + Codec.Picture.Jpg.Types, Codec.Picture.Png.Export, - Codec.Picture.Png.Type + Codec.Picture.Png.Type, + Codec.Picture.BitWriter