diff --git a/Codec/Picture.hs b/Codec/Picture.hs --- a/Codec/Picture.hs +++ b/Codec/Picture.hs @@ -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 + diff --git a/Codec/Picture/BitWriter.hs b/Codec/Picture/BitWriter.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/BitWriter.hs @@ -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 + diff --git a/Codec/Picture/Jpg.hs b/Codec/Picture/Jpg.hs --- a/Codec/Picture/Jpg.hs +++ b/Codec/Picture/Jpg.hs @@ -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 diff --git a/Codec/Picture/Jpg/DefaultTable.hs b/Codec/Picture/Jpg/DefaultTable.hs --- a/Codec/Picture/Jpg/DefaultTable.hs +++ b/Codec/Picture/Jpg/DefaultTable.hs @@ -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 ] ] --} + diff --git a/Codec/Picture/Jpg/FastDct.hs b/Codec/Picture/Jpg/FastDct.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Jpg/FastDct.hs @@ -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) diff --git a/Codec/Picture/Jpg/FastIdct.hs b/Codec/Picture/Jpg/FastIdct.hs --- a/Codec/Picture/Jpg/FastIdct.hs +++ b/Codec/Picture/Jpg/FastIdct.hs @@ -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) diff --git a/Codec/Picture/Jpg/Types.hs b/Codec/Picture/Jpg/Types.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Jpg/Types.hs @@ -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 + diff --git a/Codec/Picture/Png.hs b/Codec/Picture/Png.hs --- a/Codec/Picture/Png.hs +++ b/Codec/Picture/Png.hs @@ -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, diff --git a/Codec/Picture/Types.hs b/Codec/Picture/Types.hs --- a/Codec/Picture/Types.hs +++ b/Codec/Picture/Types.hs @@ -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 #-} diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -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